COMMENT ⊗   VALID 00023 PAGES VERSION 16-2(38)
RECORD PAGE   DESCRIPTION
 00001 00001
 00003 00002	HISTORY
 00008 00003	Leap Generators.
 00022 00004	DSCR LEPINI
 00025 00005	DSCR LEAPC1, LEAPC2
 00031 00006	
 00035 00007	STCHK:	PUSH	P,D			SAVE NUMBER OF PARAMS TO CHECK.
 00044 00008	DSCR CHKSAT -
 00045 00009	FOREACH STATEMENT HANDLERS.
 00060 00010	DATUM HANDLERS
 00066 00011	 MAKE AND ERASE
 00067 00012	 VARIOUS BOOLEANS.
 00072 00013	DSCR DELT, SIPGO, STPRIM, ECVI, STLOP, PUTIN, LPPHI, etc.
 00079 00014	DSCR PUTINL,HLDPNT,REMXD,REPLCX LISTGT
 00083 00015	DSCR CVLS,LSSUB,SELIP,SELSBL 
 00088 00016	GETTING NEW ITEMS.
 00093 00017	 CASE, EXPRESSION CONDITIONALS.
 00095 00018	 STORE ROUTINES.
 00101 00019	
 00104 00020	DSCR CALMP -MATCHING PROCEDURE EXECS
 00107 00021	DSCR REMEMBER EXECS RMASET,RMBSET,RMSTK
 00110 00022	 EXECS FOR DYNAMIC BINDING OF PROC ITEMS
 00113 00023	EXECS FOR APPLY
 00114 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  202000000046  ⊗;


COMMENT ⊗
VERSION 16-2(38) 11-2-72 BY JRL REFERENCE SETS TO PUT REMOVE SHOULD BE REMOPPED
VERSION 16-2(37) 10-23-72 BY JRL COMPILE ITEM COMPARISONS INLINE
VERSION 16-2(36) 10-22-72 BY JRL MAKE JUMPE JRST TO JUMPN IN FRBOL
VERSION 16-2(35) 10-21-72 BY JRL MAKE CATLST KNOWN TO WORLD
VERSION 16-2(34) 10-20-72 BY RHT BUG #JS# ADJUST ADEPTH IN EVLLST & EVLNLL
VERSION 16-2(33) 10-8-72 BY JRL BUG ##J#O# ADD ROUTINE LTYPCK TO MAKE AE GO TO IP OR SP
VERSION 16-2(32) 10-8-72 BY JRL BUG #JN# STORE DUMMY SEMBLK FOR DERIVED SET IN PARSE STACK
VERSION 16-2(31) 10-3-72 BY JRL OPTIMIZE CVN CODE
VERSION 16-2(30) 10-3-72 BY JRL OPTIMIZE FRCHPOP(DO ONLY WHEN NECESSARY)
VERSION 16-2(29) 10-2-72 BY JRL COMPILE POPTOP ITEM(ECHK) IN-LINE
VERSION 16-2(28) 9-27-72 BY JRL IMPROVE THE STOR1 OPERATION FOR ITEMVARS
VERSION 16-2(27) 9-26-72 BY JRL ADD DATUM(IT,TYPE) FACILITY
VERSION 16-2(26) 9-21-72 BY JRL DECLARE PREDECLARED ITEMS
VERSION 16-2(25) 9-12-72 BY JRL CHANGE DATUM TO USE GDATM PROPERLY
VERSION 16-2(24) 9-11-72 BY JRL MAKE ECVI HONEST ABOUT TYPE
VERSION 16-2(23) 9-8-72 BY JRL ADD CODE TO HANDLE ? LOCALS
VERSION 16-2(22) 9-5-72 BY JRL FORCE STAKIT TO HANDLE ? PARAMETERS
VERSION 16-2(21) 9-1-72 BY KVL MAKE CHECK ON UNTYPED ITEMVARS
VERSION 16-2(20) 8-24-72 BY JRL CHANGE BNDLST TO ALLOW SETS
VERSION 16-2(19) 8-23-72 BY JRL FIX FOR LIST WITH ITEMVAR BUG
VERSION 16-2(18) 8-21-72 BY JRL STORE ITEMS BY EITHER POP OR MOVEM (NOT LEAP CALL)
VERSION 16-2(17) 8-20-72 BY JRL TURN OFF LPFREE IN STAKIT RATHER THAN STITM
VERSION 16-2(16) 8-17-72 BY JRL HANDLE DISPLAY ITEMVAR LOCALS TO FOREACH
VERSION 16-2(15) 8-14-72 BY RHT FIX JRL
VERSION 16-2(14) 8-12-72 BY RHT MODIFY LODPDA TO HANDLE EXTERNAL PROCEDURES
VERSION 16-2(13) 8-10-72 BY JRL ADD REMEMBER, FORGET EXECS
VERSION 16-2(12) 8-9-72 BY JRL CHANGE "GLOBAL" KLUDGE SEE GLBST2
VERSION 16-2(11) 7-2-72 BY JRL ADD LEAPIS AND CLEAN UP LPXISX
VERSION 16-2(10) 6-23-72 BY RHT CHANGE LPSET,LPXISX TO LPSET!LPXISX JUST BEFORE BUG #HW# ON P 16
VERSION 16-2(9) 6-22-72 BY JRL CATCH SET ITMVR←SET
VERSION 16-2(8) 6-21-72 BY RHT FIX THINGS SO PDA NOT FIXED UP AFTER PD IS OUT
VERSION 16-2(7) 6-20-72 BY JRL BUG #HR# USE FIXUP IN LOADING SATIS BLK ADDR RATHER THAN REL. ADDR
VERSION 16-2(6) 6-12-72 BY JRL ADD BNDLST EXEC
VERSION 16-2(5) 6-8-72 BY DCS INSTALL VERSION 16
VERSION 15-2(4) 2-22-72 
VERSION 15-2(3) 2-6-72 BY DCS BUG #FN# SAFE ... ARRAY ITEMVAR BUG
VERSION 15-2(2) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER

⊗;
SUBTTL	Leap Generators.
	LSTON	(LEAP)
LEP <
	NOGEN
BEGIN	LEAP
DSCR -- LEAP EXECS
SEE Comment below, and later, for sketchy details
⊗
COMMENT ⊗

These are the generators to handle the LEAP constructs.  Supposedly,
 everything is conditionally assembled so that if LEAPSW is not
 on, you will get a smaller, faster and less elegant compiler.

The SET and ITEM expression manipulators really just call run time
 routines to stack things on some pseudo-stack.  The various Bool-
 ean and operational operators are then implemented as calls on
 the runtime interpreter.  At compiler time, a "copy" of that stack
 is kept around.  This is for purposes of type checking, checking
 to see that things are bound at the right times, etc.
The first section of this code deals with this compile-time stack.
 Every time a LEAP type primary is scanned, either STSET or STITM
 is called to place the token on the stack and to pass the things
 off to the runtime routines.  Any generators designed to make use
 of this stack mechanism should be careful to adjust things.

⊗

;VARIOUS MACRO DEFINITIONS FOR US.....


DEFINE	STAKCHECK (X,Y) <
	IFDIF <Y><>,<MOVNI D,X>
	IFIDN <Y><>,<MOVEI D,X>
	PUSHJ	P,STCHK
	>
DEFINE  CONCHK <
	TLNN	A,CNSTR
	ERR	<RETRIEVAL - CONSTRUCTION FAILURE>,1
	>
DEFINE RETCHK <
	TLNN	A,RETRV
	ERR	<RETRIEVAL - CONSTRUCTION FAILURE>,1
>

DEFINE SETCHK (N) <
	IFDIF <N><>,<MOVEI D,N>
	PUSHJ	P,CHKSET	;SEE IF REQUIRED NUMBER OF SETS
>
;BITS FOR LOCAL ITEMVAR ADDRESSES
CDISP ←← 100000			;THIS PARM NEEDS A DISPLAY CALCULATION
MPPAR	←← 200000		;THIS IS ? PARAMETER
POTUNB	←← 400000		;THIS IS A ? LOCAL

