Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

	SALL
COMMENT;
AUTHOR:			STEFAN ARNBORG 15-MAY-1973
			UPDATED AT ACADIA UNIVERSITY FOR KA10

VERSION:		4	[3,30,40,134,174,216]

PURPOSE:		TO REPLACE OPERANDS IN THE OPERAND STACK
			BY THE RESULT OPERATOR AFTER CHECKING ITS OPERANDS
			THE OPERANDS ARE MOVED TO THE EXPRESSION TREE AREA

CONTENTS:		A ROUTINE OREN DOING MOST OF THE COMMON PROCESSING OF
			OPERATORS, AND INDIVIDUAL ROUTINES FOR SPECIAL OPERATORS.
			A ROUTINE FOR MOVING OPERANDS, ORMV

;
	SEARCH	SIMMAC,SIMMC2
	CTITLE	OR
; GLOBAL ROUTINES
	EXTERN	CABSTU,CGCA,CGPU,CGAD,CGCC,CGCO,CGIM,CGIM1,CGLO,CGLO1,CAUSTD
	EXTERN	CGMO,CGMO1,CGVA,O2AD,O2GI,O2GWD,O2LN1
	EXTERN	CADS,CGG2,CGG3,CGG4,CGR2,CGR3,CGR4,O2CF,O2GA,O2GF,O2GR,O2GW
	EXTERN	CACO,CADISP,CARL,CAUD,CGEN,O2DF,O2IV,O2RF
	EXTERN	CAUNPR	;[40]
	EXTERN	ORTXCH	;[174]
	EXTERN	ORDT,ORLU,ORRP,ORSM,ORCC,ORBU,ORCT,ORTY,ORCN
	INTERN	OREN,ORMV
	OPDEF	UNDISP	[PUSHJ	XPDP,CAUD]
; GLOBAL VARIABLES
	DSW	SPAREN,YORPAR,36
	EXTERN	YORLID,YCGSWC,YBKST,YBKSTP,YEXPP,YFOP,YFORSI,YPROCI,YNOPD,YNZCN,YNZID,YNZNS
	EXTERN	YOPST,YOPSTB,YOPSTP,YORACT,YORFOR,YORFX,YORZHB,YORZQU
	EXTERN	YORPAR,YRDSTP,YSTEPP,YZHBXC,YZHET
	EXTERN	YEXPL,O2AB,YUNDEC,YCALID,YDCSTP
; MACRO USED FOR CODEWORD TABLE EXPANSION
	DEFINE	OPTAB(N,V,D1,D2)=<
		IFG <SYMBL2-V>,<
	REPEAT <V-$$LC>,<Z>
			IFNDEF	$'N,<Z>
			IFDEF	$'N,<$'N>
			$$LC=V+1
		>
	>
; MACRO USED FOR SHIFTING FIELDS OF THE CODE WORDS INTO REGISTER XP1
	DEFINE	SHIFT(B)=<
		IFNDEF	$$SCT,<
			$$SCT=-1
		>
		%2=B-$$SCT
		LSHC	XP1,%2
		$$SCT=B
	>

; MACRO USED FOR CODEWORD DEFINITION
DEFINE	ORCOD(SYMBL,NOCODE,OPERANDS,SIMPLE,OPDCON,OPDCHK,RESTYP,CONAR,COMMUT,REVERS,NOMOV)=<
	$$SCT=<NOCODE>B<%NOCODE>+<OPERANDS>B<%OPERANDS>+<SIMPLE>B<%SIMPLE>
	$$SCT=$$SCT+<CONAR>B<%CONAR>+<COMMUT>B<%COMMUT>+<NOMOV>B<%NOMOV>+<REVERS>B<%REVERS>
	$$SCT=$$SCT+<OPDCON>B<%OPDCON>+<OPDCHK>B<%OPDCHK>+<RESTYP>B<%RESTYP>
	; SET DEFAULT ARGUMENTS (I.E. BLANK ARGUMENTS IN THIS CLEVER ASSEMBLER)
	IFB <OPERANDS>,<$$SCT=$$SCT+<2>B<%OPERANDS>>
	IFB <SIMPLE>,<$$SCT=$$SCT+<1>B<%SIMPLE>>
	IFB <OPDCON>,<$$SCT=$$SCT+<QCHIGH>B<%OPDCON>>
	IFB <OPDCHK>,<$$SCT=$$SCT+<QARITH>B<%OPDCHK>>
	IFB <RESTYP>,<$$SCT=$$SCT+<QRSAME>B<%RESTYP>>
	IFB <NOMOV>,<$$SCT=$$SCT+<$NOMOV>B<%NOMOV>>
	IFDEF SYMBL'.,<
		$'SYMBL=<<$$SCT>+SYMBL'.-OREN>
	>
	IFNDEF SYMBL'.,<
		$'SYMBL=$$SCT
	>
>

; POSITIONS OF LAST BITS IN CODE WORD FIELDS
%NOCODE=0
%OPERAND=%NOCODE+2
%SIMPLE=%OPERAND+1
%OPDCON=%SIMPLE+3
%OPDCHK=%OPDCON+4
%RESTYP=%OPDCHK+4
%CONAR=%RESTYP+1
%COMMUT=%CONAR+1
%REVERS=%COMMUT+1
%NOMOV=%REVERS+1
$$SCT=-1
$$LC=0
$NOMOV=0
TWOSEG
CGINIT
MACINIT
RELOC	400K

