Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-05 - 43,50337/12/orrk.mac
There are 2 other files named orrk.mac in the archive. Click here to see a list.
00100		COMMENT;
00200	
00300		AUTHOR:	REIDAR KARLSON
00400	
00500		VERSION:	3A [5,12,35,40,133,134,174,330]
00600	
00700		CONTENTS:	ORBU,ORCC,ORCT,ORDT,ORLU,ORLD,ORRP,ORSM,ORTY
00800	
00900		;
01000	
01100		SEARCH	SIMMCR,SIMMAC,SIMMC2,simrpa
01200		SALL
01300		CTITLE	ORRK
01400	
01500	
01600		INTERNAL	ORBU,ORCC,ORCT,ORDT,ORLU,ORLD,ORRP,ORSM,ORTY
01700		INTERNAL	ORTXCH	;[174]
01800	
01900		EXTERNAL	ORCN,ORMV
02000		EXTERNAL	O2GA,O2AB
02100		EXTERNAL	YDICTB,YEXPP,YFOP,YMAXID,YNOPD,YNZCN,YNZID,YNZNS,YSTKNU
02200		EXTERNAL	YGAP
02300		EXTERNAL	YORPAR,YOPSTB,YOPSTP,YSTEPP,YUNDEC,YDCSTB,YDCSTP
02400		EXTERNAL	YTEXTI
02500		EXTERNAL	YZHET
02600	
02700		QTYPM=	17B<%ZIDTYP+^D18>
02800		QKNDM=	7B<%ZIDKND+^D18>
02900	
03000	
03100		OPDEF	GENABS	[PUSHJ	XPDP,O2GA]
03200	
03300		TWOSEG
03400	
03500	
03600		RELOC	400000
03700	
03800		MACINIT
     
00100		SUBTTL	ORBU
00200		COMMENT;
00300	
00400		PURPOSE:	TO DETERMINE THE ZNSROR,ZNSSEF AND ZNSLEV FIELDS OF A
00500				NODE.
00600	
00700		ENTRY:		ORBU
00800	
00900		INPUT ARGUMENTS:	THE OPERATOR NODE IS COMPLETE IN XV1 AND XV2
01000				EXCEPT THE THREE FIELDS MENTIONED ABOVE
01100	
01200		NORMAL EXIT:	RETURN
01300	
01400		ERROR EXIT:	NONE
01500	
01600		OUTPUT ARGUMENTS:	NONE
01700	
01800		CALL FORMAT:		EXEC	ORBU
01900	
02000		USED SUBROUTINE:	ORBUSE
02100	
02200		;
     
00100	
00200	;	SUBROUTINE ORBUSE
00300	;	CALLED WHEN A ZID OPERAND CAUSES SIDE EFFECTS
00400	;	ZNSSEF WILL BE SET IN THE OPERAND NODE XV1-XV2 AND X3 WILL BE UPDATED
00500	;	TO THE MAXIMUM SOURCE LEVEL
00600	
00700	ORBUSE:	PROC
00800	
00900		SETONA	ZNSSEF(XV2)
01000		LF	X1,ZIDZQU(X2)
01100		LF	X1,ZQUZHE(X1)
01200		LF	X1,ZHESOL(X1)
01300		CAIGE	X3,(X1)
01400		L	X3,X1
01500	
01600		RETURN
01700		EPROC
01800	
     
00100	
00200	ORBU:	PROC
00300	
00400		L	X2,YSTEPP
00500		SETOFA	ZNSSEF(XV2)
00600	
00700		IF
00800			HLR	X0,(X2)
00900			CAIE	X0,-1
01000			GOTO	FALSE
01100		THEN
01200			;ONE OPERAND ONLY
01300	
01400			SETONA	ZNSROR(XV2)
01500			IF
01600				RECTYPE(X2) IS ZNS
01700				GOTO	FALSE
01800			THEN
01900				;COPY ZNSSEF AND -LEV
02000	
02100				IFON	ZNSSEF(X2)
02200				SETONA	ZNSSEF(XV2)
02300				LF	X0,ZNSLEV(X2)
02400				SF	X0,ZNSLEV(,XV1)
02500				 RET
02600			FI
02700			IF
02800				RECTYPE(X2) IS ZID
02900				GOTO	FALSE
03000			THEN
03100				;FOR ZID WITH MODE QNAME OR (KIND QCLASS AND
03200				; ZNSGEN IN XV1-2 IS %NEW) ZNSSEF IS SET AND
03300				; ZNSLEV IS SET TO ZIDZQU.ZQUZHE.ZHESOL
03400	
03500				IF
03600					IFEQF	X2,ZIDMOD,QNAME
03700					GOTO	TRUE
03800					IFNEQF	X2,ZIDKND,QCLASS
03900					GOTO	FALSE
04000					LF	X0,ZNSGEN(,XV1)
04100					CAIE	X0,%NEW
04200					GOTO	FALSE
04300				THEN
04400					EXEC	ORBUSE
04500					SF	X3,ZNSLEV(,XV1)
04600				FI
04700				RET
04800			FI
04900			ASSERT<	WHENNOT	X2,ZCN
05000				RFAIL	WRONG OPERAND NODE TYPE IN ORBU
05100				>
05200			RET
05300		FI
05400	
05500	
05600		;MORE THAN ONE OPERAND
05700	
05800		SAVE	<X4,X5>
05900		SETZB	X3,X4
06000		SETZ	X5,
06100	
06200	
06300	;The operand nodes are tested for side effects
06400	
06500		LOOP
06600		    IF	    ;ZID NODE?
06700			RECTYPE(X2)	IS ZID
06800			GOTO	FALSE
06900		    THEN
07000			IF	;MODE QNAME?
07100			    IFNEQF	(X2,ZIDMOD,QNAME)
07200			    GOTO	FALSE
07300			THEN
07400			    AOS		X4
07500			    EXEC	ORBUSE
07600			FI
07700		    ELSE
07800			IF		;ZNS NODE?
07900			    RECTYPE(X2)	IS ZNS
08000			    GOTO	FALSE
08100			THEN
08200			    IF		;ITS ZNSSEF IS SET?
08300				IFOFF	ZNSSEF(X2)
08400				GOTO	FALSE
08500			    THEN	;SET ZNSSEF IN THE OPERAND NODE IN XV1-2
08600					; COUNT THE NUMBER OF ZNS NODES CAUSING
08700					; SIDE EFFECTS IN X5
08800					; UPPDATE X3 TO THE MAXIMUM SOURCE LEVEL
08900	
09000				SETONA	ZNSSEF(XV2)
09100				AOS	X5
09200				LF	X1,ZNSLEV(X2)
09300				CAIGE	X3,(X1)
09400				L	X3,X1
09500			    FI
09600			ELSE
09700			    ASSERT<	WHENNOT	X2,ZCN
09800					RFAIL	WRONG OPERAND NODE TYPES IN ORBU
09900				>
10000					;ONLY ZCN,ZID AND ZNS NODES SHOULD OCCUR
10100			FI
10200		    FI
10300		AS
10400		    STEPJ	(X2,ZID,TRUE)
10500		SA
10600	
10700	
10800	;DETERMINE IF ZNSROR SHOULD BE SET
10900	
11000		SF	X3,ZNSLEV(,XV1)		;ZNSLEV = MAX LEVEL
11100	
11200		SETOFA	ZNSROR(XV2)
11300	
11400		ADD	X4,X5			;X4 = NUMBER OF ZID WITH MODE
11500						; QNAME AND ZNS WITH ZNSSEF SET
11600	
11700		IF
11800			JUMPE	X4,TRUE		;NO OPERAND CAUSES SIDE EFFECTS
11900			L	X1,YNOPD
12000			SUB	X1,YNZCN	;X1 = NUMBER OF OPERANDS
12100						; THAT ARE NOT ZCN
12200			CAIE	X1,1		;ALL BUT ONE ARE ZCN OPERANDS
12300			GOTO FALSE
12400	
12500		THEN
12600			SETONA	ZNSROR(XV2)	;SWAPPING ALLOWED
12700		ELSE
12800		    IF
12900			CAIE	X4,1
13000			GOTO	FALSE		;MORE THAN ONE ZNS WITH ZNSSEF SET OR
13100						; ZID WITH MODE QNAME
13200			CAME	X5,YNZNS
13300			GOTO	FALSE		;ANOTHER ZNS OPERAND PRESENT
13400		    THEN
13500			IF			;ADDITIONAL ZID OPERANDS?
13600				SUB	X4,X5
13700				CAMN	X4,YNZID
13800				GOTO	FALSE
13900			THEN			;DETERMINE MINIMUM LEVEL OF ALL ZID
14000						; OPERANDS THAT ARE NOT OF MODE QNAME
14100	
14200				L	X2,YSTEPP
14300				LI	X4,100
14400				LOOP
14500				    IF
14600					RECTYPE(X2)	IS ZID
14700					GOTO	FALSE
14800					IFEQF	(X2,ZIDMOD,QNAME)
14900					GOTO	FALSE
15000				    THEN
15100					LF	X1,ZIDZQU(X2)
15200					LF	X1,ZQUZHE(X1)
15300					LF	X1,ZHESOL(X1)
15400					CAILE	X4,(X1)	;MIN LEVEL IN X4
15500					L	X4,X1
15600				    FI
15700				AS
15800				    STEPJ	(X2,ZID,TRUE)
15900				SA
16000				IF
16100					CAIL	X3,(X4)
16200					GOTO	FALSE	;THE OPERAND CAUSES SIDE EFFECTS
16300							; AT A LEVEL THAT IS NOT LOWER
16400							; THAN THE MINIMUM LEVEL OF
16500							; ALL OTHER ZID OPERANDS
16600				THEN
16700					SETONA	ZNSROR(XV2)
16800				FI
16900			ELSE
17000				SETONA	ZNSROR(XV2)
17100			FI
17200		    FI
17300				FI
17400	
17500		RETURN
17600	
17700		EPROC
     
