Google
 

Trailing-Edge - PDP-10 Archives - -
There are no other files named in the archive.
COMMENT    VALID 00047 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00005 00002	HISTORY
C00019 00003	For-Loop, Case Statement Variables
C00021 00004	  Descriptions of For Loop Constructs, Bit Definitions
C00026 00005	  FOR, DO, WHILE, NEEDNEXT Generators
C00030 00006
C00036 00007
C00039 00008	    (continued),  NEXT, DONE, CONTINUE
C00045 00009		
C00049 00010
C00053 00011
C00060 00012
C00062 00013	ENTLAB, TRA -- generators for label placement, Go To statements
C00065 00014	  TRAGO -- go-to-solver -- used also by RETURN code
C00068 00015
C00072 00016	CASSTR, CASEMT, CASEND, CASE1, ... -- Case Statement Generators
C00076 00017	^CASE1:	GETSEM	(1)		CASEX SEMANTICS.
C00081 00018	^CASE3:	SOSL	B,THISE		THE TYPE OF EXPRESSION.
C00086 00019	PROCEDURE Structure Descriptions, Data Declarations
C00090 00020	  PRDEC -- When Name is Seen
C00101 00021	  ENDPR -- when params have been seen
C00110 00022	 ENDRC -- MAIN RECORD CLASS EXEC
C00124 00023	  PRUP -- When Procedure Body's Finished -- Entry, Exit, Fixups, etc.
C00128 00024
C00130 00025
C00138 00026
C00142 00027	    RESTOR, SAVIT,MKESMT,SETF -- Subroutines for Above
C00149 00028		NOW THAT AC IS STATIC LINK, MIGHT AS WELL REMEMBER THAT FACT
C00151 00029	  TWPR1, TWPR2 -- Procedure Syntax  Twiddlers
C00152 00030	RDYCAL -- Prepare to Call Procedure
C00157 00031	  Describe CALARG
C00159 00032	  CALARG -- Pass a Parameter
C00168 00033
C00171 00034	MPPARM:				BINDING ITEMVAR PARAMETER
C00180 00035
C00186 00036	    ADRINS -- Subrt for Above -- Prepare an Address Constant (Semblk)
C00190 00037
C00193 00038
C00196 00039	  ISUCAL -- Call the Procedure, Mark Resultant Type, etc.
C00206 00040
C00211 00041	ARGFIX:
C00216 00042	RESULT -- Return (with or without value) from Procedure
C00221 00043
C00224 00044	DFVPV -- exec for default param values 
C00225 00045	 CLNSET
C00226 00046	DSCR	Execs for PRINT and CPRINT statements.
C00232 00047		BEND	PROCED
C00233 ENDMK
C;
COMMENT HISTORY
AUTHOR,REASON
021  102100000046  ;


COMMENT 
VERSION 17-1(38) 9-20-75 BY JFR #VD P.6  STR[1 STEP 1 UNTIL N] GAVE ILL MEM REF
VERSION 17-1(37) 2-1-75 BY JFR BAIL INTERFERRENCE WITH RECORDS, P.20
VERSION 17-1(36) 1-22-75 BY RHT BUG #TV# MAKE CLASS OF PNTVAR ARGS TO BUILTINS ANYCLASS
VERSION 17-1(35) 10-26-74 BY RHT BUG #TO# FUNNY TYPED BILTIN PROCEDURES
VERSION 17-1(34) 9-26-74 BY JFR INSERT TWO  JSFIX'S  WHICH WERE OMITTED ON P. 27
VERSION 17-1(33) 9-19-74 BY JFR INSTALL BAIL
VERSION 17-1(32) 8-3-74 BY RHT FEAT BN RECORD CLASSID IN ASCIZ
VERSION 17-1(31) 7-7-74 BY RHT MANY EDITS FOR RECGC
VERSION 17-1(30) 7-7-74 
VERSION 17-1(29) 7-7-74 
VERSION 17-1(28) 6-2-74 BY RHT MAKE EXTERNAL RECORD CLASSES WORK BETTER
VERSION 17-1(27) 5-29-74 BY RHT BUG #SH# NEEDED NOUSAC WHEN PUT OUT PDA WORD
VERSION 17-1(26) 5-28-74 BY RHT BUG #SD# NEEDED MUCH HAIR WHEN EXTERNAL PROC REDECLARED AS INT
VERSION 17-1(25) 4-12-74 BY RHT ADD RECORD CRUFT
VERSION 17-1(24) 4-12-74 
VERSION 17-1(23) 4-12-74 
VERSION 17-1(22) 4-12-74 
VERSION 17-1(21) 4-12-74 
VERSION 17-1(20) 1-31-74 BY RHT BUG #QX# MUST KEEP ADEPTH HONEST IN BUG FIX JK
VERSION 17-1(19) 1-11-74 BY JRL CMU CHANGE DON'T BARF AT EXTERNAL PROC DECS INSIDE SIMPLE PROC
VERSION 17-1(18) 1-11-74 
VERSION 17-1(17) 1-11-74 
VERSION 17-1(16) 1-8-74 BY RHT BUG #QH# FIX NEEDNEXT FOREACH PROBLEM
VERSION 17-1(15) 1-8-74 
VERSION 17-1(14) 1-8-74 
VERSION 17-1(13) 1-7-74 BY JRL BUG #QG# ALLOW MATCHING PROCEDURES WITH NO PARAMETERS
VERSION 17-1(12) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(11) 10-18-73 BY RHT FEAT %AE% PASSING TYPED ITEMVARS TO UNTYPED ONES
VERSION 17-1(10) 8-19-73 BY RHT BUG #NU# TRAGO NEEDED SPECIAL TEST FOR KILL SETS
VERSION 17-1(9) 8-19-73 BY RHT BUG #NT# NEED AN ALLSTO SOONER IN PRDEC
VERSION 17-1(8) 8-16-73 BY JRL REMOVE REFERENCES TO LEAPSW
VERSION 17-1(7) 8-14-73 BY JRL FIX BAD FIX TO BUG NP
VERSION 17-1(6) 8-14-73 
VERSION 17-1(5) 8-13-73 BY RHT ARRANGE FOR ITEMVAR PARAMS TO DEFAULT PROPERLY
VERSION 17-1(4) 8-12-73 BY JRL BUG #NP# DRYROT IN MATCHING PROCEDURE WITHOUT ? PARAMETERS
VERSION 17-1(3) 7-30-73 BY RHT BUG #NI# FIXUP FOR CONTINUE IN A DO... UNTIL...
VERSION 17-1(2) 7-27-73 BY RHT BUG #NH# ADEPTH PROBLEM FOR DEFAULTS
VERSION 17-1(1) 7-27-73 
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION 17 ****
VERSION 16-2(63) 7-9-73 BY JRL REMOVE ALL REFERENCES TO PATSW
VERSION 16-2(62) 6-29-73 BY RHT BUG #MY# FIX A TYPO
VERSION 16-2(61) 6-28-73 BY RHT BUGS #MX# & #MY#
VERSION 16-2(60) 6-28-73 
VERSION 16-2(59) 6-28-73 
VERSION 16-2(58) 6-28-73 
VERSION 16-2(57) 6-28-73 BY JRL BUG #MA# CONCHK SHOULD SAVE FF OVER ITS CALL
VERSION 16-2(56) 6-27-73 BY RHT BUG #MV# NEEDED AN ACCESS BEFORE A PUT
VERSION 16-2(55) 5-15-73 BY JRL BUG #MJ# FOR CODE REMOPING WRONG SEMBLK
VERSION 16-2(54) 5-12-73 BY RHT BUG #MH# DRYROT IN EPNT FROM LOOP CODE
VERSION 16-2(53) 4-25-73 BY JRL BUG #ME# DRYROT IN ENDPR FOR FORWARD MATCHING PROCEDURE
VERSION 16-2(52) 4-25-73 
VERSION 16-2(51) 3-22-73 BY RHT ADD DEFAULT PARAM VALUES
VERSION 16-2(50) 3-20-73 BY RHT ADD CODE FOR DEFAULT PARAM VALUES (ISUCAL)
VERSION 16-2(49) 3-13-73 BY RHT BUG #LQ# FWRD PROC PD SHOULD BE USED WHEN DECLARE THE PROC
VERSION 16-2(48) 3-13-73 BY JRL REMOVE REFERENCES TO WOM,SLS,GAG,NODIS
VERSION 16-2(47) 2-26-73 
VERSION 16-2(46) 2-14-73 BY JRL BUG #LL# PROTECTION OF AC CONTAINING UNBOUND IN MATCH PROC
VERSION 16-2(45) 2-12-73 BY JRL RETURN VAL OF MP NOW SAVED IN XX AREA
VERSION 16-2(44) 2-12-73 BY JRL BUG #LK# GET RID OF DRYROT AT BPOP AT END OF MATCH PROC
VERSION 16-2(43) 2-9-73 BY JRL MAKE AN ITEM PROCEDURE 
VERSION 16-2(42) 2-9-73 BY JRL BUG #LJ# LEAP SHOULD STACK EVERYTHING BEFORE PROCEDURE CALL
VERSION 16-2(41) 2-9-73 
VERSION 16-2(40) 2-9-73 
VERSION 16-2(39) 2-7-73 
VERSION 16-2(38) 2-5-73 BY JRL MOD MP'S FOR SPROUT
VERSION 16-2(37) 1-28-73 BY JRL ALLOW ?,BIND TO MPPARS OUTSIDE OF FOREACH
VERSION 16-2(36) 1-23-73 BY JRL REMOVE RESTRICTION ABOUT MP WITH SAME ACTUAL ? PAR TWICE
VERSION 16-2(35) 11-30-72 BY RHT MODIFY LOPSS TO CALL EPOLL
VERSION 16-2(34) 11-28-72 BY RHT INSERT EXEC FOR CLEANUP
VERSION 16-2(33) 11-13-72 BY RHT BUG #KD# RECURSIVE CORTMP IN ADRINS
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.


;;#NI# RHT 30-JULY-73 NEED A FIXUP FOR CONTINUES
^CNFXP:	MOVE	SP,FRBLK	;
	HLLZ	B,$ACNO(SP)	;FIXUP TO THE TEST
	JUMPE	B,.+4		;NO FIXUP
	PUSHJ	P,ALLSTO	;
	HRR	B,PCNT		;YES FIXUP
	PUSHJ	P,FBOUT		;
	POPJ	P,
;;#NI#
^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"
;;#VD# JFR 9-20-75
	CAIGE	B,4		;4TO, 5FOR
	SKIPN	LENCNT		;NEQ 0 IMPLIES SUBSTRINGING
	JRST	.+2
	ERR	<Substringing uses TO or FOR.>,1,CPOPJ
;;#VD# ^
	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
;; \UR#11\ JRL GIVE REASONABLE ERROR MESSAGE FOR MISSING STEP AMOUNT
	SKIPN	$DATA4(TEMP)	;ANY SEMANTICS YET?
        JRST    [ ERR <MISSING STEP AMOUNT. WILL ASSUME 1.>,1
		  PUSHJ P,GETINDX ; STORE VAR AND START
		  MOVEI A,1	; DEFAULT STEP IS 1
		  PUSHJ P,CREINT
		  HRRZM PNT,GENLEF+1
		  MOVE TEMP,FRBLK
		  JRST .+1]
;; \UR#11\ JRL - END OF STEP FIX
	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.


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,
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.
	HLRZ	D,$ADR(SP)	;PICK UP AC FOR COROUT OR JSP
	TRNE	C,COROUT!JSPDON	;IF WE HAVE ONE
	HRROS	ACKTAB(D)	;PROTECT IT
	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.
	CAIE	D,0		;DID WE PROTECT SOMEONE?
	HRRZS	ACKTAB(D)	;YES -- WITHDRAW PROTECTION
	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)
;;#MV# RHT USE TO BE A GENMOV PUT ONLY
	GENMOV	(ACCESS,EXCHIN)	;MARK FOR STORE -- ACTUALLY STORE IF THE
				;THING WAS INDXED.
	GENMOV	(PUT,0)		;
;;#MV#
	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
;;#MJ SAVE CONVERTED SEMBLK FOR LATER REMOP
	MOVEM	PNT,GENLEF+1
;;#GU#
NOWOK:	TRNE	C,INCNST	;IS INCREMENT CONSTANT ?
	JRST	FRCNST		;YES -- DO OTHER THINGS.

