Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-03 - decus/20-0078/comp/or.mac
There are 2 other files named or.mac in the archive. Click here to see a list.
00100		SALL
00200	COMMENT;
00300	AUTHOR:			STEFAN ARNBORG 15-MAY-1973
00400	
00500	VERSION:		4	[3,30,40,134,174,216,321]
00600	
00700	PURPOSE:		TO REPLACE OPERANDS IN THE OPERAND STACK
00800				BY THE RESULT OPERATOR AFTER CHECKING ITS OPERANDS
00900				THE OPERANDS ARE MOVED TO THE EXPRESSION TREE AREA
01000	
01100	CONTENTS:		A ROUTINE OREN DOING MOST OF THE COMMON PROCESSING OF
01200				OPERATORS, AND INDIVIDUAL ROUTINES FOR SPECIAL OPERATORS.
01300				A ROUTINE FOR MOVING OPERANDS, ORMV
01400	
01500	;
01600		SEARCH	SIMMAC,SIMMC2
01700		CTITLE	OR
01800	; GLOBAL ROUTINES
01900		EXTERN	CABSTU,CGCA,CGPU,CGAD,CGCC,CGCO,CGIM,CGIM1,CGLO,CGLO1,CAUSTD
02000		EXTERN	CGMO,CGMO1,CGVA,O2AD,O2GI,O2GWD,O2LN1
02100		EXTERN	CADS,CGG2,CGG3,CGG4,CGR2,CGR3,CGR4,O2CF,O2GA,O2GF,O2GR,O2GW
02200		EXTERN	CACO,CADISP,CARL,CAUD,CGEN,O2DF,O2IV,O2RF
02300		EXTERN	CAUNPR	;[40]
02400		EXTERN	ORTXCH	;[174]
02500		EXTERN	ORDT,ORLU,ORRP,ORSM,ORCC,ORBU,ORCT,ORTY,ORCN
02600		INTERN	OREN,ORMV
02700		OPDEF	UNDISP	[PUSHJ	XPDP,CAUD]
02800	; GLOBAL VARIABLES
02900		DSW	SPAREN,YORPAR,36
03000		EXTERN	YORLID,YCGSWC,YBKST,YBKSTP,YEXPP,YFOP,YFORSI,YPROCI,YNOPD,YNZCN,YNZID,YNZNS
03100		EXTERN	YOPST,YOPSTB,YOPSTP,YORACT,YORFOR,YORFX,YORZHB,YORZQU
03200		EXTERN	YORPAR,YRDSTP,YSTEPP,YZHBXC,YZHET
03300		EXTERN	YEXPL,O2AB,YUNDEC,YCALID,YDCSTP
03400	; MACRO USED FOR CODEWORD TABLE EXPANSION
03500		DEFINE	OPTAB(N,V,D1,D2)=<
03600			IFG <SYMBL2-V>,<
03700		REPEAT <V-$$LC>,<Z>
03800				IFNDEF	$'N,<Z>
03900				IFDEF	$'N,<$'N>
04000				$$LC=V+1
04100			>
04200		>
04300	; MACRO USED FOR SHIFTING FIELDS OF THE CODE WORDS INTO REGISTER XP1
04400		DEFINE	SHIFT(B)=<
04500			IFNDEF	$$SCT,<
04600				$$SCT=-1
04700			>
04800			%2=B-$$SCT
04900			LSHC	XP1,%2
05000			$$SCT=B
05100		>
     
00100	; MACRO USED FOR CODEWORD DEFINITION
00200	DEFINE	ORCOD(SYMBL,NOCODE,OPERANDS,SIMPLE,OPDCON,OPDCHK,RESTYP,CONAR,COMMUT,REVERS,NOMOV)=<
00300		$$SCT=<NOCODE>B<%NOCODE>+<OPERANDS>B<%OPERANDS>+<SIMPLE>B<%SIMPLE>
00400		$$SCT=$$SCT+<CONAR>B<%CONAR>+<COMMUT>B<%COMMUT>+<NOMOV>B<%NOMOV>+<REVERS>B<%REVERS>
00500		$$SCT=$$SCT+<OPDCON>B<%OPDCON>+<OPDCHK>B<%OPDCHK>+<RESTYP>B<%RESTYP>
00600		; SET DEFAULT ARGUMENTS (I.E. BLANK ARGUMENTS IN THIS CLEVER ASSEMBLER)
00700		IFB <OPERANDS>,<$$SCT=$$SCT+<2>B<%OPERANDS>>
00800		IFB <SIMPLE>,<$$SCT=$$SCT+<1>B<%SIMPLE>>
00900		IFB <OPDCON>,<$$SCT=$$SCT+<QCHIGH>B<%OPDCON>>
01000		IFB <OPDCHK>,<$$SCT=$$SCT+<QARITH>B<%OPDCHK>>
01100		IFB <RESTYP>,<$$SCT=$$SCT+<QRSAME>B<%RESTYP>>
01200		IFB <NOMOV>,<$$SCT=$$SCT+<$NOMOV>B<%NOMOV>>
01300		IFDEF SYMBL'.,<
01400			$'SYMBL=<<$$SCT>+SYMBL'.-OREN>
01500		>
01600		IFNDEF SYMBL'.,<
01700			$'SYMBL=$$SCT
01800		>
01900	>
     
00100	; POSITIONS OF LAST BITS IN CODE WORD FIELDS
00200	%NOCODE=0
00300	%OPERAND=%NOCODE+2
00400	%SIMPLE=%OPERAND+1
00500	%OPDCON=%SIMPLE+3
00600	%OPDCHK=%OPDCON+4
00700	%RESTYP=%OPDCHK+4
00800	%CONAR=%RESTYP+1
00900	%COMMUT=%CONAR+1
01000	%REVERS=%COMMUT+1
01100	%NOMOV=%REVERS+1
01200	$$SCT=-1
01300	$$LC=0
01400	$NOMOV=0
01500	TWOSEG
01600	CGINIT
01700	MACINIT
01800	RELOC	400K
     