COMMENT;
PURPOSE:		DO COMMON PROCESSING OF OPERATORS EXCEPT %DOT AND %RP
ENTRY:			OREN
NORMAL EXIT:		M2EN (BY RETURN), ORDT, ORRP
ERROR EXIT:		NONE
I/O PERFORMED:		NO
USED ROUTINES:		ORDT,ORRP,ORCH,ORCS,ORLU,ORBU
ERRORS GENERATED:	YES, LOTS OF
ENTRY CONDITION:	THE CURRENT OPERATOR SYMBOL IS IN XCUR
			AND ITS OPERANDS ARE IN THE OPERAND STACK.
EXIT ASSERTION:		WHEN RETURNING TO THE MAIN SCAN ALL OPERANDS OF THE
			OPERATOR HAVE BEEN CHECKED FOR NUMBER, TYPE, KIND.
			IF THE OPERATOR MUST BE THE ROOT OF A COMPILABLE CONSTRUCTION
			THE CONSTRUCTION HAS BEEN COMPILED.
ABNORMAL EXIT:		EXIT TO O2AB AND PASS 3 IF A PROCEDURE OR CLASS ENERED CAN NOT BE
			FOUND
;
	SUBTTL	OREN
OREN:	; START PROCEDURE
	IN.=OREN	; THIS IS FOR THE CLEVER GUY WHO HAS ADDED
			; IN. AS AN OPERATOR IN MACRO 10
	ASSERT<
		SKIPGE	XCUR
		RFAIL	NEGATIVE SYMBOL VALUE IN OREN
		CAIL	XCUR,SYMBL3
		RFAIL	NOT OPERATOR SYMBOL IN OREN
	>
	SETZM	YNZCN
	SETZM	YNZID
	SETZM	YNZNS
	SETZB	XP1,YNOPD
	SETOFF	SPAREN
	IF	; CODEWORD IS NEGATIVE: NO PROCESSING HERE
		SKIPL	XP2,CODEWORD(XCUR)
		GOTO	FALSE
	THEN
		CAIN	XCUR,%RP
		BRANCH	ORRP		; RIGHT BRACKET OR PARENTHESIS
		CAIN	XCUR,%DOT
		BRANCH	ORDT		; REMOTE ACCESS
		RFAIL	INVALID SYMBOL IN OREN
	FI

; NORMAL OR PROCESSING
; SET YFOP TO FIRST OPERAND
; AND YSTEPP TO INCREMENT VARIABLE
	SHIFT	%OPERANDS	; NUMBER OF OPERANDS TO XP1 (0 MEANS ALL STACK OPNDS)
	IF	; XP1=0
		JUMPN	XP1,FALSE	
	THEN	; TAKE ALL OPERANDS
		LI	YOPST
		ST	YFOP
	ELSE
		ADD	XP1,XP1	; DOUBLE
		HRRZ	YOPSTP
		SUB	XP1
		ADDI	1
		ST	YFOP
	FI
; COMPUTE YSTEPP FOR OPERATIONS STEPPING THROUGH OPERANDS
	HRL			; FIRSTOP,,FIRSTOP
	HRLZ	XP1,YOPSTP	; LASTOP+1,,0
	SUBM	XP1		; -<NUMBEROPS*2-1>,,FIRSTOP
	ST	XP1,YSTEPP

; LOOK UP ZLI OPERANDS AND SET UP OPERAND COUNTERS
	LOOP
		AOS	YNOPD	; NUMBER OPERANDS
		LF	X1,ZNOTYP(XP1)
		; THE NEXT LITERAL IS INDEXED BY X1
		XCT	[RFAI	[ASCIZ/ZOS OPERAND IN STACK NOT SEEN BY RB/]
			GOTO	[AOS	YNZID	; ZLI OPERAND
				EXEC	ORLU
				GOTO	.+1]		; OUTSIDE LITERALS
			AOS	YNZCN
			AOS	YNZID
			AOS	YNZNS
			RFAI	[ASCIZ/ZNN NODE IN OPERAND STACK/]
			](X1)
	AS	STEPJ	XP1,ZID,TRUE
	SA

; CHECK OPERAND KINDS
	IF	; ALL OPERANDS MUST BE SIMPLE
		TLZN	XP2,400K
		GOTO	FALSE
	THEN
		L	XP1,YSTEPP
		LOOP
			EXEC	ORSM
		AS
			STEPJ	XP1,ZCN,TRUE
		SA
	ELSE
		; INDIVIDUAL CHECK FOR SYMBOLS
		; THIS, WHEDO, NEW, IS, IN
		IF	; LAST OPERAND KIND MUST BE CLASS
			; SIDE EFFECT: XP1 WILL POINT TO LAST OPERAND IF
			; CONDITION IS SATISFIED
			L	XP1,YFOP
			CAIN	XCUR,%THIS
			GOTO	TRUE
			CAIN	XCUR,%WHEDO
			GOTO	TRUE
			STEP	XP1,ZNS
			CAIN	XCUR,%QUA
			GOTO	TRUE
			CAIN	XCUR,%IS
			GOTO	TRUE
			CAIN	XCUR,%IN
			GOTO	TRUE
			CAIE	XCUR,%NEW
			GOTO	FALSE
			SUBI	XP1,ZNS%S
			WHEN	XP1,ZID
			GOTO	TRUE
			LF	XP1,ZNSZNO(XP1)	;[134]GO DOWN FROM %PCALL NODE
		THEN
			LF()	ZIDKND(XP1)	; LAST OPERAND KIND
			IF	; NOT KIND CLASS OR UNDEFINED
				CAIE	QCLASS
				CAIN	QUNDEF
				GOTO	FALSE
			THEN	ERROR1	10,XCUR,IDENTIFIER AFTER %OPT IS NOT CLASS
				;[134]SET NODE TO UNDEFINED
				CAIN	XCUR,%NEW
				L	XP1,YFOP	;IN CASE OF PARAMETERS
				SETF	QZID,ZNOTYP(XP1)
				SETF	QUNDEF,ZIDKND(XP1)
				SETF	QUNDEF,ZIDTYP(XP1)
				SETF	YUNDEC,ZIDZQU(XP1)
				SETF	YUNDEC,ZIDZDE(XP1)
			FI
			IF	; XCUR IN OR IS OR QUA
				CAMN	XP1,YFOP
				GOTO	FALSE
			THEN
				L	XP1,YFOP
				EXEC	ORSM	; FIRST OPERAND OF IS AND IN MUST BE SIMPLE
			FI
		FI
	FI

