perm filename STATS[S,AIL]2 blob sn#010860 filedate 1972-11-11 generic text, type T, neo UTF8
COMMENT ⊗   VALID 00042 PAGES VERSION 16-2(32)
RECORD PAGE   DESCRIPTION
 00001 00001
 00005 00002	HISTORY
 00010 00003	For-Loop, Case Statement Variables
 00012 00004	  Descriptions of For Loop Constructs, Bit Definitions
 00017 00005	  FOR, DO, WHILE, NEEDNEXT Generators
 00021 00006	
 00026 00007	
 00029 00008	    (continued),  NEXT, DONE, CONTINUE
 00034 00009		
 00038 00010	
 00043 00011	
 00051 00012	
 00053 00013	ENTLAB, TRA -- generators for label placement, Go To statements
 00056 00014	  TRAGO -- go-to-solver -- used also by RETURN code
 00059 00015	NODIS <
 00064 00016	CASSTR, CASEMT, CASEND, CASE1, ... -- Case Statement Generators
 00068 00017	
 00072 00018	
 00076 00019	PROCEDURE Structure Descriptions, Data Declarations
 00080 00020	  PRDEC -- When Name is Seen
 00088 00021	  ENDPR -- when params have been seen
 00096 00022	  PRUP -- When Procedure Body's Finished -- Entry, Exit, Fixups, etc.
 00100 00023	
 00102 00024	
 00111 00025	
 00116 00026	    RESTOR, SAVIT,MKESMT,SETF -- Subroutines for Above
 00124 00027		NOW THAT AC IS STATIC LINK, MIGHT AS WELL REMEMBER THAT FACT
 00126 00028	  TWPR1, TWPR2 -- Procedure Syntax  Twiddlers
 00128 00029	RDYCAL -- Prepare to Call Procedure
 00133 00030	  Describe CALARG
 00135 00031	  CALARG -- Pass a Parameter
 00141 00032	
 00143 00033	MPPARM:				BINDING ITEMVAR PARAMETER
 00150 00034	
 00154 00035	    ADRINS -- Subrt for Above -- Prepare an Address Constant (Semblk)
 00158 00036	
 00161 00037	
 00164 00038	  ISUCAL -- Call the Procedure, Mark Resultant Type, etc.
 00171 00039	
 00175 00040	ARGFIX:	HRL	B,A		FIXUP
 00179 00041	RESULT -- Return (with or without value) from Procedure
 00184 00042	
 00187 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  202000000040  ⊗;


COMMENT ⊗
VERSION 16-2(32) 11-11-72 BY RHT BUG #KB# BAD LPSA ENCLOBERMENT IN SYNTUP
VERSION 16-2(31) 10-21-72 BY JRL CHANGE FIX TO BUG JT
VERSION 16-2(30) 10-20-72 BY JRL BUG #JT# DON'T RELEASE SETS TO BE RETURNED BY FUNCTION
VERSION 16-2(29) 10-13-72 BY JRL SAV MP RETURN VAL OVER CALL TO STKUWD
VERSION 16-2(28) 10-3-72 BY JRL BUG #JK# SAVE AC 1 OVER CALLS TO RECLAIM VALUE SET
VERSION 16-2(27) 10-3-72 BY JRL MOVE DEF OF MPFLAG TO STATS
VERSION 16-2(26) 9-21-72 BY JRL MAKE SURE PROC FORMALS CAN BE ACCESSED
VERSION 16-2(25) 9-18-72 BY KVL TO ADD SPECIAL CHECK: REF PARAMS TO PROC ARGS OF PROCS.
VERSION 16-2(23) 9-8-72 BY JRL HANDLE ? LOCAL ITEMVARS AS PARAMETERS TO PROCS
VERSION 16-2(22) 8-23-72 BY RHT ONLY ALLOCATE PD SEMBLK IF NOT SIMPLE
VERSION 16-2(21) 8-19-72 BY JRL HANDLE ? PARAMS TO FOREACH
VERSION 16-2(20) 8-17-72 BY JRL ALTER ISUCAL TO HANDLE MATCHING PROCEDURES
VERSION 16-2(19) 7-26-72 BY RHT BUG #IS# NEEDNEXT WHILE LOOPS
VERSION 16-2(18) 7-18-72 BY RHT BUG #IP# SET VALUE PARAMS RELEASING
VERSION 16-2(17) 7-6-72 BY RHT BUG ##I#K#  FIX DL LOADING BUG IN ISSUE
VERSION 16-2(16) 7-4-72 BY RHT MAKE DONE & CONTINUE STORE TEMPS BEFORE JUMPING
VERSION 16-2(15) 7-4-72 BY RHT DONE, NEXT, &CONTINUE
VERSION 16-2(14) 6-27-72 BY JRL BUG #HZ# ARRTRAN UPSET BY LSTBIT
VERSION 16-2(13) 6-23-72 BY RHT FIX NEEDNEXT BUG
VERSION 16-2(12) 6-23-72 BY RHT FIX NEEDNEXT BUG
VERSION 16-2(11) 6-14-72 BY JRL BUGS #HR#,#HS# STRING ITEMVAR PARAMS, AND PROCS.
VERSION 16-2(10) 6-14-72 BY DCS BUG #HT# SAVE REGS, RF, RESTORE RF ON F4 SUBROUTINE CALL
VERSION 16-2(9) 6-14-72 BY RHT PUT IN DONE OUT OF FOREACH IN SIMP PROC
VERSION 16-2(8) 6-13-72 BY DCS BUG #HQ# ALLOW RETURN OF STRING ITEMVARS
VERSION 16-2(7) 6-9-72 BY RHT MAKE DONE IN FOREACH CALL ON BEXIT
VERSION 16-2(6) 5-31-72 BY JRL FIX BUG #HM# DRYROT STRING PARAMS TO MESSAGE PROCEDURES
VERSION 16-2(5) 5-24-72 BY RHT MORE GO TO SOLVING
VERSION 16-2(4) 5-24-72 BY rht  make trago look at pda of label
VERSION 16-2(3) 5-14-72 BY DCS BUG #HG# CONSTANT BOOLEANS DIDN'T WORK WITH /H
VERSION 16-2(2) 5-11-72 BY DCS BUG #GW# DON'T CALL AT COMPTIME IF WRONG #PARAMS
VERSION 16-2(1) 5-11-72 BY DCS BUG #GU# NEGAT PROBLEM WITH LIMIT OF FOR ... UNTIL
VERSION 15-6(10) 3-15-72 BY RHT FIX SIMPSW BUGS
VERSION 15-6(9) 3-10-72 BY RHT TO FIX NNEDNEXT WHILE LOOPS
VERSION 15-6(8) 3-6-72 BY RHT FIX SIMPLE BUG
VERSION 15-6(7) 3-6-72 BY RHT FIX SIMPLE PROC DECL BUG
VERSION 15-6(6) 3-6-72 BY RHT fix trago bug
VERSION 15-6(5) 3-1-72 BY DCS CALL RUNTIME FUNCS (CONST ARGS) AT COMPTIME
VERSION 15-2(4) 2-6-72 BY DCS BUG #GP# CHECK FORWARD FORMALS AGAINST THE REAL ONES
VERSION 15-2(3) 2-6-72 BY DCS BUG #FV# CASE N ... ["A"] BLEW
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

⊗;
COMMENT ⊗For-Loop, Case Statement Variables⊗
	LSTON	(STATS)
ZERODATA (LOOP/CASE STATEMENT VARIABLES)

;CASTAK -- PCNT values for each statement of a Case Statement or
;    Expression are stored here via QPUSH (CASTAK is a Q-Descriptor).
;    These are used for setting up the Case dispatch table for 
;    the statement
↓CASTAK: 0

;FORLIS -- QSTACK Descriptor -- each entry is a saved FRBLK, 
;   put here when an inner Loop statement is started.  See
;   FRBLK for contents
↓FORLIS: 0

;FRBLK -- Semantics of current FOR-type loop. See LOOP DSCRs
;   for details of its contents
↓FRBLK: 0

;FRDO -- class index from PARSER (via AC B), telling what kind of loop
↓FRDO: 0

↓FRTYPE: 0	;LOOP TEMP VARIABLE

;NETTMP -- set if this is a NEEDNEXT loop -- coroutine-like code
;    must be generated
↓NETTMP: 0
ENDDATA
COMMENT ⊗  Descriptions of For Loop Constructs, Bit Definitions⊗

BEGIN	LOOP
DSCR FORBG, WAIT, FRSTE, FRLOP, WHIL, DOLOOP, etc.
PRO FORBG WAIT FRSTE FRWHIL FRSTO FRLIST FRLOP WHIL DOLOOP
PRO LOPPS DOUNT DNEXT DDONE
DES These are the generators for any of the looping constructs.
  When the construct is recognized at statement level, a block
  is created and attached to the Semblk for the loop descriptor
  (FORC, WHILC, FOREACH).
 Appropriate routines are called to generate the loop header code.
 The Single routine LOPPS is called at the end of the loop range.
  It generates the return jump (and the ADD to the index variable,
  if a FOR loop) and deletes the Semblk squandered for the interim
  purposes of holding AC numbers, fixups, and the like.

 The syntactic contexts of the calls to these routines are:
   FOR IVB ←			FORBG
   SG E STEP			WAIT
   SG E UNTIL/WHILE		WAIT
   FORC LHS E STEP E UNTIL E SG	FRSTE
   FORC LHS E STEP E WHILE E SG FRWHIL
   FORC LHS E SG		FRSTO
   				FRLIST a for list seen
   				FRLOP a DO seen

   WHILE BE DO			WHIL
   DO				DOLOOP (at statement level)
   DOL S UNTIL BE DO		DOUNT

   @LOOP S END			LOPPS

   NEXT				DNEXT
   DONE				DDONE
⊗
DSCR -- Loop statement Semblk Format
RES The block that is appropriated for use holding things has the 
  following format:

  $DATA		xwd fixup to jump out,,address to jump back to.
  $DATA2	good bits word for this looping statement.
  $DATA3	fixup for any DONE's done.
  $ACNO		ac number for the FOR index
  $DATA4	xwd pointer to step,, pointer to index.
  $ADR		fixup to start of statement (after that, the actual address)
  $VAL		level of forloop start,,0
  $VAL2		pcnt for start of whole thing (used for coroutines).

 Following are good bits stored in $DATA2 for my use in sorting out
  the 10↑6 cases for FOR loops and friends:
⊗
BITDATA (FOR-LOOP SEMBLKS)
↑JSPDON←←	1	;There was a push done at some point (corout or flist)
INCNST←←	2	;Step element is constant.
INPOS ←←	4	;Step element is positive.
INONE ←←       10	;Step element is +- 1

DOUNB ←←       20	;DO <s> UNTIL <be> ;
FSTAT ←←       40	;FOR <id> ← <e> STEP <e> UNTIL <e>
LWHIL ←←      100	;WHILE <be> DO
↑FRCHS ←←      200	;FOREACH x,y ....

↑FLIST ←←      400	;For lists in progress.
↑COROUT←←     1000	;The guy is going to try to use the NEXT thing.
NOJMPS←←     2000	;There are no jumps out or back!
NOJRST←←     4000	;This is a thing without a jump out (i.e. ID←E,E do)
NOMARK←←    10000	;Do not mark index for storing on exit  -
			; either an itemvar  or it was a for step while 
			;which may clobber the index
			;  but will store it at any rate!
↑TMPUS←←    20000	;A temp was used in a for statement.  Do not allow
			;loser to jump into the for loop.
IXVAR  ←←   40000	;INDEXED VAR FOR CONTROL VAR.
DONDON  ←← 200000	;A "DONE" WAS EXECUTED IN THIS LOOP, THE CONTROL
			;VARIABLE MUST NOT BE ASSUMED CORRECT IN THE AC
			; AT LOOP END (SEE MARKIT -- DCS -- 8/2/70)

ENDDATA
COMMENT ⊗  FOR, DO, WHILE, NEEDNEXT Generators⊗

↑FRCHT:	SKIPA	TBITS,[FRCHS]	;FOREACH LIST STARTER.
↑DOLOOP:			;HERE ON START OF "DO"
	MOVEI	TBITS,DOUNB
	JRST	RECORDIT	;GO MAKE A BLOCK.

↑WHIL1:				;START OF "WHILE"
	SKIPA	TBITS,[XWD 0,LWHIL]
	
↑FORBG:				;START OF "FOR"
	MOVEI	TBITS,FSTAT
RECORDIT: PUSHJ	P,ALLSTO 	;CLEAR THE BOARDS
	HRRO	A,FRBLK		;LEFT HALF NEGATIVE.
	QPUSH	(FORLIS)	;PUSH ON THE OLD FRBLK VALUE.
	GETBLK			;AND GET A NEW ONE.
	MOVE	A,LEVEL		;RECORD THE CURRENT LEVEL.
	HRLM	A,$VAL(LPSA)	;AND SAVE.
	AOS	LEVEL		;SO THAT TRAGO WILL SEE US.
	SKIPN	NETTMP		;COROUTINE FEATURE ASKED FOR ?
	JRST	NOCORT		;NO COROUTINES TODAY.
	TRO	TBITS,COROUT!JSPDON	;MARK IT AS SO.
	TRNE	TBITS,LWHIL
	JRST	[
		MOVE	SP,LPSA		;FOR THE ROUTINE TO FOLLOW
		PUSH	P,TBITS
		PUSH 	P,LPSA
		PUSHJ	P,GTJSPR	;KNOW WE HAVE TO GET A JSP REG
		POP	P,LPSA		;RESTORE LPSA
		POP	P,TBITS
		JRST  	.+1]
	MOVE	A,PCNT		;CURRENT PC.
	HRRM	A,$VAL2(LPSA)	;AND FIXUP FOR THE JSP
	TRNE	TBITS,DOUNB	;COROUTINE DISALLOWED FORTHIS
	ERR	<NO COROUTINES HERE, PLEASE>,1
	SETZM	NETTMP		;FOR NEXT TIME. (PUN, PUN)


NOCORT:	MOVE	A,PCNT
	MOVEM	A,$DATA(LPSA)	;SAVE FOR START OF WHILE.
	MOVEM	TBITS,$DATA2(LPSA)	;STORE BITS.
	MOVEM	LPSA,FRBLK	;SAVE FOR INTERESTED PARTIES.
	MOVEM	LPSA,GENRIG	;FOR THE DOLOOP.
	TRNE	TBITS,FRCHS
	TRNN	TBITS,COROUT
	POPJ	P,
	MOVE	SP,LPSA
	PUSHJ   P,GTJSPR		;IF FOREACH COROUTINE, DO MOVEI NOW
	MOVE	LPSA,SP
	POPJ	P,

↑NEXTR:				;HE IS GOING TO ASK FOR NEXT.
	SETOM	NETTMP
	POPJ	P,

↑ENDFOR: PUSHJ	P,INIT		;FINISH OUT FOREACH CODE.
	JRST	DOL1		;NO JUMP BACK, PLEASE.


↑DOUNT:				;HERE ON DO S UNTIL....
	PUSHJ	P,STIF		;GO EVALUATE BOOLEAN.
;	MOVE	B,GENRIG	;RESULTANT FIXUP.
	MOVE	SP,FRBLK
	HRR	B,$DATA(SP)