00100	COMMENT;
00200	PURPOSE:		DO COMMON PROCESSING OF OPERATORS EXCEPT %DOT AND %RP
00300	ENTRY:			OREN
00400	NORMAL EXIT:		M2EN (BY RETURN), ORDT, ORRP
00500	ERROR EXIT:		NONE
00600	I/O PERFORMED:		NO
00700	USED ROUTINES:		ORDT,ORRP,ORCH,ORCS,ORLU,ORBU
00800	ERRORS GENERATED:	YES, LOTS OF
00900	ENTRY CONDITION:	THE CURRENT OPERATOR SYMBOL IS IN XCUR
01000				AND ITS OPERANDS ARE IN THE OPERAND STACK.
01100	EXIT ASSERTION:		WHEN RETURNING TO THE MAIN SCAN ALL OPERANDS OF THE
01200				OPERATOR HAVE BEEN CHECKED FOR NUMBER, TYPE, KIND.
01300				IF THE OPERATOR MUST BE THE ROOT OF A COMPILABLE CONSTRUCTION
01400				THE CONSTRUCTION HAS BEEN COMPILED.
01500	ABNORMAL EXIT:		EXIT TO O2AB AND PASS 3 IF A PROCEDURE OR CLASS ENTERED CAN NOT BE
01600				FOUND
01700	;
01800		SUBTTL	OREN
01900	OREN:	; START PROCEDURE
02000		IN.=OREN	; THIS IS FOR THE CLEVER GUY WHO HAS ADDED
02100				; IN. AS AN OPERATOR IN MACRO 10
02200		ASSERT<
02300			SKIPGE	XCUR
02400			 RFAIL	NEGATIVE SYMBOL VALUE IN OREN
02500			CAIL	XCUR,SYMBL3
02600			 RFAIL	NOT OPERATOR SYMBOL IN OREN
02700		>
02800		SETZM	YNZCN
02900		SETZM	YNZID
03000		SETZM	YNZNS
03100		SETZB	XP1,YNOPD
03200		SETOFF	SPAREN
03300		IF	; CODEWORD IS NEGATIVE: NO PROCESSING HERE
03400			SKIPL	XP2,CODEWORD(XCUR)
03500			GOTO	FALSE
03600		THEN
03700			CAIN	XCUR,%RP
03800			BRANCH	ORRP		; RIGHT BRACKET OR PARENTHESIS
03900			CAIN	XCUR,%DOT
04000			BRANCH	ORDT		; REMOTE ACCESS
04100			RFAIL	INVALID SYMBOL IN OREN
04200		FI
     
00100	; NORMAL OR PROCESSING
00200	; SET YFOP TO FIRST OPERAND
00300	; AND YSTEPP TO INCREMENT VARIABLE
00400		SHIFT	%OPERANDS	; NUMBER OF OPERANDS TO XP1 (0 MEANS ALL STACK OPNDS)
00500		IF	; XP1=0
00600			JUMPN	XP1,FALSE	
00700		THEN	; TAKE ALL OPERANDS
00800			LI	YOPST
00900			ST	YFOP
01000		ELSE
01100			ADD	XP1,XP1	; DOUBLE
01200			HRRZ	YOPSTP
01300			SUB	XP1
01400			ADDI	1
01500			ST	YFOP
01600		FI
01700	; COMPUTE YSTEPP FOR OPERATIONS STEPPING THROUGH OPERANDS
01800		HRL			; FIRSTOP,,FIRSTOP
01900		HRLZ	XP1,YOPSTP	; LASTOP+1,,0
02000		SUBM	XP1		; -<NUMBEROPS*2-1>,,FIRSTOP
02100		ST	XP1,YSTEPP
02200	
02300	; LOOK UP ZLI OPERANDS AND SET UP OPERAND COUNTERS
02400		LOOP
02500			AOS	YNOPD	; NUMBER OPERANDS
02600			LF	X1,ZNOTYP(XP1)
02700			; THE NEXT LITERAL IS INDEXED BY X1
02800			XCT	[RFAI	[ASCIZ/ZOS OPERAND IN STACK NOT SEEN BY RB/]
02900				GOTO	[AOS	YNZID	; ZLI OPERAND
03000					EXEC	ORLU
03100					GOTO	.+1]		; OUTSIDE LITERALS
03200				AOS	YNZCN
03300				AOS	YNZID
03400				AOS	YNZNS
03500				RFAI	[ASCIZ/ZNN NODE IN OPERAND STACK/]
03600				](X1)
03700		AS	STEPJ	XP1,ZID,TRUE
03800		SA
     
00100	; CHECK OPERAND KINDS
00200		IF	; ALL OPERANDS MUST BE SIMPLE
00300			TLZN	XP2,400K
00400			GOTO	FALSE
00500		THEN
00600			L	XP1,YSTEPP
00700			LOOP
00800				EXEC	ORSM
00900			AS
01000				STEPJ	XP1,ZCN,TRUE
01100			SA
01200		ELSE
01300			; INDIVIDUAL CHECK FOR SYMBOLS
01400			; THIS, WHEDO, NEW, IS, IN
01500			IF	; LAST OPERAND KIND MUST BE CLASS
01600				; SIDE EFFECT: XP1 WILL POINT TO LAST OPERAND IF
01700				; CONDITION IS SATISFIED
01800				L	XP1,YFOP
01900				CAIN	XCUR,%THIS
02000				GOTO	TRUE
02100				CAIN	XCUR,%WHEDO
02200				GOTO	TRUE
02300				STEP	XP1,ZNS
02400				CAIN	XCUR,%QUA
02500				GOTO	TRUE
02600				CAIN	XCUR,%IS
02700				GOTO	TRUE
02800				CAIN	XCUR,%IN
02900				GOTO	TRUE
03000				CAIE	XCUR,%NEW
03100				GOTO	FALSE
03200				SUBI	XP1,ZNS%S
03300				WHEN	XP1,ZID
03400				GOTO	TRUE
03500				LF	XP1,ZNSZNO(XP1)	;[134]GO DOWN FROM %PCALL NODE
03600			THEN
03700				LF()	ZIDKND(XP1)	; LAST OPERAND KIND
03800				IF	; NOT KIND CLASS OR UNDEFINED
03900					CAIE	QCLASS
04000					CAIN	QUNDEF
04100					GOTO	FALSE
04200				THEN	ERROR1	10,XCUR,IDENTIFIER AFTER %OPT IS NOT CLASS
04300					;[134]SET NODE TO UNDEFINED
04400					CAIN	XCUR,%NEW
04500					 L	XP1,YFOP	;IN CASE OF PARAMETERS
04600					SETF	QZID,ZNOTYP(XP1)
04700					SETF	QUNDEF,ZIDKND(XP1)
04800					SETF	QUNDEF,ZIDTYP(XP1)
04900					SETF	YUNDEC,ZIDZQU(XP1)
05000					SETF	YUNDEC,ZIDZDE(XP1)
05100				FI
05200				IF	; XCUR: IN or IS or QUA
05300					CAMN	XP1,YFOP
05400					GOTO	FALSE
05500				THEN
05600					L	XP1,YFOP
05700					EXEC	ORSM	; First operand of IS and IN must be simple
05800				FI
05900			FI
06000		FI
     