00100		SUBTTL	ORCC
00200		COMMENT;
00300	
00400		PURPOSE:	TO CHECK COMPATIBILITY OF OPERAND TYPES AND
00500			TO CONVERT OPERANDS.
00600	
00700		ENTRY:	ORCC
00800	
00900		INPUT ARGUMENTS:	AN INDEX IS PASSED AS PARAMETER IN XP1
01000			INDICATING THE OPERAND TYPE CORRESPONDENCE.
01100			THE FOLLOWING CASES OCCUR:
01200	
01300			XP1		ACTION
01400			------------------------------------------------
01500			QCSAME		CHECK TYPE AND QUAL. COMPATIBILITY
01600			QCLEFT		CONVERT TO TYPE OF FIRST OPERAND
01700					IF REF CONVERT TO QUAL. OF FIRST OPERAND
01800			QCHIGH		CONVERT TO HIGHEST TYPE
01900			QCREAL		CONVERT TO REAL OR LONG REAL
02000			QCINT		CONVERT TO INTEGER
02100	
02200	
02300		NORMAL EXIT:	RETURN
02400	
02500		ERROR EXIT:	RETURN
02600	
02700		OUTPUT ARGUMENTS:	NONE
02800	
02900		CALL FORMAT:		EXEC	ORCC
03000	
03100		USED SUBROUTINE:	ORCN, ORCT
03200	
03300		;
     
00100	ORCC:	PROC
00200	
00300		L	XL1,YSTEPP
00400	
00500		ASSERT<	CAILE	XP1,QCINT
00600			RFAIL	WRONG XP1 IN ORCC
00700			>
00800		XCT	[RET
00900			GOTO	ORCCSA
01000			GOTO	ORCCLE
01100			GOTO	ORCCHI
01200			GOTO	ORCCRE
01300			GOTO	ORCCIN](XP1)	;LITERAL INDEXED BY XP1
01400	
01500	
01600	ORCCSA:	;QCSAME
01700		; CHECK IF THE OPERANDS HAVE THE SAME TYPE OR TYPE QUNDEF
01800		; IF THE TYPE IS QREF THEN CHECK IF THEIR QUALIFICATIONS ARE
01900		; COMPATIBLE, I.E. THEY ARE EQUAL OR ONE IS NONE OR ONE IS A SUBCLASS
02000		; OF THE OTHER
02100	
02200		LF	X0,ZIDTYP(XL1)
02300		LF	X2,ZIDTYP(XL1,ZID%S)
02400		IF
02500			CAIN	X0,(X2)
02600			GOTO	FALSE
02700			CAIE	X2,QUNDEF
02800			CAIN	X0,QUNDEF
02900			GOTO	FALSE
03000		THEN
03100			ERROR1	23,XCUR,INCOMPATIBLE TYPES OF OPERATOR (%OPT)
03200			SETZ
03300			SF	,ZIDTYP(XL1)
03400			RET
03500	
03600		FI
03700	
03800		CAIE	X0,QREF
03900		 RET				;NOT TYPE REF
04000	
04100		WHEN	XL1,ZCN
04200		 RET		;FIRST OPERAND NONE
04300		LF	X1,ZIDZDE(XL1)
04400		SSTEP	(XL1,ZID)
04500		WHEN	XL1,ZCN
04600		 RET		;SECOND OPERAND NONE
04700		LF	X2,ZIDZDE(XL1)
04800	
04900		IF
05000			JUMPE	X1,TRUE
05100			JUMPN	X2,FALSE
05200		THEN
05300			RET				;ONE HAS QUAL. ZERO
05400		FI
05500	
05600		LF	X1,ZQUZB(X1)
05700		LF	X2,ZQUZB(X2)
05800		CAIN	X1,(X2)
05900		 RET				;SAME QUAL.
06000	
06100		L	X0,X1
06200		LOOP
06300			LF	X3,ZHBZHB(X1)
06400			CAIN	X3,(X2)
06500			 RET				;SUBCLASS
06600	
06700			L	X1,X3
06800		AS
06900			JUMPN	X1,TRUE
07000		SA
07100	
07200	
07300		LOOP
07400			LF	X3,ZHBZHB(X2)
07500			CAIN	X0,(X3)
07600			 RET				;SUBCLASS
07700	
07800			L	X2,X3
07900		AS
08000			JUMPN	X2,TRUE
08100		SA
08200	
08300	ORCCER:	L	XL1,YSTEPP
08400		LF	X1,ZIDZDE(XL1)
08500		LF	X1,ZQULID(X1)
08600		STEP	XL1,ZID
08700		LF	X2,ZIDZDE(XL1)
08800		LF	X2,ZQULID(X2)
08900		L	X3,XCUR
09000		ERRI3	QE,<Q2.ERR+^D27>
09100		ASSERT<
09200		NOP	[ASCIZ/  INCOMPATIBLE QUALIFICATIONS (%ID AND %ID) OF  OPERATOR (%OPT)/]
09300		>
09400		RET
09500	
09600	
09700	
09800	
09900	ORCCLE:	;QCLEFT
10000		; ALL OPERANDS ARE CONVERTED TO THE TYPE AND QUALIFICATION OF THE
10100		; FIRST OPERAND BY CALLING ORCN
10200	
10300		L	XP1,XL1
10400		SSTEP	(XL1,ZID)
10500		LOOP
10600			LF	X0,ZIDTYP(XP1)
10700			LF	X1,ZIDZDE(XP1)
10800			EXEC	ORCN			;CONV TO LEFT TYPE
10900		AS
11000			STEPJ	(XL1,ZID,TRUE)
11100		SA
11200		RET
11300	
11400	
11500	ORCCHI:	;QCHIGH
11600		; ALL OPERANDS ARE CONVERTED TO THE HIGHEST TYPE CODE OCCURING
11700		; AMONG THE OPERANDS.
11800	
11900		LF	X0,ZIDTYP(XL1)
12000		LF	X2,ZIDTYP(XL1,ZID%S)
12100		IF
12200			CAIGE	X0,(X2)
12300			GOTO	FALSE
12400			THEN
12500			IF
12600				CAIE	X0,(X2)
12700				GOTO	FALSE
12800				CAIN	X0,QREF
12900				CAIE	XCUR,%IFEX
13000				 RET
13100			THEN
13200					;ELSE OPERANDS
13300					; TRY TO FIND THE INNERMOST CLASS WHICH
13400					; INCLUDES THE QUAL. OF BOTH OPERANDS
13500					; AND GIVE AN ERROR MESSAGE IF NO SUCH
13600					; CLASS IS FOUND
13700	
13800			LF	X1,ZIDZDE(XL1)
13900			IF
14000				JUMPN	X1,FALSE
14100			THEN
14200				;FIRST OPERAND HAS QUAL. ZERO (I.E. NONE)
14300				LF	X1,ZIDZDE(XL1,ZID%S)
14400				SF	X1,ZIDZDE(XL1)	;SET QUAL. OF FIRST OPERAND TO
14500							; QUAL. OF SECOND OPERAND
14600				RET
14700			FI
14800			LF	X2,ZIDZDE(XL1,ZID%S)
14900			SKIPN	X2
15000			 RET			;SECOND OPERAND NONE
15100			LF	X1,ZQUZB(X1)
15200			LF	X2,ZQUZB(X2)
15300			CAMN	X2,X1
15400			 RET	; IF QUALIFS EQUAL
15500			LF	X3,ZHBZHB(X1)
15600			SKIPN	X3
15700			EXCH	X1,X2		;NO PREFIX TO X1
15800			LOOP
15900				LF	X1,ZHBZHB(X1)
16000				JUMPE	X1,ORCCER
16100				L	X3,X2
16200				LOOP
16300					IF
16400						CAME	X1,X3
16500						GOTO	FALSE
16600					THEN
16700						;SET QUAL. OF THE FIRST OPERAND
16800						; TO THE CLASS FOUND
16900						LF	X1,ZHBZQU(X1)
17000						SF	X1,ZIDZDE(XL1)
17100						RET
17200					FI
17300					LF	X3,ZHBZHB(X3)
17400				AS
17500					JUMPN	X3,TRUE
17600				SA
17700			AS
17800				GOTO	TRUE
17900			SA
18000	
18100	
18200			FI
18300			LF	X1,ZIDZDE(XL1)
18400			SSTEP	XL1,ZID
18500			EXEC	ORCN		;CONVERT SECOND OPERAND
18600		ELSE
18700			L	X0,X2
18800			LF	X1,ZIDZDE(XL1,ZID%S)
18900			EXEC	ORCN		;CONVERT FIRST OPERAND
19000		FI
19100		RET
19200	
19300	
19400	ORCCRE:	;QCREAL
19500		;[5]	THE CHECK FOR %POW IS CHANGED
19600		; IF XCUR = %POW AND SECOND OPERAND IS AN INTEGER CONSTANT IN [0,34]
19700		; THEN CHECK IF FIRST OPERAND IS THE INTEGER CONST 2.
19800		; IF SO 2^CONST WILL BE EVALUATED AT COMPILE TIME AS AN INTEGER
19900		; CONSTANT. IN ALL OTHER CASES WITH INTEGERS AS SECOND OPERAND
20000		; CHECK IF FIRST OPERAND IS AN INTEGER AND IF SO CONVERT FIRST
20100		; OPERAND TO REAL AND GIVE A WARNING MESSAGE.
20200		; STANDARD PROCESSING IS TO CONVERT ALL OPERANDS TO REAL, OR IF
20300		; ANY OPERAND OF TYPE LONG REAL IS PRESENT, TO LONG REAL.
20400	
20500		IF
20600			CAIE	XCUR,%POW
20700			GOTO	FALSE
20800			SSTEP	(XL1,ZID)
20900			IFNEQF	(XL1,ZCNTYP,QINTEGER)
21000			GOTO	FALSE
21100		THEN
21200			;[5] THE CHECK FOR %POW WITH INTEGER AS SECOND OP IS CHANGED
21300	
21400			IF
21500				RECTYPE(XL1)	IS ZCN
21600				GOTO	FALSE
21700				LF	X1,ZCNVAL(XL1)
21800				JUMPL	X1,FALSE
21900				CAIL	X1,^D35
22000				GOTO	FALSE
22100				L	XL1,YSTEPP
22200				IFNEQF	(XL1,ZCNTYP,QINTEGER)
22300				GOTO	FALSE
22400				RECTYPE (XL1) IS ZCN
22500				GOTO	FALSE
22600				LF	X1,ZCNVAL(XL1)	;[12] NOT ZCNTYP
22700				CAIE	X1,2
22800				GOTO	FALSE
22900			THEN
23000				;SECOND OPERAND IS CONST IN [0,34]
23100				; AND FIRST OP IS = INT CONST = 2
23200				; NO ACTION HERE JUST RETURN
23300				; 2^CONST WILL BE EVALUATED AT .POW
23400			ELSE
23500				L	XL1,YSTEPP
23600				IF
23700					IFNEQF	XL1,ZCNTYP,QINTEGER
23800					GOTO	FALSE
23900				THEN	;FIRST OP IS INTEGER CONVERT IT TO REAL
24000					; AND GIVE A WARNING FOR THIS CONVERSION
24100	
24200					LI	X0,QREAL
24300					EXEC	ORCN
24400					WARNING	4,INTEGER BASE CONVERTED TO REAL BEFORE EXPONENTIATION
24500				FI
24600			FI
24700			RETURN
24800		FI
24900	
25000		L	XL1,YSTEPP
25100		LI	XP1,QREAL
25200		LOOP
25300			LF	X1,ZIDTYP(XL1)
25400		AS
25500			CAIN	X1,QLREAL		;IF ANY OPERAND HAS TYPE
25600			AOJA	XP1,FALSE		;LONGREAL THEN XP1=QREAL+1
25700			STEPJ	(XL1,ZID,TRUE)		;ELSE XP1=QREAL
25800		SA
25900	
26000		L	XL1,YSTEPP
26100		LOOP
26200			L	X0,XP1
26300			EXEC	ORCN			;CONVERT TO REAL OR LREAL
26400		AS
26500			STEPJ	(XL1,ZID,TRUE)
26600		SA
26700		RETURN
26800	
26900	ORCCIN:	;QCINT
27000		; ALL OPERANDS ARE CONVERTED TO TYPE QINTEGER
27100	
27200		LOOP
27300			LI	X0,QINTEGER
27400			EXEC	ORCN			;CONVERT TO INTEGER
27500		AS
27600			STEPJ	(XL1,ZID,TRUE)
27700		SA
27800	
27900		RETURN
28000	
28100		EPROC
     
