Google
 

Trailing-Edge - PDP-10 Archives - -
There are no other files named in the archive.
COMMENT    VALID 00028 PAGES VERSION 17-1(56)
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	HISTORY
C00018 00003	Leap Generators.
C00023 00004	NOW FOR THE DEFINITIONS OF ALL THE RUNTIME ROUTINES.
C00029 00005	ZERODATA (LEAP VARIABLES)
C00035 00006	DSCR LEPINI
C00039 00007	DSCR LEAPC1, LEAPC2
C00041 00008	DSCR STSET,LSTKCK,QUESET,FRESET
C00046 00009	
C00050 00010	STCHK:	PUSH	P,D			SAVE NUMBER OF PARAMS TO CHECK.
C00062 00011	DSCR CHKSAT -
C00063 00012	FOREACH STATEMENT HANDLERS.
C00077 00013	^DERIV:					DERIVED SETS.
C00080 00014	DATUM HANDLERS
C00088 00015	DSCR - PPSTO,EPPSTO,GETPROP  execs for PROPS
C00092 00016	 MAKE AND ERASE
C00094 00017	 VARIOUS BOOLEANS.
C00100 00018	DSCR DELT, SIPGO, STPRIM, ECVI, STLOP, PUTIN, LPPHI, etc.
C00109 00019	DSCR PUTINL,HLDPNT,REMXD,REPLCX LISTGT
C00113 00020	DSCR CVLS,LSSUB,SELIP,SELSBL 
C00118 00021	GETTING NEW ITEMS.
C00130 00022	 CASE, EXPRESSION CONDITIONALS.
C00132 00023	 STORE ROUTINES.
C00138 00024	
C00142 00025	DSCR CALMP -MATCHING PROCEDURE EXECS
C00148 00026	DSCR REMEMBER EXECS RMASET,RMBSET,RMSTK
C00153 00027	 EXECS FOR DYNAMIC BINDING OF PROC ITEMS
C00156 00028	EXECS FOR APPLY
C00158 ENDMK
C;
COMMENT HISTORY
AUTHOR,REASON
021  102100000070  ;