; TYPE CONVERSION AND ERROR CHECKING
	SETZ	XP1,
	SHIFT	%OPDCON	; CONVERSION CODE TO XP1
	SKIPE	XP1
	EXEC	ORCC	; CHECK AND CONVERT OPERAND TYPES
	SETZ	XP1,
	SHIFT	%OPDCHK
	SKIPE	XP1	; TYPE CHECK ONLY IF NONZERO CHECK CODE
	EXEC	ORCT
REPEAT 0,<; THIS CODE GIVES EXTRAORDINARILY SMALL RETURNS AT RUN-TIME
; CONSTANT ARITHMETIC
	IF	; CONSTANT ARITHMETIC BIT IS SET FOR OPERATOR
		TLZN	XP2,1B<%CONAR-$$SCT+^D17>
		GOTO	FALSE
		NOCONV=FALSE	; SAVE FALSE BRANCH INTO LOOP ... AS
		L	XP1,YSTEPP
		LOOP
			WHENNOT	XP1,ZCN
			GOTO	NOCONV	; NOT ALL OPERANDS CONSTANTS
		AS
			STEPJ	XP1,ZCN,TRUE
		SA
	THEN
		EXEC	ORCA
		RETURN	; RETURN IS TAKEN IF CONVERSION SUCCESSFUL
		; SKIP RETURN IF CONVERSION FAILED
	FI
>

; MAKE RESULT NODE IN XV1-XV2

	MOVE	XV2,XCUR
	MOVSI	XV1,(<<QSIMPLE>B<%ZNSKND>+<QZNS>B<%ZNOTYP>>)
	SETZ	XP1,
	SHIFT	%RESTYP	; GET PARAMETER TO ORTY
	SKIPE	XP1
	EXEC	ORTY
	EXEC	ORBU	; BACKUP SIDE-EFFECTS AND LEVELS
; CHECK FOR OPERAND SWAPPING
	L	XP1,YFOP
	IF
		TLNE	XP2,<1B<%NOMOV-$$SCT+^D17>>
		GOTO	FALSE
	THEN
		IF	TLNN	XP2,<1B<%COMMUT-$$SCT+^D17>+1B<%REVERS-$$SCT+^D17>>
			GOTO	FALSE	; OPERATOR NOT SWAPPABLE
			TRNN	XV2,1B<%ZNSROR>
			GOTO	FALSE	; SWAPPING NOT ALLOWED BECAUSE OF SIDE EFFECTS
			; SWAPPING ALLOWED WHEN ENTERING HERE
			; NOW DETERMINE IF IT IS PROFITABLE
			L	XL1,XP1
			STEP	(XL1,ZNO)	;XL1 -> SECOND OPERAND (SOP)
			WHEN	XL1,ZCN
			GOTO	FALSE		;DO NOT SWAPP IF SOP ZCN
			WHEN	XP1,ZCN
			GOTO	TRUE	; SWAP WHEN FIRST OPERAND IS CONSTANT
			WHENNOT	(XP1,ZID)	; OR IDENTIFIER
			GOTO	FALSE
		THEN	;SWAP
			IF	; NON-COMMUTING OPERATOR
				TLNE	XP2,<1B<%COMMUT-$$SCT+^D17>>
				GOTO	FALSE
			THEN	; FIND REVERSE OPERATOR
				LI	XL1,[%LESS,,%GRT
					%NGRT,,%NLESS
					%GRT,,%LESS
					%NLESS,,%NGRT
					0]
				LOOP
					L	X1,(XL1)
					ASSERT<	SKIPN	X1,(XL1)
						RFAIL	NO REVERSE OPERATOR FOUND
					>
				AS
					AOS	XL1
					CAIE	XCUR,(X1)
					GOTO	TRUE
				SA
				HLRZ	XCUR,X1		; REPLACE CURRENT OPERATOR
				SF	XCUR,ZNSGEN(,XV1)
			FI
			L	XL1,YEXPP
;***AUBEG
;	SPECIFY X0
			LD	X0,(XP1)
			SETONA	ZNOLST
			STD	X0,-ZNO%S(XL1)
			SUBI	XL1,<2*ZNO%S>
			LD	X0,ZNO%S(XP1)
			STD	X0,(XL1)
;****AUEND
			ST	XL1,YEXPP
			HRR	XV1,XL1
			STD	XV1,(XP1)
			L	[-ZID%S,,-ZID%S]
			ADDM	YOPSTP
		ELSE
			; NORMAL OPERAND MOVE FROM STACK TO TREE
			EXEC	ORMV
		FI
	FI
; CHECK IF SPECIAL PROCESSING IS NEEDED FOR THIS SYMBOL
	HRRZ	X1,CODEWORD(XCUR)
	ANDI	X1,377777
	JUMPN	X1,OREN(X1)	; BRANCH IF NON-ZERO RIGHT HALF OF CODEWORD
	RETURN
	;	END OF PROCEDURE OREN

	SUBTTL	SPECIAL OPERATOR PROCESSING