;;#HG#2↓ 5-14-72 DCS (3-4) TEST ENTIRE LEFT HALF OR /H WON'T WORK
	HLRE	TEMP,B		;IF LH IS -1, WE HAVE
	 AOJE	 TEMP,DONON	;   `DO S UNTIL TRUE', DO ONLY ONCE
	PUSHJ	P,FBOUT		;PUT OUT FIXUP.
	JRST	DONON		;FREE THE BLOCK, ETC.


↑WHIL:				;ALL DONE WITH A WHILE STATEMENT.
	SETZM	FRDO
	PUSHJ	P,STIF		;GO EVALUATE THE BOOLEAN EXPRESSION.
	PUSHJ	P,INIT		;GET GOOD BITS.
;	MOVE	B,GENRIG	;THE HORRID TRUTH.
	HLLM	B,$DATA(SP)	;FIXUP FOR JUMP OUT, LH -1 IF TRUE
	JRST	DOL		;GO MAKE CALLS IF NECESSARY.

↑LFOR:				;HERE FROM LEAP STUFF.
	PUSHJ	P,INIT		;GET SET UP, AND FILL UP "C";
	HRRM	PNT,$DATA4(SP)	;INDEX ... FOR WHAT IT IS WORTH.
	PUSHJ	P,ALLSTO	;STORE EVERYONE.
	TRO	C,NOMARK	;WE DO NOT MARK THE INDEX ON EXIT.
	JRST	FRS1		;GO SEE ABOUT CALLS.

↑FRSTO:				;WE HAVE SEEN A <ID> ← E , OR <ID> ← <E> DO.
	MOVEM	B,FRDO		;B HAS INDEX FROM PARSER.
	SOSL	B,THISE		;SEE WHAT KIND OF EXPRESSION
	JRST	[JUMPN B,LPFRSTO	;LEAP
		 PUSHJ	P,LEVBOL	;BOOLEAN
		 JRST .+1]
	PUSHJ	P,GETINDX	;PICK UP THE INDEX, START VALUE AND SAVE.
	PUSHJ	P,FORST		;GO DO THE STORE.
FRS1:	TRNN	C,FLIST		;IF LIST NOT GOING, THEN
	SKIPE	FRDO		;IF THIS IS THE LAST
	JRST	DOL1
	TRO	C,NOJMPS	;DO NOT EMIT ANY JUMPS.
	JRST	DOL1		;GENERATE CALLS IF NECESSARY.

↑WAIT:				;HERE ON "STEP" OR "UNTIL/WHILE"
	JUMPE	B,GETINDX	;FOR "STEP", JUST RECORD THE INDEX INFO.
	JUMPL	B,CPOPJ		;NOTHING DOING !
	
	CAILE	B,2		;IF NOT UNTIL/WHILE
	POPJ	P,		;GO AWAY.

				;DCS 8/16/70 CONVERT TYPE OF INCR
	MOVE	TEMP,FRBLK	;ALL INFO WE HAVE ABOUT LOOP SO FAR
	HRRZ	TEMP,$DATA4(TEMP) ;SEMANTICS OF INDEX VARIABLE
	HRR	B,$TBITS(TEMP)	;TYPE
	MOVE	PNT,GENLEF+1	;INCREMENT SEMANTICS
	GENMOV	(CONV,INSIST!GETD) ;MAKE SURE THEY MATCH
	MOVEM	PNT,GENLEF+1	;FIXUP
				;DCS 8/17/70
	PUSHJ	P,FORST		;GO HANDLE THE STORE. 
	MOVE	PNT,GENLEF+1	;INCREMENT.
	PUSHJ	P,CLEAR		;MAKE SURE OUT OF AC.
	PUSHJ	P,GETAD		;NOW GET SEMANTICS
	TLNE	SBITS,CORTMP	;IF A TEMP, THOUGH, BE SURE
	 TRO	 C,TMPUS	; NOT TO LET JUMPS COME INTO THE LOOP.
	GENMOV	(CONV,INSIST)	;B STILL LEFT OVER FROM FRSTO.
	QPUSH	(FORLIS,PNT)
	TRZ	C,INONE!INCNST!INPOS	;IN CASE WE COME THROUGH HERE THE SECOND
				;TIME WHEN PUTTING OUT FOR LISTS.
	TLNN	TBITS,CNST	;IF STEP IS CONSTANT, THEN COMPUTE SOME THINGS.
	JRST	NOCVN
	TRO	C,INCNST	;ASSERT CONSTANT.
	SKIPL	$VAL(PNT)	;SEE ABOUT VALUE.
	TRO	C,INPOS		;ASSERT POSITIVE.
	MOVM	TEMP,$VAL(PNT)	;SEE ABOUT VALUE EQUAL TO 1.
	CAIN	TEMP,1
	TRO	C,INONE		;IT IS ONE!
NOCVN:				;PLACE TO JUMP BACK TO IN ORDER TO 
				;COMPUTE LIMIT.
	HRRM	TBITS2,$DATA(SP) ;SINCE STOREB WAS DONE, NOW AC INFO IS ASSUMED
	HRLM	PNT,$DATA4(SP)	;SAVE INCREMENT.

	JRST	FINOUT		;SAVE C AND EXIT.


DIS <
STJSPR:	PUSHJ	P,INIT
	TRNN	C,COROUT	;IS IT A COROUTINE ????
	POPJ	P,		;NO !!!!!!!
	HLRZ	D,$ADR(SP)	;PICK UP AC NO
	JUMPN	D,HAVAC		;IF NOT FIRST TIME, THEN GET THE AC NO NOW
GTJSPR:	PUSHJ	P,GETAN0	;GET THEE AC
	PUSHJ	P,MARKINT	;MAKE IT AN INTEGER TEMP
	HRLM	PNT,$VAL2(SP)	;SAVE THE TEMP
	HRLM	D,$ADR(SP)	;REMEMBER AC NUMBER
	HRRZ	PNT,SP		;
	EMIT	<MOVEI	JSFIX>	;
	POPJ	P,		;
HAVAC:	HLRZ	PNT,$VAL2(SP)	;PICK UP THE TEMP
	CAIN	PNT,0		;IS IT THERE
	ERR	<DRYROT AT WAIT>;NO
	GENMOV	(GET,GETD!SPAC!MRK)
	HRLM	PNT,$VAL2(SP)	;PUT IT AWAY -- NOW KNOW AC IS LOADED FOR 
				;COROUTINE CALL
	POPJ	P,
>;DIS

FORST:				;ROUTINE TO HANDLE THE STORES.
;;#IS# ↓ RHT 7-26-72 NEEDED TO BE SURE MOVEI AC,START IS DONE
	PUSHJ	P,STJSPR	;INIT, SET UP TEMP IF COROUT
	HLRZ	PNT,$DATA4(SP)	;EXPRESSION FOR START 
	HRRZ	PNT2,$DATA4(SP)	;AND INDEX.
DIS <	
	HLRZ	D,$ADR(SP)	;PICK UP AC FOR COROUT OR JSP
	TRNE	C,COROUT!JSPDON	;IF WE HAVE ONE
	HRROS	ACKTAB(D)	;PROTECT IT
>;DIS
	PUSHJ	P,FORSTO	;SPECIAL GOSTO LIKE (A LA BOLSTO)
				;THE POINT OF ALL THIS IS TO STORE ANY INCREMENT
				;CALCULATIONS DONE. (I.E. TEMPS).
				;BUT WE TRY TO KEEP START EXPR IN AC.
DIS <
	CAIE	D,0		;DID WE PROTECT SOMEONE?
	HRRZS	ACKTAB(D)	;YES -- WITHDRAW PROTECTION
>;DIS
	PUSHJ	P,GETAD2	;GET SEMANTICS. OF INDEX
;	TLNE	SBITS2,INDXED!FIXARR
;	 TRO	 C,IXVAR	;INDEXED.
	TLNN	SBITS2,PTRAC	;IS IS INDXED (SHUDDER) ?
	JRST	.+3
	HRRZ	D,$ACNO(PNT2)
	PUSHJ	P,STORA		;GO STORE IT.
;	HLRZ	PNT,$DATA4(SP)	;STARTER VALUE IN PNT.
	PUSHJ	P,GETAD
	HRRI	FF,INSIST!INDX!POSIT!REM ;ALL THESE THINGS.
	SKIPE	D,$ACNO(SP)	;OLD DUSTY AC ?
	TRO	FF,SPAC		;YES -- AND MORE.
	HRRZ	B,TBITS2	;TO FORCE TYPE CONVERSION TO INDEX TYPE.
	GENMOV	(GET)		;MAGIC
	MOVE	TBITS,PCNT	;REMEMBER PROGRAM COUNTER.
				;(NOTE EXCHOP IN NEXT INSTR)
	GENMOV	(PUT,EXCHIN)	;MARK FOR STORE -- ACTUALLY STORE IF THE
				;THING WAS INDXED.
	MOVEM	D,$ACNO(SP)	;NEW AC# IF ANY.
	MOVEM	B,FRTYPE	;SAVE TYPE FOR THIS LIST.
	POPJ	P,

GETINDX:			;PICK UP INDEX AND STARTERD....
	MOVE	SP,FRBLK	;GET CURRENT BLOCK.
	MOVE	A,GENLEF+2	;INDEX
	HRL	A,GENLEF+1	;STARTER
	MOVEM	A,$DATA4(SP)
	POPJ	P,		;DONE
COMMENT ⊗    (continued),  NEXT, DONE, CONTINUE⊗

↑FRWHILE:			;HERE ON FOR-STEP-WHILE
	MOVEM	B,FRDO		;INDEX FROM PARSER.
	PUSHJ	P,STIF		;EVALUATE THE BOOLEAN
;	MOVE	B,GENRIG	;FALSE FIXUP
	PUSHJ	P,INIT
	HLLM	B,$DATA(SP)	;FIXUP FOR JUMP OUT.
	TRNE	C,FLIST!COROUT	;ONLY IF STATEMENT BEING PUSHJ'ED TO, DO WE
	PUSHJ	P,INDXGET	;GET THE INDEX BACK IN THE RIGHT AC.
	TRO	C,NOMARK	;DO NOT MARK INDEX AC ON EXIT -- STIF STORED IT.
	JRST	DOL		;SEE ABOUT CALLING THE STATEMENT.
	
↑FRSTE:				;HERE ON FOR-STEP-UNTIL
	MOVEM	B,FRDO		;INDEX FROM PARSER.
	PUSHJ	P,INDXGET	;GET INDEX BACK IN THE AC.
	MOVE	B,FRTYPE
;;#GU# 5-11-72 DCS NEGAT BUG FIX
	GETSEM	(1)		;LIMIT
	TLNN	SBITS,NEGAT	;DO WE HAVE TO DO IT?
	 JRST	 LIMOK		; NO, GOOD
	PUSH	P,D
	GENMOV	(GET,PROTECT!INSIST!POSIT!UNPROTECT) ;GET RIGHT GUY
	POP	P,D
	JRST	NOWOK		;NOW IT'S OK
LIMOK:	GENMOV	(ACCESS,PROTECT!INSIST!UNPROTECT)    ;BLESS IT
;;#GU#
NOWOK:	TRNE	C,INCNST	;IS INCREMENT CONSTANT ?
	JRST	FRCNST		;YES -- DO OTHER THINGS.

	HRL	C,D
	PUSHJ	P,GETAN0	;WE WOULD OTHERWISE CLOBBER PROTECTED AC.
	EMIT	(MOVE USADDR!NORLC)
	MOVSI	A,(<SUB>)	;SUBTRACT INDEX-LIMIT
	TRNN	TBITS,INTEGR	;CORRECT ?
	MOVSI	A,(<FSB>)
	PUSHJ	P,EMITER	;AC NOW HAS INDEX - LIMIT.
	MOVS	PNT,$DATA4(SP)	;INCREMENT.
	EMIT	(SKIPL NOUSAC)	;SKIPL INCREMENT
	HRL	C,D		;GET AC #
	EMIT	(MOVNS NOUSAC!USADDR!NORLC)
	MOVE	A,[JUMPL NOADDR];THE JUMP OUT.
	JRST	REMTMP

FRCNST:	MOVSS	C		;BECAUSE WE NEED CONDITION BITS.
	HRRI	C,3		;CODE FOR ≤
	TLNN	C,INPOS		;ASSUMPTION CORRECT?
	HRRI	C,5		;CODE FOR ≥
	MOVE	A,[CAM USCOND]	;THE SUPER COMPARE INSTRUCTION.
	PUSHJ	P,EMITER
	MOVSS	C
	MOVE	A,[JRST NOUSAC!NOADDR]

REMTMP:	MOVE	TEMP,PCNT	;PROGRAM COUNTER OF THE JRST.
	HRLM	TEMP,$DATA(SP)	;SAVE IT.
	PUSHJ	P,EMITER
	MOVE	D,$ACNO(SP)	;GET BACK AC NUMBER
	MOVE	LPSA,GENLEF+1	;LIMIT
	PUSHJ	P,REMOPL	;ALL DONE WITH IT.
DOL:	TRZA	C,NOJRST	;INDICATE THAT ADD'S ARE TO BE DONE.
DOL1:	TRO	C,NOJRST	;INDICATE NOT AN ADDITIVE FOR STATEMENT.

				;NOW GENERATE CALLS TO STATEMENT IF NECESSARY.
	TRNN	C,COROUT!FLIST	;THESE ARE THE INTERESTING CASES.
	JRST	FINTO
	TRNE	C,COROUT	;COROUTINE ?
	PUSHJ	P,CRCAL		;CALL IT.
	TRNN	C,COROUT	;IF ONLY A FOR LIST, THEN
	PUSHJ	P,FLSCAL	;CALL IT.
ENDIT:
LEP <
	TRNE	C,FRCHS		;FOREACH ?
	JRST	[PUSH	P,C
		 LPCALL (FRLOOP)
		 POP	P,C
		 JRST LSTTST]
>;LEP
	TRNE	C,NOJRST!NOJMPS	;IF NOT ADDING LOOPING STATEMENT,
	JRST	LSTTST		;GO SEE ABOUT FIXUPS AND THINGS.
	TRNN	C,FSTAT		;IF NOT FOR STATEMENT, THEN EMIT THE JRST
	JRST	[		;BACK TO THE BEGINNING.
		 HRL	C,$DATA(SP)
		 EMIT	(JRST NOUSAC!USADDR)
		 JRST	LSTTST]
	
ADDIT:	HRRZ	D,$ACNO(SP)	;MAY HAVE BEEN MANGLED BY COROUT STUFF
				;NOW IS THE TIME TO PUT OUT THE ADDS AND THINGS.
	TRNE	C,INONE		;IS INCREMENT CONSTANT AND ONE ?
	JRST	ACCDOM		;YES
	HLRZ	PNT,$DATA4(SP)	;INCREMENT.
	PUSHJ	P,GETAD
	MOVSI	A,(<ADD>)
	TRNN	TBITS,INTEGR	;IS THIS CORRECT ?
	MOVSI	A,(<FADR>)
	PUSHJ	P,EMITER
	MOVE	A,[JRST NOUSAC!USADDR]
	JRST	EJRT		;TO EMIT IT.

ACCDOM:	MOVE	A,[AOJA USADDR]
	TRNN	C,INPOS
	HRLI	A,(<SOJA>)
EJRT:	HRL	C,$DATA(SP)	;JUMP BACK.
	PUSHJ	P,EMITER	;EMIT IT.

LSTTST:	
	SKIPN	FRDO		;WAS THIS THE LAST ?
	JRST	FLTEST		;YES -- GO SEE ABOUT FOR LISTS.
	TRNE	C,NOJRST	;JUMPS BACK?
	JRST	FINTO
	HLLZ	B,$DATA(SP)	;FIXUP FOR JUMP OUT.
	HRRZS	$DATA(SP)	;RESTART IT.
	HRR	B,PCNT
	PUSHJ	P,FBOUT
	JRST	FINTO		;FIXUP DONE -- GO AWAY.

FLTEST: TRNE	C,NOJRST!COROUT	;IF ALREADY A JUMP OUT OR
	TRNN	C,FLIST!COROUT	;NO FOR LIST GOING AND NO COROUTINE
	JRST	STAT		; -- RECORD START OF STATEMENT.
	HRRZ	B,PCNT		;NONE -- NEED TO PUT IN JRST
	TRNE	C,COROUT	;COROUTINE??
	JRST	[ 
		HLL	B,$DATA(SP)	;FIXUP FOR THE JUMPS TO EXIT
		TLNE	B,-1		;IF ANY
		PUSHJ	P,FBOUT		;
		HRRZS	$DATA(SP)	;START OVER
		HLRZ D,$ADR(SP) ;JSP REGISTER
		GENMOVE(GET,GETD!SPAC!POSIT);
		HRLZ	D,D
		HRLI	C,1
		EMIT	<JRST NOUSAC!NORLC!USX!USADDR>
		JRST	STAT
		]
	HRLM	B,$DATA(SP)	;MAKE A FIXUP FOR JUMP OUT.
	EMIT	<JRST NOUSAC!NOADDR>
STAT:	TRNN	C,COROUT!JSPDON	;COROUTINE OR FOR LIST -- IE A JSP THING
	JRST	STAT.1		;NO
	HRLZ	B,PCNT		;PICK UP PCNT
	HLRM	B,$DATA3(SP)	;REMEMBER WHERE
	HLRZ	PNT,$VAL2(SP)	;THIS TEMP
	PUSHJ	P,REMOP		;IS NOW KAPUT
	HLRZ	D,$ADR(SP)	;PICK UP THE AC
	PUSHJ	P,MARKINT	;NEW TEMP
	HRLM	PNT,$VAL2(SP)	;SAVE IT
	TRNE	C,COROUT	;IF COROUTINE
	JRST	FINTO		;THE "START" IS AT THE END (SO SKIP RETURN WORKS)

STAT.1:	HRLZ	B,$ADR(SP)	;SAY THAT THIS IS THE START 
	HRR	B,PCNT		;THIS IS THE START OF STATEMENT.
	TLNE	B,-1
	PUSHJ	P,FBOUT
FINTO:	SKIPE	FRDO		;IF NOT LAST, THEN DON'T RECORD.
	JRST	FINOUT
	MOVEM	SP,GENRIG	;RECORD BEFORE GOING AWAY.
	MOVEM	SP,GENRIG+2	;.....
	

FINOUT:	MOVEM	C,$DATA2(SP)	;SAVE C
	POPJ	P,		;AND EXIT.

FLSCAL:	MOVE	PNT,SP		;FOR LIST CALL.
NODIS <
	TRO	C,PSHDON
	EMIT	<PUSHJ RP,NOUSAC!JSFIX>	;EMITER CHAINS FIXUPS.
>;NODIS
DIS <
	TRO	C,JSPDON
	PUSH	P,D		;DO I REALLY NEED TO?????????
	HLRZ	D,$ADR(PNT)	;
	JUMPN	D,EMTIT
	PUSH	P,PNT
	PUSHJ	P,GETAN0	;
	PUSHJ	P,MARKINT
	HRLM	D,$ADR(SP);
	HRLM	PNT,$VAL2(SP);
	POP	P,PNT
EMTIT:
	EMIT	<JSP  JSFIX>
	POP	P,D
>;DIS

	POPJ	P,

CRCAL:	
NODIS <
GAG < ;MAKE SURE NEXT 4 WORDS CAN GO OUT IN A CONTIGUOUS BLOCK
	MOVEI	LPSA,4
	PUSHJ	P,TWOOUT
>;GAG
	HRL	C,PCNT		;CURRENT PC.
	ADD	C,[XWD 3,0]	;FOR MOVEI AC,.+3
CRCAL2: PUSH	P,D
	HRROS	ACKTAB(D)		;PROTECT AGAINST NEXT GETAC.
	PUSHJ	P,GETAN0	;GET INDEXABLE AC.
	EMIT	(MOVEI USADDR)
	EMIT	<EXCH (RP) NOADDR>
	MOVSS	D		;FOR INDEXABLE.
GAG <
	MOVEI	LPSA,2		;MAKE SURE NEXT TWO WORDS STAY TOGETHER
	PUSHJ	P,TWOOUT
>;GAG
	EMIT	(JRST USX!NOUSAC!NOADDR)
	POP	P,D
	HRRZS	ACKTAB(D)	;AND RESTORE.
	POPJ	P,
>;NODIS
DIS <
	HLRZ	PNT,$VAL2(SP)	;TEMP SEMBLK
	HLRZ	D,$ADR(SP)	;AC NO
	SKIPE	TEMP,ACKTAB(D)	;WHAT IT THINKS IS THERE
	CAIN	PNT,(TEMP)	;IF NOTHING OR SAME THING
	JRST	TRISOK		;THEN DONT NEED TO 
	GENMOV	(GET,GETD!SPAC!POSIT);GET IT THERE
TRISOK:	EMIT	<JSP INDRCT>	;CALL IT 
	POPJ	P,
>;DIS


INIT:	MOVE	SP,FRBLK
	SKIPE	BNFG		;WANT A NAMED BLOCK??
	PUSHJ	P,FNLBK		;YES
	MOVE	C,$DATA2(SP)	;GOOD BITS WORD.
	SKIPE	FRDO		;FOR LIST (I.E. A COMMA)?
	TRO	C,FLIST		;RECORD THIS FOR ALL TIME.
	MOVE	D,$ACNO(SP)	;SET UP PRIVILEGED AC NUMBER.
	POPJ	P,

↑LOPPS:				;HERE AT END OF STATEMENT.
	PUSHJ	P,INIT
	HLLZ	B,$ACNO(SP)	;ANY "CONTINUE" FIXUPS DONE HERE
	JUMPE	B,DSTQQ
	MOVE	PNT,ACKTAB(D)	;IF (D) STILL HOLDS THE INDEX, THEN PROTECT
	HRRZ	PNT2,$DATA4(SP)	; WHAT I THINK INDEX IS
	CAIN	PNT2,(PNT)
	HRROS	ACKTAB(D)
	PUSHJ	P,ALLSTO
	HRRZS	ACKTAB(D)
	HRR	B,PCNT		;DO THE CONTINUE FIXUP NOW
	PUSHJ	P,FBOUT
DSTQQ:	PUSHJ	P,STORQQ	;STORE EVERYONET RELEVANT.
				;BUT PERHAPS NOT THE INDEX.
	TRNE	C,FLIST!COROUT	;ANY OF THESE THINGS ?
	JRST	HARDER		;YES -- ADDS ALREADY DONE.
	PUSHJ	P,ENDIT		;SEE ABOVE -- EMIT THE ADDS.
	JRST	MARKIT		;GO MARK THE AC, EMIT JUMP FIXUPS.
NODIS <

HARDER:	SOS	ADEPTH		;UNDO THE DAMAGE.
	TRNN	C,COROUT	;WAS IT A COROUTINE ?
	JRST	[EMIT <POPJ RP,NOUSAC!NOADDR>
		 JRST	MARKIT	]
	HRL	B,$VAL2(SP)	;FIXUP FOR PUSH RP,[XX]
	HRR	B,PCNT	
	PUSHJ	P,FBOUT		;DO IT NOW
	HRL	C,$ADR(SP)	;START OF STATEMENT
	PUSHJ	P,CRCAL2	;GO EMIT THE NEAT INSTRUCTIONS.
DOPOP:	EMIT	<POP RP,NOUSAC!NOADDR(RP)>
>;NODIS

DIS <
HARDER:	TRNN	C,COROUT	;COROUTINE??
	JRST	[HLRZ	PNT,$VAL2(SP)
		EMIT	<JRST	NOUSAC!INDRCT>  ;NO
		PUSHJ	P,REMOP		;FLUSH IT
		JRST	MARKIT
		]
	PUSHJ	P,CRCAL		;COROUTINE CALL
	HRLZ	B,$ADR(SP)	;THE "START" IS HERE
	HRR	B,PCNT
	PUSHJ	P,FBOUT		
	HRL	C,$DATA3(SP)	;REAL START OF LOOP ADDRS
	EMIT	<JRST NOUSAC!USADDR>
	HLRZ	PNT,$VAL2(SP)	;WE DONT NEED HIM ANY MORE
	PUSHJ	P,REMOP
>;DIS



MARKIT:	
JUMPOUT:
;	TRNN	C,IXVAR		;IF INDEXED VAR.
;	JRST	.+3
;	PUSHJ	P,REMOPA	;CLEAR OUT AC TABLE ENTRY.
;	SETZM	ACKTAB(D)
	TRNE	C,NOMARK	;IF HE REALLY DIDN'T WANT THE THING MARKED
	PUSHJ	P,CLEARA	;WIPE OUT THE AC.
	TRNE	C,DONDON	;DID SOMEBODY JUMP OUT VIA "DONE"?
	PUSHJ	P,CLEARA	;YES, WIPE OUT AC (DCS -- 8/2/70)
JMGO:	TRNE	C,NOJMPS	;IF NO JUMPS WERE DONE,
	 JRST	 ALDON		;THEN ALL DONE
	HLL	B,$DATA(SP)	;PLACE TO JUMP OUT.
	HRR	B,PCNT		;
;;#HG#2↓ 5-14-72 DCS (4-4) TEST ENTIRE LEFT HALF, OR /H WON'T WORK
	HLRE	TEMP,B		;If left half is -1, 
	 AOJE	 TEMP,DONON	;   there was no JRST FALSE (BE was TRUE)
NODIS <
	TRNE	C,COROUT	;BACK UP ONE PAST THE POP
	SUBI	B,1
>;NODIS
	PUSHJ	P,FBOUT		;FIXUP TO JUMP OUT.
DONON:	HLLZ	B,$DATA3(SP)	;"DONE" FIXUP
	JUMPE	B,ALDON		;THESE HAVE FINISHED.
	HRR	B,PCNT
	PUSHJ	P,FBOUT
ALDON:	FREBLK	<SP>		;GOING,
	SOS	LEVEL
POPER:	QPOP	(FORLIS)	; GOING,
	JUMPL	A,DONER		;REMOPS DONE.
	MOVE	PNT,A
	PUSHJ	P,REMOP
	JRST	POPER
DONER:	
	HRRZM	A,FRBLK		;  GOING,
	POPJ	P,		;    GONE.

↑DDONE:				;HERE ON "DONE" CONSTRUCT
	SKIPN	SP,FRBLK
	 ERR	 <"DONE" ILLEGAL OUTSIDE LOOP>,1,DDPOPJ
DONEXX:	PUSHJ	P,GOSTO		;IT IS SAME AS A GO TO
	MOVE	B,LEVEL
	HLRZ	SBITS,$VAL(SP)	;LOOP LEVEL
	MOVE	C,$DATA2(SP)	;IF FOREACH STATEMENT, GO ONE MORE TO
	TRNE	C,FRCHS		;GET OUT OF THE FAKE BLOCK
	SUBI	SBITS,1
	PUSHJ	P,TRAGO
	HRRZ	C,$DATA3(SP)	;PROTECT RH FROM EXCH
	HRL	C,PCNT
	EXCH	C,$DATA3(SP)	;CHAIN FIXUPS FOR DONE.
NODIS <
	MOVEI	TEMP,DONDON	;INDICATE THAT A "DONE" WAS DONE
	ORM	TEMP,$DATA2(SP) ; IN FOR LOOP CONTROL BLOCK (DCS 8/2/70)
>;NODIS
DIS <
	MOVE	TEMP,$DATA2(SP)
	TRO	TEMP,DONDON
	TRZ	TEMP,NOJMPS
	MOVEM	TEMP,$DATA2(SP)
>;DIS
	EMIT	(JRST NOUSAC!USADDR)
DDPOPJ:	POPJ	P,

↑DNEXT:				;HERE ON "NEXT" CONSTRUCT
NODIS <
	PUSHJ	P,STOREB
>;NODIS
DIS <
	PUSHJ	P,STORQQ
NEXTXX:	TRZ	C,NOJMPS
	HRRM	C,$DATA2(SP)
>;DIS

	TRNE	C,COROUT	;ONLY ALLOW IF COROUTINE
NODIS <
	JRST	CRCAL		;GENERATE COROUTINE CALL.
>;NODIS
DIS <
	JRST	CTCOR		;GO CALL THE COROUTINE
>;DIS

	ERR	<USED NEXT WITHOUT PREPARATION>,1
	POPJ	P,

DIS <
CTCOR:	PUSHJ	P,CRCAL			;CALL THE COROUTINE
	PUSH	P,PCNT
	EMIT	<JRST NOUSAC!NOADDR>
	MOVE	B,LEVEL
	HLRZ	SBITS,$VAL(SP)
	MOVE	C,$DATA2(SP)	;IF FOREACH STATEMENT, GO ONE MORE TO
	TRNE	C,FRCHS		;GET OUT OF THE FAKE BLOCK
	SUBI	SBITS,1
	PUSHJ	P,TRAGO			;SOLVE THE GO TO
	HLLZ	C,$DATA(SP)		;JUMP OUT 
	HRR	C,PCNT			;FIXUP
	HRLM	C,$DATA(SP)		;
	EMIT	<JRST NOUSAC!USADDR>
	POP	P,B
	HRLZ	B,B
	HRR	B,PCNT
	PUSHJ	P,FBOUT
	HLRZ	PNT,$VAL2(SP)		;TEMP FOR COROUT VAR
	HRLZI	SBITS,INAC		;MARK IT INAC
	ORM	SBITS,$SBITS(PNT)
	HLRZ	D,$ADR(SP)		;THE ACNO
	HRRZM	D,$ACNO(PNT)
	HRRZM	PNT,ACKTAB(D)		;SAY AC IS FULL OF IT
	POPJ	P,
>;DIS

STORQQ:	PUSHJ	P,QQW
	SKIPA	PNT,[0]
	HRRZ	PNT,ACKTAB(D)
	HLRZ	PNT2,$VAL2(SP)	;DONT WIPE THESE OUT -- JSP TEMP
	JRST	BOLSTO

↑CNTNUE:
	SKIPN	SP,FRBLK		;FETCH FOREACH BLOCK
	ERR	<"CONTINUE" ILLEGAL OUTSIDE LOOP">,1,CCPOPJ
CONTXX:	PUSHJ 	P,GOSTO			;SAME AS A GO TO
	MOVE	B,LEVEL
	HLRZ	SBITS,$VAL(SP)		;LOOP LEVEL
	PUSHJ	P,TRAGO			;SOLVE IT
	HRL	C,PCNT			;FIXUP
	HRR	C,$ACNO(SP)		;
	EXCH	C,$ACNO(SP)		;
	EMIT	<JRST NOUSAC!USADDR>	;JUMP TO LOOP END
CCPOPJ:	POPJ	P,

↑NEXTBN:	;NEXT -- WITH BLOCK NAME
	SETOM	BNFG			;SET A FLAG FOR INIT
	PUSHJ	P,STORQQ		;
	SETZM	BNFG			;

	JRST	NEXTXX			;

ZERODATA ()
BNFG:	0				;FLAG TO TELL INIT TO FIND BLOCK NAME
ENDDATA

↑CONTBN:	;CONTINUE WITH BLOCK NAME
	PUSHJ	P,FNLBK
	JRST	CONTXX

↑DONEBN:	;DONE WITH BLOCK NAME
	PUSHJ	P,FNLBK
	JRST	DONEXX

FNLBK:	;FINDS THE NAMED LOOP BLOCK

;FIRST SEARCH FOR THE NAMED BLOCK

	MOVE	A,GENLEF
	MOVE	LPSA,$PNAME+1(A)	;THE REQUESTED NAME
	MOVE	TBITS2,PPSAV		;STACK POINTERS
	MOVE	SBITS2,GPSAV	
LKNPE:	HRRZ	C,(TBITS2)		;PARSE ENTRY
	CAME	C,%NBEG			;A BEGIN???
	JRST	CHKILL			;NO
	MOVE	TEMP,(SBITS2)		;SEM ENTRY
	CAME	LPSA,$PNAME+1(TEMP)	;SAME???
	JRST	NXTBK			;NO

;HERE CHECK NEXT THING BACK TO SEE IF A LOOP
	HRRZ	C,-1(TBITS2)		;PICK UP
	CAME	C,%DOL			;
	CAMN	C,%WHILC
	JRST	OKBNM
	CAME	C,%ASSDO
	CAMN	C,%NFORC
	JRST	OKBNM
	ERR	<"DONE", "NEXT", OR "CONTINUE" TO A BLOCK NOT THE
		BODY OF A LOOP >,1
EREXT:	SKIPE	BNFG			;FROM NEXT?
	JRST	[ POP	P,(P)		;YES, TWO MORE LEVELS IN
		POP	P,(P)
		JRST	.+1 ]
	POP	P,(P)
	POPJ	P,

OKBNM:	MOVE	SP,-1(SBITS2)		;GET THE SEMANTICS INTO SP
	POPJ	P,

CHKILL:	CAMN	C,%NPDEC		;PROCEDURE DECL
	JRST	[ ERR <ATTEMPT TO "DONE", "NEXT", OR "CONTINUE" OUT OF PROCEDURE>,1
		JRST	EREXT ]
	CAMN	C,%NBLAT
	JRST	[ ERR <ATTEMPT TO "DONE", "NEXT", OR "CONTINUE" A BLOCK
THAT I CANT FIND>,1
		JRST	EREXT]
NXTBK:	SOS	TBITS2
	SOJA	SBITS2,LKNPE


STOREB: PUSHJ P,QQW	;DO IT.
	JRST	ALLSTO	;IF NOT FOR LOOP,STORE.
	HRROS	ACKTAB(D)	;PREPARE FOR STORES.
	PUSHJ	P,ALLSTO
	HRRZS	ACKTAB(D)
	POPJ	P,

INDXGET: TLOA	FF,FFTEMP
QQW:	TLZ	FF,FFTEMP
	PUSHJ	P,INIT
	TRNN	C,FSTAT		;FOR STATEMENT?
	POPJ	P,		;NO GETTING TO BE DONE.

	MOVE	PNT,$DATA4(SP)	;INDEX.
	PUSHJ	P,GETAD
	TRNE	TBITS,STRING	;IF STRING,
	POPJ	P,		;ALL DONE.
	PUSH	P,SBITS		;SAVE.
	GENMOV	(GET,SPAC!POSIT) ;GET INDEX ......
	POP	P,TEMP		;RESTORE SBITS.
	TLNN	TEMP,INDXED!FIXARR	;IF THESE,
	 JRST	 NOIXX
	TLZ	TEMP,PTRAC!INAC	;....
	MOVEM	TEMP,$SBITS(PNT)	;RESTORE IT.
	SETZM	ACKTAB(D)		;AND....
NOIXX:	TLNN	FF,FFTEMP	;NOT IF JUST INDXGET.
	AOS	(P)		;SKIP RETURN.
	POPJ	P,

BEND	LOOP
SUBTTL Land of Labels.
COMMENT ⊗ENTLAB, TRA -- generators for label placement, Go To statements⊗

BEGIN	LABEL
DSCR ENTLAB, TRA
DES Execs for handling labels
 For now, we are dealing with labels in the obvious way.
  When in doubt, the poor loser cannot do the transfer he
  requests.  When we get more smarts, we can provide more features
  (bugs?).

 Semantic contexts:
  ILB :			ENTLAB
  GOTO ILB		TRA
SEE TRAGO DSCR, for the routine which does most of the work
 (it is also used by RETURN, LOOP code)
⊗

↑ENTLAB: PUSHJ	P,ALLSTO	;CLEAR THE BOARDS.
	GETSEM	(1)
	MOVE	LPSA,PNT
	TRZN	TBITS,FORWRD	;IT IS NO LONGER FORWARD.
	ERR	<LABEL ALREADY DEFINED:>,3
	MOVEM	TBITS,$TBITS(PNT)
	HRLZ	B,$ADR(PNT)	;FIXUP
	JUMPE	B,ENT1		;HAS NOT BEEN USED YET.
	HRR	B,PCNT
	PUSHJ	P,FBOUT		;EMIT THE FIXUP.
ENT1:	MOVE	B,PCNT
	HRRZM	B,$ADR(PNT)	;THIS IS THE ADDRESS.
	MOVE	B,LEVEL		;THE LEVEL CURRENTLY AT.
	PUSHJ	P,TRAG1		;SPECIAL -- TO GUARANTEE ACCESS.
	TLNN	FF,FFTEMP	;SUCCESSFUL ?
	ERR	<LABEL DEFINED AT LOWER LEVEL>,1
	POPJ	P,		;YES




↑TRA:	PUSHJ	P,GOSTO		;STORE EVERYONE -- HE MAY BE NEEDED
	GETSEM	(0)		;THE TARGET
	MOVE	B,LEVEL		;CURRENT LEVEL
	HLRZ	PNT2,$ACNO(PNT)	;PICK UP PDA SEMBK (MAY JUMP OUT OF PROC)
	PUSHJ	P,TRAGO		;DO THE WORK.
EMJRST:	GETSEM	(0)		;AGAIN
	MOVE	A,[JRST NOUSAC]
	JRST	EMITER		;ALL THROUGH.
COMMENT ⊗  TRAGO -- go-to-solver -- used also by RETURN code⊗

DSCR TRAGO, TRAG1 -- general complicated-jump solver
CAL PUSHJ from points within Label, Loop, RETURN code.
PAR AC B contains the LEVEL we are at.
 AC SBITS contains the level we are trying to reach.
 AC PNT2 POINTS AT TARGET PDA IF JUMP OUT OF PROC
DES TRAGO and TRAG1 search up the stack looking for syntactic
  things that may need attention. If the level comparison indicates
  putting out <ARRAY RELEASE> instructions, this is done. Note
  that we disallow jumping out of a Procedure.  Stack adjustment
  many levels deep in recursion could be messy.
 TRAG1 is called when a Label is finally defined to make sure of free
  access from the level at which the label was "declared" to the level
  at which it is finally defined.  This prohibits jumping into certain
  kinds of For Loops (those with stack problems), jumping into
  Foreach statements, jumping into Blocks with Arrays dynamically
  declared, etc.
⊗
DIS <
ZERODATA(LOCAL  NAMES FOR GO TO SOLVER)
BK:	0	;SET TO SEMBLK FOR FIRST BLOCK OUT TO NEED EXITING
BL:	0	;SET TO COUNT OF BLOCKS OUT TO GO
ENDDATA

BIT2DATA (BIT DEFS FOR GOOD GO TO SOLVING BITS)
ENDDATA

>;DIS


TRAG1:	TLOA	FF,FFTEMP
↑TRAGO:	TLZ	FF,FFTEMP	;B HAS LEVEL OF JUMP
	LDB	C,[POINT LLFLDL,SBITS,=35]	;C HAS LEVEL OF LABEL
	SUB	B,C		;B HAS NUMBER OF BLOCKS WE MUST GO UP.
	JUMPE	B,CPOPJ		;NO BLOCKS TO GO THROUGH.
DIS <	SETZM	BK		;ZERO PLACE KEEPERS
	SETZM	BL;
>;DIS
	MOVE	TBITS2,PPSAV
	MOVE	SBITS2,GPSAV	;PICK UP STACK POINTESS
TOK:	HRRZ	C,(TBITS2)	;PARSE ENTRY.
	CAME	C,%DOL		;DO S UNTIL BE.
	CAMN	C,%WHILC	;WHILE BE DO...
	JRST	.+3
	CAME	C,%ASSDO	;A FOREACH LOOP ?
	CAMN	C,%NFORC	;A FOR LOOP ????
NODIS <
	JRST	[
		 MOVE	TEMP,(SBITS2)	;SEMANTICS.
		 MOVE	TEMP,$DATA2(TEMP) ;GOOD BITS.
		 TRNN	TEMP,PSHDON!TMPUS	;PUSH DONE ?
		 JRST	NOPSH		;NO PUSHES NEEDED.
		 TLZE	FF,FFTEMP	;IF TRYING TO JUMP IN,
		 POPJ	P,		;NOTHING DOING.
		 MOVE	A,[POP RP,NOUSAC!NOADDR(RP)]
		 TRNE	TEMP,PSHDON	;EMIT ONLY IF PUSH WAS DONE.
		 PUSHJ	P,EMITER
NOPSH:
LEP <
		 TRNN	TEMP,FRCHS	;FOREACH ?
>;LEP
		 JRST	LGOUP		;GO AHEAD.
LEP <
		 TLZE	FF,FFTEMP	;IF TRYING TO JUMP IN,,,
		 POPJ	P,		;NOTHING DOING.
		 LPCALL	(FRELS)		;RELEASE FOREACH.
		 JRST	LGOUP		;THIS COUNTS AS ONE LEVEL.
>;LEP
]
	CAME	C,%NBEG		;IS THIS A "BEGIN"
	JRST	PCKH		;NO -- GO ON.
	SKIPL	PNT,(SBITS2)	;SEMANTICS FOR IT.
	JRST	PCKH		;NONE -- THERE WERE NO DECLARATINS.
LARY:	MOVE	TBITS,$VAL(PNT)	;PICK UP THE TYPES DECLARED
	TLNN	TBITS,SBSCRP	;ARRAYS DECLARED?
	JRST	LGOUP		;NO
	TLZE	FF,FFTEMP	;IF ONLY WANTING ACCESS, THEN
	POPJ	P,		;FOUND OUT ALL WE WANTED TO KNOW.
	XCALL	<ARREL>		;RELEASE ARRAYS.
LGOUP:
	SOJE	B,CPOPJ		;GONE UP ENOUGH LEVELS
PCKH:	CAMN	C,%NPDEC	;PROCEDURE DECLARATION?
	ERR	<JUMPING OUT OF PROCEDURE -- NO>,1
	SOS	SBITS2
	SOJA	TBITS2,TOK	;LOOP UNTIL GONE BACK FAR ENOUGH.
>;NODIS

DIS <

	JRST	[
		MOVE	TEMP,(SBITS2)	;SEMANTICS
		MOVE	TEMP,$DATA2(TEMP); GOOD BITS
		NOLEP	<
		TRNN	TEMP,COROUT!FLIST
		>;NOLEP
		LEP <
		TRNN	TEMP,COROUT!FLIST!FRCHS
		>;LEP
	   	JRST	LGOUP 			;NOTHING EXCITING

		TLZE	FF,FFTEMP		;LOSE IF COMING IN
		POPJ	P,
		JRST	LGOUP
		]
TRYAL:	CAMN	C,%NBEG				;MIGHT IT BE A BLOCK
	JRST	DOBLK				;TREAT IT AS A BLOCK
	CAME	C,%BLKFRC			;FOREACH THING
	JRST	TRYUP				;NO
	SKIPL	PNT,(SBITS2)			;GET SEMANTICS FOR THIS
	ERR	<DRYROT AT TRAGO -- MISSING SEM FOR FOREACH>
	SKIPN	SIMPSW
	JRST	TGI				;GO SET UP FOR BEXIT
	TLZE	FF,FFTEMP			;SIMPLE PROC, CHECK GOING IN
	POPJ	P,
	LPCALL	(FRELS)				;RELEASE THE SO AND SO
	JRST	LGOUP				;GO ON UP
DOBLK:
	SKIPL	PNT,(SBITS2)			;GET SEM
	JRST	NXPRSU				;NONE
	MOVE	TBITS,$VAL(PNT)
	TDNN	TBITS,[XWD SBSCRP,SET]		;ALLOCATIONS?
	JRST	LGOUP				;NO
TGI:	TLZE	FF,FFTEMP			;GOING IN?
	POPJ	P,				;LOSE
 MRKUP:	SKIPN	BK			;IF FIRST BACK,SAY SO
	MOVEM	PNT,BK			;THIS IS THE FIRST
	AOS	BL			;INCR COUNT
LGOUP:	SOJE	B,XBKS				;IF UP, GO PUT OUT BEXIT
TRYUP:	CAMN	C,%NPDEC			;PROC?
	JRST	JOOPR				;YES, GO JUMP OUT
NXPRSU:	SOS	SBITS2
	SOJA	TBITS2,TOK
JOOPR:	TLZE	FF,FFTEMP			;
	POPJ	P,				;OK
	PUSHJ	P,XBKS				;GET OUT OF CURRENT BLOCKS
	MOVE	PNT,PNT2			;PICK UP PDA SEMBK
	EMIT	(<HRRZI LPSA,NOUSAC!JSFIX>)	;HRRZI LPSA,PDA_OF_LABEL
	LDB	C,[LLFLDL,SBITS,=35]		;PICK UP LEX LEV OF LABEL
	MOVSS	C				;FOR EMITER
	EMIT	<HRLI LPSA,NOUSAC!USADDR!NORLC>	;HRLI LPSA,LL
	XCALL	<STKUWD>			;CALL THE STACK UNWINDER
	POPJ	P,				;ALL DONE
XBKS:	SKIPN	B,BK				;ANY TO EXIT
	POPJ	P,				;NO
	HLLZ	C,$SBITS(B)
	HRR	C,PCNT
	HRLM	C,$SBITS(B)
	EMIT	<HRRZI LPSA,NOUSAC!USADDR>
	SOSG	B,BL
	JRST	BEXCL
	HRLZI	C,(B)
	EMIT	<HRLI	LPSA,NOUSAC!NORLC!USADDR>	; IF NEED, LOAD A COUNT
BEXCL:	XCALL	<BEXIT>				;EXIT THE BLOCK
	POPJ	P,
>;DIS







BEND	LABEL

SUBTTL	Case Statement Generators.
COMMENT ⊗CASSTR, CASEMT, CASEND, CASE1, ... -- Case Statement Generators⊗

BEGIN	CASE
DSCR CASSTR, CASEMT, CASEND, CASE1, etc.
PRO CASSTR CASEM1 CASEMT CASEN1 CASEND CASE1 CASE2 CASE3
DES EXECS for generating case statement code.  The expression
  generated is compared to the numcode. The generated code:
 1. compares index into the statements to number of statements.
 2. calls an error routine (run-time) if something is fishy.
 3. does an indexed jrst to dispatch to the right statement.

The syntactic contexts are:
CASE E OF → CASEX		CASSTR
CASEX S ; → CASEX		CASEMT
CASEX [ E ] S ; → CASEX		CASEM1
CASEX S END → S			CASEMT CASEND
CASEX [ E ] S END → S		CASEM1 CASEN1
CASEX ( → CASEE			CASE1	;EXPRESSION CASE STATEMENT
CASEE E , → CASEE		CASE2	; "
CASEE E ) → E			CASE2, CASE3
⊗

COMMENT ⊗ The CASE SEMBLK has the following form:
%TLINK -- saved version of CASTAK (from prev level)
$PNAME,+1 -- standard
$TBITS -- standard in CASE expression
$SBITS -- level as usual
$ADR (both halves), $ACNO (lh)  used for fixups
$VAL -- lowest case # seen,,highest seen
$VAL2 -- 0 if no S's seen, >0 if old style, <0 if new style
⊗

↑CASSTR: 			;START OF CASE CONDITIONS
	GETSEM	(1)		;SEMANTICS OF THE EXPRESSION.
	MOVE	PNT2,PNT	;MAKE SURE BOTH ARE VALID
	PUSHJ	P,BOLSTO	;STORE ALL BUT INDEX
	GENMOV	(GET,INSIST!INDX!POSIT,INTEGR)
	MOVE	A,[SKIPL NOUSAC]
	PUSHJ	P,EMITER
	PUSHJ	P,REMOP		;ALL DONE.
	GETBLK	<GENRIG>	;FOR CASE STATEMENT TEMPORARIES.
	MOVEW	(<%TLINK(LPSA)>,CASTAK);SAVE OLD CASTAK
	SETZM	CASTAK		;AND START A NEW ONE
	MOVE	A,PCNT
	HRLM	A,$ADR(LPSA)	;FIXUP FOR THE COMPARE, WHICH FOLLOWS.
	MOVE	A,[CAIL NOADDR]
	PUSHJ	P,EMITER
	XCALL	<CSERR>
GAG <;KEEP EXTRA FIXUP TO AVOID ANOTHER CALL ON TWOOUT
	MOVE	TEMP,PCNT
	HRLM	TEMP,$ACNO(LPSA) ;ADDR OF THE DISPATCHING JRST, SAVE FOR FIXUP
>;GAG
	MOVE	A,[JRST @USX+NOADDR+NOUSAC]
	MOVSS	D
	PUSHJ	P,EMITER
	QPUSH	(CASTAK,PCNT)	;SAVE ON GENERALIZED STACK THE STATEMENT
	POPJ	P,


↑CASE1:	GETSEM	(1)		;CASEX SEMANTICS.
	PUSHJ	P,GETAC		;RESERVE AN ACCUMULATOR.
	MOVEM	D,$ACNO(PNT)	;REMEMBER IT.
	MOVEM	PNT,GENRIG
	POPJ	P,


↑CASE2:	MOVEM	B,THISE
	SOJL	B,.+3
	JUMPN	B,LPCS2		;..LEAP..
	PUSHJ	P,LEVBOL	;.....
	MOVE	SP,GENLEF+2	;CASEE SEMANTICS.
	MOVE	D,$ACNO(SP)	;RESERVED AC.
	GETSEM	(1)		;THE EXPRESSION.
	SKIPN	B,$TBITS(SP)	;TYPE FOR THE EXPRESSION.
	HRRZ	B,TBITS
	MOVEM	B,$TBITS(SP)	;NOW IT HAS SOME IF NOT BEFORE.
	HRRI	FF,INSIST!REM	;FOR GENMOV -- REMOP SO ALLSTO WON'T SEE IT.
	TRNE	B,STRING	;SPECIAL FOR A STRING.
	JRST	[GENMOV (STACK)
 		 MOVNI	A,2
		 ADDM	A,SDEPTH  ;FIX UP THE STACK
		 JRST CAS22]
	TRO	FF,SPAC!POSIT
	GENMOV	(GET)

CAS22:
	JRST	CASEMT
				;EMIT JRST TO END OF CASE STATEMENT

; CASE N OF BEGIN [E]S; [E]S; ... [E] S END;

↑CASEM1: GETSEM	(5)		;SEMANTICS OF CASEX
	SKIPLE	TEMP,$VAL2(PNT);LEGAL TO EXPLICITLY NUMBER?
	 ERR	 <TOO LATE TO START NUMBERING CASES>,1 ;NO
	JUMPL	TEMP,NOTFST	;NOT FIRST
	HRROS	$VAL(PNT)	;SMALLEST SEEN IS VERY LARGE
	SETOM	$VAL2(PNT)	;LEGAL TO EXPLICITLY NUMBER
NOTFST:	GETSM2	(3)		;SEMANTICS OF `E'
	TLNN	TBITS2,CNST	;MUST BE CONSTANT
	 ERR	 <CASE NUMBER MUST BE NON-NEGATIVE INTEGER CONSTANT>,1