00100		SUBTTL	ORCT
00200		COMMENT;
00300	
00400		PURPOSE:	CHECK THE TYPE OF THE FIRST OPERAND ACCORDING
00500				TO A CODE IN XP1.
00600	
00700		ENTRY:	ORCT
00800		INPUT ARGUMENTS:	A CHECK CODE IN XP1 AS FOLLOWS
00900	
01000			XP1		CHECK ACTION
01100			-----------------------------------------------
01200			1-9		TYPE = CODE IN XP1
01300			QARITH		ARITHMETIC TYPE ( <= QLREAL )
01400			QTXREF		TYPE = QTEXT OR QREF
01500			QNREF		TYPE \= (QREF OR QLABEL)
01600			QNRFBO		TYPE \= (QREF OR QBOOLEAN OR QLABEL)
01700	
01800		NORMAL EXIT:	RETURN
01900	
02000		ERROR EXIT:	RETURN
02100	
02200		OUTPUT ARGUMENTS:	NONE
02300	
02400		CALL FORMAT:		EXEC	ORCT
02500	
02600		;
     
00100	ORCT:	PROC
00200	
00300		L	X1,YFOP
00400		LF	X0,ZIDTYP(X1)
00500		ASSERT<	CAILE	XP1,QNRFBO
00600			RFAIL	WRONG XP1 IN ORCT
00700			>
00800		CAIGE	XP1,QARITH
00900		 GOTO	ORCTTY
01000		SUBI	XP1,QARITH
01100		XCT	[GOTO	ORCTAR
01200			GOTO	ORCTTR
01300			GOTO	ORCTNR
01400			GOTO	ORCTN](XP1)	;LITERAL INDEXED BY XP1
01500	
01600	
01700	ORCTTY:	;CODE 1-9
01800		; CHECK IF FIRST OPERAND (FOP) HAS THE SAME TYPE CODE AS THE CODE
01900		; IN XP1
02000	
02100		CAIN	X0,(XP1)
02200		 RET
02300		GOTO	ORCTER
02400	
02500	
02600	ORCTAR:	;QARITH
02700		; CHECK IF FOP HAS A TYPE CODE THAT IS <= QLREAL
02800	
02900		CAIG	X0,QLREAL
03000		 RET
03100		GOTO	ORCTER
03200	
03300	
03400	ORCTTR:	;QTXREF
03500		; CHECK IF FOP HAS TYPE QTEXT OR QREF
03600	
03700		CAIE 	X0,QTEXT
03800		CAIN	X0,QREF
03900		 RET
04000		GOTO	ORCTER
04100	
04200	
04300	ORCTN:	;QNRFBO
04400		; CHECK IF FOP HAS NOT TYPE QREF, QBOOLEAN OR QLABEL
04500	
04600		CAIN	X0,QBOOLEAN
04700		 GOTO	ORCTER
04800		;CONTINUE TO ORCTNR
04900	
05000	
05100	ORCTNR:	;QNREF
05200		; CHECK IF FOP HAS NOT TYPE QREF OR QLABEL
05300	
05400		CAIE	X0,QREF
05500		CAIN	X0,QLABEL
05600		 GOTO	ORCTER
05700		RET
05800	
05900	
06000	
06100	ORCTER:	SKIPE		;ACCEPT UNDEFINED
06200		 ERROR1	24,XCUR, INVALID OPERAND TYPE OF OPERATOR (%OPT)
06300		 RET
06400	
06500	
06600		EPROC
     
00100		SUBTTL	ORDT
00200		COMMENT;
00300	
00400		PURPOSE:	TO PROCESS A DOT OPERAND
00500	
00600		ENTRY:		ORDT
00700	
00800		INPUT ARGUMENTS:	NONE
00900	
01000		NORMAL EXIT:		BRANCH ORMV
01100	
01200		ERROR EXIT:		RETURN
01300	
01400		OUTPUT ARGUMENTS:	NONE
01500	
01600		CALL FORMAT:		EXEC	ORDT
01700	
01800		USED SUBROUTINES:	ORBU, ORCT, ORLD, ORLU, ORMV, ORSM
01900	
02000		;
     
00100	ORDT:	PROC
00200	
00300		HRRZ	XP1,YOPSTP			;SET YFOP AND YSTEPP
00400		SUBI	XP1,3
00500		ASSERT<	CAMGE	XP1,YOPSTB
00600			RFAIL	(STACK UNDERFLOW IN ORDT)>
00700		ST	XP1,YFOP
00800		HRLI	XP1,-3				; -3 ,, YOPSTP-3
00900		ST	XP1,YSTEPP
01000		IF	;[174]
01100			LI	X0,(XP1)
01200			EXEC	ORTXCH
01300			GOTO	FALSE
01400		THEN
01500			ERROR2	46,CONSTANT BEFORE DOT
01600		FI
01700		WHEN	XP1,ZLI
01800		EXEC	ORLU				;LOOK UP FIRST OPERAND
01900	
02000		EXEC	ORSM				;CHECK KIND SIMPLE
02100	
02200		LI	XP1,QTXREF
02300		EXEC	ORCT				;CHECK TYPE REF OR TEXT
02400		L	XP1,YFOP
02500		LF	,ZNSTYP(XP1)
02600		L	X1,YTEXTI
02700		CAIN	QTEXT
02800		SF	X1,ZNSZQU(XP1)
02900		LF	X1,ZNSZQU(XP1)
03000		STEP	XP1,ZID
03100		IF
03200			JUMPE	X1,TRUE
03300			cain	x1,yundec
03400			goto	true
03500			JUMPE	X0,TRUE
03600			CAIE	QTEXT
03700			CAIN	QREF
03800			SKIPA		; REF OR TEXT
03900			GOTO	TRUE	; NOT TEXT OR REF
04000			WHEN	XP1,ZLI
04100			GOTO	FALSE
04200		THEN
04300			;UNDEFINED FIRST OR SECOND OPERAND
04400	
04500	L1():!		LI	X1,YUNDEC
04600			EXEC	ORLD
04700			SETF	QZNS,ZNOTYP(,XV1)
04800			SETF	%DOT,ZNSGEN(,XV1)
04900			BRANCH	ORMV
05000		FI
05100	
05200		L	XP1,YFOP
05300	
05400							;GIVE AN ERRORMESSAGE IF THE
05500							; QUALIFYING CLASS HAS ITS
05600							; ZHBKDP SET
05700		LF	X4,ZIDZDE(XP1)
05800		LF	X2,ZQUZB(X4)
05900		IF
06000			IFOFF	ZHBKDP(X2)
06100			GOTO	FALSE
06200		THEN
06300			LF	X2,ZQULID(X4)
06400			ERROR1	25, X2, INVALID REMOTE ACCESS CLASS (%ID) HAS LOCAL CLASS ATTR.
06500			STEP	XP1,ZID
06600			GOTO	L1
06700		FI
06800	
06900	
07000		;SEARCH IN THE ATTRIBUTE LISTS OF THE QUALIFYING CLASS AND ITS PREFIXES
07100		; FOR THE ID-NUMBER OF THE SECOND OPERAND AND TRANSFORM THIS OPERAND
07200		; TO A ZID NODE BY CALLING ORLD. MOVE THE OPERANDS INTO THE TREE AND
07300		; REPLACE THEM WITH A ZNS NODE WITH ZNSGEN = %DOT IN THE OPERAND STACK
07400	
07500		STEP	XP1,ZID
07600		LF	X3,ZLILID(XP1)
07700		LOOP
07800			STEP	(X2,ZHB,X1)
07900			WHILE				;ZQU RECORD
08000				RECTYPE(X1)	IS ZQU
08100				GOTO	FALSE
08200			DO
08300				LF	X0,ZQULID(X1)
08400				IF
08500					CAIE	X0,(X3)
08600					GOTO	FALSE
08700					IFON	ZQUIVA(X1)	;[40]
08800					GOTO	FALSE
08900				THEN
09000					EXEC ORLD	;TRANSFORM SECOND OPERAND
09100					LF	,ZQUTYP(X1)
09200					CAIN	QLABEL
09300					ERROR1	24,XCUR, INVALID LABEL TYPE OPERAND OF DOT
09400	
09500					SETF	(%DOT) ZNSGEN(,XV1)
09600					SETF	(QZNS) ZNOTYP(,XV1)
09700					EXEC	ORBU		;SET ZNS-SEF,-LEV,-ROR
09800	
09900					BRANCH	ORMV		;PLACE OPERANDS IN TREE
10000	
10100				FI
10200				STEP	(X1,ZQU)
10300			OD
10400			LF	X2,ZHBZHB(X2)		;GET PREFIX
10500		AS
10600			WHEN	(X2,ZHB)
10700			GOTO	TRUE
10800		SA
10900		L	X1,X3
11000		LF	X2,ZQULID(X4)
11100		ERRI2	QE,<Q2.ERR+^D41>
11200		ASSERT<
11300		NOP	[ASCIZ/ INVALID REMOTE ACCESS (%ID) IS NOT AN ATTRIBUTE OF (%ID)/]
11400		>
11500	
11600		GOTO	L1
11700	
11800		EPROC
     