; THESE SEQUENCES ARE FOR OPERATORS REQUIRING SPECIAL PROCESSING. IF A LABEL
; 'SYMBL.' IS DEFINED HERE, THEN THE CODE WORD FOR 'SYMBL' WILL GET A NON-ZERO
; RIGHT HALFWORD AND THE LABEL WILL BE BRANCHED TO FOR SUCH SYMBOLS.
; AT THIS POINT OPERANDS HAVE BEEN MOVED TO THE TREE IF 'NOMOVE' WAS NOT SET IN
; THE CODE WORD OF THE SYMBOL

; SIMPLE ROOT SYMBOLS
ADEC.:
FORSI.:
FORST.:
GOTO.:
SWEL.:
	BRANCH	CGEN


; ACTIVATION MASK BITS:
AFTER=1B15
AT=1B14
BEFORE=1B16
DELAY=1B13
ACTIV.:	INVAL
	ST	YORACT	; READ AND SAVE BIT MASK FOR ACTIVATION
	L	XP2,
	L	XP1,YSTEPP
	EXEC	ORCPR	; CHECK FIRST OPERAND QUALIFIED PROCESS
	ERROR2	11,OPERAND OF ACTIVATE OR REACTIVATE NOT PROCESS
	IF	STEPJ	XP1,ZNS,TRUE	; MORE THAN ONE OPERAND?
		GOTO	FALSE
	THEN	; YES, MORE THAN ONE
		ASSERT<
			TRNN	XP2,(<BEFORE+AFTER+AT+DELAY>)
			RFAIL	TOO MANY OPERANDS OF ACTIVATE OR WRONG BIT MASK
		>
		IF	TRNN	XP2,(<BEFORE+AFTER>)
			GOTO	FALSE
		THEN	; BEFORE OR AFTER: CHECK SECOND OPERAND QUALIFIED LINKAGE
			LI	QREF
			SETZM	X1
			L	XL1,XP1
			EXEC	ORCN
			EXEC	ORCPR
			ERROR2	38,OPERAND AFTER BEFORE OR AFTER IS NOT QUALIFIED PROCESS
		ELSE	; AT OR DELAY, CONVERT SECOND OPERAND TO REAL
			LI	QREAL
			L	XL1,XP1
			EXEC	ORCN
		FI
	ELSE	; ONE OPERAND ONLY, ASSERT MASK IS OK
		ASSERT<
			TRNE	XP2,(<BEFORE+AFTER+AT+DELAY>)
			RFAIL	TOO FEW ARGUMENTS TO ACTIVATE OR WRONG BIT MASK
		>
	FI
	EXEC	ORMV	; MOVE OPERANDS
	BRANCH	CGEN	; AND COMPILE
	; END OF ACTIVATE PROCESSING

BEGCL.:	LF	XP2,ZIDZQU(,YOPST)
	CAIN	XP2,YUNDEC
	BRANCH	O2AB	; FAILED TO FIND CLASS AND ATTRIBUTES
	; REDEFINE LAST FIXUP DEFINED TO F+5, F+2 IS HERE
	LF	XL1,ZQUIND(XP2)	; FIXUP OF CLASS
	LI	5(XL1)
	EXEC	O2RF
	LI	X1,2(XL1)
	DEFIX
	LF	XZHE,ZQUZB(XP2)
	L	X1,YZHBXC
	; DISPLAY CLASS ATTRIBUTES IN DICTIONARY
	EXEC	CAUNPR,<[0]>	;[40]
	EXEC	CADISP
	ST	XZHE,YZHBXC
	ST	XZHE,YZHET
	LF	X1,ZHBZHB(XZHE)	; BACK UP FROM PREFIX
	IF	CAIN	X1,0
		GOTO	FALSE
	THEN	;PREFIX
		IF	IFOFF	ZHBLOC(X1)
			GOTO	FALSE
		THEN	; SET LOC
			SETON	ZHBLOC(XZHE)
		FI
		LF	,ZHBSZD(X1)
		LF	X1,ZHBSZD(XZHE)
		CAMLE	X1
		SF	,ZHBSZD(XZHE)
	FI
	; ADJUST STACKS
	EXEC	CABSTU
	EXEC	CAUSTD
	EXEC	O2LN1
	BRANCH	CGPU

BEGPB.:	;CHECK SYNTAX OF PREFIX, NOT DONE IN PASS 1
	L	X1,YFOP
	IF	WHEN	X1,ZID
		GOTO	FALSE	; ID OK
		WHENNOT	X1,ZNS
		GOTO	TRUE	; MUST HAVE %PCALL OTHERWISE
		LF	,ZNSGEN(X1)
		CAIE	%PCALL
		GOTO	TRUE
		LF	X1,ZNSZNO(X1)
		WHEN	X1,ZID
		GOTO	FALSE	; OK IF NOT REMOTE PREFIX
	THEN	;ILLEGAL BLOCK PREFIX
		SETZB	X3,YORZHB
		SETZM	YORZQU
		SEVER1	3,X3,PREFIX NOT A CLASS
	ELSE

		EXEC	NEW.	;SAME OPERAND CHECK AS FOR NEW.
		L	XP1,YEXPP
		LF	XP1,ZIDZQU(XP1)
		ST	XP1,YORZQU
		LF	,ZQULID(XP1)
		ST	YCALID
		LF	XP2,ZQUZB(XP1)
		ST	XP2,YORZHB
		SKIPN	XP2
		SEVER1	3,YCALID,PREFIX NOT A CLASS
		SKIPN	XP2
		GOTO	.+4	; FORWARDD EXIT
		IFON	ZHBLOC(XP2)
		ERROR2	45,PREFIX HAS LOCAL OBJECT
		IFON	ZQUIS(XP1)
		ERROR2	48,CONNECTED PREFIX
	FI
	EXEC	CARL
	L	X1,YZHBXC
	ST	XZHE,YZHBXC
	LF	X1,ZHEFIX(XZHE)	; GET FIXUP OF PREFIXED BLOCK
	SF	XCUR,ZNSGEN(,YOPST)
	EXEC	O2LN1
	BRANCH	CGEN