COMMENT 
VERSION 17-1(56) 1-18-75 BY JRL BUG #TU# PROBLEMS WITH LEAP CORTMPS
VERSION 17-1(55) 9-18-74 BY RHT BUG #TI# REF!ITEM WAS ALWAYS SETTING TMPB
VERSION 17-1(54) 8-3-74 BY RHT REORGANIZE RFDPSH A BIT
VERSION 17-1(53) 6-28-74 BY JRL BUG #SR# DON'T ALLOW "PUT X IN LIST"
VERSION 17-1(52) 6-28-74 BY JRL BUG #SQ# BOOLEAN X IN LIST WAS COMPILED AS X IN SET
VERSION 17-1(51) 5-28-74 BY RHT BUG #SE#
VERSION 17-1(50) 5-22-74 BY RHT MODIFY ITMTYP TREATMENT OF RECORDS
VERSION 17-1(49) 5-20-74 BY RHT BUG #SB# REFITEM(STRING VALUE) NEEDED HELP
VERSION 17-1(48) 5-20-74 BY RHT BUG #RZ# TYPO AT SKKRFD
VERSION 17-1(47) 5-20-74 
VERSION 17-1(46) 5-5-74 BY JRL  FIX BUG RS AGAIN (WAS CHECKING LPITM RATHER THAN LPSET)
VERSION 17-1(45) 5-5-74 BY JRL BUG #RV# DON'T ALLOW LENGTH(ITEMEXPR)
VERSION 17-1(44) 5-1-74 BY RHT TWEAK DATUM TO ALLOW FOR RECORDS
VERSION 17-1(43) 4-12-74 BY RHT ADD RECORD INFO FOR ITMTYP & DATUM EXECS  
VERSION 17-1(42) 4-12-74 
VERSION 17-1(41) 4-12-74 
VERSION 17-1(40) 4-7-74 BY JRL BUG #RS# GIVE ERROR MESSAGE FOR COP(ITEMEXPR)
VERSION 17-1(39) 3-22-74 BY JFR MORE REFITEM/STRING CONSTANT STUFF
VERSION 17-1(38) 3-22-74 BY JFR REFITEM STRING CONSTANT PROBLEMS
VERSION 17-1(37) 3-21-74 BY JRL BUG #RP# COLLECT TYPE BITS FOR STRING TEMP RFITEMS CORRECTLY
VERSION 17-1(36) 3-21-74 
VERSION 17-1(35) 3-21-74 
VERSION 17-1(34) 2-24-74 BY RHT FEAT %BH% -- ARGLIST
VERSION 17-1(33) 2-8-74 BY JRL BUG #RB# FORGOT TO INCLUDE THE GETD'S
VERSION 17-1(32) 2-6-74 BY JRL BUG #RC# MINOR FIX TO FEAT %BD% FOREACH'S WITHOUT BINDING LISTS
VERSION 17-1(31) 2-6-74 BY JRL BUG #RB# VARIOUS MISSING ACCESSES
VERSION 17-1(30) 1-22-74 BY JRL BUG #QN# DO IT RIGHT
VERSION 17-1(29) 1-22-74 BY RHT BUG #QN# MAKE BUG PX RECOVERABLE
VERSION 17-1(28) 1-7-74 BY JRL FEAT %BD% ALLOW FOREACHS WITHOUT BINDING LISTS
VERSION 17-1(27) 12-12-73 BY JRL BUG #PX# ADD MORE STACK-HEIGHT CHECKING
VERSION 17-1(26) 12-9-73 BY RHT PROVIDE GLBSET
VERSION 17-1(25) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(24) 12-1-73 BY JRL FEAT %AU% ALLOW FAIL, SUCCEED AS ITV EXPRESSIONS (NEW ROUTINE ONEITV)
VERSION 17-1(23) 11-29-73 BY JRL BUG #PH# BAD BOOLEAN CODE WITHIN FOREACH (FBOUT WAS SUPPRESSED)
VERSION 17-1(22) 11-25-73 BY JRL FEAT %AN% MOVE ITMSTRT(FEAT(%AG%) TO GEN
VERSION 17-1(21) 11-24-73 BY JRL BUG #PD# MAKE SURE LEAP STACK IN GOOD SHAPE BEFORE COND EXPR
VERSION 17-1(20) 11-15-73 BY RHT BUG #PB# NEEDED ALLSTO IN APPLY
VERSION 17-1(19) 11-4-73 BY JRL BUG #OY# DON'T ALLOW MAKE TO TAKE A SET ARGUMENT
VERSION 17-1(18) 10-23-73 BY JRL FEATURE %AG% ITEM OVERLAP STUFF
VERSION 17-1(17) 10-23-73 BY JRL FEATURE %AF% DIFFERENT SET AND LIST MEMBERSHIP BOOLEANS
VERSION 17-1(16) 10-23-73 
VERSION 17-1(15) 10-19-73 BY JRL BUG #OQ# LOP DID NOT KNOW IT WAS A CONSTUCTIVE ITEM EXPR
VERSION 17-1(14) 10-14-73 BY JRL  BUG #ON# AGAIN
VERSION 17-1(13) 10-14-73 BY JRL BUG #ON# ? FOREACH LOCALS BEING STACKED TOO EARLY
VERSION 17-1(11) 10-14-73 BY RHT BUG #OM#  ANOTHER TYPO
VERSION 17-1(10) 10-14-73 BY RHT BUG #OK# ITEMS TREATED WRONG BY REF!ITEM
VERSION 17-1(9) 10-14-73 BY RHT BUG #OJ# SAPPL1 NEEDED A BLKGET
VERSION 17-1(8) 10-5-73 BY JRL MINOR ALLGLOBAL GLITCH FOR DATUM
VERSION 17-1(7) 8-30-73 BY JRL MOD GETITM SLIGHTLY TO MAKE MORE EFFICIENT
VERSION 17-1(6) 8-30-73 BY JRL BUG #NX# HANDLE DATUM(BINDIV,DATUM) CORRECTLY
VERSION 17-1(5) 8-16-73 BY JRL REMOVE REFERENCES TO LEAPSW
VERSION 17-1(4) 8-13-73 BY JRL SAV SEMBLKS FOR BINDIT,ANY,MAINPI,EVTYPE
VERSION 17-1(3) 8-13-73 BY JRL BUG #NR# DRYROT REMOP STCNST IN NEW OF STC
VERSION 17-1(2) 8-5-73 BY JRL BUG #NM# RELATIONS INVOLVING BINDING ITEMVARS
VERSION 17-1(1) 7-26-73 BY RHT JUST CHECKING ON JRL
VERSION 17-1(0) 7-26-73 BY JRL **** VERSION 17 ****
VERSION 16-2(87) 7-14-73 BY RHT ADD EXECS FOR SPROUT APPLY
VERSION 16-2(86) 6-15-73 BY JRL BUG #MR# STRING ARRAY IS NOT A STRING
VERSION 16-2(85) 5-7-73 BY JRL ADD CONELM EXEC
VERSION 16-2(84) 4-2-73 BY JRL MAKE BNDTRP KNOW ABOUT GLOBAL
VERSION 16-2(83) 4-2-73 BY JRL CATCH NEW(ITEMEXPR) GIVE ERRMSG
VERSION 16-2(82) 3-19-73 BY JRL REMOVE POPSET
VERSION 16-2(81) 3-16-73 BY JRL BUG #LU# GLOBAL OPERATIONS
VERSION 16-2(80) 3-12-73 BY JRL REMOVE REFERENCES TO GAG SWITCH
VERSION 16-2(79) 3-8-73 BY JRL COMPILE LENGTH IN-LINE IF POSSIBLE
VERSION 16-2(78) 3-7-73 BY JRL STUFF FOR ALLGLOBAL
VERSION 16-2(77) 3-6-73 BY JRL ADD ALLGLOBAL FEATURE
VERSION 16-2(76) 3-6-73 
VERSION 16-2(75) 2-26-73 BY JRL ANOTHER ATTEMPT TO FIX MP RETURN VALUES
VERSION 16-2(74) 2-26-73 
VERSION 16-2(73) 2-26-73 
VERSION 16-2(72) 2-19-73 BY JRL NOTE SUPERFLUOUS LEAP ROUTINES AS NOOPS
VERSION 16-2(71) 2-12-73 BY JRL ..RVAL NOW AN XX TYPE THING
VERSION 16-2(70) 2-12-73 
VERSION 16-2(69) 2-9-73 
VERSION 16-2(68) 2-7-73 
VERSION 16-2(67) 2-7-73 
VERSION 16-2(66) 2-7-73 BY RHT BUG #LH# ADEPTH PROBLEMS COPPIT,BINCL
VERSION 16-2(65) 2-7-73 
VERSION 16-2(64) 2-7-73 
VERSION 16-2(63) 2-7-73 
VERSION 16-2(62) 2-7-73 BY JRL ROUTINE MPTEMP TO CREATE LOCAL VAR FOR MP
VERSION 16-2(61) 2-6-73 BY JRL ADD ERROR MESSAGE FOR BRACKETED TRIPLE,DERIVED SET IN FOREACH
VERSION 16-2(60) 2-5-73 
VERSION 16-2(59) 2-5-73 BY JRL FIX MP'S FOR SPROUT
VERSION 16-2(58) 2-4-73 BY JRL BUG #LF# ITMREL ALWAYS POPPED STACK INTO AC 4
VERSION 16-2(57) 1-28-73 BY JRL BINDIT AS ALIAS OF UNBND
VERSION 16-2(56) 1-28-73 BY JRL ADD NULL!CONTEXT
VERSION 16-2(55) 1-23-73 BY JRL ANY NOW PREDECLARED "ITEM" FLUSH FROM COMPILER
VERSION 16-2(54) 1-22-73 BY JRL BUG #LE# HANDLE FOREACH ?X|X XOR X EQV FOO
VERSION 16-2(53) 1-22-73 
VERSION 16-2(52) 1-9-73 BY JRL  BUG #KZ# DATUM SHOULD TURN OFF OWN BIT
VERSION 16-2(51) 12-4-72 BY JRL ADD O EQV V DERIVED SET
VERSION 16-2(50) 12-1-72 BY JRL BUG #KO# CVLIST SHOULD MARK RESULT AS LIST
VERSION 16-2(49) 12-1-72 
VERSION 16-2(48) 11-26-72 BY JRL ADD POTENTIAL ANY XOR ANY EQV ANY SEARCH
VERSION 16-2(47) 11-26-72 BY JRL BUG #KN# LTYPCK SHOULD RETURN IP FOR ITEM PRIMARY
VERSION 16-2(46) 11-21-72 BY JRL BUG #KJ# ECHK WITH ITEMVAR GAVE BAD TBITS
VERSION 16-2(45) 11-13-72 BY JRL COMPILE BETTER CODE FOR PROPS
VERSION 16-2(44) 11-10-72 BY JRL ADD EXEC FOR PROPS
VERSION 16-2(43) 11-8-72 BY JRL MAKE BOOLEAN CODE LIKE BOOLEAN FNS
VERSION 16-2(42) 11-8-72 BY JRL CHANGE ISIT TO PRODUCE INTEGER RATHER THAN BOOLEAN
VERSION 16-2(41) 11-7-72 BY JRL ADD BINDING ASSOCIATIVE BOOLEAN
VERSION 16-2(40) 11-6-72 BY JRL BUG #KA# MAKE SURE REMEMBER PARAMS IN CORE
VERSION 16-2(39) 11-6-72 BY JRL JUST GET CNST SEMBLK FOR CVN(DECL ITEM)
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 
;
SUBTTL	Leap Generators.
	LSTON	(LEAP)
	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 in FOREACH SATISFIER BLOCK
CDISP __ 100000			;THIS PARM NEEDS A DISPLAY CALCULATION
MPPAR	__ 200000		;THIS IS ? FORMAL 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 ********

	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. FOR BRACKETED
					;TRIPLE OR DERIVED SET WITHIN FOREACH
	STACKET	__	2000		;THIS THING IS REALLY STACKED ....
	LPNUL	__	1000		; "PHI" LPSET ON ALSO
;FBIND AND QBIND NOW DEFINED IN HEAD
;	FBIND	__	100		;BIND ITVMR AS IN BIND X XOR Y EQV Z
;	QBIND	__	200		;? ITMVR AS IN BIND X XOR Y EQV Z

	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 		;0--ORDINARY TRIPLE SEARCHES

	RUNTIM	NOOP1,7			;1-7 NO LONGER USED.

	RUNTIM	STSRC,2			;THE SET SEARCHES ?
	RUNTIM	FRCHGO			;12--BEGINNING OF FOREACH LIST.
	RUNTIM	FRCHPOP			;13--POP SATISFIERS INTO CORE
	RUNTIM	FRLOOP			;14--LOOP BACK FOR MORE (FOREACH STATE.)
	RUNTIM	FRFAL			;15--BOOLEAN FALSE.
GLO	RUNTIM	MAKE			;16--MAKE
GLO	RUNTIM	BMAKE			;17--BRACKETED TRIPLE MAKE.
GLO	RUNTIM	ERAS			;20--ERASE ROUTINES.

	RUNTIM	NOOP2,7			;21-27 NO LONGER USED

GLO	RUNTIM	ISTRIP			;30-BOOLEAN "IS THIS A BRACKETED TRIPLE"
GLO	RUNTIM	SELECT,3		;31-33--SELECTORS.
	RUNTIM	CORPOP			;34 --MOVE CORE TO SATISFIER TABLE
GLO	RUNTIM	LDERIV,3		;35-37--DERIVED SETS DURING FOREACH LISTS.
GLO	RUNTIM	DERIV,3			;40-42--DERIVED SETS, NOT DURING FOREACH.
GLO	RUNTIM	DELETE			;43 -DELETE THIS ITEM.
GLO	RUNTIM	NEWITM			;44--MAKE A NEW ONE.
GLO	RUNTIM	NEWARITH		;45--MAKE A NEW ARITHMETIC TIEM.
GLO	RUNTIM	NEWRY			;46--MAKE A NEW ARRAY ITEM.
	RUNTIM	FRELS			;47--RELEASE THE FOREACH BLOCK
	RUNTIM	STPUT			;50--PUT
	RUNTIM	STREM			;51--REMOVE
	RUNTIM	SIP			;52--SET MAKERS( SETO SETC )
;; %AF% ! (1 OF 3) DIFFERENT ROUTINES FOR MEMBERSHIP BOOLEANS
	RUNTIM	LSTIN			;53--BOOLEAN A IN LIST?
	RUNTIM	SETCUNT			;54--LENGTH OF A SET OR LIST
	RUNTIM	STUNT			;55--COP OF A SET
	RUNTIM	STUNI			;56--SET UNION
	RUNTIM	STINT			;57--SET INTERSECTION
	RUNTIM	STMIN			;60--SET SUBTRACTION.
	RUNTIM	STORE			;61--STORE A SET OR ITEM
	RUNTIM	STORBUTDONTREMOVE	;62--EXPRESSION STORE(LEAVE ON STACK)
;; %AF% ! (2 OF 3) DIFFERENT ROUTINES FOR MEMBERSHIP BOOLEANS
	RUNTIM	STIN			;63--BOOLEAN A IN SET?
	RUNTIM	NOOPA			;64--NO-OP USED TO BE POP OFF SET
	RUNTIM	SETREL,6		;65-72 SET RELATIONS.
GLO	RUNTIM	ISIT			;73--A XOR O EQV V ?

	RUNTIM	NOOP4,7			;74-102 NO LONGER IN USE

GLO	RUNTIM	BRTRIP			;103-[A XOR O EQV V] AND LEAVE ON STACK.

	RUNTIM  NOOP5,7			;104-112 NO LONGER IN USE

GLO	RUNTIM	ITMRY			;113--THE TWO GUYS FOR MARKING ARRAYS.
	RUNTIM	ITMYR			;114
	RUNTIM	STLOP			;115--LOP OFF AN ITEM FROM A SET.
GLO	RUNTIM	BNDTRP			;116--BIND X XOR BIND Y EQV BIND Z (BOOLEAN)
	RUNTIM	SETCOP			;117--COPY A FORMAL SET (ADDRESS IN TAC1)
	RUNTIM	SETRCL			;120--RECLAIM A FORMAL SET ( "" )
	RUNTIM	CATLST			;121--CONCATENATE TWO LISTS
	RUNTIM  PUTAFT			;122--PUT AFTER ITEM
	RUNTIM	PUTBEF			;123--PUT BEFORE ITEM
	RUNTIM	SELFET			;124--SELECT LIST ELEMENT
	RUNTIM	TSBLST			;125--TO SUBLIST
	RUNTIM	FSBLST			;126--FOR SUBLIST
	RUNTIM	SETLST			;127--TRANSFORM LIST TO SET CVSET
	RUNTIM	RPLAC			;130--REPLACE ELEMENT OF LIST
	RUNTIM	REMX			;131--REMOVE INDEXED
	RUNTIM	REMALL			;132--REMOVE ALL 
	RUNTIM  PUTXA			;133--PUT AFTER INDEXED
	RUNTIM	PUTXB			;134--PUT BEFORE INDEXED
	RUNTIM	LSTMAK			;135--ADD TO TEMPORARY LIST (LISTO LISTC)
	RUNTIM	MATCAL			;136--CALL A MATCHING PROCEDURE
	RUNTIM	STK4VL			;137--STACK A ? LOCAL
	RUNTIM	STKQPR			;140--STACK A ? LOCAL AS AN MP ARGUMENT

;;FOLLOWING FOR LPCALLS FROM OTHER SOURCE FILES

^LCATLS __ LCATLS			;RETURN MUST COPY RESULT
^LSTKQP __ LSTKQP			;CALARG-STACKS QUES PARAMS
^LFRLOO __ LFRLOO			;LOOP CODE MUST BE ABLE TO LOOP BACK
^LFRELS __ LFRELS			;DONE ETC, MUST BE ABLE TO EXIT FOREACH
^LITMRY	__ LITMRY			;ARRAY DECLARATION
^LITMYR	__ LITMYR			;ARRAY DECLARATION
^LSETCO __ LSETCO			;COPY SET FORMALS
^LSETRC __ LSETRC			;RECLAIM SET FORMALS
ZERODATA (LEAP VARIABLES)

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

;MPVSTK A QSTACK OF XWD ?TABLE ADDR,STATIC LEVEL OF MATCH PROC
^^MPVSTK:0

;MPQSTK: A QSTACK FOR ? ITEMVAR PARAMS TO MATCHING PROCEDURE
^^MPQSTK: 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.
^^BYTES: 0

?FFSAVE: 0	;SAVE FF SOMETIMES

;; #PX# (1 OF 13)
;LEADUM -- ZERO WORD BEFORE LEABEG FOR STACK UNDERFLOW CHECKING
?LEADUM: 0
;; #PX
;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

;DATBITS + HOLDS TYPE BITS FOR DATUM CONSTRUCT
DATBITS: 0
;HLDCNT - COUNT OF ?FOREACH LOCALS IN SEARCH
;HLD- SEMBLK POINTERS FOR ABOVE, TO HANDLE MISERABLE
; 	FOREACH ?X | X XOR X EQV FOO DO
?HLDCNT: 0
?HLD: BLOCK 3

;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

;GLBSTK A QSTACK TO HANDLE GLOBAL CONSTRUCTS.
^^GLBSTK: 0

;ALLGLO -- indicates all leap operations are to be considered global
^^ALLGLO: 0

;; \UR#6,UR#7\  VARS FOR VERIFY!DATUM, OVERLAP!OK

;OKLPOV - indicates no WARNING at runtime for item overlap
^^OKLPOV: 0

; CHEDAT - on if emitting check on datum type

^^CHEDAT: 0
;; \UR#6\

;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
NULLCN: 0				;DUMMY SEMANTIC BLOCK FOR NULL!CONTEXT
^^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

;BNDFLG -FLAG ON IF STCHK HAS SEEN A BIND
BNDFLG: 0

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


DEFINE NAMEIT(NAME,TYPE,ITNO,SBNAME) <
	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)
	>
