Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_V7wLink_Feb83
-
datast.bli
There are 12 other files named datast.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
! OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1983
!AUTHOR: S. MURPHY/DCE/TFV/CKS/AHM/RVM
MODULE DATAST(RESERVE(0,1,2,3),SREG=#17,VREG=#15,FREG=#16,DREGS=4)=
BEGIN
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
GLOBAL BIND DATASV = 7^24 + 0^18 + #1542; ! Version Date: 25-May-82
%(
***** Begin Revision History *****
38 ----- ----- COMMENT OUT CALLS TO "ZDMPBLK" IN "DATPROC"
39 ----- ----- FIX ERROR CALLS
40 ----- ----- GIVE WARNING WHEN THERE ARE FEWER VARS THAN CONSTS
IN A GIVEN DATA STMNT; MAKE THE WARNING WHEN THERE
ARE TOO FEW CONSTS COME OUT ONLY ONCE;
REMOVE THE CALLS TO ZDMPBLK IN "DATPROC" WHICH WERE
PREVIOUSLY COMMENTED OUT
41 ----- ----- GIVE AN ERROR MESSAGE WHEN ATTEMPT TO WRITE BEYOND
THE END OF AN ARRAY IN A DATA STATEMENT
42 ----- ----- SHOULD USE "EXTSIGN" WHEN PICKING UP TARGADDR
FIELD FOR AN ARRAY REF
43 16361 273 SHOULD USE "EXTSIGN" WHEN PICKING UP CONSTANT IN
CNSTEVAL, (JNT)
44 314 QAR SHOULD USE "EXTSIGN" FOR IMPLIED DO LOOPS IN DATA, (JNT)
***** Begin Version 5B *****
45 666 25572 NEGATIVE INCREMENT IN DATA STATEMENT NOT
HANDLED CORRECTLY - DATA (A(I),I=10,1,-1), (DCE)
***** Begin Version 6 *****
46 761 TFV 1-Mar-80 -----
Add KTYPCG to fold /GFLOATING type conversions
52 1131 AHM 22-Sep-81 Q20-01671
Check for storing before the first word of an array in GETDADDR
since we already check for storing after the last word.
***** Begin Version 6A *****
1157 EGM 11-Jun-82
Alter error FTNMVC to indicate whether there are more or less data
items that constants in a DATA statement.
***** Begin Version 7 *****
47 1212 TFV 29-Apr-81 ------
Replace LITERAL with HOLLERITH, LITERALENTRY with HOLLENTRY.
50 1236 SRM 15-July-81 ------
Allow CHARACTER constants as well as HOLLERITH constants
to be used to initialize numeric data
51 1242 CKS 29-Jul-81
Add initialization of CHARACTER variables.
53 1416 CKS 9-Nov-81
Add initialization of character substrings. Allow integer
exponentiation in subscripts and substring bounds. Detect
zero-trip DO loops if F77.
54 1430 CKS 3-Dec-81
Add code to check substring bounds in when substrings occur in
DATA statements
55 1461 CKS 20-Jan-82
Change an error message: "DATA statement exceeds bounds of array"
to "Illegal substring bound in DATA statement". Also add identifier
name to "Can't store numeric constant in character variable."
1542 RVM 25-May-82
Always convert the REAL (GFLOATING) constants back to single
precision, even if the REAL constant was created by a conversion
from an OCTAL (or LOGICAL or HOLLERITH ...) constant originally.
***** End Revision History *****
)%
EXTERNAL CGERR;
FORWARD ALCDATA(0),ADJDATPTR(0),GETDADDR(0),CNSTEVAL(1),GETDCNST(0);
FORWARD GETCHADDR,GETCHCNST,IPOWER;
EXTERNAL OUTDATA;
EXTERNAL OUTCHDATA; ! [1242]
%(***************************************************************************
THIS MODULE PERFORMS ALLOCATION FOR DATA STATEMENTS.
THE OBJECTIVE OF DATA STATEMENTS IS TO GIVE THE LOADER INFORMATION
ABOUT STORAGE AREAS IN A FORTRAN PROGRAM WHICH ARE TO BE
PREINITIALIZED BEFORE EXECUTION OF THE PROGRAM. THE LOADER MUST
BE TOLD EACH LOCATION TO BE INITIALIZED AND THE CORRESPONDING
CONSTANT TO BE STORED THERE.
A DATA STMNT HAS ASSOCIATED WITH IT 2 KINDS OF LISTS:
1. DATA ITEM LISTS- THESE DESCRIBE LOCATIONS INTO WHICH THE
CONSTANTS ARE TO BE INITIALIZED. A DATA ITEM LIST LOOKS
LIKE AN IOLIST. ELEMENTS ON A DATA-ITEM LIST MAY BE:
A. DO STMNT
B. CONTINUE STMNT WITH A LABEL THAT TERMINATES THE DO
C. DATA-CALL: WHICH MAY HAVE AS AN ARG EITHER
A SCALAR OR AN ARRAYREF. IF ARG IS AN ARRAYREF
THEN ALL SUBSCRIPTS MUST BE OF THE FORM
C1*I+C2 WHERE I IS A LOOP INDEX AND C1 AND C2 ARE
INTEGER CONSTANTS
D. SLIST CALL
2. DATA CONSTANT LISTS- THESE INDICATE THE INITIAL VALS TO
BE STORED. A DATA CONSTANT LIST IS A LINKED LIST OF ELEMENTS
OF THE FORM:
----------------------------------------
! ! CLINK !
-----------------------------------------
! DATARPT ! DCONST !
-----------------------------------------
WHERE CLINK POINTS TO THE NEXT ELEMENT ON THE LIST (OR IS 0
FOR THE LAST ELEMENT),
DCONST POINTS TO A CONSTANT TABLE ENTRY (MAY BE FOR
A LITERAL OR FOR ANY OTHER CONSTANT)
AND DATARPT IS A CT OF THE NUMBER OF TIMES THE CONSTANT INDICATED
IS TO BE STORED.
***************************************************************************)%
OWN BASE DATAITMPTR; !POINTS TO THE ELEMENT IN THE DATA-ITEM LIST WHICH
! IS CURRENTLY BEING FILLED IN
OWN BASE DATACNSTPTR; !POINTS TO THE ELEMENT ON THE DATA CONSTANT LIST
! WHICH IS CURRENTLY BEING USED
OWN CNSTCT; !NUMBER OF TIMES THAT THE CONSTANT INDICATED BY
! "DATACNSTPTR" HAS BEEN OUTPUT SO FAR (NOTE THAT FOR
! A MULTI-WORD CONSTANT, THIS COUNT IS ONLY INCREMENTED AFTER
! ALL WORDS OF THE CONSTANT HAVE BEEN OUTPUT)
OWN CNSTWDCT; !NUMBER OF WORDS OF THE INDICATED CONSTANT THAT HAVE BEEN
! OUTPUTED SO FAR (NOTE THAT WHEN THE SAME CONSTANT IS
! OUTPUT MORE THAN ONCE, THIS COUNT IS SET NACK TO 0
! EACH TIME WE GO BACK TO THE FIRST WD OF THE CONSTANT)
OWN DCON1,DCON2; !CONSTANT WDS TO BE OUTPUT NEXT; IF THE SYMBOL
! BEING INITIALIZED IS DOUBLE PREC OR COMPLEX
! DCON1 IS HIGH ORDER PART, DCON2 LOW ORDER PART; OTHERWISE
! (FOR INTEGER AND REAL) DCON2 IS NOT USED
OWN CHDBP,CHDLEN; !CHAR BYTE POINTER AND CHAR STRING LENGTH TO BE
! INITIALIZED
OWN XTRAVARS; !FLAG INDICATING THAT HAVE
!TOO FEW CONSTANTS IN THE STMNT BEING PROCESSED
GLOBAL ROUTINE DATPROC=
%(***************************************************************************
ROUTINE TO WALK THRU ALL DATA STATEMENTS PERFORMING ALLOCATION FOR THEM
THE GLOBAL "DATASPTR" CONTAINS A PTR TO THE FIRST DATA STMNT IN ITS LEFT HALF.
***************************************************************************)%
BEGIN
EXTERNAL CSTMNT,DATASPTR;
EXTERNAL DMPMAINRLBF;
MAP BASE CSTMNT;
%1242% DMPMAINRLBF(); ! DUMP PREVIOUS .REL BLOCK FROM MAIN BUFFER.
! SINCE OUTCHDATA WRITES TYPE 1004 BLOCKS
! DIRECTLY, IT WON'T CAUSE BUFFER TO GET DUMPED
! SO DO IT NOW TO GET THINGS IN THE RIGHT ORDER
CSTMNT_.DATASPTR<LEFT>;
UNTIL .CSTMNT EQL 0
DO
BEGIN
ISN_.CSTMNT[SRCISN];
ALCDATA();
CSTMNT_.CSTMNT[CLINK];
END;
END; ! of DATPROC
GLOBAL ROUTINE ALCDATA=
%(***************************************************************************
ROUTINE TO PERFORM ALLOCATION FOR DATA STATEMENTS.
CALLED WITH CSTMNT POINTING TO A STATEMENT OF THE FORM:
----------------------------------------
! DATITEMS ! CLINK !
------------------------------------------
! DATCOUNT ! OPERATOR !
-----------------------------------------
! ISN ! DATCONS !
------------------------------------------
WHERE:
DATCONS - POINTS TO A DATA-CONSTANT-LIST
DATITEMS - POINTS TO A DATA-ITEM-LIST
***************************************************************************)%
BEGIN
EXTERNAL CSTMNT;
MAP BASE CSTMNT;
EXTERNAL ISN,WARNERR,E57;
OWN BASE SYM; !PTR TO THE SYMBOL TABLE ENTRY FOR THE VAR BEING INITIALIZED
OWN DADDR; !ADDRESS TO BE INITIALIZED (ADDRESS OF 1ST WD
! IF THE VAR IS DOUBLE-PREC)
DATAITMPTR_.CSTMNT[DATITEMS];
ADJDATPTR(); !GET PTR TO THE FIRST ELEMENT ON THE
! DATA ITEM LIST WHICH IS EITHER AN SLIST
! OR A DATACALL (AND SET UP VALS OF INDICES
! FOR IMPLICIT DO STMNT)
DATACNSTPTR_.CSTMNT[DATCONS]; !1ST ENTRY ON DATA CONSTANT LIST
CNSTCT_0; !NUMBER OF TIMES THIS CONSTANT HAS BEEN
! OUTPUT SO FAR
CNSTWDCT_0; !NUMBER OF WORDS OF THIS CONSTANT THAT
! HAVE BEEN OUTPUT SO FAR
XTRAVARS_FALSE; !FLAG INDICATING THAT HAVE RUN OUT OF CONSTS BEFORE
! FILLING ALL VARS(USED TO PREVENT REPEATING ERROR MESSAGE)
%(***WALK THRU THE DATA ITEM LIST OUTPUTING A CONSTANT FOR EACH LOCATION***)%
UNTIL .DATAITMPTR EQL 0
DO
BEGIN
%(***IF THIS DATA-ITEM IS AN SLIST (IE WANT TO FILL A WHOLE ARRAY)***)%
IF .DATAITMPTR[OPR1] EQL SLISTCLFL
THEN
BEGIN ! SLIST
OWN BASE SLSTCT; !PTR TO CONSTANT TABLE ENTRY FOR NUMBER
! OF ITEMS IN THE ARRAY
OWN WORDCT; !NUMBER OF WORDS IN THE ARRAY
SYM_.DATAITMPTR[SCALLELEM]; !PTR TO SYMBOL TABLE ENTRY FOR THE ARRAY
SLSTCT_.DATAITMPTR[SCALLCT];
IF .SYM[VALTYPE] NEQ CHARACTER
THEN
BEGIN ! NON-CHARACTER
%(***GET THE NUMBER OF WORDS IN THE ARRAY (THE SCALLCT FIELD
PTS TO ENTRY FOR THE NUMBER OF ITEMS. FOR DOUBLE-WD ENTRIES
MUST MULTIPLY BY 2)***)%
WORDCT_(IF .SYM[DBLFLG] THEN .SLSTCT[CONST2]*2 ELSE .SLSTCT[CONST2]);
%(***OUTPUT A CONSTANT TO BE STORED INTO EACH ELEM OF THE ARRAY***)%
INCR I FROM 0 TO .WORDCT-1
DO
BEGIN
GETDCNST(.SYM); !DETERMINE WHAT CONST TO OUTPUT
! (SET THE GLOBALS DCON1,DCON2)
OUTDATA(.I+.SYM[IDADDR],.DCON1,.SYM);
%(***IF THIS IS A DOUBLE-PREC (OR COMPLEX) ARRAY, MUST
OUTPUT 2ND WD OF THIS ELEM, AND ADD 1 TO NEXT
WD TO LOOK AT***)%
IF .SYM[DBLFLG]
THEN
OUTDATA( (I_.I+1)+.SYM[IDADDR],.DCON2,.SYM);
END;
END ! NON-CHARACTER
ELSE
BEGIN ! [1242] CHARACTER
CHDBP = .SYM[IDCHBP];
CHDLEN = .SYM[IDCHLEN];
DECR I FROM .SLSTCT[CONST2] TO 1 DO
BEGIN
GETCHCNST(.SYM); ! GET CONST TO OUTPUT
OUTCHDATA(.CHDBP,.CHDLEN,.DCON1,.SYM);
! WRITE CONST TO .REL FILE
CHDBP = BPADD(CHDBP,.CHDLEN);
! BUMP TO NEXT ELEMENT OF ARRAY
END
END ! [1242] CHARACTER
END ! SLIST
%(***IF THIS DATA-ITEM IS A DATACALL(EITHER AN ARRAYREF OR A SCALAR)***)%
ELSE
BEGIN ! DATACALL
%(***GET PTR TO SYMBOL TABLE ENTRY CORRESP TO THE DATA ITEM***)%
SYM_.DATAITMPTR[DCALLELEM];
%(***IF THE DATA-ITEM IS AN ARRAYREF, MUST GET PTR TO ENTRY FOR THE
ARRAY-NAME***)%
%1416% IF .SYM[OPRCLS] EQL SUBSTRING
%1416% THEN SYM_.SYM[ARG4PTR];
IF .SYM[OPRCLS] EQL ARRAYREF
THEN SYM_.SYM[ARG1PTR];
IF .SYM[VALTYPE] NEQ CHARACTER
THEN
BEGIN ! NON-CHARACTER
GETDCNST(.SYM); !SET UP DCON1 AND DCON2 TO THE 2 WDS OF THE
! CONSTANT TO BE OUTPUT (DO NOT USE DCON2 IF
! SYMBOL IS INTEGER OR REAL
DADDR_GETDADDR(); !ADDRESS INTO WHICH TO STORE
OUTDATA(.DADDR,.DCON1,.SYM);
%(***IF SYM IS DOUBLE-PREC, FILL IN THE 2ND WD***)%
IF .SYM[DBLFLG]
THEN OUTDATA(.DADDR+1,.DCON2,.SYM);
END ! NON-CHARACTER
ELSE
BEGIN ! [1242] CHARACTER
GETCHCNST(.SYM); ! SET UP DCON1 TO POINT TO
! THE NEXT CHAR CONSTANT
GETCHADDR(); ! GET CHDBP, BYTE PTR TO STRING
! AND CHDLEN, LENGTH
OUTCHDATA(.CHDBP,.CHDLEN,.DCON1,.SYM);
! WRITE STRING INTO .REL BLOCK
END ! [1242] CHARACTER
END; ! DATACALL
DATAITMPTR_.DATAITMPTR[CLINK];
ADJDATPTR(); !GET PTR TO NEXT ITEM ON DATA-ITEM-LIST
! WHICH IS EITHER A DATACALL OR
! SLISTCALL, ADJUST ANY DO-LOOP INDICES
END;
IF .DATACNSTPTR NEQ 0 !IF THERE ARE STILL CONSTANTS LEFT AFTER
! ALL VARS HAVE BEEN FILLED
%1157% THEN WARNERR(PLIT'is less than?0',.ISN,E57<0,0>); !GIVE WARNING
END; !OF ALCDATA
GLOBAL ROUTINE ADJDATPTR=
%(***************************************************************************
THIS ROUTINE IS ALWAYS CALLED AFTER THE GLOBAL "DATAITMPTR" HAS
BEEN MOVED FORWARD BY SETTING IT TO THE LINK FIELD OF THE PRECEEDING
NODE POINTED TO. IF THE NODE TO WHICH IT HAS BEEN ADVANCED IS
A DATACALL NODE, NO ACTION NEED BE TAKEN. IF THE NODE TO WHICH IT
HAS BEEN ADVANCED IS A DO STATEMENT NODE, THE DO LOOP MUST
BE INTIALIZED AND DATAITMPTR ADVANCED TO THE NEXT STMNT.
IF THE NODE TO WHICH IT HAS BEEN ADVANCED IS A CONTINUE STATEMENT WHICH
TERMINATES A DO, THE DO INDEX MUST BE ADVANCED, A LOOP-TERMINATION TEST
MADE, AND DATAITMPTR EITHER SET BACK TO THE FIRST STMNT INSIDE THE DO,OR
ADVANCED TO THE STMNT AFTER THE CONTINUE.
(NOTE THAT NO MORE THAN ONE DO LOOP WILL EVER BE TERMINATED ON THE
SAME CONTINUE; NOTE ALSO THAT DO INDICES MUST BE INTEGER AND THAT
INITL, FINAL, AND INCR VALS ON DO LOOPS MUST BE INTEGER CONSTANTS.
***************************************************************************)%
BEGIN
OWN PEXPRNODE DOINDEX; !SYMBOL TABLE ENTRY FOR THE VAR USED AS
! THE INDEX ON A DO STMNT BEING PROCESSED
LOCAL PEXPRNODE INCRVAL:FINALVAL; !INCREMENT AND FINAL LIMIT OF DO LOOP
EXTERNAL FATLERR,ISN,E175;
%(***WALK THRU THE DATA ITEM LIST UNTIL EITHER REACH THE END OF THE
LIST, OR REACH AN ELEMENT WHICH IS A DATACALL OR SLISTCALL***)%
UNTIL .DATAITMPTR EQL 0
DO
BEGIN
%(***IF ARE LOOKING AT A DATACALL OR AN SLIST, RETURN*****)%
IF .DATAITMPTR[OPRCLS] NEQ STATEMENT THEN RETURN;
%(***IF ARE LOOKING AT A DO STATEMENT, SET THE "IDDATVAL" FIELD IN
THE SYMBOL TABLE ENTRY FOR THE DO INDEX TO ITS INITIAL VALUE***)%
IF .DATAITMPTR[SRCID] EQL DOID
THEN
BEGIN
OWN PEXPRNODE DOINITVAL;
DOINDEX_.DATAITMPTR[DOSYM];
DOINITVAL_.DATAITMPTR[DOM1];
%(***CAN ASSUME INITIAL VAL IS AN INTEG CONSTANT***)%
DOINDEX[IDDATVAL]_.DOINITVAL[CONST2];
%1416% %(***CHECK FOR ZERO-TRIP LOOP***)%
%1416% IF F77 THEN
%1416% BEGIN
%1416% INCRVAL _ .DATAITMPTR[DOM3]; ! GET INCREMENT
%1416% FINALVAL _ .DATAITMPTR[DOM2]; ! GET FINAL VAL
%1416%
%1416% ! Check for initial value already greater than
%1416% ! final value (ie, for zero-trip loop)
%1416% IF (.INCRVAL[CONST2] GTR 0 AND
%1416% EXTSIGN(.DOINDEX[IDDATVAL]) GTR .FINALVAL[CONST2])
%1416% OR (.INCRVAL[CONST2] LSS 0 AND
%1416% EXTSIGN(.DOINDEX[IDDATVAL]) LSS .FINALVAL[CONST2])
%1416% OR (.INCRVAL[CONST2] EQL 0)
%1416% THEN
%1416% FATLERR(.ISN,E175<0,0>); ! "zero-trip loop illegal"
%1416% END;
%(***GO ON TO NEXT ELEM****)%
DATAITMPTR_.DATAITMPTR[CLINK];
END
ELSE
%(***IF ARE LOOKING AT A CONTINUE WHICH TERMINATES A DO STMNT, INCREMENT
THE DO INDEX AND TEST FOR THE DO INDEX GTR THAN ITS FINAL VAL.
IF HAVE FINISHED ITERATING THIS LOOP, THEN GO ON TO NEXT ELEM,
OTHERWISE GO BACK TO THE START OF THE LOOP****)%
IF .DATAITMPTR[SRCID] EQL CONTID
THEN
BEGIN
OWN PEXPRNODE LABNODE; !LABEL TABLE ENTRY FOR LABEL ON CONTINUE
OWN BASE DOSTNODE; !DO STMNT NODE AT START OF LOOP
OWN PEXPRNODE INCRVAL:FINALVAL; !CONSTANT TABLE ENTRIES
! FOR INCREMENT AND FINAL VAL
! OF LOOP INDEX
LABNODE_.DATAITMPTR[SRCLBL];
IF .LABNODE EQL 0 THEN CGERR(); !THE CONTINUE MUST TERMINATE SOME LOOP
DOSTNODE_.LABNODE[SNDOLNK];
IF .DOSTNODE EQL 0 THEN CGERR(); !THE CONTINUE MUST TERMINATE A DO
DOSTNODE_.DOSTNODE[LEFTP]; !GET PTR TO STMNT FROM THE LINKED LIST ! OF DO STMNTS ASSOCIATED WITH THIS LABEL
! (NOTE THATFOR A DATA STMNT THERE
! WILL NEVER BE MORE THAN 1)
INCRVAL_.DOSTNODE[DOM3];
FINALVAL_.DOSTNODE[DOM2];
DOINDEX_.DOSTNODE[DOSYM];
%(***INCR THE DO INDEX***)%
DOINDEX[IDDATVAL]_EXTSIGN(.DOINDEX[IDDATVAL])+.INCRVAL[CONST2]; !GET SIGNED #
![666] NEGATIVE (AND ZERO) INCREMENTS FOR DATA STATEMENT NOT HANDLED
![666] CORRECTLY - REVERSE SENSE OF THE TEST IF NEGATIVE INCREMENT
%[666]% IF ( .INCRVAL[CONST2] GTR 0 AND
%[666]% EXTSIGN(.DOINDEX[IDDATVAL]) GTR .FINALVAL[CONST2])
%[666]% OR ( .INCRVAL[CONST2] LSS 0 AND
%[666]% EXTSIGN(.DOINDEX[IDDATVAL]) LSS .FINALVAL[CONST2])
%[666]% OR ( .INCRVAL[CONST2] EQL 0)
THEN
%(***IF HAVE FINISHED LOOP ITERATION, GO ON TO STMNT AFTER LOOP***)%
DATAITMPTR_.DATAITMPTR[CLINK]
ELSE
%(***IF HAVE NOT FINISHED LOOP ITERATION, GO BACK TO STMNT AFTER DO STMNT***)%
DATAITMPTR_.DOSTNODE[CLINK];
END
ELSE CGERR(); !STMNT MUST BE EITHER DO OR CONTINUE
END;
END; ! of ADJDATPTR
GLOBAL ROUTINE GETDADDR=
%(***************************************************************************
THIS ROUTINE RETURNS THE RELOCATABLE ADDRESS CORRESPONDING TO
A DATACALL ELEMENT IN A DATA ITEM LIST.
IT IS CALLED WITH THE GLOBAL "DATAITMPTR" POINTING TO THE
DATACALL NODE FOR WHICH AN ADDRESS IS TO BE COMPUTED.
***************************************************************************)%
BEGIN
EXTERNAL FATLERR,E135;
REGISTER PEXPRNODE DATAELEM; !EXPRESSION NODE UNDER THE DATACALL - MAY BE
! AN ARRAYREF OR A DATA ITEM
REGISTER PEXPRNODE ARRAYNMENTRY; !SYMBOL TABLE ENTRY FOR THE ARRAY NAME
REGISTER PEXPRNODE ARRAYSIZE; ! THE NUMBER OF WDS IN THE ARRAY
OWN OFFST; !OFFSET IN THE ARRAY OF THE WD TO BE INITIALIZED
DATAELEM_.DATAITMPTR[DCALLELEM];
IF .DATAELEM[OPRCLS] EQL DATAOPR THEN RETURN .DATAELEM[IDADDR]
ELSE
IF .DATAELEM[OPRCLS] EQL ARRAYREF
THEN
BEGIN
ARRAYNMENTRY_.DATAELEM[ARG1PTR];
ARRAYSIZE_.ARRAYNMENTRY[IDDIM]; !DIM TABLE ENTRY FOR THE ARRAY
ARRAYSIZE_.ARRAYSIZE[ARASIZ]; ! THE NUMBER
! OF WORDS IN THE ARRAY
%(***IF THE SS WAS ALREADY FOLDED INTO THE ARRAY ADDR***)%
IF .DATAELEM[ARG2PTR] EQL 0
THEN OFFST_EXTSIGN( .DATAELEM[TARGADDR])
ELSE
OFFST_ CNSTEVAL(.DATAELEM[ARG2PTR]) + EXTSIGN(.DATAELEM[TARGADDR]) ;
%(**IF ARE TRYING TO SET A VALUE AFTER THE END OF THE ARRAY**)%
IF .OFFST GTR (.ARRAYSIZE-1)
%1131% OR .OFFST LSS 0 ! or before the beginning . . .
THEN FATLERR(.ARRAYNMENTRY[IDSYMBOL],.ISN,E135);
RETURN .OFFST+.ARRAYNMENTRY[IDADDR];
END
ELSE CGERR();
END; ! of GETDADDR
ROUTINE GETCHADDR= ! [1242] New
! This routine returns a byte pointer and character count for the character
! variable or character array ref or character substring ref in a data item
! list. Same as GETDADDR, but GETDADDR is called for numeric variables,
! GETCHADDR is called for character variables.
!
! Globals: same as GETDADDR
! DATAITMPTR = datacall node for which address is to be computed
! Return: CHDBP = byte pointer to char string to be initialized
! CHDLEN = number of chars in the variable
BEGIN
EXTERNAL FATLERR,E135,E173;
REGISTER PEXPRNODE DATAELEM; ! EXPRESSION NODE UNDER THE DATACALL,
! MAY BE ARRAYREF, DATA ITEM, SUBSTRING
REGISTER PEXPRNODE ARRAYNMENTRY; ! SYMBOL TABLE ENTRY FOR ARRAY NAME
REGISTER PEXPRNODE ARRAYSIZE; ! NUMBER OF CHARS IN THE ARRAY
OWN OFFST; ! CHAR OFFSET WITHIN ARRAY
DATAELEM _ .DATAITMPTR[DCALLELEM];
OFFST _ 0; ! INIT OFFSET TO 0
CHDLEN _ -1; ! LENGTH NOT SET YET
IF .DATAELEM[OPRCLS] EQL SUBSTRING
THEN
BEGIN ! SUBSTRING
OFFST _ CNSTEVAL(.DATAELEM[ARG2PTR]); ! GET LOWER BOUND - 1
CHDLEN _ CNSTEVAL(.DATAELEM[ARG1PTR]); ! GET UPPER BOUND
ARRAYNMENTRY _ .DATAELEM[ARG4PTR];
IF .ARRAYNMENTRY[OPRCLS] EQL ARRAYREF
THEN ARRAYNMENTRY _ .ARRAYNMENTRY[ARG1PTR];
ARRAYSIZE _ .ARRAYNMENTRY[IDCHLEN];
IF .OFFST LSS 0 OR .OFFST GEQ .ARRAYSIZE !CHECK LOWER BOUND
OR .CHDLEN LEQ 0 OR .CHDLEN GTR .ARRAYSIZE !CHECK UPPER BOUND
OR .OFFST GEQ .CHDLEN !CHECK LOWER VS. UPPER
THEN FATLERR(.ISN,E173<0,0>); !GIVE WARNING IF PROBLEM
CHDLEN _ .CHDLEN - .OFFST; ! SET LENGTH
DATAELEM _ .DATAELEM[ARG4PTR]; ! MOVE DOWN TO SUBSTRINGEE NODE
END; ! SUBSTRING
IF .DATAELEM[OPRCLS] EQL DATAOPR
THEN
BEGIN ! SIMPLE VARIABLE
CHDBP _ BPADD(DATAELEM[IDCHBP],.OFFST); ! SET BYTE PTR
IF .CHDLEN LSS 0 THEN CHDLEN _ .DATAELEM[IDCHLEN];
! IF LEN NOT SET BY SUBSTRING ABOVE,
! SET TO WHOLE STRING
END ! SIMPLE VARIABLE
ELSE
IF .DATAELEM[OPRCLS] EQL ARRAYREF
THEN
BEGIN ! ARRAYREF
ARRAYNMENTRY _ .DATAELEM[ARG1PTR]; ! GET ARRAY ID TABLE ENTRY
ARRAYSIZE _ .ARRAYNMENTRY[IDDIM]; ! DIM TABLE ENTRY
ARRAYSIZE _ .ARRAYSIZE[ARASIZ]; ! NUMBER OF CHARS IN ARRAY
IF .DATAELEM[ARG2PTR] NEQ 0 ! ADD SUBSCRIPT INTO OFFSET
THEN OFFST _ .OFFST + CNSTEVAL(.DATAELEM[ARG2PTR]);
IF .OFFST GTR .ARRAYSIZE-1 OR .OFFST LSS 0 ! CHECK SUBSCRIPT
THEN FATLERR(.ARRAYNMENTRY[IDSYMBOL],.ISN,E135<0,0>);
CHDBP _ BPADD(ARRAYNMENTRY[IDCHBP],.OFFST); ! SET BYTE PTR
IF .CHDLEN LSS 0 THEN CHDLEN _ .ARRAYNMENTRY[IDCHLEN];
! IF LEN NOT SET BY SUBSTRING ABOVE,
! SET TO WHOLE STRING
END !ARRAYREF
ELSE CGERR(); ! ERROR IF NOT DATAOPR OR ARRAYREF
END; ! of GETCHADDR
GLOBAL ROUTINE CNSTEVAL(EXPR)=
%(***************************************************************************
TO FOLD AN ARITHMETIC EXPRESSION IN WHICH ALL TERMS ARE INTEGER
CONSTANTS.
THE ARGUMENT "EXPR" MUST BE EITHER AN ARITHMETIC NODE OR AN INTEGER
CONSTANT NODE OR A SYMBOL TABLE ENTRY FOR AN INDEX ON AN INPLICIT
DO-LOOP INSIDE A DATA STATEMENT.
RETURNS THE VALUE COMPUTED.
THIS ROUTINE IS RECURSIVE
***************************************************************************)%
BEGIN
MAP PEXPRNODE EXPR;
IF .EXPR[OPR1] EQL CONSTFL THEN RETURN .EXPR[CONST2]
ELSE
%(***IF EXPR IS A SYMBOL TABLE ENTRY, ASSUME THAT IT
IS AN INDEX ON AN IMPLIED DO IN A DATA STMNT AND
THAT THE "IDDATVAL" FIELD OF THE SYMBOL TABLE ENTRY CONTAINS
THE CURRENT VAL OF THAT INDEX***********)%
IF .EXPR[OPRCLS] EQL DATAOPR
THEN
RETURN EXTSIGN(.EXPR[IDDATVAL]) !EXTEND SIGN FOR - NUMBERS
ELSE
IF .EXPR[OPRCLS] EQL ARITHMETIC
THEN
BEGIN
CASE .EXPR[OPERSP] OF SET
%(***FOR ADD*****)%
RETURN CNSTEVAL(.EXPR[ARG1PTR]) + CNSTEVAL(.EXPR[ARG2PTR]);
%(***FOR SUBTRACT***)%
RETURN CNSTEVAL(.EXPR[ARG1PTR]) - CNSTEVAL(.EXPR[ARG2PTR]);
%(***FOR MULTIPLY***)%
RETURN CNSTEVAL(.EXPR[ARG1PTR])*CNSTEVAL(.EXPR[ARG2PTR]);
%(***FOR DIVIDE***)%
RETURN (CNSTEVAL(.EXPR[ARG1PTR]))/(CNSTEVAL(.EXPR[ARG2PTR]));
%(***FOR EXPONENTIATION***)%
%1416% RETURN IPOWER(CNSTEVAL(.EXPR[ARG1PTR]),CNSTEVAL(.EXPR[ARG2PTR]))
TES;
END
ELSE
%(***FOR NEG (APPEARS ABOVE NEGATIVE CONSTANTS)***)%
IF .EXPR[OPR1] EQL NEGFL
THEN RETURN -CNSTEVAL(.EXPR[ARG2PTR])
ELSE CGERR();
END; ! of CNSTEVAL
GLOBAL ROUTINE IPOWER(BASE,EXP)= ! [1416] New
%(***************************************************************************
ROUTINE TO EVALUATE INTEGER ** INTEGER
***************************************************************************)%
BEGIN
REGISTER ANS,BASESQ,N;
N = .EXP;
IF .N LSS 0
THEN
BEGIN
IF .BASE NEQ 1 AND .BASE NEQ -1
THEN RETURN 0
ELSE IF .N THEN RETURN .BASE ELSE RETURN 1;
END;
IF .N EQL 0 THEN RETURN 1;
ANS = 1;
BASESQ = .BASE;
WHILE 1 DO
BEGIN ! HERE BASE**EXP = ANS * BASESQ**N
IF .N ! IF EXPONENT IS ODD
THEN
BEGIN
ANS = .ANS * .BASESQ; ! MULTIPLY
IF .N LEQ 1 THEN RETURN .ANS;
END;
N = .N ^ (-1); ! ADJUST EXPONENT
BASESQ = .BASESQ * .BASESQ; ! ADJUST BASE
END;
END; ! of IPOWER
GLOBAL ROUTINE GETDCNST(SYM)=
%(***************************************************************************
ROUTINE TO SET UP THE NEXT CONSTANT WORD(S) TO BE OUTPUT FOR A GIVEN
DATA-CONSTANT-LIST.
CALLED WITH THE GLOBALS:
DATACNSTPTR-PTR TO THE ENTRY ON THE DATA CONSTANT LIST TO BE USED NEXT
CNSTCT- COUNT OF THE NUMBER OF TIMES THAT THE CONSTANT
INDICATED BY "DATACNSTPTR" HAS BEEN OUTPUT (NOTE THAT FOR
MULTI-WORD CONSTANTS, THIS COUNT IS ONLY INCREMENTED AFTER ALL
WORDS OF THE CONSTANT HAVE BEEN OUTPUT)
CNSTWDCT-COUNT OF THE NUMBER OF WORDS OF THE INDICATED CONSTANT THAT HAVE
ALREADY BEEN OUTPUT (NOTE THAT THIS CT IS SET BECK TO 0 FOR EACH
REPITITION OF A GIVEN CONSTANT)
CALLED WITH THE ARG
SYM - THE SYMBOL THAT WILL BE SET TO THIS CONSTANT;
UNLESS THE CONSTANT IS A LITERAL, IT MUST BE CONVERTED TO AGREE IN TYPE
WITH "SYM"
IF SYM IS DOUBLE-PREC OR COMPLEX THIS ROUTINE LEAVES THE GLOBALS-
DCON1 - HIGH ORDER WD OF THE CONSTANT TO BE OUTPUT
DCON2 - LOW ORDER WD TO BE OUTPUT
OTHERWISE IT LEAVES
DCON1- THE WORD TO BE OUTPUT
DCON2 - IS IGNORED
***************************************************************************)%
BEGIN
EXTERNAL WARNERR,E57; !PRINT WARNING MESSAGE
![761] KTYPCG to fold /GFLOATING type conversions
%[761]% EXTERNAL KTYPCB,KTYPCG; !BASE IN TABLE FOR CONSTANT FOLDING FOR TYPE CONVERSIONS
EXTERNAL KISNGL; !ROUTINE TO ROUND A REAL THAT IS BEING REPRESENTED
! INTERNALLY WITH 2 WDS OF PRECISION
OWN BASE CNSTENTRY; !CONSTANT TABLE ENTRY FOR THE DESIRED CONSTANT
MAP PEXPRNODE SYM;
EXTERNAL C1H,C1L,C2H,C2L,COPRIX,CNSTCMB; !GLOBALS USED BY THE CONSTANT FOLDING
! ROUTINE
BIND BLANKWD=#201004020100; !A WORD OF BLANKS
%(***IF HAVE REACHED THE END OF THE LIST OF CONSTANTS (AND PRESUMABLY NOT THE
END OF THE LIST OF DATA ITEMS) GIVE A WARNING MESSAGE
AND FILL WITH ZEROES***)%
IF .DATACNSTPTR EQL 0
THEN
BEGIN
EXTERNAL ISN;
IF NOT .XTRAVARS !IF THIS IS THE 1ST VAR TO BE FILLED WITH 0'S
THEN
%1157% WARNERR(PLIT'is greater than?0',.ISN,E57<0,0>); !PRINT WARNING MESSAGE
XTRAVARS_TRUE;
DCON1_0;
DCON2_0;
RETURN
END;
CNSTENTRY_.DATACNSTPTR[DCONST];
%(***FOR HOLLERITH********)%
!**;[1212], GETDCNST, TFV, 29-Apr-81
!**;[1212], Replace LITERAL with HOLLERITH, LITERALENTRY with HOLLENTRY
%[1212]% IF .CNSTENTRY[VALTYPE] EQL HOLLERITH
%[1236]% OR .CNSTENTRY[VALTYPE] EQL CHARACTER ! Allow quoted constants as well as H
THEN
BEGIN
%[1212]% OWN HOLLENTRY LITENTRY;
OWN LITSIZ1; !NUMBER OF WDS IN THE LITERAL EXCLUDING A
! POSSIBLE PAD WD (DO NOT PUT ASCIZ OU FOR DATA STMNT)
LITSIZ1_(IF .CNSTENTRY[LITEXWDFLG] THEN .CNSTENTRY[LITSIZ]-1
ELSE .CNSTENTRY[LITSIZ] );
LITENTRY_.CNSTENTRY;
%(***VAL TO BE OUTPUT IS THE (N+1)TH WD OF THE LITERAL, WHERE N IS THE
VALUE OF CNSTWDCT (IE NUMBER OF WDS OF THE LITERAL ALREADY OUTPUT***)%
DCON1_.LITENTRY[.CNSTWDCT+1];
%(***GO ON TO NEXT WD OF LITERAL***)%
CNSTWDCT_.CNSTWDCT+1;
%(***IF THE SYMBOL BEING INITIALIZED IS DOUBLE-WD, MUST PICK UP A 2ND
WD OF THE LITERAL (IF HAVE REACHED THE END OF THE LITERAL, SET 2ND
WD TO A WD OF BLANKS ***)%
IF .SYM[DBLFLG]
THEN
BEGIN
IF .CNSTWDCT EQL .LITSIZ1 !IF HAVE REACHED END OF LIT
THEN DCON2_BLANKWD
ELSE
BEGIN
DCON2_.LITENTRY[.CNSTWDCT+1];
CNSTWDCT_.CNSTWDCT+1;
END;
END;
%(***IF HAVE OUTPUT THE ENTIRE LITERAL, SET THE WORD CT BACK TO 0 AND
INCREMENT THE CT OF NUMBER OF TIMES THE WHOLE CONSTANT WAS OUTPUT***)%
IF .CNSTWDCT EQL .LITSIZ1
THEN
BEGIN
CNSTWDCT_0;
CNSTCT_.CNSTCT+1;
END;
END
ELSE
%(***FOR CONSTANTS OTHER THAN LITERALS***)%
BEGIN
%(***IF THE SYMBOL IS OF A DIFFERENT VALTYPE THAN THE CONSTANT,
CONVERT THE CONSTANT***)%
IF .SYM[VALTP1] NEQ .CNSTENTRY[VALTP1]
THEN
BEGIN
C1H_.CNSTENTRY[CONST1];
C1L_.CNSTENTRY[CONST2];
COPRIX_KKTPCNVIX(.SYM[VALTP2],.CNSTENTRY[VALTP2]);
CNSTCMB(); !LEAVES THE GLOBALS C2H,C2L SET TO THE CONVERTED
! VALUE
END
ELSE
BEGIN
C2H_.CNSTENTRY[CONST1]; !SET THE GLOBALS C2H,C2L TO THE ORIG VALUE
C2L_.CNSTENTRY[CONST2];
END;
%(***SET UP DCON1 AND DCON2 TO BE THE CONSTANT***)%
CASE .SYM[VALTP1] OF SET
%(***IF THE TYPE IS INTEGER OR OCTAL/LOGICAL***)%
DCON1_.C2L;
%(***IF THE TYPE IS REAL - MUST ROUND SINCE HAVE STORED 2 WDS OF PREC***)%
%1542% DCON1=IF .GFLOAT
%1542% THEN KISNGL(.C2H,.C2L) !Even originally OCTAL constants need conversion under /GFL
ELSE IF BITPTNVALTYP(.CNSTENTRY[VALTYPE]) !IF THE CONSTANT WAS OCTAL,...
THEN .C2H ! DONT ROUND
ELSE KISNGL(.C2H,.C2L);
%(***IF THE TYPE IS DOUBLE PREC ***)%
BEGIN
DCON1_.C2H;
DCON2_.C2L;
END;
%(***IF THE TYPE IS COMPLEX***)%
BEGIN
DCON1_.C2H;
DCON2_.C2L;
END;
TES;
%(***INCR CT OF NUMBER OF TIMES THIS CONSTANT HAS BEEN USED***)%
CNSTCT_.CNSTCT+1;
END;
%(***TEST FOR WHETHER HAVE FINISHED ALL REPITITIONS OF THE CONSTANT AND IF SO
GO ON TO THE NEXT***)%
IF .CNSTCT GEQ .DATACNSTPTR[DATARPT]
THEN
BEGIN
DATACNSTPTR_.DATACNSTPTR[CLINK];
CNSTCT_0;
END;
END; ! of GETDCNST
ROUTINE GETCHCNST(SYM)= ! [1242] New
! Routine to set up the next character constant to be output for a given
! data-constant-list. Same as GETDCNST, but GETDCNST is called for numeric
! variables, GETCHCNST is called for character variables.
!
! Globals: same as GETDCNST
! DATACNSTPTR = ptr to entry on the data constant list to be
! used next
! CNSTCT = count of the number of times that the constant
! indicated by DATACNSTPTR has been output (note that
! for multi-word constants, this count is only
! incremented after all words of the constant have
! been output)
! CNSTWDCT = count of the number of words of the indicated
! constant that have already been output (note that this
! count is set back to 0 for each repetition of a given
! constant)
! Args: SYM = the symbol which will be set to this constant
! must be type CHARACTER
! The corresponding constant in the constant-list must be type character; if
! not, a fatal error message is typed. The character constant cannot have
! been partially used up by numeric variables; if not, a fatal error message
! is typed.
!
! Returns DCON1 = pointer to literal table entry of a character constant
! or 0 if the corresponding variable should be set to blanks
BEGIN ! GETCHCNST
MAP PEXPRNODE SYM;
MAP PEXPRNODE DCON1;
EXTERNAL ISN,WARNERR,FATLERR;
EXTERNAL E57,E160,E161;
! If at end of the constant-list, type warning message
IF .DATACNSTPTR EQL 0
THEN
BEGIN
IF NOT .XTRAVARS ! IF THIS IS THE FIRST TIME
THEN
%1157% WARNERR(PLIT'is greater than?0',.ISN,E57<0,0>); !PRINT WARNING MESSAGE
XTRAVARS _ TRUE;
DCON1 _ 0;
DCON2 _ 0;
RETURN;
END;
DCON1 _ .DATACNSTPTR[DCONST]; ! GET PTR TO CONSTANT
DCON2 _ 0;
IF .DCON1[VALTYPE] NEQ CHARACTER ! CHECK DATATYPE
THEN
BEGIN
FATLERR(.SYM[IDSYMBOL],.ISN,E160<0,0>);
! "Can't store numeric constant
! in character variable X"
DCON1 _ 0;
END;
IF .CNSTWDCT NEQ 0 ! CHECK THAT WE ARE AT BEGINNING OF CONSTANT
THEN
BEGIN
FATLERR(.ISN,E161<0,0>); ! "Character constant split between
! numeric and character variables"
CNSTWDCT _ 0;
DCON1 _ 0;
END;
! Increment count of how many times this const has been used
CNSTCT _ .CNSTCT + 1;
! Test for whether we've finished all repetitions of this constant and
! go to the next if we have
IF .CNSTCT GEQ .DATACNSTPTR[DATARPT]
THEN
BEGIN
DATACNSTPTR _ .DATACNSTPTR[CLINK];
CNSTCT _ 0;
END;
END; ! of GETCHCNST
END
ELUDOM