;;#FV# DCS 2-6-72 (1-1) CASE N OF BEGIN ["A"] DIDN'T WORK
	GENMOV	(CONV,EXCHIN!INSIST!EXCHOUT,INTEGR);A REASONABLE CONST.
;;#FV# (1-1)
	SKIPGE	TBITS2,$VAL(PNT2);NON-NEGATIVE?
	 ERR	 <CASE NUMBER MUST BE NON-NEGATIVE INTEGER CONSTANT>,1
	QPOP	(CASTAK)	;GET →1ST WD PREV STATEMENT
	HRL	A,TBITS2	;CASE # 
	QPUSH	(CASTAK)	;NOW CORRECT ENTRY
	JRST	CASSDO		;CONTINUE

;CASE N OF BEGIN S; S; S; S; ... S END;

↑CASEMT:GETSEM	(2)
	SKIPGE	$VAL2(PNT)	;LEGAL TO IMPLICITLY NUMBER?
	 ERR	 <EXPLICIT CASE NUMBER REQUIRED>,1
	HRRZM	PNT,$VAL2(PNT) ;GT 0 MEANS IMPLICIT NUMBERING
	AOS	TBITS2,$VAL(PNT);NUMBER SEEN
CASSDO:	PUSHJ	P,ALLSTO	;STORE ALL
	MOVE	A,[JRST NOUSAC+JSFIX]
	PUSHJ	P,EMITER
	HLRZ	TEMP,$VAL(PNT);LOWEST SEEN YET
	CAMGE	TBITS2,TEMP	;THIS ONE LOWER?
	HRLM	TBITS2,$VAL(PNT);YES, THEN NO
	HRRZ	TEMP,$VAL(PNT)
	CAMLE	TBITS2,TEMP	;SAME FOR UPPER
	HRRM	TBITS2,$VAL(PNT)
	HRL	TBITS2,PCNT	;GET CURRENT PC
	MOVS	A,TBITS2	;XWD CASE #, PC
	QPUSH	(CASTAK)	;SAVE
	POPJ	P,