IFDIF <SBNAME><>,<
	MOVEM	LPSA,SBNAME
>
>

;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/
EV2NAM: XWD	0,12
	POINT	7,.+1
	ASCII	/EVENTTYPE/
ANYNAM: XWD	0,3
	POINT	7,.+1
	ASCII	/ANY/
BINNAM: XWD	0,6
	POINT	7,.+1
	ASCII	/BINDIT/

ZERODATA(LEAP ITEM SEMBLK PTRS)
^UBSBLK: 0; BINDIT
^EVSBLK: 0; EVTYPI
^ANSBLK: 0; ANY
^MPSBLK: 0; MAINPI
ENDDATA

^^LEPINI:
	QPUSH	(LOCST)
	QPOP	(LOCST)
	MOVE	A,LOCST
	MOVEM	A,LOCBEG
	MOVEI	A,LEABEG-1
	MOVEM	A,LEAPSK
;; %AG% ITEM!START STUFF
	MOVE	A,[XWD 11,10]	;DEFAULT ITEM!START IS 11
	MOVEM	A,ITEMNO	;LEAVE SOME FOR LEAP TO PLAY WITH.
GLOC <
	MOVEI	A,7777		;MAXIMUM GLOBAL ITEM
	MOVEM	A,GITEMNO	;AND RECORD IT.
>;GLOC
	QPUSH	(MPSTAK,[0])
	QPUSH	(ITMSTK)
	QPOP	(ITMSTK)
	MOVE	A,ITMSTK
	MOVEM	A,ITMBEG		;SAVE FOR USING QTAKE
	QPUSH	(MPQSTK,[0])		;FLAG TO MARK END OF MPQSTK
	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)
	GETBLK	(NULLCN)		;DUMMY SEMBLK FOR NULL!CONTEXT
	MOVEI	A,FLOTNG!SET		;CONTEXT
	MOVEM	A,$TBITS(LPSA)
	POPJ	P,

^^LPNAME:NAMEIT  (UBNAME,ITEM,UNBND,UBSBLK)	;DECLARE PREDECLARED IDENTIFIERS
	NAMEIT	(MINAME,ITEM,MAINPI,MPSBLK)
	
	NAMEIT	(NINAME,ITEM,NIC)
	NAMEIT	(EVNAME,ITEM,EVTYPI,EVSBLK)
	NAMEIT	(EV2NAM,ITEM,EVTYPI)
	NAMEIT	(ANYNAM,ITEM,0,ANSBLK)
	NAMEIT	(BINNAM,ITEM,UNBND)		;AN ALIAS FOR UNBOUND
	MOVEI	TEMP,RESYM			;SO DONES WILL WORK CORRECTLY
	MOVEM	TEMP,VARB
	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 ACS
	POP	P,A			;GET FLAG WORD BACK AGAIN
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
	SKIPN	ALLGLO		;EVERYTHING GLOBAL??
	CAIE	B,0			;PREFACED BY GLOBAL?
	TLO	A,GLBSRC		;YES.
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,LSTKCK,QUESET,FRESET
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:				;CALLED 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 ; WE MUST BE INSIDE A BOOLEAN SINCE
					;LPPROG IS OFF, THEREFORE CAN'T USE
					;UNBOUND LOCALS.
JUSTAK:	HRRZI	A,(PNT)
	TLO	A,RETRV!CNSTR		;TURN ALL THESE ON INITIALLY.
	TLNE	SBITS,LPFRCH!FREEBD	;A LOCAL IN THIS FOREACH?
	TLO	A,BOUND			;SAY BOUND 
	TLNE	SBITS,LPFREE		;A FREE LOCAL?
	TLC	A,BOUND!BINDING		;SAY  BINDING and 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,FREEBD		;A ? LOCAL
	TLZ	A,BINDING		;A FREE ? LOCAL IS NEITHER BOUND NOR BINDING
	TRNE	TBITS,ITEM!ITMVAR	;WHICH LEAP TYPE?
	JRST	[TLO	A,LPITM			;AN ITEM
		 JRST TYPKWN]
	TLO	A,LPSET			;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,

^QUESET:SKIPA	A,[QBIND,,0]		;A ? TYPE OF ASSOCIATIVE BOOLEAN
^FRESET: 				;AN ASSOCIATIVE BOOLEAN OF BIND FORM
	HRLZI	A,FBIND			;THE BIT
	TLNE	FF,LPPROG		;INSIDE FOREACH
	ERR	<BIND  OR ? NOT VALID WITHIN FOREACH>,1
	ORM	A,@LEAPSK
	POPJ	P,
;; #PX# (2 OF 13) ADD SOME STACK HEIGHT ERROR CHECKING
^LSTKCK:
	HRRZ	TEMP,LEAPSK
	CAIE	TEMP,LEABEG-1		;NON-EMPTY STACK OR UNDERFLOW?
;;#QN# ! 1 OF 3
	ERR	<DRYROT:LEAPSK>,1,.LSKFX
.TSTAD:
	SKIPN	ADEPTH			;ALSO CHECK ADEPTH, SDEPTH
	SKIPE	SDEPTH
;;#QN# ! 2 OF 3
	ERR	<DRYROT:ADEPTH,SDEPTH>,1,.DPTFX
.DPTOK:
GLOC <
	SKIPE	LEPGLB			;COUNT OF NUMBER OF GLOBALS SEEN
	ERR	<GLOBAL SAID TOO MANY TIMES>,1
	SETZM	LEPGLB
>;GLOC
	POPJ	P,
;; #PX#

;;#QN# 3 OF 3 MAKE THESE ERRORS A BIT MORE RECOVERABLE
.LSKFX:	MOVEI	TEMP,LEABEG-1		;FIX STACK
	MOVEM	TEMP,LEAPSK
	JRST	.TSTAD
.DPTFX:	SETZM	ADEPTH
	SETZM	SDEPTH
	JRST	.DPTOK
;;#QN#
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 XOR X EQV [B XOR Y EQV Z] DO  .....

GETS CHANGED INTO --

FOREACH X,Y,Z | [B XOR Y EQV Z]=Q AND A XOR X EQV 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
;; #ON# (1 OF 2) DON'T PREMATURELY STACK ? FOREACH LOCALS
	MOVE	PNT,(D)
	CAIL	D,LEABEG	;IS REALLY STACKED.
	TLNE	PNT,STACKED	
	POPJ	P,		;ALREADY STACKED
	MOVE	TEMP,$SBITS(PNT)
	TLNE	TEMP,LPFREE
	TLNN	TEMP,FREEBD
	JRST	STAKIT
	POPJ	P,
;; #ON#


;; #JO# BY JRL 10-8-72 ROUTINE TO TAKE AE TO EITHER IP OR SP
^LTYPCK:			;MAKE AE GO TO EITHER SP OR IP
;; #PX# (3 OF 13) SOME REDUNDANT LEAPSK CHECKING
	SKIPN	A,@LEAPSK	;TOP OF STACK ENTRY
	ERR	<DRYROT:LEAPSK UNDERFLOW>,1
;; #PX#
	MOVE	B,%NIP		;ASSUME ITEM
;; #KN# 11-26-72 FOLLOWING INSTR WAS ERRONEOUSLY TLNN
	TLNE	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	<LIST EXPRESSION REQUIRED>,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
;; ##PX# (4 OF 13)
	HRRZ	TEMP,LEAPSK
	SUBI	TEMP,(D)
	CAIGE	TEMP,LEABEG-1
	ERR	<NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
	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			;ALL BITS ON (RETRV,LPITM, ETC)
	SETZM	TBITS2			;THE BITS FOR THE CONTROL WORD.
	MOVE	PNT2,[POINT 3,TBITS2,8]	;TO GET ATTPOS ON AN IDPB....
	SETZM	BNDFLG			;NO FBIND YET
POP1:	CAILE	D,(SBITS2)		;DONE?
	JRST	POP1B			;YES
	MOVE	A,(D)			;TOP OF STACK.
	TLNN	A,FBIND!QBIND
        JRST    PP1A
	SETOM	BNDFLG			;HAVE SEEN A BIND.
	TLO	A,BINDING		;THIS IS BEING BOUND
PP1A:	HLRZ	C,A			;GET LEFT HALF BITS.
	IDPB	C,PNT2			;STORE THE THREE BITS AWAY IN "BYTES"
	ANDB	A,B			;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,BINDINGATTPOS
	TRO	TBITS2,1		;START TO MAKE UP AN INCREMENT.
	TLNE	TBITS2,BINDINGOBJPOS
	TRO	TBITS2,2
	TLNE	TBITS2,BINDINGVALPOS
	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
	SKIPE	BNDFLG			;ANY BIND OPS?
	TLO	A,FBIND			;YES
	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.
					;SOMETHING BEFORE THE PARAMETERS
					;IS STACKED. WE MUST POP OFF EVERYTHING
					;SINCE WITHIN FOREACH NOTHING CAN BE
					;REMEMBERED ON THE STACK OVER CALL TO LEAP
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
;; #TU# (1-18-75) JRL (1 OF 2) MAKE SURE TBITS LOOKS LIKE A SET,LIST OR ITEMVA TEMP
	MOVEI	TBITS,ITMVAR		;ASSUME ITMVAR
	TLNE	A,LPITM			;CHECK ASSUMPTION
	JRST	POPITP			;ASSUMPTION WAS CORRECT
	MOVEI	TBITS,SET		;NOW ASSUME SET
	TLNE	A,LPXISX		;CHECK THIS ASSUMPTION
	MOVEI	TBITS,SET!LSTBIT	;ASSUMPTION WAS WRONG
POPITP:
;; #TU#
	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:	CAMG	D,LEAPSK		;ALL DONE?
	JRST	POP9A			;NO.
;; #LE# DON'T TURN OFF LPFREE TOO EARLY
	SKIPN	B,HLDCNT		;ANY ?LOCALS?
	JRST	POP0			;NO -- ALL DONE
	SETZM	HLDCNT			;FOR NEXT TIME
	MOVE	SBITS,[LPFREE,,0]
	MOVE	PNT,HLD-1(B)		;THE LAST ONE.
	ANDCAM	SBITS,$SBITS(PNT)	;TURN OFF LPFREE BIT
	SOJG	B,.-2
	JRST	POP0			;ALL DONE WITH THIS KLUDGE