PRINTX CHANGE HERE FOR LONG INTEGERS
	HRL	C,D
	TRNE	TBITS,DBLPRC
	 IORI	FF,DBL
	PUSHJ	P,GETAN0	;WE WOULD OTHERWISE CLOBBER PROTECTED AC.
	MOVE	A,[MOVE USADDR!NORLC]	;MOVE AC2,AC
	TRNE	TBITS,DBLPRC
	 HRLI	A,(<DMOVE>)
	EMIT			;;(MOVE USADDR!NORLC)
	MOVSI	A,(<SUB>)	;SUBTRACT INDEX-LIMIT
	TRNN	TBITS,INTEGR	;CORRECT ?
	MOVSI	A,(<FSBR>)
	TRNE	TBITS,DBLPRC
	 MOVSI	A,(<DFSB>)
	PUSHJ	P,EMITER	;AC NOW HAS INDEX - LIMIT.
	MOVS	PNT,$DATA4(SP)	;INCREMENT.
	EMIT	(SKIPL NOUSAC)	;SKIPL INCREMENT
	HRL	C,D		;GET AC #
	MOVE	A,[MOVN USADDR!NORLC]	;MOVN AC,AC
	TRNE	TBITS,DBLPRC
	 HRLI	A,(<DMOVN>)
	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 LEQ
	TLNN	C,INPOS		;ASSUMPTION CORRECT?
	HRRI	C,5		;CODE FOR GEQ
	TRNE	TBITS,DBLPRC
	 JRST	[EMIT	(CAMN)	;1ST INSTR ALWAYS CAMN
		XORI	C,4	;2ND IS REVERSE OF ORIGINAL
		IORI	FF,FXTWO;ON 2ND WORD
		AOJA	D,.+1]	;AND 2ND AC
	MOVE	A,[CAM USCOND]	;THE SUPER COMPARE INSTRUCTION.
	PUSHJ	P,EMITER
	TRNE	TBITS,DBLPRC
	 SOJA	D,[XORI	C,4	;3RD IS ORIGINAL ON ORIG AC
		TRZ	FF,FXTWO
		EMIT
		JRST	.+1]
	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 ?
;;#QH# HACK TO FIX NEEDNEXT FOREACHES
	PUSHJ 	P, [
		TRNN	C,FRCHS		;KLUGE SINCE FOREACH IS SPECIAL
		JRST	CRCAL		;NOT FOREACH, JUST COROUTINE CALL
		PUSHJ	P,CRCAL		;CALL IT.
		HLRZ	PNT,$VAL2(SP)	;
		JUMPE	PNT,CPOPJ	;NO TEMP CELL
		HLRZ	D,$ADR(SP)
		MOVE	A,[ MOVEM ]
		JRST	EMITER ]
;;#QH#
	TRNN	C,COROUT	;IF ONLY A FOR LIST, THEN
	PUSHJ	P,FLSCAL	;CALL IT.
ENDIT:
	TRNE	C,FRCHS		;FOREACH ?
	JRST	[PUSH	P,C
		 LPCALL (FRLOOP)
		 POP	P,C
		 JRST LSTTST]
	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.
;;#MH# ! RHT 5-12-73 WAS GETAD BUT REALLY NEED ACCESS
	GENMOV	(ACCESS,GETD)
PRINTX CHANGE HERE FOR LONG INTEGERS
	MOVSI	A,(<ADD>)
	TRNN	TBITS,INTEGR	;IS THIS CORRECT ?
	MOVSI	A,(<FADR>)
	TRNE	TBITS,DBLPRC
	 MOVSI	A,(<DFAD>)
	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.
	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

	POPJ	P,

CRCAL:	
	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,


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.
	SKIPLE	POLINT		;DO WE WANT POLLS INSERTED?
	PUSHJ	P,EPOLL		;YES -- CALL TO SAVE ALL REGS
	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.

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
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)
	PUSHJ	P,FBOUT		;FIXUP TO JUMP OUT.
DONON:	HLLZ	B,$DATA3(SP)	;"DONE" FIXUP
	JUMPE	B,ALDON		;THESE HAVE FINISHED.
;;#TD# ! be sure dont do a done & leave loop with stuff inac
;;	PUSHJ	P,ALLSTO
;;NOTE: COULDN'T GET THE BUG TO HAPPEN
	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.
	MOVE	TEMP,$DATA2(SP)
	TRO	TEMP,DONDON
	TRZ	TEMP,NOJMPS
	MOVEM	TEMP,$DATA2(SP)
	EMIT	(JRST NOUSAC!USADDR)
DDPOPJ:	POPJ	P,

^DNEXT:				;HERE ON "NEXT" CONSTRUCT
	PUSHJ	P,STORQQ
NEXTXX:	TRZ	C,NOJMPS
	HRRM	C,$DATA2(SP)

	TRNE	C,COROUT	;ONLY ALLOW IF COROUTINE
	JRST	CTCOR		;GO CALL THE COROUTINE

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

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,

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.

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



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.
	SETZM	BK		;ZERO PLACE KEEPERS
	SETZM	BL;
	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 ????

	JRST	[
		MOVE	TEMP,(SBITS2)	;SEMANTICS
		MOVE	TEMP,$DATA2(TEMP); GOOD BITS
		TRNN	TEMP,COROUT!FLIST!FRCHS
	   	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
;;\UR#33\ JRL (8-15-78) LH OF PNT <0 MEANS BLOCK HAS DECLARATIONS
;;       THAT IS ENOUGHT TO COUNT IT 
;; \UR#34\ JRL (9-14-78) Don't put out call to BEXIT if simple
;;    procedure. 
	SKIPE	SIMPSW
 	 JRST	LGOUP	; COUNT IT, BUT NO BEXIT
;;
;;#NU# RHT 8-19-73 NEEDED BETTER CHECK FOR KILL SET
;;	HRRZ	TBITS,$ACNO(PNT)		;CHECK SPECIAL FOR KILL SET
;;	JUMPN	TBITS,TGI			;IF SO, MUST BEXIT
;;#NU#
;;	MOVE	TBITS,$VAL(PNT)
;;#SW#
NOREC <
;;	TDNN	TBITS,[XWD SBSCRP,SET]		;ALLOCATIONS?
;;
>;NOREC
REC <
;;	TDNN	TBITS,[XWD SBSCRP,SET!PNTVAR]	;ALLOCATIONS??
						;ALSO CHECK FOR RECORDS
>;REC
;;	JRST	LGOUP				;NO
;; \UR#33\ SEE ABOVE
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
;; #MY# (1 OF 2) RHT BE SURE PD SEMBLK WILL APPLY
	SKIPN	PNT,PNT2			;PICK UP PDA SEMBK
	ERR	<YOU CANNOT DO THIS GO TO>,1	;
;; #MY# (1 OF 2) -- USED TO BE A SIMPLE MOVE PNT,PNT2
	EMIT	(<HRRZI LPSA,NOUSAC!JSFIX>)	;HRRZI LPSA,PDAOFLABEL
;;#MY# ! (2 OOF 2) RHT ALSO FIX A TYPO IN NEXT LINE
	LDB	C,[POINT 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,







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 drarrow  CASEX		CASSTR
CASEX S drarrow  CASEX		CASEMT
CASEX [ E ] S ; drarrow  CASEX		CASEM1
CASEX S END drarrow  S			CASEMT CASEND
CASEX [ E ] S END drarrow  S		CASEM1 CASEN1
CASEX ( drarrow CASEE			CASE1	;EXPRESSION CASE STATEMENT
CASEE E , drarrow  CASEE		CASE2	; "
CASEE E ) drarrow  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 --(lh):	-1 explicit numbering
		+1 implicit numbering
		 0 not known yet
	(rh):	 0 this individual case has not been explicitly numbered
		0 number(s) have appeared for this case


;;%DV% JFR 1-4-77 EXTENSIVE MODS FOR 'ELSE' IN CASE STMT
^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!REM,INTEGR)
	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.

;;UR#20 PDR (1 of 3) 4/27/78 save ac num for cserr err msg
	HRRM	D,$ACNO(LPSA)

	EMIT	<CAIL NOADDR>	;LOWER BOUND TEST
	EMIT	<CAIL NOADDR>	;UPPER BOUND TEST
	EMIT	<JRST NOUSAC!NOADDR>	;JUMP TO CSERR OR "ELSE"
	MOVSS	D
	EMIT	<JRST @USX+NOADDR+NOUSAC>
	QPUSH	(CASTAK,PCNT)	;ASSUME:  CASE# 0,,PCNT
	POPJ	P,
^CASE1:	GETSEM	(1)		;CASEX SEMANTICS.

;;UR#20 PDR (3 of 3) make ac# available for cserr err msg. Don't
;;   allocate an ac for case expr result here...it was done in CASSTR
;;   2 instrs were removed here

	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.
	HRRZ	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:


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

^CASEMT:			;HERE AT END OF STATEMENT OR EXPRESSION
	GETSEM	(2)		;SEMANTICS OF CASEX
	MOVSI	B,1
	SKIPN	TEMP,$VAL2(PNT)	;STATUS OF NUMBERING
	 MOVEM	B,$VAL2(PNT)	;FIRST STMT OF UNNUMBERED
	JUMPL	TEMP,[TRNN TEMP,-1	;WE HAVE BEEN NUMBERING. THIS ONE, TOO?
			ERR <Mixing numbered & unnumbered CASEs.>,1
			JRST CASEM1]
	TRNE	TEMP,-1		;NOT BEEN NUMBERING.  THIS ONE HAVE SOME?
	 ERR <Mixing numbered & unnumbered CASEs.>,1
CASEM1:	HLLZS	$VAL2(PNT)	;PRESERVE STYLE,,NO NUMBERS SEEN NEXT CASE YET
	PUSHJ	P,ALLSTO	;STORE ALL
	MOVE	A,[JRST NOUSAC+JSFIX]	;JRST TO END OF CASE
	PUSHJ	P,EMITER
	QPOP	(CASTAK)	;ASSUME NEXT CASE
	QPUSH	(CASTAK)
	AOBJN	A,.+1		; IS ONE MORE THAN PREVIOUS CASE
	HLRZ	TBITS2,A	;SAVE CASE NUMBER
	HRR	A,PCNT		;AND BEGINS AT PCNT
CASDO2:	QPUSH	(CASTAK)
	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)
	POPJ	P,



^CASEMM:		;HERE WHEN A CASE IS EXPLICITLY NUMBERED
	GETSEM (3)	;SEMANTICS OF CASEX
	SKIPLE TEMP,$VAL2(PNT)	;STATUS OF NUMBERING
	 ERR <Mixing numbered & unnumbered CASEs.>,1
	MOVEI LPSA,CASTAK	;PREPARE FOR POSSIBLE QPOP
	TRNN TEMP,-1		;IS THIS THE FIRST EXPLICIT NUMBER FOR THIS CASE
	 QPOP			;YES, SO GET RID OF ASSUMED NUMBER
	HRROI TEMP,-1
	EXCH TEMP,$VAL2(PNT)	;EXPLICIT NUMBERING,,THIS CASE HAS A NUMBER
	TLNN TEMP,-1		;FIRST CASE SEEN?
	 HRROS $VAL(PNT)		;YES, SMALLEST SEEN IS VERY LARGE
	GETSM2 (1)		;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)
	SKIPGE TBITS2,$VAL(PNT2)
	 ERR <CASE NUMBER MUST BE NON-NEGATIVE INTEGER CONSTANT>,1
	MOVSI A,(TBITS2)
	HRR A,PCNT		; #,,PCNT
;;UR#18 PDR 3/78 (1-1) Largest case label bug. Replaced a JRST CASDO2...
	QPUSH	(CASTAK)
	HLRZ	TEMP,$VAL(PNT);LOWEST SEEN YET
	CAMGE	TBITS2,TEMP	;THIS ONE LOWER?
	HRLM	TBITS2,$VAL(PNT);YES, THEN NO
	HRRZ	TEMP,$VAL(PNT)
	AOS	TBITS2
	CAMLE	TBITS2,TEMP	;SAME FOR UPPER
	HRRM	TBITS2,$VAL(PNT)
	POPJ	P,
;;UR#18 PDR 3/78 (1-1)  ...replacement ends here

