perm filename LEPRUN[S,AIL]2 blob sn#010863 filedate 1972-11-10 generic text, type T, neo UTF8
COMMENT ⊗   VALID 00040 PAGES VERSION 16-2(29)
RECORD PAGE   DESCRIPTION
 00001 00001
 00009 00002	HISTORY
 00013 00003	Leaping runtime routines.  Sept. 1972.
 00019 00004	DSCR FOREACH INTERPRETATION EXAMPLE
 00026 00005	DSCR LEAP ALLOCATION -- START OF PROGRAM.
 00031 00006		INTERNAL LPINI
 00039 00007	DSCR INTERLOCKS FOR LEAP GLOBAL MODEL
 00045 00008	DSCR MAIN DISPATCHER FOR LEAP
 00048 00009	DISPATCH TABLE FOR THE LEAP INTERPRETER.
 00054 00010	DSCR  ASSOCIATIVE SEARCH ROUTINES
 00061 00011	 XO≡V
 00068 00012	 X ε S
 00070 00013	DSCR FORSET AND NOFOR -- MAKE A SEARCH CONTROL BLOCK
 00075 00014	DSCR  FOREACH STATEMENT INTERPRETER
 00089 00015	DSCR ? LOCAL STACK ROUTINES,STK4LC,STK4VL
 00091 00016	DSCR BNDTRP- BINDING FORM OF BOOLEAN AOO≡V
 00095 00017	SOME VARIOUS BOOLEANS
 00097 00018	DSCR DERIVED SETS -- NOT IN FOREACH SPECIFICATIONS.
 00101 00019	DSCR MAKE AND ERASE
 00111 00020	
 00114 00021		TRNN	LPSA,377777
 00121 00022	 LEAP BREAKPOINTS EXIST.  
 00124 00023	DSCR ISTRIPLE, SELECTOR
 00126 00024	DSCR DELETE, NEW (VARIOUS KINDS), AND ARRAY ITEM CODE.
 00133 00025	ARRCLR: SETZM	(B)
 00134 00026	NEW:				GET A NEW ITEM NUMBER.
 00145 00027	DSCR SET AND ITEM STORING OPERATIONS.
 00153 00028	DSCR SET OPERATIONS
 00159 00029	DSCR  MORE SET OPERATIONS
 00162 00030	 
 00165 00031	DSCR UNION, INTERSECTION, SUBTRACTION
 00172 00032	DSCR PUTAFTER,PUTBEFORE
 00178 00033	DSCR SET RECLAMATION ROUTINES.
 00183 00034	DSCR RPLAC
 00185 00035	DSCR	TYPEX-to determine the type of an item
 00188 00036	DSCR TYPEIT -same as TYPEX except does not return datum address in left
 00193 00037	DSCR PUTXA,PUTXB
 00197 00038	DSCR INTNAM,CVSI,CVIS,DEL.PNAME,NEW.PNAME 
 00203 00039	
 00209 00040	DSCR MATCHING PROCEDURE ROUTINES, CALMP,RESMP,SUCFA1
 00214 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  202000000035  ⊗;


COMMENT ⊗
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,ARRRCL,LISTX,RECQQ
INTERNAL FORGET,REMEMB,RESTOR,ALLRM,ALLFOR,ALLRS
INTERNAL FP1DON,FP2DON,SDESCR
IFE ALWAYS,<ENTRY LEAP,CVIS,CVSI
	  TITLE	LEAP
	  EXTERNAL GOGTAB,ARCOP,CORGET,CORREL,ARMAK,ARYEL,TERMIN,RESUME,SPROUT
	  EXTERNAL SPRPDA,RUNNER,DADDY,CURSCB
	  EXTERNAL .SKIP.,DATM,LKSTAT,INFTB,X11,X22,X33,SAVE,RESTR,EQU,STACSV,STACRS
	  EXTERNAL PROPS
>

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.