↑CASE3:	SOSL	B,THISE		;THE TYPE OF EXPRESSION.
	JRST	[JUMPN B,LPCS3
		 PUSHJ	P,LEVBOL
		 JRST .+1]
	MOVE	PNT,GENLEF+2	;CASEE
	MOVE	D,$ACNO(PNT)	;RESERVED AC.
	GENMOV	(MARK,GETD)	;MAKE A TEMP (TBITS IS MAGICALLY SET UP
	MOVEM	PNT,GENRIG  	;MARK THE EXPRESSION.
	MOVEI	A,2
	TRNE	TBITS,STRING
	ADDM	A,SDEPTH	;UNDO THE DAMAGE
				;FALL THROUGH TO EMIT JRSTS.

↑CASEND:GETSEM	(2)		;CASEX SEMANTICS
	JRST	CASENS
↑CASEN1: GETSEM	(5)		;CASEX SEMANTICS.
CASENS:	HRRZ	B,$VAL(PNT)	;COUNT OF STATEMENTS.
	SKIPG	$VAL2(PNT)	;RANDOM NUMBERING?
	ADDI	B,1		;YES, BE COMPATIBLE (CAIL)
	MOVE	TBITS2,PCNT	;CURRENT PC
	ADDI	TBITS2,(B)	; + # STATEMENTS IS OUT ADDR
	HLL	B,$ADR(PNT)	;FIXUP FOR THE CAIL
NOGAG <;USE CHAIN FOR "GOGOL"
	PUSHJ	P,FIXOUT	;DO NOT RELOCATE THE FIXUP.
	ADD	B,[XWD 2,0]
	HRR	B,PCNT
	PUSHJ	P,FBOUT		;FIXUP FOR INDEXED JRST.
>;NOGAG
GAG <
	PUSHJ	P,CHAIN		;≡FBOUT
	MOVE	LPSA,$VAL(PNT) ;COUNT OF STATEMENTS.
	PUSHJ	P,TWOOUT		;....
	HRR	B,PCNT
	HLL	B,$ACNO(PNT)	;GET FROM BLOCK RATHER THAN BY CALCULATION
	PUSHJ	P,CHAIN		;≡FBOUT.
>;GAG
	HRRZS	$VAL(PNT)	;XWD 0,LAST STMT
	SKIPL	$VAL2(PNT)	;RANDOM NUMBERING?
	 SOS	 $VAL(PNT)	; NO, ONE TOO BIG
	MOVEI	LPSA,CASTAK	;SET FOR QSTACK OPS
	TDZA	C,C		;C←0, ALWAYS QBEG ONCE
CELUP:	SKIPGE	$VAL2(PNT)	;EXPLICIT NUMBERING
	PUSHJ	P,BBEG		; YES, ALWAYS START AT HEAD
	JUMPE	B,CLD		;NO QSTACK
	CAMLE	C,$VAL(PNT)	;DONE?
	 JRST	 CLD		; YES
CEILUP:	HRRZ	A,TBITS2	;IN CASE NO SUCH ENTRY
	PUSHJ	P,QTAK		;GET NEXT
	 JRST	 RNDM		; NO SUCH NUMBER, USE OUT ADDR
	HLRZ	TEMP,A		;CASE # THIS STATEMENT
	CAME	C,TEMP		;THERE YET?
	 JRST	 CEILUP		; NOPE
	HRRZS	A		;YEP, THIS ADDR
RNDM:	TLO	FF,RELOC
	PUSHJ	P,CODOUT	;WRITE DISPATCH ADDR
	AOJA	C,CELUP		;GET NEXT
CLD:	QFLUSH	(CASTAK)	;DELETE STACK
	MOVEW	(CASTAK,<%TLINK(PNT)>);RESTORE OLD ONE
	HRR	B,PCNT		;FIXUP OUT JUMPS
	HRL	B,$ADR(PNT)
	MOVE	LPSA,PNT
	PUSHJ	P,URGSTR	;IF CASE STATEMENT, NAMED
	FREBLK	(PNT)
	JRST	FBOUT		;AND RELEASE CASEX SEMBLK
BEND CASE

SUBTTL	Procedure Declarations.
BEGIN PROCED
COMMENT ⊗PROCEDURE Structure Descriptions, Data Declarations⊗

DSCR PRDEC -- name and type known, prepare for proc
PRO PRDEC
DES
  PD0:	PDEC @I (  →  PDEC   EXEC  PRDEC CLRSET  SCAN  ¬DS1
	PDEC @I ;  →  PDEC   EXEC  PRDEC ENDDEC  SCAN  ¬DS1

Procedure declaration.  This routine has three parts:
1.  Save status -- Temp ring, TTOP, TPROC
2.  Initialize status -- VARB, ADEPTH, SDEPTH, FORMFX stack, TPROC, TTOP.
	Down a text level, set FF bits for parameter scan
3.  Output necessary code for beginning of procedure (if not FORWRD).
    An ENTER has already been done for the symbol (semantics in NEWSYM). 

SEMBLK descriptions for procedure Semantics
%TLINK → 2d Semblk for proc	,,%TBUCK standard
$PNAME standard
$TBITS standard
$SBITS standard -- RTNDON on means a RETURN was seen in this proc
$ADR   <note1>			,,<note2>
$ACNO  <note3>			,,<note4>
%RVARB, %RSTR standard

 2d Semblk
%TLINK -- → 1st formal Semblk	,,%STEMP → saved TTEMP list (%TBUCK)
%SAVET  → old TTOP		,, → old TPROC    ($PNAME)
$NPRMS  # arith params+1	,, # string params * 2 ($PNAME+1)
$BLKLP  BLKLIM qstack dscriptr saved at PRDEC ($TBITS)
$SBITS	<note5>
$VAL	-1 if TOPLEV on at PRDEC
$VAL2	DDT level of this procedure

<note1>	fixup chain of jumps past SUB/PUSH code in string exit sequences
	(for non-recursive RETURNs which return non-temp Strings).
<note2> fixup until entry addr known (delayed to PRUP for recursive procs),
	then addr of procedure entry sequence
<note3> address of first word of proecedure text (for finding text, adjusting AOS)
<note4>	fixup chain of jumps to procedure exit sequence (incl SUB/PUSH for Str)
<note5> address of JRST around 1st procedure in nest
⊗

ZERODATA (PROCEDURE CODE VARIABLES)
;FTRPRM -- QSTACK Descriptor -- holds Semantics of actual 
;    parameters as they are developed for FORTRAN calls.
;    These are QTAKed back off after the JSA is generated
↓FTRPRM: 0

;FORMFX -- formal fixups QSTACK Descriptor -- see TOTAL for
;    definition, description

;MESFLG -- on in Procedure call code if call is a MESSAGE
;    call
↓MESFLG: 0
;TBSAVE -- Temp cell used to save tbits during call to DYNAMAK(ADRINS);
;
↓TBSAVE: 0
;MPFLAG -- Flag to FTRADR to tell that we really want the type bits
;in the left half of the adcon
↑↑MPFLAG:0

ENDDATA
COMMENT ⊗  PRDEC -- When Name is Seen⊗

; 1  -- SAVE STATUS

;;#GP# DCS 2-6-72 (3-4) CHECK FORWARD FORMALS AGAINST REAL ONES
↑PRDEC:	SETOM	OLDPRM			;NO SAVED FORMAL DECLS YET
	MOVEI	A,PROCED		;BITS FOR PROCEDURE
	IORM	A,BITS
	PUSHJ	P,ENTID			;ENTER THE SYMBOL
;;#GP# (3) ALSO SET UP OLDPRM IN ENTERS
	MOVE	PNT,TPROC		;PNT → CURRENT PROC SEMANTICS.
	LEFT	PNT,%TLINK,LPSERR	;LPSA → 2D TPROC BLOCK
	HRR	TEMP,TTEMP
	HRRM	TEMP,%STEMP(LPSA)	;SAVE CURRENT TEMP RING.
	PUSH	P,LPSA			;SAVE → 2D BLOCK OF SURROUNDING PROC
	MOVE	PNT2,NEWSYM		;NEW SYMBOL (PROCEDURE NAME)
	LEFT	PNT2,%TLINK,LPSERR	;LPSA → 2D BLOCK
	HRL	PNT,TTOP		;TTOP,TPROC SAVED HERE
	MOVEM	PNT,%SAVET(LPSA)
	TLZE	FF,TOPLEV	;NO LONGER AT TOP LEVEL,
	SETOM	$VAL(LPSA)	; BUT SAVE PREVIOUS STATUS
	MOVEW	(<$BLKLP(LPSA)>,BLKIDX) ;SAVE CURRENT BLKIDX
	SETZM	BLKIDX			;CLEAR NEW ONE

	AOS	TEMP,NMLVL	;UPDATE DDT LEVEL
SLS <
	QPUSH	(PRGBSTK,PRGBLK) ;SAVE PRGBLK ID PREP. TO GETTING ANOTHER
	SALCAL	(SLBLK,<NMLVL>,<-PNT2,$PNAME>) ;DO SO
	MOVEM	A,PRGBLK
>;SLS
	SETZM	$SBITS(LPSA)		;JRST AROUND PROCS ADDR
	HRRZM	TEMP,$VAL2(LPSA)


;  2 -- INITIALIZE STATUS FOR THIS PROCEDURE

; ***** BUG TRAP
	SKIPN	ADEPTH		;THESE SHOULD BE ZERO HERE
	SKIPE	SDEPTH
	 ERR	 <DRYROT -- ADEPTH OR SDEPTH >,1

	FOR	II ⊂ (VARB,APARNO,SPARNO,ADEPTH,SDEPTH,TTEMP) <
		SETZM	II>
DIS <
COMMENT ⊗
	AT THIS POINT YOU MAY WANT TO SAVE OLD DISPLAY LIST
	⊗
	MOVE 	A,$SBITS(PNT2)	;NEED TO ZERO OUT THE DL FLD
	TRZ	A,DLFLDM	;ZERO IT
	MOVEM	A,$SBITS(PNT2)	;PUT IT BACK
	SETOM	RECSW		;ASSUME RECURSIVE -- IF WRONG WILL FIX BELOW
>;DIS
	MOVE	TBITS2,$TBITS(PNT2)	;BITS FOR THIS PROCEDURE
	MOVEI	A,0		;ASSUME A RECURSIVE PROCEDURE
	TLNN	TBITS2,RECURS
	MOVNI	A,1		;NON-RECURSIVE -- INDICATE NO FORMAL FIXUPS
DIS <
	XORM	A,RECSW		;THIS WILL SET RECSW TO ALL 0 IF NOT RECSV
	SETOM	SIMPSW		;ASSUME SIMPLE
	TLNE	TBITS2,SIMPLE	;IS IT REALLY
	JRST	GOTPD		;YES
	SETZM	SIMPSW		;NOT SIMPLE
	GETBLK			;FOR PROC DESC STUFF
	HRRM	LPSA,$VAL(PNT2)	;RECORD IT
GOTPD:
>;DIS
	QPUSH	(FORMFX)	;SAVE MARKER
	MOVEM	PNT2,TPROC	;LET EVERYONE KNOW
	MOVEM	PNT2,TTOP	; WHO HAS A RIGHT TO KNOW WHERE
	MOVEM	PNT2,GENRIG	;  THIS PROCEDURE IS
;5-12-72
;	MOVEM	PNT2,GENRIG+1	;  (COULD GO ONE OF TWO PLACES) NO MORE -- DCS

	AOS	LEVEL
	PUSHJ	P,MAKBUK	;DOWN A LEVEL
DIS <
	SKIPN	SIMPSW		;IF NOT SIMPLE PROC
	AOS 	CDLEV		;DOWN HERE TOO
>;DIS
	TLO	FF,NOCRFW!PRODEF	;SET DECLARATION BIT

; 3 -- ISSUE CODE

Comment ⊗ consider: ... X ← A+1;
			   BEGIN INTEGER PROCEDURE ... ⊗

GAG <
	TLNN	TBITS,EXTRNL	;SINCE IN MOST CASES NOT FORWARD.
>;GAG
	TRNE	TBITS2,FORWRD	;IF FORWARD DEC, IGNORE THE REST
	 JRST	 TMPOPJ		; (SOME OF ABOVE IS IRRELEVANT ALSO)
	PUSHJ	P,ZOTDIS
	PUSHJ	P,ALLSTO	;BECAUSE OF ABOVE CONSIDERATION
DIS <
	MOVE	TEMP,CDLEV	;BUMP DISPLY LEVEL
	MOVEI	LPSA,RF
	MOVEM	LPSA,DISTAB(TEMP)	;F IS THE TOP DISPLAY
COMMENT ⊗ AT A LATER DATE MAY  WANT TOO DO MORE --
	I.E. BEFORE ALLSTO -- GO THRU ZZ CLEAR DISTAB SO
	RECORD OF DISPLAYS GETS KEPT OVER PROC DECL;
	⊗
>;DIS
NOGAG <
;CREF THE NEW BLOCK NAME.
	TLZ	FF,NOCRFW
	TLNN	FF,CREFSW
	JRST	NOCRW		;NO
	MOVEI	A,15
	PUSHJ	P,CREFOUT
	MOVE	LPSA,PNT2
	PUSHJ	P,CREFASC
NOCRW:
>;NOGAG
GAG <;KEEP NEXT TWO TOGETHER 
	MOVEI	LPSA,2
	PUSHJ	P,TWOOUT	;SUPER-MAGIC ROUTINE
>;GAG
	HRRZ	TEMP,PCNT	;ADDR OF JRST TO COME (IF ANY)
	POP	P,LPSA		;→2D SEMBLK FOR SURROUNDING PROCEDURE
	SKIPE	$SBITS(LPSA)	;HAS SOMEBODY ALREADY DONE THE JUMP?
	 JRST	 NOROUND	; YES, ONLY ONE JUMP AROUND PROCEDURES
				; (SEE ENDDEC, ENDJMP, BUILT-IN ARRAY CODE)
	HRRZM	TEMP,$SBITS(LPSA);DENOTE JRST FROM HERE
	EMIT	(<JRST NOUSAC+NOADDR>) ;JRST AROUND PROC(S)
	HRRZ	TEMP,PCNT	;NOW NEW PCNT
NOROUND:HRLZM	TEMP,$ACNO(PNT2);IDENTIFIES START OF PROCEDURE
	TLNE	TBITS2,RECURS
	 JRST	 RCSV		;RECURSIVE, CAN'T PLACE PROC YET
	TLNN	TBITS2,SIMPLE	;IS THIS NON-SIMPLE AND
	TLNN	TBITS2,INTRNL	;IS THIS AN INTERNAL PROCEDURE??
	JRST	NTINT		;NO
	HRRZ	PNT,$VAL(PNT2)	;LOOK AT PROCEDURE DESCRIPTOR
	CAIN	PNT,0		;BETTER BE HERE
	ERR	<DRYROT -- DONT HAVE PD SEMBLK YET>
	EMIT	<JSFIX>		;PUT OUT PDA
NTINT:	HRL	B,$ADR(PNT2)	;CAN NOW GIVE PROCEDURE A HOME
	HRR	B,PCNT		;AT PCNT NO LESS!
	HRRM	B,$ADR(PNT2)
	TLNE	B,-1		;IF IT WAS FORWARD, AND SOMEONE
	PUSHJ	P,FBOUT		;HAD THE FORSIGHT TO USE IT.
	TRZ	TBITS2,INPROG
	MOVEM	TBITS2,$TBITS(PNT2); NO LONGER FORWARD
DIS <
	SKIPE	SIMPSW		;IF SIMPLE THEN ALL DONE
	POPJ	P,
	PUSHJ	P,MKSEMT	;PUT OUT MSCP
	PUSHJ	P,SETF		;MAKE IT ALL OFFICIAL
>;DIS
RCSV:
IFN PATSW,<
	EMIT	(<AOS	NOUSAC+NOADDR>) ;AOS "PAT" ENTRY
>;PATSW -- PATSW INHIBITS AOS/SOS, NOT ISSUE OF WORD (FOR NOW)
	POPJ	P,

↑↑TMPOPJ:POP	P,TEMP
	POPJ	P,
COMMENT ⊗  ENDPR -- when params have been seen⊗

DSCR ENDPR
PRO ENDPR
DES
PD1:	PDEC ;  →  PDEC   EXEC ENDPR  SCAN   ¬S1
	PDNO ;  →  NIL	  EXEC ENDPR  SCAN   ¬DS0

1. Turn off formal-scanning bit
2. Save parameter counts, insert stack displacements
	for parameters
⊗
; 1

↑ENDPR:	TLZ	FF,NOCRFW!PRODEF

;  2

	HRRZ	PNT2,GENLEF+1		;THIS PROCEDURE
LEP <
	MOVE	TEMP,$TBITS(PNT2)	;GET TYPE BITS
	TLNN	TEMP,MPBIND		;A MATCHING PROCEDURE?
	JRST	MATNOT			;NO
	TLNE	TEMP,SIMPLE		;BETTER NOT BE SIMPLE.
	ERR	<MATCHING PROCEDURES MAY NOT BE SIMPLE>,1
	QPUSH	(MPSTAK,PNT2)		;SEMANTICS OF MATCHING PROCEDURE
MATNOT:
>;LEP
	HLRZ	PNT2,%TLINK(PNT2)	;→SECOND BLOCK FOR THIS PROC
	JUMPE	PNT2,LPSERR		;HAS TO BE THERE
	AOS	A,APARNO	;SAVE COUNTS
	HRLM	A,$NPRMS(PNT2)	;SAVE COUNTS
	MOVE	A,SPARNO
	LSH	A,1		; * 2 FOR STRINGS
	HRRM	A,$NPRMS(PNT2)	;AND SET UP A AND B WITH THEM

	MOVEI	A,1		;LEAVE ROOM FOR RETURN ADDR
	MOVEI	B,1		;LEAVE ROOM FOR SECOND STRING WORD

; NUMBER THE PARAMETERS, FIND BEGINNING OF THEIR LIST, REZERO VARB

	SKIPN	PNT,VARB	;ARE THERE ANY?
	 JRST	 PUTIN		; NO, MARK ZERO
PARD:	PUSHJ	P,GETAD		;FIND OUT ABOUT THIS FORMAL
	TRNE	TBITS,PROCED	;IF IT IS A PROCEDURE CALLED BY
	TLNN	TBITS,VALUE	; VALUE, COMPLAIN
	SKIPA
	 ERR	 <DON'T PASS PROCEDURES BY VALUE>,1
	TRNE	TBITS,STRING	;STRING VALUE PARAMS ARE INDEXED
	TLNN	TBITS,VALUE	;FROM THE RSP STACK
	 JRST	 PST		;ALL OTHERS OFF OF RP
;;#HR# ALLOW STRING ITEMVAR PARAMETERS
	TDNE	TBITS,[XWD SBSCRP,ITEM!ITMVAR]
;;#HR# 
	 JRST	 PST
	HRRM	B,$ADR(PNT)	;DISPLACEMENT FROM TOP OF STACK
	ADDI	B,2		;SIZE OF EACH PARAM
	JRST	PRLUP

PST:	HRRM	A,$ADR(PNT)
	ADDI	A,1
LEP <				;RECOPY SETS INTO STACK.
	TRNE	TBITS,SET
	TDNE	TBITS,[XWD REFRNC!SBSCRP,LPARRAY!ITEM!ITMVAR]
	JRST	NOSET		;EXCEPT THESE.
	TRNE	TBITS,FLOTNG	;DON'T LET CONTEXTS THROUGH
	ERR	<CONTEXTS MAY NOT BE PASSED BY VALUE>,1

; IF EXTERNAL (OR FORWARD) PROCEDURE, NO CODE GOES OUT  (DCS -- 9/11/70)
; MORE FIXES 6-11-71
	MOVE	TEMP,GENLEF+1	;PROC SEMANTICS
	MOVE	TEMP,$TBITS(TEMP)
	TDNE	TEMP,[XWD EXTRNL,FORWRD] ;SPECIAL DECLARATION?
	 JRST	 NOSET
; END BUG FIX (DCS -- 9/11/70) (6-11-71)


	PUSH	P,A
	EMIT	(<HRROI TAC1,NOUSAC>);CALL IT.
	LPCALL	(SETCOP)	;AND COPY IT.
	POP	P,A
NOSET:
	TLNN	TBITS,MPBIND	;A ?ITEMVAR
	JRST	NOMPRS		;NO.
	MOVE 	TEMP,GENLEF+1	;GET PROC'S SEMANTICS
	MOVE	TEMP,$TBITS(TEMP);
	TDNE	TEMP,[XWD EXTRNL,FORWRD]
	JRST	NOMPRS		;NO CODE FOR EXTERNS OF FORWARDS
	TLNN	TEMP,MPBIND	;THIS REALLY A MATCHING PROC.
	ERR	<? PARAMS ONLY LEGAL FOR MATCHING PROCEDURES>,1
	PUSH	P,A		;SAVE DISPLACEMENT
	PUSH	P,PNT		;SAVE
;INITIALIZE ? PARAMS TO UNBOUND IF NECESSARY
	MOVEI	A,UNBND		;THE "UNBOUND" ITEM
	PUSHJ	P,CREINT	;GET CONSTANT SEMBLK
	PUSHJ	P,GETAC
	EMIT	<MOVE ,IMMOVE>	;
	SETOM	ACKTAB(D)
	EXCH	D,(P)		;SAVE AC # ITS IN
	MOVE	PNT,D
	GENMOV	(ACCESS,GETD)	;PROBABLY NOT NECESSARY
	PUSHJ	P,GETAN0	;GET AN AC TO PLAY WITH
	EMIT	<MOVE ,0>	;LOAD PARAM
				;NOTE GENMOV WILL NOT WORK HERE
				;AS IT WOULD GENERATE MOVEI @
	SETOM	ACKTAB(D)	;PROTECT THE AC
	HRLM	D,(P)		;TO USE AS INDX FOR MOVEM BELOW
	HRLI	C,20		;THE INDIRECT BIT
	EMIT	<TLNE ,USADDR!NORLC> ;TEST FOR INDIRECT BIT
	POP	P,D		;AC CONTAINING "UNBOUND"
	EMIT	<MOVEM ,USX!NOADDR>
	SETZM	ACKTAB(D)
	MOVSS	D
	SETZM	ACKTAB(D)	;"FREE" INDEX AC
	POP	P,A		;RESTORE DISPLACEMENT
NOMPRS:
	
>;LEP

PRLUP:	LEFT	PNT,%RVARB,PUTIN;NEXT ONE OR ZERO
	MOVE	PNT,LPSA	;PNT → NEXT ONE
	JRST	PARD

PUTIN:	HRLM	PNT,%TLINK(PNT2) ;PNT2→2D PROC BLOCK
	SETZM	VARB		;BRAND NEW PROC DECL COMING
;;#GP# DCS 2-6-72 (4-4) CHECK FORWARDS AGAINS NEW FORMALS
	SKIPN	LPSA,OLDPRM	;DID ANY FORWARD HAVE DECLRARATIONS?
	 JUMPE	 PNT,OKFORM	; NO, AND ALSO NO NEW DECLARATIONS
	JUMPL	LPSA,OKFORM	;NO PREVIOUS FORMALS, QUIT
	SETOM	OLDPRM		;CLEAR OUT, JUST FOR SAFETY
CKPRM:	JUMPE	LPSA,CHKRDN	;CHECK REAL DONE TOO
	JUMPE	PNT,TOOMF	;TOO MANY FORWARDS
	PUSHJ	P,URGSTR	;RELEASE FROM STRING RING
	FREBLK	()		;RELEASE STORAGE
	MOVE	TBITS,$TBITS(PNT)
	CAME	TBITS,$TBITS(LPSA);MUST BE SAME TYPE
	ERR	 <FORMALS DON'T ALL AGREE WITH FORWARD DECLARATIONS>,1
	HRRZ	LPSA,%RVARB(LPSA);MOVE ON DOWN
	HRRZ	PNT,%RVARB(PNT)
	JRST	CKPRM

CHKRDN:	JUMPE	PNT,OKFORM	;MUST BOTH BE EMPTY
	ERR	 <MORE FORMALS DECLARED THAN IN FORWARD DECLARATION>,1
OKFORM:	POPJ	P,

TOOMF:	ERR	 <FEWER FORMALS DECLARED THAN IN FORWARD DECLARATION>,1
	JRST	 KILLST		;REMOVE THE REST
;;#GP# (4)
COMMENT ⊗  PRUP -- When Procedure Body's Finished -- Entry, Exit, Fixups, etc.⊗

DSCR PRUP
PRO PRUP
RES 
at S8:	PDEC S ;  →  NIL   EXEC PRUP  SCAN   ¬DS
1. Issues fixups for any jumps to procedure exit, and
	for the jump around the procedure.
2. Issues procedure exit code, including stack adjusts
3. Issues procedure entry code if the procedure is recursive,
	including a JRST to the procedure text.
4. Goes up a text level, restores VARB-type pointers
5. Allocates storage for locals to procedure (ALOT).
BITS used as special flag during PRUP (see NONULL+1)
⊗

↑PRUP:	PUSHJ	P,ALLSTO	;STORE ALLES NOT YET STORED
	SETZM	BITS		;NOT SPECIAL YET (BITS USED AS FLAG)
	GETSM2	(2)		;PROCEDURE SEMANTICS
;;#HS# STRING ITEMVAR PROC TO BE TREATED AS ITEMVAR PROC. NOT STRING
	TRNE	TBITS2,ITEM!ITMVAR
	TRZ	TBITS2,STRING
;;#HS#

;⊗⊗ PNT2 set will almost continuously have Proc Semantics in the sequel

DIS <
	HRRZ	PNT,$VAL(PNT2)	;PICK UP PD SEMBLK
	MOVE	TEMP,PCNT	;PICK UP PCNT
	HRRM	TEMP,$ACNO(PNT)	;
>;DIS
LEP <
	TLNN	TBITS2,MPBIND	;THIS A MATCHING PROC
	JRST	MPNO		;NO
	QPOP	(MPSTAK)
	CAIE	PNT2,(A)	;THE SAME?
	ERR	<DRYROT-PRUP MATCHING PROC>
	EMIT	<HRRZI LPSA,NOUSAC>	;ADDRESS OF PDA
	HRLI	C,LPSA
	EMIT	<PUSH RP,NOUSAC!USADDR!NORLC> ;STACK PDA ADDRESS
	XCALL	(.FAIL)		;REPORT FAILURE
MPNO:
>;LEP

	PUSH	P,TBITS2	;REST WILL BE RECONSTRUCTED LATER
	TRNE	TBITS2,STRING	;IF NO RETURN MADE FROM STRING
	TLNE	SBITS2,RTNDON	; PROC, RETURN NULL HERE
	 JRST	 NONULL
	SETZM	PNAME
	PUSHJ	P,STRINS
	GENMOV	(STACK,REM)	;STACK IT AND FORGET IT
	SETZM	SDEPTH		;WE KNOW ABOUT STACK HERE
	JRST	NOEXIT		;BYPASS SPECIAL TEST (MUST HAVE SUB/PUSH CODE)
NONULL:	HRLZ	B,$ACNO(PNT2)
	JUMPE	B,[SETOM BITS	;NOBODY JUMPED TO SUB/PUSH CODE, BUT SOMEBODY
		   TLNE SBITS2,RTNDON ;RETURNED, SO SET SPEC (DON'T GENERATE
		   TRNN TBITS2,STRING ; SUB/PUSH) -- ONLY IF STRING PROC AND
		   SETZM BITS	; SOMEBODY RETURNED (TO EXIT2, ACTUALLY)
		   JRST  NOEXIT]; NO FIXUP, IN ANY CASE
	HRR	B,PCNT		;EXIT TO HERE
	PUSHJ	P,FBOUT		; IF YOU CAN


Comment ⊗ Now call routine which obtains the necessary
	counts and such (if the procedure is recursive).  ⊗

NOEXIT:
NOGAG <
	TLZ	FF,ALLOCT	; GET SIZES
>;NOGAG
GAG <
	TLO	FF,ALLOCT	; DO EVERYTHING FIRST TIME IN
>;GAG
	PUSHJ	P,ALOT
	POP	P,TBITS2	;GET PROC TYPES BACK
	TLNN	TBITS2,RECURS	;RECURSIVE PROCEDURE?
	 JRST	 NOREC1		; NO

; FIX UP ANY REFERENCES TO THE FORMALS OF THIS PROCEDURE

FFXLUP:	QPOP	(FORMFX)	;A→ [DISPL REL 0,ADDR OF INSTR]
	JUMPL	A,FFXERR	;MUST NOT BE NEGATIVE
	JUMPLE	A,PEXIT		;GO GENERATE EXIT CODE WHEN DONE
NODIS <
	HLRZ	B,A		;200000 BIT ON IF RSP FIXUP
	MOVEI	C,SLOCALS	;ASSUME RSP STACK
	TRZN	B,200000	;CHECK ASSUMPTION
	 MOVEI	 C,ALOCALS	; WRONG
	ADD	B,(C)		;TOTAL INDEX
	MOVNS	B		;NEGATE DISPLACEMENT
	HRL	B,A		;FIXUP,,-DISPL
NOGAG <
	PUSHJ	P,FIXOUT	;DON'T RELOC FIXUP SIDE (ELSE ≡ FBOUT)
>;NOGAG
GAG <
	PUSHJ	P,CHAIN		;≡FBOUT
>;GAG
	JRST	FFXLUP		; NEXT?
>;NODIS
FFXERR:	ERR	<DRYROT -- FFXLUP>

NOREC1:	SETZM	ALOCALS		;DON'T INCLUDE IN STACK COUNTS
	SETZM	SLOCALS
	QPOP	(FORMFX)	;GET STACK POINTER OFF
	JUMPGE	A,FFXERR	;MUST BE NEGATIVE -- NO RECURSION

Comment ⊗ Generate procedure exit code -- local restore, subs, push str results ⊗

PEXIT:	GETSM2	(2)		;PROCEDURE SEMANTICS AGAIN
LEP <
	TLNN	TBITS2,MPBIND	;A MATCHING PROC?
	JRST	NOMPEX		;NO.
	PUSHJ 	P,GETCRTMP	;GET A TEMP
	MOVE	PNT,LPSA	;READY FOR EMIT
	EMIT	<MOVEM 1,NOUSAC> ;SAVE RETURN VALUE
	PUSH	P,PNT		;SAVE CORTMP SEMBLK
	HRRZ	PNT,$VAL(PNT2)	;THE PD SEMBLK
	EMIT	<HRRZI LPSA,NOUSAC!JSFIX>
	HRLZ	C,LEVEL
	EMIT	<HRLI LPSA,NOUSAC!USADDR!NORLC>
	XCALL	(STKUWD)
	POP	P,PNT		;CORTMP SEMBLK
	EMIT	<MOVE 1,NOUSAC> ;LOAD RETURN VALUE
	PUSHJ	P,REMOP		;REMOP THE TEMP
NOMPEX:
>;LEP
;;#HS# IGNORE STRING BIT FOR STRING ITEMVAR PROC.
	TRNE	TBITS2,ITEM!ITMVAR
	TRZ	TBITS2,STRING
;;#HS#
	LEFT	PNT2,%TLINK,LPSERR;LPSA → SECOND BLOCK
	PUSH	P,$NPRMS(LPSA)	;NUMBERS OF PARAMS
;;#IP# RHT 7-18-72 RELEASE ANY VALUE SETS

;;#JK# RHT 10-3-72 (1 OF 3) ↓
	TLZ	FF,FFTEMP	;HAVENT RELEASED SETS YET
	HLRZ	PNT,%TBUCK(LPSA);POINT AT FIRST FORMAL
FRSV:	JUMPE	PNT,PEX2	;ANY LEFT TO LOOK AT??
	MOVE	TBITS,$TBITS(PNT)
	TRNE	TBITS,ITEM!ITMVAR
	JRST	NXF
	TLNE	TBITS,VALUE	;IF ¬VALUE
	TRNN	TBITS,SET	;OR NOT SET THEN 
	JRST	NXF		;GO ON TO NEXT
	EMIT	<HRROI TEMP,NOUSAC>	;CODE TO RELEASE THE SET
;; #JK# BY JRL 10-3-72 SAVE AC 1 OVER LEAP CALL
	TRNE	TBITS2,ALTYPS≠<PROCED+FORTRAN+STRING>	;WAS THIS A TYPED PROCEDURE
	TLOE	FF,FFTEMP	;DO WE HAVE TO SAVE AC1??
	JRST	STRCLX		;ALREADY DONE IT
	HRLI	C,A		;WILL SAVE AC 1 OVER LPCALL
	EMIT	<PUSH RP,NOUSAC!USADDR!NORLC>
STRCLX:	LPCALL	(SETRCL)	;

;; #JK#
NXF:	HRRZ	PNT,%RVARB(PNT)	;ON TO NEXT
	JRST	FRSV	
PEX2:
;;#JK# RHT 13-3-72 3 OF 3
	HRLI	C,A		;RESTORE AC1 IF NEED
	MOVE	A,[POP RP,NOUSAC!USADDR!NORLC] ;
	TLNE	FF,FFTEMP	;DID WE SAVE IT
	PUSHJ	P,EMITER	;PUT IT BACK
;;#JK#
;;#IP#
	SKIPGE	BITS		;SPECIAL?
	 JRST	 DNTPSH		; YES, NO NEED SUBS OR PUSHES (DONE BFORE RETURN)
	MOVE	PNT,SLIMS	;VBL DESCRIPTOR BOUNDARIES
NODIS <
	MOVE	A,SLOCALS	;# STRING LOCALS
>;NODIS
DIS <
	MOVE 	A,SSDIS		;STRING STACK DISPL
>;DIS
	MOVEI	D,RSP		;INDICATE USE OF SP STACK
;⊗ PNT is Sem of last,,Sem of 1st; A is # str locs, RH(P) is #str params
	PUSHJ	P,RESTOR	;ADJUST THE STACK, RESTORE LOCALS

; NOW PUSH RESULT INTO CORRECT STACK LOC IF NECESSARY
	TRNE	TBITS2,STRING	;STRING PROCEDURE WHICH REQUIRED A SUB?
	CAIG	B,2		; (SET BY RESTOR, NUMBER SUBTRACTED)
	 JRST	 DNTPSH		; NO, NOT STRING OR RESULT IN RIGHT PLACE
	HRLI	C,-1(B)		;RELATIVE LOCATION OF RESULT TO CURRENT SP
	EMIT	<PUSH RSP,USADDR!NOUSAC!NORLC(RSP)>;#SUB'ED -1(SP)
	EMIT	<PUSH RSP,USADDR!NOUSAC!NORLC(RSP)>;#SUB'ED -1(SP)

; NOW ISSUE FIXUP FOR JUMPS AROUND ABOVE SUB/PUSH CODE

DNTPSH:	SETZM	BITS		;DON'T LEAVE BITS SCREWED UP
	HLLZ	B,$ADR(PNT2)	;THAT SPECIAL FIXUP
	JUMPE	B,NO2XIT	;NOBODY RETURNED NON-TEMP RESULT
	HRR	B,PCNT		;ISSUE FIXUP
	PUSHJ	P,FBOUT		;DOESN'T HAPPEN IN RECURSIVE PROCEDURES

NO2XIT:
IFN PATSW,<
	HLL	C,$ACNO(PNT2)	;NOW GET ADDR OF PROC TEXT (ADDR OF AOS)
	HRR	TEMP,PCNT	;ADDR OF THIS INSTR
	HRRM	TEMP,$ACNO(PNT2);SAVE IN OLD EXIT ADDRESS PLACE
	EMIT	(<SOS NOUSAC+USADDR>);C(LH) WILL BE USED, BUT NO FIXUP ISSUED
>;PATSW
DIS <
	SKIPE	SIMPSW		;IF SIMPLE
	JRST	DOOUT		;NO NEED TO MANGLE F
	MOVEI	C,0		;
	EMIT	(<MOVE RF,USADDR!NOUSAC!NORLC(RF)>); RESET RF
DOOUT:  MOVSS	(P)		;WANT NO ARITH PARAMS
	MOVEI	D,RP		;WANT RP
	MOVE	A,ASDIS		;ARTIH STACK DISPL
	SKIPN	SIMPSW		;ONLY HAVE FOR NON SIMPLE
	ADDI	A,1		;SINCE (F) TAKES UP A WORD
>;DIS
NODIS <
	MOVSS	(P)		;CONSIDER NUMBER OF ARITH PARAMS
	MOVEI	D,RP		;AND THE RP STACK
	MOVE	A,ALOCALS	;AND THE ACCURATE COUNT OF LOCALS (HOOHA)
>;NODIS
	HRRZ	TEMP,(P)	;NOW CONSIDER THE CASE WHERE THERE
	ADDI	TEMP,-1(A)	; ARE NO LOCALS OR PARAMETERS
	TRNN	TEMP,-1		;
	JRST	[EMIT (<POPJ RP,NOUSAC+NOADDR>) ;(ONLY A RETURN
				 JRST	PENTRY]		;ADDRESS) -- DO POPJ

	MOVE	PNT,ALIMS	;PNT, A, D, (P) SET UP ANALAGOUS TO ABOVE CALL
	PUSHJ	P,RESTOR	;RESTORE THE P SIDE
	HRLZ	C,(P)		;NUMBER OF ARITH PARAMS.
	HRLI	D,RP		;USE THIS STACK AS INDEX
	EMIT	(<JRST USADDR+INDRCT+NORLC+USX+NOUSAC+JSFIX>);JRST @PARAMS(RP)
	
; NOW PRODUCE PROCEDURE ENTRY CODE IF RECURSIVE PROCEDURE

PENTRY:	POP	P,TEMP		;THROW THE #PARAMS PAIR AWAY
	TLNN	TBITS2,RECURS	;
	 JRST	 PRUPYU		;NOT RECURSIVE
	TRZN	TBITS2,INPROG	;NO LONGER FORWARD
; ***** BUG TRAP
	 ERR	 <DRYROT -- PENTRY>
	HRRM	TBITS2,$TBITS(PNT2) ;OFF IN MEMORY
;NOW, IF INTERNAL, PUT OUT PDA WORD
	TLNN	TBITS2,INTRNL	;IS THIS AN INTERNAL PROCEDURE??
	JRST	NOIN.1		;NO
	HRRZ	PNT,$VAL(PNT2)	;LOOK AT PROCEDURE DESCRIPTOR
	CAIN	PNT,0		;BETTER BE HERE
	ERR	<DRYROT -- DONT HAVE PD SEMBLK YET>
	EMIT	<JSFIX>		;PUT OUT PDA
;NOW THE PDA WORD IS OUT, IF NEED BE
NOIN.1:	HRLZ	B,$ADR(PNT2)	;FIXUP FOR EARLY JUMPS
	HRR	B,PCNT
	HRRM	B,$ADR(PNT2)	;THIS IS PROCEDURE ADDRESS
	TLNE	B,-1		;DID ANYONE CALL EARLY?
	PUSHJ	P,FBOUT		;ADDR,,FIXUP FOR EARLY CALLS

NODIS <
SAVLOC:	MOVE	PNT,ALIMS	;SEMANTICS OF LAST,,SEMANTICS OF FIRST
	MOVEI	D,RP
	SKIPE	A,ALOCALS	;SAVE THE LOCALS IF THERE ARE ANY
	PUSHJ	P,SAVIT
	MOVE	PNT,SLIMS
	MOVEI	D,RSP
	SKIPE	A,SLOCALS
	PUSHJ	P,SAVIT
>;NODIS
DIS <
	PUSHJ	P,MKSEMT	;MARK THE STACK
	MOVEI	D,RP		;DO ARITH SAVES
	MOVE	A,ASDIS		;STACK DISPL
	SUBI	A,2		;FOR MSCP
	CAILE	A,0		;IF ANY ARITH LOCALS
	PUSHJ	P,SAVIT		;ZERO THE APPROPRIATE STUFF
	MOVEI	D,RSP		;STRING STACK
	SKIPE	A,SSDIS		;IF STRING LOCALS, BLT THEM TOO
	PUSHJ	P,SAVIT
	PUSHJ	P,SETF		;MAKE IT OFFICIAL
>;DIS
	HLL	C,$ACNO(PNT2)	;TEXT ADDR (OF AOS IF THERE IS ONE)
	EMIT	(<JRST NOUSAC+USADDR>)

PRUPYU:
NOGAG <
	TLO	FF,ALLOCT	;***** ASSUME SAVES ACS
	PUSHJ	P,ALOT		;ALLOCATE THE STORAGE
>;NOGAG   -- IF GAG, WAS DONE ONCE AND FOR ALL ABOVE
	GETSEM	(2)		;PROC SEMANTICS BACK
IFN PATSW,<
REN <
	PUSHJ	P,LOSET		;SWITCH TO DATA PC
>;REN
	HRL	B,$ACNO(PNT)	;FIXUP FOR "PAT" OPERATIONS
	HRR	B,PCNT		;"PAT" ACTIVITY WORD IS NEXT
	PUSHJ	P,FBOUT
	EMIT	(<NOUSAC+NOADDR>)	;PUT OUT A ZERO
REN <
	PUSHJ	P,HISET		;BACK TO UPPER SEGMENT
>;REN
>;PATSW
NOGAG <;USE BITS IN VBL BLOCKS FOR STRNGC, DON'T NEED LINKS (HOPE)
	PUSHJ	P,LNKMAK	;PUT OUT STRING LINK BLOCK IF NECESSARY
>;NOGAG

Comment ⊗ Now fix some syntactic things (restore counts,
	pointers, etc.), go up a level, and quit  .  ⊗

SYNTUP:	LEFT	PNT,%TLINK,LPSERR
	HRRZM	PNT,VARB	;CAN ADD ON FROM HERE
	SKIPE	$VAL(LPSA)	;RETURNING TO TOP LEVEL?
	 TLO	 FF,TOPLEV	; YES, RESET BIT
	MOVEW	(BLKIDX,<$BLKLP(LPSA)>) ;RESTORE OLD BLKIDX
	MOVE	TEMP,%SAVET(LPSA)
	HRRZM	TEMP,TPROC	;RESTORE VARB STRUCTURE POINTERS
	HLRZM	TEMP,TTOP
DIS <
	MOVE	A,$TBITS(TEMP)	;PICK UP TYPE BITS OF PROC
;;#KB# RHT ↓ 1 OF 2 (11-11-72) MUST SAVE LPSA
	PUSH	P,LPSA		;SAVE THE LIFE OF MY AC
	PUSHJ	P,ZOTDIS
;;#KB# 2 OF 2 ↓
	POP	P,LPSA		;CRIED THHE DESPARATE PROGRAMMER
	SKIPE	SIMPSW		;
	SKIPA	TEMP,CDLEV
	SOS	TEMP,CDLEV	;
	HRLI	TEMP,RF		;PUT RF BACK RIGHT
	HLRZM	TEMP,DISTAB(TEMP);
	SETZM	RECSW		;ASSUME DADDY NOT RECURSIVE
	TLNE	A,RECURS	;UNLESS HE WAS
	SETOM	RECSW		;THEN SAY SO
	SETZM	SIMPSW		;RESTORE SIMPLE PROCEDURE FLAG
	TLNE	A,SIMPLE
	SETOM	SIMPSW		;SAY IT IS SIMPLE
	HRRZ	TEMP,TPROC	;GET IT BACK FOR THE NEXT LOAD
>;DIS
	HLRZ	A,%TLINK(TEMP) ;RIGHT TEMP,%TLINK,
	JUMPE	A,LPSERR	;   LPSERR
	MOVE	TEMP,%STEMP(A) ;GET PARTIAL CORE TEMP LIST BACK
	HRRZM	TEMP,TTEMP	;RESTORE TO RIGHTFUL POSITION
	SOS	NMLVL		;REDUCE DDT LEVEL
SLS <
	QPOP	(PRGBSTK)	;GET PRGBLK ID BACK
	MOVEM	A,PRGBLK
>;SLS
	SOS	LEVEL		;UP A LEVEL
	PUSHJ	P,CLRSET	;CLEAR OUT BITS
NOGAG <
	TLNN	FF,CREFSW	;IF CREFFING, PUT OUT SYMBOLS FOR FORMALS.
>;NOGAG
	JRST	FREBUK		;RELEASE OLD BUCKET, RETURN
NOGAG <
	HLRZ	LPSA,%TBUCK(LPSA)	; TO FIRST FORMAL.
CRFNO:	JUMPE	LPSA,FREBUK		;ALL DONE.
	PUSHJ	P,CREFDEF		;SYMBOL DEFINITION.
	HRRZ	LPSA,%RVARB(LPSA)
	JRST	CRFNO
>;NOGAG

Comment ⊗ FORWRD declarations come here to undo damage

at PD1:	PDNO ;   →  NIL   EXEC FWUNDO  SCAN  ¬DS0
⊗

↑FWUNDO:
	QPOP	(FORMFX)	;GET STACK MARKER OFF
; ***** BUG TRAP
	SKIPLE	A		;MUST NOT HAVE PUT ANYTHING ON
	 ERR	 <DRYROT -- FWUNDO>
	GETSEM	(1)
	JRST	SYNTUP		;UP A LEVEL, RESET LIST POINTERS, ETC.

COMMENT ⊗    RESTOR, SAVIT,MKESMT,SETF -- Subroutines for Above

PAR (P)rh = #PARAMS (size of params)
 A     = #LOCALS (size of)
 PNT   = SEMANTICS OF LAST,,SEMANTICS OF FIRST TO BE RESTORED
RES B=# words subtracted
DES Sub sum of both from stack ref'ed in D if there are any (incl Str res in SUB)
 BLT from 1+paramsize(stack) to first local, ending at last local, if recursive ⊗

RESTOR:	PUSH	P,PNT		;SAVE POINTERS
	PUSH	P,A		;SAVE # LOCALS
	MOVEI	B,0		;IN CASE NONE SUBTRACTED
	ADD	A,-3(P)		;TOTAL TO SUBTRACT
	HRLS	A		;XWD
	JUMPE	A,RESDUN	;NOTHING TO DO AT ALL
	ADD	A,X22		;IF STRING PROCEDURE WITH ANY LOCALS OR PARAMS,
	CAIN	D,RSP		; AND ADJUSTING STRING STACK, SUBTRACT AN EXTRA
	TRNN	TBITS2,STRING
	 SUB	 A,X22		; TWO WORDS TO ACCOUNT FOR STRING RESULT
	PUSHJ	P,CREINT	
	HRRZ	B,$VAL(PNT)	;TOTAL NUMBER SUBTRACTED
	MOVE	A,[SUB]		;RESULTS TO PNT -- SOME OF THESE
	PUSHJ	P,EMITER	;EMITS SHOULD EVENTUALLY BE COMBINED
NODIS < 	;NO BLT NEEDED FOR DISPLAY SYS
	HRLZS	D		;NOW USE (D) AS INDEX
	TLNE	TBITS2,RECURS	;IF NOT RECURSIVE, OR
	SKIPN	(P)		; NO LOCALS, THEN
	 JRST	 RESDUN		; ALL DONE
	HRRZ	A,-3(P)		;# PARAMS
	HRLI	C,1(A)		;C(LH) IS EFFECTIVE ADDR
	EMIT	(<MOVSI RTEMP,USADDR+NORLC+USX+NOUSAC>)
			;MOVSI RTEMP,#PARAMS+1(STK)
	MOVE	PNT,-1(P)	;→SEMANTICS OF START ADDR
	EMIT	(<HRRI RTEMP,NOUSAC>) ;HRRI RTEMP,1ST VBL
	MOVSS	PNT		;→SEMANTICS OF END ADDR
	MOVE	A,[BLT RTEMP,NOUSAC]
	MOVE	TBITS,$TBITS(PNT)
	TRNE	TBITS,STRING		;BLT TO SECOND WORD
	 TRO	 A,FXTWO		; IF THERE IS ONE
	PUSHJ	P,EMITER		;BLT RTEMP,LAST VBL
>;NODIS
RESDUN:	POP	P,A			;REMOVE #PARAMS WORD
	POP	P,PNT			;SAVED PNT
	POPJ	P,


Comment  ⊗
IN:	A -- #locals
	D -- stack #
	PNT -- end,start semantics
⊗


SAVIT:
	PUSH	P,PNT
DIS <
	PUSH	P,A
	MOVEI	A,0		;CREATE A ZERO
	PUSHJ	P,CREINT	;GET A ZERO
	EMIT	(<PUSH >)	; PUSH IT ONTO STACK
	SOSG	A,(P)		;ONE LESS ZERO TO BLT
	JRST	PSH1.1		;NOTHING LEFT TO DO
	CAILE	A,4		;BLT CHEAPER ONLY IF >4 MORE
	JRST	BLTIT		;
PSH1:	EMIT	(<PUSH >)	;PUSH A ZIP ON
	SOSLE	(P)		;COUNT DOWN
	JRST	PSH1		;GO PUSH ANOTHER
PSH1.1:	POP	P,A		;GET A BACK
	POP	P,PNT		;GET IT BACK
	POPJ	P,		;THATS ALL
BLTIT:  ;WE WILL DO A BLT
	HRL	D,D		;NEED STACK NO AS INX
	MOVEI	C,0		;ZERO DISPL
	EMIT(<HRLI RTEMP,NOUSAC!NORLC!USADDR!USX>) ;FROM HERE
	HRLI	C,1		;DISPL OF ONE
	EMIT(<HRRI RTEMP,NOUSAC!NORLC!USADDR!USX>) ;TO THERE
	;NOW FOR THE ADD
	MOVE	A,(P)		;GET THE COUNT INTO A
>;DIS
	HRLS	A		;XWD
	PUSHJ	P,CREINT
	EMIT	(ADD)		;ADD STK,[XWD SIZ,SIZ]
	HRL	C,D		;USE STACK # AS DISPL
	EMIT	(<SKIPL USADDR+NORLC+NOUSAC>) ;SKIPL STK
	EMIT	(<PDLOF NOADDR>) ;PDLOF STK,0
NODIS <
	HRRZ	TEMP,$VAL(PNT)	;VALUE OF ABOVE #LOCALS,#LOCALS CONST.
	MOVNI	TEMP,-1(TEMP)	;-#LOCALS+1
	HRL	C,TEMP		;IS ADDRESS
	HRLS	D		;USE STK AS INDEX
	EMIT	(<MOVEI RTEMP,NOUSAC+USADDR+NORLC+USX>)
	POP	P,PNT
	EMIT	(<HRLI RTEMP,NOUSAC>) ;HRLI TEMP,FIRST LOCAL
GAG <;DITTO ABOVE
>;GAG
	MOVSS	PNT
	EMIT	(<BLT RTEMP,USX+NOADDR+NORLC+NOUSAC>) ;BLT RTEMP,(STK)
>;NODIS
DIS <	;NOW WE BLT
	POP	P,A		;RESTORE STACK
	POP	P,PNT		;GET THIS BACK -- NOT IMPORTANT
	MOVEI	C,0		;ZERO	DISPL
	EMIT	(<BLT	RTEMP,NOUSAC!USADDR!NORLC!USX>);BLT RTEMP,(STK)
>;DIS
	POPJ	P,
DIS <
COMMENT⊗
DSCR MKSEMT
DES	EMITS CODE TO BUILD ONE FHQ MSCP
PARM	PNT2 POINTS AT FIRST PROC SEMBLK
SID	MANGLES A,B,C,D,PNT,LPSA,TEMP
⊗

MKSEMT:	PUSH	P,FF			;SAVE IT
	HRLI	C,RF
	EMIT	(<PUSH RP,NOUSAC!USADDR!NORLC>); PUSH P,F
	MOVE	B,CDLEV			;IF PARENT IS GLOBAL, NO LOOP
	SOJG	B,SLNKIT
	HRRZ	A,$VAL(PNT2)		;A→PD SEMBLK
	HLRZ	PNT,%TLINK(A)		;PNT→PDA SEMBLK
	CAIE	PNT,0			;HAVE WE ONE?
	JRST	PPDAW			;YES
	GETBLK				;NO--GET ONE
	MOVE	PNT,LPSA		;SET PNT TO THIS ONE
	HRLM	A,%TLINK(PNT)		;LNK BACK
	HRLM	PNT,%TLINK(A)		;AND FWD
PPDAW:	EMIT	(<PUSH	RP,NOUSAC>)	;PUSH	P,[PDA,0]
	JRST	MKSSS			;GO DO STRING STUFF
SLNKIT:	PUSHJ	P,GETAN0		;GET AC FOR LOOP
	HRLI	C,RF
	EMIT	(<SKIPA, USADDR!NORLC>);SKIPA AC,F
	HRL	D,D			;USE AS INDEX
	HRLI	C,1
	EMIT	(<MOVE	USX!USADDR!NORLC>)	;MOVE AC,1(AC)
	HRLI	C,1
	EMIT    (<HLRZ RTEMP,NOUSAC!USX!USADDR!NORLC>);  HRLZ TEMP,1(AC)
	HLRZ	PNT,%TLINK(PNT2)	;2ND PROC SEMBLK
	HRRZ	PNT,%SAVET(PNT)		;PARENT PROC
	HRRZ	PNT,$VAL(PNT)		;POINT AT PARENTS PD SEMBLK
        EMIT	(<CAIE  RTEMP,NOUSAC!JSFIX>);
	HRLZ	C,PCNT	
	SUB	C,[XWD 3,0]
	EMIT	(<JRST 0,NOUSAC!USADDR>);JRST .-3
	HRRZ	PNT,$VAL(PNT2)	;PNT2→PD SEMBLK
	EMIT	(<HRLI>)	;HRL AC,PDA
	HRL	C,D
	EMIT	(<PUSH RP,USADDR!NOUSAC!NORLC>);PUSH	 P,AC
COMMENT⊗
	NOW THAT AC IS STATIC LINK, MIGHT AS WELL REMEMBER THAT FACT
⊗
	MOVE	B,CDLEV			;INTERNAL LEVEL
	SUBI	B,1			;DADDY
	PUSHJ	P,DISBLK		;LPSA→DISPLAY SEMBLK
	HRRM	D,DISTAB(B)		;UPDATE DISTAB
MKSSS:	HRLI	C,RSP
	EMIT	(<PUSH RP,USADDR!NORLC!NOUSAC>)	;PUSH	P,SP
	HRRZ	PNT,$VAL(PNT2)		;MY PD SEMBLK
	HRRZ	A,PCNT			;PCNT AFTER MKSEMT
	HRLM	A,$ACNO(PNT)		;SAVED IN PD SEMBLK
	POP	P,FF
	POPJ	P,

COMMENT ⊗ 
DSCR	SETF
DIS	EMITS CODE TO SET UP NEW RF
PARM	SAME AS MKSEMT
SID	DITTO
⊗

SETF:	PUSH	P,FF
	HRRI	C,-2			;WILL BE -2(P) FOR E PART
	SKIPE   RECSW			;UNLESS IT WAS RECURSIVE
	MOVN	C,ASDIS
	HRLZ	C,C			;FOR ADDRESS PART
	EMIT    (<HRRZI RF,NOUSAC!NORLC!USADDR(RP)>); HRRZI RF,-2(P)
	POP	P,FF
	POPJ	P,
>;DIS
 
COMMENT ⊗  TWPR1, TWPR2 -- Procedure Syntax  Twiddlers⊗

DSCR TWPR1, TWPR2
PRO TWPR1, TWPR2
DES 
at IDL:	PDEC @IDL @I )  →  PDEC   EXEC INTID ENDDEC TWPR2  SCAN
					   ¬PD1  # Q0
at PD0:	PDEC @I ;  →  PDEC ;  EXEC PRDEC TWPR1    ¬PD1  #Q0
⊗

↑TWPR2:	MOVE	PNT,GENRIG
	MOVEI	A,0		;RESULTS TO PARRIG
	JRST	TWPR
↑TWPR1:	MOVE	PNT,GENRIG+1
	MOVEI	A,1
TWPR:	PUSHJ	P,GETAD
	MOVE	TEMP,%PDNO	;IF FORWARD, PARSER WILL LOOK FOR NO
	TRNE	TBITS,FORWRD	; PROCEDURE BODY
	MOVEM	TEMP,PARRIG(A)	;MODIFIED SYNTACTIC ENTRY
	POPJ	P,

SUBTTL	Procedure Calls
COMMENT ⊗RDYCAL -- Prepare to Call Procedure⊗

DSCR RDYCAL
PRO RDYCAL
DES 
	@CALL SG  →  @CALL SG   EXEC RDYCAL  ¬

Prepare for a procedure call.
A block needs to be prepared to hold information about the
	call, because  PROC(a,PROC(b)) would otherwise
	cause awful confusion.  The block contains:

    1. In  %TLINK, → procedure semantics
    2. In  %TBUCK, →next formal parameter definition
    3. In  $ADR, initial Qstack pointer for FTRPRM. 
    4. In  $VAL, SDEPTH,,0. These (the stack counts) will be restored after the call.
	The reason that ADEPTH cannot be saved has to do with the way LEAP
	stacks things one too late.  In other words, when a fucntion call is
	seen, the ADEPTH count is really one too low, and all hell will break
	loose if the procedure caller merely restores things.  So it must keep
	explicit count of what has happened.

The preparation of this block constitutes preparation for
	the procedure call.
⊗

↑RDYCAL: 
	GETBLK	(GENRIG)
	JRST	RDYCL

↑RDYCL1: 
	GETBLK	(GENRIG+1)	;LPSA → NEW BLOCK
RDYCL:	GETSEM	(1)		;PNT → SEMANTICS OF PROCEDURE
LEP <
	TLNE	FF,LPPROG	;FOREACH IN PROGRESS?
	TLNN	TBITS,MPBIND	;AND THIS A MATCHING PROCEDURE?
	JRST	NOMPRO
	PUSH	P,PNT		;SAVE IT
	PUSH	P,LPSA		;IT ALSO
	PUSHJ   P,CHKSAT	;POP SATISFIERS INTO CORE IF NECESSARY
	MOVEI	A,0
	PUSHJ	P,CREINT
	GENMOV	(STACK,0)	;RESERVE A PLACE FOR ITEM PARAM TO SPROUT
	POP	P,LPSA
	POP	P,PNT
NOMPRO:
>;LEP
GLOC <
	SKIPN	MESFLG		;IS THIS A MESSAGE PROCEDURE ?
	 JRST	 NOMESQ		;NOPE
	SETZM	MESFLG		;RESET THE FLAG.
	TLO	SBITS,LPFREE	;THIS IS HOW WE TELL EVERYONE.
	TLNN	TBITS,MESSAGE
	ERR	<MESSAGE: REQUIRES MESSAGE PROCEDURE>,1
	MOVEM	SBITS,$SBITS(PNT);
NOMESQ:
>;GLOC
	MOVEM	TBITS,$TBITS(LPSA)
	MOVEM	SBITS,$SBITS(LPSA) ;COPY THESE
	HRLM	PNT,%TLINK(LPSA)
	EXCH	PNT,LPSA
	TLNE	TBITS,OWN	;BUILT-IN FUNCTION?
	JRST	BLTN		; YES, GO SET UP BYTE POINTER
	LEFT	,%TLINK,LPSERR	;SECOND BLOCK OF PROC
	LEFT	(,%TLINK)		;→FIRST PARAM OR NIL
	HRRM	LPSA,%TBUCK(PNT)
QCAL:	QPUSH	(FTRPRM)		;MAKE SURE STACK IS
	QPOP	(FTRPRM)		;INITIALIZED
	MOVE	TEMP,FTRPRM
	MOVEM	TEMP,$ADR(PNT)	;SAVE QSTACK POINTER
; lh of $VAL used to collect the number of string elements to be removed
; after the call -- rh is used for non-string elements.
;*-*	HRLZ	TEMP,SDEPTH
;*-*	MOVEM	TEMP,$VAL(PNT)	;SAVE SDEPTH,,0
GLOC <
	TLNN	SBITS,LPFREE	;IF A MESSAGE PROCEDURE, THEN
	POPJ	P,		;
	XCALL	<.MES1>		;PREPARE FOR THE CALLS.
>;GLOC
	POPJ	P,

BLTN:	MOVEI	TEMP,$SBITS+2(LPSA)
	HRLI	TEMP,440600	;POINT 6,FIRST PARAM WORD
	MOVEM	TEMP,$VAL2(PNT)	;STORE FOR PARAM DESCRIPTOR RETRIEVAL
	JRST	QCAL		;FINISH UP

GLOC <
;MESSAGE PROCEDURE STARTER.

↑MESCL:	SETOM	MESFLG		;NEXT FCALL IS A MESSAGE.
	POPJ	P,
>;GLOC
COMMENT ⊗  Describe CALARG⊗

DSCR CALARG
PRO CALARG
DES
at SID:	IPR SG  →  S SG   EXEC ISUCL1	¬S9

at EE2:	PCALL @E )  →  S   EXEC CALARG ISUCAL  SCAN  ¬S9
	FCALL @E )  →  P  EXEC CALARG ISUCAL TYPPRO  SCAN  ¬XID
	@CALL @E ,  →  @CALL  EXEC CALARG   ¬EX0
	IPR SG   →  P SG   EXEC ISUCL1  TYPR1   ¬XID