^CASEME:
	GETSEM	(1)		;SEMANTICS OF CASEX
	HLRZ	TEMP,$ACNO(PNT)
	JUMPE	TEMP,.+2
	 ERR	<Previous ELSE in this CASE will be ignored.>,1
	MOVE	TEMP,PCNT
	HRLM	TEMP,$ACNO(PNT)	;SAVE ADDR OF 'ELSE' PART
	SKIPLE TEMP,$VAL2(PNT)	;NOW DO AS IN CASEMM
	 ERR <Mixing numbered & unnumbered CASEs.>,1
	MOVEI LPSA,CASTAK
;;UR#19 PDR 4/3/78 (1-1) 1st case else => BPOP err. Removed extra pop
	HRROI TEMP,-1
	EXCH TEMP,$VAL2(PNT)
	TLNN TEMP,-1
	 HRROS $VAL(PNT)
	POPJ	P,
^CASE3:	SOSL	B,THISE		;THE TYPE OF EXPRESSION.
	JRST	[JUMPN B,LPCS3
		 PUSHJ	P,LEVBOL
		 JRST .+1]
	MOVE	PNT,GENLEF+2	;CASEE
	HRRZ	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
	HLRZ	TEMP,$ACNO(PNT)	;'ELSE'
	JUMPN	TEMP,.+2	;   SPECIFIED?
	HRRZS	$VAL(PNT)	;NO, MUST START TABLE AT 0
	HLRZ	B,$VAL(PNT)	;MINIMUM CASE #
	LDB	TBITS2,[POINT 17,PCNT,35]	;LEAVE OFF 400000 BIT
	CAIG	B,(TBITS2)	;IF MIN CASE < PCNT
;;#ZI# JFR 9-17-77 CURE LOADER GARBAGE
	CAILE	B,(TBITS2)	;IF MIN CASE < PCNT
	HRLM	TBITS2,$VAL(PNT)	;NEW MIN CASE #
;;#ZI# ^
	HLLZ	B,$ADR(PNT)	;ADDR OF FIRST CAIL
	HLR	B,$VAL(PNT)	;ADDR,,MIN
	PUSHJ	P,FIXOUT	;DO NOT RELOCATE THE FIXUP.
	AOBJN	B,.+1		;ADDR OF 2ND CAIL
	HRR	B,$VAL(PNT)	;ADDR,,MAX+1
	PUSHJ	P,FIXOUT
	MOVS	TEMP,$VAL(PNT)	;MAX+1,,MIN
	HLRZ	SBITS2,TEMP	;MAX+1
	SUBI	SBITS2,(TEMP)	;NUMBER OF CASES IN TABLE
	MOVE	TBITS2,PCNT	;CURRENT PC
	ADDI	TBITS2,(SBITS2)	; + # CASES IS OUT ADDR
	ADD	B,[XWD 2,0]	;ADDR OF INDEXED JRST
	HRR	B,PCNT
	SUBI	B,(TEMP)	;TRIM THE FAT
	PUSHJ	P,FBOUT		;FIXUP FOR INDEXED JRST.
	SOS	TEMP,$VAL(PNT)
	HLRZ	C,TEMP		;MIN CASE #
	HRRZM	TEMP,$VAL(PNT)	;XWD 0,LAST CASE #
	QPOP	(CASTAK)	;ASSUMED NEXT CASE NOT NEEDED
;; this because QPOP-QBEG-QTAK gives infinite loop when QPOP ran off bottom of
;; block and did not delete it JFR 1-10-77
	MOVS	TEMP,(LPSA)	;DETECT BAD SITUATION
	CAME	TEMP,(LPSA)
	 JRST	.+3
	PUSHJ	P,BPOP		;POP ONE MORE
	PUSHJ	P,BPUSH		;PUSH IT RIGHT BACK
;;^
	HLRZ	TEMP,$ACNO(PNT)
	JUMPN	TEMP,.+2
	AOJA	TBITS2,.+3	;NO 'ELSE', ALLOW FOR  PUSH P,CSERR
	SKIPA	TBITS2,TEMP	;USE 'ELSE' CASE RATHER THAN OUT ADDR
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
	HLRZ	B,$ADR(PNT)	;ADDR OF FIRST CAIL
	MOVSI	B,2(B)		;ADDR OF JRST FOR BOUNDS ERROR
	HLR	B,$ACNO(PNT)	;'ELSE' CASE, IF ANY
	TRNN	B,-1
	 HRR	B,PCNT
	PUSHJ	P,FBOUT		;OUT OF BOUNDS COMES HERE
	HLRZ	TEMP,$ACNO(PNT)
	JUMPN	TEMP,CLD1	;'ELSE' SPECIFIED?
;;UR#20 PDR (2 of 3) 4/26/78 fix err msg access to AC
	HRRZ	D,$ACNO(PNT)
	MOVEI	C,0
	EMIT	<ADDI USADDR!NORLC>
;;UR#20 end of 2nd of 3 changes

	XCALL	(CSERR)		;NO, HANDLE ERROR
CLD1:
	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 (  drarrow   PDEC   EXEC  PRDEC CLRSET  SCAN  DS1
	PDEC @I ;  drarrow   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 pnts to 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 -- pnts to 1st formal Semblk	,,%STEMP pnts to saved TTEMP list (%TBUCK)
%SAVET  ptr to  old TTOP	,, ptr 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

;MPQCNT - number of matching procedure params seen so far
?MPQCNT: 0
;MPVARS - qstack of ? params seen thus far
?MPVARS:	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
;;#NT#	! RHT 8-19-73 REALLY NEED AN ALLSTO HERE, WHILE STILL HAVE OLD TEMPS
	PUSHJ	P,ALLSTO
	MOVEI	A,PROCED		;BITS FOR PROCEDURE
	IOR	A,BITS
	TRNE	A,ITEM
	TRC	A,ITEM!ITMVAR		;ITEM PROCEDURES REALLY ITEMVAR PROCS
	MOVEM	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 to pnt to 2D TPROC BLOCK
RGC <
	HRR	TEMP,RCTEMP
	HRLM	TEMP,%RVARB(LPSA)	;SAVE RCTEMP LIST
>;RGC
	HRR	TEMP,TTEMP
	HRRM	TEMP,%STEMP(LPSA)	;SAVE CURRENT TEMP RING.
	PUSH	P,LPSA			;SAVE ptr to 2D BLOCK OF SURROUNDING PROC
	MOVE	PNT2,NEWSYM		;NEW SYMBOL (PROCEDURE NAME)
	LEFT	PNT2,%TLINK,LPSERR	;LPSA ptr to 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
	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 IN (VARB,APARNO,SPARNO,ADEPTH,SDEPTH,TTEMP) <
		SETZM	II>
RGC <
	SETZM	RCTEMP
>;RGC
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
	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
	XORM	A,RECSW		;THIS WILL SET RECSW TO ALL 0 IF NOT RECSV
;; #MX# (1 OF 1) RHT CHECK FOR NON SIMP INSIDE SIMP
;;%##% ALSO DO NOT BARF AT EXTERNAL OR FORTRAN
	TDNN	TBITS2,[ XWD SIMPLE+EXTRNL,FORTRAN]
	SKIPN	SIMPSW	
	JRST	.+2		
	ERR	<YOU HAVE DECLARED A NON-SIMPLE PROCEDURE INSIDE
A SIMPLE PROCEDURE.  WE MAKE NO PROMISSES... >,1
;; #MX#

	SETOM	SIMPSW		;ASSUME SIMPLE
NOBAIL<
	TLNE	TBITS2,SIMPLE	;IS IT REALLY
	JRST	GOTPD		;YES
	SETZM	SIMPSW		;NOT SIMPLE
>;NOBAIL
BAIL<
	TLNN	TBITS2,SIMPLE	;IS IT REALLY
	 SETZM	SIMPSW		;NO
	MOVE	TEMP,BAILON
	TLNE	TBITS2,SIMPLE	;SKIP IF NOT SIMPLE
	TRNE	TEMP,BBPDSM	;SKIP IF SIMPLE PROCS DONT GET PDS
	 JRST	.+2		;PROC WILL GET A PD
	JRST	GOTPD		;SIMPLE PROC AND NO PD
>;BAIL
;;#LQ# 2! RHT IF FWRD PROC HAD A PD, THEN KEEP IT
	HRRZ	LPSA,$VAL(PNT2)	;HAD A PD?
	JUMPN	LPSA,GOTPD	;DONT GET ANOTHER
;;#LQ#
	GETBLK			;FOR PROC DESC STUFF
	HRRM	LPSA,$VAL(PNT2)	;RECORD IT
GOTPD:
BAIL<
	MOVE	TEMP,BCORDN	;COORDINATE NUMBER AT PRDEC
	HRLM	TEMP,$VAL(LPSA)	;PLACE INTO PD SEMBLK
>;BAIL
	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
	SKIPN	SIMPSW		;IF NOT SIMPLE PROC
	AOS 	CDLEV		;DOWN HERE TOO
	TLO	FF,NOCRFW!PRODEF	;SET DECLARATION BIT

; 3 -- ISSUE CODE

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

	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
	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;
	
;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:
	HRRZ	TEMP,PCNT	;ADDR OF JRST TO COME (IF ANY)
	POP	P,LPSA		;PTR TO 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
;;%BI% ! CHANGED THIS FROM HRLZM TEMP,$ACNO(PNT2)
NOROUND:HRLM	TEMP,$VAL2(PNT2);IDENTIFIES START OF PROCEDURE
	HLLZS	$ACNO(PNT2)	;WAS PARANOID ABOUT THE ZEROING USED TO GET
;;%BI%
	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
;;#SD#
	MOVEI	A,1		;FLAG THAT SAYS ALWAYS PUT OUT PDA WORD
	PUSHJ	P,PDAWRD	;YES, NEED A PDA WORD
;;#SD#
NTINT:
NRC <
	SKIPE	RCDFLG		;IF DECLARING A RECORD CLASS
	JRST	WAITAS		;THEN WAIT TO ASSIGN ADDRESS
>;NRC
	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
WAITAS:	MOVEM	TBITS2,$TBITS(PNT2); NO LONGER FORWARD
BAIL<
	MOVE	TEMP,BAILON
	SKIPE	SIMPSW		;SKIP IF NOT SIMPLE
	TRNN	TEMP,BBPDSM	;SKIP IF SIMPLE PROCS GET PD
	 JRST	NTINT1		;SAME AS USUAL
;;#%%# 2! JFR 2-1-75	RECORDS ARE SIMPLE PROCS IN DISGUISE, THE JFCL WAS KILLING THEM
	SKIPE	RCDFLG		;RECORD CLASS DECL IN PROGRESS?
	 JRST	NTINT1		;YES
	EMIT	(<JFCL NOUSAC+NOADDR>)	;GIVE BREAKPOINTS SOME BREATHING ROOM
	HRRZ	PNT,$VAL(PNT2)	;MY PD SEMBLK
	HRRZ	B,PCNT
	HRLM	B,$ACNO(PNT)	;PCNT AFTER "MKSEMT"
	POPJ	P,
NTINT1:
>;BAIL
	SKIPE	SIMPSW		;IF SIMPLE THEN ALL DONE
	POPJ	P,
	PUSHJ	P,MKSEMT	;PUT OUT MSCP
	PUSHJ	P,SETF		;MAKE IT ALL OFFICIAL
	POPJ	P,

^^TMPOPJ:POP	P,TEMP
	POPJ	P,

PDAWRD:	HRRZ	PNT,$VAL(PNT2)	;LOOK AT PROCEDURE DESCRIPTOR
	CAIN	PNT,0		;BETTER BE HERE
	ERR	<DRYROT -- DONT HAVE PD SEMBLK YET>
;;#SD# IF USED TO BE EXTERNAL WE NEED TO BE FANCY HERE (PERHAPS)
	SKIPN	IEFLAG		;INTERNAL TO EXTERNAL??
	JRST	PDAW.1		;
	HRLZ	B,$ADR(PNT)	;PDA FIXUP CHAIN
	JUMPE	B,PDAW.1	;
	HRR	B,PCNT		;
	PUSHJ	P,FBOUT		;FIX ALL THESE UP TO HERE
	HLLZS	$ADR(PNT)	;MAKE A FRESH START
	PUSHJ	P,FRBT		;LIKE SO
	JRST	.+2		;WE REALLY NEED A PDA WORD
PDAW.1: JUMPE	A,CPOPJ
;;#SH# ! ADDED A NOUSAC
	EMIT	<NOUSAC!JSFIX>		;PUT OUT PDA
	HRRZ	TEMP,PCNT	;AND YET ANOTHER VALUE FOR
	HRLM	TEMP,$VAL2(PNT2);PCNT AT PRDEC
	POPJ	P,

RCSV:	SKIPN	IEFLAG		;
	POPJ	P,
	MOVEI	A,0		;ONLY PUT OUT PDA WORD IF NEED TO
	JRST	PDAWRD

;;#SD#
COMMENT   ENDPR -- when params have been seen

DSCR ENDPR
PRO ENDPR
DES
PD1:	PDEC ;  drarrow  PDEC   EXEC ENDPR  SCAN   S1
	PDNO ;  drarrow  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
	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:
	HLRZ	PNT2,%TLINK(PNT2)	;PTR TO SECOND BLOCK FOR THIS PROC
	JUMPE	PNT2,LPSERR		;HAS TO BE THERE
	AOS	A,APARNO	;SAVE COUNTS
	HRLM	A,$NPRMS(PNT2)	;SAVE COUNTS
	HLLM	A,$SBITS(PNT2)	;NUMBER OF VALUE LONG PARAMS
	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:
	TDNE	TBITS,[REFRNC,,ITEM!ITMVAR]
	 JRST	.+3		;ITEMISH OR BY REFERENCE
	TRNE	TBITS,DBLPRC
	 ADDI	A,1		;A VALUE LONG, REACH BACK 1 MORE
	HRRM	A,$ADR(PNT)
	ADDI	A,1
	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
	AOS	MPQCNT		;WE HAVE ANOTHER ? PARAM
	QPUSH	(MPVARS,PNT)	;SAVE ? PARS SEMANTICS
;INITIALIZE ? PARAMS TO UNBOUND IF NECESSARY
	MOVEI	A,UNBND		;THE "UNBOUND" ITEM
	PUSHJ	P,CREINT	;GET CONSTANT SEMBLK
	GENMOV  (GET,0)		;
	HRROS	ACKTAB(D)	;PROTECT THAT AC
	EXCH	D,(P)		;SAVE AC # ITS IN
	MOVE	PNT,D		;THE PARAM SEMBLK
	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 @
	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>
;; #LL# WAS UNPROTECTING WRONG AC
;;	MOVSS	D
	HRRZS	ACKTAB(D)	;"FREE" INDEX AC
	POP	P,A		;RESTORE DISPLACEMENT
NOMPRS:
	

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

PUTIN:
	MOVE	TEMP,GENLEF+1	;GET PROC'S SEMANTICS
	MOVE	TEMP,$TBITS(TEMP)
;; #ME# FOLLOWING ONLY TESTED EXTRNL
	TDNN	TEMP,[EXTRNL,,FORWRD] ;IF EXTERNAL OR FORWARD DO NOTHING HERE
	TLNN	TEMP,MPBIND	;OR NOT MATCHING PROCEDURE 
	JRST	PUTIN2		;IGNORE
	PUSH	P,PNT
	HRR	C,PCNT
	MOVE 	B,MPQCNT	; THE COUNT OF NUMBER OF ? PARAMETERS
	ADDI	C,2(B)		;
	HRLI	C,(C)
	EMIT	<JRST	,NOUSAC!USADDR> ;JRST AROUND ?TABLE
	HRL	PNT,PCNT	;SAVE ADDR OF TABLE
	HRR	PNT,LEVEL	;SAVE LEVEL FOR STKUWD
	QPUSH	(MPVSTK,PNT)
	HRLI	C,(B)		;NUMBER OF MP PARS
	EMIT	<,NOUSAC!USADDR!NORLC>;COUNT OF
;; #NP# CAN'T QPOP AN EMPTY STACK(MPVARS)
	JUMPE	B,NOQPARS	;IF NO PARAMS DO NOTHING
LBPUTL:
	QPOP	(MPVARS,PNT)
	HRRZ	C,$ADR(PNT)	;THE STACK DISPLACEMENT
	MOVNS	C
	SUBI	C,1		;FOR RETURN ADDRESS
	HRL	C,C
	EMIT	<,USADDR!NOUSAC!NORLC>
	SOJG	B,LBPUTL
NOQPARS:
	POP	P,PNT
	SETZM	MPQCNT		;FOR NEXT TIME
PUTIN2:
	HRLM	PNT,%TLINK(PNT2) ;PNT2 pnts to 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)