BEGPR.:	LF	XP1,ZIDZQU(,YOPST)
	CAIN	XP1,YUNDEC
	BRANCH	O2AB	; FAILED TO FIND PROCEDURE AND PARAMETERS
	SETON	ZQUIB(XP1)
	ST	XP1,YORZQU
	LF	XP2,ZQUZB(XP1)
	L	X1,YZHBXC
	ST	XP2,YZHBXC
	ST	XP2,YORZHB
	LF	XP2,ZQUIND(XP1)	; GET FIXUP OF PROCEDURE
	; REDEFINE PREVIOUS FIXUP OR JUMP TO F+3,
	; DEFINE F+2 HERE
	IFON	ZQUGLOB(XP1)
	GOTO	.+3
	LI	3(XP2)
	EXEC	O2RF
	LI	X1,2(XP2)
	EXEC	O2DF
	EXEC	CARL
	L	X1,YBKSTP
	L	YORZHB
	HRRM	(X1)
	ST	YZHET
	L	[-ZID%S,,-ZID%S]
	ADDM	YOPSTP	; CLEAR OPERAND STACK
	EXEC	CAUSTD
	EXEC	O2LN1
	RETURN

; := AND :-
; SUPPLY NEW OPERANDS UNTIL THE OPERAND STACK IS EMPTY
MOCEB.:
BECOM.:	LI	XCUR,%BECOM
	SKIPA
TONED.:
DENOT.:	LI	XCUR,%DENOT
	L	X1,YEXPP
	IF	WHEN	X1,ZID
		GOTO	FALSE	; ID ALOWED LHS
		CAIE	QZNS
		GOTO	TRUE	; ZCN NOT ALLOWED
		LF	,ZNSGEN(X1)
		CAIE	%RP
		CAIN	%DOT	; REMOTE AND INDEXED ALLOWED
		GOTO	FALSE
	THEN
		LF	,ZNSTYP(X1)
		IF
			CAIN	QTEXT
			CAIE	XCUR,%BECOME	; ALL EXPRESSIONS ALLOWED AS LHS TO TEXT :=
			GOTO	TRUE
			L	X0,X1	;[174]
			EXEC	ORTXCH	;[174]
			GOTO	FALSE
		THEN
			ERROR1	13,XCUR,INVALID LHS TO OPERATOR
		FI
	FI
	L	YFOP
	CAIG	YOPST
	BRANCH	CGEN	; COMPILE WHEN OPERAND STACK EMPTY
	BRANCH	OREN	; OTHERWISE TAKE NEW LEFT HAND SIDE

CVBE.:	ASSERT<NOP	; MEASUREMENT POINT
	>

CVDE.:	EXEC	CARL	;READ ZHE AND LABEL LIST
	UNDISPLAY	;MAKE LABELS UNAVAILABLE UNTIL FORDO
	EXEC	CAUSTD	;[30] RESERVE SPACE FOR FOR RETURN ADDRESS
	LF	,ZHEFIX(XZHE)
	ST	YORFX
	SETZM	YFORSI	;INITIALIZE SWITCH FOR SIMPLE FOR LIST ELEMENT
	L	XP1,YFOP
	IFEQF	XP1,ZIDTYP,QTEXT
	ERROR2	12,CONTROLLED VARIABLE OF TYPE TEXT NOT ALLOWED
;***AUBEG
;	SPECIFY X0
	LD	X0,(XP1)
	STD	X0,YORFOR
;***AUEND
	ASSERT<
		CAMLE	XP1,YOPSTB
		RFAIL	TOO MANY OPERANDS OF CVBE OR CVDE
	>
	IF	; KIND NOT SIMPLE
		WHEN	XP1,ZID
		GOTO	FALSE
	THEN
		ERROR1	13,XCUR,CONTROLLED VARIABLE NOT SIMPLE IDENTIFIER
	ELSE
	IF	; MODE NOT DECLARED OR UNDEFINED
		LF	,ZIDMOD(XP1)
		CAIE	QNAME
		GOTO	FALSE
	THEN
		LF	X1,ZIDZQU(XP1)
		LF	X1,ZQULID(X1)
		ERROR1	14,X1,CONTROLLED VARIABLE %ID IN FOR STATEMENT NOT DECLARED OR VALUE MODE
	FI
	FI
	RETURN

DELOP.:	SETON	SCERFL	; SET LOCAL ERROR FLAG
	RETURN

DEQ.:			;[174]
NDEQ.:			;[174]
	L	X1,YEXPP
	IF
		IFNEQF	(X1,ZNSTYP,QTEXT)
		GOTO	FALSE
		L	X0,X1
		EXEC	ORTXCH
		SKIPA
		GOTO	TRUE
		STEP	X1,ZNO
		L	X0,X1
		EXEC	ORTXCH
		GOTO	FALSE
	THEN
		ERROR2	62,ILLEGAL USE OF TEXT VALUE CONSTANT
	FI
	RETURN

FORWH.:	L	XL1,YFOP
	LF	,ZIDTYP(XL1)
	LF	X1,ZIDZDE(XL1)
	STEP	XL1,ZNS
	EXEC	ORCN
	STEP	XL1,ZNS
	LI	QBOOLE
	EXEC	ORCN	; CHECK CONDITION IN WHILE BOOLEAN
	EXEC	ORMV
	BRANCH	CGEN