00100	; TYPE CONVERSION AND ERROR CHECKING
00200		SETZ	XP1,
00300		SHIFT	%OPDCON	; CONVERSION CODE TO XP1
00400		SKIPE	XP1
00500		 EXEC	ORCC	; CHECK AND CONVERT OPERAND TYPES
00600		SETZ	XP1,
00700		SHIFT	%OPDCHK
00800		SKIPE	XP1	; TYPE CHECK ONLY IF NONZERO CHECK CODE
00900		EXEC	ORCT
01000	REPEAT 0,<; THIS CODE GIVES EXTRAORDINARILY SMALL RETURNS AT RUN-TIME
01100	; CONSTANT ARITHMETIC
01200		IF	; CONSTANT ARITHMETIC BIT IS SET FOR OPERATOR
01300			TLZN	XP2,1B<%CONAR-$$SCT+^D17>
01400			GOTO	FALSE
01500			NOCONV=FALSE	; SAVE FALSE BRANCH INTO LOOP ... AS
01600			L	XP1,YSTEPP
01700			LOOP
01800				WHENNOT	XP1,ZCN
01900				GOTO	NOCONV	; NOT ALL OPERANDS CONSTANTS
02000			AS
02100				STEPJ	XP1,ZCN,TRUE
02200			SA
02300		THEN
02400			EXEC	ORCA
02500			 RETURN	; RETURN IS TAKEN IF CONVERSION SUCCESSFUL
02600			; SKIP RETURN IF CONVERSION FAILED
02700		FI
02800	>
     
00100	
00200	; MAKE RESULT NODE IN XV1-XV2
00300	
00400		MOVE	XV2,XCUR
00500		MOVSI	XV1,(<<QSIMPLE>B<%ZNSKND>+<QZNS>B<%ZNOTYP>>)
00600		SETZ	XP1,
00700		SHIFT	%RESTYP	; GET PARAMETER TO ORTY
00800		SKIPE	XP1
00900		 XEC	ORTY
01000		EXEC	ORBU	; BACKUP SIDE-EFFECTS AND LEVELS
01100	; CHECK FOR OPERAND SWAPPING
01200		L	XP1,YFOP
01300		IF
01400			TLNE	XP2,<1B<%NOMOV-$$SCT+^D17>>
01500			GOTO	FALSE
01600		THEN
01700			IF	TLNN	XP2,<1B<%COMMUT-$$SCT+^D17>+1B<%REVERS-$$SCT+^D17>>
01800				GOTO	FALSE	; OPERATOR NOT SWAPPABLE
01900				TRNN	XV2,1B<%ZNSROR>
02000				GOTO	FALSE	; SWAPPING NOT ALLOWED BECAUSE OF SIDE EFFECTS
02100				; SWAPPING ALLOWED WHEN ENTERING HERE
02200				; NOW DETERMINE IF IT IS PROFITABLE
02300				L	XL1,XP1
02400				STEP	(XL1,ZNO)	;XL1 -> SECOND OPERAND (SOP)
02500				WHEN	XL1,ZCN
02600				GOTO	FALSE		;DO NOT SWAP IF SOP ZCN
02700				WHEN	XP1,ZCN
02800				GOTO	TRUE	; SWAP WHEN FIRST OPERAND IS CONSTANT
02900				WHENNOT	(XP1,ZID)	; OR IDENTIFIER
03000				GOTO	FALSE
03100			THEN	;SWAP
03200				IF	; NON-COMMUTING OPERATOR
03300					TLNE	XP2,<1B<%COMMUT-$$SCT+^D17>>
03400					GOTO	FALSE
03500				THEN	; FIND REVERSE OPERATOR
03600					LI	XL1,[%LESS,,%GRT
03700						%NGRT,,%NLESS
03800						%GRT,,%LESS
03900						%NLESS,,%NGRT
04000						0]
04100					LOOP
04200						L	X1,(XL1)
04300						ASSERT<	SKIPN	X1,(XL1)
04400							RFAIL	NO REVERSE OPERATOR FOUND
04500						>
04600					AS
04700						AOS	XL1
04800						CAIE	XCUR,(X1)
04900						GOTO	TRUE
05000					SA
05100					HLRZ	XCUR,X1		; REPLACE CURRENT OPERATOR
05200					SF	XCUR,ZNSGEN(,XV1)
05300				FI
05400				L	XL1,YEXPP
05500				LD	(XP1)
05600				SETONA	ZNOLST
05700				STD	-ZNO%S(XL1)
05800				SUBI	XL1,<2*ZNO%S>
05900				LD	ZNO%S(XP1)
06000				STD	(XL1)
06100				ST	XL1,YEXPP
06200				HRR	XV1,XL1
06300				STD	XV1,(XP1)
06400				L	[-ZID%S,,-ZID%S]
06500				ADDM	YOPSTP
06600			ELSE
06700				; NORMAL OPERAND MOVE FROM STACK TO TREE
06800				EXEC	ORMV
06900			FI
07000		FI
07100	; CHECK IF SPECIAL PROCESSING IS NEEDED FOR THIS SYMBOL
07200		HRRZ	X1,CODEWORD(XCUR)
07300		ANDI	X1,377777
07400		JUMPN	X1,OREN(X1)	; BRANCH IF NON-ZERO RIGHT HALF OF CODEWORD
07500		RETURN
07600		;	END OF PROCEDURE OREN
     