;; ENDRC -- MAIN RECORD CLASS EXEC

REC <

; Any resemblence between this routine & ENDPR or PRUP is strictly
; intentional

ZERODATA(SOME VARIABLES FOR RCLASS EMISSION)
TARAPC:	0			;PROGRAM COUNTER AT START OF TYPE ARRAY
IDRAPC:	0			;PC AT START OF ID ARRAY
PNSTPC:	0			;PC AT START OF PNAME STRING
CLSBTS:	0			;HOLDS TYPE BITS
NOFLID:	0			;IF NON-ZERO, NO FIELD PNAMES GO OUT
ENDDATA


^ENDRC:	TLZ	FF,NOCRFW!PRODEF	;MAKE THE SCANNER HAPPY
	SETZM	CURRCC			;DONE WITH THIS NOW
	HRRZ	PNT2,GENLEF+1		;THE "PROCEDURE"
	PUSHJ	P,GETAD2		;IF EXTERNAL OR FORWARD, DO NOTHING
	HLRZ	PNT2,%TLINK(PNT2)	;GET THE SECOND BLOCK
NONRC<
	SKIPE	A,SPARNO		;PARAMETER COUNT
	ERR	<STRING SUBFIELDS FOR RECORDS NOT YET IMPLEMENTED>,1
>;NONRC
NRC<
	MOVE	A,SPARNO
>;NRC
	ADD	A,APARNO		;NUMBER OF PARAMETERS
	HRRZM	A,$NPRMS(PNT2)		;

NONRC <
	TDNE	TBITS2,[XWD EXTRNL,FORWRD] ;CHECK TO SEE IF SHOULD PUT OUT
	JRST	FLDCHK			;NOTHING GOES OUT

	LSH	A,=23			;TURN THE WORD COUNT INTO "OPCODE"
	SKIPE	PNT,URCIPR		;DID THE USER SPECIFY A HANDLER
	JRST	[ PUSHJ	P,GETAD
		  HRL	C,$ADR(PNT)	;
		  TRNE	TBITS,FORWRD!INPROG	;WELL??
		  TROA	A,NOUSAC!JSFIX	;YES, LET EMITER DO FIXUP
		  TRO	A,NOUSAC!USADDR	;
		  JRST  HLRWRD
		]
	HRLZ	C,PCNT			;USE THE STANDARD ROUTINE $REC$
	EXCH	C,LIBTAB+R$REC$		;DO FIXUP MYSELF
	HRRI	A,NOUSAC!USADDR		;& PUT OUT THE INSTRUCTION
HLRWRD:	PUSHJ	P,EMITER		;PUT OUT THE HANDLER WORD
>;NONRC

FLDCHK:	
NRC <
	MOVEI	B,CMPLDC		;NO DELETE & COMPILED-IN
>;NRC
	SKIPN	LPSA,VARB		;ARE THERE ANY FIELDS
	JRST	NOFLDS			;NOPE
	HRRZ	A,$NPRMS(PNT2)		;HOW MANY THERE ARE
	HRLZI	TBITS,FORMAL		;TURN OFF THE FORMALNESS
ZRTB:	ANDCAM	TBITS,$TBITS(LPSA)	;OF THIS PARAMETER
NRC <
	MOVE	C,$TBITS(LPSA)		;GET TBITS
	TRNE	C,ITMVAR!ITEM		;AN ITEMISH THING?
	JRST	FPISIV			;YES
	TRNE	C,STRING		;A STRING?
	TRO	B,HASSTR		;HAVE SOME SORT OF STRING PARAM
	TRNE	C,DBLPRC
	TRO	B,HASDBL		;SOME DOUBLE PRECISION STUFF
	TRNE	C,PNTVAR		;PERCHANCE A RECORD CLASS
	TRO	B,HASRPS		;YES
FPISIV:
>;NRC
	MOVEM	A,$ADR(LPSA)		;INDEX
	SOJLE	A,RMFP			;REMEMBER THIS ONE 
;;#VB# (1 OF 3) MISPLACED CODE USED TO BE HERE RHT
	HLRZ	LPSA,%RVARB(LPSA)	;GO LEFT,YOUNG MAN
	JUMPN	LPSA,ZRTB		;
	ERR	<DRYROT: INDEX COUNT & PARAM RING DISAGREE>,1
;;#VB# (2 OF 3) ! PUT NOFLDS IN RIGHT PLACE
NRC <
NOFLDS:
>;NRC
RMFP:	HRLM	LPSA,%TLINK(PNT2)	;NOW LPSA HOLDS PTR TO FIRST
;;#VB# (3 OF 3) RHT
NRC <
	MOVEM	B,CLSBTS		;REMEMBER CLASS BITS
>;NRC
;;#VB#
	TDNE	TBITS2,[XWD EXTRNL,FORWRD] ;IF ONE OF THESE, NO CODE
	JRST	RCBDON
NRC <	
REN <
	PUSHJ	P,HISET			;FORCE INTO HIGH SEGMENT
>;REN
	PUSH	P,FF			;PARANOIA
	TLO	FF,RELOC		;
	MOVE	A,PCNT			;
	MOVEM	A,TARAPC		;TYPE ARRAY PC
	ADDI	A,5			;POINT AT FIRST WORD OF ARRAY
	PUSHJ	P,CODOUT
	PUSHJ	P,[ARBNDP: TLZ	FF,RELOC	;PUT OUT BOUNDS PAIRS
			MOVEI	A,0
			PUSHJ	P,CODOUT	;LOWER BND
			HRRZ	A,$NPRMS(PNT2)	;
			PUSHJ	P,CODOUT	;UPPER BND
			MOVEI	A,1		;MULT
			PUSHJ	P,CODOUT
			POPJ	P, ]
	HRRZ	A,$NPRMS(PNT2)
	ADD	A,X11			; NDIMS,,LEN
	PUSHJ	P,CODOUT		; PUT OUT THAT WORD
	MOVE	A,CLSBTS		; *** HERE IS WHERE TYPE BITS GO ***
	PUSHJ	P,CODOUT		; PUT OUT TYPE BITS
	HLRZ	LPSA,%TLINK(PNT2)	;IN CASE WAS MUNCHED (MOST LIKELY WAS OK)
	PUSHJ	P,TBCOUT		;
	MOVE	PNT,GENLEF+1		;PICK UP THE CLASS DESCRIPTOR
	EXCH	SP,STPSAV		;SINCE WILL CALL CAT
	PUSHJ	P,INSET			;WE WILL ALWAYS PUT OUT CLASSID CHARS
	PUSH	SP,$PNAME(PNT)		;CLASSID
	PUSH	SP,$PNAME+1(PNT)
	PUSH	P,[0]
EXTERN	CATCHR
	PUSHJ	P,CATCHR		;NOW ASCII WITH A ZERO
	SKIPE	NOFLID			;WANT IDS
	JRST	CHRSDO			;NO, JUST PUT OUT WHAT YOU HAVE
	HLRZ	B,%TLINK(PNT2)		;FIRST FIELD
	JUMPE	B,CHRSDO		;NO FIELDS
FIDSLP:	PUSH	SP,$PNAME(B)		;PNAME OF PARAMETER
	PUSH	SP,$PNAME+1(B)
	PUSHJ	P,CAT			;CONCATENATE IT ON
	HRRZ	B,%RVARB(B)		;GET THE NEXT ONE
	JUMPN	B,FIDSLP		;CONTINUE ON
CHRSDO: 
	POP	SP,B			;POINT AT TEXT
	POP	SP,C			;CHARACTER COUNT
	EXCH	SP,STPSAV		;PUT SP BACK TOGETHER
	HRRZ	C,C			;WANT THE BYTE COUNT
	MOVE	A,PCNT			;REMEMBER HERE
	MOVEM 	A,PNSTPC		;SO CAN BUILD DESCRIPTORS