FOREA	 -- says that this call is inside a foreach list.
SETOP	 -- this is a set type thing (e.g. x ε 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

	ITLEN←=12		;ITEM NUMBERS ARE 12 BITS LONG.



;LENGTHS OF VARIOUS THINGS.....

	PHASLN ←← =128			;LENGTH OF PNAME HASH TABLE
	FREELEN←←1000		;THIS IS HOW MUCH FREE SPACE WE GET
				;AT ONE TIME.
	HASLEN←←1777		;MUST BE OF THIS FORM.
				;I.E. 2↑N-1 .(THIS IS LENGTH OF HASH TABLE)
	INFOLEN←←7777		;MAXIMUM NUMBER OF ITEMS.
	TOPITM ←←7777		;DITTO...
GLOB <
	GBRK ←← 6000		;LOCAL - GLOBAL ITEM NUMBER BREAK
				;MAXIMUM GLOBAL ITEM # IS 7776
>;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←←=10		;MAXIMUM NUMBER OF SATISFIERS.(UNBOUND ITEMVARS)
	FPDLEN←←=70		;FOREACH PUSHDOWN LIST LENGTH
;** 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   → USER CORE ADDRESS OF VARB.
				; LH   CURRENT SATISFIER ITEM NUMBER.
				;       (PUT THERE WITH "MC", RETRIEVED
				;	WITH "MOVEA" OR "MOVEB"
	FPDL←←6+SATNO		;PUSH DOWN AREA.

	FRCHLEN←←SATNO+FPDLEN+8		;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 
	BNDFOR ←← 400000	;THIS LOCAL WAS BOUND ON ENTRY
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⊗X≡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 IMBEDDED UNDER 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.
				;ON IF NEXT GUY ON VALUE LIST IS A 
				;BRACKETED TRIPLE.
				;THIS BIT IS USED BOTH IN THE FOREACH SPEC.
				;FOR THE SEARCH, AND IN THE LEAP LIST
				;STRUCTURES CREATED.
DSCR TYPE CODES WITHIN RH OF INFOTAB ENTRY 
  I MOVED THESE TO HEAD FOR LIBRARY'S SAKE!!!!!!! DCS 6-25-72
        BRKITM ←← 2	;BRACKETED TRIPLE
	STTYPE ←← 3	;STRING ITEM
	FLTYPE ←← 4	;REAL ITEM
	INTYPE ←← 5	;INTEGER ITEM
	LSTYPE ←← 7	;LIST ITEM (TYPE SHOULD ALWAYS BE 1 MORE THN SETYPE
	SETYPE ←← 6	;SET ITEM
	PITTYP ←← 10
	INVTYP ←← 25	;NON-VALID TYPE CODE
	ARRTYP ←← 15	;ARRAYS ARE THIS PLUS SIMPLE TYPE CODE
⊗
COMMENT ⊗THERE IS A TBITS TABLE CALLED TBTBL IN EVAL -- IN FILE IOSER ⊗
;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



;THE MAGIC MACRO TO HASH

	DEFINE HASH (X,Y,Z) <
	IFDIF <X><Y>,<MOVE	X,Y>
	LSH	X,1
	XOR	X,Z
	AND	X,HASMSK(TABL)		;THE MASK
	ADD	X,HASTAB(TABL)		;AND THE BOTTOM OF THE AREA.
	>

;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

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)>
	>

CORGZR:			;THIS GETS AND ZEROES CORE.
GLOB <
	CAIN	TABL,GLUSER
	SETOM	USCOR2(USER)		;USE OTHER CORE.
>;GLOB
	PUSHJ	P,CORGET		;ASK FOR CORE (SIZE IN "C")
	ERR	<CAN'T GET LEAP CORE>
GLOB <
	SETZM	USCOR2(USER)
>;GLOB
	PUSH	P,B
	HRLS	B
	ADDI	B,1
	SETZM	-1(B)
	ADDI	C,-2(B)
	BLT	B,(C)		;ZERO THE WHOLE AREA.
	POP	P,B		;RETURN BASE OF NEW AREA IN B
	POPJ	P,

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,[DPB B,0]  ;USED TO INSERT INTO GLOBAL INFOTAB
	HRRZ	B,INFOTAB(TABL) ;ADDRESS INFOTAB
	ADDM	B,(P)
>;GLOB

	PUSH	P,[DPB	B,0]
	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
	XCT	-1(P)		;PUT IN GLOBAL INFOTAB
>;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
	SKIPG   UUO1(USER)	;IF NO LOCAL MODEL
	JRST	ITRET2		;JUST RETURN
	MOVEI	B,EVTYPI	;EVENT TYPE ITEM
	MOVEI	C,1		;CODE FOR NO DATUM
	MOVEM	C,@INFTB	;STORE CODE
	MOVEI 	B,NIC		;NIC ITEM
	MOVEM 	C,@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


↑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.
	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.
	SETZB	C,D		;ACCUMULATE MAXIMUM ITEM COUNT.
GLOB <
	MOVEI	LPSA,7777
>;GLOB
	HRROS	UUO1(USER)	;ASSUME NO LEAP LOCAL MODEL.
	MOVE	A,SPLNK(USER)	;ALLOCATION LINK POINTER
ITMWQ:	JUMPE	A,ITMDON	;0 WHEN DONE.
	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	[SKIPE C	;C USED AS FLAG,NONZERO IF WE'VE BEEN HERE BEFORE
		 TERPRI	<WARNING: TWO PROGRAMS WITH ITEMS IN THEM>
		 HRRZS UUO1(USER) ;SAY LOCAL LEAP MODEL
		 MOVE C,TEMP
		 JRST	.+1]
	SKIPLE	TEMP,$NWITM(A);IF ITEMS REALLY REQUESTED,
	HRRZS	UUO1(USER)	;SAY LOCAL LEAP MODEL
	ADD	D,TEMP		;ESTIMATE OF NEW ITEMS REQUIRED.
GLOB <
	CAML LPSA,$GITNO(A)	;JUST SO K PINGLE NEED NOT COMPILE WITH GLOB MODEL.
	MOVE LPSA,$GITNO(A)	;GLOBAL ITEMS ALLOCATED.
			;CANNOT EXCEED 7776...
>;GLOB
	HRRZ	A,(A)	;GO DOWN LINK.
	JRST	ITMWQ
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
	MOVEM	C,MAXITM(USER);TOP ITEM ALLOCATED.
	MOVEI	FP,HASLEN&777776;FOR THE HASH TABLE MASK.
	MOVEM	FP,HASMSK(USER)	;AND SAVE
GLOB <
				;GLOBAL MODEL INITIALIZATION.

	AOSE	LEPINI		;INITED ALREADY?
	JRST	LNONIT		;YES
	MOVEM	FP,HASMSK+GLUSER;IN TWO PLACES.
	MOVEI	TABL,GLUSER	;
	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 9,(3),26>) ;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 <
	ADDI	C,100(D)	;MAXIMUM EXPECTED NEWS IN ADDITION.
	CAILE	C,TOPITM	;IF OVER THE TOP, THEN...
>;NOGLOB
	MOVEI	C,TOPITM	;MAKE IT RIGHT.
	MOVEM	C,ITMTOP(USER)	;SAVE AS MAX PERMISSIBLE ITEM NUMBER.
	MOVNI	TEMP,-3(C)	;INIT FREITM(USER)
	SUB	TEMP,MAXITM(USER)
	MOVNM	TEMP,FREITM(USER);NUMBER OF UNALLOCATED LOCAL ITEMS.
GLOB <
	MOVEI	D,0
	PUSH	P,SPDON		;DUMMY RETURN ADDRESS.
>;GLOB
SPALLO:	PUSH	P,C
	LPCOR	(,)		;GET CORE FOR VALUE LINKS, ETC.
GLOB <
	SUBI	B,(D)		;SUBTRACT OFF LOWER BOUND.
>;GLOB
	MOVEM	B,INFOTAB(TABL)	;RECORD IT.
	LPCOR	(HASLEN+1,HASTAB);HASH TABLE SPACE.
	
	POP	P,C		;RESTORE SIZE
	LPCOR	(,)		;AND FOR DATUMS.
GLOB <
	SUBI	B,(D)		;ADJUST IF NECESSARY
>;GLOB
	MOVEM	B,DATAB(TABL)	;RECORD IT.
	HRLI	B,3		;ACCUMULATOR NUMBER FOR DATUM.
	SETZM	OLDITM(TABL)	;RESTART THE OLD ITEM LIST.
	HRRZ	A,INFOTAB(TABL)	;FOR DYNAMIC TYPE-CHECKING
	HRLI	A,(<POINT 9,(B),35>);BYTE PTR. FOR TYPE CHECKING
GLOB <
SPDON:	POPJ	P,.+1
>;GLOB
	MOVEM	A,INFTB		;FOR TYPE CHECKING
	HRLI	A,(<POINT 9,(3),26>) ;BYTE POINTER FOR PROPS FIELD
	MOVEM	A,PROPS
	MOVEM	B,DATM		;THIS IS FOR REFERENCING DATUMS.

; **** 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
;GET ONE AND TWO WORD FREES

GLOB <
	SKIPL 	UUO1(USER)	;WANT LOCAL LEAP?
	PUSHJ	P,GFREES	;WILL TRY TO USE HOLES IN INFOTAB,DATAB FOR ALLOC.
	MOVEI	TABL,(USER)	;WE'RE BACK TO LOWER SEGMENT STUFF
>;GLOB       
	SKIPL   UUO1(USER)	;DON'T GET FREES IF NO LOW-SEGMENT ITEMS
	PUSHJ	P,FPEES		;GET FREE STORAGE.
       	MOVE	B,SPLNK(USER)	;SPACE ALLOCATION LIST
PNMTYPLP:JUMPE	B,INITDN	;THROUGH?
	PUSH	P,B		;SAVE THROUGH CALLS
	SKIPE	A,$TINIT(B)     ;ITEM TYPE INITIALIZATION
	PUSHJ	P,INITIT
	SKIPE 	A,$PINIT(B)	;PRINTNAME INITIALIZATION
	PUSHJ	P,INTNAM
	POP	P,B
	HRRZ	B,(B)		;CDR SPACE ALLOCATION LIST
	JRST	PNMTYPLP
INITDN:	POP	P,TAC1		;RESTORE AC.
	POPJ	P,		;GO AWAY...
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 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.




ROUTABLE:
REPEAT 11,<JRST    	FOREC>	;0-10 -- FOREACH SEARCHES.
CALINDX:			;FOR MATCHING PROC RESUME
	JRST		FORGO	;11 -- START OF FOREACH STAT.
	PUSHJ P,	FRPOP	;12 -- POP FOREACH SATISFIERS INTO CORE.
	JRST		DOAG	;13 -- LOOP AT END OF FOREACH STAT.
	PUSHJ P,	FRTRUE	;14 -- IF A FOREACH BOOLEAN IS TRUE.
	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 7,<PUSHJ P,  	ERASE>	;20-26 -- ERASES
	PUSHJ P,    	ISTRIPLE;27 -- ISTRIPLE (FOO)
SELET1:	
REPEAT 3,<PUSHJ P,  	SELECTOR>;30-32 FIRST,SECOND AND THIRD.
	PUSHJ P,	CORPOP 	;33 -- CORE INTO SATISFIERS(INVERSE OF 12)
LD0:	JRST       	LD1	;34 -- DERIVED SETS -- INSIDE FOREACH.
	JRST 	   	LD2	;35
	JRST 	   	LD3	;36
DSTART:	JRST 	   	D1	;37 -- DERIVED SETS -- NORMAL.
	JRST 	   	D2	;40
	JRST 	   	D3	;41
	JRST 	   	DELETE	;42 -- DELETE.
	PUSHJ P,   	NEW	;43 -- REGULAR NEW.
	PUSHJ P,    	NEWART	;44 -- NEW (ARITHMETIC VALUE)
	JRST 	   	NEWARY	;45 -- NEW (ARRAY)
	PUSHJ P,	FDONS	;46 -- RELEASE THIS FOREACH STATEMENT.
	PUSHJ P,	PUTIN	;47 -- PUT X IN SET.
	PUSHJ P,	REMOV	;50 -- REMOVE X FROM SET.
	PUSHJ P,	SIP	;51 -- <A,B,C,D>
	PUSHJ P,	STIN	;52 -- BOOLEAN Xε SET ?
	PUSHJ P,	COUNT	;53 -- LENGTH OF SET.
	PUSHJ P,	UNIT	;54 -- COP OF SET.
	PUSHJ P,	UNION	;55 -- SET UNION
	PUSHJ P,	INTER	;56 -- SET INTERSECTION.
	PUSHJ P,	SUBTRA	;57 -- SET SUBTRACTION.
	JRST		STORITM	;60 -- STORE A SET OR ITEM FROM STACK.
	JRST	STORBUTDONTREMOVE ;61 -- SAME AS 60, BUT LEAVE ON STACK.
	JRST		POPTOP	;62 -- SAME AS 60 BUT PUT RESULT IN AC1
	JRST		POPSET	;63 -- SAME AS 60 BUT PUT RESULT IN AC1
RELSTART:
REPEAT 6,<PUSHJ P,  	SETEST>	;64-71 -- SET RELATIONALS.
	JRST		IEQ	;72 -- ITEM EQUALITY TEST.
	JRST		INE	;73 -- ITEM NON-EQUALITY TEST.
ISBEG:
REPEAT 7,< JRST     	ISIT >	;74-102 -- ANSWER TO A⊗B≡C ?
BSTART:
REPEAT 7,<JRST       	BRITM>	;103-111 -- FIND ITEM FOR [A⊗B≡C]
	JRST    	ITMRY	;112 -- FOR INITIALIZING ARRAY ITEMS.
	JRST     	ITMYR	;113 -- FOR INITIALIZING ARRAY ITEMS.
	JRST		STLOP	;114 -- LOP OF SET.
	JRST		BNDTRP	;115 -- BINDING FORM OF ASSOCIATIVE BOOLEAN
	JRST		SETCOP	;116 -- COPY A FORMAL SET.
	JRST		SETRCL	;117 -- RECLAIM A FORMAL SET.
	PUSHJ	P,	CATLST	;120 -- CONCATENATE TWO LISTS
	PUSHJ	P,	PUTAFTER ;121 -- INSERT IN LIST
	PUSHJ	P,	PUTBEFOR ;122 -- INSERT IN LIST
	JRST		SELFETCH ;123 -- SELECT ITEM FROM LIST
	PUSHJ	P,	TSBLST;124 -- LIST[EXPR TO EXPR]
	PUSHJ	P,	FSBLST;125 --  LIST[EXPR FOR EXPR]
	JRST		SETLXT	;126 -- TRANSFORM LIST TO SET
	PUSHJ	P,	RPLAC ; 127 -- REPLACE ELEMENT OF LIST
	PUSHJ   P,	REMX   	;130 -- REMOVE ELEMENT FROM LIST
	PUSHJ	P,	REMALL	;131 -- REMOVE ALL INSTANCES OF AN ITEM
	PUSHJ	P,	PUTXA	;132 -- PUT AFTER INDEXED	
	PUSHJ	P,	PUTXB	;133 -- PUT BEFORE INDEXED
	PUSHJ	P,	LSTMAK	;134 -- FOR MAKING UP LISTS
	JRST		CALMP	;135 -- SPROUT MATCHING PROCEDURE
	JRST		STK4VL	;136 -- STACK ? LOCAL AS VAL PARM
	JRST		STK4LC	;137 -- 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
	S2
	S1
	RESMP

DSCR  ASSOCIATIVE SEARCH ROUTINES
⊗;
comment @
These are the 9 kinds of associative searches:
	f1		A⊗O≡v
	f2		A⊗O≡X
	f3		A⊗X≡V
	f4		X⊗O≡V
	f5		X⊗Y≡V
	f6		A⊗X≡Y
	f7		X⊗O≡Y
	s1		x ε S
	s2		A ε 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⊗O≡V

F1:	AOSE	-TT1(FPD)	;FIRST TEMP SAYS WE WRE HERE BEFORE.
	 POPJ	 P,		;RETURN -- HAVE BEEN THROUGH ONCE.
	HASH	(A,<-ATTP(FPD)>,<-OBJP(FPD)>)
COMP:	SKIPN	B,1(A)		;SEE IF A-O-V IS THERE AT ALL.
	 POPJ	 P,		;IT IS NOT.
	XOR	B,-MASK(FPD)	;HAVE WE GOT IT?
	JUMPN	B,NO
YES:	AOS	(P)
	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,]	;FAILLLLLLllllll....
	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
	HRRZ	A,(A)		;MULTIPLE HITS LIST
	JUMPN	A,VALE
	POPJ	P,		;FAILED.