00100		SUBTTL	SPECIAL OPERATOR PROCESSING
00200	; THESE SEQUENCES ARE FOR OPERATORS REQUIRING SPECIAL PROCESSING. IF A LABEL
00300	; 'SYMBL.' IS DEFINED HERE, THEN THE CODE WORD FOR 'SYMBL' WILL GET A NON-ZERO
00400	; RIGHT HALFWORD AND THE LABEL WILL BE BRANCHED TO FOR SUCH SYMBOLS.
00500	; AT THIS POINT OPERANDS HAVE BEEN MOVED TO THE TREE IF 'NOMOVE' WAS NOT SET IN
00600	; THE CODE WORD OF THE SYMBOL
00700	
00800	; SIMPLE ROOT SYMBOLS
00900	ADEC.:
01000	FORSI.:
01100	FORST.:
01200	GOTO.:
01300	SWEL.:
01400		BRANCH	CGEN
01500	
01600	
01700	; ACTIVATION MASK BITS:
01800	AFTER=1B15
01900	AT=1B14
02000	BEFORE=1B16
02100	DELAY=1B13
02200	ACTIV.:	INVAL
02300		ST	YORACT	; READ AND SAVE BIT MASK FOR ACTIVATION
02400		L	XP2,
02500		L	XP1,YSTEPP
02600		EXEC	ORCPR	; CHECK FIRST OPERAND QUALIFIED PROCESS
02700		ERROR2	11,OPERAND OF ACTIVATE OR REACTIVATE NOT PROCESS
02800		IF	STEPJ	XP1,ZNS,TRUE	; MORE THAN ONE OPERAND?
02900			GOTO	FALSE
03000		THEN	; YES, MORE THAN ONE
03100			ASSERT<
03200				TRNN	XP2,(<BEFORE+AFTER+AT+DELAY>)
03300				RFAIL	TOO MANY OPERANDS OF ACTIVATE OR WRONG BIT MASK
03400			>
03500			IF	TRNN	XP2,(<BEFORE+AFTER>)
03600				GOTO	FALSE
03700			THEN	; BEFORE OR AFTER: CHECK SECOND OPERAND QUALIFIED LINKAGE
03800				LI	QREF
03900				SETZM	X1
04000				L	XL1,XP1
04100				EXEC	ORCN
04200				EXEC	ORCPR
04300				ERROR2	38,OPERAND AFTER BEFORE OR AFTER IS NOT QUALIFIED PROCESS
04400			ELSE	; AT OR DELAY, CONVERT SECOND OPERAND TO REAL
04500				LI	QREAL
04600				L	XL1,XP1
04700				EXEC	ORCN
04800			FI
04900		ELSE	; ONE OPERAND ONLY, ASSERT MASK IS OK
05000			ASSERT<
05100				TRNE	XP2,(<BEFORE+AFTER+AT+DELAY>)
05200				RFAIL	TOO FEW ARGUMENTS TO ACTIVATE OR WRONG BIT MASK
05300			>
05400		FI
05500		EXEC	ORMV	; MOVE OPERANDS
05600		BRANCH	CGEN	; AND COMPILE
05700		; END OF ACTIVATE PROCESSING
     
00100	BEGCL.:	LF	XP2,ZIDZQU(,YOPST)
00200		CAIN	XP2,YUNDEC
00300		BRANCH	O2AB	; FAILED TO FIND CLASS AND ATTRIBUTES
00400		; REDEFINE LAST FIXUP DEFINED TO F+5, F+2 IS HERE
00500		LF	XL1,ZQUIND(XP2)	; FIXUP OF CLASS
00600		LI	5(XL1)
00700		EXEC	O2RF
00800		LI	X1,2(XL1)
00900		DEFIX
01000		LF	XZHE,ZQUZB(XP2)
01100		L	X1,YZHBXC
01200		; DISPLAY CLASS ATTRIBUTES IN DICTIONARY
01300		EXEC	CAUNPR,<[0]>	;[40]
01400		EXEC	CADISP
01500		ST	XZHE,YZHBXC
01600		ST	XZHE,YZHET
01700		LF	X1,ZHBZHB(XZHE)	; BACK UP FROM PREFIX
01800		IF	CAIN	X1,0
01900			GOTO	FALSE
02000		THEN	;PREFIX
02100			IF	IFOFF	ZHBLOC(X1)
02200				GOTO	FALSE
02300			THEN	; SET LOC
02400				SETON	ZHBLOC(XZHE)
02500			FI
02600			LF	,ZHBSZD(X1)
02700			LF	X1,ZHBSZD(XZHE)
02800			CAMLE	X1
02900			SF	,ZHBSZD(XZHE)
03000		FI
03100		; ADJUST STACKS
03200		EXEC	CABSTU
03300		EXEC	CAUSTD
03400		EXEC	O2LN1
03500		BRANCH	CGPU
03600	
03700	BEGPB.:	;CHECK SYNTAX OF PREFIX, NOT DONE IN PASS 1
03800		L	X1,YFOP
03900		IF	WHEN	X1,ZID
04000			GOTO	FALSE	; ID OK
04100			WHENNOT	X1,ZNS
04200			GOTO	TRUE	; MUST HAVE %PCALL OTHERWISE
04300			LF	,ZNSGEN(X1)
04400			CAIE	%PCALL
04500			GOTO	TRUE
04600			LF	X1,ZNSZNO(X1)
04700			WHEN	X1,ZID
04800			GOTO	FALSE	; OK IF NOT REMOTE PREFIX
04900		THEN	;ILLEGAL BLOCK PREFIX
05000			SETZB	X3,YORZHB
05100			SETZM	YORZQU
05200			SEVER1	3,X3,PREFIX NOT A CLASS
05300		ELSE
05400	
05500			EXEC	NEW.	;SAME OPERAND CHECK AS FOR NEW.
05600			L	XP1,YEXPP
05700			LF	XP1,ZIDZQU(XP1)
05800			ST	XP1,YORZQU
05900			LF	,ZQULID(XP1)
06000			ST	YCALID
06100			LF	XP2,ZQUZB(XP1)
06200			ST	XP2,YORZHB
06300			SKIPN	XP2
06400			 SEVER1	3,YCALID,PREFIX NOT A CLASS
06500			SKIPN	XP2
06600			GOTO	.+4	; FORWARDD EXIT
06700			IFON	ZHBLOC(XP2)
06800			 ERROR2	45,PREFIX HAS LOCAL OBJECT
06900			IFON	ZQUIS(XP1)
07000			 ERROR2	48,CONNECTED PREFIX
07100		FI
07200		EXEC	CARL
07300		L	X1,YZHBXC
07400		ST	XZHE,YZHBXC
07500		LF	X1,ZHEFIX(XZHE)	; GET FIXUP OF PREFIXED BLOCK
07600		SF	XCUR,ZNSGEN(,YOPST)
07700		EXEC	O2LN1
07800		BRANCH	CGEN
07900	
08000	BEGPR.:	LF	XP1,ZIDZQU(,YOPST)
08100		CAIN	XP1,YUNDEC
08200		 BRANCH	O2AB	; FAILED TO FIND PROCEDURE AND PARAMETERS
08300		SETON	ZQUIB(XP1)
08400		ST	XP1,YORZQU
08500		LF	XP2,ZQUZB(XP1)
08600		L	X1,YZHBXC
08700		ST	XP2,YZHBXC
08800		ST	XP2,YORZHB
08900		LF	XP2,ZQUIND(XP1)	; GET FIXUP OF PROCEDURE
09000		; REDEFINE PREVIOUS FIXUP OR JUMP TO F+3,
09100		; DEFINE F+2 HERE
09200		IFON	ZQUGLOB(XP1)
09300		GOTO	.+3
09400		LI	3(XP2)
09500		EXEC	O2RF
09600		LI	X1,2(XP2)
09700		EXEC	O2DF
09800		EXEC	CARL
09900		L	X1,YBKSTP
10000		L	YORZHB
10100		HRRM	(X1)
10200		ST	YZHET
10300		L	[-ZID%S,,-ZID%S]
10400		ADDM	YOPSTP	; CLEAR OPERAND STACK
10500		EXEC	CAUSTD
10600		EXEC	O2LN1
10700		RETURN
10800	
10900	; := AND :-
11000	; SUPPLY NEW OPERANDS UNTIL THE OPERAND STACK IS EMPTY
11100	MOCEB.:
11200	BECOM.:	LI	XCUR,%BECOM
11300		SKIPA
11400	TONED.:
11500	DENOT.:	LI	XCUR,%DENOT
11600		L	X1,YEXPP
11700		IF	WHEN	X1,ZID
11800			GOTO	FALSE	; ID ALLOWED LHS
11900			CAIE	QZNS
12000			GOTO	TRUE	; ZCN NOT ALLOWED
12100			LF	,ZNSGEN(X1)
12200			CAIE	%RP
12300			CAIN	%DOT	; REMOTE AND INDEXED ALLOWED
12400			GOTO	FALSE
12500		THEN
12600			LF	,ZNSTYP(X1)
12700			IF
12800				CAIN	QTEXT
12900				CAIE	XCUR,%BECOME	; ALL EXPRESSIONS ALLOWED AS LHS TO TEXT :=
13000				GOTO	TRUE
13100				L	X0,X1	;[174]
13200				EXEC	ORTXCH	;[174]
13300				GOTO	FALSE
13400			THEN
13500				ERROR1	13,XCUR,INVALID LHS TO OPERATOR
13600			FI
13700		FI
13800		L	YFOP
13900		CAIG	YOPST
14000		 BRANCH	CGEN	; COMPILE WHEN OPERAND STACK EMPTY
14100		BRANCH	OREN	; OTHERWISE TAKE NEW LEFT HAND SIDE
     