CHRSD1:	MOVE	A,(B)			;A WORD OF TEXT
	PUSHJ	P,CODOUT		;PUT IT OUT
	SUBI	C,5			;5 CHARS WENT OUT
	CAILE	C,0			;DONE 
	AOJA	B,CHRSD1		;DO, GO DO SOME MORE
	SETZM	IDRAPC			;
	SKIPE	NOFLID			;WANT ID FIELDS TO GO OUT
	JRST	FIDSDN			;NO, THEN WE ARE DONE WITH IDS
	MOVE	A,PCNT			;REMEMBER WHERE STRING ARRAY STARTS
	MOVEM	A,IDRAPC		;
;;#XK# ! JFR 7-30-76 STRING ARRAYS HAVE -1 IN LEFT HALF OF WORD CONTAINING 000 ADDR
	HRROI	A,6(A)			;FIRST DATA ENTRY
	TLO	FF,RELOC
	PUSHJ	P,CODOUT
	PUSHJ	P,ARBNDP		;PUT OUT ARRAY BOUNDS PAIR
	HRRZ	A,$NPRMS(PNT2)		;COUNT WORD
	LSH	A,1
	HRROI	A,2(A)			;-1,,2(N+1)
	PUSHJ	P,CODOUT		;

	MOVE	D,PNSTPC		;PC AT START OF PNAME STRING
	HRLI	D,(<POINT 7,0>)		;MAKE IT A BYTE POINTER
	HRRZ	C,$PNAME(PNT)		;BYTE CNT OF ID
	PUSHJ	P,[BPEMT:  TLZ FF,RELOC
			MOVE	A,C	;PUT OUT COUNT
			PUSHJ	P,CODOUT;
			TLO	FF,RELOC;
			MOVE	A,D	;PUT OUT BPTR
			PUSHJ	P,CODOUT
			JUMPE	C,CPOPJ	;
		   BPEMT0: IBP	D	;INCREMENT POINTER
			SOJG	C,BPEMT0;THAT MANY TIMES
			POPJ	P,]
	IBP	D			;FOR THE 0 BYTE
	HLRZ	B,%TLINK(PNT2)		;PUT OUT STRINGS FOR FIELDS
	JUMPE	B,FIDSDN		;DONE
FID1DO:	HRRZ	C,$PNAME(B)		;LENGHT OF THIS ONE
	PUSHJ	P,BPEMT			;PUT OUT
	HRRZ	B,%RVARB(B)		;NEXT
	JUMPN	B,FID1DO
;; HERE PUT OUT THE ACTUAL DESCRIPTOR
FIDSDN:
REN <
	PUSHJ	P,LOSET			;THIS GOES INTO THE LOW SEGMENT
>;REN
	TLZ	FF,RELOC
	MOVEI	A,0			;RECORD CLASS LINK WORD
	PUSHJ	P,CODOUT		;
	MOVEI	B,%RCLNK		;LINK ONTO THE RECORD CLASS LIST
	PUSHJ	P,LNKOUT		;PUT IT OUT
	MOVEI	A,0			;THE RING WORD
	PUSHJ	P,CODOUT
;; NOW GIVE RECORD CLASS AN ADDRESS
	MOVE	PNT,GENLEF+1
	HRL	B,$ADR(PNT)	;PICK UP ADDRESS
	HRR	B,PCNT		;AT PCNT NO LESS!
	HRRM	B,$ADR(PNT)
	TLNE	B,-1		;IF IT WAS FORWARD, AND SOMEONE
	PUSHJ	P,FBOUT		;HAD THE FORSIGHT TO USE IT.
	MOVEI	TBITS2,INPROG	;TURN OFF INPROG
	ANDCAM	TBITS2,$TBITS(PNT)
;; NOW PUT OUT THE FIRST "REAL" WORD OF THE DESCRIPTOR
	HRLZ	C,PCNT			;
	EXCH	C,LIBTAB+R$CLASS	;DO FIXUP MYSELF
	HRRI	A,NOUSAC!USADDR		;& PUT OUT THE INSTRUCTION
	PUSHJ	P,EMITER		;PUT OUT THE CLASSID WORD
	TLZ	FF,RELOC
	MOVEI	A,0			;THE RECRNG WORD
	PUSHJ	P,CODOUT
	SKIPE	PNT,URCIPR		;DID THE USER SPECIFY A HANDLER
	JRST	[ PUSHJ	P,GETAD
		  HRL	C,$ADR(PNT)	;
		  TRNE	TBITS,FORWRD!INPROG	;WELL??
		  TROA	A,NOUSAC!JSFIX	;YES, LET EMITER DO FIXUP
		  TRO	A,NOUSAC!USADDR	;
		  JRST  HLRWRD
		]
	HRLZ	C,PCNT			;USE THE STANDARD ROUTINE $REC$
	EXCH	C,LIBTAB+R$REC$		;DO FIXUP MYSELF
	MOVEI	A,NOUSAC!USADDR		;& PUT OUT THE INSTRUCTION
HLRWRD:	PUSHJ	P,EMITER		;PUT OUT THE HANDLER WORD
;;#UG# ! REMEMBER NOT TO RELOCATE THE COUNT
	TLZ	FF,RELOC		;GOES OUT UNRELOCATED
	MOVE	A,$NPRMS(PNT2)		;WORD COUNT
	PUSHJ	P,CODOUT
	MOVE	A,TARAPC		;PC OF TYPE ARRAY
	ADDI	A,5			;FOR ARRAY HEAD
	TLO	FF,RELOC
	PUSHJ	P,CODOUT		;PUT IT OUT
	SKIPN	A,IDRAPC		;ID ARRAY
	TLZA	FF,RELOC		;A ZERO
	ADDI	A,6			;TO RIGHT PLACE
	PUSHJ	P,CODOUT		;PUT OUT
	POP	P,FF			;GET FF BACK
REN <
	PUSHJ	P,HISET			;BACK TO HIGH SEGMENT
>;REN


>;NRC
NONRC <

	PUSHJ	P,TBCOUT		;PUT OUT THE CODES FOR THESE
NOFLDS:	MOVEI	A,0			;
	PUSHJ	P,CODOUT		;A ZERO TO SAY DONE
;;%BN% PUT OUT ASCIZ/CLASSID/ & A SAIL STRING POINTER THERETO
	MOVE	PNT,GENLEF+1
	PUSH	P,FF			;SUPER PARANOID
	TLZ	FF,RELOC
	HRRZ	A,$PNAME(PNT);
	PUSHJ	P,CODOUT
	HRRZ	B,A
	HRRZ	A,PCNT
	ADD	A,[POINT 7,1]
	TLO	FF,RELOC
	PUSHJ	P,CODOUT		;PUT OUT THE BYTE PTR
	MOVE	D,$PNAME+1(PNT)		;THE BYTE POINTER WORD OF ID
	IDIVI	B,5			;NUMBER OF WORDS
	CAIE	C,0			;IF NO REMAINDER
	ADDI	B,1			;THEN WE WILL EVENTUALLY PUT OUT A 
	TLZ	FF,RELOC		;WHOLE WORD OF 0
CIDLP:	MOVE	A,(D)			;A WORD FULL OF TEXT
	PUSHJ	P,CODOUT
	ADDI	D,1
	SOJG	B,CIDLP
	JUMPN	C,.+3
	MOVEI	A,0
	PUSHJ	P,CODOUT
	POP	P,FF
;;%BN%
>;NONRC
	
RCBDON:	;WELL, THE BODY IS OUT NOW
	HLRZ	PNT,%TLINK(PNT2)	;PRE-CONDITION FOR PUTIN2
	PUSHJ	P,PUTIN2		;CHECK AGAINST POSSIBLE FORWARDS
					;(PRETENDING TO BE ENDPR, REMEMBER)

RPRUP:	SETZM	BITS			;NOW DO THE PRUPISH THINGS
	SETZM	ALOCALS			;MOST LIKELY MOOT, BUT DOESN'T HURT
	SETZM	SLOCALS
	QPOP	(FORMFX)		;THIS ARCHAIC THING SHOULD BE FLUSHED
	JUMPGE	A,FFXERR		;THE "MARK" WAS NEGATIVE

	MOVE	PNT,GENLEF+1		;JUST TO KEEP MY HEAD STRAIGHT
	PUSHJ	P,GETAD			;PROC SEMANTICS 

	PUSHJ	P,SYNTUP		;NOTE STILL PRETENDING TO BE SIMPLE PROC
	MOVE	PNT,GENLEF+1		;FOR SAFETY
	MOVE	TBITS,[XWD SIMPLE,PROCED!PNTVAR!SHORT]
	XORM	TBITS,$TBITS(PNT)	;TELL THE TRUTH ABOUT WHAT IT IS
	POPJ	P,			;HOPE IT WORKS

>;REC
COMMENT   PRUP -- When Procedure Body's Finished -- Entry, Exit, Fixups, etc.

DSCR PRUP
PRO PRUP
RES 
at S8:	PDEC S ;  drarrow  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

	HRRZ	PNT,$VAL(PNT2)	;PICK UP PD SEMBLK
	MOVE	TEMP,PCNT	;PICK UP PCNT
	HRRM	TEMP,$ACNO(PNT)	;
	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
;; #LK# BY JRL FOLLOWING WAS QPOP
	QPOP	(MPVSTK,C)	;THIS IS QPOP AGAIN, SINCE PEXIT NO LONGER
				;REFERS TO IT
;; #LK# 
	EMIT	<HRLI LPSA,NOUSAC!USADDR>;ADDRESS OF ?TAB
	HRLI	C,LPSA
	EMIT	<PUSH RP,NOUSAC!USADDR!NORLC> ;STACK PDA ADDRESS
	XCALL	(.FAIL)		;REPORT FAILURE
	EMIT	<SETZ 1,NOUSAC!NOADDR> ;FALLING THROUGH IS FALSE
	PUSHJ	P,EMITER	;BOTH NORMAL RETURN AND SKIP RETURN
MPNO:

	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:
	TLZ	FF,ALLOCT	; GET SIZES
	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 pnts to [DISPL REL 0,ADDR OF INSTR]
	JUMPL	A,FFXERR	;MUST NOT BE NEGATIVE
	JUMPLE	A,PEXIT		;GO GENERATE EXIT CODE WHEN DONE
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
;;#HS# IGNORE STRING BIT FOR STRING ITEMVAR PROC.
	TRNE	TBITS2,ITEM!ITMVAR
	TRZ	TBITS2,STRING
;;#HS#
	LEFT	PNT2,%TLINK,LPSERR;LPSA pnts to SECOND BLOCK
	HLLZ	TEMP,$SBITS(LPSA)	;NUMBER OF VALUE LONG PARAMS
	PUSH	P,TEMP
	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
REC <
NORGC <
	TLNN	TBITS,VALUE	;IF NOT VALUE
	JRST	NXF		;NO WORRY AT ALL
	TRNE	TBITS,PNTVAR	;A RECORD POINTR
	TRNE	TBITS,777777-(PNTVAR!GLOBL)
	JRST	SETCHK		;NOPE
	MOVNI	C,1		;GO DEREFERENCE THIS FELLOW
	PUSHJ	P,RFCADJ
	JRST	NXF		;GO LOOK AT NEXT FORMAL PARAMETER
SETCHK:
>;NORGC
RGC <
	TLNE	TBITS,VALUE
>;RGC
>;REC
NOREC <
	TLNE	TBITS,VALUE	;IF NOT VALUE
>;NOREC
	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>
;;#QX# RHT ! NEED TO BOOKKEEP (1 OF 2) 1-31-74
	AOS	ADEPTH
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
;;#QX# RHT ! FOR 2 (2 OF 2) 
	PUSHJ	P,[ SOS ADEPTH	;PUT IT BACK
		JRST	EMITER ]
;;#JK#
;;#IP#
	SKIPGE	BITS		;SPECIAL?
	 JRST	 DNTPSH		; YES, NO NEED SUBS OR PUSHES (DONE BFORE RETURN)
	MOVE	PNT,SLIMS	;VBL DESCRIPTOR BOUNDARIES
	MOVE 	A,SSDIS		;STRING STACK DISPL
	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
;  RH(-1(P)) is # of VALUE STRING LONGs...thus, 0!
	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:
	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
	MOVSS	-1(P)		;AND EXTRA WORDS FOR VALUE LONGS
	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
	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
	MOVE	C,(P)		;# ARITH PARAMS
	ADD	C,-1(P)		;# EXTRA WORDS FOR VALUE LONGS
	MOVSI	C,(C)		;= DISPLACEMENT
	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
	POP	P,TEMP		;AND THE # VALUE LONGS
	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>