; A⊗O≡X

F2:	AOSE	-TT1(FPD)	;BEEN HERE BEFORE?
 	 JRST	 NEXT		;YESSIR
	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)
COMP2:	SKIPN	B,1(A)		;CHECK TO SEE IF A-O-V IS THERE AT ALL
	 POPJ	 P,		;FAIL
	TRZ	B,7777		;MASK OUT VALUE.
	CAMN	B,-MASK(FPD)	;SEE IF IT MATCHES...
	 JRST	 YES2
	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)
	POPJ	P,		;SUCCESSFUL RETURN


NEXT:	SKIPE	-VALP(FPD)	;ANY ?
	SKIPN	A,-T2(FPD)	;GET NEXT ONE
	 POPJ	 P,		;NONE.
	MOVE	B,1(A)		;GET WORD AGAIN,JUST TO MAKE SURE
	TRZ	B,7777		;SINCE ERASE MUMBLE⊗MUMBLE≡ANY
	CAME	B,-MASK(FPD)	;MAY CHANGE POINTERS ON US.
	 POPJ	 P,		;NO DICE
	HRRZ	C,(A)		;POINTER TO NEXT.
	MOVEM	C,-T2(FPD)	;SAVE IT.
	JRST	PUTA		;GO GET THE VALUE.



; A⊗X≡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!
	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]
	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)	
	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.

NEXT3:	MOVE	A,-T2(FPD)	;GET THE LAST POINTER
	SKIPE	-OBJP(FPD)	;ANY OBJECT?
	JUMPN	A,NN		; -- WANT TO DO SEARCH AGAIN.
	POPJ	P,



; X⊗O≡V


F4:	AOSE	-TT1(FPD)	;BEEN HERE BEFORE
	 JRST	 NEXT4		;YES
	MOVE	A,-VALP(FPD)	;GET VALUE
	ADD	A,INFOTAB(TABL)	;PREPARE TO GET VALUE LINK
	HLRZ	A,(A)		;VALUE LINK!
	JUMPE	A,CPOPJ		;FAIL
NN4:	MOVE	B,1(A)		;A-O-V WORD
	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)	
	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,




; X⊗Y≡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,
	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
	MOVE	C,-OBJP(FPD)	;OBJECT ID NUMBER
	DPB	B,MC(FRTAB)
	AOS	(P)
	POPJ	P,


