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

688 lines
22 KiB
Fortran
Raw Permalink Blame History

C***********************************************************************
C
C DECLS.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 processes declarations at
C the beginning of a procedure or block.
C
C-----------------------------------------------------------------------
C
C R E V I S I O N H I S T O R Y
C
C 13SEP81 Alex Hunter 1. Implement ALIGN control. (V5.2)
C 29SEP81 Alex Hunter 1. Change call to INITIALIZATION. (V5.3)
C 2. Reduce macro body size by 1.
C 3. Allow dimensions >64K.
C 4. Allow structure member arrays to have
C explicit lower bounds.
C 21OCT81 Alex Hunter 1. Set S_OVERLAID attribute properly. (V5.5)
C 28OCT81 Alex Hunter 1. Allow keywords to be re-declared. (V5.7)
C 12NOV81 Alex Hunter 1. Implement psect numbers. (V6.1)
C 2. Allow PUBLIC AT(.MEMORY).
C 3. Allow AT(arg) and AT(dynamic).
C 4. Allow structure array to be implicitly
C dimensioned.
C 14NOV81 Alex Hunter 1. Add this_psect arg to INITIALIZATION.
C (V6.2)
C 14JAN82 Alex Hunter 1. Fix minor bug from V5.7. (V6.5)
C
C***********************************************************************
C --- Compile me with /NOCHECK please!!
SUBROUTINE DECLARATIONS
INCLUDE 'PLMCOM.FOR/NOLIST'
10 IF (TT.EQ.K_DECLARE) THEN
CALL DECLARE_STATEMENT
ELSEIF (TT.EQ.K_PROCEDURE) THEN
CALL PROCEDURE_DEFINITION
ELSEIF (TT.EQ.K_COMMON) THEN
CALL COMMON_STATEMENT
ELSE
RETURN
ENDIF
GO TO 10
END
C----------------------------------------------------
SUBROUTINE DECLARE_STATEMENT
INCLUDE 'PLMCOM.FOR/NOLIST'
CALL MATCH(K_DECLARE)
10 CALL DECLARE_ELEMENT(P_DATA)
IF (TT.EQ.D_COMMA) THEN
CALL GETTOK
GO TO 10
ENDIF
CALL MATCH(D_SEMI)
RETURN
END
C----------------------------------------------------
SUBROUTINE COMMON_STATEMENT
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*32 COMMON_NAME
CALL MATCH(K_COMMON)
COMMON_NAME='.BLANK.'
IF (TT.EQ.D_SLASH) THEN
CALL GETTOK
IF (TT.NE.D_SLASH) THEN
CALL MUSTBE(ID)
COMMON_NAME=IDENTIFIER
CALL GETTOK
ENDIF
CALL MATCH(D_SLASH)
ENDIF
COMMON_PSECT=SETUP_COMMON_PSECT(COMMON_NAME)
10 CALL DECLARE_ELEMENT(COMMON_PSECT)
IF (TT.EQ.D_COMMA) THEN
CALL GETTOK
GO TO 10
ENDIF
CALL MATCH(D_SEMI)
RETURN
END
C----------------------------------------------------
SUBROUTINE DECLARE_ELEMENT(DEFAULT_PSECT)
INCLUDE 'PLMCOM.FOR/NOLIST'
LOGICAL*4 FACTORED_LIST
INTEGER*2 KIND,TYPE,
# LINK,LIST_SIZE,REF,BASE,BASE_MEMBER,FLAGS
INTEGER*2 INDEX(32),REFX(32),BASEX(32),BASE_MEMBERX(32)
COMMON/DECLS/KIND,TYPE,NBR_ELEMENTS,ELEMENT_SIZE,
# LINK,LIST_SIZE,REF,BASE,BASE_MEMBER,FLAGS
LOGICAL*2 NO_MORE_DATA,STRINGLEFT
INTEGER*4 BLOCK_SIZE,NBR_ELEMENTS,LOWER_BOUND,IFSD,ELEMENT_SIZE
COMMON /INITDATA/ NO_MORE_DATA,STRINGLEFT,BLOCK_SIZE
COMMON /AT_FLAG/ AT,ATM
CHARACTER*10 STRING10
CHARACTER*80 OPERAND,OPERAND1
CHARACTER*32 PUBLIQUE
CHARACTER*4 ALIGNMENT(1:8)
DATA ALIGNMENT
# /'BYTE','WORD','----','LONG','----','----','----','LONG'/
C
FLAGS=0
N=0
REF=0
THIS_PSECT=DEFAULT_PSECT
IF (TT.EQ.D_LP) THEN
CALL GETTOK
FACTORED_LIST=.TRUE.
ELSE
FACTORED_LIST=.FALSE.
ENDIF
10 CONTINUE
IF (TT.LT.101.OR.TT.GT.199) CALL MUSTBE(ID)
IF (N.GE.32) THEN
CALL ERROR('TOO MANY ELEMENTS IN FACTORED LIST')
ELSE
CALL ENTER_SYMBOL
IF (SYMBOL_REF(SYMBOL_INDEX).EQ.S_ARG)
# SYMBOL_FLAGS(SYMBOL_INDEX)=0
N=N+1
INDEX(N)=SYMBOL_INDEX
ENDIF
CALL GETTOK
IF (TT.EQ.K_BASED) THEN
CALL GETTOK
CALL SIMPLE_VARIABLE(BTYPE)
REFX(N)=S_BASED
BASEX(N)=SYMBOL_INDEX
BASE_MEMBERX(N)=MEMBER_INDEX
IF (MEMBER_INDEX.EQ.0) THEN
IF (BTYPE.NE.S_WORD.AND.BTYPE.NE.S_PTR.AND.
# BTYPE.NE.S_LONG) THEN
CALL ERROR('BASE SPECIFIER NOT LONG/ADDRESS/POINTER: '
# //SYMBOL_PLM_ID(SYMBOL_INDEX))
ENDIF
ELSE
IF (BTYPE.NE.S_WORD.AND.BTYPE.NE.S_PTR.AND.
# BTYPE.NE.S_LONG) THEN
CALL ERROR('BASE SPECIFIER NOT LONG/ADDRESS/POINTER: '
# //SYMBOL_PLM_ID(SYMBOL_INDEX)//'.'//
# MEMBER_PLM_ID(MEMBER_INDEX))
ENDIF
ENDIF
ELSE
REFX(N)=S_STATIC
BASEX(N)=0
BASE_MEMBERX(N)=0
ENDIF
IF (FACTORED_LIST) THEN
IF (TT.EQ.D_COMMA) THEN
CALL GETTOK
GO TO 10
ENDIF
CALL MATCH(D_RP)
ENDIF
LINK=0
NO_MORE_DATA=.TRUE.
IF (TT.EQ.K_LITERALLY) THEN
CALL GETTOK
CALL MUSTBE(STRCON)
CCCC STRLEN=STRLEN+1 ! Is this necessary?
S_TOP=STRINGS_TOP(BLOCK_LEVEL)
IF (S_TOP+STRLEN.GT.STRINGS_MAX)
# CALL FATAL('STRING SPACE EXHAUSTED')
STRINGS(S_TOP+1:S_TOP+STRLEN)=STRING
STRINGS_TOP(BLOCK_LEVEL)=S_TOP+STRLEN
KIND=S_MACRO
TYPE=0
NBR_ELEMENTS=0
ELEMENT_SIZE=STRLEN
LINK=S_TOP+1
LIST_SIZE=0
DO J=1,N
IF (BASEX(J).NE.0) THEN
CALL ERROR('LITERAL CANNOT BE BASED: '//
# SYMBOL_PLM_ID(INDEX(J)))
ENDIF
REFX(J)=0
BASEX(J)=0
BASE_MEMBERX(J)=0
ENDDO
CC--- CALL GETTOK -- DONE LATER, CAUSE NEXT TOKEN MIGHT BE THIS
CC MACR0!!
ELSEIF (TT.EQ.K_LABEL) THEN
CALL GETTOK
REF=S_FORWARD
IF (TT.EQ.K_PUBLIC) THEN
FLAGS=FLAGS.OR.S_PUBLIC
CALL GETTOK
ELSEIF (TT.EQ.K_EXTERNAL) THEN
REF=S_EXT
CALL GETTOK
ENDIF
IF (REF.NE.S_EXT) THEN
FLAGS=FLAGS.OR.S_UNDEF
ENDIF
KIND=S_LABEL
TYPE=0
NBR_ELEMENTS=0
ELEMENT_SIZE=0
LINK=0
LIST_SIZE=0
DO J=1,N
IF (BASEX(J).NE.0) THEN
CALL ERROR('LABEL CANNOT BE BASED: '//
# SYMBOL_PLM_ID(INDEX(J)))
ENDIF
REFX(J)=S_STATIC
BASEX(J)=0
BASE_MEMBERX(J)=0
ENDDO
ELSE
IF (TT.EQ.D_LP) THEN
KIND=S_ARRAY
CALL DIMENSION(NBR_ELEMENTS,LOWER_BOUND)
ELSE
NBR_ELEMENTS=1
LOWER_BOUND=0
KIND=S_SCALAR
ENDIF
CALL VARIABLE_TYPE
CALL VARIABLE_ATTRIBUTES(FLAGS,REF,THIS_PSECT)
CALL INITIALIZATION(REF,THIS_PSECT)
IF (NBR_ELEMENTS.EQ.-1.AND.N.NE.1) THEN
CALL ERROR('INVALID USE OF IMPLICIT DIMENSION')
NBR_ELEMENTS=0
ENDIF
ENDIF
C
C---- ASSIGN ATTRIBUTES TO THE SYMBOLS.
C
DO 700 J=1,N
I=INDEX(J)
IF (REF.EQ.S_EXT) THEN
SYMBOL_VAX_ID(I)=PUBLIQUE(SYMBOL_PLM_ID(I))
IF (SAME_OVERLAY) FLAGS=FLAGS.OR.S_SAME_OVERLAY
ENDIF
SYMBOL_KIND(I)=KIND
SYMBOL_TYPE(I)=TYPE
SYMBOL_ELEMENT_SIZE(I)=ELEMENT_SIZE
SYMBOL_LINK(I)=LINK
SYMBOL_LIST_SIZE(I)=LIST_SIZE
SYMBOL_PSECT(I)=THIS_PSECT
IF ((REF.EQ.S_EXT.OR.(FLAGS.AND.S_PUBLIC).NE.0) .AND.
# REFX(J).NE.S_STATIC) THEN
CALL ERROR('EXTERNAL/PUBLIC VARIABLE MUST BE STATIC: '//
# SYMBOL_PLM_ID(I))
ENDIF
IF (AT.NE.0.AND.REFX(J).EQ.S_BASED) THEN
CALL ERROR('BASED VARIABLE CANNOT HAVE AT-ATTRIBUTE: '//
# SYMBOL_PLM_ID(I))
ENDIF
IF (REF.EQ.0) THEN
REF1=REFX(J)
ELSE
REF1=REF
ENDIF
IF (REF1.EQ.S_ARG) THEN
IF (NBR_ELEMENTS*ELEMENT_SIZE.GT.4) THEN
CALL WARN('DUBIOUS ARGUMENT OVERLAY: '//
# SYMBOL_PLM_ID(I))
ENDIF
ELSEIF (SYMBOL_REF(I).EQ.S_ARG) THEN
IF (KIND.NE.S_SCALAR.OR.TYPE.EQ.S_STRUC.OR.
# BYTE_SIZE(TYPE).GT.4.OR.REF1.NE.S_STATIC.OR.
# THIS_PSECT.NE.P_DATA) THEN
CALL ERROR('ILLEGAL DECLARATION FOR FORMAL PARAMETER: '//
# SYMBOL_PLM_ID(I))
ENDIF
REF1=S_ARG
SYMBOL_LINK(I)=PROC_LEVEL
ELSE
IF ((PROC_FLAGS(PROC_LEVEL).AND.
# (PROC_EXT.OR.PROC_FORWARD)).NE.0) THEN
CALL ERROR('LOCAL DECLARATION NOT ALLOWED IN EXTERNAL'//
# '/FORWARD PROCEDURE: '//SYMBOL_PLM_ID(I))
ENDIF
IF ((PROC_FLAGS(PROC_LEVEL).AND.PROC_REENT).NE.0.AND.
# REF1.EQ.S_STATIC.AND.THIS_PSECT.EQ.P_DATA) THEN
REF1=S_DYNAMIC
ENDIF
ENDIF
SYMBOL_REF(I)=REF1
SYMBOL_BASE(I)=BASEX(J)
SYMBOL_BASE_MEMBER(I)=BASE_MEMBERX(J)
SYMBOL_FLAGS(I)=FLAGS
700 CONTINUE
C
C---- SET PSECT AND PERFORM ALIGNMENT IF REQUIRED.
C
CALL PSECT(THIS_PSECT)
IF (AT.NE.0.AND.SYMBOL_REF(ATOM_SYM(ATM)).EQ.S_STATIC) THEN
OPERAND1=OPERAND(ATM,N1)
CALL EMIT1('PC.SAVE = .')
CALL EMIT1('. = '//OPERAND1(2:N1))
ENDIF
IF (ALIGN_FLAG .AND. AT.EQ.0 .AND.
# BYTE_SIZE(TYPE).GT.1 .AND. TYPE.NE.S_STRUC) THEN
DO J=1,N
IF (SYMBOL_REF(INDEX(J)).EQ.S_STATIC.AND.
# THIS_PSECT.EQ.P_DATA) THEN
CALL EMIT('.ALIGN '//ALIGNMENT(BYTE_SIZE(TYPE)))
GO TO 801
ENDIF
ENDDO
801 CONTINUE
ENDIF
C
C---- DEFINE SYMBOLS WITH POSSIBLE INITIAL VALUES.
C
OFFSET=0
DO 910 J=1,N
I=INDEX(J)
REF1=SYMBOL_REF(I)
IF (.NOT.NO_MORE_DATA.AND.REF1.NE.S_STATIC) THEN
CALL ERROR('ATTEMPT TO INITIALIZE NON-STATIC VARIABLE: '
# //SYMBOL_PLM_ID(I))
ENDIF
IF (REF1.EQ.S_STATIC) THEN
CALL EMIT_RELDEF4(I,'.',-LOWER_BOUND*ELEMENT_SIZE)
BLOCK_SIZE=0
IF (NBR_ELEMENTS.EQ.-1) THEN ! IMPLICIT DIMENSION.
NBR_ELEMENTS=0
IF (NO_MORE_DATA) THEN
CALL ERROR(
# 'IMPLICIT DIMENSION WITHOUT INITIALIZATION LIST')
ELSEIF (TYPE.EQ.S_STRUC) THEN
901 DO M=LINK,LINK+LIST_SIZE-1
DO M1=1,MEMBER_NBR_ELEMENTS(M)
CALL INITIAL_DATA(MEMBER_TYPE(M))
ENDDO
ENDDO
NBR_ELEMENTS=NBR_ELEMENTS+1
IF (.NOT.NO_MORE_DATA) GO TO 901
ELSE
902 CALL INITIAL_DATA(TYPE)
NBR_ELEMENTS=NBR_ELEMENTS+1
IF (.NOT.NO_MORE_DATA) GO TO 902
ENDIF
ELSEIF (NO_MORE_DATA) THEN ! NO INITIALIZATION.
BLOCK_SIZE=NBR_ELEMENTS*ELEMENT_SIZE
ELSE ! PROCESS INITIAL/DATA.
DO K=1,NBR_ELEMENTS
IF (TYPE.EQ.S_STRUC) THEN
DO M=LINK,LINK+LIST_SIZE-1
DO M1=1,MEMBER_NBR_ELEMENTS(M)
CALL INITIAL_DATA(MEMBER_TYPE(M))
ENDDO
ENDDO
ELSE
CALL INITIAL_DATA(TYPE)
ENDIF
ENDDO
CALL FLUSH_ASCII
ENDIF
IF (BLOCK_SIZE.NE.0) THEN
OPERAND1=STRING10(BLOCK_SIZE,IFSD)
CALL EMIT('.BLKB '//OPERAND1(IFSD:10))
ENDIF
ELSEIF (REF1.EQ.S_BASED) THEN
CALL EMIT_ABSDEF4(SYMBOL_VAX_ID(I),
# -LOWER_BOUND*ELEMENT_SIZE)
ELSEIF (AT.NE.0) THEN
SYMBOL_VAX_ID(I)=SYMBOL_VAX_ID(ATOM_SYM(ATM))
SYMBOL_FLAGS(I)=SYMBOL_FLAGS(ATOM_SYM(ATM)).OR.S_NOTPUBLIC
SYMBOL_DISP(I)=SYMBOL_DISP(I)+SYMBOL_DISP(ATOM_SYM(ATM))+
# ATOM_DISP(ATM)+OFFSET
IF (ATOM_MEM(ATM).NE.0) THEN
SYMBOL_DISP(I)=SYMBOL_DISP(I)+
# MEMBER_OFFSET(ATOM_MEM(ATM))
ENDIF
IF (REF1.EQ.S_ARG) THEN
SYMBOL_LINK(I)=SYMBOL_LINK(ATOM_SYM(ATM))
ENDIF
OFFSET=OFFSET+NBR_ELEMENTS*ELEMENT_SIZE
ELSEIF (REF1.EQ.S_DYNAMIC) THEN
CALL EMIT_ABSDEF4(SYMBOL_VAX_ID(I),
# PROC_DYN_OFF(PROC_LEVEL)-LOWER_BOUND*ELEMENT_SIZE)
PROC_DYN_OFF(PROC_LEVEL)=PROC_DYN_OFF(PROC_LEVEL)+
# NBR_ELEMENTS*ELEMENT_SIZE
ENDIF
SYMBOL_NBR_ELEMENTS(I)=NBR_ELEMENTS
SYMBOL_LOWER_BOUND(I)=LOWER_BOUND
910 CONTINUE
CALL POST_INITIALIZATION
IF (AT.NE.0.AND.SYMBOL_REF(ATOM_SYM(ATM)).EQ.S_STATIC) THEN
CALL EMIT1('. = PC.SAVE')
ENDIF
IF (KIND.EQ.S_MACRO) CALL GETTOK ! WE PROMISED WE WOULD!
RETURN
END
C----------------------------------------------------
SUBROUTINE SIMPLE_VARIABLE(TYPE)
INCLUDE 'PLMCOM.FOR/NOLIST'
C
CALL MUSTBE(ID)
CALL LOOKUP_SYMBOL
IF (SYMBOL_KIND(SYMBOL_INDEX).NE.S_SCALAR.OR.
# SYMBOL_REF(SYMBOL_INDEX).EQ.S_BASED) THEN
CALL ERROR('NOT A SIMPLE VARIABLE: '//
# SYMBOL_PLM_ID(SYMBOL_INDEX))
ENDIF
CALL GETTOK
IF (TT.EQ.D_DOT) THEN
CALL GETTOK
CALL MUSTBE(ID)
CALL LOOKUP_MEMBER
IF (MEMBER_KIND(MEMBER_INDEX).NE.S_SCALAR) THEN
CALL ERROR('NOT A SIMPLE VARIABLE: '//
# SYMBOL_PLM_ID(SYMBOL_INDEX)//'.'//
# MEMBER_PLM_ID(MEMBER_INDEX))
ENDIF
CALL GETTOK
ELSE
MEMBER_INDEX=0
IF (SYMBOL_TYPE(SYMBOL_INDEX).EQ.S_STRUC) THEN
CALL ERROR('NOT A FULLY QUALIFIED REFERENCE: '//
# SYMBOL_PLM_ID(SYMBOL_INDEX))
ENDIF
ENDIF
IF (MEMBER_INDEX.EQ.0) THEN
TYPE = SYMBOL_TYPE(SYMBOL_INDEX)
ELSE
TYPE = MEMBER_TYPE(MEMBER_INDEX)
ENDIF
RETURN
END
C----------------------------------------------------
SUBROUTINE VARIABLE_ATTRIBUTES(FLAGS,REF,THIS_PSECT)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 OFF
COMMON /AT_FLAG/ AT,ATM
AT=0 ! ASSUME NO AT-ATTRIBUTE.
IF (TT.EQ.K_EXTERNAL) THEN
REF = S_EXT
CALL GETTOK
ELSE
IF (TT.EQ.K_PUBLIC) THEN
FLAGS = FLAGS.OR.S_PUBLIC
CALL GETTOK
ENDIF
IF (TT.EQ.K_AT) THEN
CALL GETTOK
CALL MATCH(D_LP)
FLAGS = FLAGS .OR. S_OVERLAID
CALL BREAK
AT=MASSAGE(EXPRESSION(0),CX_UNSIGNED)
IF (NODE(AT).AND.OPNODE_OP(AT).EQ.OP_LOC) THEN
ATM=OPNODE_OPND1(AT)
IF (.NOT.ATOM(ATM).OR.ATOM_BASE(ATM).NE.NULL.OR.
# ATOM_SUB(ATM).NE.NULL) THEN
CALL ERROR('NOT A RESTRICTED LOCATION REFERENCE')
AT=0
ENDIF
SYMBOL_FLAGS(ATOM_SYM(ATM))=SYMBOL_FLAGS(ATOM_SYM(ATM))
# .OR. S_OVERLAID
ATOM_FLAGS(ATM)=ATOM_FLAGS(ATM).AND..NOT.(A_P2L+A_L2P)
# .OR. A_CTIM ! USE COMPILE-TIME ADDR.
# .OR. A_IMMEDIATE
IF (SYMBOL_REF(ATOM_SYM(ATM)).EQ.S_EXT) THEN
IF ((FLAGS.AND.S_PUBLIC).NE.0) THEN
CALL ERROR('PUBLIC ATTRIBUTE CONFLICTS WITH '//
# 'AT-EXTERNAL')
ENDIF
ELSEIF (SYMBOL_REF(ATOM_SYM(ATM)).NE.S_STATIC.AND.
# SYMBOL_REF(ATOM_SYM(ATM)).NE.S_ARG.AND.
# SYMBOL_REF(ATOM_SYM(ATM)).NE.S_DYNAMIC) THEN
CALL ERROR('NOT A RESTRICTED LOCATION REFERENCE')
AT=0
ENDIF
ELSE
CALL ERROR('AT MUST BE LOCATION REFERENCE')
AT=0
ENDIF
CALL MATCH(D_RP)
ENDIF
ENDIF
IF (AT.NE.0) THEN
REF=SYMBOL_REF(ATOM_SYM(ATM))
THIS_PSECT=SYMBOL_PSECT(ATOM_SYM(ATM))
ENDIF
RETURN
END
C----------------------------------------------------
SUBROUTINE DIMENSION(NBR_ELEMENTS,LOWER_BOUND)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 NBR_ELEMENTS,LOWER_BOUND
CALL MATCH(D_LP)
LOWER_BOUND=0
IF (TT.EQ.D_STAR) THEN
NBR_ELEMENTS=-1
CALL GETTOK
ELSE
CALL BREAK
N1=EXPRESSION(0)
CALL RESOLVE_CONTEXT(N1)
IF (NODE_CONTEXT(N1).EQ.0) CALL SET_CONTEXT(N1,CX_SIGNED)
CALL COERCE_TYPES(N1)
N1=FORCE_TYPE(N1,S_LONG)
N1=FOLD_CONSTANTS(N1)
IF (FIXLIT(N1)) THEN
NBR_ELEMENTS=FIXED_VAL(N1)
ELSE
CALL ERROR('ARRAY DIMENSION NOT A CONSTANT')
NBR_ELEMENTS=0
ENDIF
IF (TT.EQ.D_COLON) THEN
CALL GETTOK
LOWER_BOUND=NBR_ELEMENTS
N2=EXPRESSION(0)
CALL RESOLVE_CONTEXT(N2)
IF (NODE_CONTEXT(N2).EQ.0) CALL SET_CONTEXT(N2,CX_SIGNED)
CALL COERCE_TYPES(N2)
N2=FORCE_TYPE(N2,S_LONG)
N2=FOLD_CONSTANTS(N2)
IF (FIXLIT(N2)) THEN
NBR_ELEMENTS=FIXED_VAL(N2)-LOWER_BOUND+1
ELSE
CALL ERROR('UPPER BOUND NOT A CONSTANT')
NBR_ELEMENTS=0
ENDIF
ENDIF
IF (NBR_ELEMENTS.LT.0) THEN
CALL ERROR('ARRAY SIZE IS NEGATIVE')
NBR_ELEMENTS=0
ENDIF
ENDIF
CALL MATCH(D_RP)
RETURN
END
C----------------------------------------------------
SUBROUTINE VARIABLE_TYPE
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 NBR_ELEMENTS,ELEMENT_SIZE
COMMON/DECLS/KIND,TYPE,NBR_ELEMENTS,ELEMENT_SIZE,
# LINK,LIST_SIZE,REF,BASE,BASE_MEMBER,FLAGS
IF (TT.EQ.K_STRUCTURE) THEN
CALL STRUCTURE_TYPE
ELSE
CALL BASIC_TYPE(TYPE)
ELEMENT_SIZE = BYTE_SIZE(TYPE)
ENDIF
RETURN
END
C----------------------------------------------------
SUBROUTINE BASIC_TYPE(TYPE)
INCLUDE 'PLMCOM.FOR/NOLIST'
IF (TT.EQ.K_INTEGER) THEN
TYPE = S_INTEGER
CALL GETTOK
ELSEIF (TT.EQ.K_REAL) THEN
TYPE = S_REAL
CALL GETTOK
ELSEIF (TT.EQ.K_POINTER) THEN
TYPE = S_PTR
CALL GETTOK
ELSEIF (TT.EQ.K_WORD.OR.TT.EQ.K_ADDRESS) THEN
TYPE = S_WORD
CALL GETTOK
ELSEIF (TT.EQ.K_BYTE) THEN
TYPE = S_BYTE
CALL GETTOK
ELSEIF (TT.EQ.K_LONG) THEN
TYPE = S_LONG
CALL GETTOK
ELSEIF (TT.EQ.K_DOUBLE) THEN
TYPE = S_DOUBLE
CALL GETTOK
ELSEIF (TT.EQ.K_QUAD) THEN
TYPE = S_QUAD
CALL GETTOK
ELSE
CALL MUSTBE(NT_TYPE)
ENDIF
RETURN
END
C----------------------------------------------------
SUBROUTINE STRUCTURE_TYPE
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*4 NBR_ELEMENTS,ELEMENT_SIZE,OFF
COMMON/DECLS/KIND,TYPE,NBR_ELEMENTS,ELEMENT_SIZE,
# LINK,LIST_SIZE,REF,BASE,BASE_MEMBER,FLAGS
CALL MATCH(K_STRUCTURE)
TYPE = S_STRUC
LINK = MEMBER_TOP(BLOCK_LEVEL)+1
LIST_SIZE = 0
OFF = 0
CALL MATCH(D_LP)
10 CALL MEMBER_ELEMENT(OFF,N)
LIST_SIZE = LIST_SIZE+N
IF (TT.EQ.D_COMMA) THEN
CALL GETTOK
GO TO 10
ENDIF
CALL MATCH(D_RP)
ELEMENT_SIZE = OFF
RETURN
END
C----------------------------------------------------
SUBROUTINE MEMBER_ELEMENT(OFF,N)
INCLUDE 'PLMCOM.FOR/NOLIST'
INTEGER*2 INDEX(32)
INTEGER*4 MNBR,LB,OFF
C
N=0
IF (TT.EQ.D_LP) THEN
10 CALL GETTOK
CALL MUSTBE(ID)
IF (N.GE.32) THEN
CALL ERROR('TOO MANY ELEMENTS IN FACTORED LIST')
ELSE
CALL ENTER_MEMBER
N=N+1
INDEX(N)=MEMBER_INDEX
ENDIF
CALL GETTOK
IF (TT.EQ.D_COMMA) GO TO 10
CALL MATCH(D_RP)
ELSE
CALL ENTER_MEMBER
N=1
INDEX(N)=MEMBER_INDEX
CALL GETTOK
ENDIF
IF (TT.EQ.D_LP) THEN
MKIND = S_ARRAY
CALL DIMENSION(MNBR,LB)
IF (MNBR.EQ.-1) THEN
CALL ERROR('IMPLICIT DIMENSION NOT ALLOWED FOR MEMBER')
MNBR = 0
ENDIF
ELSE
MKIND = S_SCALAR
MNBR = 1
LB=0
ENDIF
CALL BASIC_TYPE(MTYPE)
DO J=1,N
I = INDEX(J)
MEMBER_KIND(I) = MKIND
MEMBER_TYPE(I) = MTYPE
MEMBER_NBR_ELEMENTS(I) = MNBR
MEMBER_LOWER_BOUND(I) = LB
MEMBER_ELEMENT_SIZE(I) = BYTE_SIZE(MTYPE)
MEMBER_OFFSET(I) = OFF-LB*MEMBER_ELEMENT_SIZE(I)
CALL EMIT_ABSDEF4(MEMBER_VAX_ID(I),MEMBER_OFFSET(I))
OFF = OFF+MEMBER_ELEMENT_SIZE(I)*MNBR
ENDDO
RETURN
END
Reference in New Issue View Git Blame Copy Permalink