;;#SH# ! ADDED NOUSAC
	EMIT	<NOUSAC!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

	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
;; ! %BI% USED TO BE $ACNO
	HLL	C,$VAL2(PNT2)	;TEXT ADDR (OF AOS IF THERE IS ONE)
	EMIT	(<JRST NOUSAC+USADDR>)
PRUPYU:
BAIL<
	MOVE	TEMP,PCNT
	HRRZ	LPSA,$VAL(PNT2)	;PD SEMBLK
	SKIPE	LPSA
	 HRLM	TEMP,$VAL2(LPSA);ADDR OF LAST WORD OF CODE TO PD SEMBLK
>;BAIL
	TLO	FF,ALLOCT	;***** ASSUME SAVES ACS
	PUSHJ	P,ALOT		;ALLOCATE THE STORAGE
	GETSEM	(2)		;PROC SEMANTICS BACK
	PUSHJ	P,LNKMAK	;PUT OUT STRING LINK BLOCK IF NECESSARY

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
	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
	HLRZ	A,%TLINK(TEMP) ;RIGHT TEMP,%TLINK,
	JUMPE	A,LPSERR	;   LPSERR
RGC <
	HLRZ	TEMP,%RVARB(A)	;RCTEMP LIST
	MOVEM	TEMP,RCTEMP
>;RGC
	MOVE	TEMP,%STEMP(A) ;GET PARTIAL CORE TEMP LIST BACK
	HRRZM	TEMP,TTEMP	;RESTORE TO RIGHTFUL POSITION
	SOS	NMLVL		;REDUCE DDT LEVEL
	SOS	LEVEL		;UP A LEVEL
	PUSHJ	P,CLRSET	;CLEAR OUT BITS
	TLNN	FF,CREFSW	;IF CREFFING, PUT OUT SYMBOLS FOR FORMALS.
	JRST	FREBUK		;RELEASE OLD BUCKET, RETURN
	HLRZ	LPSA,%TBUCK(LPSA)	; TO FIRST FORMAL.
CRFNO:	JUMPE	LPSA,FREBUK		;ALL DONE.
	PUSHJ	P,CREFDEF		;SYMBOL DEFINITION.
	HRRZ	LPSA,%RVARB(LPSA)
	JRST	CRFNO

Comment  FORWRD declarations come here to undo damage

at PD1:	PDNO ;   drarrow  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)
  -1(P)rh = # extra words for VALUE LONGS
 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
	ADD	A,-4(P)		;DONT FORGET VALUE LONGS
	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
;;%DN% JFR 7-4-76
	MOVEI	B,(A)		;LIKE WE PROMISED
	MOVNI	TEMP,(A)	;NEGATE FOR ADJSP
	HRLI	C,(TEMP)	;INTO DISPL. FIELD
	PUSHJ	P,EADJSP
;;	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
;;%DN% ^
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
	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
;;%DN%
	HRL	C,(P)		;COUNT
	PUSHJ	P,EADJSP	;ADJUST THE STACK
	MOVE	TEMP,ASWITCH
	TRNE	TEMP,AADJSP
	 JRST	BLTADN		;WE DID ADJSP, NO NEED FOR SKIPL AND PUSHJ $PDLOV
;;	MOVE	A,(P)		;GET THE COUNT INTO A
;;	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
	HRL	C,PCNT		;EMIT INSTR TO CAUSE PDLOV.
	EXCH	C,LIBTAB+R$PDLOV ;FIXUP
	EMIT	(<JSP USER,NOUSAC!USADDR>)
BLTADN:	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)
	POPJ	P,

;;%DN% ^

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 pnts to PD SEMBLK
	HLRZ	PNT,%TLINK(A)		;PNT ptr to 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
;;#  # (1 OF 2) BY JFR  THE JSFIX WAS MISSING
PPDAW:	EMIT	(<PUSH	RP,NOUSAC!JSFIX>)	;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 ptr to PD SEMBLK
;;#  # (2 OF 2) BY JFR  THE JSFIX WAS MISSING
	EMIT	(<HRLI JSFIX>)	;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

;;#VU# JFR 11-21-75 CANT USE THIS INFO BECAUSE APPLY MIGHT JUMP INTO MIDDLE
;;	AND THE REGISTER WOULD BE INVALID
;;	MOVE	B,CDLEV			;INTERNAL LEVEL
;;	SUBI	B,1			;DADDY
;;	PUSHJ	P,DISBLK		;LPSA ptr to DISPLAY SEMBLK
;;	HRRM	D,DISTAB(B)		;UPDATE DISTAB
;;#VU# ^
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,
 
COMMENT   TWPR1, TWPR2 -- Procedure Syntax  Twiddlers

DSCR TWPR1, TWPR2
PRO TWPR1, TWPR2
DES 
at IDL:	PDEC @IDL @I )  drarrow  PDEC   EXEC INTID ENDDEC TWPR2  SCAN
					   PD1  # Q0
at PD0:	PDEC @I ;  drarrow  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  drarrow  @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, ptr to procedure semantics
    2. In  %TBUCK, ptr to 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 pnts to NEW BLOCK
RDYCL:
;; #LJ# ALL LEAP ARGS MUST REALLY BE STACKED BEFORE PROCEDURE CALL
	PUSH	P,LPSA		;SAVE LPSA OVER OKSTACK
	PUSHJ	P,OKSTAC	;MAKE SURE EVERYTHING IS STACKED THAT SHOULD BE
	POP	P,LPSA		;RESTORE LPSA

	GETSEM	(1)		;PNT ptr to  SEMANTICS OF PROCEDURE
	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:
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)		;ptr to 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

;MESSAGE PROCEDURE STARTER.

^MESCL:
GLOC <
	SETOM	MESFLG		;NEXT FCALL IS A MESSAGE.
>;GLOC
NOGLOC <
	ERR	<This compiler will not handle MESSAGE PROCEDURES>,1
>;NOGLOC
	POPJ	P,
COMMENT   Describe CALARG

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

at EE2:	PCALL @E )  drarrow  S   EXEC CALARG ISUCAL  SCAN  S9
	FCALL @E )  drarrow  P  EXEC CALARG ISUCAL TYPPRO  SCAN  XID
	@CALL @E ,  drarrow  @CALL  EXEC CALARG   EX0
	IPR SG   drarrow  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
		TRZ	TBITS2,40	; TURN OFF DEFAULTABLE BIT
		 MOVE	TBITS2,BLTTBL(TBITS2)
		 JRST	BLTBAK		;CONTINUE AFTER SIMILAR BRANCH
]

	HRRZ	PNT2,%TLINK(SP)	;PNT2 pnts to  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) ;ptr to 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
REC <
	TRNE	TBITS2,PNTVAR	;CHECK RECORD CLASSES HERE
	TDNE	TBITS2,[XWD SBSCRP,ITEM!ITMVAR!SHORT]
				;DONT CHECK ARRAYS AND
				;NEVER CHECK ITEMISH STUFF(UNLESS CHECKED?)
	JRST	BLTB.1
	PUSH	P,LPSA		;PARANOIA
;;#YQ# JFR 2-3-77 LET ORDINARY INSIST TAKE CARE OF THIS IF POSSIBLE
	HLRZ	TEMP,$ACNO(PNT2);CLASS OF FORMAL
	HRRZM	TEMP,RCLASS	;ORDINARILY INSIST ON THIS
	HLRZ	TEMP,$ACNO(PNT)	;CLASS OF ACTUAL
;;#TV# RHT 1-22-75 DON'T CHECK IF RUNTIME ROUTINE
	MOVE	LPSA,$TBITS(SP)	;CHECK PROCEDURE SEMANTICS
	TLNE	LPSA,OWN	;IF RUNTIME ROUT, CLASS IS ANY
	 HRRZM	TEMP,RCLASS	;SO FAKE IT BY MAKING FORMAL LOOK LIKE ACTUAL
;;#TV# ^
;;#YQ# ^
	POP	P,LPSA
BLTB.1:
>;REC
	TLNE	TBITS2,REFRNC	;BY REFERENCE?
	 JRST	 REFARG		; YOU BETCHUM

	TLNE	TBITS2,MPBIND	;A FORMAL ? ITEMVAR
	JRST	MPPARM		;YES
; ***** 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
	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]
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
REC <
	TRNE	TBITS,PNTVAR		;A RECORD POINTER??
	TRNE	TBITS,777777-(PNTVAR!GLOBL)
	JRST	NOTRCD			;NOPE
NORGC <
	GENMOV	(GET,MRK!INDX)		;YEP,HAVE TO BUMP REF CNT. GET WILL DO IT
					;NOTE: IF THIS ALREADY WAS A REGULAR TEMP
					;THEN THE GET WILL NOT BUMP THE COUNT AGAIN
>;NORGC
RGC <
	TLNE	SBITS,INAC		;IS THE THING INAC
	JRST	STRT.1			;YES
;;#XT# ! MUST ALLOW FOR UP-LEVEL ADDRESSING
	GENMOV	(GET)
STRT.1:	HRRZ	D,$ACNO(PNT)		;FIND OUT WHAT AC ITS IN
	PUSHJ	P,GETRCT		;GET US AN AVAILABLE RECORD CORTMP
	HRRZ	TEMP,$ACNO(SP)		;SP POINTS AT PROC CALL SEM. (UGH!!)
	HRRM	TEMP,%TLINK(LPSA)	;LINK ONTO CHAIN
	HRRM	LPSA,$ACNO(SP)		;LIKE SO
	PUSH	P,PNT			;SAVE THE THING WE ARE GOING TO PUSH
	MOVE	PNT,LPSA		;NOW MOVEM INTO THIS TEMP
	EMIT	(<MOVEM>)		;
	POP	P,PNT			;SO THAT THE PUSH EVENTUALLY WINS
;;#YQ# ! JFR 2-3-77
	TRZ	FF,INSIST	;ALREADY DID.  KEEP RCLASS CHECKING HAPPY.
>;RGC
NOTRCD:
>;REC
	GENMOV	(STACK)			;DO THE PUSH.
	MOVEI	PNT,0			;SO WON'T REMOP TWICE
	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
;; #MA (1 OF 4) ! SAVE FF OVER CALL
	PUSH	P,FF
	MOVE	TEMP,$TBITS(SP)		;CONOK bit on in this Semblk (PCALL
	TLZN	TEMP,CONOK		; block) if calling runtime which can
;; #MA (2 OF 4) !
	 JRST	FBPOPJ			; 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
;; #MA (3 OF 4) !
	 JRST	 FBPOPJ			; 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
;;%DU%
	TRNE	TBITS,STRING		; Pcall Semblk -- will be used to readjust
	 ADDM	 TEMP,$VAL(SP)
;;	 AOSA	 $VAL(SP)		; these variables when call finished.
;;	TRNE	TBITS,ITEM!ITMVAR
;;	 JRST	.+3
;;	TRNE	TBITS,DBLPRC
;;	 AOS	$VAL(SP)
;;%DU% ^
	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.
;; #MA (4 OF 4) ! RESTORE FF
FBPOPJ:	POP	P,FF
BPOPJ:	POP	P,B
	POPJ	P,
MPPARM:				;BINDING ITEMVAR PARAMETER
	TRNN	TBITS,ITEM!ITMVAR	;BETTER BE ITEM TYPE
	ERR	<PARM TO  ? ITEMVAR NOT ITEM EXPRESSION>,1
	TLNE	PNT,FBIND!QBIND		;IS IT BIND ITEMVAR?
	JRST	PASREF			;WILL PASS BY REFERENCE
	TLNE	SBITS,LPFRCH!FREEBD
	TLNN	SBITS,LPFREE		;STILL FREE WITHIN FOREACH?
	JRST	VALPAR			;NO TREAT AS VALUE PARAMETER
NTPARM: QPUSH	(MPQSTK,PNT)		;PUT THIS ON PARM LIST
; AT THIS POINT GENERATE APPROPRIATE LPCALL FOR POTUNB IF NECESSARY.
;;#TJ# ! USED TO BE TBITS
	TLNE	SBITS,FREEBD
	JRST	[MOVE PNT,$VAL2(PNT)	;GET LOCAL NUMBER
		 GENMOV (STACK,0)
		 LPCALL (STKQPR)	;INTERPRETIVE CALL TO SEE IF BOUND
		 JRST CALRET]