; A⊗X≡Y


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
	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.
; ABOVE REPLACES BELOW (I DON'T BELIEVE IN MAGIC -- RFS DOES)
;	DPB	B,[POINT ITLEN,A,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:	PUSHJ	P,F2		;A⊗O≡X
	 JRST	 UPDAT		;FAIL
	AOS	(P)
	POPJ	P,

; X⊗O≡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
	SKIPA	A,[XWD 1000,0]	;START AT ITEM 10 (BECAUSE OF DUMMIES)
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:	PUSHJ	P,F2		; A⊗O≡X
	 JRST	 UPDAT7		;FAIL
	AOS	(P)
	POPJ	P,



; X ε 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
	DPB	B,MC(FRTAB)
	HRRZ	B,(A)		;NEXT POINTER.
	MOVEM	B,-T2(FPD)	;FOR NEXT TIME.
	AOS	(P)
	POPJ	P,		;SUCCESS.



; A ε 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)
	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:	MOVE	FRTAB,LEABOT(USER)	;ALWAYS AVAILABLE BLOCK
	MOVEI	A,1		;THIS WILL BE THE SATISFIER NO.
	TLNE	FLAG,BINDING⊗ATTPOS ;IF ATTRIBUTE IS "ANY"
	 MOVEM	 A,-2(P)	;THEN FIX.
	TLNE	FLAG,BINDING⊗OBJPOS
	 MOVEM	 A,-1(P)
	TLNE	FLAG,BINDING⊗VALPOS
	 MOVEM	 A,(P)		;THE COMPILER REALLY SHOULD DO THIS.

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.
	TRZ	B,BNDFOR	;TURN OFF "BOUND"BIT
	PUSH	FPD,B
	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.

P2:	POP	P,B
	TLNE	FLAG,BOUND⊗OBJPOS
	 XCT	 MOVEB(FRTAB)
;;#JL# BY JRL 10-4-72 SETS NOT POT BOUND
	TLNN	FLAG,SETOP	;BNDFOR ONLY FOR ITEMS
	TRZ	B,BNDFOR
	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:
	LSHC	B,-ITLEN

P1:	POP	P,B		;ATTRIBUTE
	TLNE	FLAG,BOUND⊗ATTPOS
	 XCT	 MOVEB(FRTAB)
	TRZ	B,BNDFOR
	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:
	LSHC	B,-ITLEN

	SETZM	INDEX4(FRTAB)

	PUSH	FPD,C		;THE MASK OF A-O-V
				;UNBOUND PORTIONS OF THE MASK ARE 0

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

	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).

FRTRUE  -- CALLED BY THE "TRUE" RESULT OF A BOOLEAN EXPRESSION
	   INSIDE A FOREACH SPECIFICATION.
	   SKIPS TWO INSTRUCTIONS (I.E. SKIPS OVER CALL ON FRFAL).
FRFAL	-- SIMILAR FOR FALSE. (EXCEPT NO SKIP)

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).
⊗;





LD2:	MOVE	B,(P)		;IN IS A,V,X
	EXCH	B,-1(P)		;MAKE IT A⊗X≡V
	MOVEM	B,(P)
				;COMPILER HAS FIXED UP THE BITS
				;CORRECTLY ALREADY.
LD1:
	HRRI	FLAG,(FLAG)ROUTABLE-LD0+DERIV-SEROUT ;FIX UP DISPATCH.

↑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....
	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.
	JRST	SUCC		;AND WE SUCCEEDED.





;JRST TO DOAG, FRFAL
;PUSHJ TO FRTRUE


↑FRTRUE:			;THIS IS COMPILED IN-LINE,CAN PROBABLY BE
				;DELETED
	MOVEI	A,2
	ADDM	A,UUO1(USER)	;SKIP OVER THE FALSE CODESSSS.
CPOPJ:	POPJ	P,

↑FRFAL:	
↑DOAG:  MOVE	FRTAB,FRLOC(USER) ;CURRENT SCB
	SKIPE	A,RUNNER	;ARE THERE PROCESSES?
	MOVE	FRTAB,CURSCB(A)	;LOAD FROM PVAR AREA
	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.
	HRLI	C,(<POINT 12,(C),17>)
	MOVEM	C,MC(B)		;BYTE POINTER 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.
	LDB	B,[POINT 4,(C),17] ;PICK UP DISPLAY DIFFERENCE
	MOVEI	LPSA,(RF)	;THE CURRENT DISPLAY
LPDISP:	MOVE	LPSA,1(LPSA)	;BACK THE STATIC LINK
	SOJG	B,LPDISP	;COUNT DOWN DIFFERENCE
	ADD	LPSA,(C)	;ADD THE DISPLACEMENT
	TLNE	C,20		;REFERENCE PARAMETER?
	MOVE	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
	TLNE	C,POTUNB	;A POTUNB LOCAL(?)
	CAIN	B,UNBND		;AND UNBOUND
	CAIA
	TRO	B,BNDFOR	;MARK AS BOUND ON ENTRY
	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.
	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
	SKIPE	A,RUNNER
	MOVE	FRTAB,CURSCB(A)
	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 10,10]
	JRST	FDX		;AND GO FOR MORE.


SCBRES:				;RECLAIM AN SCB
	HLR	A,FRLOC(USER)	;ADDRESS OF SCB POINTER
	SKIPE	D,RUNNER
	HLR	A,CURSCB(D)
	SETZM	(A)		;ZERO IT
	HRRZ	A,FRLOC(USER)	;ADDRESS THIS SCB
	SKIPE	D
	HRRZ	A,CURSCB(D)
	MOVE	B,SCBLNK(A)	;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(A)	;ADD TO FREE LIST
	MOVEM	A,SCBCHN(USER)	;UPDATE FREE LIST
	POPJ	P,		;RETURN
;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.
	SKIPG	C,(B)
	AOJA	B,LOPS
	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?
	SKIPG	D,(B)		;POT UNB ACTUALLY BOUND
	AOJA	B,LOPCP		;YES
	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
	SKIPL	C,(D)		;BOUND ON ENTRY?
	JRST	STKREF		;NO.
	XCT	MOVEA(FRTAB)	;YES GET CURRENT VALUE
	TRZ	A,BNDFOR	;TURN OFF "BOUND ON ENTRY" BIT
	PUSH	P,A		;LEAV ON STACK
	JRST	LEAV
STKREF: 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
	SKIPG	C,(B)		;BOUND?
	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 AOO≡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 BINDING bit on in FLAG and the stack
entry being zero.
⊗

BNDTRP:					;JRST'ED TO
	MOVE	FRTAB,LEABOT(USER)	;GET STATIC SCB
	HRRI	FLAG,0			;COMPUTE THE ROUTINE INDEX
	SETZM	SATIS+1(FRTAB)		;CLEAR SATISFIER ENTRIES
	SETZM	SATIS+2(FRTAB)	
	SETZM	SATIS+3(FRTAB)
	TLNN	FLAG,BINDING⊗ATTPOS	;ATTRIBUTE UNBOUND?
	JRST	OPOS			;NO
	HRRI	FLAG,1			;ATTRIBUTE BEING BOUND.
	SKIPN	B,-2(P)			;ATTRIBUTE = ANY?
	JRST	OPOS			;YES
	HRRZM	B,SATIS+1(FRTAB)	;SAVE ADDR OF ATTRIB. ITMVR
	HRRZM	FLAG,-2(P)		;FIRST SATISFIER IS ATTRIB