Generate parameter calls, issue procedure calls

A. Parameter calls
  Several things have to happen here:
  1. REFERENCE or VALUE determines whether an address or a 
	value will be "PUSH"ed. For reference parameters,
	certain things are illegal (i.e. expressions, procedure
 	executions) unless we are issuing a FORTRAN call. Procedures
	with no parameters must be called unless the formal is a
	(reference, non-FORTRAN) procedure. The address word (with
	types) is created (if possible) for reference 
	parameters.  A reference parameter called by reference is a special
	case.

  2. A destination must be determined. For FORTRAN calls, the
	semantics of the created (address) word is pushed into
	a compile time "buffer" Qstack. For others, the
	thing is stacked appropriately on the P or SP stack
	(code is issued).
⊗
COMMENT ⊗  CALARG -- Pass a Parameter⊗

TOOMNY:	ERR	<TOO MANY ARGUMENTS SPECIFIED TO PROCEDURE>,1
;;#GW# 5-11-72 DCS (1-4) AVOID CALLING AT RUNTIME WITH TOO MANY PARAMS
	TLNN	TBITS,CONOK	;TRYING TO CALL AT COMPILE TIME?
	 JRST	 SAMADR		;NO
	TLO	TBITS,400000	;SOMETHING SILLY -- DON'T DO IT.
	MOVEM	TBITS,(SP)	;UPDATE
	JRST	SAMADR