POP9A:	PUSH	P,POPRET		;IN LINE CALL.
STAKIT:	MOVE	PNT,(D)			;GET STACK ELEMENT.
;; #PX# (5 OF 13) SOME REDUNDANT? STACK HEIGHT CHECKING
	HRRZ	TEMP,D
	CAIGE	TEMP,LEABEG		;VALID STACK ENTRY?
	ERR	<NON LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
	TLOE	PNT,STACKET		;ALREADY STACKED?
POPRET:	POPJ	P,POP11			;DONE.
;; #ON# (2 OF 2) DON'T STACK ? FOREACH LOCALS UNLESS REALLY INSIDE FOREACH
	TLNN	FF,LPPROG
	JRST	[MOVE	TEMP,$SBITS(PNT)
		 TLNN	TEMP,LPFREE
		 JRST	.+1
		 POPJ	P,]
;; #ON#
	MOVEM	PNT,(D)
	PUSH	P,POPAA			;IN LINE CALL.
PREPAR:	PUSHJ	P,GETAD		;GET GOOD BITS.
	TLNE	PNT,FBIND!QBIND		;BIND ITMVR?
	JRST	BINDQF
	TLZ	SBITS,LPFREE		;A FREE LOCAL?
	TLNN	SBITS,FREEBD		;DON'T SAVE YET IF FREEBD
					;BECAUSE OF CONSTRUCT X XOR X EQV Y
	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
;; #TU# (2 OF 2) JRL - STACK CAN SOMETIMES CHANGE D
	PUSH	P,D
	GENMOV	(STACK,0)		;WILL CAUSE REMOP TOO.
	POP	P,D
;; #TU#
	POPJ	P,
POP11:	MOVE	PNT,(D)			;GET ITEMVAR SEMBLK BACK
	MOVE	SBITS,$SBITS(PNT)	;GET SBITS BACK
	TLNN	SBITS,LPFREE		;IF STILL FREE MUST BE FREEBD
	AOJA	D,POP90			;LOOP BACK
	TLNN	SBITS,FREEBD		;ERROR CHECK
	ERR	<DRYROT - POP11>
	AOS	A,HLDCNT
	MOVEM	PNT,HLD-1(A)		;-1 SINCE INDEX STARTS AT ZERO
	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
BINDQF: PUSH   P,PNT		;SAVE LEFT HALF BITS
	GENMOV (INCOR)			;MAKE SURE IN CORE
	HLL	PNT,(P)			;IN CASE INCOR CHANGED PNT.
	TLNE	PNT,QBIND	
	JRST	[SETOM MPFLAG
		 HRLI PNT,POTUNB
		 PUSHJ	P,FTRADR	;WANT POTUNB IN LEFT HALF
		 SETZM MPFLAG
		 JRST BINDQ1]
	HRRZS	PNT			;SINCE ADRINS WILL USE BITS LH
	PUSHJ	P,ADRINS		;WILL STACK THE ADDRESS
BINDQ1:	HLL	PNT,(P)			;GET LEFT HALF BITS BACK
	SUB	P,X11			;POP OFF OLD PNT
	POPJ	P,

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.
	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
	OPTSYM	%$FORE		;FOREACH 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.
	TLNE	TBITS,REFRNC		;A REFERENCE PARAMETER?
	TRO	A,20			;PUT ON INDIRECT BIT
	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
	HRLI	A,JSFIX!NOUSAC		;BITS FOR EMITER
	TLNN	TBITS,REFRNC!VALUE	;A FORMAL PARAMETER?
	JRST	SIMIT2			;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	SIMIT2
SIMITM:	HRLI	A,NOUSAC		;STANDARD CASE
SIMIT2:
	MOVSS	A			;RIGHT IS LEFT AND VICE VERSA
	PUSHJ	P,EMITER
	JRST	ANO			;LOOP UNTIL DONE.




^^QLOCAL:
	GETSEM (0)			;A ? FOREACH LOCAL
	TLNE	SBITS,LPFRCH!FREEBD	;ALREADY IN LIST?
	ERR	<SAME LOCAL ITEMVAR IN BINDING LIST>,1
	TLO	SBITS,FREEBD
	MOVEM	SBITS,$SBITS(PNT)
	POPJ	P,
;; %BD% (1 OF 3) ALLOW FOREACH'S WITHOUT BINDING LISTS
^DUMITV:				;ALLOW FOREACH SUCH THAT
	MOVEI	TBITS,ITMVAR		;GET AN ITEMVAR CORETMP
	PUSHJ	P,GETCRTMP
;; #RC# ! LOAD SEMBLK INTO PNT
	MOVE	PNT,LPSA		;GETCRTMP RETURNS IN LPSA NOT PNT
	PUSHJ	P,ITVCMN
	MOVE	SBITS,$SBITS(PNT2)
	TLZ	SBITS,LPFREE		;MARK AS NOT FREE
	MOVEM	SBITS,$SBITS(PNT2)
	POPJ	P,
^ENTITV:				;RECORD THE NAME OF A LOCAL.
	GETSEM	(1)		;SEMANTICS OF ITMVAR.
ITVCMN:
;; %BD%
	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 MEMORY
	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.
;; %BD% (2 OF 2) !
	QPUSH	(LOCST,PNT2)	;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.
;; #PH  DON'T SUPPRESS FBOUT IF LH(B) MERELY NEG (REENTRANT COMPILATIONS)
	HLRE	TEMP,B
	AOJE	TEMP,.+2	;If BE evaluates to FALSE no JRST TRUE
;; #PH#
	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 "
;; #PX# (6 OF 13)
	SKIPN	A,@LEAPSK	;SEE IF DUMMY ITEM(FROM DERIVED SETS)
	ERR	<NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
	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 XOR Y EQV 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)		;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)			;GET 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)
;; %BD% (3 OF 3)
	TLNE	SBITS,CORTMP		;A PHONY?
	JRST	[PUSH	P,SP		;JUST TO BE SAFE
		 PUSH	P,B		;DITTO
		 PUSHJ	P,REMOPL	;REMOP THE CORTMP
		 POP	P,B
		 POP	P,SP
		 JRST	.+1]
;; %BD%
	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)		;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.
					;NOTE DUMMY NUMBER IN RIGHT HALF;
	JRST	BFIN			;ALL DONE.



NOFR:	SKIPE	MKFLAG			;IN A MAKE STATEMENT?
	JRST	MKB			;YES
	TLNE	A,FBIND	
	ERR	<BIND NOT VALID WITH BRACKETED TRIPLES>,1
	RETCHK				;RETRIEVAL TYPES NECESSARY
	LPCALL	(BRTRIP)		;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.
	TLNE	A,FBIND
	ERR	<BIND OR ? NOT VALID IN DERIVED SETS>,1
	MOVE	B,(P)			;GET THE PARSER INDEX.
	CAIN	B,2			;IF THIS KINDS
	ERR	<P * Q NOT IMPLEMENTED>,1
	MOVEI	A,BINDING
	JRST	DERNDX(B)		;WHICH DERIVED SET
DERNDX:	JRST	DERXOR			;A  O
	JRST	DERQUOT			;A ' V
	JRST	DERXOR			;WILL TREAT A*O AS AO
; O EQV V
	LDB	C,[POINT 9,BYTES,17-VALPOS];WILL HAVE TO SHIFT BITS STACKCHECK
					;COMPUTED
	LSH	C,-3			;ATT shifts to OBJ shifts to VAL
	DPB	C,[POINT 6,BYTES,17-VALPOS]
	DPB	A,[POINT 3,BYTES,17-ATTPOS]
	SOS	(P)			;INDEX SHOULD BE 2
	JRST	NOFUNQ
; A ' V
DERQUOT:LDB	C,[POINT 3,BYTES,17-OBJPOS]
	DPB	C,[POINT 3,BYTES,17-VALPOS]
	DPB	A,[POINT 3,BYTES,17-OBJPOS]
	JRST	NOFUNQ			;SAFE.
; A  O
DERXOR:	DPB	A,[POINT 3,BYTES,17-VALPOS] ;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 XOR ( C XOR D) EQV X INTO
					;    C XOR D EQV Y AND  A XOR Y EQV 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

GETITM:				;LOAD TOP OF LEAPSK INTO AC 3
;; #PX# (7 OF 13)
	SKIPN	PNT,@LEAPSK	;GET THE LAST THING PUT ON STACK.
	ERR	<NON LEAP ARG TO LEAP EXPRESSION>,1
;; # PX#
	SOS	LEAPSK		;DECREMENT STACK COUNTER.
	TLNN	PNT,LPITM	;HAD BETTER HAVE ITEM
	ERR	<DATUM AND PROPS ONLY VALID FOR ITEM EXPR>,1
	TLNE	PNT,LPDMY
	ERR	<PROPS WON'T FOR BRACKETED TRIPLE WITHIN FOREACH>,1
	SETZM	SBITS		;ZERO OUT SBITS
;; \UR#x\ ! marked by JFR 11-24-76
        SETZM   TBITS
	TRNE	PNT,-1		;IF WE HAVE A SEMBLK
	PUSHJ	P,GETAD		;GET SEMANTICS OF ITEM.
	SKIPN	TEMP,BITS		;FOR DATUM(IT,TYPE)
	MOVE	TEMP,TBITS
	MOVEM	TEMP,DATBITS
REC <
	TRNE	TEMP,PNTVAR
	TRNE	TEMP,777777-(PNTVAR!GLOBL)
	JRST	GTIT.0			;NOT A RECORD
	PUSH	P,TEMP			;PARANOIA
	TRNN	PNT,-1			;DID HE GIVE ME AN ITEM
	HLRZ	TEMP,$ACNO(PNT)		;BITS MAY COME FROM THERE
	SKIPE	QRCTYP			;BUT HE MAY HAVE SAID EXPLICITLY
	HRRZ	TEMP,QRCTYP		;
	HRRZM	TEMP,RCLASS		;FOR THE IMMINENT MARK
	POP	P,TEMP
GTIT.0:

>;REC
	TLNE	SBITS,LPFREE
	ERR	<DATUM OR PROPS 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
	PUSHJ  P,CHKSAT
	MOVEI	D,3		;WE NEED THE ITEM IN AC 3
	TLNN	PNT,STACKET
	JRST	[
;;  #NX# WASN'T DOING RIGHT THING BY DATUM(BINDIV,STRING) MAKE SURE
;		GOOD TBITS ARE USED.
		 GENMOV (GET,SPAC!GETD);
		 JRST GOTEN]
	HRL	C,D		;AC NUMBER TO GET IT IN.
	EMIT	<POP RP,NOUSAC!NORLC!USADDR> ; IT WAS ON THE REAL STACK.
	SOSA	ADEPTH		;AND BOOKKEEP THIS.