OPOS:	TLNN	FLAG,BINDING⊗OBJPOS	;OBJECT UNBOUND?
	JRST	VPOS			;NO
	TRO	FLAG,2			;OBJECT UNBOUND.
	SKIPN	B,-1(P)			;OBJECT=ANY?
	JRST	VPOS			;YES.
	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			;NO.
	TRO	FLAG,4			;VAL IS UNBOUND
	SKIPN	B,(P)			;VAL = ANY?
	JRST	SET.UP			;NO.
	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
	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

;SOME VARIOUS BOOLEANS


ISIT:				;JRST HERE FOR A⊗O≡V ?
	JSP	LPSA,NOFOR	;GO GET THINGS SET UP
	PUSHJ	P,@SEROUT-ISBEG+ROUTABLE(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.
	JSP	LPSA,NOFOR	;GO START THINGS.
BRGO:	MOVE	FLAG,-1(FPD)	;ROUTINE NAME.
	PUSHJ	P,@SEROUT-BSTART+ROUTABLE(FLAG);CALL IT.
	ERR	<NO SUCH BRACKETED ITEM>,1,LEAV
	HLRZ	B,(A)		;VALUE POINTER.
	BRACKN	B		;BRACKETED?
	JRST	BRGO		;NO
	HRRZ	B,(B)		;YES -- THIS IS THE ITEM.
	PUSH	P,B		;ON STACK -- RESULT IS ITEM NUMBER.
	JRST	LEAV		;DONE.....



;JRST TO THESE GUYS.

;ITEM RELATIONS. (EQUAL AND NOTEQUAL)

INE:	SKIPA	D,[CAME B,C]
IEQ:	MOVE	D,[CAMN B,C]	;THE COMPARE INSTRUCTIONS.
	POP	P,C
	POP	P,B
	XCT	D
	JRST	RETYES
	JRST	RETNO


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.


⊗;


DERIV:	F2
	F3
AN1TAB:	F6
	F6
AN2TAB:	F7
	F5


INIT2:	
	POP	P,B		;LAST ARG.
	SKIPN	B		;TEST FOR "ANY"
	JRST	[HRRI	FLAG,AN1TAB-DERIV(FLAG); ADJUST ROUTINE NAME.
		 TLO	FLAG,1000 ;COMPLAIN IF ANY⊗ANY
		 JRST	.+1]
	PUSH	FPD,B		;ONTO STACK.
	MOVE	C,B
	POP	P,B
	SKIPN	B		;AGAIN IF ANY.
	JRST	[HRRI	FLAG,AN2TAB-DERIV(FLAG);
		 TLNN	FLAG,1000;SEE IF HE LOST.
		 JRST	.+1	;NO...
		 ERR	<ANY⊗ANY BITES>]
	PUSH	FPD,B
	MOVE	FRTAB,LEABOT(USER);FAKE IT UP, GUYS.
	JRST	(FP)



D1:	MOVE	FPD,LEABOT(USER)
	MOVE	FPD,FPDP(FPD)	;GET PDP FOR CURRENT SEARCH ENTRY ON STACK
	PUSH	FPD,[1]	;FOR VALUE -- RESULT.
	JSP	FP,INIT2	;GO FILL EVERYONE.
	ROT	C,-ITLEN
	LSHC	B,-ITLEN
	JRST 	DOIT		;READY TOGO


D2:	MOVE	FPD,LEABOT(USER)
	MOVE	FPD,FPDP(FPD)	;SEE ABOVE
	JSP	FP,INIT2
	MOVEI	A,1
	EXCH	A,(FPD)
	PUSH	FPD,A		;CHANGE ORDER OF ARGS.
	LSH	C,ITLEN
	LSHC	B,-ITLEN
;	JRST	DOIT




DOIT:	PUSH	FPD,C		;MASK
	PUSH	FPD,[-1]	;FOR -TT1(FPD)
	PUSH	FPD,[0]		;WORK ROOM
	PUSH	FPD,[0]		;WOULD HAVE BEEN ROUTINE NAME
	PUSH	FPD,FLAG	;THIS IS ROUTINE NAME.
	PUSH	P,[0]		;THE SET WE WILL ACCUMULATE.
AGS:	PUSHJ	P,@DERIV-DSTART+ROUTABLE(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,(FPD)
	JRST	AGS		;LOOP UNTIL DONE.

LD3:	SUB	P,X11
D3:	SUB	P,X22
	ERR	<P * Q NOT IMPLEMENTED>,1
	JRST	LEAV
DSCR MAKE AND ERASE
THESE ARE THE ROUTINES TO MAKE AND ERASE ASSOCIATIONS IN THE 
ASSOCIATIVE STORE.  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.  THE CONTRACTION MAY
INVOLVE MOVING ASSOCIATIONS AROUND, WHICH IN TURN REQUIRES
UPDATING CURRENT FOREACH POINTERS HELD IN VARIOUS PLACES
(I.E.  IN THE FPD STACKS OF THE SEARCH CONTROL BLOCKS).

MAKE AND ERASE ARE BOTH CALLED WITH THE THREE TOP OF STACK
ELEMENTS BEGIN 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.

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).

⊗;


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

MAKE:
	SKIPE	-1(P)		;VALUE BOUND?
	SKIPN	-2(P)		;OBJECT BOUND.
	JRST	.+2
	SKIPN	-3(P)		;ATTRIB BOUND?
	ERR	<MAKE WITH UNBOUND ITEM>,1
GLOB <
	WRITSEC		;ENTER A POINTER-DIDLING AREA!
	TLNN	FLAG,GLBSRC	;GLOBAL MAKE?
	JRST	LOCMAK		;NO.
	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.
	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.
	HASH	(A,<-3(P)>,<-2(P)>)
AG:	SKIPN	B,1(A)		;IS THERE AN EMPTY SPACE IN HASH AREA?
	 JRST	 EASY		;YES
	TRZ	B,7777
	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		;GO UNTIL END
	SKIPN	FP,(FP)		;NOW TACK ONE WORD ONTHE END.
	 PUSHJ	 P,FP2DON
	SETZB	LPSA,(PNT)	;ZERO FIRST WORD OF ASS. CELL.
	HRRM	PNT,(D)		;LINK CONFLICT.
GOM:	IOR	C,-1(P)		;GET VALUE THERE
	MOVEM	C,1(PNT)	;AND STORE A-O-V
	MOVE	C,-1(P)		;GET VALUE AGAIN.
	ADD	C,INFOTAB(TABL)	;NEED TO UPDATE VALUE LINK
	HLRZ	D,(C)		;OLD ONE
	HRLM	D,(PNT)		;STORE IN VALUE SPOT
	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.

OUT1AX:	SKIPA	PNT,B
OUT1:	MOVE	PNT,A
	JRST	OUT111		;MUST HAVE PNT POINTING 
				;TO THING WE MADE.

EASY:	MOVE	PNT,A
	JRST	GOM		;PUT IT THERE.


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	OUT1		;IT IS ALREADY THERE!!!
	SKIPN	FP,(FP)		;MUST NOW MAKE A MULTIPLE VALUE GUY
	 PUSHJ	P,FP2DON
	MOVE	D,(A)		;FIRST WORD OF OLD ASS. CELL
	HLLZM	D,(PNT)		;SAVE IT.(ONLY VALUE POINTER)
	HRL	D,PNT		;NEW POINTER
	MOVEM	D,(A)		;IN OLD CELL.
	MOVE	D,1(A)
	MOVEM	D,1(PNT)
	PUSH	P,D		;SAVE FOR LATER
	TRZ	D,7777
	MOVEM	D,1(A)		;NEW A-O-0 FOR HEADER.
	POP	P,D
	ANDI	D,7777		;JUST VALUE
	ADD	D,INFOTAB(TABL)	;POINTER TO GOOD BITS.
RTNQ:	HLRZ	LPSA,(D)		;VALUE POINTER
	JUMPE	LPSA,[ ERTMAK:ERR <DRYROT -- MAKE>]
	BRACKP	LPSA
	JRST	[MOVE D,LPSA
		 HLRZ LPSA,(LPSA)	;BYPASS BRACKETED TRIPLE.
		 JRST .+1]
	CAIE	LPSA,(A)		;POINTING AT OUR MAN?
	JRST	[MOVE	D,LPSA
		 JRST RTNQ]
	HRLM	PNT,(D)		;CHAIN THINGS RIGHT.
	MOVE	PNT,FP
	JRST	MULINS		;INSERT NEW ONE AS PART OF MULTIPLE HIT.

MULVAL:	HLRZ	B,(A)		;PICK UP POINTER TO MULT. VALS.
IN1:	MOVE	D,1(B)		;PICK UP A-O-V
	ANDI	D,7777		;SAVE ONLY VALUE
	CAMN	D,-1(P)		;THE RIGHT VALUE?
	JRST	OUT1AX		;YES -- IT'S THERE
	HRRZ	B,(B)		;GET NEXT POINTER
	JUMPN	B,IN1		;LOOP

MULINS:	SKIPN	FP,(FP)		;WE NEED A CELL
	 PUSHJ	 P,FP2DON
	HLR	B,(A)		;POINTER TO MULL VALS.
	HRRM	B,(PNT)		;POINTER ON DOWN.
	HRLM	PNT,(A)		;NEW POINTER TO VALS.
	JRST	GOM


;JRST TO BMAKE

BMAKE:				;BRACKETED MAKE.......;;
	PUSHJ	P,MAKE		;GO MAKE IT..
GLOB <
;MAKE HAS PUT JOB INTO WRITING SECTION
>;GLOB
	HLRZ	A,(PNT)		;VALUE POINTER
	BRACKP	A		;IS IT ALREADY A BRACKETED?
	JRST	INALREADY	;YES
GLOB <
	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	D,(FP)
	MOVEI	C,(FP)		;LOTS NEED TO KNOW.
	SKIPN	FP,(FP)
	 PUSHJ	P,FP1DON	;OUT OF FREE STORAGE.
	HRRM	FP,FP1(TABL)
	TRC	C,BRABIT	;TURN IT ON.(LOGICALLY)
	HRLM	C,(PNT)
	HRLM	A,(D)		;PUT OLD POINTER IN NEW ONE-WORD FREE
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	B,(P)		;ITEM NUMBER.
	HRRM	B,(D)		;PUT ITEM NUMBER IN FREE.
	ADD	B,DATAB(TABL)	;PREPARE TO MAKE VALUE EENTRY
; ABOVE STATEMENT WAS MODIFIED TO MAKE READY FOR NEW WORLD
; INFOTAB WILL CONTAIN TYPE INFO. DATAB WILL CONTAIN POINTER
; TO TRIPLE.
GLOB <
	SKIPN	FP,FP2(TABL)	;GET FRESS2
	PUSHJ	P,FP2DON	;NONE YET, GET SOME
>;GLOB
NOGLOB <
	MOVE	FP,FP2(TABL)
>;NOGLOB
	HRRZM	FP,(B)		;POINTER TO TRIPLE
	MOVE	C,1(PNT)	;A-O-V WORD FROM MAKE.
	MOVEI	PNT,(FP)	;POINTER TO FREE.
	MOVEM	C,1(FP)		;INTO RANDOM GOOD WORD.
	SKIPN	FP,(FP)		;GET NEXT ONE
	 PUSHJ	P,FP2DON	;ALL OUT
	MOVEM	FP,FP2(TABL)	;RESTORE IT.
	SETZM	(PNT)		;ZERO FIRST WORD OF NEW FREE.
	JRST	LEAV


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


;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,@ETAB-ESTART+ROUTABLE(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
	PUSH	P,D		;SAVE ITEM NUMBER
	ADD	D,INFOTAB(TABL)	;ADDRESS INFOTAB ENTRY
	HLLZS	(D)		;ZERO IT
	POP	P,D		;RESTORE ITEM NUMBER
	ADD	D,DATAB(TABL)	;GET POINTER TO VALUESSS
	HRRZ	LPSA,(D)	;POINTER TO BRACKET INFO.
	TRNN	LPSA,377777
	ERR	<DRYROT -- BRACKET CONFUSION>
	MOVE	FP,FP2(TABL)	;PREPARE TO FREE A CELL.
	HRRZM	FP,(LPSA)	;LINK IT IN
	MOVEM	LPSA,FP2(TABL)	;RELEASE BLOCK
	SETZM	(D)
	MOVSS	D
	SKIPA
Y1:	HLRZ	D,(A)		;OLD POINTER ELSEWISE
Y2:	HRLM	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.
	CAMN	B,A		;DO WE POINT THERE ALREADY?
	 JRST	 HASHSPACE	;YES!!

LOOK:	CAIN	B,(A)		;DO WE POINT THERE?
	JRST	THISIT		;YES
	MOVE	D,1(B)		;GET A-O-V
	CAMN	D,C
	JRST	MULVLL		;A-O MATCH AT LEAST
	MOVE	LPSA,B		;REMEMBER WHO POINTED AT US
	HRRZ	B,(B)		;GO DOWN CONFLICT LIST.
	JUMPN	B,LOOK		;AND LOOP
	ERR	<DRYROT -- ERASE2> ;NOT ON CONFLICT LIST

HASHSPACE:
	HRRZ	D,(A)		;GET CONFLICT POINTER
	JUMPE	D,VALFIX	;NOTHIN TOIT
	MOVE	B,A		;AH SO MANY ACCUMULATORS !
	MOVE	C,(D)		;MOVE THE FIRST WORD
	MOVEM	C,(B)		;INTO THE HASH AREA, AND THEN
	PUSHJ	P,LST1		;GO FINISH THE MOVE AND CHECK VALUE LINKS.
	JRST	TRY		;AND FOR MORE.

VALFIX:	SETZM	(A)		;NOT A CARE IN THE WORLD.
	SETZM	1(A)
	JRST	TRY

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

MULVLL:	SETZM	LPSA		; A COUNTER
	HLRZ	C,(B)		;POINTER TO MULTIPLE HITS.
	CAIN	C,(A)		;IS THIS IT?
	JRST	FIST		;-- YESS AND THEFIRST ONE.
M1:	MOVE	D,C		;THIS IS WHO POINTS AT US.
	SKIPN	D		;RFS FORGOT THIS ERROR CHECK - KKP
	ERR	<DRYROT -- ERASE3>
	HRRZ	C,(C)		;GET NEXT MULTIPLE HIT.
	CAIE	C,(A)
	AOJA	LPSA,M1		;LOOP UNTIL FOUND
ITER:	HRRZ	C,(A)		;DOWN POINTER TO MOREHITS.
	JUMPN	LPSA,NOCHK		;IF THERE WAS AT LEAST ONE, FORGET 
	JUMPE	C,LST		;THIS IS THE LAST.
NOCHK:				;BY PASS US ON THE MULVAL LINKS.
	HRRM	C,(D)
	JRST	LINK		;PUT OLD ASSOC CELL ON FREE STORAGE LIST.


FIST:	HRRZ	D,(A)		;NEXT IN LINE...
	HRLM	D,(B)		;INSTALL IN HEADER
	HRRZ	C,(D)		;DOES THE NEXT GUY FINISH OUT?
	JUMPN	C,LINK		;NO -- LINK UP ON FREES AND RETURN.

;COMPACTION OF SOME SORT IS REQUIRED IF WE COME HERE.
;EITHER (1) A MULTIPLE VALUE GUY IS BEING COLLAPSED, OR
;(2) A HASH-SPACE ENTRY HAS BEEN DELETED, AND ITS NEXT
;CONFLICTER MUST BE MOVED INTO THE HASH SPACE.
; D → LAST CELL, FULL OF GOOD THINGS. THIS IS THE ONE
;	WHICH WILL BE RECLAIMED.
; B → PLACE WHERE NEW CELL WILL BE LOCATED.  ANY REFERENCES
;	TO CONTENTS OF D THAT ARE IN THE FOREACH STACKS
;	SHOULD BE CHANGED TO B

LST:	HLRZ	C,(D)		;VALUE LINK
	HRLM	C,(B)		;NOW IN TOP
	PUSHJ	P,LST1		;FINISH MOVE (THIS IS A SUBROUTINE).
LINK:	MOVE	FP,FP2(TABL)
LINKA:	HRRZM	FP,(A)
	SETZM	1(A)		;ZERO OUT SECOND WORD
	MOVEM	A,FP2(TABL)	;BIGGER FREE STORAGE LIST.
	JRST	TRY


LST1:	MOVE	C,1(D)		;A-O-V
	MOVEM	C,1(B)		;NOW IN TOP
	ANDI	C,7777		;VALUE NUMBER
	JUMPE	C,RELK		;THIS IS A MULTIPLE VALUE GUY.
	ADD	C,INFOTAB(TABL)
REL1:	HLRZ	LPSA,(C)	;GO LOOK FOR VALUE POINTER
	BRACKP	LPSA
	HLRZ	LPSA,(LPSA)	;TEST FOR AN BYPASS BRACKETED TRIPLE.
	CAIN	LPSA,(D)	;WHICH POINTS TO THING WE JUST
	JRST	[HRLM B,(C)	;MOVED
		JRST RELK]
	MOVE	C,LPSA
	JUMPN	C,REL1
	ERR	<DRYROT -- ERASE4>;THING MOVED NOT ON VALUE LIST
RELK:	CAMN	D,-T2(FPD)	;SEE IF A POINTER TO THIS GUY WAS
	MOVEM	B,-T2(FPD)	;STORED DURING SEARCH. IF SO -- UPDATE.
;HERE IS THE SHIT THAT IS NEEDED WHEN YOU HAVE RANDOM POINTERS LYING AROUND
;IN THE FOREACH TABLES.
;REALLY MUST BE UPDATED FOR PROCESS WORLD

	HRRZ	C,FRLOC(USER)		;CURRENT FOREACH
;; #JJ# FOLLOWING USED TO DESTROY A, USE FRTAB INSTEAD
	SKIPE	FRTAB,RUNNER
	HRRZ	C,CURSCB(FRTAB)
;; #JJ#
	SKIPA			
FF22:	HRRZ	C,SCBLNK(C)	;DYNAMIC FATHER FOREACH
	JUMPE	C,RELK1
	MOVE	LPSA,FPDP(C)	;FPDP (FRTAB)
FF11:	HRRE	PNT,-1(LPSA)	;ROUTINE #
	JUMPL	PNT,FF22	;-1,  ALL DONE.
	CAMN	D,-T2(LPSA)
	MOVEM	B,-T2(LPSA)	;ALL FOR THIS ONE FIXUP.
	SUB	LPSA,[XWD 10,10]
	JRST	FF11

;END OF SHIT

RELK1:	MOVE	FP,FP2(TABL)	;PUT "D" BACK ON FS LIST.
	HRRZM	FP,(D)
	HRRZM	D,FP2(TABL)	;RELEASED THIS ONE.
	POPJ	P,		;END OF LST1 SUBROUTINE.
; LEAP BREAKPOINTS EXIST.  
; ENTRY IS WITH ROUTINE ADDRESS IN C.


LPBRK:	PUSH	P,A		;ENTRY FROM ERASE.
	PUSH	P,FPD		;A → ASSOCIATION TO BE ERASED.
	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.
	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.
	 PDLOF			;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
	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
	POPJ	P,

DSCR DELETE, NEW (VARIOUS KINDS), AND ARRAY ITEM CODE.

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,
	AND PERHAPS DOING AN "ERASE" ON THE BRACKETED 
	TRIPLE THAT IT REPRESENTED.

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.

⊗;



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
GLOB <
	TLNN	FLAG,GLBSRC	;LOCAL DELETE?
	CAIG	C,GBRK		;HAD BETTER BE LOCAL ITEM.
	SKIPA
	ERR	<LOCAL DELETE OF GLOBAL ITEM>,1
	TLNE	FLAG,GLBSRC	;GLOBAL DELETE?
	CAIL	C,GBRK		;HAD BETTER BE GLOBAL ITEM.
	SKIPA
	ERR	<GLOBAL DELETE OF LOCAL ITEM>,1
>;GLOB
	PUSHJ	P,TYPEX	;GET 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
	PUSHJ	P,TERMIN
	POP	P,C
	POP	P,B
	POP	P,A
	MOVE	USER,GOGTAB
	POP	P,UUO1(USER)

GLOB <
	MOVEI	TABL,(USER)
>;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
	MOVE	B,(B)	;ADDR ASSOC.
	MOVE	C,1(B)	;A-O-V OF BRACKET
	SETZM	B	;WILL NOW BUILD STACK ENTRIES
	LSHC	B,ITLEN	;GET ATTRIB.
	PUSH	P,B	;ATTRIBUTE
	SETZM	B	
	LSHC	B,ITLEN	;OBJECT
	PUSH	P,B	
	LSHC	B,ITLEN	;VALUE
	PUSH	P,B	
NOGLOB <
	MOVEI	FLAG,ESTART-ROUTABLE	;ERASE A-O-V
>;NOGLOB
GLOB <  HRRI	FLAG,ESTART-ROUTABLE
	TLZ	FLAG,-1≠GLBSRC
>;GLOB
	PUSHJ	P,ERASE
	SUB	P,X11	;REMOVE ITEM NO.
	JRST	LEAV	;RETURN
NOBRACK:
	CAIG	A,ARRTYP ;SEE IF ARRAY
	JRST	CLRDAT	;NO CLEAR DATUM
	CAIN	A,INVTYP ;INVALID TYPE?
	ERR	<DRYROT - ITEM TYPE CONFUSION>
	CAIE	A,LSTYPE+ARRTYP
	CAIN	A,SETYPE+ARRTYP
	JRST	[ PUSH	P,A  ;CALL WILL DESTROY
		  MOVE  A,(B)  ;ARRAY DESCRIPTOR
		  PUSHJ P,ARRRCL
		  POP   P,A
		  JRST  .+1]
	PUSH	P,B	;SAVE AC B
	SKIPN	B,(B)		;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	ARRCLR
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    .+1]
	CAIE	A,STTYPE	;A STRING ITEM
	JRST	ARRCLR		;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


ARRCLR: SETZM	(B)
	MOVS	B,(P)		;ITEM NUMBER
	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
	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 		



NEW:				;GET A NEW ITEM NUMBER.
NEWX:
GLOB <
	WRITSEC		;ENTER CRITICAL SECTION.
>;GLOB
	SKIPN	C,OLDITM(TABL)	;SEE IF ANY DUSTY OLD ITEMS.
	JRST	[
GLOB <
		TLNE	FLAG,GLBSRC;IF GLOBAL THEN
		SOSA	C,MAXITM(TABL);USE GLOBAL COUNT.
>;GLOB
		AOS	C,MAXITM(USER);USE LOCAL ITEM NUMBER.
GLOB <
		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.
>;GLOB
NOGLOB <
		CAMGE	C,ITMTOP(USER);IF GONE TOO HIGH. THEN
>;NOGLOB
		 JRST REITM
		ERR	<ITEM SPACE EXHAUSTED>]
	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
	HRR	B,FP1(TABL)	;NEW HEAD OF ONE-WORD FREES
	ANDI	C,TOPITM	;ITEM NUMBER.
REITM:	
	SOS	FREITM(TABL)	;ONE LESS FREE
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.

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 
	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


NEWARY:				;JRST HERE
GLOB <
	TLNE	FLAG,GLBSRC
	SETOM	USCOR2(USER)
>;GLOB
	PUSHJ	P,ARCOP		;COPIES THE ARRAY IN -1(P)
	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.
	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
	MOVEM	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,B		;SAVE B
	MOVE	B,-2(P)		;ITEM TO BE TESTED
	CAIL	B,TOPITM	;TOO HIGH?
	JRST    NTGLB
	CAMGE	B,MAXITM+GLUSER ;TOO LOW?
	JRST	NTGLB
	LDB	B,GINFTB	;ALLOC?
	SKIPN	B
;; #JI# BY JRL 10-2-72
NTGLB:	TDZA	A,A
;; #JI#
	MOVNI	A,1
	POP	P,B
>;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.
POPTOP  -- STORE TOP OF STACK (MUST BE ITEM) INTO AC 1.
POPSET  -- STORE TOP OF STACK (MUST BE SET)  INTO AC 1.

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

POPTOP:				;POP OFF TOP OF STACK.
	MOVEI	TAC1,RACS+1(USER)
	SKIPA
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
	TRZ	B,BNDFOR
	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 SET OPERATIONS
 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.  AN ERROR IS GIVEN IF THE
	ITEM IS NOT A MEMEBER OF THE SET.

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

⊗;


;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:
	SKIPN	A,-1(P)		;ITEM.
	ERR	<PUT WITH UNBOUND ITEM>,1
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.
	HRRM	FP,(B)		;LINK WHOLE THING ON FS LIST.
ENZERO:	HRRZ	B,(TAC1)	;THIS IS NOW THE FS LIST.
	SETZM	(TAC1)		;AND ZERO THE DESCRIPTOR
	JRST	GOREM

ERRS1:	SETOM   .SKIP.
	JRST	RETQ


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  MORE SET OPERATIONS
 SIP -- FOR MAKING UP SETS FROM LISTS OF ITEMS { A,B,C }.
	CALL IS WITH TOP OF STACK HAVING ITEM IN IT,
	NEXT ELEMENT IN STACK IS THE SET WE ARE BUILDING.

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

 COUNT -- RETURNS IN AC1 THE LENGTH OF THE SET ON TOP
	OF STACK.

 UNIT -- RETURNS ON TOP OF STACK THE FIRST ELEMENT OF THE
	SET WHICH IS ON THE TOP OF STACK.

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

⊗;


; SIP -- FOR MAKING UP SETS OF ITEMS.

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

SIP:
	SKIPN	B,-1(P)		;ITEM
	ERR	<MAKING SET WITH UNBOUND ITEM>,1
	TLNE	FLAG,(BOUND!BINDING)⊗ATTPOS
	PUSHJ	P,BSATIS	;GET SATIS
	MOVE	A,B
	MOVEI	TAC1,-2(P)	;THE SET DESCRIPTOR.
	HLRE	B,(TAC1)	;COUNT
	MOVMS	B
	HRLM	B,(TAC1)	;MAKE POSITIVE.

	PUSHJ	P, ENTY		;SEE PUTIN AND FRIENDS.
	HLRE	A,(TAC1)	;COUNT OF SET.
	MOVNS	A
	HRLM	A,(TAC1)	;AND MAKE A TEMP.
	SUB	P,X11
	JRST	@2(P)


RET1:	HRRM	FP,FP1(TABL)
RET0:	SUB	P,X22
	JRST	@2(P)





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

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

STIN:
	SETZM			;USES R0 FOR JUMPE...
	MOVE	B,-2(P)		;ITEM
	TLNE	FLAG,BOUND⊗ATTPOS
	PUSHJ	P,BSATIS	;GET SATIS
	MOVE	C,-1(P)		;THE SET
LOPT2:	HRRZ	C,(C)		;DOWN THE SET
	JUMPE	C,NOPE
	HLRZ	D,(C)
	CAIE	D,(B)		;THE ITEM?
	JRST	LOPT2

NOPE:	
	PUSHJ	P,RECL1		;RECLAIM IF NECESSARY.
RET3C:	HRREM	C,A		;SAVE IN REG 1 AS RESULT.
RET3:	SUB	P,X33
	JRST	@3(P)



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

COUNT:
	HLRE	C,-1(P)
	PUSHJ	P,RECL1		;RECLAIM -1(P) IF NECESSARY.
	MOVMM	C,A
	JRST	RET0		;THAT'S ALL


; UNIT ...

; CALL IS WITH SET IN -1(P)

UNIT:
	MOVE	A,-1(P)
	TLNN	A,-1
	ERR	<UNIT 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,

;SET RELATIONS......

;VARIOUS LOCAL BITS.
	TESNEQ←←40		;TEST NOT EQUAL
	TESEQL←←20		;TEST EQUAL
	TES12 ←←10		;TEST 1⊂2
	TES21 ←← 4		;TEST 1⊃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.
	SKIPN	A,-1(P)		;ITEM TO BE INSERTED
	ERR	<PUT WITH UNBOUND ITEM>,1
	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 ≤ 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)	; → 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
	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
	<list_variable> [N]  ← <item>
	TAC1 POINTS TO LIST_VARIABLE
	N IS IN -1(P)
	ITEM IN -2(P)
	CALLED WITH PUSHJ P,
	⊗