00100		SUBTTL	ORLU
00200		COMMENT;
00300	
00400		PURPOSE:	TO LOOK UP AN IDENTIFIER IN THE DICTIONARY AND TRANSFORM
00500				A ZLI NODE TO A ZID NODE IN THE OPERAND STACK.
00600	
00700		ENTRY:	ORLU
00800	
00900		INPUT ARGUMENTS:	THE ZLI NODE ADDRESS IS PASSED IN XP1
01000	
01100		NORMAL EXIT:		BRANCH ORLD
01200	
01300		ERROR EXIT:		NONE
01400	
01500		CALL FORMAT:		EXEC	ORLU
01600	
01700		USED SUBROUTINE:	ORLD
01800	
01900		;
     
00100	ORLU:	PROC
00200	
00300		ASSERT<			;VERIFY THAT THE NODE AT XP1 IS A ZLI NODE
00400			WHENNOT	(XP1,ZLI)
00500			RFAIL	(NOT ZLI NODE AT XP1 WHEN CALLING ORLU)>
00600	
00700	
00800		LF	X2,ZLILID(XP1)
00900		ASSERT<			;TEST ID-NO IN RANGE
01000			CAIL	X2,QLOWID
01100			CAMLE	X2,YMAXID
01200			RFAIL	(ID-NO NOT IN RANGE FOUND IN ORLU)>
01300	
01400		;IF THE ZDCZQU IN THE DICTIONARY ENTRY IS ZERO THEN GIVE AN ERROR
01500		; MESSAGE AND INSERT A POINTER TO A DUMMY ZQU RECORD AND PROCEED
01600	
01700		ADDI	X2,YDICTB
01800		LF	X1,ZDCZQU(X2)
01900		IF
02000			JUMPN	X1,FALSE
02100		THEN
02200			LI	X1,YUNDEC
02300			SF	X1,ZDCZQU(X2)
02400			SUBI	X2,YDICTB
02500			ERROR1	26, X2, IDENTIFIER (%ID) IS NOT DECLARED
02600		FI
02700		BRANCH	ORLD
02800	
02900	
03000		EPROC
     
00100		SUBTTL	ORLD
00200		COMMENT;
00300	
00400		PURPOSE:	TO TRANSFORM A ZLI NODE TO A ZID NODE IN THE
00500				OPERAND STACK BY MEANS OF A SUPPLIED ZQU POINTER IN X1
00600	
00700		ENTRY:		ORLD
00800	
00900		INPUT ARGUMENTS:	A ZQU POINTER IN X1
01000					AND THE ZLI NODE ADDRESS IN XP1
01100	
01200		NORMAL EXIT:		RETURN
01300	
01400		ERROR EXIT:		NONE
01500	
01600		CALL FORMAT:		EXEC	ORLD
01700	
01800		;
     
00100	ORLD:	PROC
00200	
00300		ASSERT<			;VERIFY THAT THE NODE AT XP1 IS A ZLI NODE
00400			IF	CAIN	X1,YUNDEC
00500				GOTO	FALSE
00600			THEN
00700				WHENNOT	(XP1,ZLI)
00800				RFAIL	(NOT ZLI NODE AT XP1 WHEN CALLING ORLD)
00900				;TEST THAT X1 POINTS TO A ZQU RECORD IN THE DEC. STACK
01000				WHENNOT	(X1,ZQU)
01100				RFAIL	(X1 DOES NOT POINT TO A ZQU RECORD WHEN CALLING ORLD)
01200				CAMLE	X1,YDCSTB
01300				CAML	X1,YDCSTP
01400				RFAIL	(X1 POINTS OUT OF THE DECLARATION STACK IN ORLD)
01500			FI
01600		>
01700	
01800		;BUILD UP A ZID RECORD IN XV1-XV2 AND LET IT REPLACE THE ZLI RECORD
01900		; AT XP1.
02000	
02100		WLF	XV1,ZQUZHE(X1)
02200		WLF	XV2,ZQUZB(X1)
02300		SF	X1,ZIDZQU(,XV1)
02400		SETF	QZID,ZNOTYP(,XV1)
02500		TLZ	XV1,(1B<%ZNOLST>)	; SETOFF ZNOLST
02600		TLO	XV1,(1B<%ZNOTER>)	; SETON ZNOTER
02700		STD	XV1,(XP1)
02800	
02900		CAIE	X1,YUNDEC
03000		RETURN
03100		SETON	SCERFL
03200		RETURN
03300	
03400		EPROC
     
00100		SUBTTL	ORRP
00200		COMMENT;
00300		PURPOSE:	TO PROCESS A %RP (RIGHT PARENTHESIS) OPERATOR
00400		ENTRY:		ORRP
00500		INPUT ARGUMENTS:	A POINTER TO THE LAST OCCUPIED WORD IN THE
00600					OPERAND STACK (YOPSTP) AND A POINTER TO THE
00700					FIRST OCCUPIED WORD IN THE TREE (YEXPP)
00800		NORMAL EXIT:		BRANCH ORMV
00900		ERROR EXIT:		NONE
01000		CALL FORMAT:		EXEC ORRP
01100		USED SUBROUTINES:	LOCAL:	ORRPPP, ORRPER
01200					GLOBAL:	ORLU, ORCN, ORSM, ORMV, ORBU
01300		;
01400	
01500	
01600	
01700	ORRPER:
01800	
01900			;CHECK IF FORMAL OR ACTUAL PARAM. HAS KIND OR TYPE QUNDEF
02000	
02100		IF
02200			L	X0,(XL1)
02300			TLNE	X0,QTYPM
02400			TLNN	X0,QKNDM
02500			GOTO	FALSE
02600			L	X0,(XP1)
02700			TLNE	X0,QTYPM
02800			TLNN	X0,QKNDM
02900			GOTO	FALSE
03000		THEN
03100		ELSE
03200			UNSTK		;FORGET RETURN ADDRESS
03300			GOTO	ORRPOK
03400		FI
03500	
03600				;LOAD X1 AND X2 WITH LEXICAL ID OF FORMAL PARAMETER
03700				; AND PARENT NODE RESPECTIVELY
03800		LF	X1,ZQULID(XP1)
03900		LF	X2,ZIDZQU(XP2)
04000		LF	X2,ZQULID(X2)
04100		RETURN
     
00100		SUBTTL	ORRPPP
00200		COMMENT;
00300		PURPOSE:	TO PROCESS ACTUAL-FORMAL PARAMETER PAIRS
00400		ENTRY:		ORRPPP
00500		INPUT ARGUMENTS:	XP1 POINTS TO THE FORMAL PARAMETER
00600					LIST HEADER (ZHB)
00700					XL1 POINTS TO THE ACTUAL PARAMETER IN THE
00800					OPERAND STACK
00900		NORMAL EXIT:		RETURN
01000		ERROR EXIT:		NONE
01100		CALL FORMAT:		EXEC ORRPPP
01200		USED SUBROUTINES:	ORSM, ORCN, ORRPER
01300		;
     
