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
31738079c43b1cd3eae2815a0dfb36f71505257a
Digital-Research-Source-Code/ASSEMBLY & COMPILE TOOLS/PLM VAX COMPILER/plmvax/init.for
Sepp J Morris 31738079c4 Upload 
Digital Research
2020-11-06 18:50:37 +01:00

361 lines
11 KiB
Fortran
Raw Blame History

C***********************************************************************
C
C INIT.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 contains initialization
C routines which are called just before the first non-control line
C is processed (i.e., after all primary controls have been processed
C but before the first program text is processed).
C
C-----------------------------------------------------------------------
C
C R E V I S I O N H I S T O R Y
C
C 29SEP81 Alex Hunter 1. LENGTH,FIRST,LAST, and SIZE are now LONG
C procedures.
C 24OCT81 Alex Hunter 1. Change BI_NBR_ELEMENTS and BI_ELEMENT_SIZE
C to INTEGER*4 per changes to corresponding
C SYMBOL arrays. (V5.6)
C 28OCT81 Alex Hunter 1. Add new keywords and delete '%' from
C existing keywords, since keywords may
C now be re-declared. (V5.7)
C 10NOV81 Alex Hunter 1. Add S_NO_SIDE_EFFECTS attribute. (V6.0)
C 12NOV81 Alex Hunter 1. Implement LAST(MEMORY), etc. (V6.1)
C 2. Add BI_PSECT.
C 3. Change the way psect names are fixed up.
C 14NOV81 Alex Hunter 1. Append overlay name to P_CODE psect name.
C (V6.2)
C 21NOV81 Alex Hunter 1. Temporarily change LOW back to an external.
C (V6.3)
C 10JAN81 Alex Hunter 1. Change DOUBLE keyword to DOUBLE$PRECISION
C to avoid conflict with DOUBLE builtin.
C (V6.4).
C
C***********************************************************************
SUBROUTINE INIT_SYMTAB
INCLUDE 'PLMCOM.FOR/NOLIST'
CHARACTER*32 SYMBOL
CHARACTER*1 MODL
DATA SYMBOL_VAX_ID(SYM_MLAST),SYMBOL_REF(SYM_MLAST)
// 'MEMORY.LAST', S_VALUE /
DATA SYMBOL_VAX_ID(SYM_MLEN),SYMBOL_REF(SYM_MLEN)
// 'MEMORY.LEN', S_VALUE /
DATA SYMBOL_VAX_ID(SYM_MSIZ),SYMBOL_REF(SYM_MSIZ)
// 'MEMORY.SIZ', S_VALUE /
DATA SYMBOL_VAX_ID(SYM_SLAST),SYMBOL_REF(SYM_SLAST)
// 'STACK.LAST', S_VALUE /
DATA SYMBOL_VAX_ID(SYM_SLEN),SYMBOL_REF(SYM_SLEN)
// 'STACK.LEN', S_VALUE /
DATA SYMBOL_VAX_ID(SYM_SSIZ),SYMBOL_REF(SYM_SSIZ)
// 'STACK.SIZ', S_VALUE /
PARAMETER M = FIRST_AVAILABLE_SYMBOL_INDEX
PARAMETER N=54 ! # OF BUILTINS.
CHARACTER*32 BI_PLM_ID(N),BI_VAX_ID(N)
INTEGER*2 BI_KIND(N),BI_TYPE(N),
# BI_LINK(N),
# BI_LIST_SIZE(N),BI_REF(N),BI_BASE(N),
# BI_BASE_MEMBER(N),BI_FLAGS(N),
# BI_SERIAL_NO(N),BI_PSECT(N)
INTEGER*4 BI_NBR_ELEMENTS(N),BI_ELEMENT_SIZE(N),
# BI_LOWER_BOUND(N),BI_DISP(N)
EQUIVALENCE (BI_PLM_ID,SYMBOL_PLM_ID(M))
,, (BI_VAX_ID,SYMBOL_VAX_ID(M))
,, (BI_KIND,SYMBOL_KIND(M))
,, (BI_TYPE,SYMBOL_TYPE(M))
,, (BI_NBR_ELEMENTS,SYMBOL_NBR_ELEMENTS(M))
,, (BI_ELEMENT_SIZE,SYMBOL_ELEMENT_SIZE(M))
,, (BI_LOWER_BOUND,SYMBOL_LOWER_BOUND(M))
,, (BI_LINK,SYMBOL_LINK(M))
,, (BI_LIST_SIZE,SYMBOL_LIST_SIZE(M))
,, (BI_REF,SYMBOL_REF(M))
,, (BI_BASE,SYMBOL_BASE(M))
,, (BI_BASE_MEMBER,SYMBOL_BASE_MEMBER(M))
,, (BI_FLAGS,SYMBOL_FLAGS(M))
,, (BI_DISP,SYMBOL_DISP(M))
,, (BI_SERIAL_NO,SYMBOL_SERIAL_NO(M))
,, (BI_PSECT,SYMBOL_PSECT(M))
DATA BI_PLM_ID
// 'LENGTH','LAST','FIRST','SIZE','MEMORY','MEMORYTOP'
,, 'STACK','STACKTOP','STACKPTR','FRAMEPTR'
,, 'ABS','CMPB','CMPW','DOUBLE','FINDB','FINDRB','FINDRW'
,, 'FINDW','FIX','FLOAT','HIGH','IABS','INT','LOW'
,, 'MOVB','MOVE','MOVRB','MOVRW','MOVW','ROL'
,, 'ROR','SAL','SAR','SETB','SETW','SHL'
,, 'SHR','SIGNED','SKIPB','SKIPRB','SKIPRW','SKIPW'
,, 'UNSIGN','XLAT'
,, '$_BYTE','$_WORD','$_INTEGER','$_POINTER','$_REAL'
,, '$_LONG','$_DOUBLE','$_QUAD','$_SIGNED','$_UNSIGNED'
//
DATA BI_VAX_ID
// '...','...','...','...','MEMORY.','MEMORY.TOP'
,, 'S.BOT','S.','...','...'
,, 'ABS.','CMPB.','CMPW.','...','FINDB.','FINDRB.'
,, 'FINDRW.'
,, 'FINDW.','...','...','HIGH.','IABS.','...','LOW.'
,, 'MOVB.','MOVE.','MOVRB.','MOVRW.','MOVW.','ROL.'
,, 'ROR.','SAL.','SAR.','SETB.','SETW.','SHL.'
,, 'SHR.','...','SKIPB.','SKIPRB.','SKIPRW.','SKIPW.'
,, '...','XLAT.'
,, '...','...','...','...','...'
,, '...','...','...','...','...'
//
DATA BI_KIND
// 4*S_PROC,S_ARRAY,S_SCALAR
,, S_ARRAY,S_SCALAR,S_PROC,S_PROC
,, 7*S_PROC
,, 7*S_PROC
,, 6*S_PROC
,, 6*S_PROC
,, 6*S_PROC
,, 2*S_PROC
,, 5*S_PROC
,, 5*S_PROC
//
DATA BI_TYPE
// 4*S_LONG,S_BYTE,S_BYTE
,, S_BYTE,S_BYTE,S_PTR,S_PTR
,, S_REAL,S_WORD,S_WORD,S_WORD,S_WORD,S_WORD,S_WORD
,, S_WORD,S_INTEGER,S_REAL,S_BYTE,S_INTEGER,S_LONG,S_BYTE
,, 0,0,0,0,0,S_BYTE
,, S_BYTE,S_INTEGER,S_INTEGER,0,0,S_WORD
,, S_WORD,S_INTEGER,S_WORD,S_WORD,S_WORD,S_WORD
,, S_WORD,0
,, S_BYTE,S_WORD,S_INTEGER,S_PTR,S_REAL
,, S_LONG,S_DOUBLE,S_QUAD,-1,-1
//
DATA BI_NBR_ELEMENTS
// 4*0, 0, 0
,, 0, 0, 0, 0
,, 7*0
,, 7*0
,, 6*0
,, 6*0
,, 6*0
,, 2*0
,, 5*0
,, 5*0
//
DATA BI_ELEMENT_SIZE
// 4*4, 1, 1
,, 1,1,4,4
,, 4,2,2,2,2,2,2
,, 2,2,4,1,2,4,1
,, 0,0,0,0,0,1
,, 1,2,2,0,0,2
,, 2,2,2,2,2,2
,, 2,0
,, 1,2,2,4,4
,, 4,8,8,-1,-1
//
DATA BI_LOWER_BOUND
// N*0
//
DATA BI_LINK
// N*0
//
DATA BI_LIST_SIZE
// 4*1, 0, 0
,, 0,0,0,0
,, 1,3,3,1,3,3,3
,, 3,1,1,1,1,1,1
,, 3,3,3,3,3,2
,, 2,2,2,3,3,2
,, 2,1,3,3,3,3
,, 1,4
,, 1,1,1,1,1
,, 1,1,1,1,1
//
DATA BI_REF
// 4*S_BUILTIN, S_STATIC, S_EXT
,, S_EXT,S_EXT,S_BUILTIN,S_BUILTIN
,, 3*S_EXT,S_BUILTIN,3*S_EXT
,, S_EXT,S_BUILTIN,S_BUILTIN,S_EXT,S_EXT,S_BUILTIN,S_EXT
,, 6*S_EXT
,, 6*S_EXT
,, S_EXT,S_BUILTIN,4*S_EXT
,, S_BUILTIN,S_EXT
,, 5*S_BUILTIN
,, 5*S_BUILTIN
//
DATA BI_BASE
// N*0
//
DATA BI_BASE_MEMBER
// N*0
//
DATA BI_FLAGS
// 4*S_NO_SIDE_EFFECTS,S_SPECIAL,0
,, S_SPECIAL,0,2*S_NO_SIDE_EFFECTS
,, 7*S_NO_SIDE_EFFECTS
,, 7*S_NO_SIDE_EFFECTS
,, 5*0,S_NO_SIDE_EFFECTS
,, 3*S_NO_SIDE_EFFECTS,2*0,S_NO_SIDE_EFFECTS
,, 6*S_NO_SIDE_EFFECTS
,, 2*S_NO_SIDE_EFFECTS
,, 5*S_NO_SIDE_EFFECTS
,, 5*S_NO_SIDE_EFFECTS
//
DATA BI_DISP
// N*0
//
DATA BI_SERIAL_NO
// N*0
//
DATA BI_PSECT
// 4*0,2*P_MEMORY
,, 2*P_STACK,2*0
,, 7*0
,, 7*0
,, 6*0
,, 6*0
,, 6*0
,, 2*0
,, 5*0
,, 5*0
//
PARAMETER K=54 ! # OF KEYWORDS.
CHARACTER*32 KW_PLM_ID(K)
INTEGER*2 KW_KIND(K),KW_LINK(K)
EQUIVALENCE (KW_PLM_ID,SYMBOL_PLM_ID(M+N))
,, (KW_KIND,SYMBOL_KIND(M+N))
,, (KW_LINK,SYMBOL_LINK(M+N))
DATA KW_PLM_ID
//'ADDRESS ','AND ','AT ','BASED ','BY '
,,'BYTE ','CALL ','CASE ','DATA ','DECLARE '
,,'DISABLE ','DO ','ELSE ','ENABLE ','END '
,,'EOF ','EXTERNAL ','GO ','GOTO ','HALT '
,,'IF ','INITIAL ','INTEGER ','INTERRUPT ','LABEL '
,,'LITERALLY ','MINUS ','MOD ','NOT ','OR '
,,'PLUS ','POINTER ','PROCEDURE ','PUBLIC ','REAL '
,,'REENTRANT ','RETURN ','STRUCTURE ','THEN ','TO '
,,'WHILE ','WORD ','XOR ','COMMON ','LONG '
,,'DOUBLEPRECISION'
,, 'OTHERWISE ','QUAD ','FORWARD ','SELECTOR '
,,'DWORD ','SHORT ','BOOLEAN ','REGISTER '
//
DATA KW_KIND
// K*S_KEYWORD
//
DATA KW_LINK
// 101,102,103,104,105,106,107,108,109,110
,, 111,112,113,114,115,116,117,118,119,120
,, 121,122,123,124,125,126,127,128,129,130
,, 131,132,133,134,135,136,137,138,139,140
,, 141,142,143,144,145,146,147,148,149,150
,, 151,152,153,154
//
SYMBOL_TOP(0)=M+N+K-1
FIRST_KEYWORD=M+N
C-------- IF PLM80, DISGUISE NON-PLM80 KEYWORDS.
C
C IF (PLM80_FLAG) THEN
C KW_PLM_ID(K_INTEGER-100)='$INTEGER'
C KW_PLM_ID(K_POINTER-100)='$POINTER'
C KW_PLM_ID(K_REAL-100)='$REAL'
C KW_PLM_ID(K_WORD-100)='$WORD'
C ENDIF
C-------- FIXUP VAX_ID'S OF BUILTINS WHICH DEPEND ON MODEL SIZE.
! IF (LARGE) THEN
! MODL='L'
! ELSE
! MODL='S'
! ENDIF
!
! DO I=1,N
! DO J=1,32
! IF (BI_VAX_ID(I)(J:J).EQ.'#') BI_VAX_ID(I)(J:J)=MODL
! ENDDO
! ENDDO
C-------- CHAIN BUILTINS AND KEYWORDS INTO HASH BUCKETS.
DO 10 I=M,SYMBOL_TOP(0)
H=HASH(SYMBOL_PLM_ID(I))
SYMBOL_CHAIN(I)=HASH_BUCKET(H)
HASH_BUCKET(H)=I
10 CONTINUE
C-------- READ IN GLOBAL SYMBOLS IF REQUIRED.
LAST_GLOBAL=0
IF (GLOBALS_FLAG) THEN
20 READ(GBL,1001,END=30) SYMBOL
1001 FORMAT(X,A)
IF (SYMBOL(1:1).NE.'*') THEN
IF (LAST_GLOBAL.GE.GBL_MAX)
# CALL FATAL('TOO MANY GLOBALS')
LAST_GLOBAL=LAST_GLOBAL+1
GLOBAL_SYMBOL(LAST_GLOBAL)=SYMBOL
ENDIF
GO TO 20
30 CLOSE (UNIT=GBL)
ENDIF
C-------- FIX UP PSECT NAMES AND COMPILE TIME BASES.
IF (MODEL.EQ.4) THEN
PSECT_NAME(P_DATA)='$PLM_DATA'
ENDIF
IF (OVERLAY_FLAG) THEN
NC=LNB(PSECT_NAME(P_DATA))
PSECT_NAME(P_DATA)(NC+1:)='_'
CALL MAKE_CHARS(PSECT_NAME(P_DATA)(NC+2:),OVERLAY_PREFIX)
NC=LNB(PSECT_NAME(P_CODE))
PSECT_NAME(P_CODE)(NC+1:)='_'
CALL MAKE_CHARS(PSECT_NAME(P_CODE)(NC+2:),OVERLAY_PREFIX)
BASEC='D.'
CALL MAKE_CHARS(BASEC(3:),OVERLAY_PREFIX)
NC=LNB(BASEC)
ENDIF
IF (.NOT.ROM_FLAG .AND. MODEL.NE.4) THEN
PSECT_NAME(P_CONSTANTS)=PSECT_NAME(P_DATA)
ENDIF
IF (OVERLAY_FLAG) THEN
BASEV='R11'
ELSE
BASEV='#D.'
ENDIF
RETURN
END
Reference in New Issue View Git Blame Copy Permalink