;VARIOUS BIT DEFINITIONS FOR THE LEAP RUNTIME STACK.
;SEVERAL (THOSE ***'ED) ARE PASSED ON TO THE RUNTIMES -- CAREFUL.

	LPSET	←←	1		;THIS IS A SET *********
	BINDING	←←	2		;THIS IS A LOCAL BEING BOUND ********
	BOUND	←←	4		;THIS IS A LOCAL THAT IS BOUND ********

	FIXED	←←	10		;THIS IS A FIXED ITEM.
	LPXISX	←← 	20		;THIS IS A LIST, LPSET ALSO ON ****
	DUMSEM  ←←      40		;THE LEAP STACK ENTRY IS A DUMMY

	↑↑LPITM	←←	40000		;AN ITEM.
	RETRV	←←	20000		;RETRIEVAL CONTEXT IS OK.
	CNSTR	←←	10000		;CONSTRUCTION CONTEXT IS OK.
	LPDMY	←←	4000		;THIS IS A BRAND NEW, MADE-
					;UP LOCAL NUMBER.
	STACKET	←←	2000		;THIS THING IS REALLY STACKED ....
	LPNUL	←←	1000		;"ANY" OR "PHI" DEPENDING ON 
					;FIXED OR LPSET

	MAXLOC	←←	20		;MAXIMUM NUMBER OF LOCALS. ********

	BRACKET	←←	400000		;THIS IS A BRACKETED SEARCH ****
					; **** MUST BE SIGN BIT FOR RUNTIMES
					;**** (ONLY)
GLOC <
	GLBSRC   ←←      200000		;THIS IS A GLOBAL SEARCH ******
>;GLOC
	FOREA	←←	40000		;THIS IS INSIDE A FOREACH LIST 
					; (BUT NOT USED)
	SETOP	←←	20000		;THIS IS A SET OPERATION. 


	ATTPOS ←←	6		;POSITIONS OF TYPE BITS.
					;IN CONTROL WORD.
	OBJPOS	←←	3
	VALPOS	←←	0

;NOW FOR THE DEFINITIONS OF ALL THE RUNTIME ROUTINES.

	DEFINE RUNTIM ' (X,Y) <
	L'X ←← MYCOUNT!GLOFLG
	IFDIF <Y><>,<MYCOUNT←←MYCOUNT+Y>
	IFIDN <Y><>,<MYCOUNT←←MYCOUNT+1>
	GLOFLG←←0
	>
DEFINE GLO <
GLOC <
	GLOFLG ←← 400000
>;GLOC
>
	MYCOUNT ←←0
	GLOFLG ←←0

GLO	RUNTIM	TRIPLES,7		;ORDINARY TRIPLE SEARCHES
	RUNTIM	STSRC,2			;THE SET SEARCHES ?
	RUNTIM	FRCHGO			;11--BEGINNING OF FOREACH LIST.
	RUNTIM	FRCHPOP			;12--POP SATISFIERS INTO CORE
	RUNTIM	FRLOOP			;13--LOOP BACK FOR MORE (FOREACH STATE.)
	RUNTIM	FRTRU			;14--BOOLEAN TRUE.(NO LONGER USED)
	RUNTIM	FRFAL			;15--BOOLEAN FALSE.
GLO	RUNTIM	MAKE			;16--MAKE
GLO	RUNTIM	BMAKE			;17--BRACKETED TRIPLE MAKE.
GLO	RUNTIM	ERAS,7			;20-26--ERASE ROUTINES.
GLO	RUNTIM	ISTRIP			;27-BOOLEAN "IS THIS A BRACKETED TRIPLE"
GLO	RUNTIM	SELECT,3		;30-32--SELECTORS.
	RUNTIM	CORPOP			;33 --MOVE CORE TO SATISFIER TABLE
GLO	RUNTIM	LDERIV,3		;34-36--DERIVED SETS DURING FOREACH LISTS.
GLO	RUNTIM	DERIV,3			;37-41--DERIVED SETS, NOT DURING FOREACH.
GLO	RUNTIM	DELETE			;42--DELETE THIS ITEM.
GLO	RUNTIM	NEWITM			;43--MAKE A NEW ONE.
GLO	RUNTIM	NEWARITH		;44--MAKE A NEW ARITHMETIC TIEM.
GLO	RUNTIM	NEWRY			;45--MAKE A NEW ARRAY ITEM.
	RUNTIM	FRELS			;46--RELEASE THE FOREACH BLOCK
	RUNTIM	STPUT			;47--PUT
	RUNTIM	STREM			;50--REMOVE
	RUNTIM	SIP			;51--SET MAKERS{}.
	RUNTIM	STIN			;52--BOOLEAN A ε S?
	RUNTIM	SETCUNT			;53--LENGTH OF A SET OR LIST
	RUNTIM	STUNT			;54--COP OF A SET
	RUNTIM	STUNI			;55--SET UNION
	RUNTIM	STINT			;56--SET INTERSECTION
	RUNTIM	STMIN			;57--SET SUBTRACTION.
	RUNTIM	STORE			;60--STORE A SET OR ITEM
	RUNTIM	STORBUTDONTREMOVE	;61--EXPRESSION STORE(LEAVE ON STACK)
	RUNTIM	POPTOP			;62--POP OFF TOP ELEMENTS.(POP ITEM NOW INLINE)
	RUNTIM	POPSET			;63--POP OFF SET
	RUNTIM	SETREL,6		;64-71 SET RELATIONS.
	RUNTIM	ITMREL,2		;72-73 ITEM RELATIONS.(SOON TO BE INLINE?)
GLO	RUNTIM	ISIT,7			;74-102 A⊗O≡V ?
GLO	RUNTIM	BRTRIP,7		;103-111 [A⊗O≡V] AND LEAVE ON STACK.
GLO	RUNTIM	ITMRY			;112--THE TWO GUYS FOR MARKING ARRAYS.
	RUNTIM	ITMYR			;113
	RUNTIM	STLOP			;114--LOP OFF AN ITEM FROM A SET.
	RUNTIM	NOOP			;115--FORMERLY WAS INTNAM(PNAME INIT.)
	RUNTIM	SETCOP			;116--COPY A FORMAL SET (ADDRESS IN TAC1)
	RUNTIM	SETRCL			;117--RECLAIM A FORMAL SET ( "" )
	RUNTIM	CATLST			;120--CONCATENATE TWO LISTS
	RUNTIM  PUTAFT			;121--PUT AFTER ITEM
	RUNTIM	PUTBEF			;122--PUT BEFORE ITEM
	RUNTIM	SELFET			;123--SELECT LIST ELEMENT
	RUNTIM	TSBLST			;124--TO SUBLIST
	RUNTIM	FSBLST			;125--FOR SUBLIST
	RUNTIM	SETLST			;126--TRANSFORM LIST TO SET CVSET
	RUNTIM	RPLAC			;127--REPLACE ELEMENT OF LIST
	RUNTIM	REMX			;130--REMOVE INDEXED
	RUNTIM	REMALL			;131--REMOVE ALL 
	RUNTIM  PUTXA			;132--PUT AFTER INDEXED
	RUNTIM	PUTXB			;133--PUT BEFORE INDEXED
	RUNTIM	LSTMAK			;134--ADD TO TEMPORARY LIST {{}}
	RUNTIM	MATCAL			;135--CALL A MATCHING PROCEDURE
	RUNTIM	STK4VL			;136--STACK A ? LOCAL
	RUNTIM	STKQPR			;137--STACK A ? LOCAL AS AN MP ARGUMENT

↑LCATLS ←← LCATLS
↑LSTKQP ←← LSTKQP
↑LFRLOO ←← LFRLOO
↑LFRELS ←← LFRELS
↑LITMRY	←← LITMRY
↑LITMYR	←← LITMYR
↑LSETCO ←← LSETCO
↑LSETRC ←← LSETRC
ZERODATA (LEAP VARIABLES)
;GLBSTK A QSTACK TO HANDLE GLOBAL CONSTRUCTS.
↑↑GLBSTK: 0

;MPSTAK A QSTACK OF ALL MATCHING PROCEDURES WHOSE ENDS HAVE NOT
;BEEN SEEN
↑↑MPSTAK:0

;MPQSTK: A QSTACK FOR ? ITEMVAR PARAMS TO MESSAGE PROCEDURE
;MPQBEG FIRST STACK POINTER FOR ABOVE
↑↑MPQSTK: 0
↑↑MPQBEG: 0

;LEAPIS -- ZERO IF NO LEAP CONSTRUCTS, -1 IF LEAP USED BY COMPILED PROG.
↑↑LEAPIS: 0

;SATADR -- CONTAINS ADDR FIXUP FOR SATISFIER BLOCK FOR FRCHGO
↓SATADR: 0
;BBWORD,INDEX4 used in STCHK to give type bits to ? FOREACH locals
↓BBWORD: 0
↓INDEX4: 0

;BYTES -- a parameter to LPCALL, specifies type bits, etc.  I don't
;    really understand it
↑↑BYTES: 0

↓FFSAVE: 0	;SAVE FF SOMETIMES

;LEABEG -- LEAP "push-down stack" -- used to model the runtime stack,
;    keep track of things
↓LEABEG: BLOCK	40

;LEAPSK -- LEABEG "PDP" -- points to last LEABEG entry
↑↑LEAPSK: 0

;LEPGLB -- counter set when LEAP operation preceded by GLOBAL
;When the operation is scanned (NEW,⊗,DELETE,DATUM,etc) this value is pushed
;onto the GLBSTK qstack. This is so that constructs such as
; GLOBAL NEW( DATUM (x)) is handled correctly.
↑↑LEPGLB: 0

;LOCALCOUNT -- number of bound locals in a FOREACH call
↓LOCALCOUNT: 0

;LOCBEG -- QTAK descriptor into LOCST's QSTACK for FRCHGO call --
;    first collects local names, then puts them out after call
;    see FTRPRM for similar mechanism
↓LOCBEG: 0

;LOCST -- the QPUSH/POP descriptor for the stack described above
;    in LOCBEG
↓LOCST:  0

↓MADEUPLOCALS:	0  ;TEMP IN BRACKETED TRIPLES CODE

;MKFLAG -- tells bracketed triple stuff it's inside a MAKE
↓MKFLAG: 0

;PARBEG -- a temporary pointer into LEABEG stack sometimes
↓PARBEG:  0

;PNBEG, PNLST, PNMSW -- temps for PNAMES stuff in compiler
↑↑PNBEG: 0		;QTAK pointer for PNLST
↑↑PNLST: 0		;qstack for printnames
↑↑PNMSW: 0		;non-zero if pnames required
;ITMSTK - Q-STACK FOR ITEM#'S,TYPES,ITMBEG,ITMCNT ALSO  ASSOC.
↑↑ITMSTK:	0	;QSTACK containing item-type,,item
↑↑ITMBEG:	0	;QTAK pointer for ITMSTK
↑↑ITMCNT:	0	;count of all items including GLOBALS
;HOLDPT - CROCK FOR REFERENCE LIST PARAMS. TO LEAP
;LORSET - QSTACK, TOP ELEM.INDICATES IF MAKING LIST OR SET see sip
;REMASET: FLAG ON IF REMOVE ALL CONSTRUCT
↑↑HOLDPT: 0
↑↑LORSET: 0
↑↑REMASET: 0
PHIBLK:	0				;DUMMY SEMANTIC BLOCK FOR SETS ON STACK
NILBLK: 0				;DUMMY SEMANTIC BLOCK FOR LISTS ON STACK
↑↑REMCEL: 0				;SAVE ROUTINE NAME REMEMBER,FORGET RESTORE

;NEDPOP - FLAG -1 IF SOME SEARCH (WITHIN FOREACH) HAS POSSIBLY VOIDED THE CURREN
;SATISFIERS IN CORE
NEDPOP: 0

ENDDATA

DSCR LEPINI
CAL PUSHJ FROM GENINI
DES SETS UP ALL LEAP-SPECIFIC VARIABLES BEFORE EACH COMPILATION
⊗

DEFINE NAMEIT(NAME,TYPE,ITNO) <
	HRROI   TEMP,NAME+1
	POP	TEMP,PNAME+1
	POP	TEMP,PNAME
	MOVEWI	(BITS,TYPE)
	MOVE	LPSA,SYMTAB
	PUSHJ	P,SHASH
	PUSHJ	P,ENTERS
	MOVE	PNT,NEWSYM
IFDIF <ITNO><>,<
	PUSH	P,PNT
	MOVEI	A,ITNO
	PUSHJ	P,CREINT
	POP	P,LPSA
	HRRZM	PNT,$VAL2(LPSA)
	>
>

;PREDECLARED ITEM NAMES

UBNAME: XWD	0,7
	POINT	7,.+1
	ASCII	/UNBOUND/
MINAME: XWD	0,6
	POINT	7,.+1
	ASCII	/MAINPI/
NINAME:	XWD	0,3
	POINT	7,.+1
	ASCII	/NIC/
EVNAME: XWD	0,6
	POINT	7,.+1
	ASCII	/EVTYPI/

↑↑LEPINI:
	QPUSH	(LOCST)
	QPOP	(LOCST)
	MOVE	A,LOCST
	MOVEM	A,LOCBEG
	MOVEI	A,LEABEG-1
	MOVEM	A,LEAPSK
	MOVEI	A,10
	MOVEM	A,ITEMNO	;LEAVE SOME FOR LEAP TO PLAY WITH.
GAG <
	MOVEI	A,100
	MOVEM	A,ITEMNO-SPCDAT+WOMSPC
↑↑M:				;;;DUMMY FOR PROCEDURE M.
>;GAG
GLOC <
	MOVEI	A,7777		;MAXIMUM GLOBAL ITEM
	MOVEM	A,GITEMNO	;AND RECORD IT.
GAG <
	MOVEI	A,7777-100
	MOVEM	A,GITEMNO-SPCDAT+WOMSPC	;IN SPACE ALLOCATION PLACE.
>;GAG
>;GLOC
	QPUSH	(MPSTAK,[0])
	QPUSH	(ITMSTK)
	QPOP	(ITMSTK)
	MOVE	A,ITMSTK
	MOVEM	A,ITMBEG		;SAVE FOR USING QTAKE
	QPUSH	(MPQSTK,[0])
	MOVE	A,MPQSTK
	MOVEM	A,MPQBEG
	GETBLK	(PHIBLK)
	MOVEI	A,SET
	MOVEM	A,$TBITS(LPSA)		;DUMMY SEMANTIC BLOCK FOR PHI(NULL SET)
	GETBLK  (NILBLK)
	MOVEI	A,SET!LSTBIT
	MOVEM	A,$TBITS(LPSA)
	POPJ	P,
↑↑LPNAME:NAMEIT  (UBNAME,ITEM,0)		;DECLARE PREDECLARED IDENTIFIERS
	NAMEIT	(MINAME,ITEM,MAINPI)
	NAMEIT	(NINAME,ITEM,NIC)
	NAMEIT	(EVNAME,ITEM,EVTYPI)
	POPJ	P,

DSCR LEAPC1, LEAPC2
PRO LEAPC1 LEAPC2
	These routines are called by the LPCALL macro to generate the
	call to LEAP. Both use left half of BYTES to form control
	bits for flag word. LEAPC2 also adds right half of BYTES
	to routine dispatch number.
PAR     A contains the dispatch number  of routine to be called.
⊗
↑LEAPC2:				;LEAP CALL OF FIRST VARIETY.
	ADD	A,BYTES			;USES INDICES COMPUTED BY STCHK
	SKIPA
↑LEAPC1:
	HLL	A,BYTES			;JUST THE TYPES COMPUTED BY STCHK.
	SETOM	LEAPIS			;SOMEONE USED LEAP.
	PUSH	P,LPSA			;
	PUSH	P,TBITS			;SO CAN RESTORE LATER
	PUSH	P,SBITS
	PUSH	P,PNT
	PUSH	P,D
	PUSH	P,A
	PUSHJ	P,ALLSTO		;SO LEAP DOESN'T HAVE TO SAVE.
GAG <
	MOVEI	LPSA,2			;INSURE 2 WORDS.
	PUSHJ	P,TWOOUT
>;GAG
	POP	P,A
GLOC <
	TRZN	A,400000		;LEGAL GLOBAL OPERATION
	JRST	NGLBOP			;NO.
	PUSH	P,A			;SAVE OVER QSTAK STUFF.
	QPOP	(GLBSTK)
	MOVE	B,A
	POP	P,A
	CAIE	B,0
	TLO	A,GLBSRC
NGLBOP:	
>;GLOC
	PUSHJ	P,CREINT		;AN INTEGER CONSTANT
	EMIT	<MOVE 5,NOUSAC>		;LOAD FLAG WITH CONTROL BITS, ROUTINE NAME
	SETZM	BYTES			;FOR NEXT TIME
	XCALL	(LEAP)
	POP	P,D
	POP	P,PNT			;RESTORE 
	POP	P,SBITS
	POP	P,TBITS
	POP 	P,LPSA
	POPJ	P,			;EXIT

DSCR STSET
PRO STSET
	STSET, STITM exec routines called whenever a set or item is scanned.
	Stacks entry onto LEAPSK and generates actual stack for previous top
	of LEAPSK if any unless within foreach statement.
⊗

↑STSET: ↑STITM:				;CALLE EACH TIME A SET OR ITEM IS SCANNED
	GETSEM	(1)			;SEMANTICS OF ITEM OR SET
	TLNE	FF,LPPROG		;A FOREACH IN PROGRESS?
	JRST	JUSTAK			;YES -- DO NOT STACK ON RUNTIME STACK
	PUSH	P,PNT
	MOVE	D,LEAPSK
	CAIL	D,LEABEG
	PUSHJ	P,STAKIT		;STACK THE PREVIOUS THING.
	POP	P,PNT
	PUSHJ	P,GETAD
	TLNE	SBITS,LPFREE		;NOT FREE NOW, IS IT?
	ERR	<FREE ITEMVAR IN BAD SPOT>,1

JUSTAK:	HRRZI	A,(PNT)
	TLO	A,FIXED!RETRV!CNSTR	;TURN ALL THESE ON INITIALLY.
	TLNE	SBITS,LPFRCH!FREEBD	;A LOCAL IN THIS FOREACH?
	TLC	A,BOUND!FIXED		;SAY BOUND ∧ ¬FIXED.
	TLNE	SBITS,LPFREE		;A FREE LOCAL?
	TLC	A,BOUND!BINDING		;SAY  BINDING ∧ ¬BOUND
;FOLLOWING INSTRUCTION REMOVED SO THAT MATCHING PROCEDURES MAY KNOW IF
;THERE PARAMS ARE UNBOUND (LPFREE ON);
;THE CODE IN STCHK HAS BEEN ALTERED ACCORDINGLY
;	MOVEM	SBITS,$SBITS(PNT)	;IN CASE IT WAS CHANGED.
	TLNE	SBITS,LPFREE
	TLNN	SBITS,FREEBD		;A ? LOCAL
	SKIPA
	TLZ	A,BOUND!BINDING		;A FREE ? LOCAL IS NEITHER BOUND NOR BINDING
	TRNE	TBITS,ITEM!ITMVAR	;WHICH LEAP TYPE?
	JRST	[TLO	A,LPITM			;AN ITEM
		 JRST TYPKWN]
	TLC	A,LPSET!FIXED		;A SET.
	TRNE	TBITS,LSTBIT					
	TLO	A,LPXISX		;A LIST

TYPKWN:	AOS	B,LEAPSK		;INCREMENT STACK POINTER.
	CAIL	B,LEABEG+MAXLOC	;GONE TOO FAR?
	ERR	<LEAP PUSH-DOWN OVERFLOW>,1
	MOVEM	A,(B)			;STORE THE ENTRY.
; THE FOLLOWING HACK IS TO ALLOW COMPLICATED SET OR LIST EXPRESSIONS TO
; BE ARGUMENTS TO NEW. SINCE NEW GETS TYPE OF EXPRESSION FROM PARSE STACK
	TLNE	SBITS,INUSE		;IF NOT A TEMP DON'T BOTHER
	TRNE	TBITS,ITEM!ITMVAR	;IF ITEM DON'T BOTHER
	POPJ	P,
	MOVE	A,PHIBLK		;ASSUME SET
	TRNE	TBITS,LSTBIT
	MOVE	A,NILBLK		;DUMMY LIST SEMBLK
	MOVEM	A,GENRIG+1		;NEW PARSE STACK ENTRY
	POPJ	P,

COMMENT @
HERE ARE THE PEOPLE WHO LOOK AT THE COMPILE TIME STACK.

LASCHK	-- MAKES SURE THAT TOP OF COMPILE STACK IS REALLY
	 STACKED -- THIS IS FOR CASE STATEMENTS,EXPR. CONDITIONALS. ETC.
STCHK	-- GUARANTEES THAT N (PASSED IN D) ARGUMENTS ARE IN THE RIGHT
	ORDER ON THE RUNTIME STACK.  THIS IS ONLY COMPLICATED WHEN
	PARSING A FOREACH LIST, SINCE THIS IS THE ONLY CIRCUMSTANCE
	IN WHICH REAL STACKING IS DEFERED.

	THE REASON REAL STACKING IS DEFERRED DURING FOREACH LISTS IS
	THE FOLLOWING:

FOREACH X,Y,Z |  A⊗X≡[B⊗Y≡Z] DO  .....

GETS CHANGED INTO --

FOREACH X,Y,Z | [B⊗Y≡Z]=Q AND A⊗X≡Q DO .....


WITH THE PARTICULAR FORM OF INTERPRETER DESIGNED FOR THESE THINGS,
THERE CAN BE NOTHING REMEMBERED IN THE STACK OVER
A SEARCH OPERATION (E.G. OVER THE "AND" IN THE REARRANGED EXAMPLE ABOVE.


@

OKSTACK: MOVE 	D,LEAPSK	;CHECK TO SEE IF TOP OF STACK
	CAIL	D,LEABEG	;IS REALLY STACKED.
	 JRST	 STAKIT
	POPJ	P,

;; #JO# BY JRL 10-8-72 ROUTINE TO TAKE AE TO EITHER IP OR SP
↑LTYPCK:			;MAKE AE GO TO EITHER SP OR IP
	MOVE	A,@LEAPSK	;TOP OF STACK ENTRY
	MOVE	B,%NIP		;ASSUME ITEM
	TLNN	A,LPSET!LPXISX	;LIST OR SET?
	MOVE	B,%NSP		;YES
	MOVEM	B,PARRIG+1	;INTO PARSE STACK
	POPJ	P,
;; #JO#


↑BNDITM:
	PUSHJ	P,OKSTACK		;MAKE SURE ITS STACKED
	SOS	B,LEAPSK	;TOP OF STACK
	CAIE	B,LEABEG-1	;MAKE SURE WAS ONLY 1 ITEM
	ERR	<MUST BE ITEM EXPRESSION>
	MOVE	A,1(B)		;OLD TOP OF STACK
	TLNN	A,LPITM		;TEST IF REALLY ITEM
	ERR	<BNDITM- ASSOC EXPR MUST BE ITEM>,1
	POPJ	P,

↑BNDLST:
	PUSHJ	P,OKSTACK
	SOS	B,LEAPSK	;TOP OF STACK
	CAIE	B,LEABEG-1	;MAKE SURE ONLY SINGLE LIST
	ERR	<MUST BE LIST EXPRESSION>,1
	MOVE	A,1(B)		;OLD TOP OF STACK
	TLNN	A,LPSET
	ERR	<EVAL REQUIRES LIST EXPRESSION>,1
	POPJ	P,


LASCHK:	MOVE	D,LEAPSK		;CURRENT TOP OF STACK.
	PUSHJ	P,STAKIT		;MAKE SURE THAT IT IS STACKED.
	PUSH	P,[1]			;ONE PARAMETER.
	MOVE	A,LEAPSK
	MOVEM	A,PARBEG		;ONE PARAMETER.
	JRST	POP0			;GO DO THE STUFF ON 
					;THE COMPILE-TIME STACK.
STCHK:	PUSH	P,D			;SAVE NUMBER OF PARAMS TO CHECK.
	MOVMS	D
	MOVNI	D,-1(D)			;NUMBER OF PARAMETERS -1
	ADD	D,LEAPSK		;TO GET BEGINNING.
	MOVEM	D,PARBEG		;THE FIRST PARAMETER.
	TLNE	FF,LPPROG		;MAKES A BIG DIFFERENCE.
	JRST	LPCHK			;ALAS, YES.

	MOVE	D,LEAPSK
	PUSH	P,PNT			;STAKIT WILL DESTROY
	PUSHJ	P,STAKIT		;STACK THE LAST THING.
	POP	P,PNT			;RESTORE IT
POP0:	MOVE	D,PARBEG		;THE FIRST PARAMETER
	MOVE	SBITS2,LEAPSK		;THE LAST PARAMETER.
	SETOM	B
	SETZM	TBITS2			;THE BITS FOR THE CONTROL WORD.
	MOVE	PNT2,[POINT 3,TBITS2,8]	;TO GET ATTPOS ON AN IDPB....
POP1:	CAILE	D,(SBITS2)		;DONE?
	JRST	POP1B			;YES
	MOVE	A,(D)			;TOP OF STACK.
	HLRZ	C,A			;GET LEFT HALF BITS.
	IDPB	C,PNT2			;STORE THE THREE BITS AWAY IN "BYTES"
	MOVE	C,B			;RECORD OF LAST TOP ELEMENT.
	MOVE	B,A			;THIS ELEMENT.
	AND	A,C			;AND CREATE THE HAVOC EVERYONE WANTS.
					;ACTUALLY THIS KEEPS TRACK 
					;OF CNSTR,RETRV, ETC.
	TRZ	A,-1			;NOTHING THERE.
	SOS	ADEPTH			;SINCE THIS IS A PARAMETER,
					; IT WILL DISAPPEAR
	SOS	LEAPSK			;DECREMENT STACK POINTER.
	TLNN	A,RETRV!CNSTR		;HAD BETTER BE ONE OR THE OTHER.
	ERR	<RETRIEVAL - CONSTRUCTION FAILURE>,1
					;SIGNAL RETRIEVAL-CONSTR. FAILURE
	AOJA	D,POP1			;LOOP UNTIL ALL PARAMETERS DONE.
POP1B:	TLNE	TBITS2,BINDING⊗ATTPOS
	TRO	TBITS2,1		;START TO MAKE UP AN INCREMENT.
	TLNE	TBITS2,BINDING⊗OBJPOS
	TRO	TBITS2,2
	TLNE	TBITS2,BINDING⊗VALPOS
	TRO	TBITS2,4
	TLNN	FF,LPPROG		;ONLY RECORD LEFT HALF IF FOREACH.
	TLZ	TBITS2,444		;THIS IS THE "BOUND" BITS EVERYWHERE.
	MOVEM	TBITS2,BYTES		;AND THE RESULTS.
	POP	P,D
	JUMPGE	D,CPOPJ		

	AOS	LEAPSK
	MOVEM	A,@LEAPSK
	AOS	ADEPTH			;THIS IS NOT A PARAM YET....
	POPJ	P,



LPCHK:	CAIN	D,LEABEG		;THE END OF THE LEAP STACK?
	JRST	GOODY			;YES -- EVERYTHING IS MUCH SIMPLER.

	MOVEI	D,LEABEG		;PREPARE TO RAMBLE THROUGH.
POP3:	CAMN	D,PARBEG		;ARE WE UP TO THE PARAMETERS YET
	JRST	GOODY			;YES -- WITHOUT A HITCH.
	MOVE	A,(D)			;PICK UP STACK ELEMENT.
	TLNN	A,STACKET		;IS IT REALLY STACKED ?
	AOJA	D,POP3			;LOOP -- NO
	MOVE	D,LEAPSK		;TROUBLE -- GET TOP OF STACK.
POP4:	CAIL	D,LEABEG		;LOOP UNTIL ALL ARE POPPED.
	JRST	POP8			;ALL DONE -- NOW STACK BACK ON.!!
	PUSH	P,POPEND		;IN LINE CALL.
POPIT:	MOVE	A,(D)			;STACK ELEMENT
	TLZN	A,STACKET		;ON STACK ?
	POPJ	P,			;NO
	PUSH	P,A
	PUSHJ	P,GETCRTMP		;GET A TEMP.
	MOVEI	PNT,(LPSA)		;SINCE GETCRTMP RETURNS ANSWER IN LPSA.
	EMIT	(<POP RP,NOUSAC>)
	SOS	ADEPTH			;WE HAVE POPPED.
	POP	P,A
	HRRI	A,(PNT)			;POINTER TO TEMP.
	MOVEM	A,(D)		;SAVE BACK ON STACK.
POPEND:	POPJ	P,.+1
	SOJA	D,POP4			;LOOP UNTIL DONE.


GOODY:	MOVE	D,PARBEG		;HERE WHEN STACK BEHIND 
					;PARBEG IS IN GOOD
	ADDI	D,1			;SHAPE....
G2:	CAMLE	D,LEAPSK		;ALL DONE?
	JRST	POP8			;YES ...
	MOVE	C,@PARBEG		;THE FIRST PARAMETER.
	XOR	C,(D)			;XOR WITH THE CURRENT PARAMETER.
	TLNN	C,STACKET		;ARE THEY STACKED DIFFERENTLY?
	AOJA	D,G2			;NO -- LOOP
	MOVE	D,LEAPSK		;TROUBLE -- GO THROUGH AND POP.
G1:	CAMGE	D,PARBEG
	JRST	POP8			;ALL DONE
	PUSHJ	P,POPIT			;DO THE POPS
	SOJA	D,G1


POP8:	MOVE	D,PARBEG		;WHERE IT ALL BEGINS.
	HRRI	C,(BINDING!BOUND)⊗ATTPOS
	MOVEM	C,BBWORD		;INITIAL BINDING BITS WILL RIGHT SHIFT
					;EACH TIME THROUGH LOOP
	MOVEI	C,1			;INITIAL DISPATCH INCREMENT
	MOVEM	C,INDEX4
	JRST	POP9
POP90:	MOVE	C,BBWORD
	LSH	C,-3
	MOVEM	C,BBWORD
	MOVE	C,INDEX4
	LSH	C,1
	MOVEM	C,INDEX4
POP9:	CAMLE	D,LEAPSK		;ALL DONE?
	JRST	POP0			;YES -- GO JUSTIFY COMPILE TIME STACK.
	PUSH	P,POPRET		;IN LINE CALL.
STAKIT:	MOVE	PNT,(D)			;GET STACK ELEMENT.
	TLOE	PNT,STACKET		;ALREADY STACKED?
POPRET:	POPJ	P,POP11			;DONE.
	MOVEM	PNT,(D)
	PUSH	P,POPAA			;IN LINE CALL.
PREPAR:	PUSHJ	P,GETAD		;GET GOOD BITS.
	TLZ	SBITS,LPFREE		;A FREE LOCAL?
	TLNN	SBITS,FREEBD		;DON'T SAVE YET IF FREEBD
	MOVEM	SBITS,$SBITS(PNT)	;NO LONGER FREE
	TRNE	TBITS,ITEM
	TLNE	TBITS,FORMAL!SBSCRP
	JRST	[TRNE TBITS,ITMVAR
		 TLNN SBITS,LPFRCH!FREEBD
		 JRST NONEW
		 TLNE FF,LPPROG		;ONLY GET LOCAL NUMBER IF FOREACH
		 JRST NEWSS		;IN PROGRESS
		 JRST NONEW]
NEWSS:
	HRR	PNT,$VAL2(PNT)		;THE POINTER TO ITEM NUMBER
					;OR LOCAL NUMBER......
	PUSHJ	P,GETAD
NONEW:
	SETZM	A
	TLNE	PNT,LPDMY
	HRRZ	A,(D)			; A MADE UP NUMBER.
	TLNE	PNT,LPDMY!LPNUL
	PUSHJ	P,CREINT
POP10:	GENMOV	(ACCESS,0)			;STACK THE THINGS.
POPAA:	POPJ	P,.+1
	GENMOV	(STACK,0)		;WILL CAUSE REMOP TOO.
	POPJ	P,
POP11:	MOVE	PNT,(D)			;GET ITEMVAR SEMBLK BACK
	MOVE	SBITS,$SBITS(PNT)	;GET SBITS BACK
	TLZN	SBITS,LPFREE		;IF STILL FREE MUST BE FREEBD
	AOJA	D,POP90			;LOOP BACK
	MOVEM	SBITS,$SBITS(PNT)	;NO LONGER FREE
	TLNN	SBITS,FREEBD
	ERR	<DRYROT - POP11>
	HRL	A,BBWORD
	HRR	A,INDEX4
	PUSHJ	P,CREINT
	GENMOV	(STACK,0)		;STACK BINDING BITS,DISPATCH INCREMENT
	SOS	ADEPTH			;THIS WILL GO AWAY IMMEDIATELY
	PUSH	P,BYTES			;PROTEXT BYTES OVER LPCALL
	LPCALL  (STK4VL)		;STACK VAL OR LOCAL NUMBER
	POP	P,BYTES			;RESTORE BYTES
	AOJA	D,POP90			;LOOP BACK

CHKSET:					;CHECK IF PARAMETERS SETS
	MOVE	C,LEAPSK		;TOP ELEM. OF STACK
	HRLZI	A,LPXISX		;BIT WE'RE LOOKING FOR
CHKSLP:	TDNE	A,(C)			;A LIST?
	ERR	<ERROR - ILLEGAL LIST OPERATION>,1
	SUBI	C,1
	SOJG	D,CHKSLP
	POPJ	P,			;RETURN ALL O.K.
DSCR CHKSAT -
	check to see if we have to pop satisfiers into core within
	associative context of FOREACH
⊗
↑↑CHKSAT:				;
	SKIPN 	NEDPOP			;DO WE NEED IT;
	POPJ	P,
	SETZM	NEDPOP			;DON'T NEED IT NOW
	LPCALL	(FRCHPOP)
	POPJ	P,

;FOREACH STATEMENT HANDLERS.
DSCR FRCHGO, ENTITV, BOPREP, FRBOL, STSRC, BTRIP, DERIV, etc.
PRO FRCHGO ENTITV BOPREP FRBOL STSRC FID1 FRCH1 FRCH2 BTRIP DERIV
⊗
COMMENT ⊗
	THE FIRST THING WE DO IS CAUSE THE ADDRESS OF THE SCB POINTER
	VARIABLE TO BE STACKED. WE THEN CAUSE THE LOADING OF TAC1 WITH
	THE ADDRESS OF THE SATISFIER BLOCK CONTAINING:
	1. A JRST TO THE END (OUTSIDE) OF THE LOOP.
	2. THE NUMBER OF LOCAL ITEMVARS SPECIFIED IN THE SEARCH.
	3. THE ADDRESSES (1 BY 1) OF ALL THE LOCAL ITEMVARS.
		THUS, IF A LOCAL IS REFERED TO BY NUMBER (SAY 3)
		ITS CORE STORAGE ADDRESS CAN BE FOUND BY LOOKING
		IN THE THIRD ENTRY IN THIS LIST
	We then emit the call to start leap up, followed by a jump
	around the  satisfier block followed by the satisfier block
	itself (see above);
⊗

SCBNAM: XWD 0,6				;every scb variable has the same name
        POINT 7,.+1
        ASCII /SCB.../
↑EACH4:					;DECLARE SCB VARIABLE
	NAMEIT	(SCBNAM,<INTEGR!FLOTNG>)
	PUSHJ	P,GETAD
	EMIT	<MOVEI TAC1,NOUSAC>
	HRLZI	C,14			;ADDR IS 14
	EMIT	<PUSH P,NOUSAC!USADDR!NORLC!NOADDR>
	POPJ	P,
↑FRCHGO:
	SETZM	NEDPOP			;DON'T NEED POP YET
	PUSHJ	P,FRCHT			;IN FOR LOOP DOMAIN -- 
					;MAKE A BLOCK. ETC.
	MOVEI	B,$DATA(LPSA)		;PLACE TO PUT FIXUP FOR JUMP OUT.
	TLO	FF,LPPROG		;LEAP IN PROGRESS.
GAG <
	MOVE	LPSA,LOCALCOUNT		;NEED LOTS OF CONTIG. CORE.
	ADDI	LPSA,5
	PUSHJ	P,TWOOUT
>;GAG
	MOVE	C,PCNT			;CALC. ADDR OF SATISFIER BLOCK
; ##HR## JRL 6-20-72 USE FIXUP RATHER THAT RELATIVE ADDR. SO NEEDNEXT OK
	MOVEM	C,SATADR		;FOR FIXUP LATER
	EMIT	<MOVEI TAC1,NORLC!NOADDR!NOUSAC> ;LOAD ADDRESS OF SATIS BLOCK
; ##HR##
	LPCALL	(FRCHGO)		;CALL TO SET UP FOREACH SEARCH.
	MOVE	C,PCNT			;CALC. ADDRESS FOR JUMP OVER SATIS BLOCK
	ADD	C,LOCALCOUNT		;ONE WORD PER LOCAL
	ADDI	C,3			;FOR JRST AND COUNT OF LOCALS
	MOVSI	C,(C)			;PREPARE FOR EMIT
	EMIT	<JRST ,	USADDR!NOUSAC>  ;JRST AROUND SATIS BLOCK
;NOW GENERATE SATISFIER BLOCK
	HRLZ	PNT2,PCNT
	MOVEM	PNT2,(B)		;FIXUP FOR JUMP OUT.
;;  #HR# USE FIXUP 
	HRR	PNT2,SATADR		;PLACE TO FIXUP
	MOVS	B,PNT2
	PUSHJ	P,FBOUT			;FIXUP MOVEI 14,
;; #HR#
	EMIT	(<JRST NOUSAC!NOADDR>)	;WHERE TO GO WHEN DONE.
	HRL	C,LOCALCOUNT
	EMIT	(<NOUSAC!NORLC!USADDR>)	;COUNT OF LOCALS.
	MOVE	B,LOCBEG		;THE POINTER FOR QTAK
ANO:	QTAKE	(LOCST)			;GET FIRST LOCAL.
	POPJ	P,			;ALL DONE.
	MOVE	PNT,A
	PUSHJ	P,GETAD			;GET SEMANTICS
	MOVEI	A,0			;COLLECT BITS FOR LEFT HALF
	TLNE	TBITS,MPBIND		; A ? PARAMETER
	TRO	A,MPPAR			;YES
	TLNE	SBITS,FREEBD		;POTENTIALLY UNBOUND?
	TRO	A,POTUNB		;YES
	TRNN	SBITS,DLFLDM		;A DISPLAY TYPE THING?
	JRST	SIMITM			;NO.
	LDB	TEMP,[LEVPOINT <SBITS>]
	CAMN	TEMP,CDLEV		;SAME DISPLAY LEVEL?
	JRST	SIMITM			;YES, SIMPLE CASE AGAIN
	TRO	A,CDISP			;THIS IS A DISPLAY TYPE THING
	SUB	TEMP,CDLEV		;CALCULATE DISPLAY DIFFERENCE
	MOVMS	TEMP
	IORI	A,(TEMP)		;PUT INTO INDEX FIELD
	TLNE	TBITS,REFRNC		;A REFERENCE PARAMETER?
	TRO	A,20			;PUT ON INDIRECT BIT
	HRLI	A,JSFIX!NOUSAC		;BITS FOR EMITER
	TLNN	TBITS,REFRNC!VALUE	;A FORMAL PARAMETER?
	JRST	SIMITM+1		;NO.
	HRRZ	TEMP,$ADR(PNT)		;STACK DISPLACEMENT
	MOVN	TEMP,TEMP		;NEGATE
	SUBI	TEMP,1			;FOR RETURN ADDR
	HRL	C,TEMP
	HRLI	A,USADDR!NOUSAC!NORLC
	JRST	.+2
SIMITM:	HRLI	A,NOUSAC		;STANDARD CASE
	MOVSS	A			;RIGHT IS LEFT AND VICE VERSA
	PUSHJ	P,EMITER
	JRST	ANO			;LOOP UNTIL DONE.


↑ENTITV:				;RECORD THE NAME OF A LOCAL.
	GETSEM	(1)		;SEMANTICS OF ITMVAR.
	MOVE	PNT2,PNT
	TLNE	SBITS,LPFREE
	ERR	<SAME LOCAL APPEARS MORE THAN ONCE IN BINDING LIST>,1
	TLO	SBITS,LPFREE!LPFRCH	;TURN ON.
	TLNE	SBITS,FREEBD		;A ? LOCAL
	TLZ	SBITS,LPFRCH		;YES
	MOVEM	SBITS,$SBITS(PNT)	;IN MEMEORY
	AOS	A,LOCALCOUNT
	CAILE	A,MAXLOC
	ERR	<TOO MANY LOCALS IN FOREACH LIST>,1
	PUSHJ	P,CREINT		;MAKE AN INTEGER.
	MOVEM	PNT,$VAL2(PNT2)		;SAVE FOR FUTURE GENERATIONS.
	QPUSH	(LOCST,GENLEF+1)	;SAVE FOR END.
	POPJ	P,


↑BOPREP:			;PREPARE FOR BOOLEAN INSIDE A FOREACH SPEC.
	PUSHJ	P,CHKSAT	;UPDATE CORE LOCATIONS IF NECESSARY
	TLZ	FF,LPPROG	;TURN OFF THE "LEAP" BIT.
	POPJ	P,


↑FRBOL:				;BOOLEAN DONE INSIDE FOREACH LIST.
	PUSH	P,PCNT		; SAVE PCNT
	PUSHJ	P,ALLSTO	;CLEAR ALL AC'S
	POP	P,A
	CAME	A,PCNT		;SHOULD BE THE SAME
	ERR	<DRYROT-AT LEAP:FRBOL>,1
	PUSHJ	P,BONOT		;TO JUMP ON TRUE
	PUSHJ	P,STIF		;GO GENERATE CODE.
;	LPCALL	(FRTRU)		;FOREACH TRUE HANDLER.
; WE WILL NOW SIMPLY GEN JRST	; (WILL SKIP OVER THE "FALSE" CALL FOLLOWING)
	LPCALL	(FRFAL)		;FOREACH FALSE HANDLER.
	HRR	B,PCNT
	HLL	B,GENRIG	;FIXUP FOR FALSE PART.
	JUMPL	B,.+2		;If BE evaluates to FALSE no JRST TRUE
	PUSHJ	P,FBOUT
	SETOM	GENRIG		;FOR THE FOREACH GUY TO NOTICE THAT CODE HAS GONE OUT.
	TLO	FF,LPPROG		;TURN IT BACK ON.
	POPJ	P,

↑STSRC:				;FOREACH SPEC. OF FORM  " X IN SET "
	MOVE	A,@LEAPSK	;SEE IF DUMMY ITEM(FROM DERIVED SETS)
	TLNE	A,LPDMY
	ERR	<DERIVED SET WITHIN FOREACH WILL DO WRONG THING>,1
	STAKCHECK (2)		;TWO ARGS.
	RETCHK			;RETRIEVAL TYPES NECESSARY
	MOVSI	A,SETOP		;TELL FOREACH
	IORM	A,BYTES
	LPCALL	(STSRC,,BYTES)	;CALL FOR SEARCH.
	SETOM	NEDPOP		;NEED POP INTO CORE
	SETOM	GENRIG+1	;CODE GONE OUT.
	POPJ	P,
↑FID1:				;TO SAY NO CODE GONE.
	SETZM	GENRIG+1
	POPJ	P,

↑FRCH1:					;GENERAL SEARCH X⊗Y≡Z
	SKIPE	GENLEF+1		;HAS CODE GONE OUT?
	POPJ	P,			;YES -- WAS A SET SEARCH.
	STAKCHECK (3)			;THREE ARGUMENTS.
					;STCHK COMPUTES THE DIRECTIVE BITS
					;(IN "BYTES" TO TELL LEAP INTERPRETER
					;WHICH THINGS ARE BOUND, FREE, ETC.)
	RETCHK				;RETRIEVAL TYPES NECESSARY
	LPCALL	(TRIPLES,,BYTES)	;AIN'T THAT SIMPLE.
	SETOM	NEDPOP			;NEED TO POP
	POPJ	P,

↑FRCH2:					;LAST SEARCH SPEC. IN THE FOREACH LIST.
	PUSHJ	P,FRCH1			;FOR THE LAST TRIPLE.
	MOVE	A,FRBLK			;SAVE SEMANTICS OF ASSDO
	MOVEM	A,GENRIG
	PUSHJ	P,CHKSAT		;CALL TO PUT SATISFIERS DOWN IN CORE.
	MOVE	SP,LOCALCOUNT		;GET READY TO PROCESS LOCALS.
LGO:	QPOP	(LOCST)			;ET TOP ONE
	MOVE	SBITS,$SBITS(A)		;
	MOVE 	TBITS,$TBITS(A)
	MOVE	LPSA,A			;FOR THE ERROR HANDLER TO PRINT OUT.
	TLZE	SBITS,LPFRCH!FREEBD	;NO LONGER IN A FOREACH.
	TLZE	SBITS,LPFREE
	ERR	<STRANGE USE OF LOCAL: >,3	;NEVER WAS CITED.
	MOVEM	SBITS,$SBITS(A)
	SOJG	SP,LGO

	SETZM	LOCALCOUNT	;RESTART THE COUNT FOR NEXT TIME.
	SETZM	MADEUPLOCALS	;DITTO.
	TLZ	FF,LPPROG		;AT LAST DONE.
	JRST	ENDFOR			;IN FOR LOOP CODE -- MAY PUT OUT
					;CALLS IF COROUTINES NEEDED.



↑BTRIP:					;BRACKETED TRIPLE.
	STAKCHECK	(3)		;3 PARAMS TO BRACKETED TRIPLE.
	TLNN	FF,LPPROG		;INSIDE FOREACH SEARCH
	JRST	NOFR			;NO
	AOS	A,MADEUPLOCALS		;MAKE A NEW "MADE UP" LOCAL.
	ADD	A,LOCALCOUNT
	PUSH	P,A			;"A" IS NEW LOCAL NUMBER.
	PUSHJ	P,CREINT		;MAKE AN INTEGER
	EMIT	(<PUSH	RP,NOUSAC>)	;AND GIVE THE NUMBER.
	MOVSI	B,BRACKET
	IORM	B,BYTES			;TO TELL THERUNTIMES.
	LPCALL	(TRIPLES,,BYTES)	;SEARCH FOR THE BRACKETED TRIPLE.
					;LEAP INTERP. WILL PUT ITEM # IN AS
					;SATISFIER OF THE MADEUP LOCAL.
	POP	P,A
	HRLI	A,LPDMY!LPITM!BOUND!RETRV ;NOW RECORD THE DUMMY LOCAL NUMBER.
	JRST	BFIN			;ALL DONE.



NOFR:	SKIPE	MKFLAG			;IN A MAKE STATEMENT?
	JRST	MKB			;YES
	RETCHK				;RETRIEVAL TYPES NECESSARY
	LPCALL	(BRTRIP,,BYTES)		;JUST LOOK FOR IT.
	HRLZI	A,LPITM!STACKET!RETRV	;RESULT IS AN ITEM.
	JRST	BFINA

MKB:	CONCHK				;CONSTRUCTION TYPES NECESSARY
	LPCALL	(BMAKE)			;CALL TO MAKE THE BRACKETED TRIPLE.
	HRLZI	A,LPITM!STACKET!CNSTR	;AND RESULT IS ITEM.

BFINA:	AOS	ADEPTH			;STACK HAS A RESULT ON IT.
BFIN:	AOS	B,LEAPSK		;PUT THIS BACK -- STCHK SOS'ED IT.
	MOVEM	A,(B)			;STORE THE NEW TOP OF STACK.
	POPJ	P,




↑DERIV:					;DERIVED SETS.
	PUSH	P,B			;PARSER INDEX OF TYPE.
	STAKCHECK (2)			;TWO PARAMETERS.
	MOVE	B,(P)			;GET THE PARSER INDEX.
	CAIN	B,2			;IF THIS KINDS
	ERR	<P * Q NOT IMPLEMENTED>,1
	MOVEI	A,BINDING
	DPB	A,[POINT 3,BYTES,17-VALPOS]
	CAIE	B,1			;THIS REQUIRES SOME FUNNINESS
	JRST	NOFUNQ			;SAFE.
	LDB	TEMP,[POINT 3,BYTES,17-OBJPOS];
	DPB	TEMP,[POINT 3,BYTES,17-VALPOS];COPY THESE.
	DPB	A,[POINT 3,BYTES,17-OBJPOS] ;NEW ITEMVAR.
NOFUNQ:
	TLNN	FF,LPPROG		;FOREACH GOING ?
	JRST 	NODRV			;NO
	AOS	A,MADEUPLOCALS		;MAKE UP A NEW LOCAL NUMBER.
	ADD	A,LOCALCOUNT
	PUSH	P,A
	PUSHJ	P,CREINT		;MAKE AN INTEGER FOR IT.
	EMIT	(<PUSH RP,NOUSAC>)	;PUSH ON STACK .
	LPCALL	(LDERIV,<-1(P)>)	;CALL SEARCHER.  WE HAVE ESSENTIALLY
					;TURNED A ⊗ ( C ⊗ D) ≡ X INTO
					;    C ⊗ D ≡ Y ∧ A ⊗ Y ≡ X
	POP	P,A
	HRLI	A,LPITM!LPDMY!BOUND!RETRV ;RESULT IS AN ITEM DUMMY NUMBER.
	POP	P,B
	JRST	BFIN

NODRV:	LPCALL	(DERIV,<(P)>)		;NOT INSIDE FOREACH -- JUST CALL IT.
	MOVE	A,PHIBLK		;DUMMY SET SEMBLK
;; #JN# BY JRL 10-8-72 FOLLOWING INSTR WAS TO GENRIG INSTEAD OF GENRIG+1
	MOVEM	A,GENRIG+1		;ONTO PARSE STACK
	HRLZI	A,LPSET!STACKET!RETRV	;RESULT IS A SET.
	POP	P,B
	JRST	BFINA
;DATUM HANDLERS
DSCR DDATA, LDATA
PRO DDATA LDATA
⊗
↑DDATA:
↑LDATA:	TLO	FF,FFTEMP	; GET ADDRESS OF DATUM ENTRY.
				;IF FFTEMP IS OFF, GET VALUE OF DATUM ENTRY.
	MOVEI	D,3		;THE RESULT IN THIS AC.
	PUSHJ	P,STORZ		;MAKE SURE IT IS SAFE.
	MOVE	PNT,@LEAPSK	;GET THE LAST THING PUT ON STACK.
	SOS	LEAPSK		;DECREMENT STACK COUNTER.
	TLNN	PNT,LPITM	;HAD BETTER HAVE ITEM
	ERR	<DATUM ONLY VALID FOR ITEM EXPR>,1
	SETZB	TBITS,SBITS	;ZERO THEM OUT
	TRNE	PNT,-1		;IF WE HAVE A SEMBLK
	PUSHJ	P,GETAD		;GET SEMANTICS OF ITEM.
	SKIPE	BITS		;FOR DATUM(IT,TYPE)
	MOVE	TBITS,BITS
	TLNE	SBITS,LPFREE
	ERR	<DATUM OF UNBOUND ITEMVAR WITHIN FOREACH>,1
	TLNE	FF,LPPROG	;CHECK TO SEE IF FOREACH GOING.
	TLNN	SBITS,LPFRCH!FREEBD;AND THIS THING IS ONE OF THE ITEMVARS.
	SKIPA			;NO -- OK
	JRST	[PUSHJ  P,CHKSAT
		 GENMOV	(GET,SPAC)
		 JRST GOTEN]
	TLNN	PNT,STACKET
	JRST	[PUSH	P,TBITS
		 PUSHJ	P,PREPAR	;PREPARE AN ITEM FOR CALL.
		 MOVE	TBITS,(P)
	 	 MOVE	A,[MOVE 0,0]
		 TLNE	TBITS,MPBIND	;A BINDING ITEMVAR?
		 MOVE	A, [MOVEI 0,@0]
		 PUSHJ  P,EMITER	;THIS WILL BE MOVEI 3,ITEM NUMBER.
		 POP	P,TBITS
		 JRST GOTEN]
	HRL	C,D		;AC NUMBER TO GET IT IN.
	EMIT	<POP RP,NOUSAC!NORLC!USADDR> ; IT WAS ON THE REAL STACK.
	SOS	ADEPTH		;AND BOOKKEEP THIS.
GOTEN:
	PUSHJ	P,REMOP		;REMOVE THE ITEM NUMBER.
	PUSHJ	P,GETAN0	;BUT GET ANOTHER AC FOR DATUM.
GLOC <
	QPOP	(GLBSTK)	;IF GLOBAL, THEN USE THE OTHER ONE.
	JUMPN  A,[HRLI	C,7776	;MAXIMUM ITEM.
		 EMIT	(<CAIG 3,NOUSAC!USADDR!NORLC>)
		 HRLI	C,6000	;GLOBAL BREAK
		 EMIT	(<CAIG 3,NOUSAC!USADDR!NORLC>)
		 XCALL	(DATERR)
GAG <
		 MOVSI	C,GDATM	;ADDRESS OF DATUM
>;GAG
NOGAG <
		 HRL	C,PCNT	;CHAIN INSTRUCTIONS.
		 EXCH	C,LIBTAB+RGDATM ;GLOBAL DATUM
>;NOGAG
		 JRST 	DATGO]
>;GLOC
NOGAG <
	HRL	C,PCNT
	EXCH	C,LIBTAB+RDATM	;WORD TO INDIRECT THROUGH.
>;NOGAG
GAG <
	HRLI	C,DATM
>;GAG
DATGO:	TRZN	TBITS,LPARRAY
	JRST	NORM		;ITEM TYPE IS NOT AN ARRAY.
;;#FN# DCS 2-6-72 (1-1) SAFE ... ARRAY ITEMVAR X -- X not treated as SAFE
	TLZ	TBITS,-1≠SAFE	;READY FOR NEW TEMP
	TLO	TBITS,SBSCRP	;NEW TEMP WILL BE ARRAY, NOT WITH OWN ON, ETC.
;;#FN#   Replace HRLI TBITS,SBSCRP
	TLZ	FF,FFTEMP	;BUT WE GET THE DESCRIPTOR.
	EMIT	(SKIPN @USADDR)
	XCALL	(LPRYER)	;GETTING AN ARRAY THAT DON'T EXIST.
	JRST	FINOUT

NORM:	MOVE	A,[MOVE @USADDR]	;INSTR. TO PICK UP VALUE.
	TLNE	FF,FFTEMP
	TLO	A,1000		;CHANGE IT TO A MOVEI.
	TRNE	TBITS,STRING	;STRING ITEM?
	HRLI	A,(<HRRO @>)	;HRRO INDIRECT
	PUSHJ	P,EMITER	;AND EMIT THE INSTRUCTION.
FINOUT:	TRZ	TBITS,ITEM!ITMVAR
	TRNN	TBITS,-1	;UNTYPED?
	ERR	(<UNTYPED ITEM OR ITEMVAR OUGHT TO BE TYPED.>,1)
	PUSHJ	P,TYPDEC	;TYPE THE NEW THINGS.
	MOVEM	A,PARRIG	;PARSE TYPE FOR THE PRODUCTION INTERPRETER.
	TLZ	TBITS,FORMAL	;RANDOM THINGS MAY BE ON......
	PUSH	P,PNT		;SAVE SEMANTICS OF THING POINTED DO.
	PUSH	P,TBITS		;BECAUSE MARK MASKS SOME THINGS.
	SETZB	TBITS,SBITS	;MAKE SURE WE MAKE AN ARITHMETIC TEMP....
	GENMOV	(MARK,0)	;MAKE A TEMP.
	HRROS	$ACNO(PNT)	;FOR ARRAYS $*$*$*$*$**$*$*$*$*$**$*
	POP	P,TBITS
	POP	P,TEMP
	TLNE	TBITS,SBSCRP	;IF AN ARRAY DATUM,
	MOVEM	TEMP,$VAL(PNT)	;SEE ARRY FOR THE PLACE THIS IS USED.
				;IT IS FOR MAKING A NAME FOR THE ARRAY ERROR UUO.
	MOVEM	TBITS,$TBITS(PNT)	;PUT DOWN THE REAL TYPES.
	TLNE	FF,FFTEMP
	TLC	SBITS,INAC!PTRAC!INDXED	;NORMAL CASE IS TO RETURN POINTER.
	MOVEM	SBITS,$SBITS(PNT)	;AND THE REAL SEMANTIC BITS.
	MOVEM	PNT,GENRIG	;TELL EVERYONE WHO OUGHT TO KNOW.
	POPJ	P,
; MAKE AND ERASE
DSCR MAKIT, ERAS, MKSET, MAK
PRO MAKIT ERAS MKSET MAK
⊗


↑MAKIT:	JUMPE	B,MAK
↑ERAS:
	STAKCHECK (3)		;THREE ARGUMENTS.
	RETCHK				;RETRIEVAL TYPES NECESSARY
	TLNN	A,LPITM		;ITEMS ONLY ?
	ERR	<MAKE AND ERASE DO NOT ACCEPT SET ARGUMENTS>,1
	LPCALL	(ERAS,,BYTES)	;ERASE CALL.
	POPJ	P,

↑MKSET:				;GO INTO MAKING MODE.
	SKIPN	B
	SETOM	MKFLAG
	POPJ	P,

↑MAK:				;MAKE AN ASSOCIATION.
	SETZM	MKFLAG
	STAKCHECK (3)		;THREE ARGUMENTS.
	CONCHK			;CONSTRUCTION TYPES NECESSARY
	LPCALL	(MAKE)		;DOIT.
	POPJ	P,
; VARIOUS BOOLEANS.
DSCR STIN, ISTRIP, ISIT, STREL
PRO STIN ISTRIP ISIT STREL
⊗
↑STIN:				; X IN SET ?
	STAKCHECK (2)		;TWO ARGUMETS.
	RETCHK			;RETRIEVAL TYPES NECESSARY
	XPREP
	LPCALL	(STIN)
	JRST	BLOOP		;FINISH OUT WITH JUMPE, ETC.


↑ISTRIP:			; IS X A BRACKETED TRIPLE ?
	STAKCHECK (1)
	XPREP
	LPCALL	(ISTRIP)	;CALL
	JRST	INTGO		;MARK AN INTEGER AND LET BOOP FIND IT.


↑ISIT:				;A ⊗ B ≡ C ?
	STAKCHECK (3)		;THREE ITEMS.
	RETCHK			;RETRIEVAL TYPES NECESSARY
	XPREP
	LPCALL	(ISIT,,BYTES)	;CALL.
	JRST	BLOOP

↑ITMREL:SOS	B,LEAPSK	;DEC LEAP STACK
	MOVE 	PNT,1(B)		;OLD TOP OF LEAP STACK
	TLNE	PNT,STACKED	;STACKED?
	JRST	POPIRL		;YES, WILL POP OFF
ITMRE2:	HRRZM	PNT,GENRIG+1	
	HRRZM	PNT,GENLEF+1	;BOTH PLACES
	POPJ	P,
POPIRL:	HRRI	FF,0		;DON'T NEED INDX OR DBL
	PUSHJ	P,GETAC		;GET AN AC
	HRLI	C,D		;THE AC NUMBER
	EMIT	<POP RP,NOUSAC!USADDR!NORLC>
	SOS	ADEPTH		;NO LONGER ON STACK
	HRRI	TBITS,ITMVAR
	PUSHJ	P,MARKME	;MARK AS ITEMVAR TEMP
	JRST	ITMRE2
↑STREL:				;RELATIONS ON LISTS, SETS AND ITEMS.
	CAIN	B,2		;=?
	JRST    SRELOK		;YES
	CAIN	B,3		;≠?
	JRST	SRELOK		;YES
	HRLZI	A,LPITM!LPXISX  ;INVALID TYPES FOR GTR. LE.
	MOVE	C,LEAPSK	;ADDR. TOP OF PSEUDO STACK
	TDNE	A,(C)		;O.K. RELATION
	JRST	RELERR		;NO.
	TDNN	A,-1(C)		;OTHER ARGUMENT SET?
	JRST	SRELOK		;YES, RELATION IS VALIED
RELERR:	ERR	<INVALID RELATION, CHANGED TO ≠>,1
	MOVEI	B,3		;≠
SRELOK:	PUSH	P,B		;TYPE OF RELATION.
	MOVE	A,@LEAPSK	;TOP OF LEAP STACK
	TLNN	A,LPITM		;AN ITEM?
	JRST	SREOK2		;NO.
	PUSHJ	P,ITMREL	;GET OFF OF LEAP STACK
	SKIPN	PNT,GENLEF+3
	ERR	<DRYROT AT LEAP:SRELOK>,1
	MOVE	TBITS,$TBITS(PNT) ;
	TRNN	TBITS,ITEM!ITMVAR
	ERR	<INVALID ITEM COMPARISON>,1
	TRNE	TBITS,ITEM	;AN ITEMVAR?
	TLNE	TBITS,FORMAL!SBSCRP
	JRST	STMREL
	HRRZ	PNT,$VAL2(PNT)	;GET CONSTANT SEMBLK
	JUMPN	PNT,STMREL
	ERR	<DRYROT AT LEAP:STMREL>
STMREL: MOVEM	PNT,GENLEF+3
	MOVE	PNT,GENLEF+1
	MOVE	TBITS,$TBITS(PNT)
	TRNE	TBITS,ITEM
	TLNE	TBITS,FORMAL!SBSCRP
	JRST	STMRE2
	HRRZ	PNT,$VAL2(PNT)
	MOVEM	PNT,GENLEF+1
STMRE2:
	POP	P,B		;RELATION TYPE
	JRST	IREL		;IN BOOLEAN CODE(EXPRS)
SREOK2:
	STAKCHECK (2)		;TWO ARGUMENTS.
	RETCHK			;RETRIEVAL TYPES NECESSARY
	XPREP
	TLNN	A,LPITM		;ITEMS?
	JRST	SETSES		;NO -- SETS.
	ERR	<INVALID ITEM COMPARISON>,1
;	LPCALL	(<ITMREL-2>,<(P)>)
	JRST	STFIN
SETSES:	TLNN	A,LPSET		;IS IT REALLY A SET.
	ERR	<NO MIXED RELATIONS, PLEASE>,1
	LPCALL	(SETREL,<(P)>)
STFIN:	POP	P,B
BLOOP:	GETBLK	GENRIG+1	;SIMULATE A BOOLEAN.
	MOVEM	LPSA,GENRIG
	PUSHJ	P,GOSTO
	EMIT	(<JUMPE NOADDR>)
	MOVE	A,[XWD 1,$VAL]
	JRST	BODON		;FINISH OUT WITH BOOLEANS.
DSCR DELT, SIPGO, STPRIM, ECVI, STLOP, PUTIN, LPPHI, etc.
PRO DELT, SIPGO, STPRIM SIP1 STCNT STUNT ECVI ECVN STLOP
PRO STMIN STINT STUNI PUTIN LPPHI LPANY
⊗

↑DELT:				;DELETE THE ITEM.
	STAKCHECK (1)
	RETCHK			;RETRIEVAL TYPES NECESSARY
	LPCALL	(DELETE)
	POPJ	P,

; START A LIST IN THE MAKING.
↑LIPGO:	SKIPA	A,[-1]			;TO STORE IN LORSET
; START A SET IN THE MAKING. I.E.  A← { ONE,TWO,THREE }
↑SIPGO:
	SETZ	A,			;TO STORE IN LORSET
	QPUSH	(LORSET)
	PUSHJ	P,OKSTACK
	MOVEM	FF,FFSAVE		;SAVE THE FAG WORD.T
	TLZ	FF,LPPROG
	MOVEI	A,0
	PUSHJ	P,CREINT
	EMIT	(<PUSH RP,NOUSAC>)
	AOS	ADEPTH
	SETOM	MKFLAG			;IN MAKE MODE.
	POPJ	P,

↑STPRIM:				;ALL DONE -- JUST MARK "STACK"
	SETZM	MKFLAG			;BACK AGAIN.
	MOVSI	A,LPPROG
	TDNE	A,FFSAVE
	TLO	FF,LPPROG
	MOVE	C,PHIBLK		;DUMMY SET SEMBLK
	HRLZI	B,LPSET!STACKET!RETRV	;THESE ARE THE NEW BITS.
	HLRZ	A,LORSET		;ADDRESS TOP ENTRY
	SKIPE	(A)			;SKIP IF SET
	JRST	[TLO	B,LPXISX		;REALLY A LIST
		 MOVE C,NILBLK		;DUMMY LIST SEMBLK
		 JRST .+1]
	MOVEM	C,GENRIG		;FAKE UP PARSE STACK
	QPOP	(LORSET)
	HLLZ	A,B
	JRST	BFIN

↑SIP1:					;CALLED FOR EACH ELEMENT OF SET LIST.
	STAKCHECK	(1)
	HLRZ	A,LORSET
	SKIPE	A,(A)
	JRST	[LPCALL (LSTMAK)
		 POPJ	P,]
	LPCALL	(SIP)
	POPJ	P,



↑STCNT:					;LENGTH OF SET (# OF ELEMENTS)
	STAKCHECK	(1)
INFENT:	XPREP
	LPCALL	(SETCUNT)		;ENTER HERE FROM PROCESSING INF.
INTGO:	PUSHJ	P,MARKINT	;MARK AN INTEGER.
	HRRI	TBITS,INTEGR
	MOVEM	TBITS,$TBITS(PNT)       ;IN CASE WAS A TEMP ITMVAR OR SOMETHING
					;SINCE MARK DOESN'T CHANGE TBITS OF TEMP
	MOVEM	PNT,GENRIG
	POPJ	P,


↑STUNT:				;COP OF SET (GET ONE ELEMENT)
	STAKCHECK	(1)
	LPCALL	(STUNT)
	HRLZI	A,LPITM!STACKET!RETRV!CNSTR		;A NEW ITEM.
	JRST	BFINA


↑ECVI:	PUSHJ	P,OKSTACK
	MOVE	PNT,GENLEF+1		;CONVERT TO ITEM.
	GENMOV	(GET,GETD!INSIST,INTEGR)	
	PUSH	P,D			;THE AC ITS IN
	PUSHJ	P,REMOP			;REMOP THE INTEGER TEMP
	POP	P,D
	MOVEI	TBITS,ITMVAR
	PUSHJ	P,MARKME		;THIS IS REALLY AN ITEMVAR
	MOVE	A,PNT
	HRLI	A,LPITM!RETRV!CNSTR
	JRST	LPREC			;PUT BACK ON STACK.

↑ECVN:  MOVE	PNT,@LEAPSK		;TOP OF LEAP STACK
	TLNE	PNT,LPSET!LPXISX		;BETTER NOT BE SET;
	ERR	<CVN ONLY VALID FOR ITEMS>,1
	TLNN	PNT,STACKET		;ALREADY STACKED?
	JRST	[
		GENMOV (GET,GETD)		;NOT STACKED
		 SOS LEAPSK		;NO LONGER ON LEAP STACK
		 JRST	INTGO		;MAKE INTO INTEGER
		]
	STAKCHECK (1)			;ALREADY ON RUNTIME STACK
	PUSHJ	P,GETAC			;GET A RESULT NUMBER.
	HRL	C,D
	EMIT	<POP RP,NOUSAC!NORLC!USADDR>
	JRST	INTGO			;GO MAKE AN INTEGER
					; (SEE "LLEN" IN STRING.)


FIRREF:	SOS	PNT,LEAPSK		;THERE SHOULD BE SOMETHING THERE.
	MOVE	PNT,1(PNT)
	TRNE	PNT,-1
	TLNE	PNT,STACKET		;NOT STACKED, I HOPE
	ERR	<NEEDS REFERENCE ARG>,1,CPOPJ
	PUSHJ	P,GETAD
	TLNE	SBITS,INDXED!FIXARR	;OK IF CALC. SBSCRP.
	JRST	FIROK
	TLNE	SBITS,ARTEMP!STTEMP	;NOT THESE
	ERR	<NEEDS REFERENCE ARG>,1
FIROK:	GENMOV	(ACCESS,0)
	EMIT	<MOVEI TAC1,NOUSAC>
	PUSHJ	P,REMOP
	POPJ	P,

↑STLOP:	PUSHJ	P,FIRREF		;FIRST ARG BY REF....
	LPCALL	(STLOP)
XXLP:	HRLZI	A,LPITM!STACKET!RETRV
	JRST	BFINA



FOR II    ⊂ (STMIN,STINT,STUNI),<
↑II:	SETCHK	(2)		;NEEDS TWO SET ARGUMENTS
	STAKCHECK (2,LEAVE)
	LPCALL	(II)
	POPJ	P,	>


↑REMAST: SETOM	REMASET		;INDICATES REMOVE ALL

	POPJ	P,	

↑PUTIN:				;PUT AND REMOVE.
	SETZM	MKFLAG
	PUSH	P,B		;PARSER INDEX
	PUSHJ	P,FIRREF	;GO GET IT.
	STAKCHECK	(1)	;FOR THE ITEM.
	POP	P,D
	SKIPN	D
	JRST	[
		LPCALL	(STPUT)
		POPJ	P,]
	SKIPE	REMASET
	JRST	[SETZM	REMASET
		 LPCALL	(REMALL)
		 POPJ	P,]
	LPCALL	(STREM)
	POPJ	P,


; THINGS TO MAKE ANY AND PHI WORK.  THEY JUST MARK THE COMPILE STACK.
↑STKNIL: SKIPA	C,NILBLK			;SEMANTIC BLOCK NIL LIST
↑LPPHI:	MOVE 	C,PHIBLK			;GET SEMANTIC BLOCK
	MOVEM 	C,GENRIG
	MOVE	A,[XWD LPSET!LPNUL!RETRV,0]
	CAME	C,PHIBLK
	TLO	A,LPXISX
	JRST	LPREC
↑LPANY:	MOVSI	A,LPITM!LPNUL!RETRV!BINDING
LPREC:	PUSHJ	P,BFIN
	TLNE	FF,LPPROG
	POPJ	P,			;FOREACH GOING ON.
	MOVEI	D,-1(B)		;THING BEFORE THE "ANY"
	CAIL	D,LEABEG	;ANYTHINGTO STACK ?
	JRST	STAKIT			;STACK IT.
	POPJ	P,
	LSTON	(LEAP)
DSCR PUTINL,HLDPNT,REMXD,REPLCX LISTGT
PRO	PUTINL,HLDPNT,REMXD,REPLCX,LISTGT
⊗
COMMENT ⊗
	PUTINL is exec routine which is called to generate PUT AFTER 
	REMXD is exec routine which generates REMOVE indx FROM list
	HLDPNT simply takes argument off of LEAPSK and saves it in 
	location HOLDPNT.
	LISTGT causes TEMP to be loaded from list variable whose semantics
	are in HOLDPNT
⊗
↑PUTINL:			;PUT INTO LIST (AFTER,BEFORE)
	SETZM	MKFLAG
	PUSH	P,B		;PARSER INDEX
	GETSEM	(1)		;SEMANTICS OF AE
	TRNN	TBITS,ITEM!ITMVAR!SET	;SET TO TAKE CARE OF COP,LOP 	; ITEM OR ARITHMETIC?
	JRST	PUTXAB		;ARITHMETIC
	PUSHJ	P,LISTGT	;CROCK TO GET LIST ARGUMENT
	STAKCHECK (2)		;TWO ITEM ARGUMENTS
;HERE WE SHOULD PROBABLY CHECK TO MAKE SURE BOTH ITEMS NOT SETS.
	POP	P,B		;POP INDEX
	LPCALL	(PUTAFT,<B>)	;CALL LEAP
	POPJ	P,			;RETURN TO PARSE

PUTXAB: STAKCHECK (1)		;ITEM ARGUMENT
	AOS	ADEPTH		;SINCE STAKCHECK DECREMENTED.
	GETSEM	(1)		;INDEX AMOUNT
	GENMOV	(STACK,INSIST,INTEGR)	;STACK AND COERCE TO INTEGER
	PUSHJ	P,LISTGT
	MOVNI	B,2
	ADDM	B,ADEPTH	;PARAMETERS WILL DISAPEAR
	POP	P,B		;PARSER INDEX
	LPCALL	(PUTXA,<B>)
	POPJ	P,


LISTGT: MOVE	A,HOLDPT	;PNTR FOR LIST SEMBLK
	AOS	B,LEAPSK	;WILL STACK IT TO USE FIRREF
	MOVEM	A,(B)		;STACK IT
	MOVE 	A,$TBITS(A)
	TRNN	A,LSTBIT
	ERR	<LIST DESTINATION REQUIRED>,1
	PUSHJ	P,FIRREF	;LIST ARGUMENT
	POPJ	P,


↑HLDPNT:SOS	B,LEAPSK	;TAKE OFF OF LEAP STACK
	MOVE	A,1(B)
	MOVEM	A,HOLDPT	;SAVE LIST SEMBLK POINTER
	POPJ	P,




↑REMXD:				;REMOVE INDEXED
	GETSEM	(3)		;INDEX
	GENMOV	(STACK,INSIST,INTEGR)	;COERCE AND STACK
	PUSHJ	P,FIRREF	;FOR LIST PARAMETER
	SOS	ADEPTH		;PARAMETER WILL GO AWAY
	LPCALL	(REMX)		;FOR CALL TO LEAP
	POPJ	P,		;RETURN TO PARSE


↑REPLCX: STAKCHECK (1)		;ITEM
	AOS	ADEPTH		;SINCE STACKCHEK DECREMENTED.
	GETSEM	(3)		;INDEX
	GENMOV	(STACK,INSIST,INTEGR)	;COERCE AND STACK
	GETSEM	(4)		;LIST ARGUMENT   
	TRNN	TBITS,LSTBIT
	ERR	<REPLACE REQUIRES LIST PARAMETER>,1
	GENMOVE (ACCESS,0)	;LIST PARAMETER
	EMIT	<MOVEI TAC1,NOUSAC>
	MOVNI	A,2
	ADDM	A,ADEPTH	;TWO PARAMS WILL GO AWAY.
	LPCALL	(RPLAC)
	POPJ	P,		;RETURN TO PARSE
DSCR CVLS,LSSUB,SELIP,SELSBL 
⊗
COMMENT ⊗ CVLS GENERATES THE CODE TO CONVERT A LIST EXPRESSION INTO 
	A SET EXPRESSION AND VICE_VERSA.
	REFINF - puts semantics of list variable on LENSTR q-stack for
	appropriate handling of ∞
⊗

↑CVLS:				;CONVERT LIST←→SET
; B 1 IF CVLIST, 0 IF CVSET
	MOVE	A,GENLEF+1
	MOVEM	A,GENRIG	;TWIDDLE PARSE STACK
	JUMPE	B,[STAKCHECK (1);LIST
		   LPCALL (SETLST)
		   HRLZI  A,LPSET!STACKET!RETRV!CNSTR
		   JRST BFINA]
	HRLZI	A,LPSET!LPXISX!RETRV!CNSTR
	MOVE	B,LEAPSK
	HRR	A,(B)
	MOVE	A,(B)
	POPJ	P,

↑↑REFINF:			;REFERENCE FORM FOR INF
	GETSEM	(1)		;THE LIST
	MOVE	A,PNT
	HRLI	A,777000
	JRST 	REFENT

↑↑LSSUB:				;SET UP TO HANDLE INF.
	PUSHJ	P,OKSTACK
	HRRO	A,ADEPTH
REFENT:	QPUSH	(LENSTR)		;SAME AS SUBSTRING USES
	AOS	LENCNT
	POPJ	P,
↑ELSSUB:			;DISABLE INF.
	QPOP	(LENSTR)
	SOS	LENCNT
	POPJ	P,
↑↑LINF:				;HANDLE INF. WITHIN LIST SELECTION OR REPLACE
	TLNN	A,777		;REFERENCE FORM
	JRST	[HRRZ	PNT,A
		JRST REFLNG]    ;PERM. SET, WE CAN FIND THE LENGTH DIRECTLY
	MOVN	C,ADEPTH	;CURRENT ADEPTH
	ADDI	C,(A)		;RELATIVE STACK POSITION
	LSH	C,=18		;PREPARE FOR EMIT
	PUSH	P,C		;SAVE IN CASE DESTROYED BY ROUTINES
	PUSHJ	P,GETAC		;GET AN ACCUM. TO PLAY WITH
	PUSHJ	P,MARKINT	;LENGTH IS AN INTEGER
	MOVEM	PNT,GENRIG	;PARSER EXPECTS A SEMBLK
	POP	P,C		;IN CASE GETAC OR MARKINT DESTROYED
	HRLI	D,P		;PREPARE FOR EMIT
	EMIT	<HLRE	,USADDR!NORLC!USX>
	HRL	C,D		;PREPARE FOR MOVMS
  	EMIT	<MOVM	,USADDR!NORLC>
	POPJ	P,

REFLNG:				;TO DETERMINE LENGTH OF PERMANENT SET
	PUSH	P,PNT		;REFERENCE TO SET,
	PUSHJ	P,GETAC		;ACCUM TO PLAY WITH
	PUSHJ	P,MARKINT	;LENGTH RETURNED IS INTEGER
	MOVEM	PNT,GENRIG	;PRODUCTIONS EXPECT IT HERE
	POP	P,PNT
	MOVE    SBITS,$SBITS(PNT);GET SBITS
	EMIT	<HLRE >
	POPJ	P,


↑SELIP:				;SELECT ITEM INDEXED FROM LIST
	STAKCHECK (1)		;FOR LIST ARGUMENT
	AOS	ADEPTH		;SINCE STACKCHEK DECREMENTED.
	GETSEM	(1)		;INDEX
	GENMOV	(STACK,INSIST,INTEGR)
	LPCALL	(SELFETCH)
	SOS	ADEPTH		;PARAM WILL GO AWAY.
	HRLZI	A,LPITM!STACKET!RETRV!CNSTR
	JRST	BFIN


↑SELSBL:			;FOR TAKING A SUBLIST
	SUBI	B,4		;PARSER INDEX 0 IF TO ,1 IF FOR
	SKIPGE	B		;CHECK TO MAKE SURE TO OR FOR
	ERR	<ERROR- SUBLIST SYNTAX, FOR ASSUMED>,1
	PUSH	P,B		;SAVE FOR LATER USE
	STAKCHECK	(1)		;FOR LIST
	AOS	ADEPTH		;SINCE DECREMENTED.
	GETSEM	(3)		;FOR FIRST ARG.
	GENMOV	(STACK,INSIST,INTEGR)	;FOR FIRST INDEX
	GETSEM	(1)		;FOR SECOND INDEX
	GENMOV	(STACK,INSIST,INTEGR)
	MOVNI	A,3		;STACK WILL BE THREE LESS
	ADDM	A,ADEPTH
	POP	P,B		;RESTORE INDEX
	CAIE	B,0		;TO?
	JRST	[LPCALL (FSBLST)
		 HRLZI	A,LPSET!LPXISX!STACKET!RETRV!CNSTR
		JRST BFINA]
	LPCALL	(TSBLST)
	HRLZI	A,LPSET!LPXISX!STACKET!RETRV!CNSTR
	JRST	BFINA
↑LSTCAT:			;CONCATENATE TWO LISTS
	STAKCHECK (2,LEAVE)
	LPCALL	(CATLST)
	HRLZI	A,LPXISX!LPSET	;RESULT IS LIST
	ORM	A,@LEAPSK
	POPJ	P,
;GETTING NEW ITEMS.
DSCR NEWNOT, NEWART, GLBSET, SELET
PRO NEWNOT NEWART, GLBSET, SELET
⊗
DSCR ITMTYP returns type code in A corresponding to bits in A. Normally
	A will have been loaded with TBITS entry for type 
   TYPE CODES NOW CONTAINED IN HEAD.

	STTYPE←← 3
	FLTYPE←← 4
	INTYPE←← 5	;INTEGER ITEM
	SETYPE←← 6	;SET ITEM
	LSTYPE←← SETYPE+1 ;LIST ITEM,TYPE CODE SHOULD BE 1 GTR SETYPE
	CTXTYP←← 13
	ARRTYP←← 15     ;ADDED TO MAKE ARRAY
⊗
↑ITMTYP:	PUSH	P,B		;SAVE B
		MOVEI	B,0		;INITIALLY NO TYPE
		TLNE	A,SBSCRP	;AN ARRAY?
		ADDI	B,ARRTYP
		TRNE	A,LPARRAY	;DECLARED ARRAY ITEM?
		ADDI	B,ARRTYP	;YES
		TRNN	A,SET		;A SET OR LIST?
		JRST	NTSET
		TRNE	A,FLOTNG	;A CONTEXT?
		ADDI	B,1		;MAKE UP FOR CONTEXT ≡13 BUT SET+REAL=12
		ADDI	B,SETYPE	;YES
		TRNE	A,LSTBIT	;A LIST?
		ADDI	B,1		;LIST TYPE 1 GTR THAN SET
NTSET:		TRNE	A,FLOTNG	;REAL?
		ADDI	B,FLTYPE	
		TRNE	A,STRING
		ADDI	B,STTYPE
		TRNE	A,INTEGR
		ADDI	B,INTYPE
		SKIPN	A,B
		MOVEI	A,1		;UNTYPED ITEM TYPE IS 1
		POP	P,B		;RESTORE B
		POPJ	P,

↑NEWNOT: PUSHJ	P,OKSTACK		;REGULAR NEW.
	MOVEI	A,1
	HRLM	A,BYTES		;TYPE CODE FOR UNTYPED ITEM
	LPCALL	(NEWITM)
	MOVEI	TBITS,0
	TLZ	FF,FFTEMP
	JRST	ONCON


↑NEWART: 			;NEW (ARITHMETIC ARGUMENT)
	PUSHJ	P,OKSTACK
	GETSEM	(1)
	TRNN	TBITS,SET	;IF SET, ALREADY STACKED
	JRST	NTSTKD
	TDNE TBITS,[XWD SBSCRP,FLOTNG] ;UNLESS ARRAY OR CONTEXT
	JRST 	NTSTKD
	 SOS  A,LEAPSK
	 HLRZ B,1(A); GET TYPE BITS
	 MOVEI A,SETYPE; FIRST ASSUME SET
	 TRNE B,LPXISX; A LIST
	 ADDI A,1 ; REALLY A LIST
	 JRST ISSTACK	;DON'T RESTACK IT
NTSTKD:	MOVE	A,TBITS		;PREPARE FOR CALL TO ITMTYP
	PUSHJ	P,ITMTYP	;GET TYPE	
	CAIN	A,CTXTYP	;CONTEXT?
	ERR	<CONTEXTS MAY NOT BE ARGUMENTS TO NEW>,1
	PUSH	P,A		;SAVE FOR LATER
	GENMOV	(STACK,GETD)	;STACK THE ARITHMETIC.
	POP 	P,A		;GET TYPE BACK
ISSTACK:TRNN	TBITS,STRING
	JRST	.+4		;NOT A STRING
	MOVNI   B,2
	ADDM	B,SDEPTH
	CAIA
	SOS	ADEPTH		;IT IS A PARAMETER.
	HRLM	A,BYTES		;TYPE TO LEAP PARAM
	TLNE	TBITS,SBSCRP
	JRST	[LPCALL (NEWRY)
		 JRST	DCON]
	LPCALL	(NEWARITH)
DCON:	PUSHJ	P,REMOP
ONCON:	MOVSI	A,LPITM!CNSTR!STACKET	;RECORD THAT NEW ENTRY IS ITEM.
	JRST	BFINA

NOGLOC <
↑GLBST2: POPJ  P,
>;NOGLOC
GLOC <
↑GLBSET:	AOS	LEPGLB
	POPJ	P,	;$$$*** $$$*** $$$***
↑GLBST2: QPUSH	(GLBSTK,LEPGLB)	;SAVE STATE, REALLY ZERO,NON-ZERO.
	SKIPE	LEPGLB		;IF NON-ZERO
	SOS	LEPGLB		;DECREMENT
	POPJ	P,
>;GLOC


↑SELET:				;FIRST, SECOND, THIRD.

	PUSH	P,B		;SELECTOR INDEX.
GLOC <
	PUSHJ	P,GLBST2	;HANDLE "GLOBAL"
>;GLOC
	STAKCHECK (1)		;ONE ARGUMENTS.
	RETCHK			;RETRIEVAL TYPES NECESSARY
	LPCALL	(SELECT,<(P)>)
	POP	P,B
	MOVSI	A,LPITM!RETRV!STACKET	;RESULT IS AN ITEM.
	JRST	BFINA
; CASE, EXPRESSION CONDITIONALS.

DSCR LPCS2, LPCS3, LPEXF1, LPEXF2
PRO LPCS2 LPCS3 LPEXF1 LPEXF2
⊗

↑LPCS2:	
	MOVE	SP,GENLEF+2
	PUSHJ	P,LASCHK
	SKIPN	TBITS,$TBITS(SP)
	MOVE	TBITS,A
	MOVEM	A,$TBITS(SP)
	TLNN	A,LPITM
	JRST	CASEMT		;NOT AN ITEM, SO OK.
	XOR	TBITS,A
	TDNE	TBITS,[XWD -1 ≠(CNSTR!RETRV!FIXED!LPNUL),-1]
	ERR	<CASE STATEMENT MISMATCH>,1
	JRST	CASEMT


↑LPCS3:
	MOVE	SP,GENLEF+2
	MOVE	A,$TBITS(SP)
LPGO:	PUSHJ	P,BFINA
	JRST	CASEND



↑LPEXF1:
	PUSHJ	P,LASCHK
	MOVEM	A,GENRIG+1
	JRST	IFLS1

↑LPEXF2:
	PUSHJ	P,LASCHK
	PUSH	P,A
	XOR	A,GENLEF+3
	TDNE	A,[XWD -1 ≠(LPNUL!CNSTR!RETRV!FIXED),-1]
	ERR	<EXPRESSION CONDITIONALS DON'T MATCH>,1
	POP	P,A			;TYPES ---
	PUSHJ	P,BFINA			;PUT BACK ON STACK.
	JRST	IFLS2
; STORE ROUTINES.

DSCR LPSTOR, LPFRSTO, LEAVE, PNAM
PRO LPSTOR LPFRSTO LEAVE PNAM
⊗

↑LPSTOR:
	TDZA	SP,SP			;NOT A FOR STATEMENT.
↑LPFRSTO: SETOM	SP
	MOVE	PNT,GENLEF+2		;SEMANTICS OF DESTINATION
	GENMOV	(ACCESS,GETD)		;GET ACCESS IF INDEXED
	JUMPL	SP,NOSQ			;IF A FOR LOOP, DO IT THE HARD WAY.
	MOVE	PNT2,@LEAPSK		;GET TOP OF STACK.
	TLNN	PNT2,LPITM		;IF A SET, THEN DO IT HARD WAY.
	JRST	NOSQ			;CALL LEAP ANYWAY.
	TRNN	TBITS,ITEM!ITMVAR	;CHECK TYPE
	ERR	<STORING ITEM INTO WROND ID>,1
	TRNE	PNT2,-1			;IF A TEMP
	TLNE	PNT2,STACKE		;OR STACKED
	JRST 	ITMPOP			;WILL HAVE TO POP OFF STACK
	TLNE	TBITS,MPBIND
	JRST	ITMPOP
	MOVEM	PNT2,GENLEF+1		;EXPRESSION SEMANTICS.
	TLNN	FF,FFTEMP ;DO NOT BACK UP IF EXPRESSION STORE.
	SOS	LEAPSK
	JRST	STORG	;BACK UP IN STORE FROM WHICH WE WER CALLED.
ITMPOP:					;WILL ATTEMPT TO GENERATE POP
	PUSHJ	P,OKSTACK		;MAKE SURE TOP REALLY STACKED
	GETSEM	(2)			;GET SEMANTICS OF DEST AGAIN
	TLNE	TBITS,MPBIND		;A ? PARAMETER?
	JRST	[MOVEM	FF,FFSAVE
		 GENMOV (GET,ADDR!INDX)	;GET THE ADDRESS OF THE PARAM
		 MOVSS	D		;PREPARE FOR POP
		 EMIT <POP RP,NOUSAC!NOADDR!USX!NORLC>
		 MOVE	FF,FFSAVE
		 JRST	DECSTK		;DECREMENT STACK IF NECESSARY
		]
	EMIT	<POP RP,NOUSAC>
	TLNE	SBITS,INDXED!INUSE	;REMOP?
	PUSHJ	P,REMOP
DECSTK: SOS	B,LEAPSK
	SOS	ADEPTH
	TLNN	FF,FFTEMP		;EXPRESSION STORE?
	POPJ	P,
MODSTK:	MOVE	A,[XWD 1,1]
	PUSH	P,PNT
	PUSHJ	P,CREINT
	EMIT	<ADD P,NOUSAC>
	POP	P,PNT
	HLL	TBITS2,1(B)		;OLD TYPE BITS
	JRST	STE
NOSQ:	TLNE	TBITS,MPBIND		;A ? PARAMETER?
	JRST	[HRRI	D,TAC1		;WANT ADDR IN TAC1
		 PUSH 	P,TBITS
		 GENMOV (GET,ADDR!SPAC)
		 JRST	NOSQ2]
	MOVE	A,[HRROI TAC1,NOUSAC]
	TRNE	TBITS,ITEM!ITMVAR
	HRLI	A,(<MOVEI TAC1,0>)
	PUSHJ	P,EMITER
	PUSH	P,TBITS			;PRESERVE DESTINATION TYPE.
NOSQ2:	JUMPN	SP,.+3			;ONLY IF NOT OUR MAN FOR.
	TLNE	SBITS,INDXED!INUSE
	PUSHJ	P,REMOP		;REMOP HERE SINCE LPCALL CALLS
					;ALLSTO.
	STAKCHECK	(1)		;AFTER THE MOVEI BECAUSE THIS WILL
					;CHANGE ADEPTH, ETC....
	POP	P,TBITS
	XPREP
	TLNE	A,LPITM
	JRST	[TRNN	TBITS,ITMVAR
		ERR	<STORING ITEM INTO WROND ID>,1
		 JRST	TYPOK]
	TLNN	A,LPSET!LPXISX
        ERR 	<NEITHER SET, LIST, NOR ITEM EXPRESSION>,1,TYPOK
;; #HW# BY JRL 6-22-72 A SET ITEMVAR IS NOT A SET (LHS ASSIGNMENT)
	TRNE	TBITS,ITEM!ITMVAR	;BETTER NOT BE ITEM
	ERR	<STORING LIST OR SET INTO ITEM OR ITEMVAR>,1
;; #HW#
	TRNN	TBITS,SET
	ERR	<STORING LIST INTO WRONG ID>,1
	TLNE	A,LPXISX		;A LIST TO BE STORED?
	TRNE	TBITS,LSTBIT		;A LIST DESTINATION
	CAIA
	ERR	<STORING LIST EXPRESSION INTO SET>,1

TYPOK:  JUMPN	SP,STD			;IF WITHIN FOR CAN'T BE EXPRESSION
	MOVE	TBITS2,A
	TLNN	FF,FFTEMP		;EXPRESSION STORE??
	JRST	STD			;NO
	LPCALL	(STORBUTDONTREMOVE)
	JRST	STE
STD:	LPCALL	(STORE)
STE:	JUMPN	SP,LFOR
	TLNN	FF,FFTEMP
	POPJ	P,
	TLNN	SBITS,INDXED!FIXARR
	JRST	STE1
	GETBLK	(PNT)			;GET A DUMMY SEMBLK.
	TLO	TBITS2,DUMSEM		;MARK THIS AS A DUMMY
	MOVEM	TBITS,$TBITS(PNT)
STE1:	HRRI	A,(PNT)
	MOVEM	PNT,GENRIG+1	;SAVE FOR OTHERS.
	HLL	A,TBITS2
	JRST	BFINA		;MARK THE LEAP STACK.


↑LEAVE:				;ENTERED FROM ECHK, OTHERS?
	MOVE	A,@LEAPSK	;IS IT STACKED??
	TRNE	A,-1		;SEE IF HAS SEMBLK POINTER
	TLNE	A,STACKET	;
	JRST	NOWW		;NO CLEVER.
	MOVE	TBITS,$TBITS(A)
	TRNN	TBITS,ITEM!ITMVAR!SET!LSTBIT
	JRST	NOWW
	HRRZM	A,GENLEF+1
	SOS LEAPSK
	POPJ	P,
NOWW:	
	TLNE	A,LPITM
	JRST	[PUSHJ P,GETAC  ;AN AC TO STORE IT IN
		 HRLI C,(D)	;THE AC NUMBER
		 EMIT <POP RP,NOUSAC!USADDR!NORLC>
		 SOS LEAPSK
		 SOS ADEPTH
		 HRRI TBITS,ITMVAR
		 SETZM SBITS
		 PUSH P,TBITS
		 JRST MARW]
	STAKCHECK (1)		;MAKE SURE THIS IS THE VERY TOP.
	SETZB	SBITS,TBITS
	TLNE	A,LPSET
	TRO	TBITS,SET
	TLNE	A,LPXISX
	TRO	TBITS,LSTBIT
	PUSH	P,TBITS
	XPREP
	LPCALL (POPSET)
MARW:	GENMOV	(MARK,0)
	MOVEM	PNT,GENLEF+1
	POP	P,$TBITS(PNT)	;SINCE MARK IS INCREDIBLY STUPID.
	POPJ	P,


↑MAKEST:			;PERFORM CONVERSION TO SET FOR INSIST(GENMOVE)
	GENMOV  (STACK,GETD)	;STACK LIST
	LPCALL	(SETLST)	;CONVERT TO SETLST
POPMRK:	XPREP
	SOS	ADEPTH		;REMOVEING FROM STACK
	LPCALL  (POPSET)	;REMOVE FROM STACK
	GENMOV	(MARK,0)	;MARK RESULT
	MOVEI	A,SET
	MOVEM	A,$TBITS(PNT)
	POPJ	P,

↑MAKLST:			;PERFORM CONVERSION TO LIST FOR INSIST(GENMOV)
	POPJ	P,		;NO DUPLICATION NOW.

↑PNAM:	
	SKIPE	PNMSW
	ERR	<SAY PNAMES ONLY ONCE>,1
	AOS	PNMSW		;WILL COUNT PNAMES.
	MOVE	A,SCNVAL	;FROM REQUIRE
	MOVEM	A,PNAMNO	;FOR ALLOCATION STUFF.
NOGAG <
	QPUSH	(PNLST)
	QPOP	(PNLST)
	MOVE	A,PNLST
	MOVEM	A,PNBEG		;SAVE FOR TAKING THINGS OUT.
>;NOGAG
GAG <
	MOVE	USER,GOGTAB
	MOVEI	A,1000
	MOVEM	A,ITMTOP(USER)	;JUST A DUMMY.
	PUSH	P,FF
	PUSHJ	P,LEAP
	115			;INITIALIZE PNAMES.
	0			;AND NO NAMES AT ALL.
	POP	P,FF
>;GAG
	POPJ	P,




DSCR CALMP -MATCHING PROCEDURE EXECS
⊗
↑↑CALMP:
	MOVE PNT,GENLEF+1		;PROCEDURE SEMANTICS
	HRRZ 	PNT,$VAL(PNT)		;PD SEMBLK ADDRESS
	MOVS	C,$ADR(PNT)		;FIXUP,FLAG
	MOVE	A,[HRRZI TEMP,NOUSAC!JSFIX]
	TRNE	C,-1			;ALREADY PUT OUT?
	HRRI	A,NOUSAC!USADDR		;YES 
	PUSHJ	P,EMITER		;ADDR OF PDA
	HRLI	C,TEMP			;PREPARE FOR PUSH
	EMIT	<PUSH RP,NOUSAC!NORLC!USADDR> ;PUSH PDA ONTO STACK
	LPCALL	(MATCAL)		;CALL MATCHING PROCEDURE
	SOS	ADEPTH			;FOR ITEM PARAM TO SPROUT
	SETZM	NEDPOP			;THE MP HAS DONE THE POP FOR US
; ADEPTH,SDEPTH HAVE ALREADY BEEN DECREMENTED BY ISUCAL FOR PARAMS
LPMPAR:	QPOP	(MPQSTK)		;POP OFF
	JUMPE	A,NOMORE		;ALL DONE?
	MOVE	SBITS,$SBITS(A)		;PREPARE TO MARK AS BOUND
	TLZN	SBITS,LPFREE
	ERR	<DRYROT AT LPMPAR>
	MOVEM	SBITS,$SBITS(A)
	JRST	LPMPAR
NOMORE:	QPUSH	(MPQSTK,A)		;PUT MARKER BACK ON
	POPJ	P,

↑↑QLOCAL:GETSEM (0)
	TLNE	SBITS,LPFRCH!FREEBD	;ALREADY IN LIST?
	ERR	<SAME LOCAL ITEMVAR IN BINDING LIST>,1
	TLO	SBITS,FREEBD
	MOVEM	SBITS,$SBITS(PNT)
	POPJ	P,
↑↑SUCCEX:
	QPOP	(MPSTAK)
	JUMPE	A,SUCCER
SUCCON:	QPUSH	(MPSTAK,A)		;PUT IT BACK ON
	PUSH	P,A
	PUSH	P,B			;SAVE INDEX
	HRRZ	PNT,$VAL(A)		;PDA SEMBLK
	MOVS	C,$ADR(PNT)		;
	MOVE	A,[HRRZI TEMP,NOUSAC!JSFIX]
	TRNE	C,-1			;ALREADY PUT OUT
	HRRI	A,NOUSAC!USADDR		;NO.
	PUSHJ	P,EMITER
	HRLI	C,TEMP
	EMIT	<PUSH RP,NOUSAC!USADDR!NORLC>
	POP	P,A			;SUCC OR FAIL
	ADDI	A,R.SUCCE+LIBTAB	;LIBTAB INDEX
	PUSHJ	P,XCALLQ		;CALL SUCCEED OR FAIL
	POP	P,PNT			;PROC SEMBLK
	HRLZ	C,$ACNO(PNT)		;FIXUP FOR EXIT
	HRRZ	D,PCNT			;CURRENT PC
	HRRM	D,$ACNO(PNT)
	EMIT	<JRST NOUSAC!USADDR>
	POPJ	P,
SUCCER:	ERR <SUCCEED OR FAIL MUST BE WITHIN MATCH. PROC>,1
	JRST    SUCCON

DSCR REMEMBER EXECS RMASET,RMBSET,RMSTK
⊗
;TYPE BITS TO BE PASSED TO RUNTIMES
DESC ←← 400000
ISARR ←← 200000
ISSTR ←← 100000
ISSET ←← 40000

↑RMASET:					;REMEMBER ALL
	HRLZM	B,REMCEL		;SAVE WHICH KIND OF OPERATION,# PARAMS
	POPJ	P,

↑RMBSET:					;REM,FOR,RES NAMED ENTRIES
	ADDI	B,3
	HRLI	B,1
	MOVSM	B,REMCEL		;SAVE WHICH KIND
	MOVEI	A,0			;CREATE ZERO CONSTANT
	PUSHJ	P,CREINT
	GENMOV	(STACK,GETD)
	POPJ	P,
↑RMSTK:
	AOS 	REMCEL
	GETSEM	(1)			;SEMANTICS OF VARIABLE TO BE SAVED ETC
	TRNE	TBITS,ITEM		;DON'T ALLOW ITEM TO BE SAVED ETC
	ERR	<AN ITEM IS NOT A VARIABLE CAN'T BE REMEMBERED>,1
	TRNN	TBITS,SET!ITMVAR	;LEAPISH THING?
	JRST    HVPNT			;NO.
	SOS	B,LEAPSK		;GET SEMAN FROM LEAP STACK
	MOVE	PNT,1(B)		;SEMBLK
	TLNE	PNT,STACKET		;ALREADY STACKED?
	ERR	<EXPRESSIONS CANNOT BE REMEMBERED>,1
HVPNT:
	HRRZS	PNT			;PREPARE TO CALCULATE TYPE BITS
	TLNE	TBITS,SBSCRP		;AN ARRAY?
	TLO	PNT,ISARR		;TELL THE WORLD
	TRNE	TBITS,STRING
	TLO	PNT,ISSTR
	TRNN	TBITS,SET
	JRST	RMEXPR
	TRNE	TBITS,FLOTNG!INTEGR
	ERR	<KILL_SETS AND CONTEXTS MAY NOT BE REMEMBERED>,1
	TLO	PNT,ISSET
RMEXPR:	TLNE	SBITS,ARTEMP!STTEMP	;AN EXPRESSION?
	TLNE	TBITS,SBSCRP		;OK IF ARRAY
	JRST	RMSTK2			;NO
	TLNN	SBITS,FIXARR!INDXED	;
	ERR	<EXPRESSION CANNOT BE REMEMBERED>,1
RMSTK2:	SETOM	MPFLAG			;WANT BITS IN LEFT HALF
	PUSHJ	P,FTRADR		;MAKE LIKE A FORTRAN CALL
	GENMOV	(STACK,GETD)
	SETZM	MPFLAG
	POPJ	P,

↑CNTXTS: 				;STACK CONTEXT VARIABLE AND CALL ROUTINE
	GETSEM	(1)
	PUSHJ	P,ADRINS		;GET ADDRESS OF CONTEXT VARIABLE
	GENMOV	(STACK,0)		;STACK IT
	HRLI	A,LIBTAB+RALLRM 	;
	ADD	A,REMCEL
	HLRZ	A,A
	PUSHJ	P,XCALLQ
	HRRZ	A,REMCEL
	ADDI	A,1
	MOVNS	A
	ADDM	A,ADEPTH
	POPJ	P,

BEND LEAP
>;LEP

COMMENT ⊗ EXECS FOR DYNAMIC BINDING OF PROC ITEMS⊗

DSCR PDASTK
DES EMITS CODE TO PUSH ONTO THE P-STACK PDA OF NAMED PROC

⊗

↑PDASTK:	
	MOVE	PNT2,GENLEF+1		;GET SEMBLK FOR PROC ID
	HRRZ	PNT,$VAL(PNT2)		;POINT AT PD SEMBLK
	PUSHJ	P,GETAC			;GETS AN AC
	PUSHJ	P,LODPDA
	HRL	C,D
	EMIT	<PUSH P,NOUSAC!USADDR!NORLC> ;PUSH P,AC
	AOS	ADEPTH			;HIT THEE BOOKS
	POPJ	P,

↑LODPDA:				;LOADS PDA NAMED BY PNT INTO AN AC NAMED
					;IN RH OF D (MANGLES C)
					;ASSUMES PROC SEMBLK IS IN PNT2
	SKIPL	C,$ADR(PNT)		;IS THE ADDRESS TRUE YET ?
	JRST	EMJSF			;NO, DO A FIXUP
	HRLZ	C,C			;PICK UP THE ADDRESS OF THE PDA
	EMIT	<MOVEI  USADDR>		;GO PUT IT OUT
	POPJ	P,			;RETURN
EMJSF:	MOVE	A,[MOVEI JSFIX]		;MOVEI A,PDA
	MOVE	C,$TBITS(PNT2)		;
	TLNE	TBITS,EXTRNL
	MOVE	A,[MOVE JSFIX]
	PUSHJ	P,EMITER
	POPJ	P,

DSCR COPPIT
DES EMITS CODE TO CALL PITCOP TO COPY ONE FHQ PROC ITEM DATUM INTO ANOTHER ITEM
	DATUM. DOES A STORZ ON B&C TO FREE THEM UP -- WARNING: THIS MAY
	CONFLICT WITH THE PROTECT_ACS FEATURE.  

⊗

↑COPPIT:
	MOVEI	D,B
	PUSHJ	P,STORZ			;FREE UP B
	MOVEI 	D,C			
	PUSHJ	P,STORZ			;FREE UP C
	XCALL	(PITCOP)
	POPJ	P,

DSCR BINCL
DES EMITS CODE TO CALL PITBND -- ALSO FREES UP B&C

⊗

↑BINCL:

	MOVEI	D,B
	PUSHJ	P,STORZ			;FREE UP B
	MOVEI 	D,C			
	PUSHJ	P,STORZ			;FREE UP C
	XCALL	(PITBND)
	POPJ	P,

COMMENT ⊗EXECS FOR APPLY⊗

DSCR EVLLST,EVLNLL,PITSTK
DES USED TO SET UP INTERP CALL
⊗

↑EVLLST:
	PUSHJ	P,BNDLST		;GET LIST STACKED
	JRST	XCLEVL			;GO CALL THE CALLER
↑EVLNLL:
	MOVEI	A,0
	PUSHJ	P,CREINT		;GET A ZERO
	GENMOVE	(STACK)			;STACK IT
XCLEVL:	XCALL	(APPLY)			;CALL APPLY
;;#JS#  ADJUST ADEPTH RHT 10-20-72
	MOVNI	A,2			;
	ADDM	A,ADEPTH		;
;;#JS#
	POPJ	P,


↑PITSTK:
	MOVEI	D,B		;FREE UP B & C
	PUSHJ	P,STORZ
	MOVEI	D,C
	PUSHJ	P,STORZ
	XCALL	(PITDTM)	;
	POPJ	P,