00100	ORRPPP:	PROC
00200	
00300		;The compatibility of formal and actual parameters is checked.
00400		; To connect the actual parameter to its corresponding formal parameter
00500		; the ZID nodes of both parameters are placed in the tree
00600		; and the actual parameter in the operand stack is replaced by
00700		; a ZNS node with ZNSGEN = %PARM.
00800		; XP2:- PROCEDURE or CLASS ZID [330]
00900	
01000		STEP	(XP1,ZHB)
01100		WHILE		;ZQU of mode VALUE, NAME or REFERENCE at XP1
01200		    RECTYPE(XP1) IS ZQU
01300		    GOTO FALSE
01400		    LF ,ZQUMOD(XP1)	;[40]
01500		    JUMPE FALSE
01600		    CAILE QREFER
01700		    GOTO FALSE
01800		DO	;Check parameter compatibility
01900			; XP1 points to the formal parameter ZQU node and
02000			; XL1	"     "  "  actual	"    node in the operand stack
02100	
02200	
02300	
02400			;Check if type and kind equal
02500	
02600	L2():!	    L	X0,(XP1)
02700		    XOR	X0,(XL1)
02800		    IF	;Type and kind are both equal
02900			TLNE	X0,QTYPM+QKNDM
03000			GOTO	FALSE
03100		    THEN
03200			LF	X1,ZIDTYP(XL1)
03300			IF		;Type = QREF
03400			    CAIE	X1,QREF
03500			    GOTO	FALSE
03600			THEN
03700			    IF	;Formal parameter has mode reference then the
03800				; qualification of the actual parameter is
03900				; checked by ORCN, else the qualifications must
04000				; be compatible (the same test as in ORCC QCSAME)
04100	
04200				IFNEQF	(XP1,ZQUMOD,QREFER)
04300				GOTO	FALSE
04400			    THEN
04500				LI	X0,QREF
04600				LF	X1,ZQUZQU(XP1)
04700				EXEC	ORCN
04800			    ELSE
04900				LF	X1,ZIDZDE(XL1)
05000				LF	X2,ZQUZQU(XP1)
05100				JUMPE	X1,ORRPOK
05200				JUMPE	X2,ORRPOK	;One has qual zero
05300				LF	X1,ZQUZB(X1)
05400				LF	X1,ZHBZQU(X1)
05500				LF	X2,ZQUZB(X2)
05600				LF	X2,ZHBZQU(X2)
05700				CAIN	X1,(X2)
05800				 GOTO	ORRPOK		;Same qual
05900				LF	X1,ZQUZB(X1)
06000				LF	X2,ZQUZB(X2)
06100				L	X0,X1
06200				LOOP
06300				    LF		X3,ZHBZHB(X1)
06400				    CAIN	X3,(X2)
06500				     GOTO	ORRPOK	;Subclass
06600				    L		X1,X3
06700				AS
06800				    JUMPN	X1,TRUE
06900				SA
07000				LOOP
07100				    LF		X3,ZHBZHB(X2)
07200				    CAIN	X0,(X3)
07300				     GOTO	ORRPOK	;Subclass
07400				    L		X2,X3
07500				AS
07600				    JUMPN	X2,TRUE
07700				SA
07800				EXEC	ORRPER
07900				ERRI2	QE,<Q2.ERR+^D42>
08000				ASSERT<
08100				NOP	[ASCIZ/ INCOMPATIBLE QUALIFICATIONS OF PARAMETERS CORRESPONDING TO FORMAL (%ID) OF (%ID)/]
08200				>
08300				GOTO	ORRP.E
08400			    FI
08500			ELSE
08600			    LF	X0,ZQUMOD(XP1)
08700			    IF		;formal parameter has mode reference and
08800					; type arithmetic then the actual param.
08900					; is not allowed to have mode NAME
09000					; or be a constant or an expression
09100					; other than %DOT or %RP
09200				CAIN	X0,QREFER
09300				CAILE	X1,QLREAL
09400				GOTO	FALSE
09500			    THEN
09600				IF	;Actual is a NAME param transmitted
09700					IFNEQF	XL1,ZIDMOD,QNAME
09800					GOTO	FALSE
09900				THEN
10000					EXEC	ORRPER
10100					ERRI2	QE,<Q2.ERR+^D43>
10200					ASSERT<
10300					NOP	[ASCIZ/ INVALID ACTUAL PARAMETER MODE CORRESPONDING TO FORMAL PARAMETER (%ID) OF (%ID)/]
10400					>
10500					GOTO	ORRP.E
10600				FI
10700				IF
10800					WHEN	XL1,ZCN
10900					GOTO	TRUE
11000					WHENNOT	XL1,ZNS
11100					GOTO	FALSE
11200					LF	,ZNSGEN(XL1)
11300					CAIE	%DOT
11400					CAIN	%RP
11500					GOTO	FALSE
11600				THEN
11700	ORRPPX:				EXEC	ORRPER
11800					ERRI2	QE,<Q2.ERR+^D44>
11900					ASSERT<
12000					NOP	[ASCIZ/ ILLEGAL EXPRESSION AS ACTUAL PARAMETER CORRESPONDING TO FORMAL (%ID) OF (%ID)/]
12100					>
12200					GOTO	ORRP.E
12300				FI
12400			    FI
12500			    IF		;Actual parameter is a string
12600					; =/= NOTEXT
12700					; then the mode of the formal parameter
12800						; is not allowed to be reference
12900				IFNEQF	(XP1,ZQUMOD,QREFER)
13000				GOTO	FALSE
13100				CAIE	X1,QTEXT
13200				GOTO	FALSE
13300				RECTYPE(XL1) IS ZCN
13400				GOTO	FALSE
13500				IFEQF	(XL1,ZCNVAL,0)	;NOTEXT
13600				GOTO	FALSE
13700			    THEN
13800				EXEC	ORRPER
13900				ERRI2	QE,<Q2.ERR+^D30>
14000				ASSERT<
14100				NOP	[ASCIZ/TEXT CONSTANT IS NOT VALID ACTUAL PARAMETER FOR REFERENCE MODE FORMAL (%ID) OF (%ID)/]
14200				>
14300				GOTO	ORRP.E
14400			    FI
14500			    IF		;[174] If formal has type TEXT and mode
14600					; not by value, then the actual parameter
14700					; may not contain a conditional text constant.
14800				CAIE	X1,QTEXT
14900				GOTO	FALSE
15000				IFEQF	(XP1,ZQUMOD,QVALUE)
15100				GOTO	FALSE
15200				WHEN	XL1,ZCN
15300				GOTO	FALSE
15400				L	X0,XL1
15500				EXEC	ORTXCH
15600				GOTO	FALSE
15700			    THEN
15800				GOTO	ORRPPX
15900			    FI
16000			FI
16100		    ELSE
16200			IF		;Kind equal
16300			    TLNE	X0,QKNDM
16400			    GOTO	FALSE
16500			THEN
16600			    LF	X1,ZIDTYP(XL1)
16700			    LF	X0,ZQUTYP(XP1)
16800			    IF		;Types arithmetic (  <=QLREAL )
16900				CAIG	X0,QLREAL
17000				CAILE	X1,QLREAL
17100				GOTO	FALSE
17200			    THEN
17300				IF		;kind = QSIMPLE and mode not NAME
17400						; CONVERT ACTUAL
17500						; PARAMETER TO FORMAL TYPE
17600				    LF		X2,ZIDKND(XL1)
17700				    CAIE	X2,QSIMPLE
17800				    GOTO	FALSE
17900				    LF		X2,ZQUMOD(XP1)
18000				    CAIN	X2,QNAME
18100				    GOTO	FALSE
18200				THEN
18300				    CAIN	X2,QREFER
18400				    GOTO	L3	;different types are not allowed
18500							; for arithm. types if formal
18600							; PARAM. HAS MODE QREFER
18700	
18800				    EXEC	ORCN
18900				    GOTO	ORRPOK
19000				FI
19100				LF	,ZIDKND(XL1)	;[35]
19200				CAIE	QPROCEDURE	;[35]
19300				CAIN	QARRAY		;[35]
19400				 GOTO	L3		;[35]
19500				GOTO	ORRPOK		;DIFFERENT TYPES ARE NOT ALLOWED
19600							; FOR KIND = QARRAY or QPROCEDURE ;[35]
19700	
19800			    ELSE
19900			      IF			;IF FORMAL PARAM. TYPE IS QRLREA
20000							; THE ACTUAL PARAM. MUST BE
20100							; ARITHMETIC AND CONVERTED TO
20200							; REAL IF IT IS OF TYPE INTEGER
20300				  CAIE	X0,QRLREA
20400				  GOTO	FALSE
20500			      THEN
20600				  IF	;Actual is integer
20700					CAIE	X1,QINTEG
20800					GOTO	FALSE
20900				  THEN	;Convert to real, unless we have Abs
21000					edit(330)	;[330]
21100					LF X1,ZIDZQU(XP2)
21200					LF X1,ZQUSNR(X1)	;System subr no.
21300					IF	;Abs
21400						CAIE X1,SYSI1 ;Code for Abs
21500						GOTO FALSE
21600					THEN	;Change ZIDTYP to INTEGER, no conv
21700						LI X1,QINTEG
21800						SF X1,ZIDTYP(XP2)
21900					ELSE
22000						LI X1,QINTEG
22100						LI	X0,QREAL
22200						EXEC	ORCN
22300						LI	X1,QREAL
22400					FI
22500				  FI
22600				  ST	X1,YORPAR
22700				  CAIG	X1,QLREAL
22800				   GOTO	ORRPOK
22900				  SETZM	YORPAR
23000			      ELSE
23100				IF	;Formal is a procedure
23200				    IFNEQF	(XL1,ZIDKND,QPROCEDURE)
23300				    GOTO	FALSE
23400				THEN	;Notype allowed
23500				    IFEQF	XP1,ZQUTYP,QNOTYPE
23600				     GOTO	ORRPOK
23700				FI
23800			      FI
23900			    FI
24000	L3():!		    EXEC ORRPER
24100			ERRI2	QE,<Q2.ERR+^D32>
24200			SETON	SCERFL	;[35]
24300			LI	QRELCD
24400			ST	YGAP
24500			L	[RTSERR QSORCEERR]
24600			GENABS
24700			    ASSERT<
24800			    NOP	[ASCIZ/ INVALID ACTUAL PARAMETER TYPE CORRESPONDS TO FORMAL PARAMETER (%ID)  OF (%ID)/]
24900			    >
25000			    GOTO	ORRP.E
25100			ELSE
25200			    IF			;Formal parameter kind = QSIMPLE and
25300						; actual parameter kind = QPROCEDURE
25400						; then the actual parameter may
25500						; be changed to kind QSIMPLE by
25600						; calling ORSM
25700	
25800				IFNEQF	(XP1,ZQUKND,QSIMPLE)
25900				GOTO	FALSE
26000				IFNEQF	(XL1,ZIDKND,QPROCEDURE)
26100				GOTO	FALSE
26200			    THEN
26300				EXCH	XL1,XP1
26400				EXEC	ORSM
26500				EXCH	XL1,XP1
26600				IFEQF	(XL1,ZIDKND,QSIMPLE)
26700				 GOTO	L2	;Kind equal (=QSIMPLE)
26800			    FI
26900			    EXEC ORRPER
27000			    ERRI2	QE,<Q2.ERR+^D31>
27100			    ASSERT<
27200			    NOP	[ASCIZ/ INVALID ACTUAL PARAMETER KIND CORRESPONDS TO FORMAL PARAMETER (%ID) OF (%ID)/]
27300			    >
27400				GOTO	ORRP.E
27500			FI
27600		    FI
27700	
27800	ORRPOK:			;Copy the actual parameter node
27900				; into the tree
28000	
28100		    L		X2,YEXPP
28200		    SUBI	X2,<2*ZNO%S>
28300		    ST		X2,YEXPP
28400		    LD		X0,(XL1)
28500		    STD		X0,(X2)
28600	
28700				;Build a ZID node in XV1-XV2 from the formal
28800				; parameter ZQU node, and put it in the tree
28900				; after the actual parameter.
29000	
29100		    WLF		XV1,ZQUZHE(XP1)
29200		    WLF		XV2,ZQUZB(XP1)
29300		    SETOFA	ZNOTER(XV1)
29400		    SETONA	ZNOLST(XV1)
29500		    SF		XP1,ZIDZQU(,XV1)
29600		    SETF	QZID,ZNOTYP(,XV1)
29700		    STD		XV1,ZNO%S(X2)
29800	
29900				;Transform the actual param. node in the operand
30000				; stack to a ZNS node with ZNSGEN = %PARM
30100	
30200		    SETF	QZNS,ZNOTYP(XL1)
30300		    SF		X2,ZNSZNO(XL1)
30400		    SETF	%PARM,ZNSGEN(XL1)
30500			SETOFF	ZNOLST(XL1)
30600	
30700	ORRP.E:		 	; Error exit from parameter checks
30800				;Make XP1 and XL1 point to next node
30900		    STEP	(XP1,ZQU)
31000		    STEP	(XL1,ZID)
31100	
31200		OD
31300	
31400		RETURN
31500	
31600		EPROC
     