IFEX.:	; ELSE OPERANDS HAVE BEEN CHECKED BUT NOT MOVED,
	; REENTER OREN TO CHECK THE CONDITION AFTER IF
	LI	XCUR,%IFEX1
	BRANCH	OREN

IFST.:	INVAL
	ST	YORFX	; SAVE FIXUP FOR CODEGEN
	BRANCH	CGEN

IFTRE.:	INVAL
	ST	YORFX
IFTRU.:	L	XL1,YFOP
	STEP	(XL1,ZNS)	; CHECK TYPE OF SECOND OPERAND
	LI	X3,%GOTO
	IFNEQF	(XL1,ZNSTYP,QLABEL)
	ERROR1	24,X3,INVALID OPERAND TYPE OF OPERATOR GOTO
	EXEC	ORMV
	BRANCH	CGEN

INSPE.:	L	X1,YEXPP
	LF	X2,ZNSZQU(X1)	; THIS GETS THE QUALIFICATION OF INSPECT
	IF	WHENNOT	X1,ZCN
		GOTO	FALSE
	THEN	ERROR2	49,CONSTANT AFTER INSPECT
		SETZ	X2,
	FI
	ST	X2,YORZQU
	SETZM	YORZHB	; TO AVOID MISTAKES
	INVAL
	ST	YORFX
	BRANCH	CGEN

NEW.:	L	X1,YFOP
	IF
		WHENNOT	X1,ZID
		GOTO	FALSE
	THEN
		;ZID: PARAMETERS HAVE NOT BEEN CHECKED
		LF	X2,ZIDZQU(X1)
		CAIN	X2,YUNDEC	;[134]
		RETURN			;[134]
		LF	X3,ZQUZB(X2)
		LOOP		;[3] CECK FOR PARAMETERS IN THE
				; PREFIX LINK TOO

			LF	,ZHBNRP(X3)
			IF
				JUMPE	FALSE
			THEN
				LF	X2,ZQULID(X2)
				ERROR1	17,X2,PARAMETERS OMITTED TO (%ID)
			FI
			LF	X3,ZHBZHB(X3)	;[3]
		AS
			JUMPE	X3,FALSE
			WHEN	X3,ZHB
			GOTO	TRUE
		SA
		HRREI	X4,-ZID%S
		ADDB	X4,YEXPP
		LD	X2,(X1)
		SETONA	ZNOLST(X2)
		STD	X2,(X4)
		SF	X4,ZNSZNO(X1)
	ELSE
		SETZM	YCALID
		IF	CAIN	XCUR,%NEW
			GOTO	FALSE
			IFOFF	ZNOTER(X1)
			GOTO	FALSE
		THEN
			SEVER1	3,YCALID,PREFIX NOT A CLASS
		FI
		LF	X4,ZNSZNO(X1)
	FI
	LF	X4,ZIDZQU(X4)
	SF	X4,ZNSZQU(X1)
	LI	X0,(<<QSIMPLE>B<%ZNSKND>+<QZNS>B<%ZNOTYP>+<QREF>B<%ZNSTYP>>)
	HRLM	X0,(X1)
	SF	XCUR,ZNSGEN(X1)
	SETON	ZNSSEF(X1)
	RETURN

PAREN.:	SETON	SPAREN
	ASSERT<
	L	X1,YFOP
	WHEN	X1,ZID
	NOP
	>
	RETURN

SWITC.:	L	XP1,YEXPP
	LF	XP1,ZIDZQU(XP1)
	ASSERT<
		IFNEQF	XP1,ZQUTYP,QLABEL
		RFAIL	SWITCH NOT OF TYPE LABEL IN OREN
		IFNEQF	XP1,ZQUMOD,QDECLARED
		CAIN	QVIRTUAL
		SKIPA
		RFAIL	SWITCH DECLARATION FOR PARAMETER SWITCH
		IFNEQF	XP1,ZQUKND,QPROCEDURE
		RFAIL	SWITCH NOT OF TYPE PROCEDURE
	>
	ST	XP1,YORZQU
	LF	XP2,ZQUIND(XP1)
	MOVSM	XP2,YCGSWC
	LI	1(XP2)
	EXEC	O2RF
	; IN ORDER TO PREVENT LOCAL DATA ACCESSES THROUGH XCB
	; WE MUST PLANT A NEW LEVEL ON THE STACKS AND LET YZHBXCB AND YZHET
	; POINT TO IT
	LF	X2,ZHEDLV(XZHE)
	L	XZHE,YDCSTP
	ST	XZHE,YZHET
	SUBI	X2,1
	SF	X2,ZHEDLV(XZHE)
	LI	ZHB%V
	SF	,ZDETYP(XZHE)
	LI	X2,ZHB%S(XZHE)
	ST	X2,YDCSTP
	EXEC	CABSTU
	L	YZHBXC
	ST	YORZHB
	ST	XZHE,YZHBXC
	EXEC	CAUSTD
	BRANCH	CGPU