;;#GW# (1-4)
↑CALARG: PUSH	P,SP		;GOOD SAFE AC
	PUSH	P,ADEPTH	;THIS IS FOR COMPARING PURPOSES.... SEE BELOW
	GETSEM	(2)		;SEMANTICS OF PROCEDURE CALL BLOCK
	MOVE	SP,PNT		;SAVE HERE
	TLNE	TBITS,ANYTYP	;IF ON, ASSUME REFERENCE, TYPE OK
	 JRST	 SAMADR
	TLNE	TBITS,OWN	;BUILT-IN PROCEDURE?
	 JRST	 [ILDB	TBITS2,$VAL2(PNT) ; YES, GET FORMAL DESCRIPTION
		 JUMPE	TBITS2,TOOMNY	; TOO MANY ARGUMENTS SUPPLIED
		 MOVE	TBITS2,BLTTBL(TBITS2)
		 JRST	BLTBAK		;CONTINUE AFTER SIMILAR BRANCH
]

	HRRZ	PNT2,%TLINK(SP)	;PNT2 → NEXT FORMAL PARAM DESCR
	JUMPE	PNT2,[TRNN	TBITS,FORTRAN	;FORTRAN CALL?
		      JRST	TOOMNY		;NO -- TO MANY ARGS CITED.
		      SETOM	TBITS2		;FLAG AS DON'T CONVERT
		      JRST	FTRARG]		;ELSE GO AWAY.
	HRRZ	LPSA,%RVARB(PNT2) ;→NEXT FORMAL PARAM AFTER THIS
	HRRM	LPSA,%TBUCK(SP)	;STORE POINTER TO NEXT IN CALL BLOCK
	MOVE	TBITS2,$TBITS(PNT2) ;ALL THAT'S IMPORTANT
BLTBAK:	TRNE	TBITS,FORTRAN	;FORTRAN CALL?
	 JRST	 FTRARG		; YES
	GETSEM	(1)		;SEMANTICS OF ACTUAL TO PNT GROUP
	TLNE	TBITS2,REFRNC	;BY REFERENCE?
	 JRST	 REFARG		; YOU BETCHUM

LEP <
	TLNE	TBITS2,MPBIND	;A FORMAL ? ITEMVAR
	JRST	MPPARM		;YES
>;LEP
; ***** BUG TRAP
	TLNN	TBITS2,VALUE	;TEST UNLIKELY CASE
	 ERR	 <DRYROT -- CALARG>,1

; VALUE PARAMETER
	TLNN	SBITS,LPFRCH!FREEBD
	JRST	VALPAR
	TLNE	SBITS,LPFREE
	ERR	<UNBOUND LOCAL AS PARAMETER TO PROCEDURE>,1
	PUSHJ   P,CHKSAT	;POP SATISFIERS INTO CORE IF NECESARY

VALPAR:	TLNE	TBITS,SBSCRP	;MAKE A TEST
	 ERR	 <ARRAYS BY VALUE NOT IN>,1
	PUSH	P,TBITS2	;SAVE FORMAL TYPE BITS
	TRNE	TBITS,PROCED	;IF VALUE PROCEDURE, NO PARAMS,
	 PUSHJ	 P,CALNPR	; CALL IT NOW
OKPRM:	POP	P,B		;TYPE OF FORMAL
LEP <
	TLNN	TBITS,FORMAL!SBSCRP	;FOR LEAPISH CONSTRUCTS.
	TRNN	TBITS,ITEM
	JRST	GMV
	TRNN	B,ITEM!ITMVAR		;TARGET TYPE
	ERR	<ITEM TYPE MISMATCH>,1	;BLOW
	SKIPE	PNT,$VAL2(PNT)		;PLACE WHERE ITEM NUMBER IS STORED.
	PUSHJ	P,GETAD			;AND GET HIS BITS.
	HRRI	FF,POSIT
	JRST	GMV2+1
GMV:	TRNE	TBITS,ITEM!ITMVAR
	JRST	GMV2
	TRNE	TBITS,LSTBIT
	JRST	[TRNN	B,LSTBIT	;BOTH LISTS, NO WORRY
		 ERR <WARNING-LIST EXPR. COERCED TO SET EXPR>,1
		 JRST	.+1]
>;LEP
GMV2:
	HRRI	FF,INSIST!POSIT
;;#  # DCS 2-29-72 CALL F(CONST,...) AT COMPILE TIME
	MOVE	TBITS2,$TBITS(SP)	;PROC CALL BLOCK BITS
	TLNE	TBITS2,CONOK		;STILL OK?
	TLNN	TBITS,CNST		; ALSO NO USE IF THIS NOT CONST
	 JRST	 STRET			;NO
	GENMOV	(CONV)			;MAKE SURE CONVERTED
	HRRI	FF,0			;IN CASE NOT CONST
	TLNN	TBITS,CNST		;CONST OF RIGHT TYPE?
	 JRST	 STRET			;NO
; STILL CONOK, SAVE CONST
	QPUSH	(FTRPRM,PNT)		;SAVE THE SEMBLK
	POP	P,ADEPTH		;NO CHANGE TODAY
	POP	P,SP			;GET STACK BACK
	POPJ	P,			;DONE RIGHT NOW
;;#  #

STRET:	PUSHJ	P,CONCHK		;STACK PREV CONSTS
	GENMOV	(STACK)			;DO THE PUSH.
	MOVSI	TEMP,2			;Keep track of the number of string
;;#HM# JRL 5-31-72 AVOID DRYROT BY STRING ARGS TO MESSAGE PROCEDURE
	MOVE	SBITS,$SBITS(SP)		;WILL TELL IF A MESSAGE PROC. CALL
;;#HR# JRL 6-14-72 A STRING ITEM IS NOT A STRING
	TRNE	TBITS,ITEM!ITMVAR	;TURN OFF STRING BIT FOR ITEMS
	TRZ	TBITS,STRING