00100		SUBTTL	ORRP
00200	ORRP:	PROC
00300	
00400			;Search backwards in the operand stack for a ZOS node.
00500			; Look up all ZLI nodes on the way.
00600			; Count the number of operands passed (i.e. number of parameters).
00700	
00800		SETZM	YORPAR
00900		HRRZ	XP1,YOPSTP
01000		SOJ	XP1,
01100		LOOP
01200			LF	X1,ZNOTYP(XP1)
01300			ASSERT<	CAIL	X1,ZNN%V
01400				RFAIL	WRONG PARAM. NODE TYPE IN ORRP
01500				>
01600			;THE NEXT LITERAL IS INDEXED BY X1
01700	
01800			XCT	[GOTO	FALSE		;END OF LOOP
01900				GOTO	[AOS	YNZID	;ZLI OPERAND
02000					EXEC	ORLU
02100					GOTO	.+1]	;OUTSIDE LITERALS
02200				AOS	YNZCN
02300				AOS	YNZID
02400				AOS	YNZNS](X1)
02500			AOS	YNOPD
02600			SUBI	XP1,ZNO%S
02700		AS
02800			GOTO	TRUE
02900		SA
03000	
03100		;SET YFOP TO POINT TO THE FIRST PARAMETER NODE
03200	
03300		LI	X0,ZOS%S(XP1)
03400		ST	X0,YFOP
03500	
03600		;SET YSTEPP TO -<2*NUMBER OF PARAM.-1>,,YFOP
03700	
03800		L	X1,X0
03900		SUB	X1,YOPSTP
04000		HRL	X0,X1
04100		ST	X0,YSTEPP
04200	
04300	
04400		; LOOK UP THE NODE IN FRONT OF THE ZOS NODE IF IT IS A ZLI NODE
04500	
04600		SUBI	XP1,ZNO%S
04700		IF
04800			RECTYPE(XP1) IS ZLI
04900			GOTO	FALSE
05000		THEN
05100			EXEC	ORLU
05200		ELSE	;IF IT IS A ZNS NODE (I.E. DOT NOTATION) FIND ITS SECOND OPERAND
05300	
05400			IF
05500				RECTYPE(XP1)	IS ZNS
05600				GOTO	FALSE
05700			THEN
05800				ASSERT<	IFNEQF	(XP1,ZNSGEN,%DOT)
05900					RFAIL	(ZNS BUT NOT %DOT IN FRONT OF ZOS IN ORRP)>
06000				LF	XP1,ZNSZNO(XP1)
06100				STEP	XP1,ZNO
06200			FI
06300		FI
06400		ASSERT<	WHENNOT	XP1,ZID
06500			RFAIL	(PARENT ZID NOT FOUND IN ORRP)>
06600	
06700		L	XP2,XP1
06800	
06900		;NOW XP1 AND XP2 POINTS TO THE ZID NODE WHOSE FIRST PARAMETER
07000		; NODE LIES IN THE OPERAND STACK AT YFOP
07100	
07200		LF	X1,ZIDKND(XP1)
07300	
07400		;IF SWITCH (I.E. LABEL PROCEDURE) THEN CHECK THAT THERE IS ONE
07500		; PARAMETER ONLY, AND THAT THIS SWITCH INDEX IS OF KIND SIMPLE
07600		; AND CONVERT IT TO TYPE INTEGER
07700		IF
07800			CAIE	X1,QPROCEDURE
07900			GOTO	FALSE
08000			IFNEQF	(XP1,ZIDTYP,QLABEL)
08100			GOTO	FALSE
08200		THEN
08300			IF
08400			    SOSE	YNOPD
08500			    GOTO	FALSE
08600			THEN
08700			    L	XP1,YFOP
08800			    EXEC	ORSM
08900			    L		XL1,XP1
09000			    LI		X0,QINTEGER
09100			    EXEC	ORCN
09200			ELSE
09300			    LF	X2,ZIDZQU(XP2)
09400			    LF	X2,ZQULID(X2)
09500			    ERROR1	9, X2, INCORRECT NUMBER OF SUBSCRIPTS TO (%ID);
09600			FI
09700			GOTO	L1
09800		FI
09900	
10000	
10100		IF		;KIND = QPROCEDURE OR QCLASS?
10200			CAIN	X1,QPROCEDURE
10300			GOTO	TRUE
10400			CAIE	X1,QCLASS
10500			GOTO	FALSE
10600		THEN		;FOR PROCEDURE AND CLASS CHECK THAT THE
10700				; PARAMETERS WERE NOT PRECEDED BY A [
10800			L	X2,YFOP
10900			SUBI	X2,ZNO%S
11000			IF
11100			    IFOFF	ZOSLB(X2)
11200			    GOTO	FALSE
11300			THEN
11400			    LF	X2,ZIDZQU(XP2)
11500			    LF	X2,ZQULID(X2)
11600			    ERROR1	20, X2, LEFT BRACKET AFTER (%ID) SHOULD BE LEFT PARENTHESIS
11700			FI
11800			IF		;IF MODE QDECLARED THEN CHECK NUMBER AND
11900					; COMPATIBILITY OF PARAMETERS
12000	
12100			    IFNEQF	(XP2,ZIDMOD,QDECLARED)
12200			    GOTO	FALSE
12300			THEN
12400			    LF	XP1,ZIDZQU(XP2)
12500			    LF	XP1,ZQUZB(XP1)
12600			    CAIN	X1,QCLASS
12700			    GOTO	L2
12800			    IFON	ZHBNCK(XP1)
12900			    GOTO	FALSE
13000	L2():!		    SETZ	X3,
13100			    L	X1,XP1
13200			    LOOP
13300				ADD	X3,OFFSET(ZHBNRP)(X1)
13400				IFN<<%ZHBNRP-7>>,<
13500				CFAIL	(ZHBNRP MASK IN ORRP MUST BE CHANGED)>
13600				AND	X3,[776000,,0]
13700				LF	X1,ZHBZHB(X1)
13800			    AS
13900				JUMPE	X1,FALSE
14000				WHEN	X1,ZHB
14100				GOTO	TRUE
14200			    SA
14300			    LF	X0,ZHBNRP(,X3-<OFFSET(ZHBNRP)>)
14400			    IF
14500				CAME	X0,YNOPD
14600				GOTO	FALSE
14700			    THEN
14800				L	XL1,YFOP	;LET XL1 POINT TO THE FIRST
14900							; ACTUAL PARAMETER
15000				IF		;IF CLASS AND A PREFIX CLASS EXIST
15100						; THEN STACK THE ZHB POINTER TO THE
15200						; ATTRIBUTE LIST HEADER AND COUNT THE
15300						; NUMBER OF STACKINGS IN STKNUM
15400	
15500				    IFNEQF	(XP2,ZIDKND,QCLASS)
15600				    GOTO	FALSE
15700				THEN
15800				    SETZM	YSTKNU
15900				    WHILE
16000					IFEQF	(XP1,ZHBZHB,0)
16100					GOTO	FALSE
16200				    DO
16300					STACK	XP1
16400					AOS	YSTKNU
16500					LF	XP1,ZHBZHB(XP1)
16600				    OD
16700	
16800					;PROCESS CLASS PARAMETERS
16900	
17000				    LOOP
17100					EXEC	ORRPPP
17200				    AS
17300					SKIPN	YSTKNU
17400					GOTO	FALSE
17500					SOS	YSTKNU
17600					UNSTK	XP1
17700					GOTO	TRUE
17800				    SA
17900				ELSE	;PROCESS PROCEDURE PARAMETERS
18000				    EXEC	ORRPPP
18100				FI
18200			ASSERT<			;TEST THAT ALL ACTUAL PARAMETERS HAS
18300						; BEEN PROCESSED
18400				SUB	XL1,YOPSTP
18500				SOJ	XL1,
18600				TRNE	XL1,-1
18700				 RFAIL	(INCORRECT PARAMETER PROCESSING IN ORRP)>
18800			    ELSE
18900				LF	X2,ZIDZQU(XP2)
19000				LF	X2,ZQULID(X2)
19100				ERROR1	7, X2, INCORRECT NUMBER OF PARAMETERS TO (%ID);
19200			    FI
19300			ELSE		;[133]
19400				EXEC	ORRPIV	;[133] Search for system procedures
19500			FI
19600		ELSE
19700			IF		;FOR AN ARRAY THE NUMBER OF SUBSCRIPTS IS CHECKED
19800					; IF ITS MODE IS QDECLARED
19900					; EACH SUBSCRIPT NODE IS CHECKED TO BE OF KIND
20000					; QSIMPLE AND CONVERTED TO TYPE QINTEGER
20100	
20200			    IFNEQF	(XP2,ZIDKND,QARRAY)
20300			    GOTO	FALSE
20400			THEN
20500			    IF
20600				IFNEQF	(XP2,ZIDMOD,QDECLARED)
20700				GOTO	TRUE
20800				LF	XP1,ZIDZQU(XP2)
20900				LF	X0,ZQUNSB(XP1)
21000				CAME	X0,YNOPD
21100				GOTO	FALSE
21200			    THEN
21300				L	XL1,YFOP
21400				LOOP
21500				    IF	LF	,ZNSTYP(XL1)
21600					CAIG	QLREAL
21700					GOTO	FALSE
21800				    THEN	; NONARITHMETIC SUBSCRIPT
21900					LF	X2,ZIDZQU(XP2)
22000					LF	X2,ZQULID(X2)
22100					ERROR1	16,X2,NONARITHMETIC SUBSCRIPT TO XXXX
22200				    ELSE
22300				        EXCH	XP1,XL1
22400					EXEC	ORSM
22500					EXCH	XP1,XL1
22600					LI	X0,QINTEGER
22700					EXEC	ORCN
22800				    FI
22900				    STEP	(XL1,ZID)
23000				AS
23100				    HRRZ	X1,YOPSTP
23200				    CAIG	XL1,(X1)
23300				    GOTO	TRUE
23400				SA
23500			ELSE
23600			    LF	X2,ZIDZQU(XP2)
23700			    LF	X2,ZQULID(X2)
23800			    ERROR1	9, X2, INCORRECT NUMBER OF SUBSCRIPTS TO (%ID);
23900				FI
24000			ELSE
24100			    IF
24200				IFEQF	(XP2,ZIDKND,QUNDEF)
24300				GOTO	FALSE
24400			    THEN
24500				LF	X2,ZIDZQU(XP2)
24600				LF	X2,ZQULID(X2)
24700			        ERROR1	21, X2, SIMPLE QUANTITY (%ID) IS USED AS ARRAY FUNCTION PROCEDURE CLASS OR SWITCH
24800			    FI
24900			FI
25000		FI
25100	
25200		;REMOVE THE ZOS NODE FROM THE OPERAND STACK
25300	
25400	L1():!	MOVNI	X3,ZNO%S		;LET YFOP POINT TO THE ZOS NODE
25500		ADDB	X3,YFOP
25600		LD	-ZNO%S(X3)
25700		STD	(X3)
25800	
25900	
26000			;BUILD UP A ZNS NODE IN XV1-XV2
26100	
26200		LD	XV1,(XP2)
26300		SETF	QZNS,ZNOTYP(,XV1)
26400		LF	X0,ZIDKND(XP2)
26500		IF		;FOR PROCEDURE AND CLASS ZNSGEN IS SET TO %PCALL
26600				; ELSE TO %RP
26700	
26800		    CAIG	X0,QARRAY
26900		    GOTO	FALSE
27000		    IFEQF	XP2,ZIDTYP,QLABEL
27100		    GOTO	FALSE
27200		THEN
27300		    SETF	%PCALL,ZNSGEN(,XV1)
27400			; ZNSSEF IS SET AND
27500			; ZNSLEV IS SET TO THE CURRENT SOURCE LEVEL
27600		    SETONA	ZNSSEF(XV2)
27700		    L		X1,YZHET
27800		    LF		X1,ZHESOL(X1)
27900		    SF		X1,ZNSLEV(,XV1)
28000			IF	SKIPN	X1,YORPAR
28100				GOTO	FALSE
28200			THEN	; STANDARD PROCEDURE WITH LONG/SHORT VERSIONS
28300				SF	X1,ZNSTYP(,XV1)
28400	 			SETZM	YORPAR
28500			FI
28600		ELSE
28700		    SETF	%RP,ZNSGEN(,XV1)
28800		    EXEC	ORBU
28900		FI
29000		SETF	QSIMPLE,ZNSKND(,XV1)
29100	
29200		SETOFA	ZNOTER(XV1)	; ZNS NODES ARE NOT TERMINAL
29300	
29400		EXEC	ORMV
29500	
29600		;ORMV WILL PLACE THE ZNS NODE IN XV1-2 AT YFOP.
29700		; CORRECT POSITION IS THE NODE IN FRONT OF YFOP.
29800	
29900		L	X3,YFOP
30000		STD	XV1,-ZNO%S(X3)
30100		L	[-ZNO%S,,-ZNO%S]
30200		ADDM	YOPSTP
30300		RETURN
30400	
30500		EPROC
     
00100		SUBTTL	ORRPIV	[133]
00200	
00300	COMMENT;
00400	
00500	PURPOSE:	This routine is called from ORRP when it processes a formal
00600			or virtual procedure. It checks if there are any system
00700			procedures as actual parameters. If there are, those procedures
00800			which have no parameters are preceded by a %PCALL node.
00900			[174] It also checks if there are any conditional text constants
01000			in the parameters.
01100	
01200	ENTRY:		ORRPIV
01300	
01400	NORMAL EXIT:	RETURN
01500	
01600	ERROR EXIT:	BRANCH O2AB (Too complicated expression)
01700	
01800	INPUT:		Actual parameters in operand stack starting at YFOP and
01900			ending at YOPSTP.
02000	
02100	;
02200	
02300	ORRPIV:	PROC
02400		SAVE	XP2
02500		L	XP1,YFOP	;ADDRESS OF FIRST OPERAND
02600		L	XP2,YNOPD	;NUMBER OF PARAMETERS
02700	
02800		LOOP
02900			L	X2,XP1
03000			IF
03100				WHENNOT	X2,ZNS
03200				GOTO	FALSE
03300			THEN
03400				LF	X2,ZNSZNO(X2)
03500				STEP	X2,ZNO
03600			FI
03700			IF
03800				WHEN	XP1,ZCN
03900				GOTO	FALSE
04000				IFOFF	ZIDSYS(XP1)
04100				GOTO	FALSE
04200				IFNEQF	XP1,ZIDKND,QPROCEDURE
04300				GOTO	FALSE
04400				LF	X2,ZIDZQU(X2)
04500				LF	X2,ZQUZB(X2)
04600				IFNEQF	X2,ZHBNRP,0
04700				GOTO	FALSE
04800			THEN	;APPEND A %PCALL NODE
04900				L	X2,YEXPP
05000				SUBI	X2,2
05100				IF
05200					HRRZ	YOPSTP
05300					CAIGE	(X2)
05400					GOTO	FALSE
05500				THEN
05600					ERROR2	35,TOO COMPLICATED EXPRESSION
05700					GOTO	O2AB
05800				FI
05900				ST	X2,YEXPP
06000				LD	XV1,(XP1)
06100				SETONA	ZNOLST(XV1)
06200				STD	XV1,(X2)	;MOVE NODE TO TREE
06300	
06400				SETOFA	ZNOLST(XV1)
06500				SETOFA	ZNOTER(XV1)
06600				SETF	QZNS,ZNOTYP(,XV1)
06700				SETF	QSIMPLE,ZNSKND(,XV1)
06800				SF	X2,ZNSZNO(,XV1)
06900				SETONA	ZNSSEF(XV2)
07000				L	X1,YZHET
07100				LF	X1,ZHESOL(X1)
07200				SF	X1,ZNSLEV(,XV1)
07300				SETF	%PCALL,ZNSGEN(,XV1)
07400				STD	XV1,(XP1)
07500			FI
07600			IF	;[174]
07700				LF	X0,ZNSTYP(XP1)
07800				CAIE	X0,QTEXT
07900				GOTO	FALSE
08000				WHEN	XP1,ZCN
08100				GOTO	FALSE
08200				L	X0,XP1
08300				EXEC	ORTXCH
08400				GOTO	FALSE
08500			THEN	;ILLEGAL
08600				ERROR2	62,ILLEGAL USE OF TEXT STRING
08700			FI
08800			STEP	XP1,ZNO
08900		AS
09000			SOJG	XP2,TRUE
09100		SA
09200		RETURN
09300		EPROC
     
00100		SUBTTL	ORTXCH	[174]
00200	
00300	COMMENT;
00400	
00500	PURPOSE:	This routine checks if a text expression contains
00600			any text value constants.
00700	
00800	CALL:		EXEC	ORTXCH
00900			<normal return>
01000			<error return>
01100	
01200			Error return means that a text value constant has been found.
01300	
01400	INPUT:		R0 points to a node in the expression tree.
01500	
01600	;
01700	
01800	ORTXCH:	PROC
01900		BEGIN
02000		STACK	XCUR	;SAVE REGISTER
02100		STACK	[0]
02200		STACK	X0
02300	L1():
02400		UNSTK	XCUR
02500		IF
02600			JUMPN	XCUR,FALSE
02700		THEN	;NO CONSTANT DETECTED
02800			UNSTK	XCUR	;RESTORE REGISTER
02900			RETURN
03000		FI
03100	
03200		WHEN	XCUR,ZLI
03300		GOTO	L1
03400		WHEN	XCUR,ZID
03500		GOTO	L1
03600	
03700		IF
03800			WHEN	XCUR,ZCN
03900			GOTO	FALSE
04000		THEN	;EXPRESSION
04100			LF	X0,ZNSGEN(XCUR)
04200			CAIE	X0,%IFEX1
04300			GOTO	L1
04400			LF	XCUR,ZNSZNO(XCUR)
04500			STEP	XCUR,ZNO
04600			LF	XCUR,ZNSZNO(XCUR)
04700			STACK	XCUR
04800			STEP	XCUR,ZNO
04900			STACK	XCUR
05000			GOTO	L1
05100		FI
05200	
05300	; XCUR POINTS TO CONSTANT, CHECK FOR NOTEXT
05400	
05500		LF	X0,ZCNVAL(XCUR)
05600		JUMPE	X0,L1		;NOTEXT IF 0
05700	
05800	
05900	; E R R O R
06000	
06100		LOOP	;EMPTY STACK
06200			UNSTK XCUR
06300		AS
06400			JUMPN	XCUR,TRUE
06500		SA
06600	
06700		UNSTK	XCUR	;RESTORE REGISTER
06800		AOS	(XPDP)	;PERFORM SKIP RETURN
06900		RETURN
07000		ENDD
07100		EPROC
     
00100		SUBTTL	ORSM
00200		COMMENT;
00300	
00400		PURPOSE:	CHECK THAT AN EXPRESSION NODE IN THE OPERAND STACK
00500				IS SIMPLE
00600	
00700		ENTRY:		ORSM
00800	
00900		INPUT ARGUMENTS:	THE NODE ADDRESS IS PASSED IN XP1
01000	
01100		NORMAL EXIT:		RETURN
01200	
01300		ERROR EXIT:		RETURN
01400	
01500		CALL FORMAT:		EXEC ORSM
01600	
01700	
01800		;
     
00100	ORSM:	PROC
00200	
00300		;EXIT AT ONCE IF THE NODE IS A ZCN RECORD OR ITS KIND IS
00400		; QSIMPLE OR QUNDEF
00500	
00600	
00700		LF	X1,ZIDKND(XP1)
00800		CAIN	X1,QSIMPLE
00900		RETURN
01000	
01100	
01200		STACK XP1		;XP1 WILL BE CHANGED IF DOT NOTATION
01300	
01400		;IF IT IS A ZNS NODE (I.E. DOT NOTATION) FIND ITS SECOND OPERAND
01500	
01600		IF
01700			RECTYPE(XP1)	IS ZNS
01800			GOTO	FALSE
01900		THEN
02000			ASSERT<	IFNEQF	(XP1,ZNSGEN,%DOT)
02100				RFAIL	(ZNS BUT NOT %DOT IN ORSM)>
02200			LF	XP1,ZNSZNO(XP1)
02300			STEP	XP1,ZNO
02400		FI
02500		WHEN	XP1,ZLI
02600		EXEC	ORLU
02700		ASSERT<	WHENNOT XP1,ZID
02800			RFAIL	(NO ZID FOUND IN ORSM)>
02900	
03000		;IF THE KIND IS QPROCEDURE AND ITS ZQUIB = 1 AND T IS THE FIRST OPERAND AND
03100		; XCUR = %BECOM OR %DENOTE THEN ZIDMOD := QDECLARED,
03200		; ZIDKND := QSIMPLE AND ZIDZHE := ZIDZQU.ZQUZB
03300	
03400	IF
03500		CAIE	X1,QPROCEDURE
03600		GOTO	FALSE
03700		LF	,ZNSTYP(XP1)
03800		CAIN	,QLABEL
03900		GOTO	FALSE	;SWITCH ILLEGAL HERE
04000	THEN
04100		LF	X1,ZIDZQU(XP1)
04200	
04300		IF
04400			IFOFF	ZQUIB(X1)
04500			GOTO	FALSE
04600	
04700			HRRZ	YFOP
04800			CAIE	(XP1)
04900			GOTO	FALSE
05000	
05100			CAIN	XCUR,%BECOM
05200			GOTO	TRUE
05300			CAIE	XCUR,%DENOT
05400			GOTO	FALSE
05500		THEN
05600	
05700			SETF	QDECLARED,ZIDMOD(XP1)
05800			SETF	QSIMPLE,ZIDKND(XP1)
05900			ZF	ZIDZHE(XP1)
06000			UNSTK	XP1
06100			RETURN
06200		FI
06300	
06400		;IF THE PROCEDURE HAS ZERO PARAMETERS OR IS NOT DECLARED, THEN THE
06500		; NODE IS COPIED INTO THE TREE AND A ZNS RECORD WITH ZNSGEN = %PCALL,
06600		; ZNSSEF SET, ZNSLEV =CURRENT SOURCE LEVEL
06700		; AND ZNSKND = QSIMPLE IS INSERTED
06800	
06900		LF	X1,ZQUZB(X1)	; GET ZHB OF PROCEDURE WITH PARAM COUNT
07000		IF
07100			IFEQF	(X1,ZHBNRP,0)
07200			GOTO	TRUE
07300			IFEQF	(XP1,ZIDMOD,QDECLARED)
07400			GOTO	FALSE
07500		THEN
07600			UNSTK	XP1
07700			LD	XV1,(XP1)
07800			SETF	%PCALL,ZNSGEN(,XV1)
07900			SETF	QZNS,ZNOTYP(,XV1)
08000			SETF	QSIMPLE,ZNSKND(,XV1)
08100			SETONA	ZNSSEF(XV2)
08200			L	X1,YZHET
08300			LF	X1,ZHESOL(X1)
08400			SF	X1,ZNSLEV(,XV1)
08500			HRROI	X1,-ZID%S
08600			ADDB	X1,YEXPP
08700			SF	X1,ZNSZNO(,XV1)
08800			EXCH	XV1,(XP1)
08900			EXCH	XV2,1(XP1)
09000			HRLZI	X0,3B<%ZNOLST+^D18>
09100			TDO	XV1,X0		;SETON ZNOLST AND ZNOTER
09200			STD	XV1,(X1)
09300			RETURN
09400	
09500		FI
09600	
09700	
09800	FI
09900		;ERROR
10000		; ACCEPT KIND UNDEFINED
10100		; REPLACE THE OPERAND BY THAT OF AN UNDECLARED IDENTIFIER
10200		; AND GIVE AN ERROR MESSAGE
10300	
10400		LF	X1,ZIDKND(XP1)
10500		IF
10600			CAIE	X1,QUNDEF
10700			GOTO	FALSE
10800		THEN
10900			UNSTK	XP1
11000			RETURN		;KIND UNDEFINED
11100		FI
11200	
11300		LF	X2,ZIDZQU(XP1)
11400		LF	X2,ZQULID(X2)
11500		SETF	QUNDEF,ZIDTYP(XP1)
11600		SETF	QUNDEF,ZIDKND(XP1)
11700		LI	X0,YUNDEC
11800		SF	X0,ZIDZQU(XP1)
11900	
12000		IF
12100			;LINE SYMBOL IN XCUR
12200	
12300			TRNN	XCUR,400K
12400			GOTO	FALSE
12500		THEN
12600			;PROCEDURE CALL WITHOUT PARAMETERS
12700	
12800			ERROR1	17,X2,PARAMETERS OMITTED TO (%ID)
12900			UNSTK	XP1	;RESTORE XP1
13000		ELSE
13100		UNSTK	XP1	;RESTORE XP1
13200	
13300		IF	CAIE	XCUR,%RP
13400			GOTO	FALSE
13500		THEN	; ARRAY SUBSCRIPT
13600			ERROR1	17,X2,param or subscr to xxx omitted
13700			RETURN
13800		FI
13900		IF
14000			L	YFOP
14100			CAIN	(XP1)
14200			GOTO	FALSE
14300		THEN
14400			IF	SUBI	,(XP1)
14500				ADDI	2
14600				JUMPE	,FALSE
14700			THEN
14800				ERROR2	28,NOT SIMPLE OPERAND AFTER UNTIL
14900			ELSE
15000				ERROR1	2, XCUR, INVALID 2ND OPERAND KIND OF OPERATOR (%OPT)
15100			FI
15200		ELSE
15300			ERROR1	29, XCUR, INVALID 1ST OPERAND KIND OF OPERATOR (%OPT)
15400		FI
15500		FI
15600	
15700		RETURN
15800	
15900		EPROC
     
00100		SUBTTL	ORTY
00200	
00300		COMMENT;
00400	
00500		PURPOSE:	TO DETERMINE THE TYPE FIELD OF A RESULT OPERATOR NODE IN
00600				XV1-XV2 FROM THE TYPES OF THE OPERANDS ACCORDING TO
00700				RULES DETERMINED BY AN INDEX PASSED IN XP1
00800	
00900		ENTRY:		ORTY
01000	
01100		INPUT ARGUMENTS:  THE INDEX PASSED IN XP1 HAS THE FOLLOWING MEANING
01200	
01300			XP1			MEANING
01400			----------------------------------------------------------------
01500			QRSAME	TAKE THE TYPE OF THE FIRST OPERAND AND IF IT IS REF AND
01600				THE LAST OPERAND IS OF KIND CLASS, THEN THE QUAL. IS SET
01700				TO THIS CLASS ELSE TO THE QUAL. OF THE FIRST OPERAND
01800	
01900			QRLAST	TAKE TYPE AND QUAL. OF THE LAST OPERAND
02000				 (I.E. SECOND OPERAND)
02100	
02200			QRBOOL	RESULT TYPE IS SET TO BOOLEAN
02300	
02400			QRCLAS	RESULT TYPE IS REF. COPY QUAL. FROM FIRST OPERAND IF ITS
02500				TYPE IS REF, AND TAKE THE CLASS NAME IF ITS KIND IS
02600				CLASS
02700	
02800		NORMAL EXIT:	RETURN
02900	
03000		CALL FORMAT:	EXEC ORTY
03100	
03200		;
     
00100	ORTY:	L	X1,YSTEPP
00200	
00300		ASSERT<	CAILE	XP1,QRSAME
00400			RFAIL	WRONG XP1 IN ORTY
00500			>
00600		XCT	[RETURN
00700			GOTO	ORTYCL
00800			GOTO	ORTYBO
00900			GOTO	ORTYLA
01000			GOTO	ORTYSA](XP1)	;LITERAL INDEXED BY XP1
01100	
01200	
01300	ORTYSA:	LF	X2,ZIDTYP(X1)		;TAKE TYPE OF FIRST OPERAND
01400		LF	X3,ZIDZDE(X1)		;SAVE QUAL. OF FIRST OPERAND
01500		IF				;TYPE REF?
01600			CAIE	X2,QREF
01700			GOTO	FALSE
01800		THEN				;FIND LAST OPERAND
01900			HRR	X1,YOPSTP
02000			SOJ	X1,
02100			IF			;KIND CLASS?
02200				IFNEQF	X1,ZIDKND,QCLASS
02300				GOTO	FALSE
02400			THEN			;SET QUAL.TO THIS CLASS
02500				LF	X3,ZIDZQU(X1)
02600			FI
02700		FI
02800		GOTO	ORTYEX
02900	
03000	
03100	ORTYLA:	LF	X2,ZIDTYP(X1,ZNO%S)	;TAKE TYPE OF SECOND OPERAND
03200		LF	X3,ZIDZDE(X1,ZNO%S)	; AND ITS QUALIFICATION
03300		GOTO	ORTYEX
03400	
03500	
03600	ORTYBO:	LI	X2,QBOOLEAN		;SET TYPE TO BOOLEAN
03700		GOTO	ORTYRE
03800	
03900	
04000	ORTYCL:	LI	X2,QREF			;SET TYPE TO REF
04100		IFEQF	X1,ZIDTYP,QUNDEF	;[134]
04200		LI	X2,QUNDEF
04300		IF
04400			RECTYPE(X1) IS ZNS
04500			GOTO	FALSE
04600		THEN
04700			;DOT NOTATION
04800	
04900			LF	X1,ZNSZNO(X1)
05000		FI
05100		IF				;FIRST OPERAND KIND QCLASS?
05200			IFNEQF	X1,ZIDKND,QCLASS
05300			GOTO	FALSE
05400		THEN				;SET QUAL. TO THIS CLASS
05500			LF	X3,ZIDZQU(X1)
05600		ELSE
05700			LF	X3,ZIDZDE(X1)	;COPY QUAL. FROM FIRST OPERAND
05800		FI
05900	ORTYEX:	SF	X3,ZNSZQU(,XV1)
06000	
06100	ORTYRE:	SF	X2,ZNSTYP(,XV1)
06200		RETURN
     
00100	
00200	
00300	
00400	
00500		LIT
00600		RELOC
00700		VAR
00800		END