THIS.:	L	XP1,YEXPP
	LF	X2,ZIDZQU(XP1)
	LF	X1,ZQUZB(X2)
	IF
		IFOFF	ZHBUPF(X1)
		GOTO	FALSE
	THEN	; ON
		LF	X1,ZQULID(X2)
		ERROR1	18,X1,THIS %ID IS NOT A VALID LOCAL OBJECT SINCE THE CLASS IS USED AS BLOCK PREFIX
	ELSE	; FIND DISPLAY LEVEL OF LOCAL OBJECT, X1 HAS ZHB POINTER
		L	XP2,YBKSTP
		LOOP
			POP	XP2,XP1
			IF	LF	,ZHETYP(XP1)
				CAIN	QCLASB
				GOTO	TRUE
				CAIE	QINSPE
				GOTO	FALSE
			THEN	; CHECK QUALIFICATION OF ENVIRONMENT
				LF	XP1,ZHBZQU(XP1)
				LF	XP1,ZQUZB(XP1)
				WHILE	CAMN	XP1,X1
					GOTO	FALSE
					JUMPE	XP1,FALSE
				DO
					LF	XP1,ZHBZHB(XP1)
				OD
			ELSE
				SETZ	XP1,
			FI

		AS	JUMPN	XP1,FALSE	; MATCHING ZHB IN XP1
			LI	YBKST
			CAIG	(XP2)
			GOTO	TRUE
			LF	XP1,ZHBZQU(X1)
			LF	XP1,ZQULID(XP1)
			SKIPE	XP1
			ERROR1	19,XP1,<INVALID LOCAL OBJECT NO ENCLOSING INSTANCE>
			RETURN
		SA
		; GET DISPLAY LEVEL OF INSTANCE AND PUT IT IN ZNSZNO OF THE RESULT NODE
		L	XP1,1(XP2)	; USED BLOCK STACK ENTRY
		SETON	ZHBLOC(XP1)	; THIS CLASS CAN NOT BE USED FOR BLOCK PREFIXING
		LF	,ZHEDLV(XP1)
		L	X1,YFOP
		SF	,ZNSZNO(X1)
		SETON	ZNOTER(X1)	; ZNS NODE WITH %THIS IS TERMINAL
	FI
	RETURN

UNMIN.:	L	XP2,YEXPP
	WHENNOT	XP2,ZCN
	RETURN
; CONSTANT ARITHMETIC
	L	XP1,YOPSTP
	ADD	XP1,[-2,,-2]
	L	XV1,(XP2)
	L	XV2,1(XP2)
	LF	,ZCNTYP(,XV1)
	IF	CAIN	QLREAL
		GOTO	FALSE
	THEN
		; NOT LONG REAL
		MOVN	XV2,XV2
	ELSE	; LONG REAL
;***AUBEG
;USE DNEG AND STD MACROS, NOT DMOVN AND DMOVEM, WHICH ARE RTS UUOS
		DNEG	X0,(XV2)
		STD	X0,(XV2)
;***AUEND
		DMOVEM	(XV2)
	FI
	PUSH	XP1,XV1
	PUSH	XP1,XV2
	RETURN

WHEDO.:	SETZM	@YDCSTP
	L	XP2,YEXPP
	LF	XP1,ZIDZQU(XP2)
	ST	XP1,YORZQU
		LF	,ZQUZB(XP1)
	ST	YORZHB
	EXEC	CARL
	UNDISPLAY	; UND. LABELS IN CLAUSE
	L	YORZHB
	SF	,ZHBZHB(XZHE)
	L	YORZQU
	SF	,ZHBZQU(XZHE)
	L	YORFX
	SF	,ZHEFIX(XZHE)
	EXEC	CACO
	EXEC	CGEN
	RETURN
WHILE.:	INVAL
	ST	YORFX
	BRANCH	CGEN

	SUBTTL	CODEWORD TABLE DEFINITION
DT:	Z
;	SYMBOL,NOCODE,OPDS,SIMPLE,OPDCON,OPDCHK,RESTYP,CONAR,COMMUT,REVERSE,NOMOV
ORCOD ADEC,,0,0,0,0,0,,,
ORCOD ACTIV,,0,,0,0,0,,,,1
ORCOD AND,,,,QCSAME,QBOOLE,,,1,
ORCOD BECOM,,,,QCLEFT,QNREF,,,,
ORCOD BEGCL,,0,0,0,0,0,,,,1
ORCOD BEGPB,,0,0,0,0,0,,,,1	
ORCOD BEGPR,,0,0,0,0,0,,,,1
ORCOD BOUND,,,,QCINT,0,0,,,
ORCOD CVBE,,0,,0,QNREF,,,,,1
ORCOD CVDE,,0,,0,QTXREF,,,,,1
ORCOD DELOP,,,0,0,0,QUNDEF,,,
ORCOD DENOT,,,,QCLEFT,QTXREF,,,,
ORCOD DEQ,,,,QCSAME,QTXREF,QRBOOL,,1,
ORCOD DIV,,,,QCREAL,,,1,,
ORCOD DOT,1,,0,0,QREF,,,,
ORCOD EQ,,,,,QNRFBO,QRBOOL,,1,
ORCOD EQV,,,,QCSAME,QBOOLE,,,1,
ORCOD FORSI,,0,,QCLEFT,0,0,,,,
ORCOD FORST,,0,,QCLEFT,,0,,,,
ORCOD FORWH,,0,,0,0,0,,,,1
ORCOD GOTO,,0,,0,QLABEL,0,,,,
ORCOD GRT,,,,,QNRFBO,QRBOOL,,,1
ORCOD IDIV,,,,QCINT,,,,,
ORCOD IFEX,,2,,,0,,,,
ORCOD IFEX1,,2,,0,QBOOLE,QRLAST,,,,
ORCOD IFST,,1,,0,QBOOLE,0,,,
ORCOD IFTRE,,,,0,QBOOLE,0,,,,1
ORCOD IFTRU,,,,0,QBOOLE,0,,,,1
ORCOD IMP,,,,QCSAME,QBOOLE,QRBOOL,,,
ORCOD IN,,,0,0,QREF,QRBOOL,,,
ORCOD INSPE,,1,,0,QREF,0,,,
ORCOD IS,,,0,0,QREF,QRBOOL,,,
ORCOD LESS,,,,,QNRFBO,QRBOOL,,,1
ORCOD MINUS,,,,,,,1,,
ORCOD MULT,,,,,,,1,1,
ORCOD NDEQ,,,,QCSAME,QTXREF,QRBOOL,,1,
ORCOD NEQ,,,,,QNRFBO,QRBOOL,,1,
ORCOD NEW,,1,0,0,0,QRCLAS,,,,1
ORCOD NGRT,,,,,QNRFBO,QRBOOL,,,1
ORCOD NLESS,,,,,QNRFBO,QRBOOL,,,1
ORCOD NOT,,1,,0,QBOOLE,QRBOOL,,,
ORCOD OR,,,,QCSAME,QBOOLE,QRBOOL,,1,
ORCOD PAREN,,1,0,0,0,0,,,,1
ORCOD PLUS,,,,,,,1,1,
ORCOD POW,,,,QCREAL,,,,,
ORCOD QUA,,,0,0,QREF,,,,
ORCOD RP,1,,0,0,0,,,,
ORCOD SWEL,,1,,0,QLABEL,0,,,
ORCOD SWITC,,1,0,0,0,0,,,
ORCOD THIS,,1,0,0,0,QRCLAS,,,
ORCOD UNMIN,,1,,0,,,1,,
ORCOD UPLUS,,1,,0,,,,,,1
ORCOD WHEDO,,1,0,0,0,0,,,
ORCOD WHILE,,1,,0,QBOOLE,0,,,

