seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-22 07:54:25 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity
Files
31738079c43b1cd3eae2815a0dfb36f71505257a
Digital-Research-Source-Code/ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/fold.for
Sepp J Morris 31738079c4 Upload 
Digital Research
2020-11-06 18:50:37 +01:00

579 lines
16 KiB
Fortran
Raw Blame History

C***********************************************************************
C
C FOLD.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C
C-----------------------------------------------------------------------
C
C This module of the PL/M-VAX compiler examines a code tree and
C folds operator nodes having all constant operands. Some binary
C operator nodes having one constant operand are also simplified.
C Constant displacements within atom base and subscript subtrees
C are extracted and incorporated into the atom's displacement
C field.
C
C-----------------------------------------------------------------------
C R E V I S I O N H I S T O R Y
C
C 15OCT81 Alex Hunter 1. Added disclaimer notice. (V5.4)
C 09NOV81 Alex Hunter 1. Implement CTE assumption. (V5.9)
C
C-----------------------------------------------------------------------
C!!!!! COMPILE ME WITH /NOCHECK PLEASE!!!!!!!!!
C
INTEGER*2 FUNCTION FOLD_CONSTANTS(NODX)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 I,I1,I2
REAL*8 R,R1,R2
INTEGER*4 MASK(S_BYTE:S_QUAD)
DATA MASK/'FF'X,'FFFF'X,'FFFFFFFF'X,'FFFFFFFF'X,
# 'FFFFFFFF'X,'FFFFFFFF'X,'FFFFFFFF'X,'FFFFFFFF'X/
NOD=NODX
1 IF (NOD.EQ.NULL) GO TO 9000
IF (LITERAL(NOD)) GO TO 9000
IF (CONSTANT(NOD)) GO TO 9000
IF (REGISTER(NOD)) GO TO 9000
IF (ATOM(NOD)) THEN
CALL PUSH(NOD,1)
BASE=FOLD_CONSTANTS2(ATOM_BASE(NOD))
CALL POP(NOD,1)
ATOM_BASE(NOD)=BASE
CALL PUSH(NOD,1)
CALL PUSH(BASE,1)
SUB=FOLD_CONSTANTS2(ATOM_SUB(NOD))
CALL POP(BASE,1)
CALL POP(NOD,1)
ATOM_SUB(NOD)=SUB
IF (NODE(BASE).AND.OPNODE_OP(BASE).EQ.OP_L2P) THEN
ATOM_FLAGS(NOD)=ATOM_FLAGS(NOD).OR.A_L2P
ATOM_BASE(NOD)=OPNODE_OPND1(BASE)
ENDIF
ELEMENT_SIZE=BYTE_SIZE(NODE_TYPE(NOD))
NOD1=ATOM_SUB(NOD)
IF (NODE(NOD1).AND.OPNODE_OP(NOD1).GT.100)
# NOD1=OPNODE_OPND1(NOD1)
IF (NODE(NOD1).AND.OPNODE_OP(NOD1).EQ.OP_MUL.AND.
# FIXLIT(OPNODE_OPND2(NOD1))) THEN
FACTOR=FIXED_VAL(OPNODE_OPND2(NOD1))
OPNODE_OPND1(NOD1)=EXTRACT_DISPLACEMENT(OPNODE_OPND1(NOD1)
# ,DISP)
ATOM_DISP(NOD)=ATOM_DISP(NOD)+DISP*FACTOR*ELEMENT_SIZE
ELSE
ATOM_SUB(NOD)=EXTRACT_DISPLACEMENT(ATOM_SUB(NOD),DISP)
ATOM_DISP(NOD)=ATOM_DISP(NOD)+DISP*ELEMENT_SIZE
ENDIF
! Check for special case of symbol(const).member(const) where
! size(symbol_element).ne.0 modulo size(member_element).
IF (ATOM_SYM(NOD).EQ.0 .AND. ATOM_MEM(NOD).EQ.0 .AND.
# ATOM_SUB(NOD).EQ.NULL .AND. NODE(ATOM_BASE(NOD)) .AND.
# OPNODE_OP(ATOM_BASE(NOD)).EQ.OP_LOC .AND.
# ATOM(OPNODE_OPND1(ATOM_BASE(NOD))) .AND.
# ATOM_SUB(OPNODE_OPND1(ATOM_BASE(NOD))).EQ.NULL ) THEN
NOD1=OPNODE_OPND1(ATOM_BASE(NOD))
NODE_TYPE(NOD1)=NODE_TYPE(NOD)
ATOM_DISP(NOD1)=ATOM_DISP(NOD1)+ATOM_DISP(NOD)
FOLD_CONSTANTS=NOD1
RETURN
ENDIF
GO TO 9000
ENDIF
C-------------- NODE MUST BE AN OPNODE.
IF (OPNODE_OP(NOD).EQ.OP_NOP .OR.
# (OPNODE_OP(NOD).EQ.OP_L2P .OR.
# OPNODE_OP(NOD).EQ.OP_P2L)) THEN
NOD=OPNODE_OPND1(NOD)
GO TO 1
ENDIF
IF (.NOT.ASSUME_CTE) RETURN
CALL PUSH(NOD,1)
OPND1=FOLD_CONSTANTS2(OPNODE_OPND1(NOD))
CALL POP(NOD,1)
OPNODE_OPND1(NOD)=OPND1
CALL PUSH(NOD,1)
CALL PUSH(OPND1,1)
OPND2=FOLD_CONSTANTS2(OPNODE_OPND2(NOD))
CALL POP(OPND1,1)
CALL POP(NOD,1)
OPNODE_OPND2(NOD)=OPND2
OP=OPNODE_OP(NOD)
IF (OP.EQ.OP_CALL.OR.OP.EQ.OP_ARG.OR.OP.EQ.OP_THEN.OR.
# OP.EQ.OP_ALSO) GO TO 9000
CC IF (OP.EQ.OP_P2L) THEN
CC IF (NODE(OPND1).AND.OPNODE_OP(OPND1).EQ.OP_LOC.AND.
CC # ATOM(OPNODE_OPND1(OPND1))) THEN
CC ATOM_FLAGS(OPNODE_OPND1(OPND1))=
CC # ATOM_FLAGS(OPNODE_OPND1(OPND1)).OR.A_P2L
CC NODE_TYPE(OPND1)=S_LONG
CC FOLD_CONSTANTS=OPND1
CC RETURN
CC ELSE
CC GO TO 9000
CC ENDIF
CC ENDIF
IF (.NOT.LITERAL(OPND1).AND..NOT.LITERAL(OPND2)) GO TO 9000
TYPE=NODE_TYPE(NOD)
TYPE1=NODE_TYPE(OPNODE_OPND1(NOD))
TYPE2=NODE_TYPE(OPNODE_OPND2(NOD))
IF (LITERAL(OPND1)) THEN
IF (TYPE1.EQ.S_REAL.OR.TYPE1.EQ.S_DOUBLE) THEN
R1=FLOAT_VAL(OPND1)
ELSE
I1=FIXED_VAL(OPND1).AND.MASK(TYPE1)
ENDIF
ENDIF
IF (LITERAL(OPND2)) THEN
IF (TYPE2.EQ.S_REAL.OR.TYPE2.EQ.S_DOUBLE) THEN
R2=FLOAT_VAL(OPND2)
ELSE
I2=FIXED_VAL(OPND2).AND.MASK(TYPE1)
ENDIF
ENDIF
IF (LITERAL(OPND1).AND.(LITERAL(OPND2).OR.OPND2.EQ.NULL)) THEN
IF (TYPE1.NE.S_REAL.AND.TYPE1.NE.S_DOUBLE) THEN
GO TO (10,20,30,40,50,60,70,80,90,100,110,120,130,140,
# 150,160,170,180,190,200), OP
ELSE
GO TO (15,25,35,45,55,65,75,85,95,105,115,125,135,145,
# 155,165,175,185,195,205), OP
ENDIF
GO TO (1010,1020,1030,1040,1050,1060,1070,1080,1090,1100,
# 1110,1120,1130,1140,1150,1160,1170,1180,1190,1200,
# 1210,1220,1230,1240,1250,1260,1270), OP-100
CALL BUG('FC-1')
ENDIF
C---------- BINARY OPERATION WITH EXACTLY ONE LITERAL OPERAND.
IF (LITERAL(OPND1)) THEN
LITOPND=OPND1
OPND=OPND2
I=I1
R=R1
ELSE
LITOPND=OPND2
OPND=OPND1
I=I2
R=R2
ENDIF
IF (TYPE1.NE.S_REAL.AND.TYPE1.NE.S_DOUBLE) THEN
GO TO (13,23,33,43,53,63,73,83,93,103,113), OP
IF (OP.EQ.20) GO TO 203
ELSE
GO TO (18,28,38,48,58,68,78,88,98,108,118), OP
IF (OP.EQ.20) GO TO 208
ENDIF
GO TO 9000
C--------- SIMPLIFY BINARY OPERATIONS WITH ONE CONSTANT OPERAND.
13 IF (I.EQ.0) GO TO 9100 ! ADD
IF (FIXLIT(OPND1)) THEN
FOLD_CONSTANTS=FOLD_LOC_REF(NOD,OPND2,I)
ELSE
FOLD_CONSTANTS=FOLD_LOC_REF(NOD,OPND1,I)
ENDIF
RETURN
18 IF (R.EQ.0.0) GO TO 9100
GO TO 9000
23 IF (FIXLIT(OPND1).AND.I1.EQ.0) GO TO 9300 ! SUB
IF (FIXLIT(OPND2).AND.I2.EQ.0) GO TO 9100
IF (FIXLIT(OPND2)) THEN
FOLD_CONSTANTS=FOLD_LOC_REF(NOD,OPND1,-I)
RETURN
ENDIF
GO TO 9000
28 IF (FLOATLIT(OPND1).AND.R1.EQ.0.0) GO TO 9300
IF (FLOATLIT(OPND2).AND.R2.EQ.0.0) GO TO 9100
GO TO 9000
33 IF (I.EQ.0) GO TO 9200 ! MUL
IF (I.EQ.1) GO TO 9100
IF (I.EQ.-1) GO TO 9300
GO TO 9000
38 IF (R.EQ.0.0) GO TO 9200
IF (R.EQ.1.0) GO TO 9100
IF (R.EQ.-1.0) GO TO 9300
GO TO 9000
43 IF (FIXLIT(OPND1).AND.I.EQ.0) GO TO 9200 ! DIV
IF (FIXLIT(OPND2)) THEN
IF (I.EQ.0) GO TO 9900
IF (I.EQ.1) GO TO 9100
IF (I.EQ.-1) GO TO 9300
ENDIF
GO TO 9000
48 IF (FLOATLIT(OPND1).AND.R.EQ.0.0) GO TO 9200
IF (FLOATLIT(OPND2)) THEN
IF (R.EQ.0.0) GO TO 9900
IF (R.EQ.1.0) GO TO 9100
IF (R.EQ.-1.0) GO TO 9300
ENDIF
GO TO 9000
53 GO TO 9000 ! ADWC
58 GO TO 9000
63 GO TO 9000 ! SUBWC
68 GO TO 9000
73 CONTINUE ! NEG
78 CONTINUE
83 CONTINUE ! NOT
88 CONTINUE
CALL BUG ('FC-88')
93 IF (FIXLIT(OPND1).AND.I1.EQ.0) GO TO 9200 ! EXT
IF (FIXLIT(OPND1).AND.I1.EQ.MASK(TYPE1)) THEN
IF (OPNODE_OP(OPND2).EQ.OP_NOT) THEN
FOLD_CONSTANTS=OPNODE_OPND1(OPND2)
RETURN
ELSE
GO TO 9400
ENDIF
ENDIF
IF (FIXLIT(OPND2).AND.I2.EQ.0) GO TO 9100
IF (FIXLIT(OPND2).AND.I2.EQ.MASK(TYPE1)) THEN
I=0
GO TO 8000
ENDIF
GO TO 9000
98 GO TO 8900
103 IF (I.EQ.0) GO TO 9100 ! OR
IF (I.EQ.MASK(TYPE1)) GO TO 9200
GO TO 9000
108 GO TO 8900
113 IF (I.EQ.0) GO TO 9100 ! XOR
IF (I.EQ.MASK(TYPE1)) GO TO 9400
GO TO 9000
118 GO TO 8900
203 IF (FIXLIT(OPND1).AND.I.EQ.0) GO TO 9200 ! MOD
IF (FIXLIT(OPND2)) THEN
IF (I.EQ.0) GO TO 9900
IF (I.EQ.1.OR.I.EQ.-1) THEN
FOLD_CONSTANTS=MAKE_FIXED(0,TYPE)
RETURN
ENDIF
ENDIF
GO TO 9000
208 GO TO 8900
C------------- REDUCE OPERATIONS WITH CONSTANT OPERANDS.
10 I=I1+I2 ! ADD
GO TO 8000
15 R=R1+R2
GO TO 8005
20 I=I1-I2 ! SUB
GO TO 8000
25 R=R1-R2
GO TO 8005
30 I=I1*I2 ! MUL
GO TO 8000
35 R=R1*R2
GO TO 8005
40 IF (I2.EQ.0) GO TO 9900 ! DIV
I=I1/I2
GO TO 8000
45 IF (R2.EQ.0.0) GO TO 9900
R=R1/R2
GO TO 8005
50 GO TO 9000 ! ADWC
55 GO TO 8900
60 GO TO 9000 ! SBWC
65 GO TO 8900
70 I=-I1 ! NEG
GO TO 8000
75 R=-R1
GO TO 8005
80 I=.NOT.I1 ! NOT
GO TO 8000
85 GO TO 8900
90 I=I1.AND..NOT.I2 ! EXT
GO TO 8000
95 GO TO 8900
100 I=I1.OR.I2 ! OR
GO TO 8000
105 GO TO 8900
110 I=I1.XOR.I2 ! XOR
GO TO 8000
115 GO TO 8900
120 I=I1.LT.I2 ! LT
GO TO 8000
125 I=R1.LT.R2
GO TO 8000
130 I=I1.GT.I2 ! GT
GO TO 8000
135 I=R1.GT.R2
GO TO 8000
140 I=I1.EQ.I2 ! EQ
GO TO 8000
145 I=R1.EQ.R2
GO TO 8000
150 I=I1.NE.I2 ! NE
GO TO 8000
155 I=R1.NE.R2
GO TO 8000
160 I=I1.LE.I2 ! LE
GO TO 8000
165 I=R1.LE.R2
GO TO 8000
170 I=I1.GE.I2 ! GE
GO TO 8000
175 R=R1.GE.R2
GO TO 8000
180 CALL BUG('FC-180') ! LOC
185 CALL BUG('FC-185')
190 CALL BUG('FC-190') ! ASSN
195 CALL BUG('FC-195')
200 IF (I2.EQ.0) GO TO 9900 ! MOD
I=MOD(I1,I2)
GO TO 8000
205 GO TO 8900
C----------- CONVERT TYPE OF LITERAL OPERAND.
1010 CONTINUE ! B2W
1020 CONTINUE ! B2I
1030 CONTINUE ! B2L
1050 CONTINUE ! W2B
1060 CONTINUE ! W2L
1070 CONTINUE ! I2B
1090 CONTINUE ! I2L
1120 CONTINUE ! L2W
1140 CONTINUE ! L2B
1180 CONTINUE ! L2Q
1240 CONTINUE ! Q2L
I=I1
GO TO 8000
1040 CONTINUE ! B2R
1080 CONTINUE ! I2R
1130 CONTINUE ! L2R
1170 CONTINUE ! L2D
1250 CONTINUE ! I2D
R=I1
GO TO 8005
1100 CONTINUE ! R2L
1110 CONTINUE ! R2I
1150 CONTINUE ! R2B
1160 CONTINUE ! R2W
1200 CONTINUE ! D2B
1210 CONTINUE ! D2I
1230 CONTINUE ! D2L
I=R1
GO TO 8000
1190 CONTINUE ! R2D
1220 CONTINUE ! D2R
R=R1
GO TO 8005
1260 CONTINUE ! L2P
1270 CONTINUE ! P2L
GO TO 9000
C---------------------------------------------------
8000 FOLD_CONSTANTS=MAKE_FIXED(I.AND.MASK(TYPE),TYPE)
RETURN
8005 FOLD_CONSTANTS=MAKE_FLOAT(R,TYPE)
RETURN
8900 CALL ERROR('FC - ILLEGAL MIXING OF TYPES')
9000 FOLD_CONSTANTS=NOD
RETURN
9100 FOLD_CONSTANTS=OPND
RETURN
9200 FOLD_CONSTANTS=LITOPND
RETURN
9300 FOLD_CONSTANTS=MAKE_NODE(OP_NEG,OPND,NULL,TYPE,0,0)
RETURN
9400 FOLD_CONSTANTS=MAKE_NODE(OP_NOT,OPND,NULL,TYPE,0,0)
RETURN
9900 CALL WARN('FC - ATTEMPTED DIVISION BY ZERO')
GO TO 9000
END
C----------------------------------------------------
INTEGER*2 FUNCTION FOLD_CONSTANTS2(NODX)
IMPLICIT INTEGER*2 (A-Z)
FOLD_CONSTANTS2=FOLD_CONSTANTS(NODX)
RETURN
END
C----------------------------------------------------
INTEGER*2 FUNCTION EXTRACT_DISPLACEMENT(NOD,DISP)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*2 COMBOP(S_BYTE:S_QUAD,S_BYTE:S_QUAD)
DATA COMBOP/
# 0, 0, 0, 0, 0, 0, 0, 0,
# OP_B2W, 0, 0, 0, 0, 0, 0, 0,
# OP_B2I, 0, 0, 0, 0, 0, 0, 0,
# 0, 0, 0, 0, 0, 0, 0, 0,
# 0, 0, 0, 0, 0, 0, 0, 0,
# OP_B2L,OP_W2L,OP_I2L, 0, 0, 0, 0, 0,
# 0, 0, 0, 0, 0, 0, 0, 0,
# 0, 0, 0, 0, 0, 0, 0, 0/
NOD1=NOD
IF (FIXLIT(NOD1)) THEN
DISP=FIXED_VAL(NOD1)
EXTRACT_DISPLACEMENT=NULL
RETURN
ENDIF
IF (.NOT.NODE(NOD1)) GO TO 900
IF (OPNODE_OP(NOD1).GT.100) NOD1=OPNODE_OPND1(NOD1)
IF (OPNODE_OP(NOD1).EQ.OP_ADD) THEN
IF (FIXLIT(OPNODE_OPND2(NOD1))) THEN
DISP=FIXED_VAL(OPNODE_OPND2(NOD1))
NOD2=OPNODE_OPND1(NOD1)
ELSEIF (FIXLIT(OPNODE_OPND1(NOD1))) THEN
DISP=FIXED_VAL(OPNODE_OPND1(NOD1))
NOD2=OPNODE_OPND2(NOD1)
ELSE
GO TO 900
ENDIF
ELSEIF (OPNODE_OP(NOD1).EQ.OP_SUB) THEN
IF (FIXLIT(OPNODE_OPND2(NOD1))) THEN
DISP=-FIXED_VAL(OPNODE_OPND2(NOD1))
NOD2=OPNODE_OPND1(NOD1)
ELSE
GO TO 900
ENDIF
ELSE
GO TO 900
ENDIF
IF (OPNODE_OP(NOD).LE.100) THEN
EXTRACT_DISPLACEMENT=NOD2
RETURN
ENDIF
IF (.NOT.NODE(NOD2) .OR. OPNODE_OP(NOD2).LE.100 .OR.
# NODE_TYPE(OPNODE_OPND1(NOD2)).GT.NODE_TYPE(NOD2)) THEN
C------- (Note that downward/upward coercions are not transitive!) ---
OPNODE_OPND1(NOD)=NOD2
EXTRACT_DISPLACEMENT=NOD
RETURN
ENDIF
NOD2=OPNODE_OPND1(NOD2)
NEWOP=COMBOP(NODE_TYPE(NOD2),NODE_TYPE(NOD))
IF (NEWOP.EQ.0) CALL BUG('ED-0')
EXTRACT_DISPLACEMENT=MAKE_NODE(NEWOP,NOD2,NULL,NODE_TYPE(NOD),
# 0,0)
RETURN
900 DISP=0
EXTRACT_DISPLACEMENT=NOD
RETURN
END
C----------------------------------------------------
INTEGER*2 FUNCTION FOLD_LOC_REF(NOD,OPND,I)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 I
IF (NODE(OPND).AND.OPNODE_OP(OPND).EQ.OP_LOC) THEN
ATM=OPNODE_OPND1(OPND)
IF (.NOT.ATOM(ATM)) GO TO 900
ATOM_DISP(ATM)=ATOM_DISP(ATM)+I
FOLD_LOC_REF=OPND
RETURN
ENDIF
900 FOLD_LOC_REF=NOD
RETURN
END
Reference in New Issue View Git Blame Copy Permalink