Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/comp/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