;;#HR#
	TRNE	TBITS,STRING		; words which will adjust SDEPTH
	TLNE	SBITS,LPFREE		;A MESSAGE PROCEDURE
	JRST	CALRET			;If message pro, or not string no sdepth change
	ADDM	TEMP,$VAL(SP)		; when call is finished.
;; #HM#
	JRST	CALRET			;DONE ALREADY

CONCHK:	PUSH	P,B
	MOVE	TEMP,$TBITS(SP)		;CONOK bit on in this Semblk (PCALL
	TLZN	TEMP,CONOK		; block) if calling runtime which can
	 JRST	 BPOPJ			; be evaled at comp. time, and all prev
	MOVEM	TEMP,$TBITS(SP)		; args were const -- but this arg is
	MOVE	B,$ADR(SP)		; non-const, so must recover.
	CAMN	B,FTRPRM		;If there were no previous constant
	 JRST	 BPOPJ			; args, there is nothing left to do.
	PUSH	P,PNT			;Now issue stack code for each arg
CONCAL:	QTAKE	(FTRPRM)		; previously saved (types already
	 JRST	 CONDUN			; matched up before saving).
	MOVE	PNT,A
	GENMOV	(STACK,GETD!REM)
	MOVSI	TEMP,2			;Update the ADEPTH or SDEPTH count in
	TRNN	TBITS,STRING		; Pcall Semblk -- will be used to readjust
	 AOSA	 $VAL(SP)		; these variables when call finished.
	 ADDM	 TEMP,$VAL(SP)
	JRST	CONCAL
CONDUN:	MOVE	TEMP,$ADR(SP)		;No REF args were handled, our part of
	MOVEM	TEMP,FTRPRM		; this stack had only consts, can remove.
	POP	P,PNT			;Now the state of things is as if the
	PUSHJ	P,GETAD			; stack code had gone out the first time.
BPOPJ:	POP	P,B
	POPJ	P,
MPPARM:				;BINDING ITEMVAR PARAMETER
LEP <
	TRNN	TBITS,ITEM!ITMVAR	;BETTER BE ITEM TYPE
	ERR	<PARM TO  ? ITEMVAR NOT ITEM EXPRESSION>,1
	TLNE	SBITS,LPFRCH!FREEBD
	TLNN	SBITS,LPFREE		;STILL FREE WITHIN FOREACH?
	JRST	VALPAR			;NO TREAT AS VALUE PARAMETER
	MOVE	B,MPQBEG		;THE BEGINNING OF LIST OF ? PARMS
	HRRZS	PNT			;TO USE CAI
LPPCHK:	QTAKE	(MPQSTK)		;CHECK TO SEE IF PARM ALREADY THERE
	JRST	NTPARM			;NOT THERE
	CAIE	PNT,(A)			;THE SAME PARAM?
	JRST	LPPCHK			;NO.
	ERR	<SAME PARAM MENTIONED TWICE TO MATCHING PROCEDURE>,1
NTPARM: QPUSH	(MPQSTK,PNT)		;PUT THIS ON PARM LIST
; AT THIS POINT GENREATE APPROPRIATE LPCALL FOR POTUNB IF NECESSARY.
	TLNE	TBITS,FREEBD
	JRST	[MOVE PNT,$VAL2(PNT)	;GET LOCAL NUMBER
		 GENMOV (STACK,0)
		 LPCALL (STKQPR)	;INTERPRETIVE CALL TO SEE IF BOUND
		 JRST CALRET]
	TLO	PNT,20			;WANT INDIRECT BIT
	SETOM	MPFLAG			;TO TELL THAT WE WANT TYPE BITS
	PUSHJ	P,FTRADR		;GET ADCON
	GENMOV	(STACK,0)		;STACK IT
	SETZM	MPFLAG
	JRST	CALRET
>;LEP

; FORTRAN ARGUMENT -- ASSURE VALID TYPE

FTRARG:
	GETSEM	(1)
	TLNE	TBITS,SBSCRP
	 ERR	 <DON'T PASS ARRAYS TO FORTRAN (YET)>,1
	TRNE	TBITS,PROCED	;PROCEDURES MUST BE EVALUATED
	 PUSHJ	 P,CALNPR	; CALL WITH NO PARAMS
	HRRI	FF,INSIST!POSIT
	SKIPG	B,TBITS2	;THIS IS THE TYPE WE HOPE FOR
	TRC	FF,INSIST!ARITH	;NO TYPE SPECIFIED -- JUST GET ARITH.
	TLNE	TBITS,CNST	;PROTECT CONSTANTS BY MOVING THEM.
	 JRST	 CNGET
	GENMOV	(CONV)
	JRST	 MAKADR		;GO MAKE ADDRESS CONSTANT
CNGET:	TRO	FF,MRK
	GENMOV	(GET)
	JRST	MAKADR

REFARG:	PUSHJ	P,CONCHK	;STACK PREV CONSTANTS
	TRNE	TBITS2,PROCED	;IF FORMAL ¬ PROCEDURE,
	 JRST	 CHKEXP
	TRNE	TBITS,PROCED	;AND ACTUAL IS ONE, ERROR
	PUSHJ	P,CALNPR	;MAKE IT AN EXPRESSION TO PASS BY REFERENCE
CHKEXP:
; #HZ# JRL 6-27-72 TEST SBSCRP BIT BEFORE ALL OTHERS
	TLNE	TBITS,SBSCRP
	JRST	CKTYP
LEP <
	TRNE	TBITS,ITEM
	ERR	<DO NOT PASS ITEMS BY REFERENCE>,1
	TRNE	TBITS2,LSTBIT	;LIST FORMAL?
	JRST	[TRNE	TBITS,LSTBIT;	AN ACTUAL LIST?
		 JRST .+1	;YES
		 MOVE B,SET!LSTBIT
		 JRST	RTYPER]
	TLNE	SBITS,LPFRCH!FREEBD
	ERR	<FOREACH LOCAL AS REFERENCE PARAMETER>,1
>;LEP
; #HZ#
	TLNN	SBITS,ARTEMP!STTEMP ;EXPRESSION?
	 JRST	 CKTYP		;NO
	TLNE	SBITS,FIXARR	;FIXED CALCULATED ARRAY THING?
	 JRST	 CKTYP		; YES, DON'T WORRY
	TLNN	SBITS,INDXED	;OK IF CALCULATED SUBSCRIPT

	JRST	[TRNN	TBITS2,STRING ;DON'T ALLOW STRING EXP BY REF
		 ERR	<WARNING: EXPRESSION BY REFERENCE;
WILL WORK BUT INACCESSABLE AFTER CALL>,1
		STREXP: TRNE TBITS2,STRING
		ERR	<NO STRING EXPRESSIONS BY REFERENCE>,1
		GENMOV	(INCOR)
		QPUSH	(FTRPRM,PNT)	;SAVE FOR LATER REMOPING
		JRST	.+1]		;GO CHECK TYPES

CKTYP:	
	TRNA	TBITS,PROCED		;SPECIAL CHECK
	JRST	[PUSH	P,TBITS2
		HRRZ	TEMP,GENLEF+1	;GET THE ARGUMENT PROCEDURE
		TLNE	TBITS,OWN	
		JRST	CKTYPO		;EVEN SPECIALER
CKTYP0:		HRRZ	TEMP,%RVARB(TEMP)	;GET PARMS TO PARM PROC
		JUMPE	TEMP,CKTYP2		;DONE
		HRRZ	TBITS2,$TBITS(TEMP)	;GET BITS
		TLNN	TBITS2,REFRNC		;PARMS OF PRAM PROC MUST BE REF.
		ERR	<PARAMETERS TO A PROCEDURE ARGUMENT TO A PROCEDURE MUST BE REFERENCE>,1
		JRST	CKTYP0
CKTYPO:		MOVEI	TEMP,$ACNO(TEMP)	;MAKING  BYTE POINTER
		HRLI	TEMP,440600		;POINT 6,FIRST PARM WORD
CKTYP1:		ILDB	TBITS2,TEMP		;GET BITS
		JUMPE	TBITS,CKTYP2		;DONE
		TLNN	TBITS,REFRNC		;
		ERR	<PARAMETERS TO A PROCEDURE ARGUMENT TO A PROCEDURE MUST BE REFERENCE>,1
		JRST	CKTYP1
CKTYP2:		POP	P,TBITS2
		JRST	.+1    ]


	MOVE	B,TBITS		;ALGORITHM IS TO MAKE SURE THAT ALL BITS
	AND	B,[XWD SBSCRP,ALTYPS]	;ON IN ACTUAL ARE ON IN FORMAL.
	SETCM	TEMP,TBITS2	;THIS ALLOWS ARRINFO AND FRIENDS TO HAVE
	TLNE	TBITS2,SBSCRP	;IF FORMAL REQUIRES ARRAY, THEN MAKE SURE IT IS
	TLNE	TBITS,SBSCRP
	TDNE	B,TEMP		;ANY TYPE ARRAYS PASSED TO THEM.

RTYPER:	JRST	[TERPRI <WARNING: TYPE MISMATCH FOR REFERENCE CALL>
		 TERPRI <CONVERTED EXPRESSION WILL BE PASSED BY REFERENCE>
		 ERR	<ORIGINAL VARIABLE WILL NOT BE ALTERED BY PROCEDURE>,1
		 MOVE   B,TBITS2
		 GENMOV	(CONV,INSIST)	;MAKE TYPE CONVERSION
		 MOVE	TBITS2,TBITS	;DON'T LET IT HAPPEN AGAIN!
		 JRST	STREXP]

	JRST	MAKADR		;FINISH UP

; CREATE FORTRAN-LIKE TYPE BITS FOR AC FIELD

SAMADR:	GETSEM	(1)		;NOBODY ELSE GOT ACTUAL'S SEMANTICS
MAKADR:	MOVE	TBITS2,$TBITS(SP)	;GET PROC BITS BACK
	TLNE	SBITS,INDXED	;NO NEED TO STORE INDXED THINGS
	 JRST	 LATER		; BECAUSE DYNAMAK AND FRIENDS WILL
	GENMOV	(INCOR)		;MAKE SURE ARG IS IN CORE.

LATER:	
	TRNE	TBITS2,FORTRAN	;IF HERE AND FORTRAN, WE DEFINITELY
	 JRST	 .+3		;WANT TO STAY HERE DAMMMMMIT
	TLNE	TBITS,REFRNC
	 JRST	 REFREF		;REF CALLED BY REF (SPCL CASE)
	MOVEI	TEMP,0		;COLLECT BITS HERE
	TRNE	TBITS,FLOTNG	;0 FOR INTEGR, 2 FOR FLOATING,
	ADDI	TEMP,2
	TLNE	TBITS,SBSCRP	;8 + OTHERS FOR ARRAYS
	ADDI	TEMP,=8
	LSH	TEMP,5		;TO AC POSITION
	HRL	PNT,TEMP	;TO AC AREA

; PNT NOW CONTAINS SEMANTICS OF REF VBL IN LH, TYPES IN RH

	TRNE	TBITS2,FORTRAN	;CALLING FORTRAN?
	 JRST	 FTRSAV		;YES, JUST SAVE ADCON SEMANTICS
	TLNN	TBITS,SBSCRP	;STACK VBL ITSELF IF SBSCRP
	PUSHJ	P,ADRINS	;GET → ADCON IN PNT, ETC.
	GENMOV	(STACK,0)		;STACK IT
	JRST	 CALRET

FTRSAV:	PUSHJ	P,FTRADR	;GET (UNIQUE) ADCON SEMANTICS
	QPUSH	(FTRPRM,PNT) ;SAVE SEMANTICS TILL LATER
	JUMPL	PNT,[POP P,A ↔ POP P,SP
		     POPJ P,]
	JRST	CALRET

REFREF:	GENMOV	(STACK,ADDR)	;JUST STACK IT AGAIN (REF BY REF)
CALRET:	
	MOVE	SP,GENLEF+2		;SINCE TOTAL USES THE DAMNED THING.
	POP	P,A			;OLD ADEPTH.
GLOC <
	MOVE	SBITS,$SBITS(SP)	;SBITS FOR PROCEDURE.
	TLNN	SBITS,LPFREE		;IF A MESSAGE PROCEDURE IS BEING ISSUED.
	JRST	CAL00			;NO
	MOVE	TBITS2,$TBITS(PNT2)	;DESTROYED IF A REFERENCE.
	TRNE	TBITS2,PROCED!LABEL	;THESE NOT ALLOWED.
	 ERR	 <MESSAGE: INVALID PARAMETER LIST MEMBER>,1
	TRNE	TBITS2,STRING		;GODDAMN
	TLNE	TBITS2,REFRNC
	JRST	.+3			;FIGURE OUT WHICH STACK TO SUBTRACT
	SOS	SDEPTH
	SOSA	SDEPTH
	SOS	ADEPTH			;ALL OVER.
	HRL	C,TBITS2		;GET THE TBITS WORD IN TAC1
	EMIT	(<MOVEI TAC1,USADDR!NOUSAC!NORLC>)
	HLL	C,TBITS2
	EMIT	(<HRLI TAC1,USADDR!NOUSAC!NORLC>)
	XCALL	<.MES2>			;AND PROCESS THE PARAM.
	JRST	NOADJ		;DO NOT INDEX COUNTS. -- OTHERWISE DOOM.
CAL00:
>;GLOC
	CAME	A,ADEPTH		;SAME AS NOW (WAS THERE A PUSH DONE??)
	AOS	$VAL(SP)		;NO -- UPDATE COUNTS.
NOADJ:	POP	P,SP		;RESTORE STACK
	JRST	REMOP		;REMOVE TEMP ARGS,RETURN

↑CALNPR: PUSH	P,GENRIG	;SINCE ISUCL1 DESTROYS IT.
	MOVEM	PNT,GENLEF+1	;SIMULATE A CALL TO RDYCAL
	PUSHJ	P,RDYCL1	;AS THE PARSER WOULD DO IT
	MOVEW	GENLEF+1,GENRIG+1 ;RESULTS BACK TO LEFT SIDE
	PUSHJ	P,ISUCL1	;CALL THE PROCEDURE
	MOVE	PNT,GENRIG+1
	POP	P,GENRIG	;RESTORE THE BLESSED CELL (IT ONLY POINTS TO PROC).
	JRST	GETAD		;LEAVE ITS SEMANTICS IN PNT, ETC.
COMMENT ⊗    ADRINS -- Subrt for Above -- Prepare an Address Constant (Semblk)

Address constant blocks have fixup information for
	address constants necessary for procedure calls. The
	constants are of the form:

	TYP(fortran),,address, where TYP is:

  0  for integer
  2  for floating
  8 + others for arrays

An ADCON block uses %RVARB to link to the ADRTAB ring.
	The %TLINK field indicates the intity whose AD
	is being CONned. The type is inserted in the left
	half of $ADR -- fixups for the ADCON go in $ADR(rh).
	These constants will be output after space is 
	allocated for the associated variables, or at the
	time of a FORTRAN call. For temps and those
	blocks involved in a FORTRAN call, unique ADCON
	blocks are assigned for each eventual word of code. For 
	others, fixups are chained via a search of the 
	ADCON list.

IN:	PNT -- TYPE,,semantics of entry
OUT:	PNT,TBITS,SBITS -- semantics of result
	C(lh) -- old fixup
Call ADRINS for normal insertion, FTRADR for unicke ones
If FTRADR is called with MPFLAG non-zero the type bits,
in left half PNT will be inserted but otherwise FORTRAN-like
things won't happen (see DYNAMAK)
If MPFLAG is set the address of the array is considered to be
the address of the cell containing the descriptor. I don't
believe ADRINS is every called with an array except if MPFLAG
is set.
⊗

↑ADRINS: TLOA	FF,FFTEMP	;CONDUCT A SEARCH
↑FTRADR: TLZ	FF,FFTEMP	;DON'T
	PUSHJ	P,GETAD		;GET SEMANTICS OF AD TO BE CONNED
DIS <
	TRNE	SBITS,DLFLDM	;IF A DISPLAY REG IS NEEDED
	JRST	DYNAMAK		;MUST DO DYNAMAK
	TLNE	CORTMP		;ALSO CHECK THE CASE OF TEMPS IN REC PRO
	SKIPN	RECSW		;
	JRST	.+2		;
	JRST	DYNAMAK		;
>;DIS
	TRNE	TBITS,PNTVAR	;DON'T REALLY UNDERSTAND THESE YET
	 ERR	 <POINTER VARS MAY NOT BE CALLED BY REFERENCE>,1
	TLNE	SBITS,FIXARR	;IF HAVE CALCULATED WHOLE INDEX THING,
	 JRST	 DYNAMAK	; GET IT WITH A MOVEI
	TLNN	TBITS,FORMAL	;IF ARG IS NOT IN FIXED LOC,
	TLNE	SBITS,INDXED
	 JRST	 DYNAMAK	;  CREATE ADCON AT RUN TIME

	TLNN	FF,FFTEMP	;ALSO IF FORTRAN TYPE ADCON
	 JRST	 INSNEW		;JUST INSERT A NEW ONE
	TLNE	SBITS,ARTEMP	;DON'T SEARCH FOR TEMP MATCHES
	 JRST	 TEMLUK		; IN THE SAME WAY

	TLNE	TBITS,CNST	;ALSO CONSTANTS DONE DIFFERENTLY
	JRST	CONADD


SRCH:	MOVE	LPSA,ADRTAB	;ADDRESS CONSTANT "RING"
	JUMPE	LPSA,INSNEW	;NOTHING YET, MAKE SOMETHING
SRCLUP:	HLRZ	TEMP,%TLINK(LPSA) ;→SEMANTICS OF THING
	CAIN	TEMP,(PNT)	;SAME STUFF?
	 JRST	 FOUND1		;YES, FOUND ONE
	LEFT	,%RVARB,INSNEW	;KEEP LOOKING
	 JRST	 SRCLUP

TEMLUK:	TLNN	SBITS,CORTMP	;MUST BE A CORTMP
	ERR	<DRYROT -- TEMLUK>
	MOVE	LPSA,ADRTAB	;SEARCH ADCON TABLE FOR SAME ID NO
	JUMPE	LPSA,INSNEW	;NONE FOR THIS TEMP YET
	MOVE	A,$PNAME(PNT)	;TEMP ID NO FOR THIS TEMP

TMLUUP:	MOVE	TEMP,$SBITS(LPSA)
	TLNN	TEMP,ARTEMP	;MUST BE TEMP OR DON'T LOOK
	JRST	LEFLUK
	CAMN	A,$PNAME(LPSA)	;SAME TEMP?
	 JRST	 GETADL		;YES, THIS IS THE RESULT
LEFLUK:	LEFT	,%RVARB,INSNEW	;LOOP UNLESS YOU RUN OUT
	JRST	TMLUUP


FOUND1:	HLLZ	TEMP,$ADR(LPSA) ;MAKE SURE TYPE HASN'T CHANGED
	HLR	TEMP,PNT
	TSC	TEMP,TEMP	;SEE IF TYPE FROM ADCON IS SAME
	SKIPN	TEMP		; AS THAT COMING IN
	JRST	GETADL		;IT IS,DONE

INSNEW:	GETBLK
				;GET ANOTHER ONE
	PUSHJ	P,RNGADR	;ADD THIS ADCON TO ADRTAB
	HLLM	PNT,$ADR(LPSA)	;STORE TYPE
	HRLM	PNT,%TLINK(LPSA) ;AND SEMANTICS OF THING BEING ADCONNED

	MOVEW	(<$PNAME(LPSA)>,<$PNAME(PNT)>) ;TRANSFER ID NO IF ANY
	MOVEI	TEMP,INTEGR	;TYPE FOR ADCON ITSELF, IF NEEDED
	MOVEM	TEMP,$TBITS(LPSA)
	MOVEM	SBITS,$SBITS(LPSA)	;SAVE SBITS FOR ADCON TYPE DETERMINATION

GAG <;ASSIGN STORAGE AND ADDRESS VALUE TO ADCON
	HRRZ	A,$ADR(PNT)		;THE ADDRESS OF THE ADD BEING CONNED
	TRNE	TBITS,STRING		;USE 2D WORD FOR STRING REFERENCES
	 HLRZ	 A,$ADR(PNT)
	MOVEI	TEMP,0			;DON'T DO IT FOR FORTRAN (DIFFERENT
	MOVEI	B,0			;INDICATE INTEGER THING
	PUSH	P,LPSA
	MOVEI	LPSA,VARSTK
	TLNE	FF,FFTEMP		;  SCHEME ENTIRELY)
	 PUSHJ	 P,CPUSH		;PUT ADDR IN NEW WORD, GET POINTER
	POP	P,LPSA
	HRRZM	TEMP,$ADR(LPSA)		;ADDR OF ADCON TO $ADR WORD
>;GAG


	HRR	PNT,LPSA		;DO NOT CLOBBER LEFT HALF OF PNT.
	JRST	GETAD			;THAT'S IT.



CONADD:	TRNE	TBITS,STRING	;WILLING TO PASS ALL BUT STRING CONST
	ERR	(<NO STRING CONSTANTS BY REFERENCE>,1) ;BY REFERENCE
	PUSH	P,$VAL(PNT)	;SAVE FOR A MOMENT
	PUSH	P,$TBITS(PNT)
	PUSHJ	P,REMOP		;IN CASE IN AC
	POP	P,BITS
	POP	P,A
	PUSHJ	P,ADCINS	;SPECIAL ENTRY (UNIQUE)
	JRST	INSNEW		;MAKE ADCON FOR THIS UNIQUE CONSTANT
DYNAMAK: 
	MOVEM	TBITS,TBSAVE	;SAVE SBITS
	TLNE	TBITS,SBSCRP	;AN ARRAY
	TLZN	TBITS,REFRNC	;TURN OFF REFERENCE BIT
	CAIA
	TLO	TBITS,VALUE	;TURN ON VALUE BIT IF WAS REFRNC
	MOVEM	TBITS,$TBITS(PNT); 
	GENMOV	(GET,ADDR!REM)	;WILL GET ADDRESS OF THING WITH A MOVEI
				;IT ALL HAPPENS MAGICALLY
	MOVE	TBITS,TBSAVE
	MOVEM	TBITS,$TBITS(PNT)
	HLLZ	C,PNT		;TYPE BITS, USE AS ADDR FLD OF HRLI
	PUSHJ	P,MARKINT	;MARK AN INTEGER FOR KICKS.
	TLNE	FF,FFTEMP	;FORTRAN CALL REQUIRE THIS ADCON?
	 POPJ	 P,		;NO, LEAVE SEMANTICS FOR PUSH
	JUMPN	C,NDBITS	;ARE THERE NON-ZERO TYPE BITS
	SKIPE	MPFLAG		;IF NO BITS AND NOT FORTRAN
	POPJ	P,		;RETURN
