perm filename LEPRUN.GLB[UOR,AIL]1 blob sn#252305 filedate 1976-12-08 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00063 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00006 00002	HISTORY
C00015 00003	Leaping runtime routines.  Sept. 1972.
C00023 00004	DSCR FOREACH INTERPRETATION EXAMPLE
C00025 00005	VARIOUS DEFINITIONS OF BITS IN THE CONTROL WORD:
C00027 00006	DSCR USEFUL MACROS
C00030 00007	DSCR INTERLOCKS FOR LEAP GLOBAL MODEL
C00036 00008	DSCR LEAP ALLOCATION -- START OF PROGRAM.
C00040 00009		INTERNAL LPINI
C00047 00010
C00052 00011	NOLOCL:
C00057 00012	ALLOCATE INITIAL ITEM TYPES AND PNAMES
C00058 00013	DSCR MAIN DISPATCHER FOR LEAP
C00061 00014	DISPATCH TABLE FOR THE LEAP INTERPRETER.
C00067 00015	DSCR  ASSOCIATIVE SEARCH ROUTINES
C00069 00016	THE SEARCH ROUTINES.....
C00072 00017	 A XOR O EQV X
C00077 00018	 A XOR X EQV V
C00081 00019	 X XOR O EQV V
C00085 00020	 X XOR Y EQV V
C00089 00021	 A XOR X EQV Y
C00095 00022	URHASH <
C00102 00023
C00108 00024	 X  IN  S
C00110 00025	DSCR FORSET AND NOFOR -- MAKE A SEARCH CONTROL BLOCK
C00117 00026	DSCR  FOREACH STATEMENT INTERPRETER
C00124 00027	JRST TO DOAG, FRFAL
C00133 00028	DSCR FRPOP, CORPOP
C00135 00029	DSCR ? LOCAL STACK ROUTINES,STK4LC,STK4VL
C00138 00030	DSCR BNDTRP- BINDING FORM OF BOOLEAN A XOR O EQV V
C00142 00031	DSCR ISIT,BRITM
C00144 00032	DSCR DERIVED SETS -- NOT IN FOREACH SPECIFICATIONS.
C00146 00033	DSCR MAKE AND ERASE
C00157 00034	URLEAP	<
C00162 00035	URLEAP	<
C00168 00036	NOURLEAP	<
C00171 00037		SKIPA
C00174 00038	 LEAP BREAKPOINTS EXIST.  
C00178 00039	DSCR ISTRIPLE, SELECTOR
C00180 00040		JRST	ERR1		NO, ERROR	
C00181 00041	DSCR DELETE
C00192 00042	DSCR ARRRCL			RECLAIM ARRAY OF SETS,LISTS
C00194 00043	DSCR NEW (VARIOUS KINDS), AND ARRAY ITEM CODE.
C00199 00044	NEWART:		PUSHJ HERE FOR NEW WITH ARITHMETIC TYPE
C00203 00045	NEWARY:				JRST HERE
C00210 00046	DSCR SET AND ITEM STORING OPERATIONS.
C00217 00047	DSCR PUTIN REMOV
C00223 00048	DSCR  SIP ,LSTMAK
C00227 00049	DSCR STIN, LSTIN
C00230 00050	DSCR COUNT,UNIT,STLOP
C00232 00051	DSCR SETEST
C00235 00052	DSCR UNION, INTERSECTION, SUBTRACTION
C00242 00053	DSCR PUTAFTER,PUTBEFORE
C00248 00054	DSCR SET RECLAMATION ROUTINES.
C00250 00055	 TRANSFER FUNCTION SET← LIST
C00253 00056	DSCR RPLAC
C00255 00057	DSCR	TYPEX-to determine the type of an item
C00258 00058	DSCR TYPEIT -same as TYPEX except does not return datum address in left
C00262 00059	DSCR PUTXA,PUTXB
C00264 00060	DSCR INTNAM,CVSI,CVIS,DEL.PNAME,NEW.PNAME 
C00271 00061
C00277 00062	DSCR MATCHING PROCEDURE ROUTINES, CALMP,RESMP,SUCFA1
C00282 00063	NOGLOB <
C00283 ENDMK
C⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  102100000033  ⊗;


COMMENT ⊗
VERSION 17-1(28) 24-AUG-76 BY JES (@UOR) 18-BIT ITEM SPACE (URLEAP)
VERSION 17-1(27) 2-26-75 BY RHT BUG #UC# ERRORS IN REFITEM DELETION
VERSION 17-1(26) 9-22-74 BY rht BUG #TK# TYPO IN STK4LC
VERSION 17-1(25) 5-20-74 BY RHT BUG #SB# REFITM STACKS VALUE STRINGS NOW
VERSION 17-1(24) 4-17-74 
VERSION 17-1(23) 4-14-74 BY RHT BUG #RU# USER MAY NEED SETTING UP AT RECQQ
VERSION 17-1(22) 3-6-74 BY JRL BUG #RM# (CMU =B3=) FIX BY LDE FP1 LIST GLUBBED UP
VERSION 17-1(21) 3-6-74 
VERSION 17-1(20) 2-14-74 BY RHT BUG #RF# LSTMAK WAS MAKING BAGS INSTEAD
VERSION 17-1(19) 1-11-74 BY RHT MODIFY WAY GBRK IS DEFINED
VERSION 17-1(18) 1-11-74 
VERSION 17-1(17) 1-11-74 
VERSION 17-1(16) 12-9-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(15) 12-9-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(14) 11-18-73 BY JRL CHANGE PDLOF UUO CALLS TO JSP USER,$PDLOV
VERSION 17-1(13) 11-4-73 BY JRL BUG #OW# STATIC LINK IS ONLY IN RIGHT HALF OF STACK ENTRY
VERSION 17-1(12) 10-29-73 BY JRL MORE GRACEFUL EXIT WHEN SAME PNAME USED TWICE
VERSION 17-1(11) 10-24-73 BY JRL MUNGE THE LPINI LEAP INITIALIZER
VERSION 17-1(10) 10-23-73 BY JRL FEATURE %AG% ITEM OVERLAP STUFF
VERSION 17-1(9) 10-23-73 BY JRL FEATURE %AF% DIFFERENT BOOLEANS FOR SET LIST MEMBERSHIP
VERSION 17-1(8) 9-15-73 BY JRL BUG #OE# AVOID DRYROT WHEN DELETING DECLARED STRING ARRAY ITEM
VERSION 17-1(7) 9-4-73 BY JRL BUG #OA# REMOVE ALL DESTROYED FREE-STORAGE LIST
VERSION 17-1(6) 8-30-73 BY RHT BUG #NZ# TRAP DELETION OF RESERVED ITEM
VERSION 17-1(5) 8-30-73 
VERSION 17-1(4) 8-27-73 BY JRL BUG #NW# DRYROT WHEN DELETING STRING ARRAY ITEM
VERSION 17-1(3) 8-27-73 
VERSION 17-1(2) 8-16-73 BY JRL BUG #NS# SHOULD PICK UP NUMBER OF BUCKETS WITH HLRE NOT HLRZ
VERSION 17-1(1) 8-4-73 BY JRL BUG #NL# A XOR ANY EQV ANY BOOLEAN ALWAYS FAILED
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION 17 ****
VERSION 16-2(59) 7-22-73 BY JRL BUG #ND# DELETING LIST ARRAY ITEMS
VERSION 16-2(58) 5-6-73 
VERSION 16-2(57) 5-6-73 BY JRL ADD REFITM
VERSION 16-2(56) 5-6-73 
VERSION 16-2(55) 5-6-73 
VERSION 16-2(54) 5-6-73 
VERSION 16-2(53) 4-5-73 BY JRL BUG #LY# GLOBAL PROPS BEING DESTROYED
VERSION 16-2(52) 4-5-73 
VERSION 16-2(51) 4-2-73 BY JRL DON'T ALLOW PNAMES FOR ANY
VERSION 16-2(50) 3-20-73 
VERSION 16-2(49) 3-20-73 
VERSION 16-2(48) 3-20-73 BY JRL DON'T ERASE ASSOCIATIONS WHEN DELETE BTRIP
VERSION 16-2(47) 2-27-73 BY JRL FIX BYTE POINTERS FOR PROPS
VERSION 16-2(46) 2-19-73 BY JRL FLUSH POPTOP (NOW COMPILED INLINE)
VERSION 16-2(45) 2-13-73 
VERSION 16-2(44) 1-28-73 BY JRL HAVE DELETE TO A FORGET ALL TO CONTEXT ITEMS
VERSION 16-2(43) 1-25-73 BY JRL ADD ? TYPE ASSOCIATIVE BOOLEANS
VERSION 16-2(42) 1-23-73 BY JRL MAKE ANY AND UNBOUND DISTINCT,DETECT ANY EVERYWHERE
VERSION 16-2(41) 1-23-73 BY JRL MAKE PROPS FIELD 12 BITS WIDE
VERSION 16-2(40) 1-22-73 BY JRL BRITM RETURNS NIC(IF FAIL) HANDLE(X XOR X EQV FOO)
VERSION 16-2(39) 1-22-73 
VERSION 16-2(38) 1-5-73 BY  JRL DCS ALLOW UNBOUND IN SETS,LIST
VERSION 16-2(37) 1-5-73 
VERSION 16-2(36) 1-5-73 
VERSION 16-2(35) 1-5-73 
VERSION 16-2(34) 12-8-72 BY JRL ADD O EQV V DERIVED SET
VERSION 16-2(33) 12-4-72 BY DCS FIX F1 SEARCH BUG
VERSION 16-2(32) 12-1-72 BY JRL BUG #KP# FDONS DESTROYED AC A
VERSION 16-2(31) 11-26-72 BY JRL ADD POTENTIAL ANY XOR ANY EQV ANY SEARCH
VERSION 16-2(30) 11-18-72 BY JRL CHANGE HASH TABLE TO ONE WORD POINTERS TO CONFLICT LISTS
VERSION 16-2(29) 11-10-72 BY JRL ADD PROPS TO LEAP INIT
VERSION 16-2(28) 11-9-72 BY JRL ADD BNDTRP ROUTINE (BINDING ASSOC BOOL)
VERSION 16-2(27) 11-8-72 BY JRL MAKE INFTB INTO BYTE POINTER
VERSION 16-2(26) 10-16-72 BY jrl update item codes to include contexts
VERSION 16-2(25) 10-9-72 BY JRL GIVE MAINPI ETC TYPES, DON'T ALLOW UNBOUND IN MAKES,SETS,LIST
VERSION 16-2(24) 10-4-72 BY JRL BUG #JL# BNDFOR TURNED OFF FOR SETS
VERSION 16-2(23) 10-2-72 BY JRL BUG #JJ# MULTPLE PROCESS STUFF WAS DESTROYING FP2 LIST
VERSION 16-2(22) 10-2-72 BY JRL BUG #JI# FIX IFGLOBAL
VERSION 16-2(21) 9-17-72 
VERSION 16-2(20) 9-17-72 
VERSION 16-2(19) 9-17-72 
VERSION 16-2(18) 9-11-72 BY JRL TURN OFF BNDFOR BIT WHEN FETCHING ? LOCALS
VERSION 16-2(17) 9-7-72 BY JRL ADD ROUTINES TO STACK ?LOCALS
VERSION 16-2(16) 8-25-72 BY JRL CHANGE CALL TO DELETE FROM MPFAIL
VERSION 16-2(15) 8-25-72 BY JRL MAINTAIN FRLOC AS CURSCB FOR PROCESSES
VERSION 16-2(14) 8-24-72 BY JRL ADD MATCHING PROCEDURE ROUTINES
VERSION 16-2(13) 8-23-72 BY JRL CHANGE FORGO TO HANDLE DISPLAY ITEMVARS
VERSION 16-2(12) 8-22-72 BY RHT BE SURE THAT LEAP IS INITED WHEN NEED
VERSION 16-2(11) 8-10-72 BY DCS MAKE LINK GO IN RIGHT SEG
VERSION 16-2(10) 8-7-72 BY RHT CHANGE LPINI LINKAGE
VERSION 16-2(9) 7-24-72 BY JRL ADD GLOBAL-LOCAL CHECKING MAKES,ERASES,DELETES
VERSION 16-2(8) 7-2-72 BY JRL LPINI CALLED FROM ALLOC IN GOGOL
VERSION 16-2(7) 6-8-72 BY DCS BUG #HP# RETURN NULL STR FROM CVIS IF NO PNAME
VERSION 15-6(6) 2-22-72 
VERSION 15-6(5) 2-20-72 
VERSION 15-2(4) 2-6-72 BY DCS BUG #GC# CONSISTENCY ABOUT FIRST ACTUAL ITEM #
VERSION 15-2(3) 2-1-72 BY DCS USE SYMBOLIC (HEAD-DEFINED) INDICES IN SPACE TABLE
VERSION 15-2(2) 12-22-71 BY DCS REMOVE SAILRUN
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER

⊗;
SUBTTL Leaping runtime routines.  Sept. 1972.
	LSTON	(LEPRUN)



IFNDEF UPPER,<?UPPER←←0>
IFNDEF LOWER,<?LOWER←←0>
IFNDEF ALWAYS,<?ALWAYS←←0>

IFNDEF SEGS,<?SEGS←←0>
IFNDEF GLOBSW,<?GLOBSW←←0>

IFNDEF RENSW,<?RENSW←←0>
BEGIN LEAP
INTERNAL LEAP,CVIS,CVSI,NEW.PNAME,DEL.PNAME,TYPEX,TYPEIT,LISTX
;;#US% ! JFR 8-12-75 add TYPEIT
IFE ALWAYS,<ENTRY LEAP,CVIS,CVSI,TYPEIT
	  TITLE	LEAP
	  EXTERNAL GOGTAB,ARCOP,CORGET,CORREL,ARMAK,ARYEL,TERMIN,RESUME
	  EXTERNAL SPRPDA,RUNNER,DADDY,CURSCB,SPROUT,$PDLOV
	  EXTERNAL .SKIP.,DATM,LKSTAT,INFTB,X11,X22,X33,SAVE,RESTR,EQU
	  EXTERNAL PROPS,STACSV,STACRS
URLEAP<
;; \UR#7\ SUPPRESS OVERLAP MESSAGE IF USER SO DESIRES.
	EXTERNAL $$LNOWARN
;; \UR#7\
>;URLEAP
URLEAP <
;; && JES (@UOR) NEW LEAP HASH AND ITEM ALLOCATION
	EXTERNAL TPALLC,ITMBOT
>;URLEAP
URSTAT <
;; %% JES LOCATIONS USED FOR COUNTING THE NUMBER OF TIMES INNER
;   LOOPS OF LEAP SEARCHES ARE EXECUTED
	EXTERNAL RCNT1,RCNT2,RCNT3,RCNT4,RCNT5,RCNT6,RCNT7
	EXTERNAL RSUC1,RSUC2,RSUC3,RSUC4,RSUC5,RSUC6,RSUC7
>;URSTAT
	  EXTERNAL FP1DON,FP2DON,SDESCR,CORGZR,FPEES,ALLFOR,FSAV,FREST
	  INTERNAL COPARR,ARRRCL,RECQQ,CATLST,LPINI
>

REN <
	TWOSEG	400000
	RELOC	400000
	USE	HIGHS
	USE
	RELOC
	USE	HIGHS
>;REN
COMMENT ⊗
These are the leap runtime routines.  If you can believe it,there
is only one entry, LEAP.  On entry FLAG contains a 
control word.  The right half specifies
a routine name (see table of routines).  The left half has
various bits -- such as:

BOUND
BINDING  **during foreach lists only.
SETT	 **these bits are present for all (3) arguments.
	SETT is passed in but never used since without set arguments
	to MAKE,ERASE etc, it is superfluous

FOREA	 -- says that this call is inside a foreach list.
	This is never used, it is not clear it is even passed in.
SETOP	 -- this is a set or list type thing (e.g. x  IN  S)
BRACKET	 -- this is a bracketed search.
GLOB <
GLBSRC   -- this is a global model operation
>;GLOB


Since there is no elegant way of drawing spaghetti with characters,
I will refrain from describing here the mess that these
routines build and destroy (at random).  

⊗

;ac definitions.
IFNDEF A,<
	A←←1 
	B←←2
	C←←3
	D←←4
>
	?FLAG ←←5
	FP←6
	FRTAB←TAC1
	FPD←10
	PNT←11
GLOB <
	TABL←←7
>;GLOB
NOGLOB <
	TABL ←← USER	;MAKE IT THE SAME AS USER.
>;NOGLOB
NOURLEAP	<
	ITLEN←=12		;ITEM NUMBERS ARE 12 BITS LONG
>;NOURLEAP
;LENGTHS OF VARIOUS THINGS.....
	PHASLN ←← =128			;LENGTH OF PNAME HASH TABLE
	HASLEN←←777		;MUST BE OF THIS FORM.
				;I.E. 2↑N-1 .(THIS IS LENGTH OF HASH TABLE)
URLEAP	<
	TOPITM←←777777		;MAXIMUM NUMBER OF ITEMS
>;URLEAP
NOURLEAP	<
	TOPITM←←7777
	INFOLEN←←7777
>;NOURLEAP
GLOB <
IFNDEF GBRK,<
				;DO IT THIS WAY SINCE GOGOL ALSO SETS THIS 
				;VALUE (ON PAGE WITH STSW)
URLEAP	<
	GBRK ←← 600000		;LOCAL - GLOBAL ITEM NUMBER BREAK
				;MAXIMUM GLOBAL ITEM # IS 777776
>;URLEAP
NOURLEAP	<
	GBRK ←← 6000		;LOCAL - GLOBAL ITEM NUMBER BREAK
				;MAXIMUM GLOBAL ITEM # IS 7776
>;NOURLEAP
>; OF THE IFNDEF

>;GLOB

;FOREACH BLOCK TEMPLATE.
;THIS IS THE "SEARCH CONTROL BLOCK" -- ONE IS MADE FOR EACH KIND
;OF ASSOCIATIVE SEARCHING ROUTINE CALLED.  THE FPD STACK HAS GOOD
;MASKS, TEMPORARY POINTERS, AND A-O-V INFORMATION IN IT.

	SATNO←←MAXLOC 		;MAX NO. OF SATISFIERS.(foreach locals)
				;CURRENTLY =10