00100	CVBE.:	ASSERT<NOP	; Measurement point
00200		>
00300				edit(321)
00400		TDZA		;[321] Flag :=
00500	
00600	CVDE.:
00700		LI 1		;[321] Flag :-
00800		ST YFORSI	;[321]
00900		EXEC	CARL	;READ ZHE AND LABEL LIST
01000		UNDISPLAY	;MAKE LABELS UNAVAILABLE UNTIL FORDO
01100		EXEC	CAUSTD	;[30] RESERVE SPACE FOR FOR RETURN ADDRESS
01200		LF	,ZHEFIX(XZHE)
01300		ST	YORFX
01400		L	XP1,YFOP
01600	repeat 0,<;[321] Removed restriction
01700		IFEQF	XP1,ZIDTYP,QTEXT
01800		 ERROR2	12,CONTROLLED VARIABLE OF TYPE TEXT NOT ALLOWED
01900	>
02000		LD	(XP1)
02100		STD	YORFOR
02200		ASSERT<
02300			CAMLE	XP1,YOPSTB
02400			RFAIL	TOO MANY OPERANDS OF CVBE OR CVDE
02500		>
02600		IF	; KIND NOT SIMPLE
02700			WHEN	XP1,ZID
02800			GOTO	FALSE
02900		THEN
03000			ERROR1	13,XCUR,CONTROLLED VARIABLE NOT SIMPLE IDENTIFIER
03100		ELSE
03200		IF	; MODE NOT DECLARED OR UNDEFINED
03300			LF	,ZIDMOD(XP1)
03400			CAIE	QNAME
03500			GOTO	FALSE
03600		THEN
03700			LF	X1,ZIDZQU(XP1)
03800			LF	X1,ZQULID(X1)
03900			ERROR1	14,X1,CONTROLLED VARIABLE %ID IN FOR STATEMENT NOT DECLARED OR VALUE MODE
04000		FI
04100		FI
04200		RETURN
04300	
     