GOTEN:
	PUSHJ	P,REMOP		;REMOVE THE ITEM NUMBER.
	POPJ	P,

^DDATA:
^LDATA:	TLO	FF,FFTEMP	; GET ADDRESS OF DATUM ENTRY.
				;IF FFTEMP IS OFF, GET VALUE OF DATUM ENTRY.
	PUSHJ	P,GETITM
;; \UR#6\ VERIFY DATUMS.
        SKIPE   CHEDAT		; CHECKING DATUMS?
        JRST    [ 
		HRL C,PCNT
		SKIPN   NOEMIT
                EXCH    C,LIBTAB+RINFTB
                EMIT    (<LDB 14,NOUSAC!USADDR!NOADDR>)
		MOVE A,DATBITS
	        PUSHJ P,ITMTYP
                HRLZ   C,A
                EMIT   (<CAIE 14,NOUSAC!USADDR!NORLC!NOADDR>)
                XCALL  ($$DERR)
                JRST .+1]
;; \UR#6\
	PUSHJ	P,GETAN0	;BUT GET ANOTHER AC FOR DATUM.
GLOC <
	QPOP	(GLBSTK)	;IF GLOBAL, THEN USE THE OTHER ONE.
	SKIPN	ALLGLO
	SKIPE	A		;USE GLOBAL DATUM?
	JRST	[HRLI	C,7776	;MAXIMUM ITEM.
		 EMIT	(<CAIG 3,NOUSAC!USADDR!NORLC>)
		 HRLI	C,6000	;GLOBAL BREAK
		 EMIT	(<CAIG 3,NOUSAC!USADDR!NORLC>)
		 XCALL	(DATERR)
		 HRL	C,PCNT	;CHAIN INSTRUCTIONS.
		 SKIPN	NOEMIT
		 EXCH	C,LIBTAB+RGDATM ;GLOBAL DATUM
		 JRST 	DATGO]
>;GLOC
	HRL	C,PCNT
	SKIPN	NOEMIT
	EXCH	C,LIBTAB+RDATM	;WORD TO INDIRECT THROUGH.
DATGO:	
	MOVE 	TBITS,DATBITS
	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,-1SAFE	;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,DBLPRC
	TLNE	FF,FFTEMP
	 JRST	.+2		;NOT DOUBLE, OR ADDR
	HRLI	A,(<DMOVE @>)	;TO FETCH DOUBLE VALUE
	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.
;; #KZ# TURN OFF OWN BIT DATUM(OWNARRAY[I])
	TLZ	TBITS,FORMAL!OWN!MPBIND;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.
NOREC <				;CAN FLUSH NOW SINCE ADDED CHECK FOR ARTEMP IN ARRAY
	HRROS	$ACNO(PNT)	;FOR ARRAYS $*$*$*$*$**$*$*$*$*$**$*
>;NOREC
	POP	P,TBITS
	POP	P,TEMP
	TLNE	TBITS,SBSCRP	;IF AN ARRAY DATUM,
NOREC <

	MOVEM	TEMP,$VAL(PNT)	;SEE ARRY FOR THE PLACE THIS IS USED.
				;IT IS FOR MAKING A NAME FOR THE ARRAY ERROR UUO.
>;NOREC
REC <
	HRLZM	TEMP,$VAL2(PNT) ;PUT THIS IN A DIFFERENT SPOT. ARRAY ERR UUO NEEDS
	HLRZ	TEMP,$ACNO(TEMP);RECORD CLASS INFO
	TRNE	TBITS,PNTVAR	;ADD MARKING IF A RECORD
	HRLM	TEMP,$ACNO(PNT)	;REMEMBER REC TYPES IF APPLIC
>;REC
	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,
DSCR - PPSTO,EPPSTO,GETPROP  execs for PROPS

^PPROP: SOS	B,LEAPSK	;GET ITEM
;; #PX# (8 OF 13)
	SKIPN	PNT,1(B)	;TOP ELEM OF LEAP STACK
	ERR	<NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
	TLNN	PNT,LPITM	;BETTER BE ITEM
	ERR	<PROPS REQUIRES ITEM EXPR ARGUMENT>,1
	TLNE	PNT,STACKED	;STACKED,HOPE NOT!
	JRST	WSSTKD		;TOO BAD
	HRRZM	PNT,GENRIG	;NO JUST PUT IT DOWN
	POPJ	P,
WSSTKD:	MOVEI	D,3		;WANT AC 3
	PUSHJ	P,STORZ		;MAKE SURE WE CAN HAVE IT
	HRLI	C,3
	EMIT	<POP RP,USADDR!NOUSAC!NORLC> ; POP IT OFF
	SOS	ADEPTH		;NO LONGER ON STACK
	MOVEI	TBITS,ITMVAR	;RESULT IS ITEMVAR
	PUSHJ	P,MARKME
	HRRZM	PNT,GENRIG
	POPJ	P,

^EPPSTO:TLOA	FF,FFTEMP	;EXPR STORE
^PPSTO:	TLZ	FF,FFTEMP	;JUST STORE
	MOVE	PNT,GENLEF+3	;THE ITEM
	MOVEI	D,3		;WANT ITEM IN AC 3
	GENMOV  (GET,SPAC!GETD)
	PUSHJ	P,REMOP		;REMOP THE TEMP IF NEC.
	HRROS	ACKTAB+3	;PROTECT AC 3
	MOVE	PNT,GENLEF+1	;THE VALUE TO BE STORED
	HRRI	B,INTEGR	;HAD BETTER BE INTEGER
	GENMOV	(GET,INSIST!POSIT!GETD)
	TLNN	FF,FFTEMP	;EXPR STORE?
	JRST	STPROP		;NO.
	PUSHJ	P,MARKINT	;MARK AS TEMP
	MOVEM	PNT,GENRIG+1	;THE RESULT
	JRST	.+2		;SKIP OVER REMOP
STPROP:	PUSHJ	P,REMOP
	HRL	C,PCNT		;FOR FIXUP TO PROPS
GLOC <	QPOP	(GLBSTK)	;GLOBAL PROPS?
	SKIPE	ALLGLO
	JRST	[SKIPN NOEMIT
		 EXCH C,LIBTAB+RGPROPS
		 JRST PPDPB]
	JUMPN	A,[SKIPN NOEMIT
		   EXCH C,LIBTAB+RGPROPS	;FIXUP TO GPROPS
		   JRST PPDPB]
>;GLOC
	SKIPN	NOEMIT
	EXCH	C,LIBTAB+RPROPS ;FIXUP TO PROPS
PPDPB:	EMIT	<DPB ,USADDR>	;STORE VALUE
	HRRZS	ACKTAB+3	;UNPROTECT AC 3
	POPJ	P,

^GTPROP:
	MOVE	PNT,GENLEF+1	;ITEM INTO AC 3
	MOVEI	D,3
	GENMOV	(GET,SPAC!GETD)
	PUSHJ	P,REMOP		;REMOP THE TEMP
	HRL	C,PCNT		;FOR FIXUP TO PROPS
GLOC <
	QPOP	(GLBSTK)
	SKIPE	ALLGLO
	JRST	PPAGLO
	JUMPN	A,[PPAGLO:SKIPN NOEMIT
		   EXCH C,LIBTAB+RGPROPS
		   JRST GTPR2]
>;GLOC
	SKIPN	NOEMIT
	EXCH	C,LIBTAB+RPROPS
GTPR2:	PUSHJ	P,GETAC		;AC FOR RESULT
	EMIT	<LDB ,USADDR>
	PUSHJ 	P,MARKINT	;MARK AS INTEGER
	MOVEM	PNT,GENRIG+1
	POPJ	P,
; MAKE AND ERASE
DSCR MAKIT, ERAS, MKSET, MAK
PRO MAKIT ERAS MKSET MAK



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

^MKSET:				;GO INTO MAKING MODE.
	SKIPN	B
	SETOM	MKFLAG		;TO DETERMINE IF BRACKETED TRIPLE SHOULD
				;BE MADE, OR RETRIEVED
	POPJ	P,

^MAK:				;MAKE AN ASSOCIATION.
	SETZM	MKFLAG
	STAKCHECK (3)		;THREE ARGUMENTS.
;; #OY# MAKE CAN'T TAKE SET ARGUMENTS
	TLNN	A,LPITM		;EVERYTHING HAD BETTER BE ITEMS
	ERR	<MAKE DOES NOT ACCEPT SET OR LIST ARGUMENTS>,1
;; #OY#
	TLNE	A,FBIND
	ERR	<BIND NOT VALID IN MAKE>,1
	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 ?
;; #SQ# ! (1 OF 2) SAVE WHETHER SET OR LIST HERE
	PUSH	P,@LEAPSK	;TOP LEAPSK ENTRY
	STAKCHECK (2)		;TWO ARGUMETS.
	TLNE	A,FBIND
	ERR	<BIND NOT VALID IN SET BOOLEANS>,1
	RETCHK			;RETRIEVAL TYPES NECESSARY
	XPREP
;; %AF% (3 OF 3) DIFFERENT ROUTINES FOR LIST AND SET MEMBERSHIP BOOLEANS
;; #SQ# ! (2 OF 2) TEST THE CORRECT BITS
	POP	P,A
	TLNE	A,LPXISX	;A LIST WE'RE SEARCHING?
	JRST	[LPCALL (LSTIN)
		 JRST   INTGO1]
;; %AF%
	LPCALL	(STIN)
	JRST	INTGO1		;MARK AS INTEGER.


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


^ISIT:				;A XOR B EQV C ?
	STAKCHECK (3)		;THREE ITEMS.
	RETCHK			;RETRIEVAL TYPES NECESSARY
	TLNE	A,FBIND
	JRST	[XPREP
		 LPCALL(BNDTRP) ;CALL
		 JRST INTGO1]
	XPREP
	LPCALL	(ISIT)		;CALL.
	JRST	INTGO1

^ITMREL:SOS	B,LEAPSK	;DEC LEAP STACK
;; #PX# (8 OF 13)
	SKIPN	PNT,1(B)		;OLD TOP OF LEAP STACK
	ERR	<NON-LEAP ARGUMENT TO LEAP EXPRESSION>,1
;; #PX#
	TLNE	PNT,LPDMY
	ERR	<BRACKETED TRIPLE WON'T WORK HERE>,1
	TLNN	PNT,STACKED	;STACKED?
;;#NM# ! (1 OF 2) IF A BINDING ITEMVAR MUST LOAD;
	JRST	BINTST		;NO, JUST STORE
	HRRI	FF,0		;DON'T NEED INDX OR DBL
	PUSHJ	P,GETAC		;GET AN AC