NDBITS:	SKIPN	MPFLAG		;DON'T CHANGE INSTR IF REMEMBER PARAM
	OR	C,[JUMP]	;FORTRAN WANTS A NOOP HERE
	EMIT	(<HRLI  USADDR+NORLC>) ;HRLI AC,TYPE*2↑5
	SKIPE	MPFLAG
	POPJ	P,		;IF REMEMBER OF MP RETURN NOW.
	PUSHJ	P,REMOP		;DON'T NEED SEMANTICS ANYMORE
	HRRO	PNT,PCNT	;FIXUP ADDR IN RH, MARK LH NEG TO DIFFERENTIATE
	EMIT	(<MOVEM NOADDR>)	;MOVEM AC,FIXED UP LATER
	POPJ	P,

COMMENT ⊗  ISUCAL -- Call the Procedure, Mark Resultant Type, etc.⊗

DSCR ISUCAL, ISUCL1
PRO ISUCAL ISUCL1
RES
	PCALL @E )   →   S	EXEC CALARG ISUCAL  SCAN  GO S9
	FCALL @E )   →   P	EXEC CALARG ISUCAL  TYPPRO  SCAN  GO XID
	IPR SG       →   P SG	EXEC ISUCL1 TYPR1  GO XID
⊗

↑ISUCAL:
	SKIPA	PNT,GENLEF+2	;GET PROCEDURE

↑ISUCL1:
	MOVE	PNT,GENRIG+1	;   CALL BLOCK SEMANTICS
				; (PLACED BY RDYCAL FOR ISUCL1)

ISSUE:	PUSH	P,$ADR(PNT)	;CONTAINS SAVED FTRPRM PTR.
	PUSH	P,$VAL(PNT)	;RESTORE DEPTHS
				;BUT AFTER CALLING ALLSTO, ETC.

	MOVE	TBITS2,$TBITS(PNT) ;NEED TO CHECK BUILT-IN
	MOVE	C,TBITS2	;FOR CONST EVAL DON'T DO IT FLAG
	TLNE	TBITS2,OWN	; IS IT?
	 JRST	[ILDB	TEMP,$VAL2(PNT) ;YES, GET NEXT PARAM DSCRPTR
		 JUMPN	TEMP,ERCAL	;SHOULD BE 0 (NONE LEFT)
		 JRST	OKCAL		;OTHERWISE, ALL DONE
]

	RIGHT	PNT,%TBUCK,OKCAL ;MAKE SURE FORMAL LIST IS EMPTY
ERCAL:	 ERR	 <NOT ENOUGH PARAMETERS SUPPLIED TO PROCEDURE>,1
;;#GW#↓ 5-11-72 DCS (2-4) DON'T CALL AT COMPTIME IF WRONG NUMB. OF PARAMS
	 TLO	 C,400000	;FLAG ERROR -- DON'T EVAL AT COMPILE TIME
OKCAL:	HRRZ	LPSA,PNT	;RELEASE CALL BLOCK,
	HLRZ	PNT,%TLINK(PNT)	;  GET SEMANTICS OF PROC
	FREBLK
	PUSHJ	P,GETAD		; PNT, ETC. DESCRIBE PROC SEMANTICS
;;#  # DCS 2-29-72 COMPILE-TIME CALL OF PROCEDURE
	TLNN	TBITS2,CONOK	;If CONOK on, all args were const, we call
	 JRST	 NC		; the procedure now, recording approp. const.
	POP	P,TEMP		;Any saved Depths are irrelevant now
	EXCH	SP,STPSAV	;Prepare stacks and pdlov-message information
	MOVSS	POVTAB+6	; for the impending call.
	MOVE	B,(P)		;Fetch start of our part of stack, verify that
	CAMN	B,FTRPRM	; there were args, or quit.
	 JRST	 NA
NOWLUP:	QTAKE	(FTRPRM)	;Actually stack each constant value, then REMOP
	 JRST	 NA		; its representation.  Choose the right stack.
	MOVE	PNT2,A
	PUSHJ	P,REMOP2
	MOVE	TBITS2,$TBITS(PNT2)
;;#GW#↓ 5-11-72 DCS (3-4) SEE JUST ABOVE
	JUMPL	C,NOWLUP	;DON'T DO IT IF MARKED
	TRNE	TBITS2,STRING
	 JRST	 NOWSTR
	PUSH	P,$VAL(PNT2)
	JRST	NOWLUP
NOWSTR:	PUSH	SP,$PNAME(PNT2)
	PUSH	SP,$PNAME+1(PNT2)
	JRST	NOWLUP
NA:	HLRZ	TEMP,$ADR(PNT)	;Get the address of the procedure from its
;;#GW#2↓ 5-11-72 DCS (4-4) SEE JUST ABOVE
	JUMPL	C,NS
	PUSHJ	P,(TEMP)	; Semblk, and call it for its value
;;#GW#↓ SEE JUST ABOVE
	MOVEM	1,SCNVAL	;Store resultant value where CONINS will expect
	TRNN	TBITS,STRING	; it, along with the desired type bits from
	 JRST	 NS		; the procedure's type.
	HRRZ	TEMP,-1(SP)	;Align Strings to full-word boundary by
	JUMPE	TEMP,NLS	; concatenating 0 (if non-null)
	PUSH	SP,[1]
	PUSH	SP,[POINT 7,[0]]
	PUSHJ	P,CAT
	SOS	-1(SP)		; then remove the extra character from the end
NLS:	POP	SP,PNAME+1
	POP	SP,PNAME
NS:	EXCH	SP,STPSAV	;PUT OLD STACKS BACK
	MOVSS	POVTAB+6
	ANDI	TBITS,-1≠<PROCED!FORWRD!INPROG>
	TLO	TBITS,CNST
	MOVEM	TBITS,BITS
	PUSHJ	P,CONINS
	POP	P,FTRPRM	;Back the Qstack up to value at start of call
	JRST	MRKDN		;This just records the result
;;#  #
	
NC:
GLOC <
	TLZN	SBITS,LPFREE	;A MESSAGE PROCEDURE ??
	JRST	CAL01		;NO
	MOVEM	SBITS,$SBITS(PNT)
	HRROI	B,$PNAME+1(PNT)	;PRINT NAME.
	POP	B,PNAME+1
	POP	B,PNAME		;AND READY TO
	PUSHJ	P,STRINS	;MAKE A CONSTANT.
	PUSHJ	P,GETAD		;GET BITS.
	GENMOV	(STACK,0)	;PISS ON IT.
	SOS 	SDEPTH
	SOS	SDEPTH		;SINCE TYPPRO WILL ADD 2 TO SDEPTH
	MOVEI	TBITS2,STRING	;CROCK -- THIS IS THE TYPE OF MESS.
;#IK#↓ 7-5-72 RHT PREVENT DL FLD OF SBITS FROM CAUSING MUCH BAD DISPLAY LOADING
	MOVEI	SBITS2,0	;RENDER SBITS2 HARMLESS (FOR FUTURE EXCHIN &STACK)
	JRST	MRKCAL		;AND FINISH OUT
CAL01:
>;GLOC

	PUSHJ	P,STORIX	;INTERNALS.AND EXTERNALS ARE NOW STORED.
	TRNE	TBITS,FORTRAN	;IF FORTRAN CALL
	 JRST	 FTRCAL		;GO ISSUE IT.
	MOVEI	D,1		;PREPARE TO STORE R1
	TRNE	TBITS,INTEGR!FLOTNG
	 PUSHJ	 P,STORZ	;DO IT IF TYPED ARITH PROC.
	TLNN	TBITS,BILTIN	;UNLESS BUILTIN PROC.
	 PUSHJ	 P,ALLSTO	;STORE THE REST.

DPUSHJ:

GAG <;FIND BILTIN PROCEDURE ADDRESSES DIRECTLY FROM SYMBOL TABLE
	TLNE	TBITS,OWN		;RUNTIME ROUTINE?
	 JRST	 BLTCAL			; YES, CALL BILTIN PROC
>;GAG
;;  BY JRL 9-20-72  MAKE SURE PROCEDURE FORMALS CAN BE ACCESSED
	GENMOV	(ACCESS,0)		;MAKE SURE WE HAVE ACCESS
;;  BY JRL 
	MOVE	A,[PUSHJ RP,NOUSAC]	;PUSHJ PDP,ROUTINE.
	TLNE	FF,LPPROG		;A FOREACH IN PROGRESS AND
	TLNN	TBITS,MPBIND		;A MATCHING PROCEDURE?
	PUSHJ	P,EMITER
MVCAL:	MOVOPS			;PROC SEMANTICS TO SECOND GROUP.
;BUG TRAP
	SKIPN	B,-1(P)		;SAVED FRTPRM POINTER.
	ERR	<DRYROT AT DPUSHJ>

QQQLRX: QTAKE	(FTRPRM)	;POP OFF A GOODY
	 JRST	 LLQRLX
	PUSH	P,B
	MOVE	PNT,A
	PUSHJ	P,REMOP		;REMOP IT
	POP	P,B
	JRST	QQQLRX		;GET ALL OF THEM
LLQRLX:
	MOVEI	D,1		;IF ARITH TYPE, RESULTS IN R1
	JRST	MRKCAL		;FINISH OUT, MARK RESULT

;;#HT# 6-14-72 DCS (1-2) SAVE ALL ACS, ALSO RF, WHEN FORTRAN SUBROUTINE
FTRCAL:	TRNN	TBITS2,ALTYPS≠(FORTRAN!PROCED);TYPED PROCEDURE?
	 JRST	 [PUSHJ	P,ALLSTO
		  HRLI	C,RF	;NO, STORE ALL ACS, SAVE F
		  EMIT (<PUSH RP,NOUSAC!USADDR!NORLC>)
		  JRST  CALFTR]
;;RW#HT# (1-2)
	MOVEI	D,0		;ASSURE R0 FREE
	PUSHJ	P,STORZ
	MOVEI	D,1		;AND R1
	PUSHJ	P,STORZ
CALFTR:	EMIT	(<JSA 16,NOUSAC>) ;JSA 16,ROUTINE
	MOVOPS			;SEMANTICS OF PROC TO 2D GROUP
; ***** BUG TRAP
	SKIPN	B,-1(P)		;FTRPRM POINTER
	 ERR	 <DRYROT -- FTRCAL> ;WASN'T A POINTER
ARGLUP:	QTAKE	(FTRPRM)	;GET NEXT ADCON DESCRIPTOR
	 JRST	 LLLQRX		; DONE WITH ADCONS
	PUSH	P,B		;SAVE UPDATED POINTER
	JUMPL	A,ARGFIX	;MOVEI,HRLI,MOVEM WAS DONE, FIX IT UP
	PUSH	P,A		;SAVE ADCON POINTER
	HLRZ	PNT,%TLINK(A)	;SEMANTICS OF AD BEING CONNED
	HLLZ	A,$ADR(A)	;TYPE BITS, ALREADY IN AC FIELD POS
	PUSHJ	P,GETAD	;GET DESCRIPTION
	OR	A,[JUMP NOUSAC]
	PUSHJ	P,EMITER	;JUMP TYP,ADDR
	PUSHJ	P,REMOP		;GET RID OF IT
	POP	P,A		;GET POINTER BACK
	HRRZ	LPSA,A		;→SEMANTICS OF ADCON
	PUSHJ	P,URGADR	;REMOVE FROM ADRTAB
	FREBLK			;RETURN ADCON BLOCK TO FREE STORAGE

	POP	P,B		;UPDATED STACK PTR
	JRST	ARGLUP		;GET ALL OF THEM
ARGFIX:	HRL	B,A		;FIXUP
	HRR	B,PCNT		;ADDRESS
	PUSHJ	P,FBOUT		;OUTPUT FIXUP
	EMIT	(< JUMP  NOADDR+NOUSAC>) ;ADDR ADDED LATER
	POP	P,B		;UPDATED QSTACK PTR
	JRST	ARGLUP		;RETURN

LLLQRX:	MOVEI	D,0		;IF TYPED, RESULT IN 0
MRKCAL: 
	HLRZ	TEMP,(P)	;NUMBER OF SDEPTH ADJUST WORDS
	SUB	TEMP,SDEPTH	;ADJUST
	MOVNM	TEMP,SDEPTH
	HRRZ	TEMP,(P)	;SIMILAR ADEPTH STUFF
	SUB	TEMP,ADEPTH
	MOVNM	TEMP,ADEPTH
	POP	P,TEMP		;TOSS OUT
	POP	P,FTRPRM	;RESTORE OLD QSTACK PTR
	SETZM	PNT
	TLNE	FF,LPPROG	;A FOREACH IN PROGRESS?
	TLNN	TBITS2,MPBIND	;THIS A MATCHING PROCEDURE CALL?
	JRST	ISTYPD		;NO
	MOVE	TEMP,%MPRO	;MESSAGE PROCEDURE TOKEN
	MOVEM	TEMP,PARRIG	;TELL THE PARSER
	MOVE	PNT,PNT2	;TO BE REPLACED IN PARSE STACK
	JRST	MRKDN		;FINI
ISTYPD:
;;#HT# 6-14-72 DCS (2-2) RESTORE SAVED RF REGISTER
	TRNE	TBITS2,ALTYPS≠(FORTRAN!PROCED)	;TYPED PROC?
	 JRST	 TYPRC		;YES
	TRNN	TBITS2,FORTRAN	;NO, FORTRAN PROCEDURE?
	 JRST	 MRKDN		;NO, QUIT
	HRLI	C,RF		;YES, UNTYPED F4, RESTORE RF
	EMIT	(<POP RP,NOUSAC!USADDR!NORLC>)
	JRST 	MRKDN
;;#HT# (2-2)
TYPRC:	GENMOV	(MARK,EXCHIN)	;TEMP INDICATES TYPE OF PROCEDURE
	MOVEI	TEMP,2		;IF A STRING PROC, INCREASE
;;#HS# JRL 6-14-72 STRING ITEMVAR PROC. IS NOT A STRING PROC.
	TRNE	TBITS,ITMVAR!ITEM;STRING ITEMVAR PROC. NOT REALLY STRING
	JRST	MRKDN
;;#HS#
	TRNE	TBITS,STRING	; STRING STACK DEPTH
	ADDM	TEMP,SDEPTH
MRKDN:	MOVEM	PNT,GENRIG	;ONE OF THESE
	MOVEM	PNT,GENRIG+1	;WILL COVER IT
	POPJ	P,

GAG <; LOOK UP ADDR OF BILTIN PROC IF NOT ALREADY THERE
BLTCAL:	HRL	C,$ADR(PNT)	;SEE IF IT'S THERE ALREADY
	TLNE	C,-1		; IS IT?
	 JRST	 PSJBLT		; YES, CALL ROUTINE
	MOVE	LPSA,PNT	;SET UP FOR RAD50
	PUSHJ	P,RAD50		;CONVERT
	MOVEI	TEMP,10/4
	DPB	TEMP,[POINT 4,A,3] ;ASSUME NON-EXTERNAL FOR GAG
	PUSH	P,[RADIX50 0,SAIL];PROGRAM NAME
	PUSH	P,[RADIX50 14,GOGOL];BLOCK NAME
	PUSH	P,A		;DESIRED SYMBOL
	PUSHJ	P,LUKSYM
	 ERR	 (<PROCEDURE NOT LOADED>,1) ;IMPOSSIBLE!!!
;VALUE RETURNED IN LH(C)
	HLRM	C,$ADR(PNT)	;WON'T HAVE TO LOOK TWICE
PSJBLT:	EMIT	<PUSHJ RP,NOUSAC+USADDR>
	JRST	MVCAL		;FINISH UP
>;GAG

SUBTTL	Return Statement
COMMENT ⊗RESULT -- Return (with or without value) from Procedure⊗

DSCR RESULTS, RESLT1
PRO RESULT RESLT1
DES 
at RT0:	  SG ;  →  S ;		EXEC RESLT1      ¬S9
   EE2:	RETURN ( @E )  →  S	EXEC RESULTS SCAN  ¬S9
⊗

;  SETUP PROCEDURE FOR BOTH KINDS OF RETURNS
RETSET:	MOVE	PNT2,TPROC		;CAN ONLY RETURN FROM INNERMOST PROC
	PUSHJ	P,GETAD2		;SEMANTICS OF IT
	TLNE	TBITS2,MPBIND		;MATCHING PROCS ARE NO-NO'S
	ERR	<RETURN NOT VALID WITHIN MATCHING PROC.>,1
	MOVSI	TEMP,RTNDON		;MARK RETURN DONE THIS PROC
	IORM	TEMP,$SBITS(PNT2)	;IN SEMBLK
	EXCH	TEMP,(P)		;≥0 IN TOP OF STACK, RETN TO TEMP
	JRST	(TEMP)			;RETURN

↑RESLT1: PUSHJ	P,RETSET		;GET SEMANTICS OF THIS PROC TO 2D GROUP
	TRNE	TBITS2,ALTYPS≠PROCED	;CANNOT BE TYPED
	 ERR	 <TYPED PROCEDURE MUST RETURN A VALUE>
	JRST	JMPOU1			;GENERATE THE ARRAY RELEASES AND EXIT JUMP

↑RESULTS:PUSHJ	P,RETSET
	TRNN	TBITS2,ALTYPS≠PROCED	;THIS MUST BE TYPED
	 ERR	 <UNTYPED PROCEDURE MUST NOT RETURN A VALUE>,1
;;#HQ#↓ 6-13-72 DCS ITEMVARS ARE ITEMVARS, NOT THEIR DATUMS!!!!!!!
	TRNN	TBITS2,ITEM!ITMVAR	;PRECLUDE DATUMS
	TRNN	TBITS2,STRING		;STRING VALUE RETURNED?
	 JRST	 ARRET			; NO, ARITHMETIC VALUE

STRRET:	LEFT	PNT2,%TLINK,LPSERR 	; LPSA → 2D PROCEDURE BLOCK
	HRRZ	A,$NPRMS(LPSA)		;#PARAMS(STRING)
	GETSEM	(1)			;GET SEMANTICS OF RESULT
	TLNN	TBITS2,RECURS		;IF NOT RECURSIVE PROCEDURE
	TLNE	SBITS,STTEMP		; AND NOT A TEMP RESULT, THEN CAN
	 JRST	 RTSTR1			; DO THE SUB HERE, ELSE JUST STACK
	TRNE	TBITS,STRING		;IF RESULT IS STRING VALUE FORMAL,
	TLNN	TBITS,VALUE		; AND IS FIRST STRING PARAM,
	 JRST	 NOTEZY			; CAN REPLACE SUB/PUSH BY DIFFERENT SUB
	HRRZ	TEMP,$NPRMS(LPSA)	;# STRING WORDS
	SUBI	TEMP,1			;-1 TO MATCH HOPEFUL CANDIDATE
	CAME	TEMP,$ADR(PNT)		;THIS THE FIRST STRING PARAM?
	 JRST	 NOTEZY			; NO
	SUBI	A,2			;REMOVE ONE FEWER STRINGS (LEAVE ANSWER)
	PUSHJ	P,MARKME		;NOW A TEMP STRING-TYPE RESULT
	MOVEM	PNT,GENLEF+1		;WILL BE PICKED UP LATER
NOTEZY:	JUMPE	A,RTSET			;IF NOTHING TO SUBTRACT, DON'T DO IT

	MOVN	TEMP,A			;UPDATE SDEPTH TO REFLECT THE COMING SUB
	ADDM	TEMP,SDEPTH		; SO THAT REFERENCES TO PARAMS ARE RIGHT
	HRLS	A			; IN SUBSEQUENT STACKING OPERATION
	PUSHJ	P,CREINT		;FOR SUB
	EMIT	<SUB RSP,NOUSAC> 	;SUB RSP,[XWD #,#]
	PUSHJ	P,REMOP			;REMOVE CONSTANT FROM USE
RTSET:	SETOM	(P)			;<0 IN TOP OF STACK, MARK THIS CASE

RTSTRG:	GETSEM	(1)			;SEMANTICS OF RESULT
RTSTR1:	MOVEI	B,STRING
	GENMOV	(STACK,INSIST)		;MAKE SURE RESULT IS STACKED
	SETZM	SDEPTH			;DON'T RECORD EFFECTS OF THIS PUSH
	JRST	JMPOU1			;RETURN

ARRET:	GETSEM  (1)			;ARG.
	MOVEI	D,1			;RESULTS TO AC 1
	HRRZ	B,TBITS2		;TYPE CONVERSION IF NECESSARY
;; #JT# BY JRL 10-21-72 COPY SET TO BE RETURNED
LEP <
	TRNN	TBITS,ITMVAR
	TRNN	TBITS,SET
	JRST	ARRET2
	PUSH	P,PNT
	GENMOV	(STACK,INSIST)
	MOVEI	A,0
	PUSHJ	P,CREINT
	GENMOV	(STACK,GETD)
	LPCALL  (CATLST)
	MOVNI	A,2
	ADDM	A,ADEPTH
	HRLI	C,1
	EMIT	<POP RP,NOUSAC!USADDR!NORLC>
	POP	P,PNT
	PUSHJ	P,GETAD
	JRST	ARRET3
>;LEP
;; #JT#
ARRET2:	GENMOV	(GET,INSIST!SPAC!POSIT) ;LOAD THE AC
ARRET3:	PUSHJ	P,REMOP

JMPOUT:	PUSHJ	P,CLEARA		;FORGET ABOUT  AC  1
JMPOU1:	EXCHOP				;GET PROC SEMANTICS BACK FROM HIDING
RETJMP:	PUSHJ	P,GOSTO			;DUMP EVERYTHING, BUT REMEMBER WHERE
	MOVE	B,LEVEL			;CURRENT LEVEL
	SUBI 	B,1			;DO NOT ENCOUNTER PROCEDURE
	PUSH	P,PNT
	PUSHJ	P,TRAGO			;GUARANTEE ACCESS
	POP	P,PNT			;THE WORK IS DONE.
	MOVE	A,[JRST NOUSAC+USADDR]	;THE JUMP OUT
	HRR	C,PCNT			;PUT CURRENT IN CHAIN
	POP	P,TEMP			;IF <0, NON-REC, NON-TEMP STRING RESULT
	JUMPL	TEMP,OTHJMP		; JUMP PAST SUB/PUSH PAIR IN EXIT CODE
	HRL	C,$ACNO(PNT)		;THIS IS WHERE PROC. RET. FIXUP IS STORED.
	HRRM	C,$ACNO(PNT)		;CHAIN THE FIXUP.
	JRST	EMITER			;EMIT JUMP
OTHJMP:	HLL	C,$ADR(PNT)		;OTHER JUMP ADDR
	HRLM	C,$ADR(PNT)		;CHAIN
	JRST	EMITER			;DO IT

BEND	PROCED