RPLAC:
	SKIPN	A,-2(P)		;ITEM
	ERR	<REPLACE WITH UNBOUND ITEM>,1
GLOB<
	JSP	B,GQSET		;IN CASE GLOBAL SET
	>;GLOB
	SKIPG	B,-1(P)		;N≤0?
	ERR	<REPLACE - INDEX ≤ 0>
	POP	P,-1(P)		;MAKE STACK LOOK LIKE CALL
				;TO PUT IN
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
			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
	MOVE	A,-3(P)		;ITEM #
	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 9,(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 ≤ 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
	SKIPN	A,-2(P)		;ITEM
	ERR	<PUT WITH UNBOUND ITEM>,1
	JSP	B,INSET		;INITIALIZE FREE STORAGE PNTRS
	POP	P,-1(P)		;MAKE IT LOOK LIKE CALL TO PUT
	JUMPLE	D,ERRPUT	;INDEX ≤0 ?
	HLRE	C,(TAC1)	;LENGTH OF LIST
	CAMLE	D,C		;INDEX ≤ 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 LSTMAK
	FOR MAKING UP LISTS OF ITEMS
	CALL IS WITH ITEM IN -1(P)
	LIST STAYS IN -2(P)
	⊗

LSTMAK:	SKIPN	B,-1(P)		;ITEM
	ERR	<MAKING LIST WITH UNBOUND ITEM>,1
	TLNE	FLAG,(BOUND!BINDING)⊗ATTPOS
	PUSHJ	P,BSATIS	;GET SATISFIER
	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)		;RETURN


DSCR ARRRCL
	TO RECLAIM AN ARRAY OF LISTS OR SETS
	ONLY RECLAIMS LIST SPACE, NOT ARRAY SPACE
	ARRAY ADDR IN -1(P)
	ROUTINE CALLED WITH PUSHJ
	⊗
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 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 ≤0 ⊃ 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.
;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>
		]
	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
	CAIA	
CVSNO:	SETOM	@-1(P)
	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
	MOVEM	FPD,FPDP(FRTAB)		;REPLACE PDL POINTER
	HRRI	FLAG,CALINDX-ROUTABLE	;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