;; #LF#  FOLLOWING WAS A HRLI
	HRL	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
;; #NM# (2 OF 2) LOAD INTO AC IF ? ITEMVAR
BINTST:				;IF A BINDING ITEMVAR MUST MAKE A TEMP;
	MOVE	TBITS,$TBITS(PNT);
	TLNN	TBITS,MPBIND	; A BINDING PARAM?
	JRST	ITMRE2		; NO.
	GENMOV	(GET,GETD)	;LOAD INTO AC
	HRRI	TBITS,ITMVAR
	PUSHJ	P,MARKME	;MARK AS ITMVAR
;; #NM#
ITMRE2:	HRRZM	PNT,GENRIG+1	
	HRRZM	PNT,GENLEF+1	;BOTH PLACES
	POPJ	P,

^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 NEQ>,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
;;#YL# ! JFR 1-20-77
	PUSHJ	P,BOPBLK	;SIMULATE A BOOLEAN
	MOVEM	LPSA,GENRIG
	PUSHJ	P,GOSTO
	EMIT	(<JUMPE NOADDR>)
;;#YL#	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


^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_ SETO ONE,TWO,THREE SETC
^SIPGO:
	SETZ	A,			;TO STORE IN LORSET
	QPUSH	(LORSET)
	PUSHJ	P,OKSTACK
	MOVEM	FF,FFSAVE		;SAVE THE FLAG WORD.
	TLZ	FF,LPPROG
	MOVEI	A,0
	PUSHJ	P,CREINT
	EMIT	(<PUSH RP,NOUSAC>)
	AOS	ADEPTH
	POPJ	P,

^STPRIM:				;ALL DONE -- JUST MARK "STACK"
	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)
;; #PX# (9 OF 13)
	SKIPN	PNT,@LEAPSK
	ERR	<NON-LEAP ARGUMENT TO LEAP EXPRESSION>,1
;; #PX#
	MOVE	SBITS,$SBITS(PNT)
	TLNN	PNT,STACKED		;ALREADY STACKED?
	TLNE	SBITS,ARTEMP		;OR A TEMP?
	JRST	LPCNT			;CALL LEAP DO DO IT
;; #RB# (1 OF 4) JRL DO ACCESS BEFORE EMIT
	GENMOV	(ACCESS,GETD)
;; #RV# (1 OF 2) DON'T ALLOW LENGTH(ITEM)
	TRNE	TBITS,ITEM!ITMVAR
	ERR	<LENGTH OF ITEM EXPRESSION>,1
;; #RV#
	PUSHJ	P,GETAC			;GET AN AC TO PLAY WITH
	EMIT	<HLRE ,>		;FETCH THE LENGTH
	SOS	LEAPSK			;SO LONGER ON LEAP STACK
	JRST	INTGO			;MAKE INTO INTEGER
LPCNT:					;WILL HAVE TO CALL LEAP
	STAKCHECK	(1)
;; #RV# (2 OF 2)
	TLNE	A,LPITM
	ERR	<LENGTH OF ITEM EXPRESSION>,1
;; #RV#
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,

INTGO1: PUSHJ	P,MARKINT	;MARK AS INTEGER
	HRRI	TBITS,INTEGR
	MOVEM	TBITS,$TBITS(PNT)
	MOVEM	PNT,GENRIG+1
	POPJ	P,


^STUNT:				;COP OF SET (GET ONE ELEMENT)
	STAKCHECK	(1)
;; #RS# GIVE ERROR MESSAGE FOR COP(ITEMVAR)
	TLNN	A,LPSET!LPXISX
	ERR	<COP REQUIRES LIST OR SET EXPRESSION ARGUMENT>,1
;; #RS#
	LPCALL	(STUNT)
	HRLZI	A,LPITM!STACKET!RETRV!CNSTR		;A NEW ITEM.
	JRST	BFINA


^ECVI:
	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:  SKIPN	PNT,@LEAPSK		;TOP OF LEAP STACK
	ERR	<NON-LEAP ARG TO LEAP EXPRESSION>,1
	TLNE	PNT,LPSET!LPXISX		;BETTER NOT BE SET;
	ERR	<CVN ONLY VALID FOR ITEMS>,1
	TLNE	PNT,LPDMY
	ERR	<BRACKETED TRIPLE INVALID HERE>,1
	TLNN	PNT,STACKET		;ALREADY STACKED?
	JRST	GTITM
	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.)
GTITM:
	MOVE	TBITS,$TBITS(PNT)	;TYPE BITS OF QUANTITY
	TRNE	TBITS,ITEM		;DECLARED ITEM?
	JRST	[TRNE TBITS,FORMAL!SBSCRP
		 JRST .+1
		 HRRZ TEMP,$VAL2(PNT)	;THE CONSTANT SEMBLK
		 JUMPE TEMP,.+1		;NOT THERE
		 MOVEM TEMP,GENRIG	;THE CONSTANT SEMBLK
		 SOS LEAPSK		;NO LONGER ON LEAP STACK
		 POPJ P,]
	GENMOV (GET,GETD)		;NOT STACKED
	SOS LEAPSK			;NO LONGER ON LEAP STACK
	JRST	INTGO			;MAKE INTO INTEGER


FIRREF:	SOS	PNT,LEAPSK		;THERE SHOULD BE SOMETHING THERE.
	SKIPN	PNT,1(PNT)
	ERR	<NON-LEAP ARGUMENT TO LEAP EXPRESSION>,1
	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)
;; #OQ# ! DID NOT INCLUDE CNSTR BIT
	HRLZI	A,LPITM!STACKET!RETRV!CNSTR
	JRST	BFINA



FOR II   IN (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.
	PUSH	P,B		;PARSER INDEX
;; #SR# ! TYPE CHECK TO CATCH PUT X IN LIST.
	PUSH	P,@LEAPSK
	PUSHJ	P,FIRREF	;GO GET IT.
	STAKCHECK	(1)	;FOR THE ITEM.
	POP	P,A		;THE TYPE BITS
	POP	P,D
	SKIPN	D
	JRST	[
;; #SR#  TYPE CHECK 
		TLNE	A,LPXISX ;BETTER NOT BE A LIST VARIABLE
		ERR	<INVALID LIST PUT STATEMENT>,1
;; #SR#
		LPCALL	(STPUT)
		POPJ	P,]
	SKIPE	REMASET
	JRST	[SETZM	REMASET
		 LPCALL	(REMALL)
		 POPJ	P,]
	LPCALL	(STREM)
	POPJ	P,


; THINGS TO MAKE NIL 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
LPREC:				;ENTER HERE FROM ECVI
	PUSHJ	P,BFIN
	TLNE	FF,LPPROG
	POPJ	P,			;FOREACH GOING ON.
	MOVEI	D,-1(B)		;THING BEFORE THE "NIL"
	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)
	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.
	TLNN	A,LPITM		;BOTH ITEMS?
	ERR	<SET OR LIST WHERE ITEM EXPECTED>,1
	POP	P,B		;POP INDEX
	LPCALL	(PUTAFT,<B>)	;CALL LEAP
	POPJ	P,			;RETURN TO PARSE

PUTXAB: STAKCHECK (1)		;ITEM ARGUMENT
	TLNN	A,LPITM		;REALLY AN ITEM?
	ERR	<SET OR LIST WHERE ITEM EXPECTED>,1
	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
;; #PX# (10 OF 13)
	SKIPN	A,1(B)
	ERR	<NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
	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 INF


^CVLS:				;CONVERT LIST TO SET(VICE-VERSA)
; B 1 IF CVLIST, 0 IF CVSET
	MOVE	A,GENLEF+1
	MOVEM	A,GENRIG	;TWIDDLE PARSE STACK
	SKIPN	A,@LEAPSK
	ERR	<NON-LEAP ARG TO LEAP EXPRESSION>,1
	TLNN	A,LPSET
	ERR	<CVLIST CVSET REQUIRE SET, LIST ARGUMENTS>,1
	JUMPE	B,[STAKCHECK (1);LIST
		   LPCALL (SETLST)
		   HRLZI  A,LPSET!STACKET!RETRV!CNSTR
		   JRST BFINA]
;; #KO# BY JRL CVLIST SHOULD MARK RESULT AS LIST
	HRLZI	A,LPSET!LPXISX!RETRV!CNSTR
	IORM	A,@LEAPSK
	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
;; #RB# ! (2 OF 4) DO ACCESS BEFORE EMIT
	GENMOV	(ACCESS,GETD)
	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,RFIMAK
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
REC <
		TRNE	A,PNTVAR
		ADDI	B,RECTYP	;A RECORD
>;REC
		TRNE	A,DBLPRC
		ADDI	B,LFLTYP-FLTYPE	;DOUBLE PRECISION
		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)
	TRNE	TBITS,ITEM!ITMVAR
	ERR	<NEW OF ITEM EXPRESSION ILLEGAL>,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	
	PUSH	P,A		;SAVE FOR LATER
	CAIN	A,CTXTYP	;CONTEXT?
	JRST	[CAME	PNT,NULLCN	;HAD BETTER BE NULL!CONTEXT
		 ERR	<ONLY NULL!CONTEXT MAY BE ARGUMENT TO NEW>,1
		 MOVEI	A,0	;WILL STACK 0
		 PUSHJ  P,CREINT
		 JRST	.+1]
	GENMOV	(STACK,GETD)	;STACK THE ARITHMETIC.
	POP 	P,A		;GET TYPE BACK
ISSTACK:
;; #MR# A STRING ARRAY IS NOT A STRING
	TLNN	TBITS,SBSCRP
	TRNN	TBITS,STRING
	JRST	NWA		;NOT A STRING
	MOVNI   B,2
	ADDM	B,SDEPTH
	CAIA
NWA:	SOS	ADEPTH		;IT IS A PARAMETER.
	HRLM	A,BYTES		;TYPE TO LEAP PARAM
	TLNE	TBITS,SBSCRP
	JRST	[LPCALL (NEWRY)
		 JRST	DCON]
	LPCALL	(NEWARITH)
DCON:
;; #NR# ! AVOID DRYROT REMOP STCNST
;;;	PUSHJ	P,REMOP		;STACK HAS ALREADY DONE REMOP
ONCON:	MOVSI	A,LPITM!CNSTR!STACKET	;RECORD THAT NEW ENTRY IS ITEM.
	JRST	BFINA

NOGLOC <
^GLBSET: ERR	<THIS COMPILER WON'T DO GLOBAL MODEL TYPE THINGS>,1
^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

;;%BH% -- ADD EXEC RFTEMP & REORGANIZE RFIMAK SO MAIN PART IS RFDPSH
ZERODATA(REFERENCE VAR FLAG)
NOSKIT:	0		;IF NOT 0, THEN RFDPSH DOESN'T STACK THE DESCRIPTOR
			;AND RETURNS ITS SEMANTICS IN PNT