CODEWORDS:
	SYMB	6,1,OPTAB

	SUBTTL	ORMV
;PURPOSE:	MOVE OPERANDS OF CURRENT OPERATOR FROM THE
;		OPERAND STACK TO THE EXPRESSION TREE AND UPDATE POINTERS.
;		STORE OPERATOR NODE FROM XV1,XV2 INTO OPERAND STACK.
;ENTRY:		ORMV
;NORMAL EXIT:	RETURN
;ERROR EXIT:	NONE
;I/O PERFORMED:	NONE
;ERRORS GENERATED:	NO
;USED ROUTINES:	NONE
ORMV:	PROC
	SAVE<X2,X3>	;?
	HRRZ	X3,YOPSTP
	L	X2,YEXPP
	SUBI	X2,2
	IF	CAIL	X2,2(X3)
		GOTO	FALSE
	THEN	; OVERFLOW OPERAND STACK
		ERROR2	35,COMPLICATED EXPRESSION
		GOTO	O2AB	; RECOVERY IS NOT SAFE
		L	X2,YEXPL
		SUBI	X2,2
	FI
	SOJ	X3,
	SETON	ZNOLST(X3)
	LOOP	; MOVE ONE ZNO AT A TIME
;***AUBEG
;	SPECIFY X0
		LD	X0,(X3)
		STD	X0,(X2)
;***AUEND
	AS
		CAMG	X3,YFOP	; EQUALITY WHEN LAST OPD HAS BEEN MOVED
		GOTO	FALSE
		SUBI	X3,2
		SUBI	X2,2
		SETOFF	ZNOLST(X3)
		GOTO	TRUE	; MOVE NEXT OPD
	SA
	SF	X2,ZNSZNO(,XV1)
	STD	XV1,(X3)
	ST	X2,YEXPP
	L	X3
	SUB	YEXPL
	MOVS		; GET OFLOW COUNTER IN LH
	HRRI	1(X3)
	ST	YOPSTP
	RETURN
	EPROC

	COMMENT;
PURPOSE:	DETERMINE IF A QUANTITY (OCCURRING IN AN ACTIVATE
		STATEMENT) IS QUALIFIED PROCESS.

ENTRY:		ORCPR

INPUT:	ZNO RECORD POINTER IN XP1

USED ROUTINE:	ORCN
;
ORCPR:	PROC
	SAVE	<X2,X3>
	N==2
	LF	X1,ZNSTYP(XP1)	;[216]
	CAIE	X1,QREF		;[216]
	GOTO	L9		;[216]
	LF	X2,ZNSZQU(XP1)	; OPERAND QUALIFICATION
	JUMPE	X2,L8		;[216] Accept NONE
	L	X1,YPROCI
	CAMN	X1,X2
	GOTO	L8
	LF	X1,ZQUZB(X1)
	LF	X3,ZQUZB(X2)
	IF	IFOFF	ZQUSYS(X2)
		GOTO	FALSE
	THEN	;SYSTEM CLASS, MUST BE LINK OR LINKAGE
		LOOP	ASSERT<WHENNOT	X1,ZHB
				RFAIL	ZHBZHBLINK ERROR
			>
			IF	CAME	X1,X3
				GOTO	FALSE
			THEN
				LI	QREF
				L	X1,YPROCI
				EXCH	XL1,XP1
				EXEC	ORCN
				EXCH	XL1,XP1
				GOTO	L8
			FI
		AS	LF	X1,ZHBZHB(X1)
			JUMPN	X1,TRUE
		SA
	ELSE	; NOT SYSTEM CLASS, FOLLOW ITS PREFIXES
		LOOP	ASSERT<WHENNOT	X3,ZHB
				RFAIL	ZHBZHBLINK ERROR
			>
			CAMN	X3,X1
			GOTO	L8
		AS	LF	X3,ZHBZHB(X3)
			JUMPN	X3,TRUE
		SA
	FI
; NO MATCH, INCOMPATIBLE QUALIFICATION
	GOTO	L9
L8():!	AOS	-N(XPDP)
L9():!	RETURN
	EPROC

	LIT
	RELOC
	VAR
END