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