00100	DELOP.:	SETON	SCERFL	; SET LOCAL ERROR FLAG
00200		RETURN
00300	
00400	DEQ.:			;[174]
00500	NDEQ.:			;[174]
00600		L	X1,YEXPP
00700		IF
00800			IFNEQF	(X1,ZNSTYP,QTEXT)
00900			GOTO	FALSE
01000			L	X0,X1
01100			EXEC	ORTXCH
01200			SKIPA
01300			GOTO	TRUE
01400			STEP	X1,ZNO
01500			L	X0,X1
01600			EXEC	ORTXCH
01700			GOTO	FALSE
01800		THEN
01900			ERROR2	62,ILLEGAL USE OF TEXT VALUE CONSTANT
02000		FI
02100		RETURN
02200	
02300	FORWH.:	L	XL1,YFOP
02400		LF	,ZIDTYP(XL1)
02500		LF	X1,ZIDZDE(XL1)
02600		STEP	XL1,ZNS
02700		EXEC	ORCN
02800		STEP	XL1,ZNS
02900		LI	QBOOLE
03000		EXEC	ORCN	; CHECK CONDITION IN WHILE BOOLEAN
03100		EXEC	ORMV
03200		BRANCH	CGEN
03300	
03400	IFEX.:	; ELSE OPERANDS HAVE BEEN CHECKED BUT NOT MOVED,
03500		; REENTER OREN TO CHECK THE CONDITION AFTER IF
03600		LI	XCUR,%IFEX1
03700		BRANCH	OREN
03800	
03900	IFST.:	INVAL
04000		ST	YORFX	; SAVE FIXUP FOR CODEGEN
04100		BRANCH	CGEN
04200	
04300	IFTRE.:	INVAL
04400		ST	YORFX
04500	IFTRU.:	L	XL1,YFOP
04600		STEP	(XL1,ZNS)	; CHECK TYPE OF SECOND OPERAND
04700		LI	X3,%GOTO
04800		IFNEQF	(XL1,ZNSTYP,QLABEL)
04900		ERROR1	24,X3,INVALID OPERAND TYPE OF OPERATOR GOTO
05000		EXEC	ORMV
05100		BRANCH	CGEN
05200	
05300	INSPE.:	L	X1,YEXPP
05400		LF	X2,ZNSZQU(X1)	; THIS GETS THE QUALIFICATION OF INSPECT
05500		IF	WHENNOT	X1,ZCN
05600			GOTO	FALSE
05700		THEN	ERROR2	49,CONSTANT AFTER INSPECT
05800			SETZ	X2,
05900		FI
06000		ST	X2,YORZQU
06100		SETZM	YORZHB	; TO AVOID MISTAKES
06200		INVAL
06300		ST	YORFX
06400		BRANCH	CGEN
06500	
06600	NEW.:	L	X1,YFOP
06700		IF
06800			WHENNOT	X1,ZID
06900			GOTO	FALSE
07000		THEN
07100			;ZID: PARAMETERS HAVE NOT BEEN CHECKED
07200			LF	X2,ZIDZQU(X1)
07300			CAIN	X2,YUNDEC	;[134]
07400			RETURN			;[134]
07500			LF	X3,ZQUZB(X2)
07600			LOOP		;[3] CECK FOR PARAMETERS IN THE
07700					; PREFIX LINK TOO
07800	
07900				LF	,ZHBNRP(X3)
08000				IF
08100					JUMPE	FALSE
08200				THEN
08300					LF	X2,ZQULID(X2)
08400					ERROR1	17,X2,PARAMETERS OMITTED TO (%ID)
08500				FI
08600				LF	X3,ZHBZHB(X3)	;[3]
08700			AS
08800				JUMPE	X3,FALSE
08900				WHEN	X3,ZHB
09000				GOTO	TRUE
09100			SA
09200			HRREI	X4,-ZID%S
09300			ADDB	X4,YEXPP
09400			LD	X2,(X1)
09500			SETONA	ZNOLST(X2)
09600			STD	X2,(X4)
09700			SF	X4,ZNSZNO(X1)
09800		ELSE
09900			SETZM	YCALID
10000			IF	CAIN	XCUR,%NEW
10100				GOTO	FALSE
10200				IFOFF	ZNOTER(X1)
10300				GOTO	FALSE
10400			THEN
10500				SEVER1	3,YCALID,PREFIX NOT A CLASS
10600			FI
10700			LF	X4,ZNSZNO(X1)
10800		FI
10900		LF	X4,ZIDZQU(X4)
11000		SF	X4,ZNSZQU(X1)
11100		LI	X0,(<<QSIMPLE>B<%ZNSKND>+<QZNS>B<%ZNOTYP>+<QREF>B<%ZNSTYP>>)
11200		HRLM	X0,(X1)
11300		SF	XCUR,ZNSGEN(X1)
11400		SETON	ZNSSEF(X1)
11500		RETURN
11600	
11700	PAREN.:	SETON	SPAREN
11800		ASSERT<
11900		L	X1,YFOP
12000		WHEN	X1,ZID
12100		NOP
12200		>
12300		RETURN
12400	
     
00100	SWITC.:	L	XP1,YEXPP
00200		LF	XP1,ZIDZQU(XP1)
00300		ASSERT<
00400			IFNEQF	XP1,ZQUTYP,QLABEL
00500			RFAIL	SWITCH NOT OF TYPE LABEL IN OREN
00600			IFNEQF	XP1,ZQUMOD,QDECLARED
00700			CAIN	QVIRTUAL
00800			SKIPA
00900			RFAIL	SWITCH DECLARATION FOR PARAMETER SWITCH
01000			IFNEQF	XP1,ZQUKND,QPROCEDURE
01100			RFAIL	SWITCH NOT OF TYPE PROCEDURE
01200		>
01300		ST	XP1,YORZQU
01400		LF	XP2,ZQUIND(XP1)
01500		MOVSM	XP2,YCGSWC
01600		LI	1(XP2)
01700		EXEC	O2RF
01800		; IN ORDER TO PREVENT LOCAL DATA ACCESSES THROUGH XCB
01900		; WE MUST PLANT A NEW LEVEL ON THE STACKS AND LET YZHBXCB AND YZHET
02000		; POINT TO IT
02100		LF	X2,ZHEDLV(XZHE)
02200		L	XZHE,YDCSTP
02300		ST	XZHE,YZHET
02400		SUBI	X2,1
02500		SF	X2,ZHEDLV(XZHE)
02600		LI	ZHB%V
02700		SF	,ZDETYP(XZHE)
02800		LI	X2,ZHB%S(XZHE)
02900		ST	X2,YDCSTP
03000		EXEC	CABSTU
03100		L	YZHBXC
03200		ST	YORZHB
03300		ST	XZHE,YZHBXC
03400		EXEC	CAUSTD
03500		BRANCH	CGPU
03600	
03700	THIS.:	L	XP1,YEXPP
03800		LF	X2,ZIDZQU(XP1)
03900		LF	X1,ZQUZB(X2)
04000		IF
04100			IFOFF	ZHBUPF(X1)
04200			GOTO	FALSE
04300		THEN	; ON
04400			LF	X1,ZQULID(X2)
04500			ERROR1	18,X1,THIS %ID IS NOT A VALID LOCAL OBJECT SINCE THE CLASS IS USED AS BLOCK PREFIX
04600		ELSE	; FIND DISPLAY LEVEL OF LOCAL OBJECT, X1 HAS ZHB POINTER
04700			L	XP2,YBKSTP
04800			LOOP
04900				POP	XP2,XP1
05000				IF	LF	,ZHETYP(XP1)
05100					CAIN	QCLASB
05200					GOTO	TRUE
05300					CAIE	QINSPE
05400					GOTO	FALSE
05500				THEN	; CHECK QUALIFICATION OF ENVIRONMENT
05600					LF	XP1,ZHBZQU(XP1)
05700					LF	XP1,ZQUZB(XP1)
05800					WHILE	CAMN	XP1,X1
05900						GOTO	FALSE
06000						JUMPE	XP1,FALSE
06100					DO
06200						LF	XP1,ZHBZHB(XP1)
06300					OD
06400				ELSE
06500					SETZ	XP1,
06600				FI
06700	
06800			AS	JUMPN	XP1,FALSE	; MATCHING ZHB IN XP1
06900				LI	YBKST
07000				CAIG	(XP2)
07100				GOTO	TRUE
07200				LF	XP1,ZHBZQU(X1)
07300				LF	XP1,ZQULID(XP1)
07400				SKIPE	XP1
07500				ERROR1	19,XP1,<INVALID LOCAL OBJECT NO ENCLOSING INSTANCE>
07600				RETURN
07700			SA
07800			; GET DISPLAY LEVEL OF INSTANCE AND PUT IT IN ZNSZNO OF THE RESULT NODE
07900			L	XP1,1(XP2)	; USED BLOCK STACK ENTRY
08000			SETON	ZHBLOC(XP1)	; THIS CLASS CAN NOT BE USED FOR BLOCK PREFIXING
08100			LF	,ZHEDLV(XP1)
08200			L	X1,YFOP
08300			SF	,ZNSZNO(X1)
08400			SETON	ZNOTER(X1)	; ZNS NODE WITH %THIS IS TERMINAL
08500		FI
08600		RETURN
08700	
     