;** FOLLOWING ARE INDICES INTO SEARCH CONTROL BLOCK (USUALLY "FRTAB")
	FPDP←←0			;FOREACH PUSHDOWN POINTER.
	MOVEA←←1		;INSTRUCTION TO EXECUTE TO LOAD AC "A"
				;WITH THE CURRENT SATISFIER FOR THE LOCAL NUMBER
				;IN "A"
	MOVEB←←2		;SAME FOR AC "B"
	MC←←3			;BYTE POINTER FOR DEPOSITING SATISFIERS.
	INDEX4←←4		;INCREMENT TO SEARCH ROUTINE FOR ? LOCALS
	SCNT←←5			;NUMBER OF CORE SATISFIERS FOR THIS SEARCH.
	SATIS←←6-1		;START OF SATISFIERS.
				;EACH CELL HAS :
				; RH  PNTS TO  USER CORE ADDRESS OF VARB.
				; LH   CURRENT SATISFIER ITEM NUMBER.
				;       (PUT THERE WITH "MC", RETRIEVED
				;	WITH "MOVEA" OR "MOVEB"
				;Note that SCNT is used for depositing satisfiers
				;to ANY and thus when count really wanted should
				;loaded with HRRE
	OLDSAT ←← SATIS+1+SATNO ;BLOCK OF OLD VALUES OF FOREACH LOCALS
	FPDL←←OLDSAT+SATNO	;PUSH DOWN AREA.
;DISPLACEMENTS IN FPD STACK FOR VARIOUS THINGS.
;	USED BY THE SEARCH ROUTINES TO FIND ARGUMENTS LEFT BY
;	THE FOREACH SEARCH CALLER.
	T2←←2
	TT1←←3
	MASK←←4
	ATTP←←5
	ITMP←←5
	OBJP←←6
	SETP←←6
	VALP←←7
	LENFPD←←10	;LENGTH OF AN FPD STACK ENTRY
	FPDLEN←←=10*LENFPD	;FOREACH PUSHDOWN LIST LENGTH
				;ALLOW 10 SEARCHES
	FRCHLEN←←FPDL+FPDLEN+2		;TOTAL LENGTH.
	SCBLNK←←FRCHLEN-1		;FRCHLEN-1 OFFSET OF SCBLINK
;BITS IN LEFT HALF OF LOCAL ITEMVARS
	CDISP ←← 100000		;A DISPLAY MUST BE CALCULATED
	MPPAR ←← 200000		;THIS IS A ? ITEMVAR PARAMETER
	POTUNB ←← 400000	;THIS LOCAL IS ONLY POTENTIALLY UNBOUND
;IF POTUNB THEN SATISFIER CAN CONTAIN FOLLOWING 
NOURLEAP	<
	BNDFOR ←← 400000	;THIS LOCAL WAS BOUND ON ENTRY
>;NOURLEAP
URLEAP	<
;LOCAL WAS BOUND ON ENTRY IS NOW INDICATED BY -1 IN L.H. OF THE
;CORRESPONDING ENTRY IN OLDSAT
>;URLEAP
DSCR FOREACH INTERPRETATION EXAMPLE
⊗;
COMMENT @
THE THREE FOLLOWING DEFINITIONS PERTAIN TO THE (SAY) THREE ARGUMENTS
IN A FOREACH SEARCH SPECIFICATION: IF I SAID:
	FOREACH X | A XOR X EQV B AND X IN FOOSET DO...
THE CODE WOULD BE:
	MOVEI	TAC1,.+4	;ADDRESS SATIS INFO BLOCK
	MOVEI	FLAG,11		;ROUTINE NO. 11, START A FOREACH
	PUSHJ	P,LEAP
	JRST	.+4		;JUMP AROUND SATIS INFO BLOCK
	JRST	2232323		;WHERE TO GO WHEN FOREACH ALL DONE.
	1			;NUMBER OF FREE LOCALS
	X			;ADDRESS OF THE ITEMVAR X.
	PUSH	P,[A]		;ITEM A
	PUSH	P,[1]		;FIRST SATISFIER
	PUSH	P,B		;ITEMVAR B.
	MOVE	FLAG,[XWD 20,2] ;SPECIFIES THAT OBJECT IS BEING BOUND
				;IN THIS OPERATION ("BINDING"), AND
				;TO USE SEARCH 2  (OBJECT UNBOUND).
	PUSHJ	P,LEAP
	PUSH	P,[1]		;FIRST SATISFIER
	PUSH	P,FOOSET	;SET
	MOVE	[XWD 20410,7]	;SET SEARCH.  SPECIFIES THAT THIS IS
				;A SET OPERATION ("SETOP") AND THAT
				;THE FIRST ARG. IS A BOUND SATISFIER.
	PUSHJ	P,LEAP
	MOVEI	FLAG,12		;PUT SATISFIERS DOWN IN CORE....
	PUSHJ	P,LEAP



@
;VARIOUS DEFINITIONS OF BITS IN THE CONTROL WORD:
;	THIS IS THE CONTROL WORD LOADED INTO FLAG BEFORE THE PUSHJ P,LEAP.
;	THESE BITS ARE IN THE LEFT HALF, AND SPECIFY MODIFICATIONS
;	ON THE ROUTINE NUMBER MENTIONED IN THE RIGHT HALF.

	BOUND←←4		;THESE NEXT 3 REPEATED FOR A,O AND V.
	BINDING←←2
	SETT←←1

	FOREA←←40000		;A FOREACH SEARCH (NOT USED)
	SETOP←←20000		;A SET SEARCH IN A FOREACH.
GLOB <
	GLBSRC←←200000		;GLOBAL SEARCH SPECIFIED.
>;GLOB
	BRACKET←←400000		;MUST BE SIGN BIT.
				;MEANS A BRACKETED TRIPLE SEARCH IN
				;FOREACH CONTEXT.

	ATTPOS←←6		;POSITION IN THE WORD.....
	OBJPOS←←3
	VALPOS←←0

;BITS IN THE DATA STRUCTURES OF LEAP.

	BRABIT←←400000		;MUST BE SIGN BIT.
NOURLEAP	<
				;ON IF NEXT GUY IN THE VALUE LIST IS A
				;BRACKETED TRIPLE
>;NOURLEAP
				;THIS BIT IS USED BOTH IN THE FOREACH SPEC.
				;FOR THE SEARCH, AND IN THE LEAP LIST
				;STRUCTURES CREATED.
COMMENT ⊗THERE IS A TBITS TABLE CALLED TBTBL IN EVAL -- IN FILE IOSER ⊗
DSCR USEFUL MACROS
⊗;
;THE MAGIC MACRO TO HASH

URHASH <
	DEFINE HASH (X,Y,Z) <
	IFDIF <X><Y>,<MOVE	X,Y>
	LSH 	X,@RMASK3(TABL)	;SHIFT X OVER
	MOVEM	C,TEMPR#	;SAVE C SO AS NOT TO CLOBBER IT
	MOVE	C,Z		;PUT Z (OBJECT) IN C
	AND	C,RMASK4(TABL)	;MASK OUT ALL BUT LAST FEW BITS
	XOR	X,C		;XOR X (ATT) AND Z (OBJECT) 
	MOVE   	C,TEMPR		;RESTORE C (I'M BEING VERY CAUTIOUS)
	AND	X,HASMSK(TABL)	;MASK OUT HIGH ORDER BITS
	ADD	X,HASTAB(TABL)	;ADD TO BASE PTR
	>
 >;URHASH
NOURHASH <
	DEFINE HASH (X,Y,Z) <
	IFDIF <X><Y>,<MOVE	X,Y>
	LSH	X,1
	XOR	X,Z
	AND	X,HASMSK(TABL)
	ADD	X,HASTAB(TABL)
	>
>;NOURHASH

;MAGIC MACRO TO TEST FOR BRACKETED TRIPLE.
NOGLOB <
	DEFINE BRACKP (X) <TRZE X,BRABIT>	;SKIPS IF NO BRACK. TRIPLE.
	DEFINE BRACKN (X) <TRZN X,BRABIT>	;SKIPS IF BRACKETED TRIPLE.
>;NOGLOB
GLOB <
	DEFINE BRACKP (X) <
	CAIN	TABL,GLUSER
	JRST	[JUMPE X,.+ 3
		 TRON X,BRABIT
		 JRST .+2
		 JRST .+3]
	TRZE	X,BRABIT
	>
	DEFINE BRACKN (X) <
	CAIN	TABL,GLUSER
	JRST	[JUMPE X, .+2
		 TRON X,BRABIT
		 JRST .+3
		 JRST .+2]
	TRZN	X,BRABIT
	>
>;GLOB


NOEXPO <
NOGLOB <
INTERNAL .MES1,.MES2
.MES1:.MES2:	POP P,(P) 
		POPJ	P,
>;NOGLOB

INTERNAL DATERR
DATERR:	ERR	<INCORRECT ITEM # FOR GLOBAL DATUM>,1
	POPJ	P,

>;NOEXPO

INTERNAL $$DERR
;; \UR#6\ ERROR MESSAGE FOR VERIFY!DATUMS
HEREFK($$DERR,$$DER.)
	MOVE	USER,GOGTAB
	POP	P,UUO1(USER)	; FOR ERROR MESSAGE
	ERR	<INCORRECT ITEM DATA TYPE FOR DATUM>,1
	JRST	@UUO1(USER)
;; \UR#6\
DSCR INTERLOCKS FOR LEAP GLOBAL MODEL
	PMUTX,VMUTX,PNOENT,VNOEN,RDSEC,WRITSEC,NOSEC
 ⊗
GLOB <


COMMENT ⊗ THE BASIC STRATEGY IS TO CONSIDER LEAP ACTIONS AS DIVIDED
 INTO TWO CLASSES. THOSE WHICH READ ONLY, AND THOSE WHICH BOTH READ
 AND WRITE. ANY NUMBER OF JOBS MAY BE ALLOWED TO ENTER LEAP IF
 ALL THEY WANT TO DO IS READ AND THERE IS NO JOB CURRENTLY IN LEAP
 WHICH WILL WRITE. THE SOLUTION TO THE CRITICAL SECTION PROBLEM
 IS TAKEN FROM THE COURTOIS, ET AL ARTICLE IN CACM, OCT. 1971 ⊗

;MACROS TO AID US

DEFINE PMUTX < 
	PUSHJ P,PMUTXR
	>; PREFORMS P OPERATION ON SEMAPHORE MUTEX

DEFINE VMUTX <
	SOS MUTEX
	>; PREFORMS V OPERATION ON SEMAPHORE MUTEX

DEFINE PNOENT <
	PUSHJ P,PNOENR
	>; PREFORMS P OPERATION ON SEMAPHORE NOENTER

DEFINE VNOENT <
	SOS NOENTER
	>; PERFORMS V OPERATION ON SEMAPHORE NOENTER

DEFINE WRITSEC <
	PUSHJ 	P,ENTWRT
	>; MAKE SURE INSIDE OF WRITING SECTION

DEFINE RDSEC <
	PUSHJ	P,ENTRD
	>; MAKE SURE INSIDE OF READING SECTION

DEFINE NOSEC <
	PUSHJ  	P,NOSECR
	>; EXIT WHATEVER KIND OF SECTION WE'RE IN IF ANY
;ROUTINE THAT DO THE WORK FOR MACROS

↑AOSENT:			;TO START READING SECTION
	TLNN	FLAG,GLBSRC ;GLOBAL OPERATION
	POPJ	P,		;NO.
	PMUTX			;MANIPULATING READCOUNT CRITICAL
	AOSN	ENTERED		;INC COUNT, FIRST JOB IN?
	PNOENT			;YES, LOCK OUT WRITING JOBS
	VMUTX			;EXIT THIS CRIT. SECTION
	POPJ	P,		;RETURN

↑SOSENT:			;TO EXIT READING SECTION
	TLNN	FLAG,GLBSRC	;GLOBAL OPERATION
	POPJ	P,		;NO.
	PMUTX			;MANIPULATING READCOUNT CRITICAL
	SOSGE   ENTERED		;DEC COUNT,OTHERS READERS AROUND?
	VNOENT			;NO. FREE CRIT. SECT.
	SETZM	LKSTAT		;NOT IN ANY TYPE OF SECTION
	VMUTX			;EXIT THIS CRIT. SECT.
	POPJ	P,		;RETURN

↑PMUTXR:			;P(MUTEX)
	AOSE	MUTEX		;IF NOW=ZERO WE'RE O.K.
	JRST	[SOS MUTEX	;TOO BAD WE HAVE TO WAIT
		 PUSHJ P,WAIT1	;SLEEP AWHILE
		 JRST .-1	;TRY AGAIN
		]
	POPJ	P,		;WE'RE IN CRIT. SECTION MUTEX

↑PNOENR:			;P(NOENTER)
	AOSE	NOENTER		;ZERO, WE'RE ALLOWED IN
	JRST	[SOS NOENTER	;WE HAVE TO WAIT
		 PUSHJ	P,WAIT10 ;SLEEP SOUNDLY
		 JRST .-1]
	POPJ	P,		;WE'RE INSIDE.

ENTCHK:				;TO ENTER WRITING SECTION

	PNOENT 			;WAIT UNTIL WE CAN ENTER
	PUSH	P,A		;FREE AN AC
	CALLI 	A,30		;GET JOB NO.
	MOVEM	A,LKJBNO	;SAVE IN CASE ANYONE WANTS TO KNOW
	POP	P,A		;RESTORE A
	POPJ	P,		;RETURN

EXCHK:				;TO EXIT FROM WRITING SECTION
	VNOENT			;EXIT WRITING, ALLOW READERS BACK IN
	SETZM	LKSTAT		;NOT IN ANY SECTION
	SETZM	LKJBNO		;CLEAR JOB NUMBER
	POPJ	P,		;RETURN

↑↑WAITQQ:
WAIT1:	PUSH	P,A		;SAVE AC
	MOVEI	A,1		;ONE SECOND SLEEP
	JRST	WAIT10+2
WAIT10: PUSH	P,A		;SAVE AN AC
	MOVEI	A,10		;10 SEC. WAIT
	CALLI	A,31		;BEDDY-BYE
	POP	P,A		;RESTORE A
	POPJ	P,		;RETURN

ENTWRT:				;FORCE INTO WRITING SECTION
	TLNN	FLAG,GLBSRC	;IF NOT GLOBAL FORGET IT.
	POPJ	P,
	SKIPGE	LKSTAT		;ALREADY IN WRITING SECTION?
	POPJ	P,		;IF SO, RETURN
	SKIPE	LKSTAT		;IN READING SECTION?
	PUSHJ	P,SOSENT	;YES, EXIT FIRST
	PUSHJ	P,ENTCHK	;ENTER WRITING SECTION
	SETOM	LKSTAT		;MARK AS INSIDE WRITING SECTION
	POPJ	P,

ENTRD:				;FORCE INTO READING SECTION
	TLNN	FLAG,GLBSRC	;GLOBAL OPERATION?
	POPJ	P,		;NO FORGET IT.
	SKIPLE	LKSTAT		;ALREADY IN READING SECTION?
	POPJ	P,		;YES.
	SKIPE	LKSTAT		;IN WRITING SECTION?
	PUSHJ	P,EXCHK		;YES EXIT IT.
	AOS	LKSTAT		;MARK AS INSIDE READING SECTION
	PUSHJ	P,AOSENT	;ENTER SECTION
	POPJ	P,

NOSECR: 			;EXIT ANY SECTION

	SKIPN	LKSTAT		;IN A SECTION?
	POPJ	P,		;NO, RETURN
	SKIPG	LKSTAT		;WRITING 
	PUSHJ	P,EXCHK		;YES
	SKIPE	LKSTAT		;READING
	PUSHJ	P,SOSENT	;YES
	POPJ	P,
>;GLOB
DSCR LEAP ALLOCATION -- START OF PROGRAM.

 Allocation (initially).
The initialization proceeds in several phases:
	1. zero all the set variables.
	2. accumulate counts of declared items and NEW estimates.
	3. allocate hash table, datum table, info table, and frees.
	4. initialize random other things (datum, foreach tables)
	5. initialize printnames, item types for declared items

⊗

;MACRO TO GET LEAP CORE.
DEFINE	LPCOR (SIZE,PLACE) <
	IFDIF <SIZE><>,<MOVEI	C,SIZE>
	PUSHJ	P,CORGZR
	IFDIF <PLACE><>,<MOVEM	B,PLACE(TABL)>
	>


DSCR INITIT - INITIALIZE ITEM TYPE FOR DECLARED ITEMS ⊗

COMMENT ⊗ AC A is assumed to contain address of type info block
	from SPLNK. Type info block contains word containing N
	the number of declared items followed by N words containing
	item # ,, type index.

	this routine destroys contents ac A. ⊗

INITIT:				;CALLED BY PUSHJ FROM LPINI
	PUSH	P,B		;GET SOME AC'S TO PLAY WITH
	PUSH	P,C		
GLOB <
	MOVEI	TABL,GLUSER	;POINT TO GLOBAL STUFF
	PUSH	P,[HRRM B,(C)]  ;USED TO INSERT INTO GLOBAL INFOTAB
	HRRZ	B,INFOTAB(TABL) ;ADDRESS INFOTAB
	ADDM	B,(P)
>;GLOB

	PUSH	P,[HRRM	B,(C)]
	HRRZ	B,INFOTAB(USER)	;
	ADDM	B,(P)
	MOVN	B,(A)		;NEG. COUNT OF DECLARED ITEMS
	JUMPE	B,ITRETRN	;NO DECLARED ITEMS?
	ADDI	A,1		;POINT TO FIRST "DATA" WORD
	HRL	A,B		;MAKE AOBJN POINTER
LPINIT: HRRZ	B,(A)		;GET TYPE CODE
	HLRZ	C,(A)		;GET ITEM NUMBER
GLOB <
	CAIL	C,GBRK
;; #LY# GLOBAL ITEM TYPES SHOULD ONLY BE INITIALIZED ONCE.
	JRST    [SKIPN LEPINI	;IF GLOBAL ALREADY INITIALIZED DON'T DESTROY PROPS
		 XCT	-1(P)		;PUT IN GLOBAL INFOTAB
		 JRST .+1]
;; # 
>;GLOB
	SKIPL   UUO1(USER)	;IF NO LOCAL MODEL DON'T
	XCT	(P)		;PUT IN LOCAL INFOTAB
	CAIE	B,STTYPE	;STRING ITEM?
	JRST	ADDONE		;NO.
	PUSHJ	P,SDESCR	;GET A STRING DESCRIPTOR
	POP	P,@DATM		;SAVE AS DATUM
ADDONE:	AOBJN	A,LPINIT	;THROUGH?
ITRETRN:
NOGLOB <
	SUB	P,X11		;REMOVE HRRM
>;NOGLOB
GLOB <
	MOVEI	TABL,(USER)	;REFER TO LOCAL MODEL AGAIN
	SUB 	P,X22		;REMOVE BOTH HRRM'S
>;GLOB
	SKIPGE  UUO1(USER)	;IF NO LOCAL MODEL
	JRST	ITRET2		;JUST RETURN
	MOVEI	C,EVTYPI	;EVENT TYPE ITEM
	MOVEI	B,1		;CODE FOR NO DATUM
	MOVEM	B,@INFTB	;STORE CODE
	MOVEI 	C,NIC		;NIC ITEM
	MOVEM 	B,@INFTB	;ALSO UNTYPED ITEM
ITRET2:
	POP	P,C
	POP	P,B
	POPJ	P,
	INTERNAL LPINI
NOLOW <
NOUP <
REN <
	USE
>;REN
LPLNK:	0
	LPINI
	0
	LINK	%INLNK,LPLNK
REN <
	USE	HIGHS
>;REN
>;NOUP
>;NOLOW

↑LPINI2: ERR	<LEAP SHOULD HAVE BEEN INITIALIZED>,1,LIN.1
HERE(LPINI)
	SKIPN	HASMSK(USER)	;LEAP INITIALIZATION ROUTINE.
	POPJ	P,		;DONT NEED IT
LIN.1:	PUSH	P,TAC1		;NOT SAVED IN CORGET AND FRIENDS.
GLOB <
	WRITSEC			;INSIDE WRITING SECTION
	MOVEI	TABL,(USER)	;START OFF AS LOCAL MODEL
>;GLOB


; FIRST CLEAR OUT ALL SETS AND LISTS LINKED BY COMPILER

	MOVE	B,SETLNK(USER)	;CLEAR OUT ALL SETS LINKED BY COMPILER
	JUMPE	B,LPALLO	;NO SETS!!!!
GOSET:	MOVE	C,-1(B)
	SETZM	(C)		;ZERO THE SET.
	AOBJN	C,.-1
	HRRZ	B,(B)
	JUMPN	B,GOSET		;CDR OF LIST.


;

LPALLO:				;SEARCH SPACE ALLOCATION INFORMATION.

; C WILL CONTAIN THE MAXIMUM DECLARED ITEM,
; D WILL CONTAIN THE TOTAL OF REQUIRED NEW ITEMS
; LH OF UUO1(USER) IS FLAG, -1 IF NO LOCAL MODEL, 0 IF LOCAL MODEL
; HASMSK(USER) WILL CONTAIN MAXIMUM BUCKETS REQUIRED
; A PTS TO SPACE ALLOCATION BLOCK FOR CURRENT RELFILE
; B SAVES STACK PTR AS WE WILL BE SAVING THE ITEM RANGES (LOWEST,HIGHEST) ON
; 		THE P-STACK

GLOB <
; LPSA CONTAINS "MINIMUM" DECLARED GLOBAL ITEM
>;GLOB
	SETZB	C,D		;ACCUMULATE MAXIMUM ITEM COUNT.
	SETZM	HASMSK(USER)	;WILL COLLECT MAX BUCKETS REQUIRED
GLOB <
URLEAP	<
	MOVEI	LPSA,777777
>;URLEAP
NOURLEAP	<
	MOVEI	LPSA,7777
>;NOURLEAP
>;GLOB
	HRROS	UUO1(USER)	;ASSUME NO LEAP LOCAL MODEL.
	MOVE	B,P
	MOVE	A,SPLNK(USER)	;ALLOCATION LINK POINTER
ITMWQ:
	HRRE	TEMP,$ITNO(A)	;TOP ITEM NUMBER USED.
	CAILE	TEMP,10		;THERE ARE 7 DUMMIES.
; THIS WAS A CAILE -- I THINK IT'S BETTER THIS WAY -- DCS 10-6-71
; THIS IS A CAILE AGAIN -- OTHERWISE THE HAND/EYE SYSTEM GETS THE ERROR MESSAGE
; EVERY TIME - KKP 10-25-71
	JRST	[CAILE TEMP,(C)    ;NEW HIGHEST ITEM NUMBER?
		 MOVEI C,(TEMP)	   ;YES
		 HLL TEMP,$ITNO(A) ;GET BACK LOWEST ITEM NUMBER
		 TLNN TEMP,-1	   ;IF NONE WILL DEFAULT TO 11
		 HRLZI	TEMP,11
		 PUSH	P,TEMP	   ;SAVE LOWEST,HIGHEST PAIRS ON P-STACK
		 HRRZS UUO1(USER) ;SAY LOCAL LEAP MODEL
		 JRST	.+1]
URLEAP<
;; \UR#7\ SUPPRESS WARNING IF USER SAID OVERLAP!OK
	HLRE	TEMP,$TINIT(A)	; SUPPRESS OVERLAP MSG FLAG
	ORM	TEMP,$$LNOWARN
;; \UR#7\
>;URLEAP
	HRRE	TEMP,$NWITM(A);IF ITEMS REALLY REQUESTED,
	JUMPLE	TEMP,.+2
	HRRZS	UUO1(USER)	;SAY LOCAL LEAP MODEL
	ADD	D,TEMP		;ESTIMATE OF NEW ITEMS REQUIRED.
GLOB <
	HRRZ	TEMP,$GITNO(A)	;LH OF GITNO CONTAINS "LEAPIS" FLAG
	JUMPE	TEMP,.+3
	CAIL	LPSA,(TEMP)	;JUST SO K PINGLE NEED NOT COMPILE WITH GLOB MODEL.
	MOVEI	LPSA,(TEMP)	;GLOBAL ITEMS ALLOCATED.
			;CANNOT EXCEED 7776...
>;GLOB
;;#NS# ! USED TO BE HLRZ WE SHOULD ALLOW NEGATIVES
	HLRE	TEMP,$NWITM(A)	;NUMBER OF BUCKETS REQUIRED
	CAMLE	TEMP,HASMSK(USER) ;MORE THAN BEFORE?
	MOVEM	TEMP,HASMSK(USER) ;YES.
	HRRZ	A,(A)	;GO DOWN LINK.
	JUMPN	A,ITMWQ		;0 WHEN DONE.
ITMDON:				;FINISHED WITH SPACES.
	CAIGE	C,10	;MAKE SURE ITEMS 10 AND BELOW NOT ALLOCATED
;;#GC# DCS 2-6-72 (1-1) BE CONSISTENT
	MOVEI	C,10	;NEXT NEW WILL YIELD 11
;;#GC# (1-1) FIRST DECLARED WAS 11 -- NOW IF NONE DECLARED, FIRST IS 11
URLEAP <	;; %% JES(@UOR) FOR DESCENDING ITEM ALLOCATION
	MOVEM	C,TPALLC	;TOP ITEM ALLOCATED.
>;URLEAP
NOURLEAP <
	MOVEM	C,MAXITM(USER)	;TOP ITEM ALLOCATED
>;NOURLEAP
	SOSGE	FP,HASMSK(USER)
	MOVEI	FP,HASLEN&777777;FOR THE HASH TABLE MASK.
	MOVEM	FP,HASMSK(USER)	;AND SAVE
URHASH <
;THE FOLLOWING REPRESENTS THE CODE WHICH WILL STUFF THE RMASKS WITH
;APPROPRIATE INFORMATION BASED ON THIS INVOCATION OF LEAP
;(RICK RASHID 3/15/76)

;THE FOLLOWING NEW (JES 30-JUL-76) VERSION OF THIS LEAVES THE RMASKS AS
;FOLLOWS, ASSUMING THE REQUESTED HASH TABLE SIZE IS 2↑N:
;	RMASK1(USER) =	2 ↑ (N DIV 2) - 1	(USUALLY 17)
;	RMASK2(USER) = 	2 ↑ (N DIV 2)		(USUALLY 20)
;	RMASK3(USER) =	N DIV 2			(USUALLY 4)
;	RMASK4(USER) = 2 ↑ ((N + 1) DIV 2) - 1	(USUALLY 37)

	PUSH	P,A		;SAVE A FOR SAFETY SAKE
	PUSH	P,B
	PUSH	P,C		;AND C, I'M GOING TO USE IT TOO
	MOVE	A,HASMSK(USER)	;PICK UP 2 ↑ N - 1	(USUALLY 777)
	JFFO	A,.+1		;LEAVE COUNT OF LEADING ZEROS IN B
	MOVEI	A,=36
	SUB	A,B		;LEAVE N IN A
	IDIVI	A,2		;LEAVE REMAINDER IN B
	MOVEM	A,RMASK3(USER)
	MOVEI	C,1
	ASH	C,@A
	MOVEM	C,RMASK2(USER)
	SUBI	C,1
	MOVEM	C,RMASK1(USER)
	JUMPE	B,.+3		;IF N WAS ODD THEN RMASK4 NEEDS ANOTHER 1-BIT
	LSH	C,1
	ADDI	C,1
	MOVEM	C,RMASK4(USER)
	POP	P,C
	POP	P,B
	POP	P,A
>;URHASH
	SKIPGE	UUO1(USER)	;A LOCAL LEAP MODEL?
	JRST	NOLOCL		;NO

	PUSHJ	P,FPEES		;GET AN INITIAL ONE-TWO WORD FREES
				;FIRST TIME ONLY GET 1 TWO-WORD FREE
				;AND 10 1-WORD FREES

	ADDI	C,50(D)		;MAX EXPECTED OVER "DECLARED"
NOGLOB <
	CAILE	C,TOPITM
	MOVEI	C,TOPITM
>;NOGLOB
GLOB <
	CAILE	C,GBRK-1
	MOVEI	C,GBRK-1
>;GLOB
	MOVEM	C,ITMTOP(USER)	;SAVE THE MAXIMUM ITEM NUMBER
URLEAP <
		;ITEMS WILL BE ALLOCATED IN DESCENDING ORDER, STARTING
		; WITH -1(C)
	MOVEM	C,MAXITM(USER)	;STORE IT HERE TOO (THIS IS A KLUDGE
			;DESCENDING FROM THE OLD ITEM ALLOCATION)
	MOVEM	C,ITMBOT	;LOAD A DOWN-COUNTER WITH ONE ...
				;... MORE THAN MAXIMUM ITEM NUMBER
	MOVEI	TEMP,(C)	;NO KLUDGES HERE
	SUB	TEMP,TPALLC	;SUBTRACT THE NUMBER ALREADY USED
>;URLEAP
NOURLEAP <
	MOVEI	TEMP,-3(C)	;BUILD THE NUMBER OF FREE ITEMS (- FUDGE)
	SUB	TEMP,MAXITM(USER)
>;NOURLEAP
	MOVEM	TEMP,FREITM(USER)
; AT THIS POINT ON THE P-STACK FROM LOCATIONS 1(B) TO (P) ARE PAIRS
; LOWEST,,HIGHEST CORRESPONDING TO THE DECLARED ITEMS USED BY A PROGRAM
; WE WILL NOW SORT THESE IN DESCENDING ORDER
SRTINT:
	MOVEI	A,(B)		;BUBBLE SORT
OTRSRT:
	ADDI	A,1
	CAIL	A,(P)		;THROUGH?
	JRST	SRTED		;YES
	MOVEI	C,(A)		;PREPARE FOR INNER LOOP
INRSRT:
	MOVE	TEMP,(C)	;
	CAML	TEMP,1(C)
	JRST	ADDIC		;NO SWAP
	EXCH	TEMP,1(C)
	MOVEM	TEMP,(C)
ADDIC:
	ADDI	C,1
	CAIE	C,(P)		;DONE INNER LOOP?
	JRST	INRSRT		;NO.
	JRST	OTRSRT		;YES, CONTINUE OUTER LOOP
SRTED:
; CHECK TO MAKE SURE NO OVERLAP
	MOVEI	A,-1(P)		;
CHKOVR:
	CAIG	A,(B)
	JRST	OVRCHKD		;THROUGH
	HLRZ	TEMP,(A)	;START OF NEXT
	MOVE	C,1(A)		;END OF THIS
	CAILE	TEMP,(C)	;EVERYTHING FINE?
	SOJA	A,CHKOVR	;YES
URLEAP<
;; \UR#7\ CHECK IF USER SAID TO SUPPRESS WARNING
	SKIPN	$$LNOWARN	; USER DOESN'T WANT WARNINGS
;;\UR#7\
>;URLEAP
	TERPRI	<WARNING: TWO PROGRAMS WITH ITEM OVERLAP>
	SETZM  1(A)
	HLLM	TEMP,(A) ;MERGE TWO OVERLAPS
	CAIN	TEMP,11	;INITIAL OVERLAP?
	SOJA	A,CHKOVR
	MOVEI	TEMP,(TEMP)	;FOR ERR UUO BELOW
	ERR 	< LEAP OVERLAP:  FIRST CONFLICT ITEM NUMBER >,7
	SOJA	A,CHKOVR
OVRCHKD:
	MOVE	FP,FP1(USER)    ;WE WILL LINK UP
	HRRZM	FP,OLDITM(USER)	;LINKED LIST OF AVAILABLE ITEMS
	SKIPN	(P)
	JRST    [SUB P,X11	;LOOP UNTIL FIND NON-EMPTY STACK ELEMENT
		 JRST .-1]
	MOVEI	C,0		;FLAG TO DETERMINE IF WE LINKED ANY AT ALL
	HLRZ	TEMP,(P)	;LOWEST DECLARED ITEM NUMBER
	MOVEI	A,10		;
	PUSHJ	P,LNKITM
	CAMN	P,B
	JRST	LNKOVR
LPLNKM:
	HRRZ	A,(P)
LPLNK2:
	SUB	P,X11
	CAMN	P,B		;THROUGH?
	JRST	LNKOVR		;YES
	SKIPN	(P)
	JRST    LPLNK2
	HLRZ	TEMP,(P)
	PUSHJ	P,LNKITM
	JRST	LPLNKM
LNKITM:				;PUSHJ'D TO
	ADDI	A,1		;LINK IN ITEMS FROM (A)+1 TO (TEMP)-1
	CAIG	TEMP,(A)	;DONE?
	POPJ	P,		;YES
	MOVEI	C,(FP)
	SKIPN	FP,(FP)		;FOR NEXT TIME
	PUSHJ	P,FP1DON
	HRLM	A,(C)		;ITEM FOR FREE LIST
	AOS	FREITM(USER)
	JRST	LNKITM
LNKOVR:
	JUMPE	C,[SETZM OLDITM(USER) ;THERE WEREN'T ANY
		   JRST  NOLOCL]
	HRRM	FP,FP1(USER)
	HLLZS	(C)
NOLOCL:
GLOB <
				;GLOBAL MODEL INITIALIZATION.
	AOSE	LEPINI		;INITED ALREADY?
	JRST	LNONIT		;YES
	MOVEI	FP,HASLEN&777777
	MOVEM	FP,HASMSK+GLUSER;IN TWO PLACES.
	MOVEI	TABL,GLUSER	;
URHASH <
;MORE CODE FOR STUFFING RMASKS (3/15/76)
	PUSH	P,A		;JUST TO BE ON SAFE SIDE
	MOVEI	A,17
	MOVEM	A,RMASK1(TABL)
	MOVEI	A,20
	MOVEM	A,RMASK2(TABL)
	MOVEI	A,4
	MOVEM	A,RMASK3(TABL)
	MOVEI	A,37
	MOVEM	A,RMASK4(TABL)
	POP	P,A
>;URHASH
	MOVEM	LPSA,MAXITM(TABL);AS WE ACCUMULATED IT.
	MOVEI	D,GBRK		;ADJUST FOR LOCAL -GLOBAL DIFFERENCE.
	MOVEI	C,TOPITM-GBRK+1	;NUMBER OF GLOBAL ITEMS TO ALLOC.
	PUSHJ	P,SPALLO	;AND ALLOCATE
	MOVEM	A,GINFTB	;GLOBAL TYPE-CHECKING
	HRLI	A,(<POINT 12,(3),29>) ;FOR PROPS FIELD
	MOVEM	A,GPROPS
	MOVEM	B,GDATM		;GLOBAL DATUM REFERENCES.
	PUSHJ	P,FPEES		;FREES.
LNONIT:
	MOVEI	TABL,(USER)	;REFER TO LOW CORE AGAIN
>;GLOB
	SKIPGE	UUO1(USER)	;DOES USER REALLY WANT LOCAL MOD?
	JRST	 INDONE		;THIS IS TO AVOID HAVING SOME
				;POOR LOSER WHO ONLY WANTS GLOBAL
				;ARRAYS GETTING 15 K CORE FOR LEAP!
NOGLOB <
	MOVE	C,ITMTOP(USER)  ;HOW MANY LOCAL ITEMS WE'RE GOING TO HAVE
>;NOGLOB
GLOB <
URLEAP	<
;SINCE THE TOP GLOBAL ITEM IS 777777 (HALFWORD -1), WE WILL ALLOCATE
; THE DATUM TABLE AND THE INFOTAB IN THE FOLLOWING WAY:
;
;			MAXIMUM LOCAL ITEM
;			.
;			.		(LOCAL ITEMS)
;			.
;	TABLE POINTER:	ITEM 0		(I.E. ANY)
;			ITEM 777777	(I.E. TOPITM)
;			.
;			.		(GLOBAL ITEMS)
;			.
;			ITEM GBRK	(600000 FOR NOW)
;
	MOVE	C,ITMTOP(USER)	;HOW MANY LOCAL ITEMS WE'RE GOING TO HAVE
	MOVEI	C,-GBRK(C)	;ADD THE NUMBER OF GLOBAL ITEMS
	MOVEI	D,GBRK		;OFFSET FROM BOTTOM OF TABLES TO ITEM 0
	PUSH	P,[SPDON]	;DUMMY RETURN ADDRESS
>;URLEAP
NOURLEAP	<
	MOVEI	C,TOPITM
	MOVEI	D,0
	PUSH	P,[SPDON]		;DUMMY RETURN ADDRESS.
>;NOURLEAP
>;GLOB
SPALLO:
URLEAP <
	MOVEI	C,1(C)	;INCREMENT C SO THE TABLES WILL BE BIG ENOUGH
>;URLEAP
	PUSH	P,C
	LPCOR	(,)		;GET CORE FOR VALUE LINKS, ETC.
GLOB <
	SUBI	B,(D)		;SUBTRACT OFF LOWER BOUND.
>;GLOB
	HRLI	B,(<POINT 6,(C),35>);MAKE INTO BYTE POINTER
	MOVEM	B,INFOTAB(TABL)	;RECORD IT.
	MOVE	C,HASMSK(TABL)
	ADDI	C,1		; NUMBER OF BUCKETS
	LPCOR	(,HASTAB);HASH TABLE SPACE.
	
	POP	P,C		;RESTORE SIZE
	LPCOR	(,)		;AND FOR DATUMS.
GLOB <
	SUBI	B,(D)		;ADJUST IF NECESSARY
>;GLOB
	HRLI	B,3		;ACCUMULATOR NUMBER FOR DATUM.
	MOVEM	B,DATAB(TABL)	;RECORD IT.
	MOVE	A,INFOTAB(TABL)	;FOR DYNAMIC TYPE-CHECKING
GLOB <
	MOVEI	TABL,(USER)	;WE'RE BACK TO LOWER SEGMENT STUFF
	POPJ	P,
SPDON:				;USUALLY POPJ ABOVE CONTINUES HERE
;GET ONE AND TWO WORD FREES
>;GLOB
	MOVEM	A,INFTB		;FOR TYPE CHECKING
	HRLI	A,(<POINT 12,(3),29>) ;BYTE POINTER FOR PROPS FIELD
	MOVEM	A,PROPS
	MOVEM	B,DATM		;THIS IS FOR REFERENCING DATUMS.
GLOB <
	PUSHJ	P,GFREES	;WILL TRY TO USE HOLES IN INFOTAB,DATAB FOR ALLOC.
>;GLOB
; **** COMMENT HERE ON BUFACS PROBLEM *****
INDONE:	LPCOR	(FRCHLEN,LEABOT) ;GET CORE FOR "ERASE" SCB
	SETZM	SCBLNK(B)	;NOT CONSIDERED NESTED FOREACH
	SETZM	SCBCHN(USER)	;NO FREE SCB'S
	MOVEI	TAC1,(USER)	;SO FRGO WON'T CAUSE ILL MEM REF.
	JSP	FP,FRGO	        ;INITIALIZE "ERASE" SCB
;ALLOCATE INITIAL ITEM TYPES AND PNAMES
       	MOVE	B,SPLNK(USER)	;SPACE ALLOCATION LIST
PNMTYPLP:
	PUSH	P,B		;SAVE THROUGH CALLS
;;	SKIPE	A,$TINIT(B)     ;ITEM TYPE INITIALIZATION
;; \UR#7\ LH OF $TINIT NOW OVERLAP OK FLAG
	HRRZ	A,$TINIT(B)	;HERE LH($TINIT) USED FOR
				;LEAP WARNING SUPPRESSION
	JUMPE	A,.+2
	PUSHJ	P,INITIT
	SKIPE 	A,$PINIT(B)	;PRINTNAME INITIALIZATION
	PUSHJ	P,INTNAM
	POP	P,B
	HRRZ	B,(B)		;CDR SPACE ALLOCATION LIST
	JUMPN	B,PNMTYPLP
INITDN:
GLOB <
	NOSEC
>;GLOB
	POP	P,TAC1		;RESTORE AC.
	POPJ	P,		;GO AWAY...
DSCR MAIN DISPATCHER FOR LEAP

THIS IS THE MAIN ENTRY OF THIS CODE (I.E. "LEAP").
THE APPROPRIATE INTERPRETER ROUTINE IS CALLED.

 ****** AC'S SET UP FOR ALL INTERPRETER ROUTINES ******
USER		SET UP TO GOGTAB.
UUO1(USER)	CONTAINS THE USER'S RETURN ADDRESS.
FLAG		CONTAINS CONTROL WORD.. UNTOUCHED
P		PUSH-DOWN STACK HAS RETURN ADDRESS WORD POPPED OFF.

⊗;



HERE (LEAP)			;THIS HERE IS LEAP.
	MOVE	USER,GOGTAB
GLOB <
	MOVEI	TABL,(USER)	;AND FOR LOCAL TABLES.
>;GLOB
	SKIPN	HASMSK(USER)	;TEST TO SEE IF INITIALIZED ALREADY.
	 PUSHJ	 P,LPINI2	;NO -- GO DO IT.
	POP	P,UUO1(USER)	;RETURN ADDRESS
GLOB <
	TLNE	FLAG,GLBSRC
	MOVEI	TABL,GLUSER	;REFER TO UPPER SEG.
	RDSEC			;ENTER READING SECTION
>;GLOB
	XCT	ROUTABLE(FLAG)	;CALL THE ROUTINE.
?LEAV:				;UNIFORM EXIT LOCATION.
GLOB <
	PUSH	SP,P		;UNCLEAN HACK.
	MOVE	P,SP		;USE STRING STACK TEMPORARILY.
	NOSEC			;EXIT ANY SECTION
	POP	SP,P		;USE OLD STACK AGAIN
>;GLOB
	JRST	@UUO1(USER)

GLOB <				;MISCELLANEOUS....
INTERNAL GINFTB,GDATM,NOENTER,ENTERED,LKJBNO,MUTEX,GPROPS
MUTEX: -1			;FOR CRITICAL SECTION CHANGING ENTERED
LKJBNO: 	0
NOENTER:	-1	;GTR EQ 0 IF WRITING LOCKED OUT
GINFTB:         0               ;INDIRECT WORD FOR REFERING TO INFOTAB
GDATM:		0
GPROPS:		0		;HOLDS BYTE POINTER FOR ACCESSING PROPS FIELD
LEPINI:		-1
ENTERED:	-1



;HERE IS A RESET ROUTINE.
INTERNAL RE.MOD

RE.MOD:	SETOM	NOENTER
	SETOM	ENTERED
	SETOM	QUETCH
	SETZM	MESQ
	SETZM	JOBCNT		;THIS REALLY RESETS THE WORLD.
	SETZM	LKJBNO
	POPJ	P,
>;GLOB



;DISPATCH TABLE FOR THE LEAP INTERPRETER.
;WHEN COMPILER OF (FEB 19) IN USE WILL HAVE TO CHANGE ROUTABLE
;TO REFLECT NEW NO-OPS


ROUTABLE:
REPEAT 12,<JRST    	FOREC>	;0-11 -- FOREACH SEARCHES.
	JRST		FORGO	;12 -- START OF FOREACH STAT.
	PUSHJ P,	FRPOP	;13 -- POP FOREACH SATISFIERS INTO CORE.
	JRST		DOAG	;14 -- LOOP AT END OF FOREACH STAT.
	JRST		FRFAL	;15 -- IF A FOREACH BOOLEAN IF FALSE.
	PUSHJ P,    	MAKE	;16 -- MAKE AN ASSOCIATION.
	JRST        	BMAKE	;17 -- MAKE A BRACKETED TRIPLE.
ESTART:	
REPEAT 10,<PUSHJ P,  	ERASE>	;20-27 -- ERASES
	PUSHJ P,    	ISTRIPLE;30 -- ISTRIPLE (FOO)
SELET1:	
REPEAT 3,<PUSHJ P,  	SELECTOR>;31-33 FIRST,SECOND AND THIRD.
	PUSHJ P,	CORPOP 	;34 -- CORE INTO SATISFIERS(INVERSE OF 12)
LD0:	JRST       	LD1	;35 -- DERIVED SETS -- INSIDE FOREACH.
	JRST 	   	LD2	;36
	JRST 	   	LD3	;37
DSTART:	JRST 	   	D1	;40 -- DERIVED SETS -- NORMAL.
	JRST 	   	D2	;41
	JRST 	   	D3	;42
	JRST 	   	DELETE	;43 -- DELETE. -- NOTE: INDEX USED BY APPLY, TOO
	PUSHJ P,   	NEW	;44 -- REGULAR NEW.
	PUSHJ P,    	NEWART	;45 -- NEW (ARITHMETIC VALUE)
	JRST 	   	NEWARY	;46 -- NEW (ARRAY)
	PUSHJ P,	FDONS	;47 -- RELEASE THIS FOREACH STATEMENT.
	PUSHJ P,	PUTIN	;50 -- PUT X IN SET.
	PUSHJ P,	REMOV	;51 -- REMOVE X FROM SET.
	PUSHJ P,	SIP	;52 -- <A,B,C,D>
;; %AF% ! (1 OF 3) DIFFERENT BOOLEANS FOR LIST AND SET MEMBERSHIP
	PUSHJ P,	LSTIN	;53 -- BOOLEAN X IN  LIST?
	PUSHJ P,	COUNT	;54 -- LENGTH OF SET.
	PUSHJ P,	UNIT	;55 -- COP OF SET.
	PUSHJ P,	UNION	;56 -- SET UNION
	PUSHJ P,	INTER	;57 -- SET INTERSECTION.
	PUSHJ P,	SUBTRA	;60 -- SET SUBTRACTION.
	JRST		STORITM	;61 -- STORE A SET OR ITEM FROM STACK.
	JRST	STORBUTDONTREMOVE ;62 -- SAME AS 61, BUT LEAVE ON STACK.
;; %AF% ! (2 OF 3) DIFFERENT BOOLEANS FOR LIST AND SET MEMBERSHIP
	PUSHJ P,	STIN	;63 -- BOOLEAN X  IN  SET?
	JRST		POPSET	;64 -- (NO LONGER IN COMPILED CODE)
				;POP PERM SET INTO AC1
RELSTART:
REPEAT 6,<PUSHJ P,  	SETEST>	;65-72 -- SET RELATIONALS.
ISBEG:
REPEAT 10,< JRST     	ISIT >	;73-102 -- ANSWER TO A XOR B EQV C ?
BSTART:
REPEAT 10,<JRST       	BRITM>	;103-112 -- FIND ITEM FOR [A XOR B EQV C]
	JRST    	ITMRY	;113 -- FOR INITIALIZING ARRAY ITEMS.
	JRST     	ITMYR	;114 -- FOR INITIALIZING ARRAY ITEMS.
	JRST		STLOP	;115 -- LOP OF SET.
	JRST		BNDTRP	;116 -- BINDING FORM OF ASSOCIATIVE BOOLEAN
	JRST		SETCOP	;117 -- COPY A FORMAL SET.
	JRST		SETRCL	;120 -- RECLAIM A FORMAL SET.
	PUSHJ	P,	CATLST	;121 -- CONCATENATE TWO LISTS
	PUSHJ	P,	PUTAFTER ;122 -- INSERT IN LIST
	PUSHJ	P,	PUTBEFOR ;123 -- INSERT IN LIST
	JRST		SELFETCH ;124 -- SELECT ITEM FROM LIST
	PUSHJ	P,	TSBLST;125 -- LIST[EXPR TO EXPR]
	PUSHJ	P,	FSBLST	;126 --  LIST[EXPR FOR EXPR]
	JRST		SETLXT	;127 -- TRANSFORM LIST TO SET
	PUSHJ	P,	RPLAC ; 130 -- REPLACE ELEMENT OF LIST
	PUSHJ   P,	REMX   	;131 -- REMOVE ELEMENT FROM LIST
	PUSHJ	P,	REMALL	;132 -- REMOVE ALL INSTANCES OF AN ITEM
	PUSHJ	P,	PUTXA	;133 -- PUT AFTER INDEXED	
	PUSHJ	P,	PUTXB	;134 -- PUT BEFORE INDEXED
	PUSHJ	P,	LSTMAK	;135 -- FOR MAKING UP LISTS
	JRST		CALMP	;136 -- SPROUT MATCHING PROCEDURE
	JRST		STK4VL	;137 -- STACK ? LOCAL AS VAL PARM
	JRST		STK4LC	;140 -- STACK ? LOCAL AS MP PARM



DSCR DISPATCH TABLE FOR THE FOREACH SEARCHES

INDEXED BY THE FLAG CONTROL WORD NUMBER -- RESULT
IS ROUTINE NUMBER TO EXECUTE.  IF THE INDEX IS -1,
"FDONE" IS CALLED, WHICH AUTOMATICALLY FLUSHES THE
CURRENT FOREACH STATEMENT GROUP OF SEARCHES (I.E.
THE OUTERMOST SEARCH FAILED, AND IT IS TIME TO GO AWAY).

⊗;

	FDONE
ETAB:
SEROUT:	F1
	F4
	F3
	F5
	F2
	F7
	F6
	F8
	S2
	S1
CALINDX:RESMP

DSCR  ASSOCIATIVE SEARCH ROUTINES
⊗;
comment @
These are the 9 kinds of associative searches:
	f1		A XOR O EQV v
	f2		A XOR O EQV X
	f3		A XOR X EQV V
	f4		X XOR O EQV V
	f5		X XOR Y EQV V
	f6		A XOR X EQV Y
	f7		X XOR O EQV Y
	s1		x  IN  S
	s2		A  IN  S

These all use a "search control block" to describe the details
of the search.  Any bound items have values in the FPD stack,
at -ATTP(FPD),-OBJP(FPD), and -VALP(FPD) depending whether
they are attribute, object or value.  If these items are unbound,
then the stack entries contain the satisfier number (and hence
a description of a place where to put the result we find in the
search).

-TT1(FPD) and -T2(FPD) are used as temporaries by each routine --
they are used to store pointers into the data structure, and
to remember whether the search has been initialized once.
The initial values of these entries are -1 and 0 respectively.

Each search routine skips if it succeeds in finding an association
of the correct variety.  In this case, register A points to the
2 word cell which stores that association.  ERASE code counts
on this pointer, as do some other people (?).

If the search fails, or is exhausted, the normal (non-skipping)
return is taken.


@
;THE SEARCH ROUTINES.....

; A XOR O EQV V



F1:	AOSE	-TT1(FPD)	;THIS SEARCH CAN ONLY SUCCEED ONCE
	 POPJ	 P,		;SO FAIL RETURN IF WE'VE BEEN HERE BEFORE
	HASH	(A,<-ATTP(FPD)>,<-OBJP(FPD)>)
URLEAP	<
	MOVE	B,-MASK(FPD)	;GET DESIRED A-O FROM SCB
COMP:	HRRZ	A,(A)		;GET ADDR OF NEXT M.H. BLOCK
URSTAT	<
	AOS	RCNT1		;COUNT A PROBE
>;URSTAT
	JUMPE	A,CPOPJ		;IF NO MORE M.H. BLOCKS IN THE CONFLICT LIST,
				;GO FAIL-RETURN
	CAME	B,1(A)		;DO WE HAVE AN A-O MATCH HERE?
	 JRST	COMP		;GO DOWN CONFLICT LIST IF NOT
;A-O MATCH - NOW LOOK IN M.H. LIST FOR MATCHING VALUE
	HRRZ	B,-VALP(FPD)	;GET DESIRED VALUE
F11:	HLRZ	A,(A)		;GET ADDRESS OF NEXT VALUE BLOCK
URSTAT	<
	AOS	RCNT1
>;URSTAT
	JUMPE	A,CPOPJ		;IF NO MORE VALUE BLOCKS, GO FAIL-RETURN
	HRRZ	C,1(A)		;GET THIS VALUE
	CAIE	C,(B)		;HAVE WE A MATCH?
	 JRST	F11		;GO TRY AGAIN IF NOT
URSTAT	<
	AOS	RSUC1		;COUNT A SUCCESS
>;URSTAT
	AOS	(P)		;SO RETURN WILL SKIP
	POPJ	P,		;SUCCESS RETURN
>;URLEAP

NOURLEAP	<
	SKIPN	A,(A)		;SEE IF A-O-V IS THERE AT ALL
URSTAT	<
	 JRST	[AOS	RCNT1	;COUNT A PROBE
		POPJ	P, ]	;FAIL - NOTHING FOR THIS HASH VALUE
>;URSTAT
NOURSTAT<
	 POPJ	P,		;FAIL - NOTHING AT ALL FOR THIS HASH VALUE
>;NOURSTAT
COMP:	MOVE	B,1(A)		;PICK UP A-O-V
	XOR	B,-MASK(FPD)	;HAVE WE GOT IT?
	JUMPN	B,NO
YES:	AOS	(P)
URSTAT	<
	AOS	RCNT1
	AOS	RSUC1
>;URSTAT
	POPJ	P,		;SUCCESSFUL RETURN
NO:	TDNE	B,[ 777777770000];DO A-O AT LEAST MATCH?
	 JRST	[HRRZ	A,(A)	;CONFLICT POINTER
		JUMPN	A,COMP	;AND LOOK IF NONZERO
		POPJ	P,]	;FAIL OTHERWISE
	MOVE	B,1(A)
	TRNE	B,7777		;IS VALUE ZERO?
	 POPJ	P,		;NO -- HENCE CANNOT SUCCEED.
	HLRZ	A,(A)		;VALUE LINK POINTS TO MULTIPLE HITS.
VALE:	MOVE	B,1(A)		;THIS IS IT.
	CAMN	B,-MASK(FPD)	;COMPARE
	 JRST	 YES
URSTAT	<
	AOS	RCNT1
>;URSTAT
	HRRZ	A,(A)		;MULTIPLE HITS LIST
	JUMPN	A,VALE
	POPJ	P,		;FAILED.
>;NOURLEAP


; A XOR O EQV X

F2:	AOSE	-TT1(FPD)	;BEEN HERE BEFORE?
 	 JRST	 NEXT		;YESSIR
URLEAP	<
	HRRZ	B,-MASK(FPD)	;PICK UP OBJECT ...
	HLRZ	A,-MASK(FPD)	;... AND ATTRIBUTE
	HASH	(A,A,B)
URSTAT	<
	AOS	RCNT2
>;URSTAT
	SKIPN	A,(A)		;SEE IF THERE'S A M.H. HEADER FOR THIS HASH
	 POPJ	P,		;NOTHING'S THERE, SO FAIL
	MOVE	B,-MASK(FPD)	;PICK UP DESIRED A-O WORD
COMP2:	CAMN	B,1(A)		;DOES THIS M.H. HEADER BLOCK MATCH?
	 JRST	YES2		;GO WORRY ABOUT VALUE BLOCKS IF IT DOES
URSTAT <
;------------------------LEAP STATISTICS INSTRUCTION------------
	AOS 	RCNT2		;INCREMENT LEAP STATISTIC
;--------------------------------------------------------------
>;URSTAT
	HRRZ	A,(A)		;GO DOWN CONFLICT LIST TO NEXT M.H. HEADER
	JUMPN	A,COMP2		;GO BACK & TRY AGAIN IF THERE IS ONE
	POPJ	P,		;OTHERWISE FAILURE EXIT

YES2:	HLRZ	A,(A)		;GET FIRST VALUE BLOCK
YS21:	HLRZ	C,(A)		;GET POINTER TO NEXT ONE
	MOVEM	C,-T2(FPD)	;SAVE IT FOR NEXT TIME
	HRRZ	B,1(A)		;PICK UP VALUE FROM VALUE BLOCK
	HRRZ	C,-VALP(FPD)	;LOCAL # FOR VALUE
	HRLM	B,@MC(FRTAB)	;STORE IT IN SATISFIER TABLE
	AOS	(P)		;SIMULATE A SKIP ON RETURN
URSTAT <
;---------------------LEAP STATISTICS INSTRUCTION---------------
	AOS	RCNT2		;INCREMENT LEAP STATISTIC
	AOS	RSUC2		;INCREMENT SUCCESS COUNT
;---------------------------------------------------------------
>;URSTAT
	POPJ	P,		;SUCCESSFUL RETURN


NEXT:	SKIPE	-VALP(FPD)	;ANY ?
	 SKIPN	A,-T2(FPD)	;GET NEXT ONE
	 POPJ	 P,		;NONE.
	JRST	YS21		;BACK WE GO...
>;URLEAP
NOURLEAP<
	LDB	B,[POINT ITLEN,-MASK(FPD),23]	;PICK UP OBJECT
	LDB	A,[POINT ITLEN,-MASK(FPD),ITLEN-1] ;PICK UP ATTRIBUTE
	HASH	(A,A,B)
	SKIPN	A,(A)		;CHECK TO SEE IF A-O-V IS THERE AT ALL
	JRST	[URSTAT <
		AOS	RCNT2	;STATISTIC INCREMENT
		>; URSTAT
		POPJ	P,	;FAIL
		]
COMP2:	MOVE	B,1(A)
	TRZ	B,7777		;MASK OUT VALUE.
	CAMN	B,-MASK(FPD)	;SEE IF IT MATCHES...
	 JRST	 YES2

URSTAT <
;------------------------LEAP STATISTICS INSTRUCTION------------
	AOS 	RCNT2		;INCREMENT LEAP STATISTIC
;--------------------------------------------------------------
>;URSTAT

	HRRZ	A,(A)		;CONFLICT.
	JUMPN	A,COMP2		;LOOP
	POPJ	P,		;FAILURE

YES2:	MOVE	B,1(A)		;PICK IT UP AGAIN.
	TRNE	B,7777		;COULD STILL BE A MULTIPLE HIT.
	 JRST	 PUT		;NOPE
	HLRZ	A,(A)		;POINTER TO MULTIPLE HITS.
	HRRZ	C,(A)		;POINTER TO NEXT ONE.
	MOVEM	C,-T2(FPD)	;SAVE FOR NEXT TIME.
PUTA:	MOVE	B,1(A)		;PICK UP A-O-V
PUT:	MOVE	C,-VALP(FPD)	;LOCAL NUMBER FOR VALUE
	DPB	B,MC(FRTAB)	;PUT IN SATISFIER TABLE.
	AOS	(P)

URSTAT <
;---------------------LEAP STATISTICS INSTRUCTION---------------
	AOS	RCNT2		;INCREMENT LEAP STATISTIC
	AOS	RSUC2		;INCREMENT SUCCESS COUNT
;---------------------------------------------------------------
>;URSTAT

	POPJ	P,		;SUCCESSFUL RETURN


NEXT:	SKIPE	-VALP(FPD)	;ANY ?
	SKIPN	A,-T2(FPD)	;GET NEXT ONE
	 POPJ	 P,		;NONE.
	HRRZ	C,(A)		;POINTER TO NEXT.
	MOVEM	C,-T2(FPD)	;SAVE IT.
	JRST	PUTA		;GO GET THE VALUE.
>;NOURLEAP

; A XOR X EQV V

F3:	AOSE	-TT1(FPD)	;FIRST TIME
	 JRST	 NEXT3		;NO
	MOVE	A,-VALP(FPD)	;VALUE
	ADD	A,INFOTAB(TABL)	;PREPARE TO GET VALUE LINK
	HLRZ	A,(A)		;VALUE LINK!
URLEAP	<
NN:	JUMPE	A,CPOPJ		;IF ZERO, THERE IS NONE.
	HLRZ	B,1(A)		;GET BACK POINTER TO M.H. HEADER FOR THIS ASSOC
	HLRZ	C,1(B)		;GET ATTRIBUTE FROM M.H. HEADER
URSTAT <
;---------------------LEAP STATISTICS INSTRUCTION---------------
	AOS	RCNT3		;INCREMENT STATISTIC
;---------------------------------------------------------------
>;URSTAT
	CAME	C,-ATTP(FPD)	;IS IT THE DESIRED ONE?
	JRST	[HRRZ	A,(A)	;GET POINTER TO NEXT VALUE BLOCK ON VALUE LIST
		JRST	NN]	;GO SEE IF IT WILL DO
	HRRZ	C,(A)		;GET POINTER TO NEXT VALUE BLOCK
	MOVEM	C,-T2(FPD)	;STASH IT AWAY FOR NEXT TIME
	HRRZ	B,1(B)		;GET OBJECT FROM M.H. HEADER
	MOVE	C,-OBJP(FPD)	;LOCAL # FOR OBJECT
	HRLM	B,@MC(FRTAB)	;STORE OBJECT IN SATISFIER TABLE
	AOS	(P)		;SIMULATE SKIP FOR SUCCESS-RETURN
URSTAT<
;-----------------LEAP STATISTICS--------------------------
	AOS	RSUC3		;INCREMENT SUCCESS COUNT
;----------------------------------------------------------
>;URSTAT
	POPJ	P,		;GOODBYE
>;URLEAP

NOURLEAP<
	JUMPE	A,CPOPJ		;IF ZERO, THERE IS NONE.
NN:	MOVE	B,1(A)		;PICK UP A-O-V
	AND	B,[BYTE (ITLEN) 7777,0,7777]

URSTAT <
;---------------------LEAP STATISTICS INSTRUCTION---------------
	AOS	RCNT3		;INCREMENT STATISTIC
;---------------------------------------------------------------
>;URSTAT

	CAME	B,-MASK(FPD)	;IS THIS THE ONE?
	 JRST	 NO3
	HLRZ	C,(A)		;VALUE LINK
	BRACKP	C		;IF BRACKETED TRIPLE THEN
	 HLRZ	 C,(C)		;PASS UP BRACKET NUMBER
	MOVEM	C,-T2(FPD)
	MOVE	C,-OBJP(FPD)	;OBJECT NUMBER
	LDB	B,[POINT ITLEN,1(A),23]
	DPB	B,MC(FRTAB)	;STORE IN SATISFIER TABLE.
	AOS	(P)	
URSTAT<
;-----------------LEAP STATISTICS--------------------------
	AOS	RSUC3		;INCREMENT SUCCESS COUNT
;----------------------------------------------------------
>;URSTAT
	POPJ	P,

NO3:	HLRZ	A,(A)		;VALUE LINK
	BRACKP	A
	 HLRZ	 A,(A)		;PAST BRACKETED ITEM NUMBER.
	JUMPN	A,NN		;LOOP UNTIL EXHAUSTED
	POPJ	P,		;EXHAUSTED.

>;NOURLEAP
NEXT3:	MOVE	A,-T2(FPD)	;GET THE LAST POINTER
	SKIPE	-OBJP(FPD)	;OBJECT = ANY?
	 JUMPN	A,NN		; -- WANT TO DO SEARCH AGAIN.
	POPJ	P,
; X XOR O EQV V


F4:	AOSE	-TT1(FPD)	;FIRST TIME
	 JRST	 NEXT4		;NO
	MOVE	A,-VALP(FPD)	;VALUE
	ADD	A,INFOTAB(TABL)	;PREPARE TO GET VALUE LINK
	HLRZ	A,(A)		;VALUE LINK!
URLEAP	<
NN4:	JUMPE	A,CPOPJ		;IF ZERO, THERE IS NONE.
	HLRZ	B,1(A)		;GET BACK POINTER TO M.H. HEADER FOR THIS ASSOC
	HRRZ	C,1(B)		;GET OBJECT FROM M.H. HEADER
URSTAT <
;---------------------LEAP STATISTICS INSTRUCTION---------------
	AOS	RCNT4		;INCREMENT STATISTIC
;---------------------------------------------------------------
>;URSTAT
	CAME	C,-OBJP(FPD)	;IS IT THE DESIRED ONE?
	 JRST	[HRRZ	A,(A)	;GET POINTER TO NEXT VALUE BLOCK ON VALUE LIST
		JRST	NN4]	;GO SEE IF IT WILL DO
	HRRZ	C,(A)		;GET POINTER TO NEXT VALUE BLOCK
	MOVEM	C,-T2(FPD)	;STASH IT AWAY FOR NEXT TIME
	HLRZ	B,1(B)		;GET ATTRIBUTE FROM M.H. HEADER
	MOVE	C,-ATTP(FPD)	;LOCAL # FOR ATTRIBUTE
	HRLM	B,@MC(FRTAB)	;STORE ATTRIBUTE IN SATISFIER TABLE
	AOS	(P)		;SIMULATE SKIP FOR SUCCESS-RETURN
URSTAT<
;-----------------LEAP STATISTICS--------------------------
	AOS	RSUC4		;INCREMENT SUCCESS COUNT
;----------------------------------------------------------
>;URSTAT
	POPJ	P,		;GOODBYE

NEXT4:	MOVE	A,-T2(FPD)	;GET THE LAST POINTER
	SKIPE	-ATTP(FPD)	;ATTRIBUTE = ANY?
	 JUMPN	A,NN4		; -- WANT TO DO SEARCH AGAIN.
	POPJ	P,
>;URLEAP

NOURLEAP<
	JUMPE	A,CPOPJ		;FAIL
NN4:	MOVE	B,1(A)		;A-O-V WORD

URSTAT <
;----------------------LEAP STATISTIC INSTRUCTION---------------
	AOS	RCNT4		;INCREMENT STATISTIC
;---------------------------------------------------------------
>;URSTAT

	TLZ	B,777700	;MASK OFF ATTRIBUTE
	CAME	B,-MASK(FPD)	;IS THIS THE ONE?
	 JRST	 NO4
	HLRZ	C,(A)		;VALUE LINK
	BRACKP	C		;TEST FOR BRACKETED TRIPLE.
	 HLRZ	 C,(C)		;PASS UP BRACKET ID NUMBER
	MOVEM	C,-T2(FPD)	;SAVE FOR NEXT TIME.
	MOVE	C,-ATTP(FPD)	;ATTRIBUTE ID NUMBER
	LDB	B,[POINT ITLEN,1(A),ITLEN-1];ATTRIBUTE NUMBER
	DPB	B,MC(FRTAB)	;STORE IN SATISFIER TABLE.
	AOS	(P)	
URSTAT <
;----------------LEAP STATISTICS----------------------------
	AOS	RSUC4		;INCREMENT SUCCESS COUNT
;-----------------------------------------------------------
>;URSTAT
	POPJ	P,		;RETURN....

NO4:	HLRZ	A,(A)		;VALUE LINK
	BRACKP	A		;TEST FOR BRACKETED TRIPLE.
	 HLRZ	 A,(A)		;PAST BRACKETED ITEM NUMBER.
	JUMPN	A,NN4
	POPJ	P,		;FAILED.

NEXT4:	MOVE	A,-T2(FPD)	;POINTER
	SKIPE	-ATTP(FPD)	; IS THE ATTRIBUTE "ANY" ?
	JUMPN	A,NN4		; NO -- TRY TO CONTINUE SEARCH
	POPJ	P,
>;NOURLEAP
; X XOR Y EQV V


F5:	MOVE	A,-T2(FPD)	;FOR NEXT......
	AOSE	-TT1(FPD)	;BEEN HERE BEFORE?
	 JRST	 NEXT5		;YUP
	MOVE	A,-VALP(FPD)	;VALUENUMBER
	ADD	A,INFOTAB(TABL)	;GET READY TO GET
	HLRZ	A,(A)		;VALUE LINK
	JRST	NEXT6		;DO NOT CHECK FOR "ANY" FIRST TIME - KKP
NEXT5:	SKIPN	-ATTP(FPD)	;IF BOTH ARGS ARE "ANY", THEN
	SKIPE	-OBJP(FPD)	;RETURN IMMEDIATELY.
NEXT6:	SKIPN	A		;NOT THERE.
	POPJ	P,

URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION-----------
	AOS	RCNT5		;INCREMENT STATISTIC
;-----------------------------------------------------------
>;URSTAT

URLEAP	<
	HRRZ	B,(A)		;NEXT VALUE POINTER
	MOVEM	B,-T2(FPD)	;SAVE IT FOR NEXT TIME
	HLRZ	D,1(A)		;GET BACK POINTER TO M.H. HEADER
	MOVE	D,1(D)		;PICK UP ATTR-OBJ WORD
	MOVE	C,-ATTP(FPD)	;LOCAL # FOR ATTRIBUTE
	HLLM	D,@MC(FRTAB)	;STORE ATTRIBUTE IN SATISFIER TABLE
;; #NL# A XOR ANY EQV ANY , BOTH ANY'S DON'T HAVE TO MATCH;
	SKIPE	C,-OBJP(FPD)	;OBJECT ID NUMBER, IF ANY DON' WORRY
	CAME	C,-ATTP(FPD)	;ATTRIB AND OBJECT TO BE BOUND THE SAME?
	JRST	.+2
;; #NL#
	JRST	[HLRZ	C,D	;ATTRIBUTE FROM A-O WORD
		HRRZ	D,D	;CLEAR L.H. D LEAVING OBJECT ONLY
		CAIN	C,(D)	;THE SAME?
		 JRST	ROSP5	;SINCE OBJECT IS ATTRIBUTE, IT'S ALREADY
				;STORED, SO JUST SUCCEED-RETURN
		MOVE	A,B	 ;TRY AGAIN
		JRST NEXT6]
	HRLM	D,@MC(FRTAB)	;STORE OBJECT IN SATISFIER TABLE
ROSP5:
URSTAT	<
	AOS	RSUC5
>;URSTAT
>;URLEAP

NOURLEAP	<
	HLRZ	C,(A)		;NEXT VALUE POINTER
	BRACKP	C		;TEST FOR BRACKETED TRIPLE.
	 HLRZ	 C,(C)		;PASS UP BRACKET ID NUMBER
	MOVEM	C,-T2(FPD)
	MOVE	B,1(A)		;A-O-V WORD.
	ROT	B,ITLEN		;ATTRIBUTE IS NOW LOW.
	MOVE	C,-ATTP(FPD)	;ATTRIBUTE NUMBER
	DPB	B,MC(FRTAB)	;STORE IN SATISFIER TABLE.
	ROT	B,ITLEN		;OJECT IS NOW LOW
;; #NL# A XOR ANY EQV ANY , BOTH ANY'S DON'T HAVE TO MATCH;
	SKIPE	C,-OBJP(FPD)	;OBJECT ID NUMBER, IF ANY DON' WORRY
	CAME	C,-ATTP(FPD)	;ATTRIB AND OBJECT TO BE BOUND THE SAME?
	JRST	.+2
;; #NL#
	JRST	[LDB D,MC(FRTAB) ;BINDING FOR ATTRIB.
		 ANDI B,7777	;JUST THE OBJECT
		 CAIN D,(B)	;THE SAME?
		JRST [
			URSTAT < AOS RSUC5 >;URSTAT
			JRST	AOSP
		     ]
		 MOVE A,-T2(FPD) ;TRY AGAIN
		 JRST NEXT6]
	DPB	B,MC(FRTAB)
>;NOURLEAP

AOSP:	AOS	(P)
	POPJ	P,

; A XOR X EQV Y


NOURHASH <
F6:	AOSE	-TT1(FPD)
	JRST	[SKIPE  -VALP(FPD);IS VALUE "ANY" ?
		 JRST	GRT6	;NO -- CONTINUE SEARCH.
		 SKIPE	-OBJP(FPD);IS OBJECT "ANY"
		 JRST	UPDAT	;NO -- GO TO NEXT OBJECT.
		 POPJ	P,	;YES-- IT WAS ANY AND ANY
	]
GLOB <
	TLNE	FLAG,GLBSRC	;IF GLOBAL SEARCH,THEN
	JRST	[MOVE A,MAXITM+GLUSER	;START THE COUNT AT LOWEST GL. ITEM-KKP
		 DPB	A,[POINT ITLEN,-MASK(FPD),2*ITLEN-1] ;
		 MOVEI B,(A)	;SO WE DON'T HAVE TO DO LDB - KKP
		 JRST	UPDAT+3]; AND JUMP AROUND IT - KKP
>;GLOB

UPDAT:	MOVEI	A,1⊗ITLEN	; 10000
	ADDB	A,-MASK(FPD)	; GO UP ONE ITEM NUMBER OBJ. POSITION
	LDB	B,[POINT ITLEN,A,2*ITLEN-1];OBJECT
GLOB <
	CAIL	B,TOPITM	;HAVE WE GONE OFF COMPLETELY??
	 POPJ	P,
	CAMGE	B,MAXITM+GLUSER	; THIS MEANS ITEM IN GLOBAL AREA.
	CAMG	B,MAXITM(USER)	;THIS TESTS FOR ITEM IN LOCAL AREA.
	 JRST    OKIT1		;FINE...
	MOVE	B,MAXITM+GLUSER
	DPB	B,[POINT ITLEN,-MASK(FPD),2*ITLEN-1] ;PUT IT DOWN.
OKIT1:
>;GLOB
NOGLOB <
	CAMLE	B,MAXITM(USER)	;GONE FAR ENOUGH?
	 POPJ	 P,		;YES
>;NOGLOB
	MOVE	C,-OBJP(FPD)	;OBJECT ID NUMBER.
	DPB	B,MC(FRTAB)	;FILL SATISFIER
	SETZM	-T2(FPD)	;RESTART SEARCH
	SETOM	-TT1(FPD)	;RESTART SEARCH
GRT6:
URSTAT <
	PUSH	P,RCNT2
	PUSH	P,RSUC2
	SETZM	RCNT2
	>;URSTAT
	PUSHJ	P,F2		; A XOR O EQV X
	 JRST	[ URSTAT <
		MOVE	B,RCNT2
		ADDM	B,RCNT6
		POP	P,RSUC2
		POP	P,RCNT2
		>;URSTAT
		JRST 	UPDAT]
URSTAT <MOVE	B,RCNT2
	ADDM	B,RCNT6
	POP	P,RSUC2
	POP	P,RCNT2
	>;URSTAT
	SKIPE	C,-VALP(FPD)	;ANY
	CAME	C,-OBJP(FPD)    ;SAME OBJ,VAL ITEMVAR?
	JRST	ROSP6		;NORMAL
	LDB	D,[POINT ITLEN,1(A),35] ;THE VALUE
	LDB	C,[POINT ITLEN,1(A),2*ITLEN-1];THE OBJECT
	CAIE	D,(C)		;THE SAME?
	JRST	GRT6		;NO,TRY AGAIN.
ROSP6:	
;-----------------LEAP STATISTICS------------------------
URSTAT<	AOS	RSUC6	>;URSTAT
;--------------------------------------------------------
	JRST	AOSP

; X XOR O EQV Y

F7:	AOSE	-TT1(FPD)
	JRST	[SKIPE	-VALP(FPD);IS VALUE "ANY" 
		 JRST	GRT7	;NO -- GO AHEAD
		 SKIPE	-ATTP(FPD);IS ATTRIBUTE "ANY" ?
		 JRST	UPDAT7	;NO -- GET ANOTHER ATTRIBUTE
		 POPJ	P,]	;NO -- GO AHEAD
GLOB <
	TLNE	FLAG,GLBSRC	;IF GLOBAL SEARCH.
	JRST	[MOVE A,MAXITM+GLUSER; SEE COMMENT ON LAST SEARCH - KKP
		 DPB	A,[POINT ITLEN,-MASK(FPD),ITLEN-1]; START COUNT
		MOVEI B,(A)
		 JRST	UPDAT7+3]	;AT RIGHT PLACE.
>;GLOB
UPDAT7:	MOVSI	A,(1⊗(2*ITLEN))	; 1000
	ADDB	A,-MASK(FPD)	;UPDATE MASK ATTRIBUTE NUMBER
	LDB	B,[POINT ITLEN,A,ITLEN-1];ATTRIBUTENUMBER
GLOB <
	CAIL	B,TOPITM
	 POPJ	 P,		;GONE TOO FAR.
	CAMGE	B,MAXITM+GLUSER
	CAMG	B,MAXITM(USER)	;IN ALLOWED RANGE??
	 JRST	 OKIT2		;YES
	MOVE	B,MAXITM+GLUSER	;NO -- BUMP IT UP.
	DPB	B,[POINT ITLEN,-MASK(FPD),ITLEN-1];PUT IT AWAY.
OKIT2:
>;GLOB
NOGLOB <
	CAMLE	B,MAXITM(USER)	;GONE FAR ENOUGH?
	 POPJ	 P,
>;NOGLOB
	MOVE	C,-ATTP(FPD)	;ATTRIBUTE ID NUMBER
	DPB	B,MC(FRTAB)	;FILL SATISFIER
	SETZM	-T2(FPD)	;RESTART SEARCH
	SETOM	-TT1(FPD)	;RESTART SEARCH
GRT7:
URSTAT <
	PUSH	P,RCNT2
	PUSH	P,RSUC2
	SETZM	RCNT2
	>;URSTAT
	PUSHJ	P,F2		; A XOR O EQV X
	 JRST	[ URSTAT <
		MOVE	B,RCNT2
		ADDM	B,RCNT7
		POP	P,RSUC2
		POP	P,RCNT2
		>;URSTAT
		JRST 	UPDAT7]
URSTAT <MOVE	B,RCNT2
	ADDM	B,RCNT7
	POP	P,RSUC2
	POP	P,RCNT2
	>;URSTAT
	SKIPE	C,-VALP(FPD)	;THE VALUE SAT NO.
	CAME	C,-ATTP(FPD)	;THE ATTIB SAT NO.
	JRST	ROSP7		;NOT SAME OR VAL ANY
	LDB	D,[POINT ITLEN,1(A),35]; THE VALUE
	LDB	C,[POINT ITLEN,1(A),ITLEN-1]; THE ATTRIB
	CAIE	D,(C)		;THE SAME?
	JRST	GRT7		;NO, TRY AGAIN
ROSP7:	
;--------------LEAP STATISTICS------------------------------
URSTAT<	AOS	RSUC7	>;URSTAT
;-----------------------------------------------------------
	JRST	AOSP

>;NOURHASH

URHASH <
;	A XOR X EQV Y

F6:	AOSE 	-TT1(FPD)		;HAVE WE BEEN HERE BEFORE?	
	 JRST 	[SOS 	-TT1(FPD)	;UNDO DAMAGE FROM ABOVE
		 SKIPE	-VALP(FPD)	;IS VALUE ANY?
		  JRST 	CONT6		;IF NOT GET NEXT ONE
		 SKIPE 	-OBJP(FPD)	;IS OBJECT ANY?
		  JRST   NXT6		;GET NEXT OBJECT
		 POPJ	P,	]	;JUST FAIL RETURN IF BOTH ANY
URLEAP	<
	HLRZ	A,-MASK(FPD)	;PICK UP DESIRED ATTRIBUTE
>;URLEAP
NOURLEAP	<
	LDB	A,[POINT ITLEN, -MASK(FPD), ITLEN-1]
>;NOURLEAP
	LSH 	A,@RMASK3(TABL)	;BUILD RESULT OF HASHING WITH ZERO
	TRZ	A,@RMASK4(TABL)
	AND	A,HASMSK(TABL)
	MOVEM	A,-TT1(FPD)	;SAVE HASH OFFSET
	JRST	UPDT6
UPDAT6:	AOS	A,-TT1(FPD)	;INCREMENT HASH OFFSET
	AND     A,RMASK4(TABL)	;HAVE WE TRIED ALL POSSIBILITIES?
	JUMPE	A,CPOPJ		;IF SO, FAIL-RETURN
	MOVE	A,-TT1(FPD)	;PICK UP HASH OFFSET AGAIN
UPDT6:	ADD	A,HASTAB(TABL)	;MAKE HASH POINTER
	SKIPN	A,(A)		;IS ANYTHING THERE?
URSTAT	<
	 JRST	[AOS	RCNT6
		JRST	UPDAT6]
>;URSTAT
NOURSTAT<
	 JRST	UPDAT6		;TRY THE NEXT HASH POSITION
>;NOURSTAT

URLEAP	<
COMP6:	HLLZ	B,1(A)		;GET ATTRIBUTE FROM THIS M.H. BLOCK
URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION-------------
	AOS	RCNT6
;---------------------------------------------------------------
>;URSTAT
	CAMN	B,-MASK(FPD)	;IS IT THE ONE WE'RE LOOKING FOR?
	 JRST	YES6		;GOOD-OH
	HRRZ	A,(A)		;GO DOWN CONFLICT LIST TO NEXT M.H.
	JUMPN	A,COMP6		;SEE IF ITS ATTRIBUTE IS O.K.
	JRST	UPDAT6		;OTHERWISE TRY A NEW HASH POSITION

YES6:	HRRZ	B,(A)		;GET POINTER TO NEXT M.H. HEADER
	HRRZM	B,-T2(FPD)	;SAVE IT FOR NEXT TIME
	HRRZ	B,1(A)		;PICK UP OBJECT FOR THESE ASSOCIATIONS
	MOVE	C,-OBJP(FPD)	;LOCAL # FOR OBJECT
	HRLM	B,@MC(FRTAB)	;SAVE IT IN SATISFIER BLOCK
	HLRZ	A,(A)		;GET ADDR OF FIRST VALUE BLOCK
YES6A:	HLRZ	D,(A)		;ADDR OF NEXT VALUE BLOCK
URSTAT	<
	AOS	RCNT6
>;URSTAT
	HRLM	D,-T2(FPD)	;SAVE IT FOR NEXT TIME
	HRRZ	D,1(A)		;GET VALUE ITEM FROM THIS VALUE BLOCK
	SKIPN	C,-VALP(FPD)	;PICK UP LOCAL # FOR VALUE
URSTAT	<
	 JRST	[ROSP6:	AOS	RSUC6
			JRST	AOSP
		]
>;URSTAT
NOURSTAT<
	 JRST	AOSP		;SUCCEED-RETURN IF IT'S ANY
>;NOURSTAT
	HRLM	D,@MC(FRTAB)	;STORE VALUE IN SATISFIER TABLE
	CAIE	B,(D)		;IF VALUE & OBJECT ITEMS ARE THE SAME ...
	CAME	C,-OBJP(FPD)	;... OR THE LOCALS ARE DIFFERENT ...
URSTAT	<
	 JRST	ROSP6
>;URSTAT
NOURSTAT<
	 JRST	AOSP		;... THEN EVERYTHING'S COOL
>;NOURSTAT
;IF WE FALL THROUGH HERE, WE WERE LOOKING FOR AN ASSOCIATION WITH IDENTICAL
;OBJECT AND VALUE, WE DIDN'T FIND IT, AND WE HAVE TO KEEP LOOKING.
CONT6:	HLRZ	A,-T2(FPD)	;NEXT VALUE BLOCK ON M.H. LIST
	JUMPN	A,YES6A
NXT6:	HRRZ	A,-T2(FPD)	;NEXT M.H. BLOCK ON CONFLICT LIST
	JUMPN	A,COMP6
	JRST	UPDAT6		;IF ALL ELSE FAILS, TRY HASH
>;URLEAP
NOURLEAP	<
COMP6:	MOVE B,1(A)
	AND	B,[777700000000]
	CAMN	B,-MASK(FPD)
	JRST	YES6
	HRRZ	A,(A)

URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION-------------
	AOS	RCNT6
;---------------------------------------------------------------
>;URSTAT

	JUMPN	A,COMP6
	JRST	UPDAT6
YES6:	HRRZ	C,(A)
	MOVEM	C,-T2(FPD)
	MOVE	B,1(A)
	TRNE	B,1⊗ITLEN-1
	JRST	PUT6
	HLRZ	A,(A)
NEXTH6:	HRL	C,(A)
	HRR	C,-T2(FPD)
	MOVEM	C,-T2(FPD)
PUT6:	MOVE	B,1(A)

URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION------------
	AOS	RCNT6
;--------------------------------------------------------------
>;URSTAT

	MOVE 	C,-VALP(FPD)
	DPB	B,MC(FRTAB)
	LSH	B,-14
	MOVE	C,-OBJP(FPD)
	DPB	B,MC(FRTAB)
	SKIPE	C,-VALP(FPD)
	CAME	C,-OBJP(FPD)
	JRST	ROSP6
	MOVE	B,1(A)
	LDB	C,[POINT ITLEN,B,35]
	LDB	D,[POINT ITLEN,B,2*ITLEN-1]
	CAIN	D,(C)
	JRST	ROSP6
CONT6:	HLRZ	A,-T2(FPD)
	JUMPN	A,NEXTH6
NXT6:	HRRZ	A,-T2(FPD)
	JUMPN	A,COMP6
	JRST	UPDAT6
ROSP6:
;-----------LEAP STATISTICS-------------------------------
URSTAT<	AOS	RSUC6	>;URSTAT
;---------------------------------------------------------
	JRST	AOSP
>;NOURLEAP

; X XOR O EQV Y
F7:	AOSE 	-TT1(FPD)	
	JRST 	[SOS 	-TT1(FPD)
		 SKIPE	-VALP(FPD)
		 JRST 	CONT7
		 SKIPE 	-ATTP(FPD)
		 JRST   NEXT7
		 POPJ	P,	]
URLEAP	<
	HRRZ	A,-MASK(FPD)	;PICK UP DESIRED OBJECT
>;URLEAP
NOURLEAP	<
	LDB 	A,[POINT ITLEN, -MASK(FPD), 2*ITLEN-1]
>;NOURLEAP
	AND	A,RMASK1(TABL)
	MOVEM	A,-TT1(FPD)
	JRST	UPDT7
UPDAT7:	MOVE	A,RMASK2(TABL)
	ADDB	A,-TT1(FPD)
	TRZ	A,@RMASK1(TABL)
	AND	A,HASMSK(TABL)
	JUMPE	A,CPOPJ		;FAIL-RETURN IF WE'VE TRIED EVERYTHING
	MOVE	A,-TT1(FPD)
UPDT7:	ADD	A,HASTAB(TABL)
	SKIPN	A,(A)
URSTAT	<
	 JRST	[AOS	RCNT7
		JRST	UPDAT7]
>;URSTAT
NOURSTAT<
	 JRST	UPDAT7		;TRY AGAIN IF NOBODY'S HOME
>;NOURSTAT
;INCREMENT LEAP STATISTIC (SEE ABOVE)

URLEAP	<
COMP7:	HRRZ	B,1(A)		;PICK UP OBJECT FOR THESE ASSOCIATIONS
URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION-------------
	AOS	RCNT7
;---------------------------------------------------------------
>;URSTAT
	CAMN	B,-MASK(FPD)
	JRST	YES7
	HRRZ	A,(A)
	JUMPN	A,COMP7
	JRST	UPDAT7
YES7:	HRRZ	B,(A)		;GET POINTER TO NEXT M.H. HEADER
	HRRZM	B,-T2(FPD)	;SAVE IT FOR NEXT TIME
	HLRZ	B,1(A)		;PICK UP ATTRIBUTE FOR THESE ASSOCIATIONS
	MOVE	C,-ATTP(FPD)	;LOCAL # FOR ATTRIBUTE
	HRLM	B,@MC(FRTAB)	;SAVE IT IN SATISFIER BLOCK
	HLRZ	A,(A)		;GET ADDR OF FIRST VALUE BLOCK
YES7A:	HLRZ	D,(A)		;ADDR OF NEXT VALUE BLOCK
URSTAT	<
	AOS	RCNT7
>;URSTAT
	HRLM	D,-T2(FPD)	;SAVE IT FOR NEXT TIME
	HRRZ	D,1(A)		;GET VALUE ITEM FROM THIS VALUE BLOCK
	SKIPN	C,-VALP(FPD)	;PICK UP LOCAL # FOR VALUE
URSTAT	<
	 JRST	[
		ROSP7:	AOS	RSUC7
			JRST	AOSP
		]
>;URSTAT
NOURSTAT<
	 JRST	AOSP		;SUCCEED-RETURN IF IT'S ANY
>;NOURSTAT
	HRLM	D,@MC(FRTAB)	;STORE VALUE IN SATISFIER TABLE
	CAIE	B,(D)		;IF VALUE & ATTRIBUTE ITEMS ARE THE SAME ...
	CAME	C,-ATTP(FPD)	;... OR THE LOCALS ARE DIFFERENT ...
URSTAT	<
	 JRST	ROSP7
>;URSTAT
NOURSTAT<
	 JRST	AOSP		;... THEN EVERYTHING'S COOL
>;NOURSTAT
;IF WE FALL THROUGH HERE, WE WERE LOOKING FOR AN ASSOCIATION WITH IDENTICAL
;ATTRIBUTE AND VALUE, WE DIDN'T FIND IT, AND WE HAVE TO KEEP LOOKING.
CONT7:	HLRZ	A,-T2(FPD)	;NEXT VALUE BLOCK ON M.H. LIST
	JUMPN	A,YES7A
NEXT7:	HRRZ	A,-T2(FPD)	;NEXT M.H. BLOCK ON CONFLICT LIST
	JUMPN	A,COMP7
	JRST	UPDAT7		;IF ALL ELSE FAILS, TRY HASH
>;URLEAP
NOURLEAP	<
COMP7:	MOVE B,1(A)
	AND	B,[000077770000]
	CAMN	B,-MASK(FPD)
	JRST	YES7
	HRRZ	A,(A)

URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION-------------
	AOS	RCNT7
;---------------------------------------------------------------
>;URSTAT

	JUMPN	A,COMP7
	JRST	UPDAT7
YES7:	HRRZ	C,(A)
	MOVEM	C,-T2(FPD)
	MOVE	B,1(A)
	TRNE	B,1⊗ITLEN-1
	JRST	PUT7
	HLRZ	A,(A)
NEXTH7:	HRL	C,(A)
	HRR	C,-T2(FPD)
	MOVEM	C,-T2(FPD)
PUT7:	MOVE	B,1(A)
URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION---------
	AOS	RCNT7
;---------------------------------------------------------------
>;URSTAT

	MOVE 	C,-VALP(FPD)
	DPB	B,MC(FRTAB)
	LSH 	B,-30
	MOVE	C,-ATTP(FPD)
	DPB	B,MC(FRTAB)
	SKIPE	C,-VALP(FPD)
	CAME	C,-ATTP(FPD)
	JRST	ROSP7
	MOVE	B,1(A)
	LDB	C,[POINT ITLEN,B,35]
	LDB	D,[POINT ITLEN,B,ITLEN-1]
	CAIN	D,(C)
	JRST	ROSP7
CONT7:	HLRZ	A,-T2(FPD)
	JUMPN	A,NEXTH7
NEXT7:	HRRZ	A,-T2(FPD)
	JUMPN	A,COMP7
	JRST	UPDAT7
ROSP7:
;-----------LEAP STATISTICS------------------------------
URSTAT<	AOS	RSUC7	>;URSTAT
;--------------------------------------------------------
 	JRST	AOSP

>;NOURLEAP
>;URHASH
F8:	ERR	<ASSOCIATIVE SEARCH WITH NOTHING BOUND>,1
	POPJ	P,		;ALWAYS FAIL

; X  IN  S


S1:	MOVE	A,-T2(FPD)	;IN CASE OF NEXT
	AOSE	-TT1(FPD)
	 JRST	 NEXS1		;BEEN HERE BEFORE
	SKIPN	A,-SETP(FPD)
	 POPJ	 P,		;NULL SET
	HRRZ	A,(A)		;GET PAST SET HEADER

NEXS1:	JUMPE	A,CPOPJ		;DONE
	HLRZ	B,(A)		;ITEM NUMBER
	MOVE	C,-ITMP(FPD)	;DESTINATION TEMP
URLEAP	<
	HRLM	B,@MC(FRTAB)
>;URLEAP
NOURLEAP	<
	DPB	B,MC(FRTAB)
>;NOURLEAP
	HRRZ	B,(A)		;NEXT POINTER.
	MOVEM	B,-T2(FPD)	;FOR NEXT TIME.
	AOS	(P)
	POPJ	P,		;SUCCESS.



; A  IN  S

S2:	AOSE	-TT1(FPD)	;SO THAT YOU DON'T
	 POPJ	 P,		;GO THROUGH TWICE
	SKIPN	A,-SETP(FPD)	;PICK UP SET POINTER
	 POPJ	 P,		;NULL SET
	HRRZ	A,(A)		;PASS UP HEADER
NXT:	JUMPE	A,CPOPJ		;GONE TO END AND NOT FOUND.
	HLRZ	B,(A)
	CAMN	B,-ITMP(FPD)	;RIGHT ONE?
	 JRST	 YESS1
	HRRZ	A,(A)
	JRST	NXT
YESS1:	AOS	(P)
CPOPJ:	POPJ	P,
DSCR FORSET AND NOFOR -- MAKE A SEARCH CONTROL BLOCK
THESE ROUTINES TAKE ENTRIES OFF THE STACK (P) AND
MAKE UP SEARCH CONTROL BLOCKS BASED ON THESE ENTRIES AND
THE CONTENTS OF THE FLAG WORD.  THESE ROUTINES ARE
CALLED BY THE FOREACH INTERPRETER, THE ERASE CODE,
AND SOME OF THE "IS THIS ASSOCIATION IN THE STORE"
ROUTINES.

THE DIFFERENCE BETWEEN THE ROUTINES IS THIS:
NOFOR HANDLES "ANY" CONSTRUCTS DIFFERENTLY.  THE SEARCH ROUTINES
ARE CAPABLE OF CUTTING SHORT THEIR SEARCHES, BASED ON THE
EXISTENCE OF AN "ANY".  THIS IS A FINE IDEA FOR THE
FOREACH STATEMENT, SINCE THE USER IS NOT INTERESTED
IN THE ACTUAL ITEMS WHICH WILL MATCH THE "ANY".
HOWEVER, THE ERASE CODE IS VITALLY INTERESTED, SINCE
IT MUST ERASE ALL OF THEM.  SO:

NOFOR -- CALL IF YOU WANT SEARCH CONTROL BLOCK WHICH WILL
	RETURN ON ALL SUCCESSFUL MATCHES TO "ANY"
FORSET -- CALL IF YOU WANT THE ABBREVIATED SEARCHES.

CALLS: BOTH WITH JSP LPSA,xxxx

⊗;



NOFOR:				;ONLY CALLED BY ERASE
	MOVE	FRTAB,LEABOT(USER)	;ALWAYS AVAILABLE BLOCK
	SKIPE	-2(P)		;ANY?
	JRST	NOFOR1		;NO.
	TLO	FLAG,BINDING⊗ATTPOS
	MOVEI	A,1		;THIS WILL BE THE SATISFIER NO.
	MOVEM	 A,-2(P)	;THEN FIX.
NOFOR1:	SKIPE	-1(P)
	JRST	NOFOR2
	TLO	FLAG,BINDING⊗OBJPOS
	MOVEI	A,2		;MAKE THEM ALL DIFFERENT
	MOVEM	 A,-1(P)
NOFOR2:	SKIPE	(P)
	JRST	FORSET
	TLO	FLAG,BINDING⊗VALPOS
	MOVEI	A,3
	MOVEM	A,(P)		;THE COMPILER CAN'T REALLY DO THIS.
				;SINCE ANY CAN NOW BE STORED IN ITEMVARS

FORSET:	MOVE	FPD,FPDP(FRTAB)	;PICK UP THE LEAP PUSH-DOWN POINTER.
	TLNE	FLAG,SETOP
	 AOBJN	 FPD,P2		;NO ENTRY IF A SET.

	TLNE	FLAG,BRACKET	;IF BRACKETED TRIPLE SEARCH.
	 POP	 P,D		;THE BRACKETED ITEM NUMBER

P3:	POP	P,B		;THE VALUE
	TLNE	FLAG,BOUND⊗VALPOS ;IF VALUE IS A BOUND ITEMVAR, THEN
	 XCT	 MOVEB(FRTAB)	;GET THE SATISFIER FROM THE TABLE.
NOURLEAP	<
	TRZ	B,BNDFOR	;TURN OFF "BOUND"BIT
>;NOURLEAP
	JUMPN   B,.+2
	TLO	FLAG,BINDING⊗VALPOS ;VALUE IS "ANY"
	PUSH	FPD,B
URLEAP	<
GLOB <
	TLNE	FLAG,BINDING⊗VALPOS ;IS ENTRY UNBOUND?
	JRST	P2		;NOT BOUND
	TLNE	FLAG,GLBSRC	;GLOBAL SEARCH?
	CAIGE	B,GBRK		;WITH LOCAL ITEM?
				;ABOVE SKIP GOES TO P2
	ERR	<GLOBAL SEARCH WITH LOCAL ITEM>,1
>;GLOB
		;VALUE DOESN'T GO INTO MASK IN URLEAP
>;URLEAP
NOURLEAP	<
	TLNE	FLAG,BINDING⊗VALPOS ;IS ENTRY UNBOUND?
GLOB	<
	JRST	P3A		;NOT BOUND
	TLNE	FLAG,GLBSRC	;GLOBAL SEARCH?
	CAIL	B,GBRK		;WITH LOCAL ITEM?
	JRST	P3OK
	ERR	<GLOBAL SEARCH WITH LOCAL ITEM>,1
	SKIPA
P3A:
>;GLOB
	SETZM	B		;ZERO UNBOUND ENTRY
P3OK:
	LSHC	B,-ITLEN	;MAKE UP MASK IN C.
>;NOURLEAP
P2:	POP	P,B
	TLNE	FLAG,BOUND⊗OBJPOS
	 XCT	 MOVEB(FRTAB)
NOURLEAP	<
;;#JL# BY JRL 10-4-72 SETS NOT POT(ENTIALLY) BOUND
	TLNN	FLAG,SETOP	;BNDFOR ONLY FOR ITEMS
	TRZ	B,BNDFOR
>;NOURLEAP
	JUMPN 	B,.+2
	TLO	FLAG,BINDING⊗OBJPOS ;OBJECT IS ANY.
	PUSH	FPD,B
	TLNE	FLAG,BINDING⊗OBJPOS
GLOB <
	JRST	P2A		;UNBOUND ENTRY
	TLNE	FLAG,SETOP	;A SET OPERATION?
	JRST	P2OK		;YES.
	TLNE	FLAG,GLBSRC	;GLOBAL SEARCH?
	CAIL	B,GBRK		;GLOBAL ITEM?
	JRST	P2OK		;ALL OK.
	ERR	<GLOBAL SEARCH WITH LOCAL ITEM>,1
	SKIPA
P2A:
>;GLOB
	 SETZM	 B
P2OK:
URLEAP	<
	MOVE	C,B		;SAVE OBJECT IN C FOR MASK
>;URLEAP
NOURLEAP	<
	LSHC	B,-ITLEN
>;NOURLEAP

P1:	POP	P,B		;ATTRIBUTE
	TLNE	FLAG,BOUND⊗ATTPOS
	 XCT	 MOVEB(FRTAB)
NOURLEAP	<
	TRZ	B,BNDFOR
>;NOURLEAP
	JUMPN	B,.+2
	TLO	FLAG,BINDING⊗ATTPOS ;ATTRIB IS ANY
	PUSH	FPD,B
	TLNE	FLAG,BINDING⊗ATTPOS
GLOB <
	JRST	P1A
	TLNE	FLAG,GLBSRC
	CAIL	B,GBRK
	JRST	P1OK
	ERR	<GLOBAL SEARCH WITH LOCAL ITEM>,1
	SKIPA
P1A:
>;GLOB
	 SETZM	 B
P1OK:
URLEAP	<
	HRL	C,B		;MASK IS ATTRIBUTE,,OBJECT
>;URLEAP
NOURLEAP	<
	LSHC	B,-ITLEN
>;NOURLEAP
	SETZM	INDEX4(FRTAB)
	PUSH	FPD,C		;THE MASK OF A-O ( -V IF NOURLEAP )
				;UNBOUND PORTIONS OF THE MASK ARE 0

	PUSH	FPD,[-1]	;INITIAL -TT1(FPD)
	PUSH	FPD,[0]		;INITIAL -T2(FPD)

	TLNE	FLAG,SETOP	;DON'T COMPUTE ROUTINE NAME FOR SET SEARCH
	JRST	STSRCH
	HRRI	FLAG,0
	TLNE	FLAG,BINDING⊗ATTPOS
	TRO	FLAG,1
	TLNE	FLAG,BINDING⊗OBJPOS
	TRO	FLAG,2
	TLNE	FLAG,BINDING⊗VALPOS
	TRO	FLAG,4
STSRCH:
	PUSH	FPD,FLAG	;SAVE THE ROUTINE NAME.
	PUSH	FPD,UUO1(USER)	;SAVE RETURN ADDRESS.(on success)
	HRLM	D,(FPD)		;SAVE BRACKETED ITEM # IN LH.
	
	JRST	(LPSA)		;ALL DONE.

DSCR  FOREACH STATEMENT INTERPRETER

THERE ARE SEVERAL ROUTINES IN THIS SECTION:

FORGO	-- CALLED TO INITIALIZE A FOREACH STATEMENT.
	   RECORDS FAILURE ADDRESS.
	   RECORDS COUNT AND ADDRESSES OF FREE ITEMVARS.
FRGO	-- TO INITIALIZE A PART OF LEAP CORE (JUST LIKE THE
	   LEABOT(USER) AREA) TO USE AS A SEARCH CONTROL
	   BLOCK.

FDONE	-- WHEN THE OUTERMOST SEARCH IN THE FOREACH STAT.
	   FAILS, THIS IS CALLED.  IT MERELY TAKES THE
	   FAILURE EXIT FROM THE FOREACH STATEMENT.
FDONS	-- USED BY THE "DONE" CONSTRUCT (OR BY A "GO TO")
	   WHEN EXITING FROM INSIDE A FOREACH STATEMENT -- THE
	   IDEA IS TO BACK UP THE NESTING OF FOREACH SEARCHES BY
	   ONE, AND DO SOME BOOKEEPING.

FRPOP 	-- CALLED AT END OF SEARCH SPECIFICATIONS IN FOREACH
	   OR WHEN PREPARING FOR A BOOLEAN EXPRESSION INSIDE
	   A FOREACH SPECIF.  THIS COPIES CURRENT SATISFIER
	   VALUES INTO THEIR REAL USER CORE ADDRESSES (AS RECORDED
	   BY FORGO).

FRFAL	-- WHEN BOOLEAN FAILS WITHIN FOREACH. FIRE UP SEARCHES AGAIN

DOAG	-- CALLED AT THE BOTTOM OF THE FOREACH LOOP. CAUSES
	   THE SEARCHES TO BE FIRED UP TO FIND THE NEXT GROUP OF
	   SATISFIERS.

FOREC	-- MAIN CALL TO START A TRIPLE SEARCH, AS SPECIFIED
	   IN THE FOREACH SPECIFICATION. A,O, AND V ARE ON THE
	   STACK.
LD1,LD2,LD3 -- CALLED BY "DERIVED SETS" INSIDE A FOREACH SPEC.
	   SPECIAL ADJUSTMENTS ARE MADE TO THE STACK (TO REORDER
	   OPERANDS).
⊗;

LD3:	MOVE	B,(P)		;IN IS O,V,X
	EXCH	B,-2(P)
	JRST	LD22

LD2:	MOVE	B,(P)		;IN IS A,V,X
LD22:	EXCH	B,-1(P)		;MAKE IT A XOR X EQV V
	MOVEM	B,(P)
				;COMPILER HAS FIXED UP THE BITS
				;CORRECTLY ALREADY.
LD1:

↑FOREC:	MOVE	FRTAB,FRLOC(USER); CURRENT SCB
	SKIPE	A,RUNNER	;ARE THERE PROCESSES?
	MOVE	FRTAB,CURSCB(A) ;THEN LOAD FROM PVAR AREA
	SETZB	LPSA,D		;MAIN FOREACH SPECIFICATION PROCESSOR.
GLOB <
	NOSEC			;FAKE IT BACK.  YOU ARE NOT
				;CONSIDERED "ENTERED" WHEN RUNNING
				;FOREACHES......
>;GLOB
	ADD	FLAG,INDEX4(FRTAB)
	SETZM	INDEX4(FRTAB)
	JSP	LPSA,FORSET	;SET UP THE SEARCH CONTROL BLOCK.

GO:				;LOOP BACK TO HERE TO DO SEARCHES.
GLOB <
	MOVE	FLAG,-1(FPD)	;PICK UP ROUTINE NAME.
	MOVEI	TABL,(USER)
	TLNE	FLAG,GLBSRC	;IF GLOBAL, THEN
	MOVEI	TABL,GLUSER	;REARRANGE.
	JUMPL	FLAG,BRACK	;AND GO IF BRACKETED TRIPLE SEARCH.
>;GLOB
NOGLOB <
	SKIPG	FLAG,-1(FPD)	;PICK UP ROUTINE NAME.
	 JRST	 BRACK		;BRACKETED SEARCH
>;NOGLOB
	PUSHJ	P,@SEROUT(FLAG)	;CALL THE ROUTINE.
	 JRST	 FAIL		;IT FAILED IF IT CAME HERE.
				;BACK UP THE SEARCH TO NEXT OUTER.

SUCC:	MOVEM	FPD,FPDP(FRTAB)	;SAVE PUSH-DOWN POINTER
	MOVE	FPD,(FPD)	;RETURN ADDRESS (LEFT HALF HAS STUFF)
	JRST	(FPD)		;RETURN
				;THIS DOES NOT RETURN THROUGH
				;"LEAV".
GLOB <
		;HENCE WE SEE THAT YOU ARE REALLY NOT "ENTERED"
		;WHEN EXECUTING THIS CODE.
>;GLOB


FAIL:	MOVE	FLAG,-1(FPD)	;THE CONTROL WORD.
	SKIPGE	A,-SETP(FPD)	;IF SET NEEDS RECLAIMING
	TLNN	FLAG,SETOP	;WAS THIS A SET?
	 JRST	 FAIGO
	MOVE	B,FP1(USER)	;PREPARE TO RECLAIM TEMP SET.
	HLRZ	C,(A)
	HRRZM	B,(C)		;PUT IN DOWN POINTER.
	HRRM	A,FP1(USER)	;AND UPDATE FREE LIST.
FAIGO:	SUB	FPD,[XWD LENFPD,LENFPD]
	JRST	GO		;USE THE NEXT HIGHER ROUTINE.




BRACK:				;IF BRACKETED TRIPLE SEARCH.
	PUSHJ	P,@SEROUT(FLAG)	;CALL THE ROUTINE.
	 JRST	 FAIL		;FAIL....
URLEAP	<
;ON SUCCESSFUL RETURN FROM SEARCH, A POINTS TO ASSOCIATION.  WE HAVE TO
;SEE IF THERE IS A BRACKETED TRIPLE BLOCK INDICATING THAT THIS ASSOCIATION
;IS A BRACKETED TRIPLE
;L.H. OF A BETTER BE ZERO
	MOVEI	B,BRACKL(TABL)	;GET ADDRESS OF LIST OF B.T. BLOCKS
BRCK1:	HRRZ	B,(B)		;GET NEXT B.T. BLOCK (ITEM # IN L.H.)
	JUMPE	B,[HRRZ	FLAG,-1(FPD)	;NO MORE B.T. BLOCKS ...
		JRST	BRACK]		;... LOOK FOR ANOTHER ASSOCIATION
	CAME	A,1(B)		;DOES THIS B.T. BLOCK REFER TO THIS ASSOC?
	 JRST	BRCK1		;NO - TRY ANOTHER B.T. BLOCK
	HLRZ	B,(B)		;GET ITEM # FOR THIS ASSOC FROM B.T. BLOCK
	HLRZ	C,(FPD)		;LOCAL # THAT REQUESTED IT
	HRLM	B,@MC(FRTAB)	;SAVE IT IN SATISFIER TABLE (LOCAL # IN C)
>;URLEAP
NOURLEAP	<
	HLRZ	B,(A)		;A POINTS TO THING FOUND.
	BRACKN	B		;IS THIS A BRACKETED TRIPLE?
	 JRST	[HRRZ	FLAG,-1(FPD)	;NO -- GET CONTROL WORD AGAIN.
		JRST	BRACK]	;AND TRY AGAIN.
	HRRZ	B,(B)		;THIS IS THE ITEM ## BRACKET.
	HLRZ	C,(FPD)		;THIS IS THE LOCAL NUMBER
				;FOR THE BRACKETED #
	DPB	B,MC(FRTAB)	;STORE AWAY THE LOCAL.
>;NOURLEAP
	JRST	SUCC		;GOOD-BYE

;JRST TO DOAG, FRFAL

↑DOAG:
	MOVE	FRTAB,FRLOC(USER) ;CURRENT SCB
	SKIPE	A,RUNNER	;ARE THERE PROCESSES?
	MOVE	FRTAB,CURSCB(A)	;LOAD FROM PVAR AREA
	HRRE	A,SCNT(FRTAB)	;NUMBER OF SATS TO SAVE
	MOVEI	B,SATIS+1(FRTAB)
DOAGLP: AOJG    A,FRFAL2	;THROUGH GETTING CURRENT VALS?
URLEAP	<
	SKIPG	OLDSAT-SATIS-1(B)	;WAS THIS A ? LOCAL ALREADY BOUND?
	AOJA	B,DOAGLP	;YES.
	MOVE	C,(B)		;GET THE CURRENT SATISFIER
	HLRM	C,OLDSAT-SATIS-1(B) ;DEPOSIT LATEST SATISFIER
>;URLEAP
NOURLEAP	<
	SKIPG	C,(B)		;WAS THIS A ? LOCAL ALREADY BOUND?
	AOJA	B,DOAGLP	;YES.
	HLRZM	C,OLDSAT-SATIS-1(B) ;DEPOSIT LATEST SATISFIER
>;NOURLEAP
	AOJA	B,DOAGLP	;LOOP
↑FRFAL:	
	MOVE	FRTAB,FRLOC(USER) ;CURRENT SCB
	SKIPE	A,RUNNER	;ARE THERE PROCESSES?
	MOVE	FRTAB,CURSCB(A)	;LOAD FROM PVAR AREA
FRFAL2:	MOVE	FPD,FPDP(FRTAB)	;RESTORE PUSHDOWN POINTER.
	JRST	GO		;CALL THE RIGHT ROUTINE.


;JRST TO FORGO

↑FORGO:

	SKIPN	B,SCBCHN(USER)	;FREE SCB'S?
	JRST	[PUSH P,TAC1 ;CORGET WILL DESTROY
		 LPCOR (<FRCHLEN>) ; NO GO GET ONE.
		 POP P,TAC1  ;RESTORE IT
		JRST	HAVSCB]
	HRRZ	A,SCBLNK(B)	;ADDRESS NEXT FREE SCB
	MOVEM	A,SCBCHN(USER)	;UPDATE FREE SCB CHAIN
HAVSCB:	HRRZ	A,FRLOC(USER)	;DYNAMIC NESTING SCB
	SKIPE   D,RUNNER
	HRRZ	A,CURSCB(D)
	HRL	A,(P)		;ADDRESS SCB POINTER
	MOVEM	A,SCBLNK(B)	;DYNAMIC SCB CHAIN
	POP	P,A		;ADDRESS SCB POINTER
	MOVEM	B,(A)		;PUT POINTER IN.
	HRL	B,A		
	MOVEM	B,FRLOC(USER)	;HANDLE TO CURRENT SCB
	SKIPE	D,RUNNER
	MOVEM	B,CURSCB(D)
	MOVEI	FP,FREND	;IN LINE CALL TO FRGO


FRGO:
	MOVEI	A,FPDL-1(B)	;PUSHDOWN LIST.
	HRLI	A,-FPDLEN	;AND LENGTH.
	
	HRRI	C,SATIS(B)	;SATISFIER LIST.
	HRLI	C,(<HLRZ A,(A)>)
	MOVEM	C,MOVEA(B)	;THIS IS THE "UPDATE "A" INSTRUCTION".
	HRLI	C,(<HLRZ B,(B)>)
	MOVEM	C,MOVEB(B)	;AND FOR B.
URLEAP	<
	HRLI	C,(<HRLM C,(C)>)
>;URLEAP
NOURLEAP	<
	HRLI	C,(<POINT 12,(C),17>)
>;NOURLEAP
	MOVEM	C,MC(B)		;INDIRECT WORD (BYTE POINTER IF NOURLEAP) FOR
				;PUTTING AWAY SATISFIERS.

	PUSH	A,[XWD 0,-1]	;TO CALL FDONE WHEN ALL DONE.
	PUSH	A,(TAC1)	;THIS IS THE JUMP OUT OF THE FOREACH.
;TAC1 THAT IS FRTAB CONTAINS ADDRESS OF SATISFIER INFO BLOCK FROM CALLER
	MOVEM	A,FPDP(B)	;AND SAVE THE PUSH-DOWN POINTER.
	JRST	(FP)

FREND:	ADDI	TAC1,1		;INCREMENT OVER JRST WORD.
	MOVEI	D,SATIS+1(B)	;BEGINNING OF SATISFIER TABLE.
	MOVN	A,(TAC1)	; - COUNT OF LOCALS IN THIS LIST.
	MOVEM	A,SCNT(B)	;KEEP TRACK FOR THE POPPING OFF.
LOP:	ADDI	TAC1,1		;THIS COUNTS UP!
	AOJG	A,LEAV		;DONE, BY GOOOLLY
	MOVE	C,(TAC1)	;THE LOCAL WORD
	TLNN	C,CDISP		;A DISPLAY NEEDED?
	JRST	NODISP		;NO.
;; #OW# !(1 OF 3) USED TO BE POINT,(C) BY MISTAKE
	LDB	B,[POINT 4,C,17] ;PICK UP DISPLAY DIFFERENCE
	MOVEI	LPSA,(RF)	;THE CURRENT DISPLAY
LPDISP:
;; #OW# !(2 OF 3) JRL USED  TO BE MOVE. LH SCREWED UP TLNE C, BELOW
	HRRZ	LPSA,1(LPSA)	;BACK THE STATIC LINK
	SOJG	B,LPDISP	;COUNT DOWN DIFFERENCE
;; #OW# !(3 OF 3) JRL USED TO BE ADD LPSA,(C)
	ADD	LPSA,C		;ADD THE DISPLACEMENT
	TLNE	C,20		;REFERENCE PARAMETER?
	HRRZ	LPSA,(LPSA)	;YES
	JRST	HAVEAD
NODISP:	MOVEI	LPSA,@C		;MUCH EASIER
HAVEAD:	TLNN	C,MPPAR		;A ? PARAMETER?
	JRST	CALPOT		;NO.
	MOVE	B,(LPSA)	
	TLZE	B,20		;BOUND?
	MOVEI	LPSA,(B)	;NO.
CALPOT:
	HRRZ	B,(LPSA)	;PICK UP CURRENT VALUE
	MOVEM	B,OLDSAT-SATIS-1(D) ;SAVE CURRENT VALUE FOR BACKUP
	TLNE	C,POTUNB	;A POTUNB LOCAL(?)
	CAIN	B,UNBND		;AND UNBOUND
	CAIA
NOURLEAP	<
	TRO	B,BNDFOR	;MARK AS BOUND ON ENTRY
>;NOURLEAP
URLEAP	<
	HRROS	OLDSAT-SATIS-1(D)	;MARK OLDSAT INSTEAD
>;URLEAP
	HRL	LPSA,B		;GET CURRENT VALUE IF BOUND
	MOVEM	LPSA,(D)	;SAVE IN SATIS TABLE
	AOJA	D,LOP		;LOOP

;FDONE WHEN ALL TESTS EXHAUSTED END FOREACH
FDONE:	MOVE	FP,(FPD)	;RETURN ADDRESS.
;RESTORE LAST SUCCESSFUL SATISFIER GROUP
	HRRE	A,SCNT(FRTAB)
	MOVEI	B,SATIS+1(FRTAB)
LPDONE: AOJG	A,RESTSCB
URLEAP	<
	SKIPG   OLDSAT-SATIS-1(B)	;A ?LOCAL BOUND ON ENTRY?
	AOJA	B,LPDONE	;YES.
	MOVE	C,(B)		;GET LOCAL ADDRESS FROM SATISFIER TABLE
	HRRZ	D,OLDSAT-SATIS-1(B) ;PICK UP LATEST SATISFIER
>;URLEAP
NOURLEAP	<
	SKIPG	C,(B)		;A ?LOCAL BOUND ON ENTRY?
	AOJA	B,LPDONE	;YES.
	MOVE	D,OLDSAT-SATIS-1(B) ;PICK UP LATEST SATISFIER
>;NOURLEAP
	MOVEM   D,(C)		;STORE INTO CORE
	AOJA	B,LPDONE
RESTSCB:
	PUSHJ	P,SCBRES	;RESTORE SCB TO FREE LIST
	SUB	P,X11		;PAST FOREACH RETURN ADDRESS
	JRST	(FP)		;JUMP OUT OF FOREACH STATEMENT.

FDONS:	MOVE	FRTAB,FRLOC(USER);CURRENT SCB
;; #KP# BY JRL (11-28-72) FOLLOWING TWO INSTRS USED AND THUS DESTROYED AC A
	SKIPE	D,RUNNER
	MOVE	FRTAB,CURSCB(D)
	PUSHJ	P,SCBRES	;RESTORE SCB TO FREE LIST
	MOVE	FPD,FPDP(FRTAB)	;WE ARE ABOUT TO LEAVE, SO MAKE
FDX:	MOVE	D,-1(FPD)	;LOOK AT CONTROL WORD.
	SKIPGE	LPSA,-SETP(FPD)	;IF SET NEEDS RECLAIMING
	TLNN	D,SETOP		;THEN DO SO
	JRST	FDY
	MOVE	B,FP1(USER)	;PREPARE TO RECLAIM SET.
	HLRZ	C,(LPSA)
	HRRZM	B,(C)
	HRRM	LPSA,FP1(USER)	;DONE.
FDY:	CAIN	D,-1		;THIS IS THE LAST.
	POPJ	P,		;DONE
	SUB	FPD,[XWD LENFPD,LENFPD]
	JRST	FDX		;AND GO FOR MORE.


SCBRES:				;RECLAIM AN SCB
;; #KP# THIS ROUTINE FORMERLY USED AC A INSTEAD OF PNT THUS
;; DESTROYING VALUE OF EXPRESSION RETURNED FROM FOREACH
	HLR	PNT,FRLOC(USER)	;ADDRESS OF SCB POINTER
	SKIPE	D,RUNNER
	HLR	PNT,CURSCB(D)
	SETZM	(PNT)		;ZERO IT
	HRRZ	PNT,FRLOC(USER)	;ADDRESS THIS SCB
	SKIPE	D
	HRRZ	PNT,CURSCB(D)
	MOVE	B,SCBLNK(PNT)	;ADDRESS PREVIOUS SCB
	HLL	B,SCBLNK(B)	;GET ADDR SCB POINTER
	MOVEM	B,FRLOC(USER)	;POP FOREACH
	SKIPE	D
	MOVEM	B,CURSCB(D)
	MOVE	B,SCBCHN(USER)	;WILL ADD TO FREE SCB CHAIN
	MOVEM	B,SCBLNK(PNT)	;ADD TO FREE LIST
	MOVEM	PNT,SCBCHN(USER);UPDATE FREE LIST
	POPJ	P,		;RETURN
DSCR FRPOP, CORPOP
	FRPOP - MOVE SATISFIERS FROM SCB INTO CORE
	CORPOP - MOVE FROM CORE TO SCB SATISFIER AREA
⊗;


;PUSHJ TO FRPOP
↑FRPOP: MOVE	FRTAB,FRLOC(USER);CURRENT SCB
	SKIPE	D,RUNNER
	MOVE	FRTAB,CURSCB(D)
	HRRE	A,SCNT(FRTAB)	;COUNT OF LOCALS.
				;PICKED UP WITH HRRE SINCE THE
				;DEPOSITS OF SATISFIERS FOR "ANY" WILL BE WRONG.
	MOVEI	B,SATIS+1(FRTAB)	;START OF SATISFIERS.
LOPS:	AOJG	A,CPOPJ		;LOOP UNTIL ALL IN CORE.
URLEAP	<
	SKIPGE	OLDSAT-SATIS-1(B)	;WAS IT BOUND ON ENTRY ?
	 AOJA	B,LOPS		;IF SO DON'T RESTORE IT
	MOVE	C,(B)		;PICK UP VALUE,,ADDRESS
>;URLEAP
NOURLEAP	<
	SKIPG	C,(B)
	 AOJA	B,LOPS
>;NOURLEAP
	HLRZM	C,(C)		;STORE LEFT HALF IN CORE.
	AOJA	B,LOPS

;PUSHJ TO CORPOP
↑CORPOP: MOVE	FRTAB,FRLOC(USER);CURRENT SCB
	SKIPE	D,RUNNER
	MOVE	FRTAB,CURSCB(D)
	HRRE	A,SCNT(FRTAB)	;COUNT OF LOCALS
	MOVEI	B,SATIS+1(FRTAB) ;ADDR FIRST LOCAL
LOPCP:	AOJG	A,CPOPJ		;THROUGH?
URLEAP	<
	SKIPG	OLDSAT-SATIS-1(B)	;POT UNB ACTUALLY BOUND
	 AOJA	B,LOPCP		;YES
	MOVE	D,(B)		;PICK UP OLD VALUE,,ADDRESS
>;URLEAP
NOURLEAP	<
	SKIPG	D,(B)		;POT UNB ACTUALLY BOUND
	 AOJA	B,LOPCP		;YES
>;NOURLEAP
	HRL	D,(D)		;THE CURRENT VALUE
	MOVEM	D,(B)		;BACK INTO SATIS TABLE
	AOJA	B,LOPCP		;CONTINUE
DSCR ? LOCAL STACK ROUTINES,STK4LC,STK4VL
⊗
STK4LC:				;STACK FOREACH ? LOCAL AS PARM TO MATCHING PROCEDURE
				;JRST'ED TO
	MOVE	FRTAB,FRLOC(USER)
	SKIPE	A,RUNNER	;PROCESSES AROUND?
	MOVE	FRTAB,CURSCB(A) ;GET FRCH TABLE FROM PROCESS VARIABLE AREA
	POP	P,A		;LOCAL NUMBER
	MOVEI	B,SATIS(FRTAB)	;START OF SATISFIER TABLE
	ADDI	B,(A)		;ADDRESS THIS SATISFIER
;;#TK# ! RHT 9-21-74 USED TO BE (D).  AS NEAR AS I CAN SEE SHOULD BE B
URLEAP	<
	SKIPL	OLDSAT-SATIS-1(B)	;BOUND ON ENTRY?
>;URLEAP
NOURLEAP	<
	SKIPL	C,(B)		;BOUND ON ENTRY?
>;NOURLEAP
	 JRST	STKREF		;NO.
	XCT	MOVEA(FRTAB)	;YES GET CURRENT VALUE
NOURLEAP	<
	TRZ	A,BNDFOR	;TURN OFF "BOUND ON ENTRY" BIT
>;NOURLEAP
	PUSH	P,A		;LEAV ON STACK
	JRST	LEAV
STKREF:
URLEAP	<
	MOVE	C,(B)		;GET SATISFIER TABLE ENTRY
>;URLEAP
	HRLI	C,20		;MARK AS UNBOUND
	PUSH	P,C		;STACK ADDRESS OF LOCAL
	JRST	LEAV


STK4VL: 			;FOREACH SEARCHES STACK LOCAL NUMBER OR VALUE
				;JRST'ED TO
	MOVE	FRTAB,FRLOC(USER)
	SKIPE	A,RUNNER
	MOVE	FRTAB,CURSCB(A)
	POP	P,D		;THE DISPATCH INCREMENT AND TYPE BITS
	MOVE	A,(P)		;LOCAL NUMBER
	MOVEI	B,SATIS(FRTAB)	;ADDRESS SATISFIER TABLE
	ADDI	B,(A)		;ADDRESS THIS LOCAL
URLEAP	<
	SKIPG	OLDSAT-SATIS-1(B)	;BOUND?
>;URLEAP
NOURLEAP	<
	SKIPG	C,(B)		;BOUND?
>;NOURLEAP
	 JRST	STK4V2		;YES
	TLZA	D,BOUND⊗ATTPOS!BOUND⊗OBJPOS!BOUND⊗VALPOS
STK4V2:	AND	D,[XWD BOUND⊗ATTPOS!BOUND⊗OBJPOS!BOUND⊗VALPOS,0]
	ADDM	D,INDEX4(FRTAB)
	JRST	LEAV


DSCR BNDTRP- BINDING FORM OF BOOLEAN A XOR O EQV V
	Top three elements of stack are A, O, and V. If the
element is being bound the corresponding bit in FLAG is on and
the stack entry contains the address of the itemvar being bound.
ANY is represented by the stack entry being zero.
⊗

BNDTRP:					;JRST'ED TO
	MOVE	FRTAB,LEABOT(USER)	;GET STATIC SCB
	SETZM	SATIS+1(FRTAB)		;CLEAR SATISFIER ENTRIES
	SETZM	SATIS+2(FRTAB)	
	SETZM	SATIS+3(FRTAB)
	TLNN	FLAG,BINDING⊗ATTPOS     ;ATTRIBUTE UNBOUND?
	JRST	OPOS			;NO.
	SKIPG	B,-2(P)			;GET ATTRIBUTE ITEMVAR.
;POTUNB BIT IS SIGN BIT
	JRST	[TLZ  B,POTUNB		;A ?ITMVR
		 MOVE C,(B)
		 CAIN C,UNBND		;BOUND?
		 JRST .+1		;NO.
		 TLZ FLAG,BINDING⊗ATTPOS ;NO WE'RE NOT BINDING IT
		 MOVEM C,-2(P)		;ACTUAL VALUE
		 JRST	VPOS]
	MOVEI	C,1			;FIRST SATISFIER
	HRRZM	B,SATIS+1(FRTAB)	;SAVE ADDR OF ATTRIB. ITMVR
	HRRZM	C,-2(P)		;FIRST SATISFIER IS ATTRIB
OPOS:
	TLNN	FLAG,BINDING⊗OBJPOS	;OBJECT UNBOUND?
	JRST VPOS			;NO.
	SKIPG	B,-1(P)			;OBJECT ITEMVAR
	JRST	[TLZ B,POTUNB		;A ?ITMVR
		 MOVE C,(B)
		 CAIN C,UNBND		;ACTUALLY BOUND?
		 JRST .+1		;NO.
		 TLZ FLAG,BINDING⊗OBJPOS
		 MOVEM	C,-1(P)
		 JRST VPOS]
	MOVEI	C,1			;ASSUME SAME AS ATTRIB
	CAMN	B,SATIS+1(FRTAB)	;IS IT REALLY?
	JRST	STOBJ			;YES
	MOVEI	C,2			;ATTRIB≠OBJECT ITEMVAR
	HRRZM	B,SATIS+2(FRTAB)	;SAVE ADDR OF OBJECT ITMVAR
STOBJ:	MOVEM	C,-1(P)			;SATIS NO. FOR OBJECT
VPOS:
	TLNN	FLAG,BINDING⊗VALPOS	;VAL UNBOUND?
	JRST SET.UP
	SKIPG	B,(P)			;VAL = ANY?
	JRST	[TLZ B,POTUNB
		 MOVE C,(B)
		 CAIN C,UNBND
		 JRST .+1
		 TLZ FLAG,BINDING⊗VALPOS
		 MOVEM C,(P)
		 JRST SET.UP]
	MOVEI	C,1			;ASSUM SAME AS ATTRIB ITMVR
	CAMN	B,SATIS+1(FRTAB)	;IS IT
	JRST	STVAL			;YES, THE SAME
	MOVEI	C,2			;SAME AS OBJECT ITMVR?
	CAMN	B,SATIS+2(FRTAB)	;
	JRST	STVAL			;YES, THE SAME
	MOVEI	C,3			;DIFFERENT THAN THE OTHERS
	HRRZM	B,SATIS+3(FRTAB)	;SAVE ADDR VALUE ITMVR
STVAL:	MOVEM	C,(P)			;SATIS NO. FOR VALUE
SET.UP:
	JSP	LPSA,FORSET		;SET UP MASK,SCB ETC
					;ALSO DOES BINDING BITS FOR "ANY"
	PUSHJ	P,@SEROUT(FLAG)		;DO SEARCH
	JRST 	RETNO			;RETURN FALSE
	SKIPE	A,SATIS+1(FRTAB)	;FIRST SATIS USED?
	HLRZM	A,(A)			;YES.
	SKIPE	A,SATIS+2(FRTAB)
	HLRZM	A,(A)
	SKIPE	A,SATIS+3(FRTAB)
	HLRZM	A,(A)
	JRST	RETYES			;RETURN TRUE
DSCR ISIT,BRITM

	ISIT - ASSOCIATIVE BOOLEAN WITH EVERYTHING BOUND (OR ANY)
		A,O,V ON TOP OF STACK
	BRITM - FIND BRACKETED TRIPLE ITEM (RETURN BINDIT IF NONE)
⊗;


ISIT:				;JRST HERE FOR A XOR O EQV V ?
	MOVE	FRTAB,LEABOT(USER)
	JSP	LPSA,FORSET	;GO GET THINGS SET UP
;; FORSET HAS CHANGED THE RH OF FLAG FOR APPROPRIATE SEARCH
	PUSHJ	P,@SEROUT(FLAG);CALL ROUTINE.
RETNO:	TDZA	A,A		;FAILED
RETYES:	SETOM	A		;SUCCEEDED.
				;RESULT LEFT IN REGISTER 1.
	JRST	LEAV


BRITM:				;JRST HERE FOR BRACKETED ITEM
				;TO BE LEFT ON STACK.
	MOVE	FRTAB,LEABOT(USER)
	JSP	LPSA,FORSET	;GO START THINGS.
;; FORSET HAS STACKED ARGS AND COMPUTED ROUTINE NAME
BRGO:	MOVE	FLAG,-1(FPD)	;ROUTINE NAME.
	PUSHJ	P,@SEROUT(FLAG);CALL IT.
	 JRST	[PUSH P,[NIC]
		JRST LEAV]
URLEAP	<
	MOVE	B,BRACKL(TABL)	;GET LIST OF B.T. BLOCKS
BRGO1:	JUMPE	B,BRGO		;IF NO MORE THIS WASN'T A B.T.
	CAME	A,1(B)		;DOES THIS B.T. BLOCK SAY THIS ASSOC IS A B.T.?
	 JRST	[HRRZ	B,(B)	;NOPE -- GET NEXT B.T. BLOCK
		JRST	BRGO1]
	HLRZ	B,(B)		;GET ITEM NUMBER
>;URLEAP
NOURLEAP	<
	HLRZ	B,(A)		;VALUE POINTER.
	BRACKN	B		;BRACKETED?
	 JRST	BRGO		;NO
	HRRZ	B,(B)		;YES -- THIS IS THE ITEM.
>;NOURLEAP
	PUSH	P,B		;ON STACK -- RESULT IS ITEM NUMBER.
	JRST	LEAV		;DONE.....
DSCR DERIVED SETS -- NOT IN FOREACH SPECIFICATIONS.

THESE ROUTINES COMPUTE DERIVED SETS.  THEY CALL THE SEARCH
ROUTINES ABOVE, AFTER SETTING UP THE "FIXED" SEARCH CONTROL
BLOCK TO RELECT THE PARTICULAR SEARCH.


⊗;

; A XOR O
D1:	MOVE	FRTAB,LEABOT(USER)
	PUSH	P,[1]		;FOR VALUE -- RESULT.
	JRST 	DOIT		;READY TOGO

; O EQV V
D3:	MOVE	FRTAB,LEABOT(USER)
	MOVEI	A,1
	EXCH	A,-1(P)
	JRST	D2DO

; A'V
D2:	MOVE	FRTAB,LEABOT(USER)
	MOVEI	A,1
D2DO:	EXCH	A,(P)
	PUSH	P,A		;CHANGE ORDER OF ARGS.

DOIT:
	JSP	LPSA,FORSET
	PUSH	P,[0]		;THE SET WE WILL ACCUMULATE.
AGS:	PUSHJ	P,@SEROUT(FLAG)	;CALL THE SEARCH
	 JRST	 [HLRZ A,(P)	;FAILED, AND DONE!
		 MOVNS A	;CHANGE COUNT TO NEGATIVE 
				;TO INDIC. TEMP.
		 HRLM A,(P)
		 JRST LEAV]
	HLRZ	A,SATIS+1(FRTAB);RESULT IN FIRST SATISFIER
	MOVEI	TAC1,(P)	;PLACE OF SET
GLOB <
	PUSH	P,TABL
	TLZ	FLAG,GLBSRC	;ENTY NEEDS TO KNOWS....
>;GLOB
	PUSH	P,A		;ITEM FOR ENTY.
	PUSHJ	P,ENTY		;IN PUTIN
GLOB <
	POP	P,TABL
>;GLOB
	MOVE	FRTAB,LEABOT(USER) ;SINCE ENTY DESTROYED TAC1
	MOVE	FLAG,-1(FPD)
	JRST	AGS		;LOOP UNTIL DONE.
DSCR MAKE AND ERASE
THESE ARE THE ROUTINES TO MAKE AND ERASE ASSOCIATIONS IN THE 
ASSOCIATIVE STORE.
NOURLEAP	<
THE BIGGEST HAIR IN THESE ROUTINES HAS
TO DO WITH MULTIPLE VALUES.  "MAKE" MAY HAVE TO EXPAND
A SINGLE ASSOCIATION INTO A MULTIPLE VALUE CONFIGURATION,
AND "ERASE" MAY HAVE TO CONTRACT IT.
>;NOURLEAP

MAKE AND ERASE ARE BOTH CALLED WITH THE THREE TOP OF STACK
ELEMENTS BEING THE ATTRIBUTE, OBJECT, AND VALUE PASSED
AS ARGUMENTS.

MAKE AND ERASE HAVE A "BREAKPOINT" FACILITY, FOR ACTIVATING
A SAIL PROCEDURE EACH TIME AN ASSOCIATION IS MADE OR ERASED.
THE A, O, AND V ARE PASSED BY VALUE IN THE STACK TO THE
BREAKPOINT ROUTINE.

PROBLEMS OCCUR WHEN AN ASSOCIATION IS ERASED WHICH IS POINTED
TO BY SOME POINTER IN THE FOREACH SEARCH TABLES. WE SHOULD
PROBABLY SEARCH ALL ACTIVE SCBS FOR SUCH POINTERS AND GIVE A WARNING
BUT EVEN THIS WAY WE COULD NOT FIND POINTERS IN OTHER JOBS SHARING
A GLOBAL STRUCTURE OR POINTERS IN AN ERASE SCB WHOSE ERASE WAS
INTERRUPTED BY A ERASE-BREAKPOINT.

MAKE -- CALLED WITH PUSHJ.
ERASE -- JRST TO IT; IT WILL JRST TO LEAV.
BMAKE -- JRST TO IT; IT WILL JRST TO LEAV. (BRACKETED TRIPLE MAKE).

URLEAP	<
THE STRUCTURE BUILT BY MAKE IS AS FOLLOWS:  THERE ARE TWO KINDS OF BLOCKS;
MULTIPLE HIT BLOCKS AND VALUE BLOCKS.  THERE IS ONE MULTIPLE HIT BLOCK FOR
EACH ATTRIBUTE - OBJECT PAIR IN THE ASSOCIATIVE STORE.  IT CONTAINS TWO 
POINTERS IN ADDITION TO THE ATTRIBUTE AND THE OBJECT.  THESE ARE THE CONFLICT
POINTER, WHICH (IF NON-ZERO) POINTS TO ANOTHER M.H. BLOCK WHOSE ATTRIBUTE AND
OBJECT HAVE THE SAME HASH VALUE AS THIS ONE, AND THE MULTIPLE HIT POINTER,
WHICH IS NEVER ZERO, AND POINTS TO A LIST OF VALUE BLOCKS, CALLED THE MULTIPLE
HIT LIST.  EACH VALUE BLOCK
ON THAT LIST REPRESENTS AN ASSOCIATION WITH THE ATTRIBUTE AND OBJECT FROM THE
M.H. BLOCK.  BESIDES THE VALUE, EACH VALUE BLOCK CONTAINS THREE POINTERS:
A BACK-POINTER TO THE M.H. BLOCK, A POINTER TO THE NEXT VALUE BLOCK FOR THIS
M.H. LIST, AND A POINTER TO THE NEXT VALUE BLOCK ON THE VALUE LIST, THAT
IS, THE NEXT VALUE BLOCK REPRESENTING AN ASSOCIATION WITH THE SAME VALUE BUT
DIFFERENT ATTRIBUTE OR OBJECT. TO RECAPITULATE, WE HAVE:

M.H. BLOCK:		XWD	M.H.PTR, CONFLICT PTR
			XWD	ATTRIBUTE, OBJECT

VALUE BLOCK:		XWD	M.H.PTR, VALUE PTR
			XWD	BACK PTR, VALUE

SEE BMAKE FOR WHAT HAPPENS WHEN THERE'S A BRACKETED TRIPLE.
>;URLEAP

⊗;


;PUSHJ TO MAKE
; ON EXIT, "PNT" MUST POINT TO THE ASSOCIATION CREATED.

MAKE:
	SKIPE	A,-1(P)		;VALUE "ANY"?
	CAIN	A,UNBND		;OR VALUE UNBOUND?
	JRST	ERRMAK
	SKIPE	A,-2(P)		;OBJECT "ANY"?
	CAIN	A,UNBND		;OR OBJECT UNBOUND?
	JRST	ERRMAK
	SKIPE	A,-3(P)		;ATTRIB "ANY"?
	CAIN	A,UNBND		;ATTRIB UNBOUND?
ERRMAK:	ERR	<MAKE WITH UNBOUND ITEM>,1
GLOB <
	WRITSEC			;ENTER A POINTER-DIDLING AREA!
	TLNN	FLAG,GLBSRC	;GLOBAL MAKE?
	JRST	LOCMAK		;NO.
;; CAN THE FOLLOWING TESTS BE EFFICIENTLY BE MERGED WITH TESTS ABOVE?
	MOVEI	A,GBRK		;GLOBAL LOCAL BREAK
	CAMG	A,-1(P)		;VALUE GLOBAL?
	CAML	A,-2(P)		;OBJECT LOCAL?
	JRST	.+2
	CAML	A,-3(P)		;ATTRIB LOCAL?
	ERR	<GLOBAL MAKE WITH LOCAL ITEM>,1
LOCMAK:
>;GLOB
	SKIPE	C,MKBP(USER)	;MAKE BREAK-POINT?
	 PUSHJ	 P,LPBRK1	;GO TO A BREAKPOINT !
GLOB <
	SKIPN	FP,FP2(TABL)	;WE WILL CERTAINLY NEED SOME FRESS.
	 PUSHJ	P,FP2DON	;GET SOME.
>;GLOB
NOGLOB<
	MOVE	FP,FP2(TABL)
>;NOGLOB
	MOVE	PNT,FP		;THIS IS THE ONE WE WILL USE.
URLEAP	<
	HRR	C,-2(P)		;PICK UP OBJECT
	HRL	C,-3(P)		;AND ATTRIBUTE
>;URLEAP
NOURLEAP	<
	SETZM	C		;FOR MAKING UP THE MAGIC WORD.
	MOVE	B,-2(P)		;OBJECT.
	LSHC	B,-ITLEN
	MOVE	B,-3(P)		;ATTRIBUTE
	LSHC	B,-ITLEN	; A-O-0 IS IN C.
>;NOURLEAP
	HASH	(D,<-3(P)>,<-2(P)>)
	SKIPN	A,(D)		;ANY THING THERE?
	JRST	GOM		;NO.
AG:	MOVE	B,1(A)		;GET A-O OF THIS LIST OF ASSOCATIONS
NOURLEAP	<		;WE HAVE A-O-V IN THE OLD SYSTEM
	TRZ	B,7777		;A-O
>;NOURLEAP
	CAMN	B,C		;SAME AS THE ONE WE ARE PUTTING IN?
	 JRST	 DONE		;YES -- MODULO MULTIPLE HITS.
	MOVE	D,A		;REMEMBER WHO POINTS TO US.
	HRRZ	A,(A)		;GO DOWN CONFLICT LIST.
	JUMPN	A,AG		;... IF THERE'S ANYTHING LEFT
;IF WE FALL THROUGH HERE, WE'VE COME TO THE END OF THE CONFLICT LIST WITHOUT
;FINDING A MATCHING A-O, SO WE HAVE TO BUILD A NEW M.H. BLOCK
GOM:	SKIPN	FP,(FP)		;BEFORE USING THIS FREE BLOCK ...
	 PUSHJ	 P,FP2DON	;... BE SURE THERE'S ANOTHER ONE
NOURLEAP	<
	SETZB	(PNT)		;ZERO FIRST WORD OF ASS. CELL.
>;NOURLEAP
	HRRM	PNT,(D)		;LINK FROM CONFLICT LIST OR HASH TABLE
NOURLEAP	<
	IOR	C,-1(P)		;GET VALUE THERE
>;NOURLEAP
	MOVEM	C,1(PNT)	;AND STORE A-O
NOURLEAP	<
	MOVE	C,-1(P)		;GET VALUE AGAIN
>;NOURLEAP
URLEAP	<
	SETZM	(PNT)		;DON'T LEAVE ANY GARBAGE
	MOVE	D,PNT		;REMEMBER LOCATION OF M.H. BLOCK ...
	MOVE	B,PNT		;... TWICE SO NEXT CAN KILL TWO
	MOVE	PNT,FP		;THIS WILL BE THE VALUE BLOCK
GOM1:	SKIPN	FP,(FP)
	 PUSHJ	P,FP2DON
	HRLM	PNT,(B)		;LINK V-BLOCK TO M.H. BLOCK OR PREVIOUS V-BLOCK
	HRLZM	D,1(PNT)	;LINK M.H. BLOCK TO VALUE BLOCK
	MOVE	C,-1(P)		;GET VALUE.
	HRRM	C,1(PNT)	;STORE IT IN VALUE BLOCK
>;URLEAP
	ADD	C,INFOTAB(TABL)	;NEED TO UPDATE VALUE LINK
	HLRZ	D,(C)		;OLD ONE
URLEAP	<
	HRRM	D,(PNT)		;STORE IN VALUE SPOT
>;URLEAP
NOURLEAP	<
	HRLM	D,(PNT)		;STORE IN VALUE SPOT
>;NOURLEAP
	HRLM	PNT,(C)		;AND UPDATE INFO TABLE.
	MOVEM	FP,FP2(TABL)	;SAVE NEW FREE POINTER.
OUT111:	SUB	P,[XWD 4,4]
	JRST	@4(P)		;RETURN, AFTER ADJUSTING STACK.

OUT1A:
URLEAP	<
	MOVE	PNT,C
>;URLEAP
NOURLEAP	<
	MOVE	PNT,A
>;NOURLEAP
	JRST	OUT111		;MUST HAVE PNT POINTING 
				;TO THING WE MADE.

URLEAP	<
DONE:			;AT LEAST A AND O MATCH TO GET HERE.
			;A POINTS TO THE M.H. BLOCK
	MOVE	D,A	;SAVE IT IN D FOR GOM1
	HLRZ	C,(A)	;GET FIRST V-BLOCK IN M.H. LIST
DONE1:	HRRZ	B,1(C)	;GET VALUE ITEM FROM V-BLOCK
	CAMN	B,-1(P)	;SEE IF IT'S THE ONE WE'RE LOOKING FOR
	 JRST	OUT1A	;IT'S ALREADY THERE!
	MOVE	B,C	;REMEMBER IN CASE IT'S THE END OF THE LIST
	HLRZ	C,(C)	;GO DOWN THE M.H. LIST TO THE NEXT VALUE BLOCK
	JUMPN	C,DONE1	;AND BACK AROUND UNLESS IT'S THE END OF THE LIST
	JRST	GOM1	;GO BUILD A NEW VALUE BLOCK
>;URLEAP

NOURLEAP	<
DONE:	MOVE	B,1(A)		;AT LEAST A AND O MATCH TO GET HERE.
	TRNN	B,7777		;MULTIPLE VALUES?
	JRST	MULVAL		;YES
	ANDI	B,7777
	CAMN	B,-1(P)		;COMPARE WITH SPECIFIED VALUE
	JRST	OUT1A		;IT IS ALREADY THERE!!!
	SKIPN	FP,(FP)		;MUST NOW MAKE A MULTIPLE VALUE GUY
	 PUSHJ	P,FP2DON
	MOVE	LPSA,FP		;ADDRESS ONE-WORD FREE
	EXCH	LPSA,PNT	;USE OLDER FREE FIRST
	HRL	A,(A)		;XWD CONF.LIST,,NEW MULT HIT LIST
	MOVSM	A,(LPSA)	;STORE XWD MH-LIST,,CONF LIST
	MOVEM	C,1(LPSA)	;STORE A-0 MH HEADER
	HRRM	LPSA,(D)	;LINK INTO CONFLICT LIST
	HRRZ	D,A		;FIRST ITEM ON CONFLICT LIST
	JRST	GOM

MULVAL:	HLRZ	A,(A)		;PICK UP POINTER TO MULT. VALS.
IN1:	MOVE	B,1(A)		;PICK UP A-O-V
	ANDI	B,7777		;SAVE ONLY VALUE
	CAMN	B,-1(P)		;THE RIGHT VALUE?
	JRST	OUT1A		;YES -- IT'S THERE
	MOVE	D,A		;BACK-POINTER
	HRRZ	A,(A)		;GET NEXT POINTER
	JUMPE   A,GOM		;PUT ON END OF MH LIST
	JRST	IN1		;LOOP UNTIL FOUND OR MH LIST EXHAUSTED
>;NOURLEAP
	
URLEAP	<
;JRST TO BMAKE
;BRACKETED TRIPLES ARE EVIL, AND THEREFORE THEY WILL BE INEFFICIENT
;UNTIL I GET AROUND TO FIXING THIS UP.
;THEY ARE IDENTIFIED BY A LIST OF TWO-WORD BLOCKS, IN THE FOLLOWING FORMAT:
;	XWD	ITEM #, NEXT B.T. BLOCK
;	XWD	0, VALUE BLOCK ADDRESS
;THE LIST HEADER IS BRACKL(TABL)
;ON EXIT, THE ITEM NUMBER WILL BE ON THE TOP OF THE STACK, AND PNT WILL
;CONTAIN THE ADDRESS OF THE ASSOCIATION

BMAKE:				;BRACKETED MAKE.......;;
	PUSHJ	P,MAKE		;GO MAKE IT.. ADDR OF ASSOC RETURNED IN PNT
	HRRZI	A,BRACKL(TABL)	;GET ADDRESS OF B.T. LIST
BM0:	HRRZ	A,(A)		;GO DOWN THE B.T. LIST
	JUMPE	A,BM1		;... IF THERE ARE ANY LEFT
	CAME	PNT,1(A)	;IS THIS ASSOCIATION ALREADY A B.T.?
	 JRST	BM0		;NO, GO BACK AND TRY AGAIN
;IT WAS ALREADY A BRACKETED TRIPLE
	HLRZ	A,(A)		;GET THE ITEM NUMBER OF THE ASSOCIATION
	PUSH	P,A		;SAVE IT FOR CALLER
	JRST	LEAV		;SPLIT
BM1:	PUSH	P,PNT		;SAVE ASSOCIATION ADDRESS
NOGLOB <
	HRLI	FLAG,BRKITM	;SO NEW WILL INIT TYPE
> ;NOGLOB
GLOB <
	TLZ	FLAG,-1≠GLBSRC	;DON'T DESTROY GLOBAL BIT
	TLO	FLAG,BRKITM 	;ITEM TYPE IS BRACKETED ITEM
> ;GLOB
	PUSHJ	P,NEWX		;GET A NEW ITEM.....
	MOVE	PNT,(P)		;PNT <- NEW ITEM NUMBER
	EXCH	PNT,-1(P)	;PNT <- ASSOCIATION ADDRESS
				;-1(P) <- ITEM NUMBER
	POP	P,B 		;B <- ITEM NUMBER, ITEM NUMBER AT TOP OF STACK
	MOVE	FP,FP2(TABL)	;GET A TWO-WORD FREE FOR A NEW B.T. BLOCK
	MOVE	A,FP		;SAVE ITS ADDRESS
	SKIPN	FP,(FP)
	 PUSHJ	P,FP2DON
	MOVEM	FP,FP2(TABL)	;SAVE NEW FREE POINTER
	MOVEM	PNT,1(A)	;SAVE ASSOCIATION ADDRESS IN B.T. BLOCK
	HRL	B,BRACKL(TABL)	;PICK UP OLD FIRST B.T. BLOCK
	MOVSM	B,(A)		;STORE ITEM #,,NEXT B.T. PTR IN NEW B.T. BLOCK
	MOVEM	A,BRACKL(TABL)	;UPDATE LIST HEADER
	ADD	B,DATAB(TABL)	;PREPARE TO MAKE VALUE ENTRY
	MOVEM	PNT,(B)		;POINTER TO ASSOC
	JRST	LEAV
>;URLEAP
NOURLEAP	<
;JRST TO BMAKE

BMAKE:				;BRACKETED MAKE.......;;
	PUSHJ	P,MAKE		;GO MAKE IT..
	HLRZ	A,(PNT)		;VALUE POINTER
	BRACKP	A		;IS IT ALREADY A BRACKETED?
	JRST	INALREADY	;YES
GLOB <
;MAKE HAS PUT JOB INTO WRITING SECTION
	SKIPN	FP,FP1(TABL)	;ONE-WORD FREES.
	PUSHJ	P,FP1DON	;NONE YET, GET SOME.
>;GLOB
NOGLOB <
	MOVE	FP,FP1(TABL)	;ONE-WORD FREES.
>;NOGLOB
	MOVEI	C,(FP)
	SKIPN	FP,(FP)
	 PUSHJ	P,FP1DON	;OUT OF FREE STORAGE.
	HRRM	FP,FP1(TABL)
	HRLM	A,(C)		;OLD VALUE LIST
	TRC	C,BRABIT	;TURN IT ON.(LOGICALLY)
	HRLM	C,(PNT)
	PUSH	P,PNT		;SAV ADDR OF IT
NOGLOB <
	HRLI	FLAG,BRKITM	;SO NEW WILL INIT TYPE
> ;NOGLOB
GLOB <
	TLZ	FLAG,-1≠GLBSRC	;DON'T DESTROY GLOBAL BIT
	TLO	FLAG,BRKITM 	;ITEM TYPE IS BRACKETED ITEM
> ;GLOB
	PUSHJ	P,NEWX		;GET A NEW ITEM.....
	MOVE	PNT,(P)
	EXCH	PNT,-1(P)
	POP	P,B 		;ITEM NUMBER.
	HLR	C,(PNT)		;THE BRACKET NODE
	TRC	C,BRABIT
	HRRM	B,(C)		;PUT ITEM NUMBER IN BRACKET NODE
	ADD	B,DATAB(TABL)	;PREPARE TO MAKE VALUE EENTRY
	MOVEM	PNT,(B)		;POINTER TO ASSOC
	JRST	LEAV


INALREADY:
	HRRZ	B,(A)		;ITEM NUMBER....
	PUSH	P,B
	JRST	LEAV
>;NOURLEAP

URLEAP	<
;PUSHJ, TO ERASE

ERASE:
GLOB <
	WRITSEC			;ANOTHER POINTER DIDDLING AREA !!
>;GLOB
	POP	P,PNT		;SAVE RETURN ADDRESS.
	JSP	LPSA,NOFOR	;IN LINE CALL
  	PUSH	P,PNT		; ";" ADDED 5-3 DCS
TRY:	MOVE	FLAG,-1(FPD)	;ROUTINE NAME.
	PUSHJ	P,@SEROUT(FLAG)	;GET THE RIGHT SEARCH
	POPJ	P,		;DONE... (IT FAILED)
	SKIPE	C,ERBP(USER)	;ERASE BREAK-POINT?
	 PUSHJ	 P,LPBRK	;A LEAP BREAK POINT !!!
;FIRST CHECK IF IT'S A BRACKETED TRIPLE
	SKIPN	B,BRACKL(TABL)	;PICK UP LIST OF B.T. BLOCKS
	 JRST	NBTE		;NO B.T.'S -- NO PROBLEMS
	MOVEI	C,BRACKL(TABL)	;GET ADDR OF B.T. LIST POINTER IN CASE FIRST
				;BLOCK MATCHES
CMPE:	CAMN	A,1(B)		;DOES THIS B.T. BLOCK POINT TO THIS ASSOC ?
	 JRST	YESE
	MOVE	C,B		;REMEMBER WHO POINTS TO US
	HRRZ	B,(B)		;GET POINTER TO NEXT B.T. BLOCK
	JUMPN	B,CMPE		;GO TRY AGAIN IF THERE IS ONE
NBTE:	;REMOVE THIS ASSOCIATION FROM ITS VALUE LIST
	HRRZ	B,1(A)		;GET THE VALUE ITEM
	ADD	B,INFOTAB(TABL)	;GET INFOTAB POINTER
	HLRZ	C,(B)		;FIRST VALUE BLOCK
	CAMN	C,A		;IS THE FIRST ONE THE ONE ?
	 JRST	[HRRZ	C,(C)		;GET ITS VALUE POINTER
		HRLM	C,(B)		;STORE IT IN INFOTAB
		JRST	ENXT]		;GO WORRY ABOUT M.H. LIST, ETC.
	JUMPN	C,ERS1		;GO TAKE CARE OF THE USUAL CASE
ERERR:	ERR	<DRYROT -- ERASE2>

YESE:	;FIX UP BRACKETED TRIPLES LIST & DELETE B.T. ITEM
GLOB	<
	SKIPN	FP,FP1(TABL)	;ANY FREES YET ?
	 PUSHJ	P,FP1DON	;NO, GO GET SOME
>;GLOB
NOGLOB	<
	MOVE	FP,FP1(TABL)	;GET A FREE TO LINK ONTO OLDITEMS
>;NOGLOB
	MOVE	PNT,FP		;ADDRESS OF NEW CELL
	SKIPN	FP,(FP)		;FOR NEXT TIME
	 PUSHJ	P,FP1DON	;GET SOME MORE IF NECESSARY
	HRRM	FP,FP1(TABL)	;UPDATE FREE STORAGE LIST HEAD
	HLRZ	D,(B)		;GET ITEM NUMBER
	ADD	D,DATAB(TABL)	;MAKE POINTER TO DATUM TABLE ENTRY
	SETZM	(D)		;CLEAR IT
	HLLZ	D,(B)		;GET ITEM NUMBER AGAIN
	HRR	D,OLDITM(TABL)	;BUILD ENTRY FOR DELETED ITEMS LIST
	MOVEM	D,(PNT)
	MOVEM	PNT,OLDITM(TABL);FIX LIST HEAD
	AOS	FREITM(TABL)	;INCREASE COUNT OF FREE ITEMS
	HRRZ	FP,FP2(TABL)	;NEXT RETURN B.T. BLOCK TO FREE STORAGE
	HRRZM	FP,(B)
	SETZM	1(B)
	HRRZM	B,FP2(TABL)	;UPDATE LIST HEAD
	JRST	NBTE		;GO WORRY ABOUT VALUE LIST, ETC.

ERS1:	MOVE	B,C		;REMEMBER WHO POINTS TO US
	HRRZ	C,(C)		;GET POINTER TO NEXT VALUE BLOCK
	JUMPE	C,ERERR		;IT HAS TO BE THERE
	CAME	C,A		;IS THIS THE ONE ?
	 JRST	ERS1		;GO BACK AND TRY AGAIN IF NOT
	HRRZ	C,(C)		;GET ITS VALUE POINTER
	HRRM	C,(B)		;LINK AROUND THIS VALUE BLOCK

ENXT:	;NOW FOR THE MULTIPLE HIT LIST
	HLRZ	C,1(A)		;GET THE BACK POINTER TO THE MULTIPLE HIT BLOCK
MHE:	JUMPE	C,ERERR		;IT HAS TO BE THERE
	MOVE	B,C		;REMEMBER WHO POINTS TO US
	HLRZ	C,(C)		;GET POINTER TO NEXT VALUE BLOCK
	CAME	C,A		;IS THIS THE ONE ?
	 JRST	MHE		;IF NOT TRY AGAIN
	HLRZ	C,(C)		;GET POINTER TO NEXT VALUE BLOCK
	HRLM	C,(B)		;LINK AROUND THIS VALUE BLOCK
	HLRZ	C,1(A)		;GET THE M.H. BLOCK AGAIN FOR LATER
	HRRZ	FP,FP2(TABL)	;WE'RE GONNA RETURN THE VALUE BLOCK TO FREE STG
	HRRZM	FP,(A)
	SETZM	1(A)
	HRRZM	A,FP2(TABL)	;FIX FREE LIST HEADER
	HLRZ	B,(C)		;THIS IS THE M.H. LIST POINTER
	JUMPN	B,TRY		;IF IT'S NON-ZERO WE'RE O.K.
;DELETE THE M.H. HEADER 'CAUSE THAT WAS THE ONLY ASSOCIATION ATTACHED TO IT
	HRRZ	B,1(C)		;GET THE OBJECT FROM THE M.H. HEADER
	HLRZ	A,1(C)		;GET ATTRIBUTE
	HASH	(A,A,B)
MHE1:	MOVE	B,A		;SAVE IT
	HRRZ	A,(A)		;GO DOWN CONFLICT LIST
	CAMN	A,C		;IS THIS THE ONE ?
	 JRST	[HRRZ	C,(C)	;FIX UP THE LINKS JUST AS BEFORE
		HRRM	C,(B)
		HRRZ	FP,FP2(TABL)	;RETURN IT TO FREE STORAGE
		HRRZM	FP,(A)
		SETZM	1(A)
		HRRZM	A,FP2(TABL)	;FIX UP FREE LIST HEADER
		JRST	TRY]
	JUMPN	A,MHE1
	ERR	<DRYROT -- ERASE3>
>;URLEAP
NOURLEAP	<
;PUSHJ, TO ERASE

ERASE:
GLOB <
	WRITSEC			;ANOTHER POINTER DIDDLING AREA !!
>;GLOB
	POP	P,PNT		;SAVE RETURN ADDRESS.
	JSP	LPSA,NOFOR	;IN LINE CALL
  	PUSH	P,PNT		; ";" ADDED 5-3 DCS
TRY:	MOVE	FLAG,-1(FPD)	;ROUTINE NAME.
	PUSHJ	P,@SEROUT(FLAG);GET THE RIGHT SEARCH
	POPJ	P,		;DONE... (IT FAILED)
	SKIPE	C,ERBP(USER)	;ERASE BREAK-POINT?
	 PUSHJ	 P,LPBRK	;A LEAP BREAK POINT !!!
	HRRZ	B,1(A)		;A POINTS TO ASS. CELL
	TRZ	B,770000	;NOW WE HAVE THE VALUE
	ADD	B,INFOTAB(TABL)	;NONO
GOE:	HLRZ	C,(B)		;VALUE LINK.
	BRACKP	C		;TEST FOR BRACKETED TRIPLE
	JFCL			;MACROS FORCE ONE OCCASIONALLY TO PARANOIA
	CAIN	C,(A)		;THE VERY SAME?
	JRST	YESE		;WE HAVE IT
	MOVE	B,C		;REMEMBER WHERE WE CAME FROM
	JUMPN	B,GOE
	ERR	<DRYROT -- ERASE1>;ASSOCIATION NOT ON VALUE LIST

YESE:	HLRZ	C,(A)		;AGAIN
	BRACKN	C		;A BRACKETED TRIPLE?
	JRST 	Y1		;NO
	MOVE	FP,OLDITM(TABL)	;PREPARE TO LINK ON LIST.
	MOVE	D,(C)		;THE ONE-WORD CELL
	HRL	FP,D		;ITEM NUMBER
	MOVEM	FP,(C)		;THIS IS THE THE OLD ITEM LIST.
	HRRZM	C,OLDITM(TABL)
	AOS	FREITM(TABL)	;COUNT THE NUMBER FREE
	MOVEI	C,(D)		;ITEM NUMBER
	HLLZS	@INFOTAB(TABL)	;ZERO INFOTAB ENTRY (WONDERS OF INDIRECT ADDR)
	CAME	A,@DATAB(TABL)	;SAME ASSOC. POINTER TO BRACKET INFO.
	ERR	<DRYROT -BRACKET CONFUSION>
	SKIPA
Y1:	HLLZ	D,(A)		;OLD POINTER ELSEWISE
Y2:	HLLM	D,(B)		;CHAIN NEW VALUE LINK.
	LDB	C,[POINT ITLEN,1(A),ITLEN-1];ATTRIBUTE
	LDB	D,[POINT ITLEN,1(A),2*ITLEN-1];OBJECT
	HASH	(B,C,D)
	MOVE	C,1(A)		;PICK UP THE WORD WE SEARCH FOR
	TRZ	C,7777		;AND TURN OFF VALUE.
	MOVE	PNT,(B) 	;FIRST IN CONFLICT LIST
LOOK:	CAIN	PNT,(A)		;DO WE POINT THERE?
	JRST	THISIT		;YES
	MOVE	D,1(PNT)	;GET A-O-V
	CAMN	D,C
	JRST	MULVLL		;A-O MATCH AT LEAST
	MOVE	B,PNT		;REMEMBER WHO POINTED AT US
	HRRZ	PNT,(PNT)	;GO DOWN CONFLICT LIST.
	JUMPN	PNT,LOOK		;AND LOOP
	ERR	<DRYROT -- ERASE2> ;NOT ON CONFLICT LIST

THISIT:	HRRZ	PNT,(A)		;CONFLICT
	HRRM	PNT,(B)		;BYPASS AROUND US.
	JRST	LINK		;RECLAIM THE WORD OF CORE.

MULVLL:
	HLRZ	C,(PNT)		;POINTER TO MULTIPLE HITS.
	CAIN	C,(A)		;IS THIS IT?
	JRST	FIST		;-- YESS AND THEFIRST ONE.
M1:	SKIPN	B,C
	ERR	<DRYROT -- ERASE3>;RFS FORGOT THIS ERROR CHECK - KKP
	HRRZ	C,(C)		;GET NEXT MULTIPLE HIT.
	CAIE	C,(A)
	JRST	M1		;LOOP UNTIL FOUND
	JRST	THISIT

FIST:	HRRZ	D,(A)		;NEXT IN LINE...
	JUMPE	D,MHDEL		;NONE LEFT WILL DELETE MH HDR
	HRLM	D,(PNT)		;MH LIST
	JRST	LINK		;RELEASE ASSOC TWO WORDS

MHDEL:	MOVE	FP,FP2(TABL)
	HRRZM	FP,(A)
	HRRZM	A,FP2(TABL)
	SETZM	1(A)
	MOVEI	A,(PNT)
	JRST	THISIT		;DELETE MH HDR

LINK:	HRRZ	FP,FP2(TABL)
	HRRZM	FP,(A)
	SETZM	1(A)
	HRRZM	A,FP2(TABL)
	JRST	TRY
>;NOURLEAP

; LEAP BREAKPOINTS EXIST.  
; ENTRY IS WITH ROUTINE ADDRESS IN C.


LPBRK:	PUSH	P,A		;ENTRY FROM ERASE.
	PUSH	P,FPD		;A PNTS TO ASSOCIATION (I.E. VALUE BLOCK)
				;TO BE ERASED.
NOURLEAP	<
	LDB	B,[POINT 12,1(A),11]
	PUSH	P,B
	LDB	B,[POINT 12,1(A),23];OBJECT
	PUSH	P,B
	LDB	B,[POINT 12,1(A),35];VALUE
	PUSH	P,B
	PUSH	P,B		;STACKS NEED TO BE EQUAL
>;NOURLEAP
URLEAP	<
	HLRZ	B,1(A)		;BACK POINTER TO M.H. HEADER
	HLRZ	FPD,1(B)	;ATTRIBUTE (USE FPD AS TEMP)
	PUSH	P,FPD		;REPLICATE STACK OF MAKE
	HRRZ	FPD,1(B)	;OBJECT
	PUSH	P,FPD
	HRRZ	B,1(A)		;VALUE (FROM VALUE BLOCK)
	PUSH	P,B
	PUSH	P,B		;STACKS NEED TO BE EQUAL.
	MOVE	FPD,-4(P)	;RESTORE FPD TO ITS VALUE ON ENTRY
>;URLEAP
	PUSHJ	P,LPBRK1	;GO DO IT.
	SUB	P,[XWD 4,4]	;ALL GONE.
	POP	P,FPD
	POP	P,A
	POPJ	P,

LPBRK1:				;ENTRY FROM MAKE.
	HRL	TEMP,LEABOT(USER)
	ADD	P,[XWD FRCHLEN,FRCHLEN]
	SKIPL	P		;SEE IF WE OVERFLEW THE STACK.
	 JSP	USER,$PDLOV		;YES, SIGH.
	HRRI	TEMP,1-FRCHLEN(P)
	BLT	TEMP,(P)	;SAVE WORK AREA. SINCE BRK MAY CALL LEAP
	PUSH	P,FLAG
	PUSH	P,UUO1(USER)
GLOB <
	NOSEC				;SO BREAKPOINT ROUTINE CAN CALL LEAP
	PUSH	P,TABL
	PUSH	P,-7-FRCHLEN(P)	;ATTRIBUTE
	PUSH	P,-7-FRCHLEN(P)	;OBJECT
	PUSH	P,-7-FRCHLEN(P)	;VALUE
>;GLOB
NOGLOB<
	PUSH	P,-6-FRCHLEN(P)	;ATTRIBUTE
	PUSH	P,-6-FRCHLEN(P)	;OBJECT
	PUSH	P,-6-FRCHLEN(P)	;VALUE
>;NOGLOB
	PUSHJ	P,(C)		;CALL ROUTINE
GLOB <
	POP	P,TABL
>;GLOB
	MOVE	USER,GOGTAB	;SET UP AGAIN.
	POP	P,UUO1(USER)
	SUB	P,[XWD FRCHLEN+1,FRCHLEN+1];REMOVE OLD FLAG AND OLD SCB
	HRLI	TEMP,1(P)
	HRR	TEMP,LEABOT(USER)
	HRRI	FLAG,FRCHLEN-1(TEMP)
	BLT	TEMP,(FLAG)	;RESTORE OLD SCB
	MOVE	FLAG,FRCHLEN+1(P)	;RETRIEVE FLAG
GLOB <
	WRITSEC			;IN CASE GLOBAL
>;GLOB
	POPJ	P,


INTERNAL BRKERS,BRKMAK,BRKOFF	;BREAKPOINT FOR ERASE,BREAKPOINT FOR MAKE.

HERE (BRKERS)	
	SKIPA	TEMP,[ERBP]
HERE (BRKMAK)
	MOVEI	TEMP,MKBP;THE POSITIONS.
	ADD	TEMP,GOGTAB;HO HO.
	POP	P,USER
	POP	P,(TEMP);SUBROUTINE NAME.
	JRST	(USER)


HERE (BRKOFF)			;TURN OFF BREAKPOINTS
	MOVE	USER,GOGTAB
	SETZM	ERBP(USER)
	SETZM	MKBP(USER)
	POPJ	P,		;RETURN

DSCR ISTRIPLE, SELECTOR
⊗;


; INITIALIZATION ROUTINE FOR THE ROUTINES THAT FOLLOW.
;ALL THESE ROUTINES ARE CALLED BY PUSHJ P,

INIT1:	
;	MOVE	FRTAB,FRLOC(USER)
	MOVE	B,-2(P)		;ARGUMENT
;	TLNE	FLAG,BOUND⊗ATTPOS
;	XCT	MOVEB(FRTAB)
	MOVE	C,B		;COPY ITEM NUMBER
	ADD	C,INFOTAB(TABL) ;ADDRESS OF TYPE FLAGS
	LDB	C,[POINT 9,(C),35];GET TYPE FLAGS
	ADD	B,DATAB(TABL)	;ADDRESS TRIPLE POINTER
	POPJ	P,

; ISTRIPLE

ISTRIPLE:
	PUSHJ	P,INIT1
	CAIE	C,BRKITM
	TDZA	A,A
	SETOM	A
RET:	SUB	P,X22
	JRST	@2(P)


SELECTOR:			;FOR COMPUTING FIRST,SECOND,THIRD.
	PUSHJ	P,INIT1
	CAIE	C,BRKITM	;IS IT BRACKETED
URLEAP	<
	 ERR	<NOT A BRACKETED TRIPLE>,1
	HRRZ	C,(B)		;GET ADDRESS OF VALUE BLOCK
	SUBI	FLAG,SELET1-ROUTABLE-2
;WE SHOULD NOW HAVE FLAG = 2 IF ATTRIBUTE WAS REQUESTED, 3 FOR OBJECT,
;OR 4 FOR VALUE.
	TRNN	FLAG,3		;SKIP IF ATTRIBUTE OR OBJECT
	 JRST	[HRRZ	B,1(C)	;GET VALUE ITEM NUMBER
		JRST	SLCT1]
	HLRZ	B,1(C)		;BACK POINTER TO M.H. HEADER
	MOVE	B,1(B)		;ATT-OBJ WORD
	TRNN	FLAG,1		;SKIP IF OBJECT DESIRED
	 MOVS	B,B		;PUT ATTRIBUTE IN R.H.
SLCT1:	HRRZM	B,-1(P)		;STORE IT AS A RETURNED VALUE
>;URLEAP
NOURLEAP	<

	JRST	ERR1		;NO, ERROR	
	HRRZ	C,(B)
	MOVE	B,1(C)		;GET A-O-V GUY.
	TRNN	B,-1
ERR1:	ERR	<NOT A BRACKETED TRIPLE>,1
	SUBI	FLAG,SELET1-ROUTABLE-2
	TRNE	FLAG,1
	LSH	B,ITLEN
	TRNE	FLAG,2
	LSH	B,-(2*ITLEN)
	ANDI	B,7777		;A FULL-FLEDGED ITEM
	MOVEM	B,-1(P)		;STORE IT AS A RETURNED VALUE
>;NOURLEAP
	POPJ	P,

DSCR DELETE

DELETE -- ITEM PASSED IN STACK. IT IS DELETED. THIS INVOLVES
	COPYING IT ONTO THE "RECENT FREE ITEM" LIST,
	REMOVING ITS PRINTNAME IF ANY, RELEASING THE
	ARRAY WHICH WAS ITS DATUM IF THAT WAS THE CASE.
	IF IT'S A BRACKETED TRIPLE ITEM, WE DELETE THE
	ITEM BUT LEAVE THE TRIPLE (I.E. IT'S NO LONGER A
	BRACKETED TRIPLE BUT IT'S STILL IN THE STORE.
⊗;

DELETE:				;JRST TO DELETE....
	HRRZ	A,HASHP(USER)	;IF THERE ARE PRINTNAMES.
	JUMPE	A,NOPRN		;NO
	PUSH	P,(P)		;ITEM NUMBER.
	PUSHJ	P,DEL.PNAME	;DELETE THE PNAMES.
NOPRN:
	PUSH	P,(P)		;COPY ITEM NUMBER
	MOVE	C,(P)		;GET ITEM NUMBER
;;#NZ# RHT 8-30-73 1 OF 1
	CAIG	C,7		;IS THIS TURKEY DELETING ONE OF THE GOOD GUYS
	ERR	<DELETE OF A RESERVED ITEM>,1
;;#NZ#
GLOB <
	TLNN	FLAG,GLBSRC	;LOCAL DELETE?
	CAIG	C,GBRK		;HAD BETTER BE LOCAL ITEM.
	JRST	.+2
	ERR	<LOCAL DELETE OF GLOBAL ITEM>,1
	TLNE	FLAG,GLBSRC	;GLOBAL DELETE?
	CAIL	C,GBRK		;HAD BETTER BE GLOBAL ITEM.
	JRST	.+2
	ERR	<GLOBAL DELETE OF LOCAL ITEM>,1
>;GLOB
	PUSHJ	P,TYPEX		;GET ADDRESS OF DATUM,,TYPE
	HLRZ	B,A		;ADDRESS OF DATUM
	HRRZS	A		;TYPE
	CAIE	A,PRCTYP	;PROCESS TYPE?
	JRST	NTPRCT
	PUSH 	P,UUO1(USER)	;SINCE TERMIN WILL DESTROY
	PUSH	P,A
	PUSH	P,B
	PUSH	P,C
	PUSH	P,C		;ITEM PARAMETER TO TERMINATE
	PUSHJ	P,TERMIN
	POP	P,C
	POP	P,B
	POP	P,A
	MOVE	USER,GOGTAB
	POP	P,UUO1(USER)

GLOB <
	MOVEI	TABL,(USER)	;WE KNOW IT IS A LOCAL ITEM
>;GLOB
	JRST	CLRDAT
NTPRCT:
	JUMPN	A,.+2		;ALREADY DELETED?
	ERR	<DELETE - DELETED NON-EXISTANT ITEM>
GLOB<
	WRITSEC			;CRITICAL SECTION
>;GLOB
	ADD	C,INFOTAB(TABL)	;
	HLLZS	(C)		;MARK AS DELETED
	CAIE	A,BRKITM 	;BRACKETED TRIPLE?
	JRST	NOBRACK		;NO
;BRACKETED TRIPLE
URLEAP	<
	HRRZ	C,(B)		;ADDR ASSOC.
	MOVEI	A,BRACKL(TABL)	;LIST HEAD OF B.T. BLOCKS
DBT1:	MOVE	D,A		;REMEMBER WHO POINTS TO US
	HRRZ	A,(A)		;NEXT B.T. BLOCK
	SKIPN	A		;IF WE RUN OUT, WE'RE REALLY SCREWED UP
	 ERR	<DRYROT -- BRACKETED TRIPLE DELETE>
	CAME	C,1(A)		;IS THIS THE BLOCK THAT HAS TO GO?
	 JRST	DBT1		;THIS IS WOEFULLY INEFFICIENT, BUT ...
	HRRZ	C,(A)		;NEXT POINTER FROM DOOMED B.T. BLOCK
	HRRM	C,(D)		;MAKE LIST GO AROUND IT
	SETZM	1(A)		;CLEAR IT OUT IN PREPARATION FOR ...
	HRRZ	FP,FP2(TABL)	;... RETURNING IT TO THE TWO-WORD FREE LIST
	HRRZM	FP,(A)
	HRRZM	A,FP2(TABL)	;UPDATE LIST HEADER
	JRST	CONDEL
>;URLEAP
NOURLEAP	<
	MOVE	C,(B)		;ADDR ASSOC.
	HLRZ	PNT,(C)		;A-O-V OF BRACKET
	BRACKN	(PNT)		;REALLY A BTRIP?
	 ERR	<DRYROT-BRACKETED TRIPLE DELETE>,1 ; NO
	HLRZ	D,(PNT)		;NEXT IN VALUE LIST
	HLRM	D,(C)		;ASSOC NO LONGER BTRIP
	JRST	LINKOLD		;LINK BTRIP ITEM INTO FREELIST
>;NOURLEAP
NOBRACK:
	CAIE	A,RFITYP	;REFITM?
	JRST	NOTREF		;NO
; A REFITM
	MOVE	C,(B)		;GET THE DATUM OF REFITM
	TLNE	C,REFB		;BY REFERENCE?
	JRST	CLRDAT		;YES,EASIEST CASE OF ALL
	TLNE	C,ITEMB		;AN ITEM TYPE THING?
	JRST	RELONE		;YES, JUST NEED TO RELEASE THE ONE WORD FREE
;;#UC# (1) ! USED TO BE (C)
	LDB	D,[POINT 6,C,12] ;GET TYPEIT CODE
	CAIN	D,STTYPE	;IS THIS A STRING TEMP
	JRST	DLSREF		;YES 
	CAIE	D,LSTYPE	;A LIST TYPE THING?
	CAIN	D,SETYPE
	JRST	DLSTREF
RELONE:
	HRR	FP,FP1(TABL)
	HRRZM	FP,(C)		;LINK THE FREE IN.
	HRRM	C,FP1(TABL)	;NEW FREE LIST
	JRST	CLRDAT		;REMAINDER OF DELETE
DLSREF:	HLRZ	D,HASHP(USER)	;FREE STRING DESCRIPTOR LIST
;;#TY# (CMU =E5=) LDE ! 2-10-75 ZERO FIRST WORD OF DESCRIPTOR 
	SETZM	-1(C)		;SO GARBAGE COLLECTOR IS HAPPY
	HRRZM	D,(C)
	HRLM	C,HASHP(USER)
	JRST	CLRDAT		;REMAINDER OF DELETE
DLSTREF:			;SET OR LIST
;;#UC# (2) USED TO BE HLRZ D,(C)
	HRRZ	D,(C)		;ADDRESS OF LAST,,FIRST WORD
	HLRZ	D,(D)		;ADDRESS OF LAST WORD IN LIST
;;#UC# ↑
	HRR	FP,FP1(TABL)
	HRRZM	FP,(D)
	HRRM	C,FP1(TABL)	;FREE THE TEMP AND LIST AT ONCE
	JRST	CLRDAT
NOTREF:				;CONTINUE TO CHECK SPECIAL CASES
REC <
;;#VG# DONT NEED TO DEREFERENCE ANY MORE
NORGC <
	**** THIS SHOULD NOT ASSEMBLE ****
	CAIE	A,RECTYP	;A RECORD ITEM?
	JRST	NOTREC		;NOPE
	RECUUO	0,(B)		;DEREFERENCE THIS ONE
	JRST	CLRDAT		;
NOTREC:
>;NORGC
>;REC
;;%BI% ! USED TO TEST ARRTYP
	CAIG	A,MXSTYP ;SEE IF ARRAY (IE GREATER THAN MAX SCALAR TYPE)
	JRST	CLRDAT	;NO CLEAR DATUM
	CAIN	A,INVTYP ;INVALID TYPE?
	ERR	<DRYROT - ITEM TYPE CONFUSION>
;; #ND# !  BETTER SAVE B ALSO
	PUSH	P,B		;SAVE B OVER ARRAY STUFF
	CAIE	A,LSTYPE+ARRTYP
	CAIN	A,SETYPE+ARRTYP
	JRST	[ PUSH	P,A  ;CALL WILL DESTROY
;; #ND# BAD CALLING SEQUENCE TO ARRRCL, WAS DOING MOVE A,(B) INSTEAD OF PUSH
		  PUSH  P,(B)  ;ARRAY DESCRIPTOR
;; #ND#
		  PUSHJ P,ARRRCL
		  POP   P,A
		  JRST  .+1]
	SKIPN	B,@(P)		;DATUM
	ERR	<DRYROT - DELETE MISSING ARRAY ITEM>,1
	CAIE	A,STTYPE+ARRTYP	;STRING ARRAY
	JRST	RELGO		;NO.
	MOVEI	LPSA,ARYLS(USER) ;LINKED LIST OF STRING ARRAYS
	MOVE	C,ARYLS(USER)	;
	HLRZ	D,(C)		;ARRAY POINTER
	CAIE	D,(B)		;RIGHT ONE?
	JRST	[MOVEI LPSA,(C)
		HRRZ C,(C)
		JUMPN	C,.-2
		ERR	<STRING ARRAY ITEM CONFUSION>]
	HRR	D,(C)		;REMOVE FROM ARYL LIST
	HRRM	D,(LPSA)
	HRR	D,FP1(USER)	;LINK ONTO FREE LIST
	HRRM	D,(C)		
	HRRM	C,FP1(USER)     ;
	SUBI	B,1		;ADDR STRING ARRAY ITEM
RELGO:	HLRE	C,-1(B)		;NUMBER OF DIMENSIONS
	MOVMS	A,C		;WILL DO 2 ADDS TO SIMUL. MULT BY 3
	ADDI	C,(C)
	ADDI	C,(A)
	SUBI	B,2(C)		;NOW A CORGET POINTER
	PUSHJ	P,CORREL	;RELEASE ARRAY SPACE
	POP	P,B		;DATUM ADDRESS
	JRST	CONDEL		;CONTINUE WITH REST OF DELETE
CLRDAT: CAIE	A,LSTYPE	;A SIMPLE LIST?
	CAIN	A,SETYPE	;A SIMPLE SET
	JRST	[SKIPN	A,(B)   ;SEE IF NULL LIST OR SET
		JRST .+1	;NULL SO IGNORE
		SKIPG	A	;TEMP?
		ERR	<DRYROT-TEMP. CONTAINED IN ITEM LIST OR SET >
		PUSH	P,B	;SAVE DATUM ADDRESS
		PUSHJ	P,RECQQ	;RECLAIM LIST SPACE
		POP	P,B
		JRST    CONDEL]
	CAIN	A,CTXTYP	;A CONTEXT ITEM?
	JRST	[PUSH P,UUO1(USER) ;ALLFOR DESTROYS
		 PUSH P,B       ;THE ADDRESS OF CONTEXT
		 PUSHJ	P,ALLFOR
		 MOVE USER,GOGTAB
		 POP  P,UUO1(USER)
		 JRST	CONDEL]
	CAIE	A,STTYPE	;A STRING ITEM
	JRST	CONDEL		;NO.
	MOVE	A,(B)		;ADDRESS STRING DESCRITOR
	SETZM	-1(A)		;NULL STRING
	HLRZ	C,HASHP(USER)	;OLD STRING LIST
	HRRM	C,(A)		;LINK DELETED DESCRIPTOR ONTO IT
	HRLM	A,HASHP(USER)	;SAVE NEW LIST
CONDEL:

GLOB<	
	SKIPN	FP,FP1(TABL)	;ANY FREES YET?
	PUSHJ	P,FP1DON	;NONE YET. GET SOME.
>;GLOB

NOGLOB <
	MOVE	FP,FP1(TABL)	;NEED TO MAKE FREE ITEM CELL
>;NOGLOB

	MOVEI	PNT,(FP)	;ADDRESS NEW CELL
	SKIPN	FP,(FP)		;FOR NEXT TIME
	PUSHJ	P,FP1DON	;GET SOME MORE IF NECESSARY
	HRRM	FP,FP1(TABL)	;UPDATE FREE STORAGE LIST HEAD
LINKOLD:
	SETZM	(B)		;MAKE SURE DATUM IS CLEARED
	MOVS	B,(P)		;ITEM NUMBER
	HRR	B,OLDITM(TABL)
	MOVEM	B,(PNT)
	MOVEM	PNT,OLDITM(TABL)	;UPDATE LIST OF DELETED ITEMS
	AOS	FREITM(TABL)	;INCREASE COUNT OF FREE
ALDDD:
	POP	P,A		;REMOVE ITEM
	JRST	LEAV		;EXIT 		
DSCR ARRRCL			;RECLAIM ARRAY OF SETS,LISTS
	TO RECLAIM AN ARRAY OF LISTS OR SETS
	ONLY RECLAIMS LIST SPACE, NOT ARRAY SPACE
	ARRAY ADDR IN -1(P)
	ROUTINE CALLED WITH PUSHJ
	SAVES AC'S
	⊗
HERE(ARRRCL)			;RECLAIM AN ARRAY OF LISTS
	PUSHJ	P,FSAV		;SAVE AC'S
	MOVE	B,-1(P)		;ADDRESS OF ARRAY
	HRRZ	C,-1(B)		;NUMBER OF ELEMENTS IN ARRAY
ARLOOP:	MOVEI	TAC1,(B)	;ADDRESS OF LIST
	SKIPGE	A,(TAC1)	;TEST IF TEMPORARY
	ERR	<ARRAY TEMP SET -CONFUSION>
	JUMPE	A,INCBC		;IF NULL, NO NEED TO RECLAIM
	PUSH	P,B		;SAVE AC
	PUSH	P,C		;SAVE AC
	PUSHJ	P,RECQQ		;RECLAIM SET
	POP	P,C		;RESTORE
	POP	P,B		;RESTORE
INCBC:	ADDI	B,1		;TO NEXT ELEMENT ADDRESS
	SOJG	C,ARLOOP	;MORE?
	PUSHJ	P,FREST		;RESTORE CALLERS AC`S
	SUB	P,X22		;ADJUST STACK
	JRST	@2(P)		;RETURN
DSCR NEW (VARIOUS KINDS), AND ARRAY ITEM CODE.
NEW AND NEWX -- RETURN WITH THE STACK BUMPED BY ONE, AND
	THE TOP OF STACK HAS A SHINY NEW ITEM.  THE
	DATUM ENTRY IS ZEROED.  THE INFOTAB ENTRY IS NOT
	ZEROED IN CASE THERE ARE ERRONEOUS ASSOCIATIONS
	STILL USING THAT VALUE LIST.THE RIGHT HALF OF INFOTAB
	WILL CONTAIN 0 PROPS FIELD AND TYPE OF NEW ITEM (FROM
	LEFT HALF OF FLAG)

NEWART -- CALL IS WITH ARITHMETIC VALUE IN STACK.
	RETURNS A NEW ITEM NUMBER, WITH ARITHMETIC VALUE
	STUFFED IN DATUM ENTRY.

NEWARY -- CALL IS WITH ARRAY DESCRIPTOR IN STACK.
	RETURNS A NEW ITEM NUMBER, WITH DESCRIPTOR OF
	COPIED ARRAY STUFFED IN DATUM ENTRY.

⊗;


NEW:				;GET A NEW ITEM NUMBER.
NEWX:
GLOB <
	WRITSEC		;ENTER CRITICAL SECTION.
>;GLOB
	SKIPN	C,OLDITM(TABL)	;SEE IF ANY DUSTY OLD ITEMS.
	JRST	NWITM	;CAN'T USE A LITERAL HERE
	MOVEI	B,(C)		;PREPARE TO FREE THE ONE WORD
	MOVS	C,(C)
	HLRZM	C,OLDITM(TABL)	;UPDATED POINTER.
	HRR	FP,FP1(TABL)	;WILL ADD WORD FROM OLDITM LIST
	HRRM	FP,(B)		;LINK ON
	HRRM	B,FP1(TABL)	;NEW HEAD OF ONE-WORD FREES
URLEAP	<
	HRRZ	C,C		;CLEAR L.H., LEAVING ITEM NUMBER
>;URLEAP
NOURLEAP	<
	ANDI	C,TOPITM	;ITEM NUMBER.
>;NOURLEAP
REITM:	
URLEAP	<
	SOSGE	FREITM(TABL)	;ONE LESS FREE
	 ERR	<DRYROT - LEAP NEW FREITM BUG>,1
>;URLEAP
NOURLEAP<
	SOS	FREITM(TABL)	;CAN GO NEGATIVE BECAUSE OF ALLOCATION FUDGE
>;NOURLEAP
GLOB <
	TLNN	FLAG,GLBSRC
>;GLOB
	SETZM	@DATM		;ZERO THE DATUM.
GLOB <
	TLNE	FLAG,GLBSRC	;IF GLOBAL THEN
	SETZM	@GDATM		;ALSO ZERO THE GLOBAL DATUM.
>;GLOB
	MOVE	A,INFOTAB(TABL)	;ADDRESS INFOTAB
	ADDI	A,(C)		;ADDRESS THIS ITEM ENTRY
	HLLZ	B,FLAG		;GET TYPE CODE
GLOB<	TLZ	B,GLBSRC	;TURN OFF GLBSRC BIT
>;GLOB
	HLRM	B,(A)		;STORE TYPE CODE
	EXCH	C,(P)		;RECORD NEW ITEM NUMBER
				;IN STACK.
	JRST	(C)		;EXIT.
NWITM:	;JRST HERE FROM ABOVE
GLOB <
NOURLEAP <
	TLNE	FLAG,GLBSRC;IF GLOBAL THEN
	SOSA	C,MAXITM(TABL);USE GLOBAL COUNT.
	AOS	C,MAXITM(USER);USE LOCAL ITEM NUMBER.
	CAIGE	C,GBRK	;ABOVE THE BREAK?
	 JRST [	TLNE FLAG,GLBSRC;	WAS IT A GLOBAL SEARCH
		ERR	<GLOBALS OVERFLOWED INTO LOCALS>,1
		JRST REITM]	;NO --PROCEED.
	TLNN	FLAG,GLBSRC ;IF GLOBAL REQUEST, OK.
	ERR	<LOCALS OVERFLOWED INTO GLOBALS>,1
	CAIGE	C,TOPITM ;IF GONE TOO HIGH.
>;NOURLEAP
URLEAP <
	TLNE	FLAG,GLBSRC;IF GLOBAL THEN
	SOSA	C,MAXITM(TABL);USE GLOBAL COUNT.
	SOS	C,ITMBOT	;USE LOCAL ITEM NUMBER
	CAIL	C,GBRK	;IF ABOVE BREAK,...
	 JRST	REITM	;... NO ERROR POSSIBLE
	TLNE	FLAG,GLBSRC	;WAS IT A GLOBAL ITEM?
	 ERR	<GLOBAL ITEM OVERFLOW>,1
	CAMLE	C,TPALLC	;IF GONE TOO LOW, THEN
>;URLEAP
>;GLOB
NOGLOB <
NOURLEAP <
	AOS	C,MAXITM(USER);USE LOCAL ITEM NUMBER.
	CAMGE	C,ITMTOP(USER);IF GONE TOO HIGH. THEN
>;NOURLEAP
URLEAP <
	SOS	C,ITMBOT	;USE LOCAL ITEM NUMBER
	CAMLE	C,TPALLC	;IF GONE TOO LOW, THEN
>;URLEAP
>;NOGLOB
	 JRST REITM
	ERR	<ITEM SPACE EXHAUSTED>

NEWART:		;PUSHJ HERE FOR NEW WITH ARITHMETIC TYPE
	POP	P,FRTAB		;RETURN ADDRESS.
	HLRZ	B,FLAG
	CAIE	B,STTYPE	;IF STRING THEN VALUE IS NOT ON PSTACK
	POP	P,FPD		;VALUE
	PUSHJ	P,NEWX		;GET NEW ITEM
	MOVE	PNT,(P)
	ADD	PNT,DATAB(TABL)
	MOVEM	FPD,(PNT)	;DATUM...
	HLRZ	B,FLAG
GLOB<
	TRZ	B,GLBSRC	;TURN IF OFF IF ON
	>;GLOB
	CAIE	B,LSTYPE	;LIST?
	CAIN	B,SETYPE	;SET
	JRST	[PUSH	P,FPD
		 PUSH	P,FRTAB ;RETURN ADDRESS
		 MOVEI	TAC1,(PNT)
		 JRST	DUPSET]  ;MUST COPY 
	CAIN	B,RFITYP
	JRST	REFITM
	CAIE	B,STTYPE	;STRING?
	JRST	(FRTAB)		;NO,RETURN.
	PUSH	P,FRTAB		;RETURN ADDRESS
	PUSHJ	P,SDESCR	;GET AN NIL STRING DESCRIPTOR
	POP	P,A		;ADDRESS DESCRIPTOR
	MOVEM	A,(PNT)		;ADDRESS INTO DATAB
	POP	SP,(A)
	POP	SP,-1(A)	;STORE INITIAL STRING
	POPJ	P,		;RETURN

REFITM:
	HLLZ	B,(PNT)		;THE TYPE BITS
	TLNE	B,REFB		;REFERENCE?
	JRST	(FRTAB)		;EVERYTHING DONE
	TLZ	B,37		;TURN OFF @ AND INDEX(FOR VALUE STRINGS)
	HRROI	C,@(PNT)	;THE ADDRESS OF A TEMP
	TLNE	B,ITEMB		;VALUE ITEMVAR?
	JRST	SMPL		;EASY
	HLRZ	D,B		;GET THE TYPE BITS
	LSH	D,-5		;
	ANDI	D,77		;JUST THE TYPEIT CODE
	CAIN	D,STTYPE	;STRING?
	JRST	SREF		;YES
	CAIE	D,LSTYPE	;LIST OR
	CAIN	D,SETYPE	;SET?
	JRST	STREF		;YES
SMPL:
; AT THIS POINT.
; PNT POINTS TO DATUM TABLE ENTRY
; LH(B) CONTAINS THE TYPE BITS
; RH(C) POINTS TO A CELL CONTAINING VALUE TO BE SAVED
; FRTAB CONTAINS RETURN ADDRESS
; 	THIS ROUTINE CAN'T USE AC D AS C MAY POINT TO AC D IN CASE OF LISTS
GLOB <
	SKIPN	FP,FP1(TABL)	;ANY FREE'S YET
	PUSHJ	P,FP1DON	;NO, GO GET SOME.
>;GLOB
NOGLOB <
	MOVE	FP,FP1(TABL)	;ADDRESS OF FREE
>;NOGLOB
	HRRI	B,(FP)		;SAVE ADDRESS OF FREE
	SKIPN	FP,(FP)		;FOR NEXT TIME
	PUSHJ	P,FP1DON	
	HRRM	FP,FP1(TABL)
	MOVEM	B,(PNT)		;SAVE IN DATUM TABLE
	MOVE	PNT,(C)		;VALUE TO BE SAVED
	MOVEM	PNT,(B)		;SAVE IN ONE WORD FREE WE JUST GOT
	JRST	(FRTAB)		;RETURN
SREF:				;A VALUE STRING
	PUSHJ	P,SDESCR	;GET A STRING DESCRIPTOR
	POP	P,A		;POINTS TO DESCRIPTOR WE GOT
;; #SB# RHT VALUE STRINGS NOW ON SP STACK
	POP	SP,(A)		;COPY STRING
	POP	SP,-1(A)
;; #SB#
	HRR	B,A
	MOVEM	B,(PNT)		;INTO DATUM TABLE
	JRST	(FRTAB)		;RETURN
STREF:				;SET OR LIST
	SKIPG	D,(C)		;IF NULL OR TEMP SET 
	JRST	SIMSET		;NO NEED TO COPY
	PUSH	P,B		;SAVE TYPE BITS
	PUSH	P,PNT		;AND DATUM TABLE POINTER OVER CALL TO CAT
	PUSH	P,(C)
	PUSH	P,[0]
	PUSHJ	P,CATLST	;LET CAT COPY SET
	POP	P,D
	POP	P,PNT
	POP	P,B
SIMSET:	HLRE	C,D		;THE TEMP SET INDICATOR
	MOVMS	C		;MAKE PERMANENT
	HRL	D,C		;NOW A PERM SET
	MOVEI	C,D		;SET UP FOR SMPL
	JRST	SMPL

NEWARY:				;JRST HERE
GLOB <
	TLNE	FLAG,GLBSRC
	SETOM	USCOR2(USER)
>;GLOB
	PUSHJ	P,ARCOP		;COPIES THE ARRAY IN -1(P)
;; #NW ! MAKE SURE LH(ARRAY PTR) ZERO,(AVOID DRYROT ON DELETING STRING ARRAY ITEM);
	HRRZS	A
	PUSH    P,A		;SAVE POINTER
				;RETURNS POINTER IN A
	PUSHJ	P,NEW		;GET A NEW ITEM.
				;ITEM IS ON TOP OF STACK.
 	MOVE    A,-1(P)		;POINTER
	MOVE	PNT,(P)		;ITEM NUMBER
 	JSP	FPD,ARYL	;MARK AN ARRAY; LINK INTO ARYLS.
	POP	P,A		;ITEM NUMBER  
	EXCH    A,(P)		;EXCHANGE WITH ARRAY POINTER
	HLRZ	B,FLAG		;GET TYPE CODE OF NEW ARRAY
GLOB <
	TRZ	B,GLBSRC	;TURN OFF GLBSRC
>;GLOB
	CAIE	B,SETYPE+ARRTYP	;A SET ARRAY?
	CAIN	B,LSTYPE+ARRTYP ;A LIST ARRAY?
	PUSHJ	P,COPARR	;YES

GLOB <
	SETZM	USCOR2(USER)
>;GLOB
	JRST	LEAV

↑COPARR:PUSH	P,A		;ADDRESS BASE OF ARRAY
	SOS	(P)		;SO AOS WILL WORK BELOW
	PUSH	P,-1(A)		;SIZE OF ARRAY
	HRRZS	(P)		;REMOVE DIMENSION INFO.
LPCOPA:	SOSGE	(P)		;THROUGH COPYING?
	JRST	[ SUB	P,X22
		  POPJ	P,]
	AOS	TAC1,-1(P)	;ADDRESS THIS SET
	PUSH	P,(TAC1)	;SET TO BE COPIED
	PUSHJ	P,DUPSET	;COPY SET
	JRST	LPCOPA		;LOOP


;THIS IS THE "NEW ARRAY" CODE.  
;THIS MAKES ARRAYS FOR ITEMS AND PUTS THE DESCRIPTOR IN THE
;DATUM TABLE
GLOB <
;IF FLAG HAS GLBSRC ON, THIS IS GOING TO BE A GLOBAL ARRAY.
;IF FLAG HAS THE ARRTYP BIT IN THE LEFT HALF, THIS IS A REAL LEAP
;ARRAY (MEANING IT IS THE DATUM OF SOME ITEM)
;IF FLAG DOES NOT HAVE THE ARRTYP BIT SET IN THE LEFT HALF,
;IT IS PRESUMABLY A GLOBAL ARRAY OF SOME SORT.
>;GLOB

ITMYR:				;COMPILED IN LOCAL ARRAY ITEM
	HLRZ	A,TEMP		;LEFT OVER FROM HRLI FOR
	POP	P,PNT		;ITEM NUMBER.
	MOVEI	FPD,LEAV	;IN LINE CALL.
	JRST	ARYPUT		;COMPILED IN ARRAY.
ITMRY:				;COMPILED IN GLOBAL ARRAY OR ARRAY ITEM
	MOVE	C,UUO1(USER)	;RETURN ADDRESS SINCE ARMAK WILL DESTROY.
GLOB <
	HRRZ	B,@UUO1(USER)	;THIS IS ADDRESS OF THE MOVEM ....
	TLNE	FLAG,ARRTYP    	;THIS IS THE LPARRAY BIT
	JRST [
>;GLOB
	POP	P,B		;ITEM NUMBER.....
	MOVE	D,B		;ITEM NUMBER
	ADD	B,DATAB(TABL)	;NOW INDEX TO DATUM.
GLOB <
	JRST	.+1]
	TLNE	FLAG,GLBSRC	;SEE IF GLBMODEL
	JRST	[SKIPE (B)	;IS IT THERE ALREADY?
		 JRST FIXUP	;YES -- FIXUP STACK FOR EXIT.
		 SETOM USCOR2(USER);GET IT NOW
		 JRST	.+1]
>;GLOB
	PUSHJ	P,ARMAK		;MAKE AN ARRAY
				;RETURNS DESCRIPTOR IN A.
;; #OE ! AVOID DRYROT WHEN DELETING STRING ARRAY ITEM
	HRRZS	A
	MOVEM	A,(B)		;AND RECORD ANSWER SINCE AC B WAS SAVED.
	MOVEM	C,UUO1(USER)	;AND PUT THIS BACK.
GLOB <
	SETZM	USCOR2(USER)	;PUT IT BACK.
	TLNN	FLAG,ARRTYP	;THIS IS ON IF A LEAP ARRAY.
	JRST	LEAV	;GO AWAY -- IT WAS A SIMPLE GLOBAL ARRAY.
>;GLOB
	MOVE	PNT,D		;IT WAS AN ARRAY ITEM -- THIS IS THE ITEM
	MOVEI	FPD,LEAV	;IN LINE CALL.

;STUFF BELOW IS CALLED AS  SUBROUTINE.
;  ARYL RECORDS THE ARRAY IN A IN LIST OF STRING ARRAY ITEMS  ARYLS
;  IT ALSO SETS UP THE DATUM AND INFOTAB ENTRIES CORRECTLY.

;INPUT --- A     HAS THE ARRAY DESCRIPTOR
;	   PNT   HAS THE ITEM NUMBER (PASSED AS PARAM).
GLOB <
;	   FLAG  HAS THE GLBSRC BIT ON IF THIS IS A GLOBAL ARRAY.
>;GLOB

ARYL:
GLOB <
	TLNE	FLAG,GLBSRC
	 JRST	 NOGLH		;DO NOT PUT ON LISTS.
>;GLOB
	HLRZ	C,FLAG		;GET TYPE OF ARRAY
	CAIE	C,STTYPE+ARRTYP	;STRING ARRAY?
	JRST	NOGLH		;NO.
GLOB <
	SKIPN	FP,FP1(TABL)	;FOR ARRAY LISTS
	PUSHJ	P,FP1DON	;NONE YET, GET SOME.
	HRRZ	C,FP
	SKIPN	FP,(FP)
>;GLOB
NOGLOB <
	HRRZ	C,FP1(TABL)	;FOR ARRAY LISTS
	SKIPN	FP,(C)
>;NOGLOB
	 PUSHJ	 P,FP1DON
;; #RM# ! (CMU =B3=) LDE WAS PREVIOUSLY A MOVEM
	HRRM	FP,FP1(TABL)
	HRRZ	D,A		;STRING ARRAY POINTER
	HRL	D,ARYLS(USER)	;CURRENT LINKED LIST OF ARRAYS.
	MOVSM	D,(C)		;IN NEW BLOCK.
	HRRZM	C,ARYLS(USER)	;AND UPDATE LIST
NOGLH:
ARYPUT:	HRRZ	B,PNT		;ITEMNUMBER
	ADD	B,DATAB(TABL)	;POINTER TO DATUM
	MOVEM	A,(B)		;PUT DOWN DESCRIPTOR.
	JRST	(FPD)		;RETURN.


GLOB <
FIXUP:				;FIXUP THE ARMAK CALL....
	MOVM	B,(P)		;NUMBER OF PARAMS.
	LSH	B,1		;MULT. BY TWO.
	ADDI	B,1
	HRLI	B,(B)		;XWD PARAM+1,PARAM+1
	SUB	P,B		;O GOD.
	TLNN	FLAG,ARRTYP
	AOS	UUO1(USER)	;PAST THE MOVEM......
	JRST	LEAV
>;GLOB

NOEXPO <
INTERNAL IFGLOBAL
HERE (IFGLOBAL)
GLOB <
	PUSH	P,C		;SAVE B
	MOVE	C,-2(P)		;ITEM TO BE TESTED
	CAIL	C,TOPITM	;TOO HIGH?
	JRST    NTGLB
	CAMGE	C,MAXITM+GLUSER ;TOO LOW?
	JRST	NTGLB
	LDB	C,GINFTB	;ALLOC?
	SKIPN	C
;; #JI# BY JRL 10-2-72
NTGLB:	TDZA	A,A
;; #JI#
	MOVNI	A,1
	POP	P,C
>;GLOB
NOGLOB <
	MOVEI	A,0		;NO GLOBAL ITEMS
>;NOGLOB
	SUB	P,X22
	JRST	@2(P)

>;NOEXPO
DSCR SET AND ITEM STORING OPERATIONS.

IF THE TOP OF THE STACK IS AN ITEM, WE OCCASIONALLY CALL
"STORE" TO STORE IT INTO SOME CORE LOCATION.  THE COMPILER
SHOULD BE FIXED TO SIMPLY "POP" THE THING OFF INTO THE RIGHT
SPOT.

HOWEVER, IF THE TOP OF THE STACK IS A SET, WE REALLY DO NEED
TO DO SOME SCREWING AROUND.  HENCE, CALLING "STORE" IS MORE
OR LESS NEEDED.

ALL ENTRIES NEED: TAC1  HAS ADDRESS OF TARGET LOCATION.
	IF LH (TAC1) = -1, THEN THE TARGET IS A SET DESCRIPTOR.

THE VARIOUS ENTRIES ARE:

STORITM	-- MAIN STORE ROUTINE. STORE ITEM OR SET ON TOP OF
		STACK. SUBTRACT STACK WHEN DONE.
POPSET  -- STORE TOP OF STACK (MUST BE SET)  INTO AC 1.
	(NO LONGER COMPILED), MAY BE DELETED WHEN SAISG5 IS

STORBUTDONTREMOVE -- SAME AS STORITM, BUT STACK IS NOT 
		SUBTRACTED.

SETCOP  -- THE SET AT THE ADDRESS SPECIFIED BY TAC1 IS
		COPIED OVER INTO ITSELF.  THIS IS FOR SETS
		PASSED AS VALUE PARAMETERS TO PROCEDURES.  IF 
		THE ACTUAL IS A "TEMP SET", THEN NO ACTUAL
		COPY IS MADE.  THE INVERSE OF SETCOP IS:
SETRCL  -- RECLAIM THE SET POINTED TO BY TAC1.  THE STORAGE
		IS LINKED BACK ON THE FREE STORAGE LIST.

⊗;




SETCOP:	PUSH	P,(TAC1)	;THE SET TO BE COPIED.
	TLZ	TAC1,777
	JRST	SETGO		;ALWAYS RECOPY.


POPSET:	SETZM	RACS+1(USER)	;TO MAKE TARGET SET LOOK NULL.
	HRROI	TAC1,RACS+1(USER)
	JRST	STORITM

STORBUTDONTREMOVE:
	TLOA	TAC1,777	;THESE BITS WILL TELL US WHETHER
STORITM:			;TO ADJUST THE STACK ON EXIT.
	TLZ	TAC1,777
	JUMPL	TAC1,SETSTOR
	MOVE	B,(P)		;ITEM ARGUMENT.
	TLNE	FLAG,BOUND⊗ATTPOS
	PUSHJ	P,BSATIS	;FOR IMBEDDED STORES IN FOREACHES
	MOVEM	B,(TAC1)	;STORE IT.
	JRST	DECIDE		;ARRANGE STACK ACCORDINGLY.

BSATIS:	PUSH	P,FRTAB		;SAVE AC
	PUSH	P,C
	MOVE	FRTAB,FRLOC(USER) ;CURRENT FOR EACH TABLE
	SKIPE	C,RUNNER
	MOVE	FRTAB,CURSCB(C)
	POP	P,C
	XCT	MOVEB(FRTAB)	;GET SATISFIER
NOURLEAP	<
	TRZ	B,BNDFOR
>;NOURLEAP
	POP	P,FRTAB		;RESTORE AC
	POPJ	P,		;RETURN
SETSTOR:			;SET IS TO BE STORED.
GLOB <
	TRNE	TAC1,400000	;A SECOND SEGMENT SET??
	JRST	[MOVSI	FLAG,GLBSRC
		 MOVEI	TABL,GLUSER;FIX IT UP
		 JRST	.+3]
	TLNE	FLAG,GLBSRC
	WRITSEC			;ENTER CRITICAL SECTION.
>;GLOB
	SKIPE	A,(TAC1)	;IS OLD SET THERE?
	CAMN	A,(P)		;IF NULL SET, OR SAME AS ON STACK.
	 JRST	 SETGO		;DO NOT RECLAIM OLD ONE.
	MOVE	FP,FP1(TABL)
	HLRZ	B,(A)		;RECLAIM STORAGE
	HRRM	FP,(B)
	HRRM	A,FP1(TABL)	;VERY FAST !
SETGO:
GLOB <
	TLNE	FLAG,GLBSRC	;IF GLOBAL SEARCH, THEN
	JRST	[MOVE A,(P)	;GET SET....
		 JRST  COPYQ]	;AND COPY IT.
>;GLOB
	SKIPGE	A,(P)		;GET ARGUMENT.
	JRST	TEMPSET		;A TEMPORARY -- NO NEED TO COPY.
COPYQ:	JUMPE	A,NULLSET
	PUSH	P,[0]		;LET UNION DO THE WORK.
	PUSHJ	P,UNION		;MAGIC.
	MOVE	A,(P)		;RESULTS.
TEMPSET:
	HLRE	B,A		;GET COUNT FROM TEMP SET.
	MOVMS	B		;MAKE IT POSITIVE (I.E. PERMANENT SET)
	HRL	A,B		;ABSOLUTE COUNT.
	MOVEM	A,(TAC1)	;STORE IN DESCRIPTOR.
	MOVEM	A,(P)		;IN CASE OF STORBUTDONTREMOVE.
	SKIPA
NULLSET:
	SETZM	(TAC1)		;TARGET SET IS EASY !
DECIDE:	MOVE	A,RACS+1(USER)	;IN CASE OF POPTOP'S
	TLNN	TAC1,777	;LEAVE TOP OF STACK ON?
	 POP	 P,B		;NO --THROW OUT.
	JRST	LEAV		;YES

SETRCL:	SKIPGE	A,(TAC1)	;IF TEMP SET, CRASH
	ERR	<PROC EXIT WITH TEMP SET>,1
	JUMPE	A,LEAV		;NOT IF NULL SET.
	PUSHJ	P,RECQQ		;RECLAIM A SET IN A.
	JRST	LEAV		;AND RETURN.


DSCR DUPSET - COPY A SET OR LIST 

	-1(P) CONTAINS A SET DESCRIPTOR OF A SET TO BE COPIED
	TAC1 CONTAINS THE ADDRESS OF THE DESTINATION OF THE COPIED SET.
	IF THE SET IS  NULL WE SIMPLY ZERO THE DESTINATION. IF THE
	SET IS PERMANENT WE COPY IT INTO THE APPROPRIATE SEGMENT.
	IF TEMP SET (NEG. LENGTH) AND LOCAL DESTINATION WE CHANGE
	THE TEMP TO A PERM. SET. IF GLOBAL DEST. WE MUST COPY
	THE TEMP INTO THE UPPER SEGMENT, SINCE ALL TEMPS ARE IN TH
	LOWER SEGMENT. ALL AC'S EXCEPT USER MAY BE CHANGED. ⊗

DUPSET:		SKIPN	A,-1(P)		;NULL SET?
		JRST	[SETZM (TAC1)   ;YES
			 SUB P,X22
			 JRST @2(P)]
		JUMPL	A,TMPSTC	;TEMP SET?
MSTCOP:					;HAVE TO COPY SET
	GLOB <
		JSP	B,GQSET		;GLOBAL SET?
	>;GLOB

		PUSH	P,A		;SET TO BE COPIED
		PUSH	P,[0]		;NULL SET
		PUSHJ	P,CATLST
EXTCOP:		HLRE	A,(P)		;MAKE INTO PERM. SET
		MOVMS	A
		HRLM	A,(P)
		POP	P,(TAC1)
		SUB	P,X22
		JRST	@2(P)

TMPSTC:					;TEMP SET TO BE COPIED
	GLOB <
		TRNE	TAC1,400000	;GLOBAL DESTINATION?
		JRST	MSTCOP		;THEN MUST COPY.
	>;GLOB
		PUSH	P,-1(P)
		JRST	EXTCOP
DSCR PUTIN REMOV
 PUTIN   -- PUT TOP OF STACK IN SET POINTED TO BY TAC1.
	THIS MAKES A PERMANENT SET (I.E. COUNT IN SET
	DESCRIPTOR IS KEPT POSITIVE).

 REMOV   -- REMOVE THE ITEM MENTIONED IN TOP OF STACK FROM
	THE SET POINTED TO BY TAC1.

⊗;


;SET OPERATIONS.


;INITIALIZER FOR ALL SETS.

INSET:
	SETZB	LPSA		;FOR COUNTING PURPOSES.
				;ALSO RIGHT HALF OF REGISTER 
				;0 MUST BE 0.
GLOB <
	SKIPN	FP,FP1(TABL)	;ONE-WORD FREES IF ANY
	PUSHJ	P,FP1DON	;NONE YET, GET SOME.
	HRRZS	FP
>;GLOB
NOGLOB <
	HRRZ	FP,FP1(TABL)	;ONE-WORD FREES IF ANY
>;NOGLOB
	MOVEI	FPD,(FP)	;ANOTHER COPY
	HRROI	PNT,(FP)	;AND ANOTHER COPY.
	JRST	(B)		;RETURN

GLOB <
GQSET:	TRNE	TAC1,400000	;SECOND SEGMENT??
	 JRST	[TLO  FLAG,GLBSRC
		 MOVEI TABL,GLUSER
		 WRITSEC
		 JRST (B)]
	MOVEI	TABL,(USER)
	NOSEC			;IN CASE IT WAS ON
	TLZ	FLAG,GLBSRC
	JRST	(B)
>;GLOB

;PUT AND REMOVE  ----
;	ITEM IS IN -1(P)
;	=> SET IN TAC1

PUTIN:
	MOVE	A,-1(P)		;ITEM.		;REPLACES BELOW
ENTY:	
GLOB <
	JSP	B,GQSET	;GET SET FOR GLOBAL MODEL.
>;GLOB
GLOB <
	SKIPN	FP,FP1(TABL)
	PUSHJ	P,FP1DON	;NONE YET, GET SOME.
	HRRZS	FP
>;GLOB
NOGLOB <
	HRRZ	FP,FP1(TABL)
>;NOGLOB
	MOVEI	PNT,(FP)
	SKIPN	B,(TAC1)	;HEADER FOR SET.
	JRST	INS1		;BRAND NEW
LOPSET:	MOVE	C,B		;REMEMBER WHO POINTED AT US.
	HRRZ	B,(B)		;GO DOWN SET.
	JUMPE	B,INSRT		;GOT TO END AND NOT FOUND.
	HLRZ	D,(B)		;GET ITEM NUMBER
	CAIGE	D,(A)		;COMPARE TO ONE BEING INSERTED
	JRST	LOPSET		;NOT FAR ENOUGH
	CAIN	D,(A)
	JRST	RETQ		;ALREADY THERE.
INSRT:	SKIPN	FP,(FP)		;GET FREE STORAGE.
	PUSHJ	 P,FP1DON	;NONE LEFT.
	HRLM	A,(PNT)		;STORE THE NEW ITEM
	HRRM	PNT,(C)		;PUT IN POINTER.
	HRRM	B,(PNT)		;DOWN POINTER
	TRNE	B,-1		;WAS THIS THE LAST?
	JRST	COUTUP		;NO
	MOVE	B,(TAC1)	;GET SET AGAIN.
	HRLM	PNT,(B)		;PUT IN "LAST" POINTER.
COUTUP:	MOVSI	B,1
	ADDM	B,(TAC1)	;BUMP COUNTER
	JRST	RETQ

INS1:	MOVEI	PNT,(FP)	;POINTER TO FIRST FREE.
	SKIPN	FP,(FP)
	 PUSHJ	 P,FP1DON
	MOVEI	B,(FP)		;POINTER TO SECOND FREE.
	SKIPN	FP,(FP)
	 PUSHJ	 P,FP1DON
	HRLZM	A,(B)		;ITEM INSERTED
	HRLM	B,(PNT)
	MOVEM	PNT,(TAC1)
	JRST	COUTUP


;REMOVE

;SAME CALLING SITUATION AS PUT.

REMOV:
GLOB <
	JSP	B,GQSET
>;GLOB
	JSP	B,INSET
	SETZM	.SKIP.
	HRRZ	A,-1(P)		;THE ITEM
	MOVE	B,(TAC1)	;SET HEADER
LOPSS1:	MOVE	C,B
	HRRZ	B,(B)
	JUMPE	B,ERRS1		;IT WAS NOT THERE
	HLRZ	D,(B)		;ITEM NUMBER
	CAIE	D,(A)		;COMPARE
	JRST	LOPSS1		;GO FARTHER
ENREMX:	CAMN	C,(TAC1)	;THE FIRST ELEMENT?
	JRST	ZEROS		;YES
REG:	HRRZ	D,(B)		;DOWN POINTER.
	HRRM	D,(C)		;BYPASS THE CELL BEING DELETED.
	HRRZ	LPSA,(TAC1)	;POINTER TO SET HEADER.
	HLRZ	D,(LPSA)	;NOW THE POINTER TO LAST OF LIST.
	CAIN	D,(B)		;SAME AS ONE WE FOUND?
	HRLM	C,(LPSA)	;YES -- INSTALL NEW "LAST" ELEMENT.
	HRRM	FP,(B)		;LINK ON FREE STORAGE LIST
	HRLZI	C,-1
	ADDM	C,(TAC1)	;DECREMENT COUNTER.
GOREM:	MOVE	FP,B
RETQ:	HRRM	FP,FP1(TABL)	;
	JRST 	RET0		;ALL DONE.

ZEROS:	TLNE	C,-2		;THE VERY LASTELEMENT OF LIST.
	JRST	REG		;NO -- DO A REGULAR REMOVE.
;; #OA ENZERO ERRONEOUSLY LABELED THE HRRZ
ENZERO:	HRRM	FP,(B)		;LINK WHOLE THING ON FS LIST.
	HRRZ	B,(TAC1)	;THIS IS NOW THE FS LIST.
	SETZM	(TAC1)		;AND ZERO THE DESCRIPTOR
	JRST	GOREM

ERRS1:	SETOM   .SKIP.
	JRST	RETQ


DSCR  SIP ,LSTMAK
	SIP -- FOR MAKING UP SETS FROM LISTS OF ITEMS  SETC  A,B,C  SETO .
	CALL IS WITH TOP OF STACK HAVING ITEM IN IT,
	NEXT ELEMENT IN STACK IS THE SET WE ARE BUILDING.

⊗
; SIP -- FOR MAKING UP SETS OF ITEMS.

;CALL IS WITH ITEM IN -1(P)
;SET STAYS IN -2(P) ..

SIP:
	MOVE	B,-1(P)		;ITEM
	TLNE	FLAG,(BOUND!BINDING)⊗ATTPOS  ;THIS AND NEXT INSTRUCTION PROBABLY
	PUSHJ	P,BSATIS	;GET SATIS   ;    NO LONGER NECESSARY
	MOVEI	TAC1,-2(P)	;THE SET DESCRIPTOR.
	PUSH	P,B		;ITEM TO BE INSERTED
	HLRE	B,(TAC1)	;COUNT
	MOVMS	B
	HRLM	B,(TAC1)	;MAKE POSITIVE.
	PUSHJ	P,PUTIN		;SEE PUTIN
	HLRE	A,(TAC1)	;COUNT OF SET.
	MOVNS	A
	HRLM	A,(TAC1)	;AND MAKE A TEMP.
	SUB	P,X22		;RETRN ADDRESS AND ITEM, LEAVE SET ON STACK
	JRST	@2(P)		;RETURN

DSCR LSTMAK
	FOR MAKING UP LISTS OF ITEMS
	CALL IS WITH ITEM IN -1(P)
	LIST STAYS IN -2(P)
	⊗

LSTMAK:
	MOVE	B,-1(P)		;ITEM
	TLNE	FLAG,(BOUND!BINDING)⊗ATTPOS
	PUSHJ	P,BSATIS	;GET SATISFIER

;;#RF# THE OLD CODE DID NOT INSERT AT END OF LIST (DID A BAG INSERTION)
COMMENT ⊗ THIS WAS THE BAD OLD CODE ---
	MOVEI	TAC1,-2(P)	;ADDRESS OF SET
	PUSH	P,B		;SAVE
	PUSH	P,[0]		;WILL USE PUTA
	HLRE	B,(TAC1)	;COUNT
	MOVMS	B		;MAKE POSITIVE
	HRLM	B,(TAC1)	;STORE IN LIST DESCRIPTOR
	PUSHJ	P,PUTAFT	;INSERT ITEM INTO LIST AT TAIL
	HLRE	A,(TAC1)	;GET COUNT AGAIN
	MOVNS	A		;MAKE NEGATIVE
	HRLM	A,(TAC1)	;MAKE A TEMP
	SUB	P,X22
	JRST	@2(P)
⊗
GLOB <	
	SKIPN	FP,FP1(TABL)
	PUSHJ	P,FP1DON
	HRRZ	FP,FP
>;GLOB
NOGLOB <
	HRRZ	FP,FP1(TABL)
>;NOGLOB
	HRRZ	PNT,FP		;
	SKIPN	C,-2(P)		;LIST EMPTY
	JRST	FI		;YUP
	HRLZI	TAC1,-1		;FIX COUNT
	ADDM	TAC1,-2(P)	;
	HLRZ	TAC1,(C)	;TAC1 POINTS AT CURR LAST ELT
				;AT THIS POINT, TAC1 POINTS AT LAST ELT
				;C POINTS AT LAST,,FIRST WORD
				;PNT IS A FREE CELL
				;LIST LENGTH IS UPDATED
IB:	SKIPN	FP,(FP)		;INSERT B, AS SOON AS
	PUSHJ	P,FP1DON	;MAKE ROOM FOR POSTERITY
	HRLZM	B,(PNT)		;STICK ON END
	HRRM	PNT,(TAC1)	;OLD END POINTS HERE
	HRLM	PNT,(C)		;THIS IS THE END
	JRST	RETQ		; THIS DOES A HRRM FP,FP1(TABL)
				; 		SUB	P,X22
				;		JRST @2(P)
FI:	SKIPN	FP,(FP)		;NEED ANOTHER CELL
	PUSHJ	P,FP1DON
	HRRO	C,FP		;LEN,,[LAST,,FIRST]
	MOVEM	C,-2(P)
	MOVE	TAC1,C		;WILL CHAIN BOTH WAYS
	JRST 	IB

;;#RF#

DSCR STIN, LSTIN

 STIN -- BOOLEAN TO SEE IF ITEM (SECOND ELEMENT DOWN IN
	STACK) IS MEMBER OF SET (TOP OF STACK).

 LSTIN -- BOOLEAN TO SEE IF ITEM (-2(P)) IS MEMBER OF LIST (-1(P))
⊗;




; STIN  -- A BOOLEAN OF THE FORM  X  IN  SET

;CALL IS WITH X IN -2(P)
; 	SET IN -1(P)

STIN:
	MOVE	B,-2(P)		;ITEM
	TLNE	FLAG,BOUND⊗ATTPOS
	PUSHJ	P,BSATIS	;GET SATIS
	SKIPN	C,-1(P)		;IS THE SET EMPTY?
	JRST	NOPE		;SET EMPTY, THEREFORE ITEM CAN'T IN IT
	HRRZ	C,(C)		;POINT TO FIRST REAL NODE IN SET
SLOPT2:
	HLRZ	D,(C)
	CAIL	D,(B)		;FURTHER DOWN IN SET?
	JRST	[CAIE D,(B)	;ACTUALLY IN THE SET?
		 JRST NOPE	;NO.
		 JRST YUP]	;YES.
	HRRZ	C,(C)		;CDR DOWN THE SET
	JUMPN	C,SLOPT2	;IF CDR=NULL THEN FAILURE
NOPE:	
	TDZA	C,C
YUP:	SETO	C,		;RESULT IN C SINCE RECL1 USES A
	PUSHJ	P,RECL1		;RECLAIM IF NECESSARY.
RET3C:	HRREM	C,A		;SAVE IN REG 1 AS RESULT.
RET3:	SUB	P,X33
	JRST	@3(P)

; LSTIN -- A BOOLEAN X  IN  LIST


LSTIN:
	MOVE	B,-2(P)		;ITEM
	TLNE	FLAG,BOUND⊗ATTPOS
	PUSHJ	P,BSATIS	;GET SATISFIER
	SKIPN	C,-1(P)		;LIST EMPTY?
	JRST	NOPE		;LIST WAS EMPTY, THEREFORE FAIL
	HRRZ	C,(C)		;POINT TO FIRST REAL NODE IN LIST
LOPT2:
	HLRZ	D,(C)
	CAIN	D,(B)		;THIS THE ONE?
	JRST	YUP		;YESSIR
	HRRZ	C,(C)		;CDR DOWN THE LIST
	JUMPN	C,LOPT2
	JRST	NOPE

DSCR COUNT,UNIT,STLOP

 COUNT -- RETURNS IN AC1 THE LENGTH OF THE SET (OR LIST) ON TOP
	OF STACK.

 UNIT -- RETURNS ON TOP OF STACK THE FIRST ELEMENT OF THE
	SET (OR LIST) WHICH IS ON THE TOP OF STACK.

 STLOP   -- LOP OFF AN ELEMENT OF THE SET (OR LIST) POINTED TO BY
	TAC1, RETURN RESULTANT ITEM IN TOP OF STACK.

⊗;


; COUNT ....
	
; CALL IS WITH SET (OR LIST) IN -1(P)

COUNT:
	HLRE	C,-1(P)
	PUSHJ	P,RECL1		;RECLAIM -1(P) IF NECESSARY.
	MOVMM	C,A
RET0:
	SUB	P,X22
	JRST	@2(P)


; UNIT ...

; CALL IS WITH SET (OR LIST) IN -1(P)

UNIT:
	MOVE	A,-1(P)
	TLNN	A,-1
	ERR	<LOP OR COP OF NULL SET OR LIST UNDEFINED>,1
	HRRZ	A,(A)
	HLRZ	PNT,(A)		;THING TO RETURN
	PUSHJ	P,RECL1		;RECLAIM IF NECESSARY.
	EXCH	PNT,-1(P)
	POPJ	P,

; STLOP

; TAC1 PTS TO SET OR LIST, JRST TO STLOP

STLOP:
	PUSH	P,(TAC1)	;THE SET.
	PUSHJ	P,UNIT		;GO GET THE FIRST ELEMENT IN (P)
	PUSH	P,[1]		;REMOVE FIRST
	PUSHJ	P,REMX		;REMOVE IT
	JRST	LEAV		;RETURN AND LEAVE ITEM ON TOP OF STACK.
DSCR SETEST

 SETEST -- CODE FOR TESTING SET BOOLEANS, I.E. SET CONTAINMENT,
	EQUALITY, INEQUALITY, ETC.
⊗;
;SET RELATIONS......

;VARIOUS LOCAL BITS.
	TESNEQ←←40		;TEST NOT EQUAL
	TESEQL←←20		;TEST EQUAL
	TES12 ←←10		;TEST 1 CONTAINED IN 2
	TES21 ←← 4		;TEST 1 CONTAINS 2
	TESMAY←← 2		;IMPROPER SUBSETS.
	ANSWER←← 1		;THE ANSWER 0 FOR FALSE, 1 FOR TRUE
				;FALSE UNTIL PROVEN TRUE.


RELTAB:
	TES12
	TES21
	TESEQL
	TESNEQ
	TES12!TESMAY
	TES21!TESMAY


SETEST:
	MOVE	RELTAB-RELSTART+ROUTAB(FLAG)	;BITS!!!!
	TRNN	TES21
	JRST	.+4
	MOVE	B,-2(P)		;EXCHANGE THE OPERANDS.
	EXCH	B,-1(P)
	MOVEM	B,-2(P)

	HLRE	A,-2(P)		;EXAMINE COUNTS.
	HLRE	B,-1(P)
	MOVMS	A
	MOVMS	B
	TRNN	TESNEQ!TESEQL	;THESE GUYS WANT THE EQUAL TEST
	JRST	CONTES
	CAIE	A,(B)
	JRST	TESE

EQTST:	JUMPE	A,TESME		;IF NULL SETS, CLEARLY EQUAL
	MOVE	A,-2(P)
	MOVE	B,-1(P)
EQLOP:	HRRZ	A,(A)		;NEXT ELEMENT.
	JUMPE	A,TESME
	HRRZ	B,(B)
	HLRZ	D,(A)
	HLRZ	LPSA,(B)	;ITEMS
	CAIN	LPSA,(D)	;EQUAL?
	JRST	EQLOP
TESE:	TRNE	TESNEQ
SETYES:	TRC	ANSWER
SETNO:
SETANS:	SETOM	C
	TRNN	ANSWER
	SETZM	C
	PUSHJ	P,RECL2		;RECLAIM....
	JRST	RET3C

TESME:	TRNN TESNEQ
	   TRC  ANSWER
	JRST	SETANS
CONTES:	CAIE	A,(B)
	JRST	TESREL		;NOT SAME LENGTH.
	TRZN	TESMAY
	JRST	SETNO		;NOT POSSIBLY CONTAINED.
	JRST	EQTST

TESREL:	CAIL	A,(B)		;POSSIBLY CONTAINED :: COUNT(1) < COUNT(2)?
	JRST	SETNO
	JUMPE	A,SETYES	;NULL SET CONTAINED IN ANY SET.
	MOVE	A,-2(P)
	MOVE	B,-1(P)
COMLP:	HRRZ	A,(A)
COMLP1:	HRRZ	B,(B)
	JUMPE	A,SETYES	;ALL DONE AND NOT KICKED OUT.
	JUMPE	B,SETNO		;TRY TO GO PAST END ? -- NOT FEASIBLE.
	HLRZ	D,(A)
	HLRZ	LPSA,(B)
	CAIGE	D,(LPSA)	;CONTAINED?
	JRST	SETANS		;NO -- RETURN NO.
	CAIE	D,(LPSA)	;THE VERY SAME?
	JRST	COMLP1
	JRST	COMLP
DSCR UNION, INTERSECTION, SUBTRACTION

IN EACH CASE, ARGUMENTS ARE PASSED IN TOP TWO STACK
POSITIONS.  RESULT IS LEFT AS A TEMPORARY SET ON THE
TOP OF THE STACK.

⊗;


; UNION

; CALL IS WITH SETS IN -1 AND -2 (P)

UNION:
	JSP	B,INSET
	MOVE	A,-1(P)
	MOVE	B,-2(P)		;THE SETS
	HRRZ	A,(A)
	HRRZ	B,(B)		;AND PAST THE HEADERS.

LOPA1:	JUMPE	A,AEXH		;A IS EXHAUSTED
LOPA2:	JUMPE	B,BEXH
	HLRZ	C,(A)		;ITEM
	HLRZ	D,(B)		;THE OTHER ITEM
	MOVEI	PNT,(FP)	;THIS IS A FREE STOR. CELL.
	SKIPN	FP,(FP)
	 PUSHJ	 P,FP1DON
	CAILE	C,(D)		;WHICH ONE IS INSERTED?
	SOJA	LPSA,[HRLM D,(PNT)	;PUT IN ITEM
		   HRRZ B,(B)
		   JRST LOPA2]
	HRLM	C,(PNT)
	CAIN	C,(D)		;THE SAME ITEM?
	HRRZ	B,(B)
	HRRZ	A,(A)
	SOJA	LPSA,LOPA1	;LOOP


AEXH:	JUMPE	B,DONN		;IF BOTH EXHAUSTED, DONE
	HLRZ	D,(B)		;NEXT ITEM
	MOVEI	PNT,(FP)	;FREE STORAGE CELL.
	SKIPN	FP,(FP)
	 PUSHJ	 P,FP1DON
	HRLM	D,(PNT)
	HRRZ	B,(B)
	SOJA	LPSA,AEXH

BEXH:	JUMPE	A,DONN
	HLRZ	D,(A)
	MOVEI	PNT,(FP)
	SKIPN	FP,(FP)
	 PUSHJ	 P,FP1DON
	HRLM	D,(PNT)
	HRRZ	A,(A)
	SOJA	LPSA,BEXH



;INTERSECTION.....

; CALL IS WITH SETS IN -1 AND -2 (P)

INTER:
	JSP	B,INSET
	MOVE	A,-1(P)		;FIRST SET
	MOVE	B,-2(P)
LOPS0:	HRRZ	A,(A)
LOPS1:	HRRZ	B,(B)		;GO ON DOWN....
LOPS2:	JUMPE	A,DONN		;IF EITHER A OR B DONE,
LOPS3:	JUMPE	B,DONN		;THEN WE ARE REALLY DONE.
	HLRZ	C,(A)		;ITEM
	HLRZ	D,(B)		;OTER ITEM
	CAIN	C,(D)		;THE SAME?
	JRST	YES4		;YES
	CAIL	C,(D)		;IS THE A LIST LOWER?
	JRST	LOPS1		;NO
	HRRZ	A,(A)		;YES
	JRST	LOPS2

YES4:	MOVEI	PNT,(FP)
	SKIPN	FP,(FP)
	 PUSHJ	 P,FP1DON
	HRLM	C,(PNT)
	SOJA	LPSA,LOPS0	;GO PAST BOTH OF THEM.



; SUBRACTION .

; CALL IS WITH SUBTRAHEND IN -1(P), OTHER IN -2(P)

SUBTRA:
	JSP	B,INSET
	MOVE	A,-1(P)
	MOVE	B,-2(P)		;LARGER SET
LOPR1:	HRRZ	A,(A)		;PAST SET HEADER & DOWN THE LIST.
	JUMPE	A,[ADDI LPSA,1
		   JRST BCOP1]	;COPY THE REST OF B
	HLRZ	C,(A)		;THE ITEM
LOPR2:	HRRZ	B,(B)
	JUMPE	B,DONN
	HLRZ	D,(B)		;THE OTHER ITEM
LOPR3:	CAIN	C,(D)		;THE SAME?
	JRST	LOPR1		;YES -- WALK ON BY.
	CAIL	D,(C)		;IS B LIST LOWER?
	JRST	[HRRZ A,(A)
		 JUMPE A,BCOP	;ALL DONE
		 HLRZ C,(A)
		 JRST LOPR3]
	MOVEI	PNT,(FP)
	SKIPN	FP,(FP)
	 PUSHJ	 P,FP1DON
	HRLM	D,(PNT)
	SOJA	LPSA,LOPR2

BCOP:	JUMPE	B,DONN
	MOVEI	PNT,(FP)
	SKIPN	FP,(FP)
	 PUSHJ	 P,FP1DON
	HRLM	D,(PNT)		;THERE WAS A THING IN D TO BE
				;DISPOSED OF.
BCOP1:	HRRZ	B,(B)		;ON DOWN B.
	HLR	D,(B)		;ITEM NUMBER.
	SOJA	LPSA,BCOP


; LIST OR SET ELEMENT SELECTION. LIST OR SET
; DESCRIPTOR IN -1(P). SELECTOR INDEX ON TOP OF STACK
; ERROR DETECTED IF SELECTOR OUT OF RANGE
; ITEM RETURNED ON TOP OF STACK.
; ROUTINE IS JRST'ED TO.

SELFETCH:	SKIPG	A,(P)		;GET INDEX AMOUNT
		JRST	SELERR		;ERROR IF <=0
		MOVE	C,-1(P)		;SET ARGUMENT
		HLRE	B,C		;GET COUNT
		MOVM	B,B		;ABS. LENGTH OF SET
		CAMG	B,A		;TEST IF IN RANGE
		JRST	LSTELM		;LAST ELEM. OR ERROR
LPSEL:		MOVE	C,(C)		;NEXT NODE
		SOJG	A,LPSEL		;COUNT DOWN
COMSEL:		HLRZ	PNT,(C)		;ITEM TO BE RETURNED
		PUSHJ	P,RECL1		;RECLAIM SET IF NECESSARY
		MOVEM	PNT,-1(P)	;VAL. TO BE RETURNED
		POP	P,		;POP OFF ARG.
		JRST	LEAV		;RETURN
LSTELM:		CAME	B,A		;SKIP IF LAST ELEMENT
		JRST	SELERR		;RANGE ERROR
		HLRZ	C,(C)		;ADDR LAST WORD IN LIST
		JRST	COMSEL		;NORMAL RETURN
SELERR:		ERR	<LIST SELECTOR OUT OF RANGE>


;CATLST CONCATENATES THE TWO LISTS ON THE TOP OF STACK
;FIRST LIST IS IN -2(P). SECOND LIST IS IN -1(P)
;RETURN ADDRESS IS IN (P).


↑CATLST:	JSP	B,INSET		;INITIALIZE
		HLRE	LPSA,-1(P)	;GET LENGTH FIRST LIST
		MOVM	LPSA,LPSA	;COUNT
		HLRE	A,-2(P)		;LENGTH OF SECOND LIST
		MOVM	A,A		;COUNT
		ADD	LPSA,A		;LENGTH OF NEW LIST
		MOVN	LPSA,LPSA	;NEGATIVE LENGTH OF NEW LIST
		MOVEI	B,2		;CAT TWO LISTS
		MOVE	A,-2(P)		;FIRST LIST
PASTHD:		HRRZ	A,(A)		;BYPASS HEADER
		JUMPE	A,AEXCAT	;IF NULL LIST IGNORE
LPCAT:		HLRZ	C,(A)		;GET ITEM
		MOVEI	PNT,(FP)	;GET A FREE 
		SKIPN	FP,(FP)		;FOR NEXT FREE
		PUSHJ	P,FP1DON	;GET NEW FREES
		HRLM	C,(PNT)		;COPY ITEM
		HRRZ	A,(A)		;CDR OF LIST
		JUMPN	A,LPCAT		;LOOP IF NOT THROUGH
AEXCAT:		SOJE	B,DONN		;IF SECOND SET, END
		MOVE	A,-1(P)		;SECOND SET
		JRST    PASTHD		;CAT IT
DSCR PUTAFTER,PUTBEFORE⊗



PUTAFTER:	SKIPA	LPSA,[0];LPSA=0 IF AFTER
PUTBEFOR:	SETO	LPSA,	;LPSA=-1 IF BEFORE

	GLOB <
		JSP	B,GQSET	;GET LIST FOR GLOBAL MODEL
		SKIPN	FP,FP1(TABL)	;ANY FREES YET
		PUSHJ	P,FP1DON	; NO GET SOME
		HRRZS	FP	; A FREE
	>;GLOB
 NOGLOB <
	HRRZ	FP,FP1(TABL)	;A FREE NODE
	>;NOGLOB
	MOVE	A,-1(P)		;SEARCH ITEM
	POP	P,-1(P)		;MAKE IT LOOK LIKE CALL TO PUTIN
	MOVEI	PNT,(FP)	;POINTER TO FIRST FREE
	SKIPN	B,(TAC1)	;NULL LIST?
	JRST	NEWLST		;YES.
LOPLST:	MOVE	C,B		;REMEMBER WHO POINTED TO US
	HRRZ	B,(B)		;CURRENT NODE
	JUMPE	B,LSTEXH	;LIST EXHAUSTED?
	HLRZ	D,(B)		;GET ITEM
	CAIE	D,(A)		;ONE WE'RE LOOKING FOR?
	JRST	LOPLST		;NO.
; AT THIS POINT NODE POINTED TO BY B CONTAINS THE ITEM WE
; WERE LOOKING FOR. C POINTS TO PREVIOUS NODE IN LIST.
	MOVE	A,-1(P)
	JUMPN	LPSA,INSRT	;BEFORE THEN INSERT
	MOVE	C,B
	HRRZ	B,(B)		;FOR AFTER
	JRST	INSRT		;INSERT IT
NEWLST:	MOVE	A,-1(P)		;ITEM TO BE INSERTED
	JRST	INS1		;INSERT IN NEW LIST
LSTEXH:	MOVE	A,-1(P)		;GET ITEM
	JUMPE	LPSA,INSRT	;AT END OF LIST
	HRRZ	C,(TAC1)	;GET LIST HEADER
	HRRZ	B,(C)		;INSERT AT HEAD OF LIST
	JRST	INSRT		;INSERT IT
; LIST [EXPR1 FOR EXPR2]
; LIST IN -3(P)
; expr1 IN -2(P)
; expr2 IN -1(P)

FSBLST:
	SKIPGE	A,-1(P)		;GET FOR EXPR
 	ERR 	<INVALID "FOR" INDEX IN SUBLIST>,1
	ADD	A,-2(P)		;CHANGE TO TO
	SOJA	A,TSBLST+1	;NOW A TO EXPR.


; LIST [expr1 TO expr2]
; LIST IN -3(P)
; expr1 in -2(P)
; expr2 IN -1(P)

TSBLST:	MOVE	A,-1(P)		;GET TO EXPR VALUE
	JSP	B,INSET		;INITIALIZE NEW SET
	SKIPG	B,-2(P)		;EXPR1
	ERR	<INDEX FOR SUBLISTING  LEQ  0>,1
LENLST:	HLRE	C,-3(P)		;GET LENGTH OF LIST
	MOVM	C,C		;ABS VAL. LENGTH
	CAMLE	A,C		;TO > LENGTH?
	ERR	<INVALID SUBLIST OPERATION,LIST NOT LONG ENOUGH>,1
STKMOD:	POP	P,-2(P)		;MODIFY STACK
	SUB	P,[XWD 1,1]	;MOD STACK
	CAMLE	B,A		;NULL SUBLIST?
	JRST	NULSUB		;YES.
;PREPARE TO BYPASS HEADER
	SETZ	C,		;COUNTER FOR LIST POSITION
	MOVE	D,-1(P)		;GET LIST HEADER
HDLST:	HRRZ	D,(D)		;NEXT
	AOS	C		;INC PLACE COUNTER
	CAIGE	C,(B)		;THROUGH?
	JRST	HDLST		; NO.
; (D) POINTS TO FIRST NODE TO BE COPIED
; CALCULATE NUMBER TO BE COPIED
	SUB	A,B	
	AOS	A		;NUMBER OF NODES TO BE COPIED
	MOVN	LPSA,A		;NEGATIVE LENGTH FOR TEMP. SET
LPCPY:	HLRZ	B,(D)		;GET ITEM
	MOVEI	PNT,(FP)	;GET FREE
	SKIPN	FP,(FP)		;FOR NEXT TIME
	PUSHJ	P,FP1DON	;NEED SOME NEW FREES
	HRLM	B,(PNT)		;COPY ITEM
	HRRZ	D,(D)		;TO NEXT NODE
	SOJG	A,LPCPY		;IF NOT THROUGH LOOP
	HLLZS	(PNT)		;ZERO LAST PNTR.
	MOVEI	A,(PNT)		;ADDR LAST WORD IN LIST
	MOVEI	PNT,(FP)	;GET A FREE
	SKIPN	FP,(FP)		;FOR NEXT TIME
	PUSHJ	P,FP1DON	;IF OUT, GET SOME MORE
	HRRM	FPD,(PNT)	;ADDR. FIRST LIST NODE
	HRLM	A,(PNT)		;ADDR LAST LIST NODE
	HRRM	FP,FP1(TABL)	;FREE LIST UPDATE
	HRLM	LPSA,PNT	;STORE LIST LENGTH
RETLST:	PUSHJ	P,RECL1	;RECLAIM SET IF NECESSARY
	MOVEM	PNT,-1(P)	;LIST TO BE RETURNED
	POPJ	P,		;RETURN
NULSUB:	SETZ	PNT,		;RETURN NULL LIST
	JRST	RETLST

; THE EXIT CODE

DONN:	
	JUMPL	PNT,[SETZM PNT	;IF NOTHING DONE,
		 JRST RECLM2]	;RETURN NULL SET.
	HLLZS	(PNT)		;ZERO THE POINTER IN LAST CELL.
	MOVEI	A,(PNT)		;LAST WORD ALLOCATED.
	MOVEI	PNT,(FP)	;AND A NEW ONE -- FOR HEADER.
	SKIPN	FP,(FP)
	 PUSHJ	 P,FP1DON
	HRRM	FPD,(PNT)	; PTR TO  FIRST OF SET LIST.
	HRLM	A,(PNT)		;PUT IN THE "LAST" LINK
	HRLM	LPSA,PNT	;LPSA IS NEGATIVE, TO INDICATE TEMP.
	HRRM	FP,FP1(TABL)	;....
;	JRST	RECLM2		;NEXT PAGE.
DSCR SET RECLAMATION ROUTINES.

RECLM2 -- RECLAIMS TOP TWO STACK ELEMENTS, SUBTRACTS FROM
	STACK, THEN PUSH'ES "PNT" (A RESULT) ONTO STACK.

RECL2 -- RECLAIMS SETS IN -1(P) AND -2(P)  .. THOSE ARE
	THE STACK POSITIONS BEFORE THE CALL TO RECL2.

RECQQ -- RECLAIMS SET MENTIONED IN REGISTER "A".
	CLOBBERES ACS: FP AND B.

⊗;



RECLM2:	PUSHJ	P,RECL2

ALLD:	
	SUB	P,X33
	PUSH	P,PNT
	JRST	@2(P)		;RETURN.



RECL2:	SKIPGE	A,-3(P)		;...
	PUSHJ	P,RECQQ
RECL1:	SKIPL	A,-2(P)		;RECLAIM IF NECESSARY.
	POPJ	P,
↑↑RECQQ:	
GLOB <
	TRNE	A,400000	;IF SECOND SEGMENT, THEN
	JRST	SECRCL		;DO SPECIALLY
>;GLOB
;;#RU# ! MAY BE CALLED WITH THIS MUNGED
	MOVE	USER,GOGTAB

	MOVE	FP,FP1(USER)
	HLRZ	B,(A)
	HRRM	FP,(B)		;LINK AT THE END OF LIST.
	HRRM	A,FP1(USER)
	POPJ	P,

GLOB <
SECRCL:	PUSH    P,LKSTAT	;SAVE INTERLOCK STATUS
	PUSH	P,FLAG		;SAVE FLAG
	TLO	FLAG,GLBSRC
	WRITSEC		;GAIN ACCESS TO POINTERS.
	MOVE	FP,FP1+GLUSER
	HLRZ	B,(A)
	HRRM	FP,(B)
	HRRM	A,FP1+GLUSER
	POP	P,FLAG		;RESTORE FLAG
	POP	P,A
	CAMN	A,LKSTAT	;SAME STATUS AS WHEN ENTERED
	POPJ	P,		;YES
	JUMPN	A,[RDSEC
		   POPJ P,]
	NOSEC
	POPJ	P,
>;GLOB

; TRANSFER FUNCTION SET← LIST
; LIST IN (P) . RESULTANT SET WILL BE LEFT ON TOP OF STACK
; ROUTINE JRST`ED TO

SETLXT:
	SKIPN	A,(P)		;THE LIST
	JRST	LEAV		;RETURN IF NULL
	JSP	B,INSET		;INITIALIZE NEW SET
; GET A FREE FOR  LAST,FIRST NODE
	MOVEI	PNT,(FP)	
	SKIPN	FP,(FP)		; FOR NEXT TIME
	PUSHJ	P,FP1DON	; GET SOME MORE IF HAVE RUN OUT
;LEFT HALF WILL CONTAIN ADDR. LAST NODE IN SET.
	SETZM	(PNT)
;AN IMPORTANT THING TO REMEMBER IN THIS AND ALL OTHER SET-LIST BUILDING
;CODE IS THAT INSET SETS AC 0 TO 0.
LPOUTR:	HRRZ	A,(A)		;POINT TO NEXT NODE IN LIST
	JUMPE	A,LTHRU		;IF THROUGH THEN EXIT LOOP
	HLRZ	D,(A)		;GET ITEM
	MOVEI	C,(FPD)		;REMEMBER WHO POINTED TO US
	HRRZ	B,(C)		;ADDR FIRST CANDIDATE
LPINNR:	HLRZ	PNT,(B)		;GET ITEM FROM SET
	CAIG	D,(PNT)		;SHOULD WE CONTINUE DOWN CDR
	JRST	FNDITM		;NO
	JUMPE	B,FNDITM	;FOR FIRST TIME
	MOVEI	C,(B)		;YES
	HRRZ	B,(B)		;NEXT NODE
	JRST	LPINNR		;LOOP
;NOTICE ABOVE THAT NO EXPLICIT TEST WAS MADE TO DETERMINE IF WE
;HAD EXHAUSTED THE SET. THAT IS TAKEN CARE OF BY THE FACT AC 0 CONTAINS 0
FNDITM:	CAIN	D,(PNT)		;ALREADY THERE?
	JRST	LPOUTR		;YES
	MOVEI	PNT,(FP)      	;GET A FREE FOR THIS NEW NODE
	SKIPN	FP,(FP)		;FOR NEXT TIME
	PUSHJ	P,FP1DON	;IF OUT, GET SOME MORE
	HRRM	B,(PNT)		;LINK TO NEXT NODE
	HRLM	D,(PNT)		;ITEM
	HRRM	PNT,(C)		;LINK IN FORMER NODE
	SOS	LPSA		;COUNT OF NUMBER OF ITEMS IN SET
	JUMPN	B,LPOUTR	;IF NOT LAST NODE IN CHAIN CONTINUE
	HRLM	PNT,(FPD)	;RECORD NEW LAST NODE
	JRST	LPOUTR		;LOOP
LTHRU:	HRRM	FP,FP1(TABL)	;REPLACE FREE LIST POINTER
	PUSH	P,FPD		;RESULTANT SET TO BE RETURNED
	HRLM	LPSA,(P)	;STORE COUNT
	PUSHJ	P,RECL1		;RECLAIM LIST IF NECESSARY
	POP	P,-1(P)		;ADJUST STACK 
	JRST	LEAV		;RETURN
DSCR RPLAC
	<listvariable> [N]  ← <item>
	TAC1 POINTS TO LIST!VARIABLE
	N IS IN -1(P)
	ITEM IN -2(P)
	CALLED WITH PUSHJ P,

	ITEM REMAINS IN AC 1
	⊗

RPLAC:
	MOVE	A,-2(P)		;ITEM
GLOB<
	JSP	B,GQSET		;IN CASE GLOBAL SET
>;GLOB
	SKIPG	B,-1(P)		;N LEQ 0?
	ERR	<REPLACE - INDEX LEQ 0>
	POP	P,-1(P)		;MAKE STACK LOOK LIKE CALL
				;TO PUT IN WHEN WE GO TO INS1
GLOB<
	SKIPN	FP,FP1(TABL)	;ANY FREE`S YET
	PUSHJ	P,FP1DON	;NO GET SOME
	HRRZS	FP
>;GLOB
NOGLOB<
	HRRZ	FP,FP1(TABL)
>;NOGLOB
	HLRE	C,(TAC1)
	CAMG	B,C		;INDEX HIGH?
	JRST	RPLAC1		;NORMAL REPLACE
	ADDI	C,1		;LENGTH + 1
	CAME	B,C		
	ERR	<REPLACE - INDEX TOO HIGH>
NLAST:	CAIN	B,1		;NEW LIST?
	JRST	INS1		;YES
	MOVEI	PNT,(FP)
	HRRZ	C,(TAC1)
	HLRZ	C,(C)
	SETZ	B,		;END OF LIST?
	JRST	INSRT		;LET PUT HANDLE IT
RPLAC1:	HRRZ	D,(TAC1)
LPRPLAC: HRRZ	D,(D)		;DOWN LIST
	SOJG	B,LPRPLAC	;LOOP
	HRLM	A,(D)		;REPLACE ITEM
	JRST	RETQ		;RETURN
DSCR	TYPEX-to determine the type of an item
	
	CALLING SEQUENCE:
		PUSH	P,[ITEM#]
		PUSHJ	P,TYPEX

	RETURNS WITH THE STACK APPROPRIATELY DECREMENTED
	AND RIGHT HALF OF AC 1 CONTAINING TYPE CODE.
	LEFT HALF OF AC 1 CONTAINS ADDRESS OF DATUM ENTRY IF ANY.

	TYPE CODES ARE:
			0 - item not allocated or ANY
			1 - untyped
			2 - bracketed triple
			3 - string
			4 - real
			5 - integer
			6 - set
			7 - list
		       10 - procedure item
		       11 - process item
		       12 - event item
		       13 - context item
		       20 - string array
		       21 - real array
		       22 - integer array
		       23 - set array
		       24 - list array
		       30 - context array
		       31 - invalid  code
	⊗

HERE(TYPEX)			;CALLED WITH PUSHJ FROM USER
	PUSH	P,TABL		;SAVE AC
	PUSH	P,B	;SAVE AN AC
	SKIPN	A,-3(P)		;ITEM #
	JRST    NTALLOC		;ANY IS NOT CONSIDERED ALLOCATED
	MOVE	TABL,GOGTAB	;INITIALIZE TO LOCAL MODE
GLOB<
	CAIGE	A,GBRK		;GLOBAL ITEM?
	JRST	LCLTYP		;LOCAL
	MOVEI	TABL,GLUSER	;FOR GLOBAL
	CAMGE	A,ITMTOP(TABL)	;ALLOCATED?
	JRST	NTALLOC		;NO
	JRST	WASALLOC	;YES.
	>;GLOB

LCLTYP:	CAMLE	A,ITMTOP(TABL)	;ALLOCATED?
	JRST	NTALLOC		;NO.
	JUMPLE  A,NTALLOC	;INVALID ITEM #?
WASALLOC: MOVEI	B,(A)		;COPY ITEM #
	ADD	A,INFOTAB(TABL)	;ADDRESS INFOTAB ENTRY
	ADD	B,DATAB(TABL)	;ADDRESS DATAB ENTRY
	LDB	A,[POINT 6,(A),35]	;GET TYPE CODE
	CAILE	A,INVTYP		;VALID TYPE
NTVALID: MOVEI	A,INVTYP		;INVALID CODE
	HRL	A,B
	POP	P,B	;RESTORE AC
	POP	P,TABL		;RESTORE AC
	SUB	P,[XWD 2,2]
	JRST	@2(P)		;RETURN
NTALLOC: SETZ	A,		;NOT ALLOCATED TYPE CODE

	JRST  	NTVALID+1	;RETURN

DSCR TYPEIT -same as TYPEX except does not return datum address in left
	half ⊗

HERE(TYPEIT)			;ENTRY POINT 
	PUSH	P,-1(P)		;ITEM NUMBER
	PUSHJ	P,TYPEX		;GET TYPE
	HRRZS	A		;ZERO DATUM ADDRESS
	SUB	P,X22
	JRST	@2(P)		;RETURN
	MOVE   FLAG,USER;	DUMMY

DSCR	REMX -- REMOVE <list!variable> <index>
	list!variable pointed to by TAC1
	INDEX IN -1(P)
	CALLED WITH PUSHJ  P,
	⊗


REMX:
GLOB<
	JSP	B,GQSET		;FOR GLOBAL SETS
	>;GLOB
	JSP	B,INSET		;FREE LIST POINTERS ETC.
	SKIPG	A,-1(P)		;INDEX > 0
	ERR	<REMOVE - INDEX LEQ 0>
	HLRE	D,(TAC1)	;LENGTH OF LIST
	CAMLE	A,D		;INDEX > LENGTH?
	ERR	<REMOVE - INDEX GTR LENGTH>
	MOVE	B,(TAC1)
LPREMX:	MOVE	C,B		;REMEMBER PRECEDING NODE
	HRRZ	B,(B)		;DOWN-LIST
	SOJG	A,LPREMX	;COUNT-DOWN
	JRST	ENREMX		;REST OF CODE WITHIN REMOVE

DSCR	REMALL
	REMOVE ALL <item> FROM <list!variable>
	TAC1 POINTS TO LIST-VARIABLE
	ITEM IN -1(P)
	CALLED WITH PUSHJ P,
	⊗

REMALL:
GLOB<
	JSP	B,GQSET		;FOR GLOBAL SETS
	>;GLOB
	JSP	B,INSET		;INITIALIZE AC`S FOR LIST CREATION
	HRRZ	A,-1(P)		;ITEM
	MOVE	B,(TAC1)
LOPRA1:	MOVE	C,B		;ADDR PRECEDING NODE
	HRRZ	B,(B)		;NEXT IN LIST
	JUMPE	B,RETQ		;NO MORE
	HLRZ	D,(B)		;ITEM
	CAIE	D,(A)		;ONE TO BE REMOVED?
	JRST	LOPRA1		;NO.
	HRRZ	D,(B)		;NEXT LINK
	CAMN	C,(TAC1)	;FIRST ELEMENT?
	JRST	RAFIRST		;YES.
RACMN:	HRRM	D,(C)		;DELETE ITEM
	HRRM	FP,(B)		;ONTO FREE LIST
	MOVEI	FP,(B)		;NEW HEAD OF FREE LIST
	MOVSI	B,-1		;TO DECREMENT LENGTH COUNT
	ADDM	B,(TAC1)	;DEC COUNT
	MOVE	B,C		;WILL CONTINUE DOWN LIST
	JUMPN	D,LOPRA1	;GO.
	MOVE	D,(TAC1)	;END OF LIST
	HRLM	C,(D)		;NEW END OF LIST
	JRST	RETQ		;RETURN
RAFIRST: JUMPN	D,RACMN		;IF LIST NOT NOW NULL BRANCH
	JRST	ENZERO		;NULL LIST. LET REMOVE HANDLE IT


DSCR LISTX
	RETURNS THE INDEX OF THE N TH OCCURRENCE OF ITEM WITHIN
	THE LIST OR 0 IF THERE ARE NOT AT LEAST N OCCURRENCES OF
	THE ITEM WITHIN THE LIST.
		LIST IN -3(P)
		ITEM IN -2(P)
		N    IN -1(P)
	CALLED WITH PUSHJ DIRECTLY FROM USER.
	⊗

HERE(LISTX)
	MOVE	D,-1(P)		;N
	MOVE	B,-2(P)		;ITEM
	MOVE	C,-3(P)		;LIST
	SETZB	0,A		;ZERO AC 0 AND A
LPLSTX:	HRRZ	C,(C)		;GO DOWN LIST
	JUMPE	C,ZRETRN	;NOT N DIFFERENT OCCURENCES?
	ADDI	A,1		;KEEP TRACK OF INDEX
	HLRZ	LPSA,(C)	;ITEM
	CAIE	B,(LPSA)	;ONE WE`RE LOOKING FOR?
	JRST	LPLSTX		;NO
	SOJG	D,LPLSTX	;N TH OCCURRENCE?
	SKIPA
ZRETRN:	SETZ	A,		;CLEAR INDEX
	EXCH	A,-3(P)		;SWAP RESULT AND LIST.
	MOVEM	A,-1(P)		;PREPARE FOR RECL1
	PUSHJ	P,RECL1		;RECLAIM LIST IF NECESSARY
	SUB	P,X33		;DEC. STACK
	POP	P,A		;RESULT
	JRST	@4(P)

DSCR PUTXA,PUTXB

	PUT ITEM IN LIST AFTER(BEFORE) INDEX;
	ITEM IN -2(P)
	ITEM IN -1(P)
	INDEX IN -1(P)
	CALLED WITH PUSHJ P,
	⊗

PUTXA:	MOVE	D,-1(P)		;INDEX
	AOSA	D		;WILL USE PUTXB ROUTINE
PUTXB:	MOVE	D,-1(P)		;INDEX
	MOVE	A,-2(P)		;ITEM
	JSP	B,INSET		;INITIALIZE FREE STORAGE PNTRS
	POP	P,-1(P)		;MAKE IT LOOK LIKE CALL TO PUT
	JUMPLE	D,ERRPUT	;INDEX LEQ 0 ?
	HLRE	C,(TAC1)	;LENGTH OF LIST
	CAMLE	D,C		;INDEX LEQ LENGTH
	JRST	PTLAST		;NO
	HRRZ	B,(TAC1)	;NEW LAST OR ERROR
LPPUTX:	MOVE	C,B	
	HRRZ	B,(B)		;DOWN THE LIST
	SOJG	D,LPPUTX	;LOOP 
	JRST	INSRT		;

PTLAST:	ADDI	C,1		;NEW LAST ELEMENT?
	CAME	D,C
ERRPUT:	ERR	<PUT- BAD INDEX>
	MOVE	B,D		;PREPARE TO JUMP
	JRST	NLAST		;USE PUTAFTER ROUTINE



DSCR INITTP - INITIALIZE ITEM TYPE.
	ITEM IS IN -2(P)
	TYPE IS IN -1(P)
	CALLED WITH PUSHJ P,
	⊗

INITTP:
	MOVE	A,-2(P)
	ADD	A,INFOTAB(TABL)	;INFOTAB ENTRY ADDRESS
	MOVE	B,-1(P)		;TYPE
	HRRM	B,(A)		;STORE CODE
	MOVE    A,-2(P)		; WILL RETURN ORIGINAL ITEM
	SUB	P,X33		;DEC STACK
	JRST	@3(P)		;RETURN
DSCR INTNAM,CVSI,CVIS,DEL.PNAME,NEW.PNAME ⊗

; PRINT NAME HANDLING FOR THE WORLD.
; FIRST THE ROUTINE TO HASH THINGS UP, THEN
; THE RETRIEVAL ROUTINES.

INTNAM:			;INITIALIZE DECLARED ITEM PNAMES
;;#  # DCS 5-3-72 LEQ 0 THEN  NO PNAMES
	SKIPG  (A)		;ANY TO BE INITED?
;;#  # DCS
	POPJ	P,		;NO.
	PUSH	P,(A)		;NUMBER OF ITEMS IN LIST
	ADDI	A,1
	PUSH	P,A		;SAVE ADDRESS OF CURRENT ITEM.
INT1:	MOVE	A,@(P)		;XWD ITEM NUMBER,, ADDR. STRING DESCRIPTOR
	PUSH	SP,(A)
	PUSH	SP,1(A)		;STRING IS THERE.
	HLRZS	A
	PUSH	P,A
	PUSHJ	P,ENTR		;PUT IT IN.....(NEW.PNAME)
	AOS	(P)		;INDEX THE ADDRESS.
	SOSE	-1(P)		;ITEM COUNT.
	 JRST	 INT1
	SUB	P,X22
INT4:	POPJ	P,		;RETURN


INITNM:				;INITIALIZE HASH TABLE
	LPCOR	(PHASLN)	;ITEM AND STRING HASH TABLE
	HRRM	B,HASHP(USER)
	POPJ	P,		;RETURN

; LEFT HALF OF HASH TABLE IS FOR ITEMS
; RIGHT HALF OF HASH TABLE IS FOR STRINGS
IFE ALWAYS, <
EXTERNAL OUTSTR
>

HERE(NEW.PNAME)			;
ENTR:				;ENTRY POINT FOR INTNAME
	MOVE	USER,GOGTAB
	SKIPN	HASMSK(USER)	;LEAP INITED?
	PUSHJ	P,LPINI 	;NO, GO INITIALIZE LEAP
	MOVE	A,HASHP(USER)	;SEE IF PRINTNAMES INITIALIZED
	TRNN	A,-1		;HASH TABLE ALLOCATED
	PUSHJ	P,INITNM	;NO, GO DO IT.
;IF ITEM NOT ALLOCATED NO GOOD
NOGLOB <
	SKIPE	C,-1(P)		;THE ITEM
	LDB	C,INFTB		;GET THE TYPE
>;NOGLOB
GLOB <
	SKIPN   C,-1(P)
	JRST	PHAVT		;HAV ITEM TYPE
	CAIGE   C,GBRK		;A GLOBAL?
	JRST	[LDB	C,INFTB
		 JRST .+2]
	LDB	C,GINFTB
PHAVT:
>;GLOB
	SKIPN	C
	ERR	<ATTEMPT TO GIVE UNALLOCATED ITEM A PNAME>,1
;SEE IF ITEM ALREADY HAS PNAME
	PUSH	P,[0]		;WILL SERVE AS FLAG PARAM TO CVIS
	PUSH	P,-2(P)		;ITEM
	MOVEI	TAC1,-1(P)	;ADDR. FLAG
	PUSH	P,TAC1		;FLAG PARM.
	PUSHJ	P,CVIS		;ALREADY HAVE NAME
	SUB	SP,X22		;REMOVE STRING RETURNED BY CVIS
	SKIPN	(P)		;FLAG TRUE?
	JRST	[ADD SP,X22	;RESTORE STRING RETURNED BY CVIS
		 PUSH SP,-3(SP)	;OUR STRING
	         PUSH SP,-3(SP)
		PUSH	SP,-3(SP)	;STRING RETURNED BY CVIS
	 	PUSH	SP,-3(SP)
		 PUSHJ P,EQU	;STRINGS EQUAL?
		 MOVE USER,GOGTAB;SINCE EQU DESTROYS
		 JUMPN  A,RTRNEW  ;IF EQUAL THEN WE MUST RETURN
		 PRINT <
WARNING ITEM >
		 PUSHJ P,OUTSTR	;PRINT IT
		 PRINT < RENAMED TO >
		 PUSH SP,-1(SP)
		 PUSH SP,-1(SP)
		 PUSHJ P,OUTSTR
		 TERPRI
		 PUSH P,-2(P)	;ITEM NUMBER(FLAG STILL ON STACK)
		 PUSHJ P,DEL.PNAME  ;REMOVE OLD PNAME
		
		 JRST .+1]
;NOW SEE IF STRING ALREADY EXISTS.
	PUSH	SP,-1(SP)	;COPY STRING
	PUSH	SP,-1(SP)	
	MOVEI	TAC1,(P)	;ADDRESS OF "FLAG"
	PUSH	P,TAC1		;PARAM TO CVSI
	PUSHJ	P,CVSI
	MOVE	USER,GOGTAB		;CVSI WILL DESTROY
	SUB	P,X11		;REMOVE "FLAG"
	SKIPN	1(P)		;SKIP IF NOT ALREADY THERE
	JRST	[CAMN	A,-1(P)	;SAME ITEM?
		 JRST  [ SUB P,X22
			    SUB SP,X22
			    JRST @2(P)]		 
		 PRINT <ERROR - >
	         PUSHJ P,OUTSTR	;TYPE PRINTNAME
		 ERR < USED AS PNAME FOR TWO DIFFERENT ITEMS>,1
		 PUSH	P,A
		 PUSHJ	P,DEL.PNAME
		 JRST	.+1
		]
	PUSHJ	P,SDESCR	;GET A FREE STRING DESCRIPTOR
	POP	P,C		;ADDR. DESCRIPTOR
	POP	SP,(C)		;STRING
	POP	SP,-1(C)	
	SKIPN	FP,FP2(USER)		;FOR A TWO-WORD FREE
	PUSHJ	P,FP2DON		;IF NONE YET GO GET SOME
	MOVEI	D,(FP)		;OUR NEW FREE 
	SKIPN	FP,(FP)		;FOR NEXT TIME
	PUSHJ	P,FP2DON	;GET SOME MORE IF NEEDED
	MOVEM	FP,FP2(USER)	;CDR FREE LIST
	HRLM	C,1(D)		;STRING 
	MOVE	A,-1(P)		;ITEM
	HRLM	A,(D)		;STORE IT
	ANDI	A,PHASLN-1	;ITEM HASH
	ADD	A,HASHP(USER)	;TABLE LOC.
	HLR	C,(A)		;OLD CLASH LIST
	HRRM	C,(D)		;ADD NEW ELEM.
	HRLM	D,(A)		;UPDATE CLASH LIST
;STRING HASH
	HRRZ	C,1(SP)		;STRING LENGTH
	SKIPN	C		;TEST IF NULL STRING
	JRST	[ERR <ERROR - NULL PNAME>,1
		 SUB P,X22
		 JRST @2(P)]
	MOVE	B,2(SP)		;BYTE POINTER
	ILDB	A,B		;FIRST CHARACTER
	ILDB	B,B		;SECOND CHARACTER IF ANY
	LSH	A,3		;HIGH ORDER BIT CARRIES NO INFO
	CAIE	C,1		;LENGTH= 1?
	XORI	A,(B)
	ANDI	A,PHASLN-1	;TABLE INDEX
; THIS HASH REALLY COULD STAND SOME IMPROVEMENT.
	ADD	A,HASHP(USER)
	HRR	C,(A)
	HRRM	C,1(D)
	HRRM	D,(A)
	SUB	P,X22
	JRST	@2(P)

RTRNEW:	SUB	SP,[XWD 4,4]
	SUB	P,X33
	JRST	@2(P)



HERE(DEL.PNAME)				;DELETE PNAME IF ANY
	MOVE	USER,GOGTAB
	SKIPN	HASMSK(USER)		;LEAP INITIALIZED?
	PUSHJ	P,LPINI			;GO DO IT
	HRRZ	A,HASHP(USER)		;PNAMES YET?
	JUMPE	A,EXDELP		;NO. SIMPLY EXIT
	MOVE	A,-1(P)			;ITEM NUMBER
	ANDI	A,PHASLN-1		;HASH HA HA
	ADD 	A,HASHP(USER)		;HASH POSITION
	HRROS	(P)			;FLAG INDICATES FIRST IN CONFLICT LIST
	MOVEI	D,(A)			;ADDRESS THIS BUCKET
	HLRZ	A,(A)
LPDELP:	SKIPN	A			;END OF LIST?
	JRST	[SUB	P,X22
		 HRRZ A,2(P)
		 JRST	(A)]		;RETURN, NO SUCH  PNAME
	HLRZ	B,(A)			;ITEM NUMBER
	CAMN	B,-1(P)			;ONE WE'RE LOOKING FOR?
	JRST	DELFND			;YES
	MOVEI	D,(A)		
	HRRZS	(P)
	HRRZ	A,(A)			;CDR CONFLICT LIST
	JRST	LPDELP
DELFND:	MOVE	C,(A)			;NEXT LINK IN CONFLICT LIST
	SKIPG	(P)			;NOT FIRST IN CONFLICT LIST?
	JRST	[HRRZS (P)
		 HRLM	C,(D)
		 JRST .+2]
	HRRM	C,(D)	;DELETE NODE FROM LIST
	HLRZ	C,1(A)			;ADDRESS STRING DESC.
	PUSH	SP,-1(C)		;SAVE STRING SO CAN DELETE FROM
					;STRING HASH TABLE
	PUSH	SP,(C)
	SETZM	-1(C)			;SO GARB. COLLECT. WILL IGNORE
	HLRZ	D,HASHP(USER)		;FREE LIST
	HRRM	D,(C)			;LINK IT ON
	HRLM	C,HASHP(USER)		;SAVE UPDATED FREE LIST
	ILDB	B,(SP)			;FIRST CHAR.
	ILDB	C,(SP)			;SECOND CHAR
	HRRZ	D,-1(SP)		;STRING LENGTH
	LSH	B,3
	CAIE	D,1
	XORI	B,(C)
	ANDI	B,PHASLN-1		;TABLE INDEX
	ADD	B,HASHP(USER)		;STRING HASH TABLE POSITION
	MOVEI	D,(B)
	HRRZ	B,(B)			;FIRST IN CONFLICT LIST
LPSTRD:	SKIPN	B
	ERR	<DRYROT- PNAMES DELETE>
	CAIN	B,(A)			;ONE WE'RE LOOKING FOR
	JRST	FNDSBK			;FOUND STRING BUCKET
	MOVEI	D,1(B)
	HRRZ	B,1(B)			;CDR CONFLICT LIST
	JRST	LPSTRD
FNDSBK:	HRRZ	B,1(B)			;CDR OF CONFLICT LIST
	HRRM	B,(D)			;PUT IT DOWN
	MOVE	FP,FP2(USER)
	HRRM	FP,(A)
	MOVE	A,FP2(USER)
	SUB	SP,X22
EXDELP:	SUB	P,X22
	JRST	@2(P)		;RETURN



HERE(CVSI)				;STRING TO ITEM
	MOVE	USER,GOGTAB
	SKIPN	HASMSK(USER)		;LEAP INITED?
	PUSHJ	P,LPINI			;GO DO IT
	HRRZ	A,HASHP(USER)		;PNAMES INITED?
	JUMPE	A,CVSNO			;CAN'T SUCCEED
	MOVE	B,(SP)			;BYTE POINTER
	ILDB	A,B
	ILDB	B,B
	HRRZ	C,-1(SP)		;STRING LENGTH
	LSH	A,3
	CAIE	C,1
	XORI	A,(B)
	ANDI	A,PHASLN-1		;OUR HASH
	ADD	A,HASHP(USER)
	HRRZ	B,(A)			;FIRST IN CONFLICT LIST
LPCVSI:	SKIPN	B			;END OF LIST?
	JRST	CVSNO			;STRING NOT FOUND
	HLRO	C,1(B)			;STRING ADDRESS
	PUSH	SP,-1(SP)
	PUSH	SP,-1(SP)
	PUSH	SP,-1(C)
	PUSH	SP,(C)
	PUSH	P,B			;IN CASE EQU DESTROYS
	PUSHJ	P,EQU			;STRINGS EQUAL?
	MOVE	USER,GOGTAB
	POP	P,B
	JUMPN	A,CVSYES		;FOUND RIGHT STRING
	HRRZ	B,1(B)			;NO. TRY AGAIN
	JRST	LPCVSI
CVSYES:	SETZM	@-1(P)			;FLAG←FALSE
	HLRZ	A,(B)			;ITEM NUMBER
	JRST	CVSIRT
CVSNO:	SETOM	@-1(P)
	MOVEI	A,-1			;JUST TO BE REPEATABLE
CVSIRT:	SUB	SP,X22
	SUB	P,X22
	JRST	@2(P)


HERE(CVIS)				;ITEM TO STRING
	MOVE	USER,GOGTAB
	SKIPN	HASMSK(USER)		;LEAP INITED?
	PUSHJ	P,LPINI			;NO GO DO IT
	HRRZ	A,HASHP(USER)		;ANY PNAMES?
	JUMPE	A,CVINO			;IF NONE, CAN'T SUCCEED
	MOVE	A,-2(P)			;ITEM NUMBER
	ANDI	A,PHASLN-1
	ADD	A,HASHP(USER)
	HLRZ	B,(A)
LPCVIS:	SKIPN	B
	JRST	CVINO			;NO SUCH PNAME
	HLRZ	A,(B)			;ITEM NUMBER
	CAMN	A,-2(P)			;SAME AS OURS?
	JRST	CVIYES			;SUCCESS
	HRRZ	B,(B)			;CDR OF CONFLICT LIST
	JRST	LPCVIS			;TRY AGAIN
CVIYES:	HLRZ	C,1(B)			;STRING ADDR
	PUSH	SP,-1(C)		;RETURN ON STRING STACK
	PUSH	SP,(C)
	SETZM	@-1(P)			;FLAG←FALSE
	JRST	CVIRET
CVINO:  ADD	SP,X22			;RETURN GARBAGE STRING
;;#HP#! 6-8-72 DCS GARBAGE STRING MUST BE GARBAGE COLLECTABLE!
	SETZM	-1(SP)			;CONSTANT, NULL STRING -- HARMLESS
	SETOM	@-1(P)			;FLAG←TRUE
CVIRET:	SUB	P,X33
	JRST	@3(P)
DSCR MATCHING PROCEDURE ROUTINES, CALMP,RESMP,SUCFA1;
	⊗
;CALMP ON STACK IS PLACE FOR ITEM,PROCEDURE CALL WITH PDA AT VERY
;TOP OF STACK. ROUTINE IS JRSTED TO
SOPTS ←← 11	;SPROUT OPTIONS,SUSPEND HIM LET ME CONTINUE
ROPTS ←← 0	;RESUME OPTIONS
CALMP:					;SPROUT MATCHING PROCEDURE
GLOB <
	NOSEC				;NOT "ENTERED" INSIDE FOREACH'S
>;GLOB
	PUSHJ	P,FRPOP			;POP SATIS INTO CORE, ALSO LOADS FRTAB
	MOVE	FPD,FPDP(FRTAB)		;FOREACH PUSH DOWN LIST
	ADD	FPD,[XWD LENFPD,LENFPD] ;MAKE AN ENTRY ON PDL
	SKIPL	FPD
	 JSP 	USER,$PDLOV
	MOVEM	FPD,FPDP(FRTAB)		;REPLACE PDL POINTER
	HRRI	FLAG,CALINDX-SEROUT	;SEROUT # FOR RESUME MP
	MOVEM	FLAG,-1(FPD)		;PUT DOWN ROUTINE NAME
	MOVE	D,UUO1(USER)		;PICKUP RETURN ADDRRESS
	MOVEM	D,(FPD)			;PUT IT DOWN
	SETOM	-TT1(FPD)		;BE CONSISTENT WITH OTHERS
	SETZM	-T2(FPD)
	PUSHJ	P,NEW			;GET AN ITEM FOR PROCESS
	POP	P,D			;THE ITEM
	MOVEM	D,-ATTP(FPD)		;SAVE IN FPD ENTRY
	MOVE	C,(P)			;PICK-UP PDA
	HLRZ	LPSA,PD.NPW(C)		;NUMBER OF STRING ENTRIES
	HRRZ	B,PD.NPW(C)		;NON STRING ENTRIES
	ADD	LPSA,B			;DISPLACEMENT
	MOVNS	LPSA
	ADDI	LPSA,(P)		;ADDR OF ITEM SLOT
	MOVEM	D,(LPSA)		;PUT ITEM DOWN
	PUSH	P,[SOPTS]		;THE OPTIONS FOR SPROUT
	HRRZI	LPSA,-MASK(FPD)		;THE"KILL-SET"
	SETZM	-MASK(FPD)		;MAKE NIL
	PUSH	P,LPSA
	PUSHJ	P,SPROUT		;SPROUT IT
	MOVE	USER,GOGTAB
	MOVE	FRTAB,FRLOC(USER)
	SKIPE	A,RUNNER
	MOVE	FRTAB,CURSCB(A)
	MOVE	FPD,FPDP(FRTAB)
	JRST	GO			;RESUME IT

RESMP:					;RESUME THE MATCHING PROCEDURE
	MOVEM	FPD,FPDP(FRTAB)		;SAVE PDP
	PUSH	P,-ATTP(FPD)		;PROCESS!ITEM
	PUSH	P,[0]			;NULL PARAM
	PUSH	P,[ROPTS]		;RESUME OPTIONS
	PUSHJ	P,RESUME		;RESUME IT
	MOVE	USER,GOGTAB
	MOVE	FRTAB,FRLOC(USER)
	SKIPE	D,RUNNER
	MOVE	FRTAB,CURSCB(D)
	MOVE	FPD,FPDP(FRTAB)
	JUMPE	1,MPFAIL		;WAS IT SUCCESS
	PUSHJ	P,CORPOP		;GET CORE INTO SATIS TABLE
	AOS	(P)			;SUCCESS, SKIP RETURN
	POPJ	P,			;YES
MPFAIL:	PUSH	P,-ATTP(FPD)		;THE ITEM
	MOVEI	D,MPDEL			;PREPARE FOR CALL TO DELETE
	MOVEM	D,UUO1(USER)
GLOB <
	MOVEI	TABL,(USER)
>;GLOB
	JRST	DELETE
MPDEL:
GLOB<
	NOSEC
>;GLOB
	MOVE	USER,GOGTAB
	MOVE	FRTAB,FRLOC(USER)	;SINCE DELETE DESTROYED
	SKIPE	A,RUNNER
	MOVE	FRTAB,CURSCB(A)
	MOVE	FPD,FPDP(FRTAB)
	POPJ	P,			;REPORT FAILURE

DSCR .SUCCE,.FAIL  
SUCCEED OR FAIL
	WE DO A SKIP RETURN IF A PROCESS,OTHERWISE WE SIMPLY
	RETURN, WHICH WILL JUMP TO END OF MATCHING PROCEDURE AND
	GIVE A NORMAL RETURN
	PDA OF MATCHING PROCEDURE ON TOP OF STACK
⊗
INTERNAL .FAIL,.SUCCE
SFOPTS ←← 0			;SUCCEED FAIL OPTIONS
HERE(.FAIL)
	TDZA	A,A
HERE(.SUCCE)
	SETOM	A
	POP	P,TEMP			;THE RETURN ADDRESS
	EXCH	TEMP,(P)		;THE PDA
	MOVE	D,RF			;CURRENT DISPLAY
LPSFA:	HLRZ	C,1(D)			;PDA THIS DISPLAY LEVEL
	MOVE	D,(D)			;BACK ONE LEVEL
	CAIE	C,(TEMP)		;THIS THE ONE?
	JRST	LPSFA			;NO.
	HLRZ	C,1(D)			;PDA OF "FATHER"
	CAIE	C,SPRPDA		;SPROUTER?
	POPJ	P,			;NO.
;PUSH ITEM NUMBER OF "SPROUTER"
	MOVE	D,RUNNER		;BASE OF PROCESS STACK
	PUSH	P,DADDY(D)		;WHO SPROUTED ME
	PUSH	P,1			;VAL TO BE RETURNED
	PUSH	P,[SFOPTS]		;OPTIONS
	PUSHJ	P,RESUME		;RESUME
	AOS	(P)
	POPJ	P,			;SKIP RETURN

NOGLOB <
BEND	LEAP
>;NOGLOB

IFE ALWAYS,<
		END
>