ENDDATA

^RFNCDO: 
	SETOM	NOSKIT
	GETSEM	(1)		;GET SEMANTICS OF EXPRN
	HLRZ	PNT2,GENLEF+2	;GET EXTRA FLAG BITS
	TDNN	TBITS,[XWD SBSCRP,ITEM!ITMVAR]
	TRNN	TBITS,STRING
	JRST	RFDT.1		;BETTER NOT ALLOW STRING VALUES ON STACK
	TLNN	SBITS,STTEMP	;IF A STRING TEMP OR CONSTANT
	TLNE	TBITS,CNST	;
	ERR	<UNFORTUNATELY, REFERENCE WONT WORK FOR STRING EXPRESSIONS>,1
RFDT.1:	PUSHJ	P,RFDPSH	;GET REFERENCE COMPUTED
	SETZM	NOSKIT		;RESET THE FLAG
	HRRZM	PNT,GENRIG	;RESULT SEMANTICS
	POPJ	P,

^RFIMAK:
;;#SY# SET UP BOTH PNT & PNT2

	GETSEM	(1)		;GET SEMANTICS
	HLRZ	PNT2,GENLEF+2	;AND EXTRA BITS
	PUSHJ	P,RFDPSH	;GO PUSH REFITEM DATUM
	MOVEI	A,RFITYP	;THE ACTUAL TYPE
	JRST	NWA		;GO PUT IT AWAY

;; RFDPSH WILL BUILD & PUSH ONTO THE STACK A DESCRIPTOR FOR
;; THE THING IN PNT GROUP, WITH ANY BITS THAT MAY BE IN THE RHS OF PNT2
;; OR'D INTO THE LHS OF THE DESCRIPTOR.  IF NOSKIT IS ON, THEN 
;; DONT DO THE PUSH, RATHER, RETURN SEMANTICS OF TEMP IN PNT.
;; MUNCHES VARIOUS ACS
;;
;; ALSO, IF THE BIT 15 IS ON IN PNT2, THEN A VALUE REFERENCE IS 
;; ASSUMED (SO REFB BETTER BE OFF IN PNT2).  IF ALL THIS SEEMS VERY
;; AD HOC, DONT WORRY, IT IS.

;; *** RHT: NOTE THAT THIS ROUTINE STILL CONTAINS REFERENCES TO GENLEF+1
;;     THIS IS CLEARLY WRONG, BUT I DON'T WANT TO WORRY ABOUT IT JUST NOW
;;
^RFDPSH:
;;#RQ# -- TO MAKE STRING CONSTANTS WORK, ESPECIALLY FOR WRITEON
	TDNN	TBITS,[XWD SBSCRP,ITEM!ITMVAR]
	TRNN	TBITS,STRING
	JRST	RFDP1		;JUMP IF ARRAY OR ITEM OR NOT STRING
;;#SB# ALL VALUE STRINGS MUST PUSH SP,...
	TLNN	TBITS,CNST
	TRNE	PNT2,15	;
	TLNE	SBITS,STTEMP	;DON'T STACK AGAIN IF STRING
	JRST	RFDP1		;JUMP IF NOT CONSTANT  VALUE
;;#SB#
	GENMOV	(STACK,0)	;WE NOW HAVE A STRING CONSTANT
	MOVEI	TBITS,STRING	;  MAKE A STRING TEMP FROM IT
	SETZM	SBITS
	GENMOV	(MARK,0)
	MOVEM	PNT,GENLEF+1	;THIS THING IS NOW A STRING TEMP
RFDP1:
;;#RQ#
;;#OK# -- TO MAKE ITEMS WORK
	TRNE	TBITS,ITEM	;ITEMS NEED TO HAVE VALUES
	JRST	[ HRRZ PNT,$VAL2(PNT); GET NUMBER, BUT KEEP THESE SEMANTICS
		MOVEI B,0	;LIKE A CONSTANT
		TRZ	PNT2,15;RESET THIS IMPORTANT FLAG
		JRST	RFDAT]	;GO DO REST
;;#SE#
;;#OK#
	MOVEI	B,REFB		;USUALLY A REAL LIVE REF
	TLNN	TBITS,CNST	;CONSTANTS GO RIGHT AWAY
	TLNE	SBITS,ARTEMP!INUSE
	TRZ	B,REFB		;THIS IS A TEMP
	TLNE	SBITS,INDXED!PTRAC
	TRO	B,REFB		;REFERENCE !
;;%BH%  -- USE THE FLAG A BIT DIFFERENT NOW
	TRZE	PNT2,15	;WAS IT A VALUE
	TRZ	B,REFB		;YES

;;#TI# THIS ISNT THE WAY TO SET TMPB ANY MORE
;TMPTST:	TRNE	A,-1		;A ZERO RH MEANS NOT TEMP
;	TRO	B,TMPB
;;#TI#

RFDAT:	MOVE	A,TBITS		;THIS IS A REFERENCE
	TRNN	TBITS,ITMVAR!ITEM ;AN ITEMVAR?
	JRST	NTITRF		;NO
ISIREF:	TRO	B,ITEMB		;YES
	TLCE	A,SBSCRP	;ARY2 THING
	TROA	B,ARY2B		;
	TLC	A,SBSCRP	;
NTITRF:	PUSHJ	P,ITMTYP	;
	LSH	A,5		;GET IT OVER
	TLNE	PNT,FBIND	;BIND?
	TRO	A,BINDB		;YES
	TLNE	PNT,QBIND	;? ?
	TRO	A,QUESB
	TRO	A,(B)		;THE ARY2 BIT & OTHERS
	GENMOV	(INCOR,0)	;BE SURE THE THING IS INCORE
	TLNE	SBITS,STTEMP	;STRING TEMP?
	JRST	ISSTTT		;YES
	HRL	PNT,A		;FOR DATUM
;;%  %
	TLO	PNT,(PNT2)	;A FEW EXTRA BITS, PERHAPS
	SETOM	MPFLAG
	PUSHJ	P,FTRADR	;STACK THE TYPE,,POINTER
	SETZM	MPFLAG
;;#RZ# ! used to skipn
SKKRFD:	SKIPE	NOSKIT		;WANT A STACKING??
	JRST	SKKR.1
	GENMOV	(STACK,0)	;DOES THE ACTUAL STACKING (& REMOPS IT)
;;#VP# ! RHT
	POPJ	P,		;DO NOT REMOP AGAIN
SKKR.1:	MOVE	LPSA,GENLEF+1	;THE TEMP FROM THE EXPRN
	PUSHJ	P,REMOPL	;REMOP THE EXPRN
	POPJ	P,

ISSTTT:
;; #RP# ! TYPE BITS GO IN LEFT HALF
	HRLZ	A,A		;WE WERE COLLECTING BITS IN RIGHT HALF
	TLZ	A,REFB		;REFB NOT
	TLO	A,SP		;IS TOP OF STRING STACK
	PUSHJ	P,CREINT	;TYPES 0(SP)
	MOVNI	A,2		;ADJUST SDEPTH
	ADDM	A,SDEPTH	;
	JRST 	SKKRFD		;GO STACK THE RFI DATUM

;;%BH% FIX THESE GUYS TO SET THE BITS IN THE RIGHT HALF

^RFTEMP: MOVSI  A,TMPB
	ORM	A,GENLEF+2	;SET FLAG TO INDICATE A TMPB ON
	POPJ	P,

^RFVAL:				;SAY IS A VALUE 
	HRLZI	A,15		;THE BIT
	HLLM	A,GENRIG	;REMEMBER IT IN GENERATOR STACK
	POPJ	P,

^RFZERO:
	HRRZS	GENRIG+1	;ZERO OUT THE ENTRY
	POPJ	P,

^RFBKLG: SKIPA	A,[XWD BINDB,0]
^RFQKLG: HRLZI	A,QUESB		;REMEMBER ? BIT
	ORM	A,GENRIG+2
	POPJ	P,
; CASE, EXPRESSION CONDITIONALS.

DSCR LPCS2, LPCS3, LPEXF1, LPEXF2,CHKLEP
PRO LPCS2 LPCS3 LPEXF1 LPEXF2

^CHKLEP:			;TO MAKE SURE EVERYTHING IS STACKED
				;BEFORE PROCESSING CASE OR CONDITIONAL
				;LEAP EXPRESSION
	HRRZ	TEMP,LEAPSK	;ANY THING ON LEAP STACK?
	CAIG	TEMP,LEABEG-1
	POPJ	P,		;NOPE
	TLNE	FF,LPPROG	;FOREACH IN PROGRESS?
	ERR	<WARNING: CONDITIONALS INSIDE FOREACH MAY NOT WORK CORRECTLY>,1
	PUSHJ	P,OKSTACK	;MAKE SURE THIS THING IS STACKED
	POPJ	P,		

^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!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),-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.
;; #PX# (11 OF 13)
	SKIPN	PNT2,@LEAPSK		;GET TOP OF STACK.
	ERR	<NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
	TLNE	PNT2,LPDMY
	ERR	<THIS CONSTRUCT WON'T WORK WITHIN FOREACH>,1
	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,
;;%DN% JFR 7-4-76
MODSTK:
	HRLI	C,1
	PUSHJ	P,EPADJ
;;	MOVE	A,[XWD 1,1]
;;	PUSH	P,PNT
;;	PUSHJ	P,CREINT
;;	EMIT	<ADD RP,NOUSAC>
;;	POP	P,PNT
;;%DN% ^
	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?
;; #PX# (12 OF 13)
	SKIPN	A,@LEAPSK	;IS IT STACKED??
	ERR	<NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
	TRNE	A,-1		;SEE IF HAS SEMBLK POINTER
	TLNE	A,STACKET	;
	JRST	NOWW		;NO CLEVER.
	TLNE	A,LPDMY		;A CRAZY DERIVED SET OR BTRIP
	JRST	[ERR <DERIVED SET OR BRACKETED TRIPLE DOESN'T WORK HERE>,1
		      MOVE A,GENLEF+1 ;MAYBE THIS WILL SAVE REST OF COMPILING
		JRST .+1]
	MOVE	TBITS,$TBITS(A)
	TRNN	TBITS,ITEM!ITMVAR!SET!LSTBIT
	JRST	NOWW
	HRRZM	A,GENLEF+1
	TLNE	A,FBIND!QBIND
	HLLM	A,GENLEF+1	;LEAVE FBIND,QBIND BITS FOR CALARG TO FIND
	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