00100	UNMIN.:	L	XP2,YEXPP
00200		WHENNOT	XP2,ZCN
00300		RETURN
00400	; CONSTANT ARITHMETIC
00500		L	XP1,YOPSTP
00600		ADD	XP1,[-2,,-2]
00700		L	XV1,(XP2)
00800		L	XV2,1(XP2)
00900		LF	,ZCNTYP(,XV1)
01000		IF	CAIN	QLREAL
01100			GOTO	FALSE
01200		THEN
01300			; NOT LONG REAL
01400			MOVN	XV2,XV2
01500		ELSE	; LONG REAL
01600			DMOVN	(XV2)
01700			DMOVEM	(XV2)
01800		FI
01900		PUSH	XP1,XV1
02000		PUSH	XP1,XV2
02100		RETURN
02200	
02300	WHEDO.:	SETZM	@YDCSTP
02400		L	XP2,YEXPP
02500		LF	XP1,ZIDZQU(XP2)
02600		ST	XP1,YORZQU
02700			LF	,ZQUZB(XP1)
02800		ST	YORZHB
02900		EXEC	CARL
03000		UNDISPLAY	; UND. LABELS IN CLAUSE
03100		L	YORZHB
03200		SF	,ZHBZHB(XZHE)
03300		L	YORZQU
03400		SF	,ZHBZQU(XZHE)
03500		L	YORFX
03600		SF	,ZHEFIX(XZHE)
03700		EXEC	CACO
03800		EXEC	CGEN
03900		RETURN
04000	WHILE.:	INVAL
04100		ST	YORFX
04200		BRANCH	CGEN
     