PASREF:	PUSH	P,PNT			;SAV LH ACTUALLY
	GENMOV  (INCOR,0)		;MAKE SURE NOT IN AC
	HRLI	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
	POP	P,PNT
	TLNN	PNT,QBIND
	JRST	CALRET
	HRLZI	D,RP			;WILL NOW LOAD VAL FROM STACK
	EMIT	<MOVEI TAC1,INDRCT!NOUSAC!NOADDR!USX> ; GEN MOVEI TAC1,@(P)
	HRLI	C,UNBND			;FOR COMPARE WITH UNBOUND
	EMIT	<CAIE TAC1,NOUSAC!USADDR!NORLC>
	EMIT	<MOVEM TAC1,NOUSAC!NOADDR!USX>
	JRST	CALRET

; 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
	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
; #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:	
;;%AE% RHT ALLOW TYPED ITEMVARS THROUGH TO ITEMVAR FORMALS
	TRNE	TBITS2,ITMVAR		;ITEMVAR FORMAL
	TRNE	TBITS2,<ITMVAR+PROCED>	;ANYTHING ELSE TOO
	JRST	.+2			;NO CHANGE
	TRZ	TBITS,<ITMVAR+PROCED>	;TURN OFF THE BAD GUYS
;;%AE%
	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
;;#??# RHT WHAT IS GOING ON HERE?????
		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    ]


;; \UR#12\ NEED ITEMVAR ACTUAL FOR ITEMVAR FORMAL
IFN 0,<   ; THIS FIX SCREWS UP ARRYIN,ARRBLT,ARROUT. SO REMOVE FOR NOW
;; MUST INSIST THAT ITEMVAR FORMAL RECEIVE ITEMVAR ACTUAL
	TRNE	TBITS2,ITMVAR
        JRST	[ TRNN TBITS,ITMVAR
		  ERR <ITEMVAR FORMAL NEEDS ITEMVAR ACTUAL>,1
		  JRST .+1 ]
;; MUST INSIST THAT CONTEXT FORMAL HAVE CONTEXT ACTUAL
        TRNE    TBITS2,SET
        JRST    [ TRNN TBITS,SET
                  JRST RTYPER
                  TRNN TBITS2,FLOTNG
                  JRST .+1
                  TRNN TBITS,FLOTNG
                  ERR <CONTEXT FORMAL NEEDS CONTEXT ACTUAL PARAM>,1
                  JRST .+1]
;; END OF PATCH
>;IFN 0
;; \UR#12\
	MOVE	B,TBITS		;ALGORITHM IS TO MAKE SURE THAT ALL BITS
	AND	B,[XWD SBSCRP,ALTYPS]	;ON IN ACTUAL ARE ON IN FORMAL.
;;#YI# JFR 1-13-77 IF USER PROCEDURE THEN BE MORE CAREFUL
	MOVE	TEMP,$TBITS(SP)	;BITS FOR THE PROCEDURE
	TLNN	TEMP,OWN
	 JRST	[MOVE	TEMP,TBITS2	;USER PROC.
		AND	TEMP,[XWD SBSCRP,ALTYPS]
		XOR	TEMP,B
		JUMPE	TEMP,MAKADR	;ALL THE IMPORTANT BITS MATCH
		JRST	RTYPER]		;DONT MATCH
;;#YI# ^
	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)
;;%DT% FORTRAN-10 WANTS 2 FOR INTEGR, 4 FOR FLOTNG
	TRNN	TBITS2,FORTRAN
	 JRST	.+3		;NOT FORTRAN
	SKIPE	TEMP,ASWITCH
	TRNN	TEMP,ASWF10
	 TDZA	TEMP,TEMP	;NOT FORTRAN-10, START AT ZERO
	MOVEI	TEMP,2		;FORTRAN-10, ADD 2
;;%DT% ^
	TRNE	TBITS,FLOTNG	;0 FOR INTEGR, 2 FOR FLOATING,
	ADDI	TEMP,2
	TRNE	TBITS,DBLPRC
	ADDI	TEMP,4		;+4 FOR DOUBLE (GIVING 6 FOR LONG REAL)
	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 ptr to  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
	TLNE	TBITS2,REFRNC		;SUBTRACT RIGHT AMOUNT FROM RIGHT STACK
	 JRST	CALR.1			;REF ANYTHING USES 1 ADEPTH
	TRNN	TBITS2,STRING
	 JRST	.+3
	SOS	SDEPTH			;VALUE STRING
	SOSA	SDEPTH
	SOS	ADEPTH
	TRNN	TBITS2,ITEM!ITMVAR
	TRNN	TBITS2,DBLPRC
	 SKIPA
CALR.1:	 SOS	ADEPTH			;VALUE DOUBLE (OR IF BY JUMP, REF ANY)
	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
;;%DU%	CAME	A,ADEPTH		;SAME AS NOW (WAS THERE A PUSH DONE??)
;;	AOS	$VAL(SP)		;NO -- UPDATE COUNTS.
	MOVNI	A,(A)
	ADD	A,ADEPTH
	ADDM	A,$VAL(SP)	;UPDATE COUNT OF HOW MANY PUSH'ED
;;%DU% ^
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
	TRNE	SBITS,DLFLDM	;IF A DISPLAY REG IS NEEDED
	JRST	DYNAMAK		;MUST DO DYNAMAK
;; #KD# ! RHT 11-13-72 FOLLOWING INSTR HAD SBITS MISSING
	TLNE	SBITS,CORTMP	;ALSO CHECK THE CASE OF TEMPS IN REC PRO
	SKIPN	RECSW		;
	JRST	.+2		;
	JRST	DYNAMAK		;
NOREC <
	TRNE	TBITS,PNTVAR	;DON'T REALLY UNDERSTAND THESE YET
	 ERR	 <POINTER VARS MAY NOT BE CALLED BY REFERENCE>,1
>;NOREC
	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) ;ptr to 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



	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:
;;%DT%
	SKIPN	TEMP,MPFLAG	;DON'T CHANGE INSTR IF LEAP CALL: MPFLAG IS SETZM/SETOM
	SKIPE	TEMP,ASWITCH	;FORTRAN CALL, WHICH KIND?
	TRNN	TEMP,ASWF10	;ALWAYS SKIPS IF LEAP
	 TLO	C,(<JUMP>)	;F40 CALL PUTS 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
	PUSH	P,TBITS		;JUST IN CASE
	PUSH	P,SBITS
	MOVEI	TBITS,INTEGR
	PUSHJ	P,GETCRTMP	;A CORETEMP FOR THE COMPUTED ADDRESS
	MOVEI	PNT,(LPSA)
	EMIT	(<MOVEM>)	;STORE THE ADDRESS
	POP	P,SBITS
	POP	P,TBITS
	IOR	PNT,C		;COPY BITS
	TLO	PNT,400000	;AND MARK LH NEG
;;%DT% ^
	POPJ	P,
COMMENT   ISUCAL -- Call the Procedure, Mark Resultant Type, etc.

DSCR ISUCAL, ISUCL1
PRO ISUCAL ISUCL1
RES
	PCALL @E )   drarrow   S	EXEC CALARG ISUCAL  SCAN  GO S9
	FCALL @E )   drarrow   P	EXEC CALARG ISUCAL  TYPPRO  SCAN  GO XID
	IPR SG       drarrow   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.

BICHK:	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	[MOVE	B,$VAL2(PNT) ;YES, GET NEXT PARAM DSCRPTR
		ILDB	TEMP,$VAL2(PNT)	; SO CAN RESTORE
		 JUMPE	TEMP,OKCAL	;SHOULD BE 0 (NONE LEFT)
		TRZN	TEMP,40		;DEFAULTABLE?
		JRST	ERCAL		;NO
		MOVE	TBITS,BLTTBL(TEMP);TBITS OF THIS ARG
		TLNN	TBITS,VALUE	;REF NEVER DEFAULTED
		JRST	ERCAL
		PUSH	P,PNT		;SAVE PNT
		MOVEI	A,0		;COMMON NULL VALUE
		MOVE	PNT,UBSBLK	;
		TRNE	TBITS,ITMVAR	;ITEMVARS ARE SET TO NEC
		JRST	SFFPRM
		TRNE	TBITS,STRING	; A STRING GETS A NULL STRING
		JRST	NSTVP		;
		PUSHJ	P,CREINT	;
	SFFPRM:	MOVE	TEMP,PNT	;
		MOVE	PNT,(P)		;THE PROCID
		MOVEM	B,$VAL2(PNT)
		JRST	PCA1		;GO PUSH THE CONST ARG
	NSTVP:	PUSH	P,BITS		;SAVE SOME CRUFT
		PUSH	SP,PNAME	;
		PUSH	SP,PNAME+1	;
		SETZM	PNAME		;NULL
		PUSHJ	P,STRINS	;MAKE ONE
		POP	SP,PNAME+1	;
		POP	SP,PNAME	;PUT EM BACK
		POP	P,BITS		;
		JRST	SFFPRM		;GO STACK IT
]

	RIGHT	PNT,%TBUCK,OKCAL ;MAKE SURE FORMAL LIST IS EMPTY
	HRRZ	TEMP,$VAL2(LPSA)	;GET DEFAULT VALUE , IF ANY
	JUMPE	TEMP,ERCAL		;YOU LOSE
PCA:	PUSH	P,PNT			;SAVE
PCA1:	PUSH	P,GENLEF+1		;
	PUSH	P,GENLEF+2		;
	MOVEM	TEMP,GENLEF+1		;
	MOVEM	PNT,GENLEF+2		;
;;#WL# JFR 3-16-76 BUMP REF CNT OF STRING DEFAULT PARAM SO REMOP WONT DRYROT
	MOVEI	PNT,(TEMP)
	PUSHJ	P,GETAD
	TRNN	TBITS,ITEM!ITMVAR
	TRNN	TBITS,STRING
	 JRST	.+2
	AOS	$VAL2(PNT)
;;#WL# ^
	PUSHJ	P,CALARG		;OH, WHAT A DREADFUL THING TO DO
	POP	P,GENLEF+2		;
	POP	P,GENLEF+1		;
	POP	P,PNT			;PUT EM BACK THE WAY THEY WAS
;;#NH# RHT 7-25-73 1 OF 1 THE THINGS ON THE STACK WERE CHANGED BY CALARG
	SUB	P,X22
	JRST	ISSUE			;TRY AGAIN
;;#NH#

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
NORGC <
OKCAL:	HRRZ	LPSA,PNT	;RELEASE CALL BLOCK,
	HLRZ	PNT,%TLINK(PNT)	;  GET SEMANTICS OF PROC
>;NORGC
RGC <
OKCAL:	PUSH	P,PNT	
	HRRZ	PNT,$ACNO(PNT)		;FETCH THE THINGS TO REMOP
	JUMPE	PNT,OKCA.1		;NONE LEFT
OKCA.0:	EMIT	<SETZM NOUSAC>		;ZERO IT OUT
	MOVE	LPSA,PNT		;
	HRRZ	PNT,%TLINK(PNT)		;GET NEXT
	PUSHJ	P,REMOPL		;
	JUMPN	PNT,OKCA.0		;LIKE SO
OKCA.1:	POP	P,LPSA			;FOR THE FREBLK
	HLRZ	PNT,%TLINK(LPSA)	;PROC CALL SEMANTICS
>;RGC
	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
;;#TO# ! (2-2) RHT 10-27-74 (USED TO BE INTEGR+FLOTNG)
	TRNE	TBITS,SNGTYP	;DEFINED IN SAIL/13
	 JRST	[PUSHJ	 P,STORZ	;DO IT IF TYPED ARITH PROC.
		MOVEI	D,2
		TRNN	TBITS,ITEM!ITMVAR
		TRNN	TBITS,DBLPRC
		 SKIPA
		 PUSHJ	P,STORZ		;STORE AC2 IF DOUBLE TYPE
		SOJA	D,.+1]	;KEEP D AT 1
	TLNN	TBITS,BILTIN	;UNLESS BUILTIN PROC.
	 PUSHJ	 P,ALLSTO	;STORE THE REST.
DPUSHJ:

;;  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:
;;%DT% JFR 8-22-76
	SKIPE	TEMP,ASWITCH
	TRNN	TEMP,ASWF10
	 JRST	CALF.1		;NOT FORTRAN-10
	SKIPN	B,-1(P)		;FTRPRM PTR
	 ERR	<DRYROT -- FTRCAL>;NOT THERE
	MOVEI	C,0		;COUNT PARAMS