;; #KJ BY JRL (11-21-72) FOLLOWING INSTR WAS HRRI, GOT GARBAGE LH BITS
		 MOVEI 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
	HRLI	C,1		;POP INTO AC 1
	EMIT    <POP RP,NORLC!USADDR!NOUSAC>
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
	HRLI	C,1
	EMIT	<POP RP,USADDR!NORLC!NOUSAC>
	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.
	QPUSH	(PNLST)
	QPOP	(PNLST)
	MOVE	A,PNLST
	MOVEM	A,PNBEG		;SAVE FOR TAKING THINGS OUT.
	POPJ	P,



^ALLGLB: SETOM	ALLGLO		;EVERY OPERATION IS TO BE CONSIDERED GLOBAL
	POPJ	P,
DSCR CALMP -MATCHING PROCEDURE EXECS

^^CALMP:
	MOVE PNT2,GENLEF+1		;PROCEDURE SEMANTICS
	HRRZ	PNT,$VAL(PNT2)		;
	HRRI	D,TEMP			;WE WANT IT LOADED INTO TEMP
	PUSHJ	P,LODPDA		;ADDR OF PDA ONTO STACK
	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?
	HRLZI	SBITS,LPFREE
	ANDCAM	SBITS,$SBITS(A)		;THE ? PARMS ARE NO LONGER FREEE
	JRST	LPMPAR
NOMORE:	QPUSH	(MPQSTK,A)		;PUT MARKER BACK ON
	POPJ	P,

^^SUCCEX:
	PUSHJ	P,ALLSTO		;NOTHING IS SAVED OVER CALL
	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
	QLOOK	(MPVSTK)		;XWD ?TABLE,,LEVEL
	MOVE	C,(A)
	EMIT	<HRLI	TEMP,NOUSAC!USADDR>
	HRLI	C,TEMP
	EMIT	<PUSH RP,NOUSAC!USADDR!NORLC>
	MOVE	A,(P)			;SUCC OR FAIL
	ADDI	A,R.SUCCE+LIBTAB	;LIBTAB INDEX
	PUSHJ	P,XCALLQ		;CALL SUCCEED OR FAIL
;; THE SKIP RETURN FROM .SUCC SHOULD BE INVERTED IN THE RUNTIMES
;; UNTIL THAT TIME WE WILL DO IT HERE
	OPTSYM	%$SUCC		;SUCCEED/FAIL LOCATION
	EMIT	<SKIPA ,NOUSAC!NOADDR>
;; END OF TEMPORARY HACK
	HRL	C,PCNT
	ADD	C,[XWD 6,0]
	EMIT	<JRST , NOUSAC!USADDR>
	MOVE	PNT,-1(P)			;THE PROC SEMBLK
	HRR	PNT,$VAL(PNT)		;THE PDA SEMBLK
	MOVS	C,$ADR(PNT)		;
	MOVE	A,[HRRZI LPSA,NOUSAC!JSFIX]
	TRNE	C,-1			;ALREADY PUT OUT
	HRRI	A,NOUSAC!USADDR		;NO.
	PUSHJ	P,EMITER
	QLOOK	(MPQSTK)
	HRLZ	C,(A)			;THE LEXICAL LEVEL
	EMIT	<HRLI LPSA,USADDR!NORLC!NOUSAC>
	XCALL	<STKUWD>
	POP	P,C			;SUCCEED OR FAIL
	MOVE	A,[SETZ A,NOUSAC!NOADDR] ;ASSUME FALSE
	SKIPN	C
	HRLI	A,(<SETO A,>)
	PUSHJ	P,EMITER		;THE TRUTH VALUE TO BE RETURNED
	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

^ONEITV:				;FOR WHEN FAIL, SUCCEED CALLED WITHIN
					;EXPRESSION.
	MOVEI	D,1			;SUCCEX HAS ALREADY DONE EVERYTHING ELSE
					;WE KNOW RESULT IS RETURNED IN AC 1
	MOVEI	TBITS,ITMVAR
	SETZ	SBITS,
	PUSHJ	P,MARKME
	MOVEM	PNT,GENRIG		;FOR RESULTANT ITV EXPRESSION
	POPJ	P,
^SAMEV:
	MOVE	PNT,GENLEF+4		;FIRST ITEMVAR
	MOVE	PNT2,GENLEF+2
	MOVE	TBITS,$TBITS(PNT)	;SEE IF REALLY A MP PARM.
	TLNN	TBITS,MPBIND
	JRST	FALCON			;NO ALWAYS FALSE.
	MOVE	TBITS,$TBITS(PNT2)
	TLNN	TBITS,MPBIND
	JRST	FALCON	
;;#RB# (3 OF 4) DO AN ACCESS
	GENMOV	(ACCESS,GETD)
	PUSHJ	P,GETAC			;GET AN AC TO PLAY WITH
	EMIT	<MOVE ,>		;LOAD WITH FIRST ITEMVAR
	MOVE	PNT,PNT2		;SECOND ITEMVAR SEMBLK
;; #RB# (4 OF 4) ACCESS AGAIN
	HRROS	ACKTAB(D)		;PROTECT AC OVER ACCESS
	GENMOV	(ACCESS,GETD)
	HRRZS	ACKTAB(D)
;; #RB#
	EMIT	<CAMN ,>		;COMPARE FIRST WITH SECOND
	HRLI	C,20			;INDIRECT BIT FOR NEXT INSTR
	EMIT	<TLNN ,NORLC!USADDR>
	HRLI	C,(D)			;THE AC ITEMVAR IN.
	EMIT	<TDZA ,NORLC!USADDR> ;FALSE
	HRLI	C,1
	EMIT	<MOVNI ,NORLC!USADDR>;TRUE
	PUSHJ	P,MARKINT
	MOVEM	PNT,GENRIG+1
	POPJ	P,
FALCON: MOVNI	A,1
	PUSHJ	P,CREINT
	MOVEM	PNT,GENRIG+1
	POPJ	P,
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
	TLNN	TBITS,SBSCRP		;ARRAYS ARE NEVER ON LEAPSK
	TRNN	TBITS,SET!ITMVAR	;LEAPISH THING?
	JRST    HVPNT			;NO.
	SOS	B,LEAPSK		;GET SEMAN FROM LEAP STACK
;; #PX# (13 OF 13)
	SKIPN	PNT,1(B)		;SEMBLK
	ERR	<NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
	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:
	TLNN	SBITS,FIXARR!INDXED	;IF NOT ARRAY ELEM
	PUSHJ   P,INCOR			;MAKE SURE INCORE
	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
	PUSHJ	P,ALLSTO		;MAKE SURE NOTHING IN AC
	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,

^INCNTX: GETSEM (1)
	GENMOV (STACK,0)		;STACK VAL
	XPREP
	XCALL	(.INCON)
;;#WR# 2! JRL (JFR) 4-17-76 USED TO GIVE ADEPTH,SDEPTH DRYROT
	SOS	ADEPTH
	SOS	ADEPTH
	PUSHJ	P,MARKINT
	MOVEM	PNT,GENRIG
	POPJ	P,
^NLCNXT:				;NULL!CONTEXT
	MOVE	PNT,NULLCN		;DUMMY SEMBLK FOR NULL!CONTEXT
	MOVEM	PNT,GENRIG		;STORE IT AWAY
	POPJ	P,
^CONELM:				;CNTX:VAR CONSTRUCT
	GETSEM	(3)			;THE CONTEXT
	GENMOV	(STACK,0)		;STACK IT
	GETSEM	(1)			;THE VARIABLE NAME
	PUSH	P,TBITS			;SINCE HVPNT WILL DESTROY
	PUSHJ	P,HVPNT			;STACK IT
	POP	P,TBITS			;HVPNT DESTROYED
	XPREP				;CONELM WILL RETURN RESULT IN 1
	XCALL	(CONELM)
	MOVNI	TEMP,2			;UPDATE P-STACK
	ADDM	TEMP,ADEPTH
	PUSHJ	P,TYPDEC		;TYPE THE THING
	MOVEM	A,PARRIG+1
; BUF \UR#36\ 	TLZ	TBITS,OWN!FORMAL!MPBIND ;IF ARRAY NO LONGER OWN
;; \UR#36\ JRL (12-22-78) ALSO TURN OFF EXTRNL,INTRNL
        TLZ     TBITS,OWN!FORMAL!MPBIND,EXTRNL,INTRNL
	PUSH	P,PNT
	PUSH	P,TBITS			;SAVE OVER CALL TO MARK
	SETZB	TBITS,SBITS
	GENMOV	(MARK,0)		;GET A TEMP
	MOVEM	PNT,GENRIG+1
	HRROS	$ACNO(PNT)		;FOR ARRAYS
	POP	P,TBITS
	POP	P,TEMP
	TLNE	TBITS,SBSCRP		;AN ARRAY?
	MOVEM	TEMP,$VAL(PNT)		;NAME FOR ARRERR UUO
	MOVEM	TBITS,$TBITS(PNT)	;STORE REAL TBITS
	TLC	SBITS,INAC!PTRAC!INDXED
	MOVEM	SBITS,$SBITS(PNT)	;STORE REAL SBITS
	POPJ	P,
BEND LEAP
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
;;#UY# JFR 8-18-75 this does not work for parametric procedures
	MOVE	TEMP,$TBITS(PNT2)
	TLNE	TEMP,REFRNC
	 ERR	<Parametric procedures are not allowed in ASSIGNs.>,1
;;#UY# ^
	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	C,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)
;;#LH# 1 OF 2 RHT 2-6-73 ADJUST ADEPTH
	MOVNI	D,2
	ADDM	D,ADEPTH
;;#LH#
	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)
;;#LH# 2 OF 2 RHT 2-6-73 ADJUST ADEPTH
	MOVNI	D,2
	ADDM	D,ADEPTH
;;#LH#
	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:	
;;#PB# !  RHT 15 NOV 73 NEEDED AN ALLSTO
	PUSHJ P,ALLSTO
	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,




;; EXECS FOR SPROUT APPLY

;;#OJ# -- Revised this code to do a getblk.  RHT
^SAPPL1: GETBLK GENRIG+1
	HLLOS	$VAL2(LPSA)	;MARK SPROUT SEMBLK AS SPROUT APPLY
	POPJ	P,
;;#OJ#

^SAPPL:	PUSHJ	P,BNDLST	;GET ARG LIST ON STACK
	JRST	SAPPP
^SAPPN:	MOVEI	A,0
	PUSHJ	P,CREINT	;A NULL
	GENMOVE (STACK,0)	;STACK IT
SAPPP:	
	HRL	C,PCNT
;;#OM# ! LEFT OUT LIBTAB
	EXCH	C,LIBTAB+RAPPL$Y	;FIXUP ON APPL$Y
	EMIT	<MOVEI	TEMP,NOUSAC!USADDR>
	HRLI	C,TEMP
	EMIT	<PUSH RP,NOUSAC!USADDR!NORLC>
	AOS	ADEPTH
	POPJ	P,