00100		SUBTTL	CODEWORD TABLE DEFINITION
00200	DT:	Z
00300	;	SYMBOL,NOCODE,OPDS,SIMPLE,OPDCON,OPDCHK,RESTYP,CONAR,COMMUT,REVERSE,NOMOV
00400	ORCOD ADEC,,0,0,0,0,0,,,
00500	ORCOD ACTIV,,0,,0,0,0,,,,1
00600	ORCOD AND,,,,QCSAME,QBOOLE,,,1,
00700	ORCOD BECOM,,,,QCLEFT,QNREF,,,,
00800	ORCOD BEGCL,,0,0,0,0,0,,,,1
00900	ORCOD BEGPB,,0,0,0,0,0,,,,1	
01000	ORCOD BEGPR,,0,0,0,0,0,,,,1
01100	ORCOD BOUND,,,,QCINT,0,0,,,
01200	ORCOD CVBE,,0,,0,QNREF,,,,,1
01300	ORCOD CVDE,,0,,0,QTXREF,,,,,1
01400	ORCOD DELOP,,,0,0,0,QUNDEF,,,
01500	ORCOD DENOT,,,,QCLEFT,QTXREF,,,,
01600	ORCOD DEQ,,,,QCSAME,QTXREF,QRBOOL,,1,
01700	ORCOD DIV,,,,QCREAL,,,1,,
01800	ORCOD DOT,1,,0,0,QREF,,,,
01900	ORCOD EQ,,,,,QNRFBO,QRBOOL,,1,
02000	ORCOD EQV,,,,QCSAME,QBOOLE,,,1,
02100	ORCOD FORSI,,0,,QCLEFT,0,0,,,,
02200	ORCOD FORST,,0,,QCLEFT,,0,,,,
02300	ORCOD FORWH,,0,,0,0,0,,,,1
02400	ORCOD GOTO,,0,,0,QLABEL,0,,,,
02500	ORCOD GRT,,,,,QNRFBO,QRBOOL,,,1
02600	ORCOD IDIV,,,,QCINT,,,,,
02700	ORCOD IFEX,,2,,,0,,,,
02800	ORCOD IFEX1,,2,,0,QBOOLE,QRLAST,,,,
02900	ORCOD IFST,,1,,0,QBOOLE,0,,,
03000	ORCOD IFTRE,,,,0,QBOOLE,0,,,,1
03100	ORCOD IFTRU,,,,0,QBOOLE,0,,,,1
03200	ORCOD IMP,,,,QCSAME,QBOOLE,QRBOOL,,,
03300	ORCOD IN,,,0,0,QREF,QRBOOL,,,
03400	ORCOD INSPE,,1,,0,QREF,0,,,
03500	ORCOD IS,,,0,0,QREF,QRBOOL,,,
03600	ORCOD LESS,,,,,QNRFBO,QRBOOL,,,1
03700	ORCOD MINUS,,,,,,,1,,
03800	ORCOD MULT,,,,,,,1,1,
03900	ORCOD NDEQ,,,,QCSAME,QTXREF,QRBOOL,,1,
04000	ORCOD NEQ,,,,,QNRFBO,QRBOOL,,1,
04100	ORCOD NEW,,1,0,0,0,QRCLAS,,,,1
04200	ORCOD NGRT,,,,,QNRFBO,QRBOOL,,,1
04300	ORCOD NLESS,,,,,QNRFBO,QRBOOL,,,1
04400	ORCOD NOT,,1,,0,QBOOLE,QRBOOL,,,
04500	ORCOD OR,,,,QCSAME,QBOOLE,QRBOOL,,1,
04600	ORCOD PAREN,,1,0,0,0,0,,,,1
04700	ORCOD PLUS,,,,,,,1,1,
04800	ORCOD POW,,,,QCREAL,,,,,
04900	ORCOD QUA,,,0,0,QREF,,,,
05000	ORCOD RP,1,,0,0,0,,,,
05100	ORCOD SWEL,,1,,0,QLABEL,0,,,
05200	ORCOD SWITC,,1,0,0,0,0,,,
05300	ORCOD THIS,,1,0,0,0,QRCLAS,,,
05400	ORCOD UNMIN,,1,,0,,,1,,
05500	ORCOD UPLUS,,1,,0,,,,,,1
05600	ORCOD WHEDO,,1,0,0,0,0,,,
05700	ORCOD WHILE,,1,,0,QBOOLE,0,,,
05800	
05900	CODEWORDS:
06000		SYMB	6,1,OPTAB
     
     
00100		SUBTTL	ORMV
00200	;PURPOSE:	MOVE OPERANDS OF CURRENT OPERATOR FROM THE
00300	;		OPERAND STACK TO THE EXPRESSION TREE AND UPDATE POINTERS.
00400	;		STORE OPERATOR NODE FROM XV1,XV2 INTO OPERAND STACK.
00500	;ENTRY:		ORMV
00600	;NORMAL EXIT:	RETURN
00700	;ERROR EXIT:	NONE
00800	;I/O PERFORMED:	NONE
00900	;ERRORS GENERATED:	NO
01000	;USED ROUTINES:	NONE
01100	ORMV:	PROC
01200		SAVE<X2,X3>	;?
01300		HRRZ	X3,YOPSTP
01400		L	X2,YEXPP
01500		SUBI	X2,2
01600		IF	CAIL	X2,2(X3)
01700			GOTO	FALSE
01800		THEN	; OVERFLOW OPERAND STACK
01900			ERROR2	35,COMPLICATED EXPRESSION
02000			GOTO	O2AB	; RECOVERY IS NOT SAFE
02100			L	X2,YEXPL
02200			SUBI	X2,2
02300		FI
02400		SOJ	X3,
02500		SETON	ZNOLST(X3)
02600		LOOP	; MOVE ONE ZNO AT A TIME
02700			LD	(X3)
02800			STD	(X2)
02900		AS
03000			CAMG	X3,YFOP	; EQUALITY WHEN LAST OPD HAS BEEN MOVED
03100			GOTO	FALSE
03200			SUBI	X3,2
03300			SUBI	X2,2
03400			SETOFF	ZNOLST(X3)
03500			GOTO	TRUE	; MOVE NEXT OPD
03600		SA
03700		SF	X2,ZNSZNO(,XV1)
03800		STD	XV1,(X3)
03900		ST	X2,YEXPP
04000		L	X3
04100		SUB	YEXPL
04200		MOVS		; GET OFLOW COUNTER IN LH
04300		HRRI	1(X3)
04400		ST	YOPSTP
04500		RETURN
04600		EPROC
     
00100		COMMENT;
00200	PURPOSE:	DETERMINE IF A QUANTITY (OCCURRING IN AN ACTIVATE
00300			STATEMENT) IS QUALIFIED PROCESS.
00400	
00500	ENTRY:		ORCPR
00600	
00700	INPUT:	ZNO RECORD POINTER IN XP1
00800	
00900	USED ROUTINE:	ORCN
01000	;
01100	ORCPR:	PROC
01200		SAVE	<X2,X3>
01300		N==2
01400		LF	X1,ZNSTYP(XP1)	;[216]
01500		CAIE	X1,QREF		;[216]
01600		GOTO	L9		;[216]
01700		LF	X2,ZNSZQU(XP1)	; OPERAND QUALIFICATION
01800		JUMPE	X2,L8		;[216] Accept NONE
01900		L	X1,YPROCI
02000		CAMN	X1,X2
02100		GOTO	L8
02200		LF	X1,ZQUZB(X1)
02300		LF	X3,ZQUZB(X2)
02400		IF	IFOFF	ZQUSYS(X2)
02500			GOTO	FALSE
02600		THEN	;SYSTEM CLASS, MUST BE LINK OR LINKAGE
02700			LOOP	ASSERT<WHENNOT	X1,ZHB
02800					RFAIL	ZHBZHBLINK ERROR
02900				>
03000				IF	CAME	X1,X3
03100					GOTO	FALSE
03200				THEN
03300					LI	QREF
03400					L	X1,YPROCI
03500					EXCH	XL1,XP1
03600					EXEC	ORCN
03700					EXCH	XL1,XP1
03800					GOTO	L8
03900				FI
04000			AS	LF	X1,ZHBZHB(X1)
04100				JUMPN	X1,TRUE
04200			SA
04300		ELSE	; NOT SYSTEM CLASS, FOLLOW ITS PREFIXES
04400			LOOP	ASSERT<WHENNOT	X3,ZHB
04500					RFAIL	ZHBZHBLINK ERROR
04600				>
04700				CAMN	X3,X1
04800				GOTO	L8
04900			AS	LF	X3,ZHBZHB(X3)
05000				JUMPN	X3,TRUE
05100			SA
05200		FI
05300	; NO MATCH, INCOMPATIBLE QUALIFICATION
05400		GOTO	L9
05500	L8():!	AOS	-N(XPDP)
05600	L9():!	RETURN
05700		EPROC
05800	
     
00100		LIT
00200		RELOC
00300		VAR
00400	END