CALF.2:	QTAKE	(FTRPRM)
	 JRST	.+2
	AOJA	C,CALF.2
	PUSH	P,C		;SAVE # PARAMS
	HRLI	C,RSP
	EMIT	(<PUSH RP,NOUSAC!USADDR!NORLC>)	;NEED TO SAVE SP
	AOS	ADEPTH
	MOVE	C,PCNT
	ADDI	C,4
	MOVSI	C,(C)
	EMIT	(<MOVEI RSP,NOUSAC!USADDR>)	;MOVEI 16,.+4
	EMIT	(<PUSHJ RP,NOUSAC>)	;PUSHJ P,ROUTINE
	MOVE	C,(P)		;# PARAMS
	ADD	C,PCNT
	ADDI	C,2
	MOVSI	C,(C)
	EMIT	(<JRST NOUSAC!USADDR>)	;JRST AROUND ADDRESS BLOCK
	POP	P,A		;# PARAMS
	MOVNI	A,(A)
	MOVSI	A,(A)
	PUSHJ	P,CODOUT	;-N,,0
	JRST	CALF.3
CALF.1:	EMIT	(<JSA 16,NOUSAC>) ;JSA 16,ROUTINE
CALF.3:
;;%DT% ^
	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
;;%DT%
	SKIPE	TEMP,ASWITCH
	TRNN	TEMP,ASWF10
	TLO	A,(<JUMP>)	;F40 ONLY
	TRO	A,NOUSAC	;BOTH
;;%DT% ^
	PUSHJ	P,EMITER	;JUMP TYP,ADDR
	PUSHJ	P,REMOP		;GET RID OF IT
	POP	P,A		;GET POINTER BACK
	HRRZ	LPSA,A		;ptr to 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:
;;%DT%
	MOVEI	PNT,(A)		;ADDR OF SEMBLK OF CORE TEMP FOR ADDRESS
	TLC	A,400020	;REMOVE FLAG, INSERT @
	HRRI	A,NOUSAC
	PUSHJ	P,EMITER	;BITS,@TEMP
	PUSHJ	P,REMOP		;NO LONGER NEED TEMP
	POP	P,B		;UPDATED QSTACK PTR
;;%DT% ^
	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
;; #QG# TOKEN BEING PLACED IN WRONG LOC WHEN NO PARAMS
	MOVE	PNT,PNT2	;TO BE REPLACED IN PARSE STACK
	HLRZ	PNT2,%TLINK(PNT) ;SECOND PROCEDURE BLOCK
	MOVE	PNT2,$NPRMS(PNT2)	;ANY PARAMETERS
	CAMN	PNT2,[XWD 1,0]
	JRST	[MOVEM TEMP,PARRIG+1 ;NO PARAMETERS WAS AN ISUCL1
		 JRST  MRKDN]
;; #QG#
	MOVEM	TEMP,PARRIG	;TELL THE PARSER
	JRST	MRKDN		;FINI
ISTYPD:
REC <
	TRNE	TBITS2,PNTVAR			;A POINTER PROCEDURE
	TRNE	TBITS2,ITEM!ITMVAR		;THESE ARE DIFFERENT
	JRST	NOTPPP				;NOPE
	HLRZ	TEMP,$ACNO(PNT2)		;REMEMBER CLASS ID FOR MARK
	MOVEM	TEMP,RCLASS			;NEXT MARK WILL DO THIS
NOTPPP:
>;REC
;;%DT%
	SKIPE	TEMP,ASWITCH
;;#XQ# ! JFR 10-21-76 TEST FOR FROTRAN PROC
	TRNE	TBITS2,FORTRAN
	TRNN	TEMP,ASWF10
	 JRST	NF10.1
	MOVSI	C,RSP
	EMIT	(<POP RP,NOUSAC!USADDR!NORLC>)
	SOS	ADEPTH
NF10.1:
;;%DT% ^
;;#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,


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

DSCR RESULTS, RESLT1
PRO RESULT RESLT1
DES 
at RT0:	  SG ;  drarrow  S ;		EXEC RESLT1      S9
   EE2:	RETURN ( @E )  drarrow  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)		;GEQ 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,ALTYPSPROCED	;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,ALTYPSPROCED	;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 ptr to  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
;;%DN% JFR 7-2-76
	HRLI	C,(TEMP)
	PUSHJ	P,ESPADJ
;;	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
;;%DN% ^
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
;;#YQ# 3! JFR 2-2-77 SET UP RCLASS IF RPTR PROC
	HLRZ	B,$ACNO(PNT2)		;RCLASS LIST, IF ANY
	TRNE	TBITS2,PNTVAR
	 HRRZM	B,RCLASS
	HRRZ	B,TBITS2		;TYPE CONVERSION IF NECESSARY
;; #JT# BY JRL 10-21-72 COPY SET TO BE RETURNED
	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
;; #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
COMMENT DFVPV -- exec for default param values 

ZERODATA();
PBITTS:	0			;SAVE PARAM BITS HERE
ENDDATA

^DFVPV0:	MOVE	A,BITS			;
	MOVEM	A,PBITTS		;SAVE THE BITS
	POPJ	P,

^DFVPV:	MOVE	PNT,VARB		;THE MOST RECENT FORMAL ON VARB 
DFV.01:	PUSHJ	P,GETAD			;RING
	TLNE	TBITS,FORMAL		;
	JRST	GOTVCT
	HRRZ	PNT,%RVARB(PNT)		;
	JUMPN	PNT,DFV.01		;
	ERR	<DRYROT IN DFVPV, CAN CONTINUE>,1;
	JRST	DFV.2			;
GOTVCT:	TLNE	TBITS,REFRNC		;
	ERR	<DEFAULT VALUES FOR REF PARAMS IS A VERY BAD IDEA>,1
	MOVE	PNT2,GENLEF+1		;THE VALUE
	HRRM	PNT2,$VAL2(PNT)		;
DFV.2:	MOVE	A,PBITTS		;PUT BITS BACK
	MOVEM	A,BITS
	POPJ	P,
; CLNSET

^CLNSET:
	MOVE	PNT,TTOP	;CURRENT BLOCK
	HLRZ	PNT2,%TLINK(PNT)	;SECOND SEMBLK
	JUMPN	PNT2,CLNS.1		;HAVE ONE
	GETBLK				;GET ONE
	HRLM	LPSA,%TLINK(PNT)	;SAVE IT
	HRRZ	PNT2,LPSA		;
CLNS.1:	MOVE	A,GENLEF+1		;PROC SEMBLK
	HLRZ	B,%TLINK(A)		;SECOND BLOCK
	MOVSI	C,1			;STACK DISPLS FOR 0 PARS
	CAME	C,$NPRMS(B)		;BETTER HAVE NO PARAMS
	ERR	<CANNOT USE A PROC WITH PARAMS FOR CLEANUP>,1
	QPUSH	(<$ACNO(PNT2)>)		;REMEMBER
	MOVEI	A,SET			;SO GO TO SOLVER WORKS
	ORM	A,$VAL(PNT)		;
	POPJ	P,
DSCR	Execs for PRINT and CPRINT statements.


	The PRINT and CPRINT statements allow an arbitrary number
of expressions to be formatting according to expression and printed
out to the teletype or other device.  Each expression is converted
to a string by a formatting function (either the standard one or one
supplied by the user) then is printed out to the teletype, file, both,
or to a user-specified function which can do anything.
	The expected syntax is either

	PRINT(e1,e2, ... , en)

or

	CPRINT(chan,e1,e2, ... , en)

The PRINT statement prints out to the Teletype or whatever is specified
by the SETPRINT statement.  The CPRINT statement goes to the channel
specified by the first integer argument.  Both of these constructions
occur as statements, and both are parsed.
	The EXEC functions here (1) initialize the printing by pushing
the channel number for CPRINT or -1 for PRINT onto the stack, done
by STRTPT for PRINT or STCTPT for CPRINT; (2) printing out each argument
by a call on the appropriate runtime, using the syntactic type of
the expression as a key to which function is used; (3) closing off
the PRINT or CPRINT statement by removing the channel argument, which
remains on the stack during the entire operation.  Note that the
calling sequence is therefore divergent from the classical SAIL sequence.
	Currently, only scalars of each type (INTEGER, REAL, RECORD!POINTER)
are allowed.  Adding arrays is a possible extension.


;start the PRINT statement
^STRTPT:	
	SETO	A,			;USE -1
	PUSHJ	P,CREINT		;AS A CHANNEL TO INDICATE TELETYPE
STRTP1:	SETZB	C,D
	EMIT	(<PUSH RP,NOUSAC>)
;;#VW#  (1 OF 2)  STACK NOT ADJUSTED FOR PRINT RLS 12-6-75
	AOS	ADEPTH			;RECORD CHANGE OF STACK
	POPJ	P,

;start the CPRINT statement
^STCPRT:
	GETSEM	(1)			;CHANNEL ARGUMENT
	GENMOV	(CONV,INSIST,INTEGR)	;MAKE IT INTEGER
	JRST	STRTP1			;AND USE THIS AS THE CHANNEL

;make subroutine call to appropriate function
^DOPRT:
	GETSEM	(1)
	TLNE	TBITS,SBSCRP		;ARRAY?
	  ERR	<PRINT not defined for arrays>,1
	SETZ	TEMP,			;ASSUME ERROR
	TRNN	TBITS,ITEM!ITMVAR	;SOME ITEM EXPRESSION
	  JRST	NOTITM
	MOVEI	TEMP,.$PITM
	JRST	DOPRT1
NOTITM:
	TRNE	TBITS,SET
	TRNN	TBITS,LSTBIT		;IS IT A LIST SOMEHOW?
	  JRST	NOTLST			;NO
	MOVEI	TEMP,.$PLST		;YES
	JRST	DOPRT1
NOTLST:
	TRNN	TBITS,DBLPRC
	 JRST	NOTDBL
	TRNE	TBITS,FLOTNG
	  MOVEI	TEMP,.$PLRL
	JRST	DOPRT1
NOTDBL:
	TRNE	TBITS,INTEGR		;USE CVS(X) FOR INTEGER
	  MOVEI	TEMP,.$PINT
	TRNE	TBITS,PNTVAR
	  MOVEI	TEMP,.$PREC
	TRNE	TBITS,STRING		;JUST PRINT A STRING
	  MOVEI	TEMP,.$PSTR
	TRNE	TBITS,FLOTNG		;CVG(X) FOR REAL ARGUMENT
	  MOVEI	TEMP,.$PREL
	TRNE	TBITS,SET		;SETS GET PRINTED {IT, ...~
	  MOVEI	TEMP,.$PSET

DOPRT1:	SKIPN	TEMP			;A LEGAL PRINT ARGUMENT?
	  ERR	<Can't PRINT this syntactic type>,1

;HERE TO SIMULATE PARSING OF A PROCEDURE CALL FOR PRINT,
;PROCEDURE DESCRIPTOR IS IN TEMP

PRTCAL:	PUSH	P,GENLEF+1		;SAVE ARGUMENT
	MOVEM	TEMP,GENLEF+1		;PROCEDURE TO CALL
	PUSHJ	P,RDYCL1		;PREPARE
	MOVEW	<GENLEF+2>,<GENRIG+1>	
	POP	P,GENLEF+1
	PUSHJ	P,CALARG		;NOW SEND ARGUMENT
	JRST	ISUCAL			;AND FINALLY THE CALL


;finish up a PRINT or CPRINT sequence
^ENDPRT:
;;%DN% JFR 8-17-76 POSSIBLY USE ADJSP
	SOS	ADEPTH
	HRLI	C,-1		;REMOVE 1 EL
	JRST	EPADJ		;FROM P STACK
;;	MOVE	A,X11
;;	PUSHJ	P,CREINT		;CREATE AN INTEGER XWD 1,1
;;	SETZB	C,D
;;	EMIT	(<SUB RP,NOUSAC>)	;NOW ADJUST USER'S STACK AFTER PRINT
;;#VX# STACK NOT ADJUSTED FOR PRINT  RLS 12-6-75
;;	SOS	ADEPTH			;AND MARK THAT STACK RESET
;;	POPJ	P,
;;%DN% ^
	BEND	PROCED