Trailing-Edge
-
PDP-10 Archives
-
BB-4157D-BM
-
sources/act1.bli
There are 26 other files named act1.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) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: T.E. OSTEN/FJI/MD/SJW/JNG/DCE
MODULE ACT1(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
! REQUIRES LEXNAM, FIRST, TABLES, ASHELP
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
SWITCHES NOSPEC;
REQUIRE ASHELP.BLI;
GLOBAL BIND ACT1V = 5^24 + 1^18 + 113; !VERSION DATE: 4-AUG-77
%(
REVISION HISTORY
69 ----- ----- MAKE USE COUNT FOR IMPLIESD DO LOOP LABELS
2 INSTEAD OF 1
70 ----- ----- GENERATE LABELS FOR DIMENSION BLOCKS FOR ARRAYS
THAT ARE PROTECTED (ALSO - COMMENT OUT CODE IN
"BLDARRAY" THAT APPEARS TO PROCESS MULTIPLE
ARRAYS SPECIFIED BY THE SAME DIMENSION SPECIFICATION)
71 ----- ----- FIX OPERSP FIELD OF SLIST CALLS
72 ----- ----- MODIFY "BLDARRAY" TO GENERATE DIMENSION LABELS
FOR ALL ARRAYS IF THE "BOUNDS" SWITCH WAS SPECIFIED.
(WE HAVE DONE AWAY WITH THE "ISPROT" FLAG ON INDIVIDUAL
ARRAYS)
76 ----- ----- DETECT UNDETECTED SUBSCRIPTED IMPLICIT DO INDICES
77 ----- ----- PUT PARAMETER STUFF IN NAMCHK AND NAMDEF.
PUT *N OVERRIDE IN BLDARRAY.
CHANGE NO PARAMETERS IN FUNCTION TO WARNING
78 ----- ----- IN FUNCGEN - NO LONGER SET FNNAME ON FUNCTIONS.
- PROGNAME IS NOW SET IN ACTION PNAMSET
79 ----- ----- MAKE A LINKED LIST OF ENTRY POINT NAMES IN FUNCGEN
80 ----- ----- ALLOW DIMENSION A(1:3)
81 ----- ----- DUMMIES CAN BE IN EXTERNAL STATEMENTS
82 ----- ----- CLEAR THE NOALOC BIT IN THE OTHER PLACE
WHERE THE SPECIAL FORMAL ARRAY PSEUDOSYMBOL TABLE
ENTRY IS GENERATED - FUNCGEN
83 ----- ----- CHANGE NAMDEF AND NAMCHK TO INTERPRET THE &/* EXTERNAL
STATEMENT PROPERLY
84 ----- ----- FIX BLDARRAY SO THAT IT ACCEPTS THE TYPE INFORMATION
FOR TYPE STATEMENTS BEFORE THE DIMENSION INFORMATION
RATHER THAN AFTER
85 ----- ----- CHECK FOR DUPLICATE DUMMY ARGS IN FUNCTIONS,
SUBROUTINES AND ENTRYS
86 ---- ----- HAVE BLDDIM USE DVARFLGS TO CLEAR THE FLAGS IN
THE DIMENSION TABLE ENTRY.
87 ----- ----- DETECT THE CASE OF AN IMPLIED DO SPEC WITHOUT
PRECEEDING VARIABLE LIST OF SOME SORT - DATALIST
88 ----- ----- ISSUE A WARNING MESSAGE WHEN LABEL INDICATORS
APPEAR IN THE FORMAL ARGUMENT LIST OF A FUNCTION
FUNCGEN
89 ----- ----- FIX BLDARRAY SO THAT IT WILL REVERSE
THE CALCULATED DIMENSIONS OF AN ARRAY WHICH
HAS GONE TO DOUBLE PRECISION DUE TO
AN IMPLICIT STATEMENT AND IS THEN EXPLICITLY TYPED
TO SINGLE PRECISION
90 ----- ----- CHECK IN BLDDIM TO BE SURE THAT DIMENSIONS
ARE WITHIN A RESPECTABLE RANGE
91 ----- ----- IN BLDDIM, CHANGE REFERENCE TO "DEBUG" FLAG
TO "DBGDIMN" FLAG
92 ----- ----- FUNCGEN - FIX DUPLICATE DUMMY PARAMETER CHECK SO
IT REALLY WORKS
93 ----- ----- MAKE A CHECK FOR DO INDEX MODIFICATION IN NAMSET
SO THAT ALL CASES ARE CHECKED
94 ----- ----- NAMSET WAS NOT CALLED FOR IMPLICIT DO INDICES
95 ----- ----- BLDDIM - CHECK FOR ZERO SINGLE DIMENSION
96 ----- ----- WITH THE ADVENT OF SIGNED PARAMETERS - BULDDIM
MUST BE PREPARED TO CHECK THE SIGN OF THE NUMBER
NOT JUST WHETHER OR NOT A - WAS
PRESENT
97 ----- ----- EXTEND NAMDEF TO DETECT REFERENCE TO DUMMY PARAMETERS
BEFORE THEY HAVE BEEN DEFINED
*** BEGIN VERSION 4A
99 230 ----- RESTORE NOALLOC BIT WHEN ADJUSTABLE DIMENSION
IS NOT YET DEFINED
100 232 ----- FIX BLDUNIT - IT NEEDED ONE MORE LEVEL OF
INDIRECTION IN THE RECORD NUMBER PROCESSING.
101 235 ----- FIX NAMELIST PROBLEMS
USING NEW PARAMETER NMLSTITM
102 265 15946 ADD CHECK FOR VARIABLE IN DATA STATEMENT TWICE
103 272 ----- CHANGE 102 TO ONLY CHECK SIMPLE VARIABLES, NOT ARRAYS
*** BEGIN VERSION 5
104 VER5 ----- SHARE .I OFFSET IN DIMENTRY FOR ARRAYS
WITH VARIABLE UPPER BOUND (LINK DIM ENTRIES)
105 410 ----- MAKE DTABPTR GLOBAL SO WILL BE INITIALIZED TO 0
106 414 QA625 FIX SHARING .I OFFSET SO ONLY SHARES DIM2 .I
IF DIM1 SAME
107 415 18964 DON'T DESTROY SYMBOL TABLE ENTRY FOR A FORMAL
FUNCTION IF A LATER ENTRY STATEMENT SEEN WITH
THE FUNCTION AS A PARAMETER.
108 423 QA709 FIX PATCH 414: DIMNUM=1 => ARRAY HAS 1 DIM NOT 2
109 460 19477 TEST FOR OVERSIZED DIMENSIONING CORRECTLY
***** BEGIN VERSION 5A *****
110 567 22284 MAKE EXTERNAL STMNT APPLY TO ALL ENTRY POINT PARAMS
111 571 22378 FIX V5 OPTIMIZATION THAT SHARES 2ND OFFSET OF
FORMAL ARRAYS IF 1ST DIMENSIONS = SO ALL WILL
WORK IF ARRAY SUBSEQUENTLY TYPED DIFFERENTLY
(DIFFERENT # WORDS) THAN WHEN SHARING 1ST DONE
112 572 21825 CHECK IMPLIED DO INDEX FOR ALREADY ACTIVE (FROM
AN ENCLOSING IMPLIED OR REAL DO)
113 601 Q20-26 FIX EDIT 572 TO CHECK IMPLIED DO INDEX IN DATA
STATEMENT FOR ALREADY ACTIVE FROM AN ENCLOSING
IMPLIED DO
)% !END REVISION HISTORY
FORWARD
FUNCGEN, !
TYPEGEN, !
TMPGEN, !
BLDDIM, !
BLDARRAY, !
BLKSRCH, !
BLDVAR, !
DATALIST, !
BLDFORMAT, !
BLDUNIT, !
NAMSET,
NAMREF,
NAMDEF,
NAMCHK;
% THE FOLLOWING TABLE IS USED TO PRODUCE THE ERROR MESSAGES
IT IS BASED UPON THE BIT POSITION OF THE CONFLICTING IDATTRIBUT
FIELD BIT %
BIND DUMDUM = PLIT (
R18 NAMES R23 NAMES 'IN EXTERNAL STATEMENT?0',
R22 NAMES 'AS DUMMY PARAMETER?0',
R19 NAMES 'IN TYPE STATEMENT?0',
R24 NAMES 'IN DATA STATEMENT?0',
R26 NAMES 'IN COMMON?0',
R27 NAMES 'IN EQUIVALENCE?0',
R28 NAMES 'AS AN ENTRY POINT NAME?0',
R33 NAMES 'AS STATEMENT FUNCTION?0',
R34 NAMES 'AS COMMON BLOCK?0',
R35 NAMES 'AS NAMELIST?0',
AYORFN NAMES ' AS AN ARRAY OR FUNCTION?0',
AY NAMES 'AS AN ARRAY?0',
FNN NAMES 'AS A FUNCTION?0'
);
GLOBAL ROUTINE
NAMDEF ( TYPE, ID ) =
BEGIN
EXTERNAL E136;
MAP BASE ID;
% ID - POINTER TO SYMBOL TABLE ENTRY %
% TYPE - CODE FOR WHAT YOU THINK YOU HAVE %
% THE FOLLOWING BINDS ARE USED TO MAKE THE SYMBOL TABLE ATTRIBUTE
FIELD MASKS %
BIND
NAMLST = 1^35,
CMNBLK = 1^34,
STFN = 1^33,
ENTPNT = 1^28,
EXTERN = 1^23,
EXTRSGN = 1^18,
TYPED = 1^19,
EXTBTH = 1^18 + 1^23,
EQVIN = 1^27,
COMIN = 1^26,
DATAIN = 1^24,
DUMIEE = 1^22;
% THE FOLLOWING ARE MASKS ( INDEXED BY .TYPE ) OF THE SYMBOLTABLE
IDATRIBU FIELD. IF THE AND IS NON-ZERO THEN THERE IS A CONFLICT %
BIND DEFMASK = PLIT (
%ARRYDEF% NAMLST + STFN + ENTPNT + EXTBTH,
%ARRYDEFT% NAMLST + STFN + ENTPNT + EXTBTH + TYPED,
%STFNDEF% NAMLST + STFN + ENTPNT + EXTBTH + EQVIN + COMIN + DATAIN + DUMIEE,
%EXTDEF% NAMLST + STFN + ENTPNT + EXTBTH + DATAIN + COMIN + EQVIN,
%NMLSTDEF% NAMLST + STFN + ENTPNT + EXTBTH + DUMIEE + DATAIN + COMIN + EQVIN,
%VARARY% NAMLST + STFN + EXTBTH + COMIN + DUMIEE,
%IDDEFT% NAMLST + TYPED,
%IDDEFINE% NAMLST + STFN + ENTPNT + EQVIN + COMIN + DATAIN, %DUMMY PARAMETERS%
%ENTRYDEF% NAMLST + STFN + ENTPNT + EXTBTH + CMNBLK + DUMIEE,
%EXTDEFS% NAMLST + STFN + ENTPNT + EXTBTH + CMNBLK + DATAIN + COMIN + EQVIN,
%CMNBLK% ENTPNT + EXTRSGN,
%**;[235], ROUTINE NAMDEF , REPLACE @ LINE 3511, DT/MD ,11/18/74 %
%[235]% %PARADEF% NAMLST + CMNBLK + STFN + ENTPNT + EXTBTH + TYPED + EQVIN + COMIN + DATAIN + DUMIEE,
%[235]% %NMLSTITM% NAMLST + STFN + EXTBTH + DUMIEE
);
% NAMDEF IS REFERENCED FROM THE FOLLOWING ROUTINES WITH THE FOLLOWING TYPES:
SEMANTIC ROUTINE - TYPES
TYPE STATEMENTS ARRYDEFT, IDDEFT
FUNCTION ENTRYDEF, IDDEF
SUBROUTINE ENTRYDEF, IDDEF
ENTRY ENTRYDEF, IDDEF
PROGRAM ENTRYDEF
BLOCKDATA ENTRYDEF
DIMENSION ARRYDEF
COMMON VARARY, CMNBLK, ARYDEF
EXTERNAL EXTDEF, EXTDEFS(LIB FUNCTION)
NAMELIST NMLSTDEF, VARARY
STMNT FUNCTION STFNDEF
PARAMETER PARADEF
NOTE THAT EQUIVALENCE AND DATA STATEMENTS REFERENCE NAMSET RATHER
THAN NAMDEF. THIS IS DONE MAINLY FOR CONVIENCE. IF THEY COULD BE
CHANGED TO REFERENCE NAMREF IT MIGHT BE POSSIBLE, WITH A LITTLE THOUGHT, TO DETECT
INSTANCES OF DEFINITION AFTER REFERENCE.
%
%THIS MASK DEFINES WHICH TYPES CAN BE THE SAME AS AN ENTRY POINT
NAME AS LONG AS ITS NOT IN A FUNCTION %
BIND OKSAMEASENTRY = 1^ARRYDEF + 1^ARRYDEFT + 1^STFNDEF +
1^EXTDEF + 1^NMLSTDEF + 1^IDDEFINE ;
BIND PDEFAS = PLIT (
R18,R19,0,0,R22,R23,R24,0,R26,R27,R28,0,0,0,0,R33,R34,R35 );
REGISTER R;
EXTERNAL CREFIT;
IF .FLGREG<CROSSREF> THEN CREFIT( .ID, SETT );
% CHECK THE ATTRIBUTES %
IF ( R _ .DEFMASK[.TYPE]<LEFT> AND .ID[IDATTRIBUT(ALLOFTHEM)] ) NEQ 0
THEN
%ALLOW STATEMENT FUNCTIONS , ARRAYS , NAMELISTS , AND POSSIBLE LIBRARY
FUNCTIONS TO BE THE SAME AS ENTRY POINT NAMES PROVIDING
THAT THIS IS NOT A FUNCTION %
IF (1^(.TYPE) AND OKSAMEASENTRY ) EQL 0
OR .FLGREG < PROGTYP> EQL FNPROG
OR .R NEQ ENTPNT^(-18)
THEN
% ALLOW ENTRY POINT DEFINITIONS TO BE THE
SAME AS NAMELIST, STATEMENT FUNCTIONS, AND
POSSIBLE LIBRARY FUNCTIONS AS LONG AS ITS NOT A FUNCTION%
IF .TYPE NEQ ENTRYDEF
OR .FLGREG<PROGTYP> EQL FNPROG
OR ( .R NEQ NAMLST^(-18)
AND .R NEQ STFN^(-18)
AND .R NEQ EXTERN^(-18) )
THEN
% ITS A CONFLICTING DEFINITION %
RETURN FATLEX ( .PDEFAS[35-FIRSTONE(.R)], ID[IDSYMBOL], E34 );
% WE MUST DO JUST A BIT MORE CHECKING %
VREG _ 0;
VREG _ CASE .TYPE OF SET
%ARRYDEF% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1 THEN AYORFN
END;
%ARRYDEFT% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1 THEN AYORFN
END;
%STFNDEF% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1 THEN AYORFN
END;
%EXTDEFS% BEGIN
IF .ID[OPRSP1] EQL ARRAYNM1 THEN AY
END;
%NMLSTDEF% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1 THEN AYORFN
END;
%VARARY% BEGIN
IF .ID[OPRSP1] EQL FNNAME1 THEN FNN
END;
%IDDEFT% BEGIN END;
%IDDEF% BEGIN
%CHECK HERE TO SEE THAT DUMMY PARAMETERS
HAVE NEVER BEEN REFERENCED %
IF NOT .ID[IDATTRIBUT(NOALLOC)]
AND NOT .ID[IDATTRIBUT(DUMMY)]
THEN RETURN FATLEX(.ID[IDSYMBOL],E136<0,0>)
END;
%ENTRYDEF% BEGIN
IF .ID[OPRSP1] EQL FNNAME1 AND NOT .ID[IDATTRIBUT(NOALLOC)] THEN FNN
END;
%EXTDEF% BEGIN
IF .ID[OPRSP1] EQL ARRAYNM1 THEN AY
END;
%CMNBLK% BEGIN
IF .ID[OPRSP1] EQL FNNAME1 AND NOT .ID[IDATTRIBUT(NOALLOC)] THEN FNN
END;
%PARADEF% BEGIN
IF NOT .ID[IDATTRIBUT(NOALLOC)] THEN IDENPLIT
%**;[235], ROUTINE NAMDEF , REPLACE @ LINE 3621 , DT/MD ,11/18/74 %
%[235]% END;
%[235]% %NMLSTITM% BEGIN
%[235]% IF .ID[OPRSP1] EQL FNNAME1 THEN FNN
%[235]% END
TES;
IF .VREG NEQ 0
THEN RETURN FATLEX ( .VREG, ID[IDSYMBOL], E34 );
END; %NAMDEF%
GLOBAL ROUTINE
NAMSET ( TYPE , ID ) =
BEGIN % THE SYMBOL POINTED TO BY ID AND DEFINED BY TYPE IS
BEING SET %
EXTERNAL CREFIT;
MAP BASE ID;
EXTERNAL CKDOINDEX,STMNDESC;
%CHECK FOR DO INDEX MODIFICATION%
IF CKDOINDEX ( .ID )
THEN IF .LABOK(@STMNDESC) EQL 0 !FORGET DATA AND EQUIV
THEN FATLEX(E77<0,0>); !MODIFICATION WARNING
ID[IDATTRIBUT(STORD)] _ 1;
IF .FLGREG<CROSSREF> THEN CREFIT( .ID, SETT );
RETURN NAMCHK ( .TYPE , .ID )
END; %NAMSET%
GLOBAL ROUTINE
NAMREF ( TYPE , ID ) =
BEGIN % THE SYMBOL POINTED TO BY ID AND DEFINED BY TYPE IS BEING
REFERENCED %
EXTERNAL CREFIT;
IF .FLGREG<CROSSREF> THEN CREFIT( .ID, USE );
RETURN NAMCHK ( .TYPE, .ID )
END; %NAMREF%
GLOBAL ROUTINE
NAMCHK ( TYPE, ID ) =
BEGIN % CHECK TO SEE IF WE HAVE WHAT WE THINK WE HAVE AND IF NOT
OUTPUT AN ERROR MESSAGE %
% THE FOLLOWING BINDS ARE USED TO MAKE THE SYMBOL TABLE ATTRIBUTE
FIELD MASKS %
BIND
NAMLST = 1^35,
CMNBLK = 1^34,
STFN = 1^33,
ENTPNT = 1^28,
EXTERN = 1^23,
EXTRSGN = 1^18,
TYPED = 1^19,
EXTBTH = 1^18 + 1^23,
EQVIN = 1^27,
COMIN = 1^26,
DATAIN = 1^24,
DUMIEE = 1^22;
BIND DUMO = PLIT (
VAORAY NAMES 'A VARIABLE OR ARRAY?0',
VARIB NAMES 'A SCALAR VARIABLE?0',
AAY NAMES 'AN ARRAY?0',
AFN NAMES 'A SUBPROGRAM NAME?0' );
MAP BASE ID;
VREG _ 0;
VREG _ CASE .TYPE OF SET
%VARYREF% BEGIN
IF .ID[OPRSP1] EQL FNNAME1
OR .ID[IDATTRIBUT(NAMNAM)]
THEN VAORAY
END;
%VARIABL1% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1
OR .ID[IDATTRIBUT(NAMNAM)]
THEN VARIB
END;
%ARRAYNM1% BEGIN
IF .ID[OPRSP1] NEQ ARRAYNM1
THEN AAY
END;
%FNNAME1% BEGIN
IF .ID[OPRSP1] EQL FNNAME1
THEN
BEGIN
%CHECK TO SEE THAT POSSIBLE LIBRARY FUNCTIONS
WHICH TURNED OUT NOT TO BE LIBRARY FUNCTIONS
ARE NOT CONFLICTING WITH ANY GLOBAL NAMES %
IF ( VREG _ .ID[IDATTRIBUT(ALLOFTHEM)] AND
( CMNBLK^(-18) + ENTPNT^(-18)) ) NEQ 0
THEN IF .ID[IDATTRIBUT(COMBL)]
THEN FATLEX( R34, ID[IDSYMBOL], E34<0,0> )
ELSE FATLEX(R28,ID[IDSYMBOL],E34<0,0>);
0
END
ELSE
BEGIN
IF .ID[OPRSP1] EQL ARRAYNM1 OR NOT .ID[IDATTRIBUT(NOALLOC)] OR ISDEFIND(ID)
OR .ID[IDATTRIBUT(COMBL)]
THEN AFN !ITS A VARIABLE OR ARRAY
ELSE
BEGIN
ID[OPERSP] _ IF .ID[IDATTRIBUT(DUMMY)]
THEN FORMLFN ELSE FNNAME;
0
END
END
END;
%NMLSTREF% BEGIN
%NO CONFLICTS HERE%
0
END;
%PARAREF% BEGIN
RETURN .ID[IDPARAVAL]
END
TES;
IF .VREG NEQ 0
THEN RETURN FATLEX (.VREG, ID[IDSYMBOL],E15<0,0> );
% INDICATE THAT WE ARE USING THIS NAME %
ID[IDATTRIBUT(NOALLOC)] _ 0;
END; %ROUTINE NAMCHK %
GLOBAL ROUTINE FUNCGEN (FPNT)=
BEGIN
LOCAL BASE R1;
REGISTER BASE T2; MAP BASE FPNT;REGISTER BASE T1:R2;
EXTERNAL MULENTRY; !POINTER TO FIRST ENTRY POINT NAME
EXTERNAL SAVSPACE %(SIZE,LOC)%,TYPE,IDTYPE,PROGNAME,CORMAN %()%,
NEWENTRY %()%,STK,NAME;
MACRO
FCTN = 4$, ENT=1$,
ERR40=RETURN FATLEX(R1[IDSYMBOL], E40<0,0>)$;
!------------------------------------------------------------------------
!THIS ROUTINE IS CALLED WITH THE PARAMETER FPNT POINTING TO
!THE LIST:
!
!IDENTIFIER (20^18+LOC) - SUBPROGRAM NAME
!OPTION 0 - NO ARGUMENTS, ILLEGAL IF THIS IS A FUNCTION
! OR
!OPTION 1 - ARGUMENT LIST POINTER FOLLOWS
! COUNT^18+LOC - POINTS TO LIST POINTER
! 1^18+LOC - POINTS TO LIST OF
! CHOICE 1 - DUMMY ARGUMENT
! IDENTIFIER (20^18+LOC)
! CHOICE 2 - DUMMY LABEL
!
!THE LOCATION TYPE IS NON-ZERO (4) FOR A FUNCTION STATEMENT
!AND ZERO FOR A SUBROUTINE OR ENTRY STATEMENT. AN ARGUMENT
!LIST MUST BE PRESENT IF TYPE IS NON-ZERO. IF THE FUNCTION
!WAS TYPED, IDTYPE WILL CONTAIN THE TYPE OTHERWISE IT CONTAINS -1
!------------------------------------------------------------------------
R1_.FPNT[ELMNT];!R1_LOC (SUBPROGRAM NAME)
IF NAMDEF( ENTRYDEF, .R1) LSS 0 THEN RETURN .VREG;
IF .FPNT[ELMNT1]EQL 0 THEN ! NO ARGUMENTS
BEGIN
IF .FLGREG<PROGTYP> EQL FNPROG THEN WARNLEX ( E28<0,0> ); !FUNCTION SUBPROGRAM
R2_0
END
ELSE
BEGIN
!--------------------------------------------------------------------
!CREATE AN ARGUMENT LIST ON THE UNUSED PORTION OF THE
!LEXEME STACK (STK[2] THRU STK[100]). THIS IS NECESSARY
!BECAUSE THE EXACT NUMBER OF ARGUMENTS IS NOT KNOWN.
!THE ARGUMENT LIST PRODUCED BY SYNTAX CONTAINS 2 WORDS
!(CHOICE 1) FOR EACH DUMMY ARGUMENT BUT ONLY 1 WORD
!FOR ACH DUMMY LABEL (CHOICE 2). THE PROPORTION OF
!EACH ARGUMENT TYPE IS NOT KNOWN UNTIL THE LIST IS SCANNED.
!--------------------------------------------------------------------
T2_.FPNT[ELMNT2];T1_.T2[ELMNT];SAVSPACE(0,@T2);
T2_STK[3]<0,0>;!T1_LOC(GENERATED ARG LIST),SET COUNT T2 TO LOC OF ARGLIST
INCR ALST FROM @T1 TO @T1+.T1<LEFT>DO
BEGIN
MAP BASE ALST;
T2_.T2+1;
IF .ALST[ELMNT] EQL 1 THEN !DUMMY ARGUMENT
BEGIN
T2[ELMNT]_R2<RIGHT>_.ALST[ELMNT1];
IF NAMDEF(IDDEFINE, .R2 ) LSS 0 THEN RETURN .VREG;
IF .R2[OPRCLS] EQL DATAOPR THEN T2[P1AVALFLG] _ 1;
!**;[415] Change in routine FUNCGEN @ 3859 JNG 3-Aug-76
%[415]% IF .R2[IDDIM] EQL 0 THEN
!**;[567], FUNCGEN @3885, DCE, 5-MAY-77
!**;[567], ADD ONE MORE TEST SO THAT EXTERNAL DECLARATION WILL CARRY OVER
!**;[567], TO ALL ENTRY POINT PARAMETERS
%[567]% (IF .R2[OPERSP] NEQ FORMLFN
%[567]% AND .R2[OPERSP] NEQ FNNAME THEN
%[415]% R2[OPERSP]_FORMLVAR)
%[415]% !IF NOT DIMENSIONED THEN VARIABLE
%[415]% !UNLESS WE KNOW BETTER (ALREADY SAW
%[415]% !IT AS A FORMAL THAT HAS BEEN USED)
%[415]% ELSE
BEGIN
LOCAL BASE DIMPTR;
R2[OPERSP] _ FORMLARRAY;
DIMPTR _ .R2[IDDIM];
IF .DIMPTR[ARADDRVAR] EQL 0
THEN IF NOT .DIMPTR[ADJDIMFLG]
THEN BEGIN
LOCAL BASE PTRVAR;
ENTRY[0] _ .R2[IDSYMBOL];
NAME _ IDTAB;
PTRVAR _ NEWENTRY();
PTRVAR[VALTYPE] _ INTEGER;
PTRVAR[OPERSP] _ FORMLVAR;
PTRVAR[IDATTRIBUT(NOALLOC)] _ 0; !LET THIS BE ALLOCATED
DIMPTR[ARADDRVAR] _ .PTRVAR;
END;
END;
R2[IDATTRIBUT(DUMMY)]_-1; !DUMMY ARGUMENT
IF .FLGREG<PROGTYP> EQL FNPROG THEN IF .R2<RIGHT> EQL .R1<RIGHT>
THEN ! ARGUMENT IS SAME AS FUNCTION
FATLEX( R2[IDSYMBOL], E71<0,0>);
END
ELSE( EXTERNAL E129;
FLGREG<LABLDUM> _ 1; !SET DUMMY LABLES FLAG
IF .FLGREG<PROGTYP> EQL FNPROG
THEN WARNLEX (E129<0,0>);
!ISSUE WARNING BECAUSE FUNCTIONS WITH
! MULTIPLE RETURNS CANNOT BE REFERENCED
! AS FUNCTIONS
T2[ELMNT]_0 !DUMMY LABEL
);
IF .ALST[ELMNT] LEQ 2 THEN ALST_.ALST+1; !IF ARG IS NOT A $ THE SKIP BY 1
END;SAVSPACE(.T1<LEFT>,@T1);
!------------------------------------------------------------------------
!THE FOLLOWING CODE SETS UP T1 AS THE BLT POINTER
!(SOURCE ADDRESS ^18+ DESTINATION ADDRESS AND T2 AS THE FINAL
!ADDRESS. R2 POINTS TO THE BEGINNING OF THE ARG BLOCK CREATED.
!ITS FIRST WORD CONTAINS THE ARG COUNT.
!------------------------------------------------------------------------
STK[2]_0; !LINK WORD
T2_.T2-STK[3]<0,0>; !NUMBER OF ARGUMENTS
% CHECK FOR DUPLICATE ARGUMENTS %
INCR PRM FROM STK[4]<0,0> TO STK[4]<0,0>+.T2-2
DO
BEGIN
MAP BASE PRM;
LOCAL BASE PLST:ID1:ID2;
IF ( ID1 _ @@PRM ) NEQ 0 !IE AN IDENTIFIER
THEN
BEGIN
PLST _ .PRM+1;
DO
BEGIN
IF ( ID2 _ @@PLST ) NEQ 0 !IDENTIFIER
THEN
BEGIN
IF .ID1[IDSYMBOL] EQL .ID2[IDSYMBOL]
THEN RETURN FATLEX(.ID1[IDSYMBOL],E87<0,0>)
END
END
UNTIL (PLST _ .PLST+1) EQL STK[3]<0,0>+.T2+1;
END;
END;
STK[3] _ .T2;
NAME<LEFT> _ T2_ .T2+2; !ARG BLOCK CONTAINS 2+ NUM OF ARGS
T2_.T2-1+(T1<RIGHT>_R2_CORMAN());
T1<LEFT>_STK[2]<0,0>; BLT(T1,0,T2);!COPY ARG LIST FROM STACK
END;
NAME_IDOFSTATEMENT_ENTRDATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
IF @IDTYPE GEQ 0 THEN( R1[IDATTRIBUT(INTYPE)] _ -1; R1[VALTYPE]_@IDTYPE);
IF .TYPE EQL ENT THEN
BEGIN
T1[ENTNUM] _ -1;
%LINK UP THE ENTRY POINTS FOR REL OUTPUT%
R1[IDENTLNK] _ .MULENTRY;
MULENTRY _ .R1;
END;
R1[IDATTRIBUT(FENTRYNAME)] _ 1; !SET ENTRY NAME BIT
T1[ENTSYM]_@R1;T1[ENTLIST]_@R2;
SAVSPACE(.FPNT<LEFT>,@FPNT);
END;
GLOBAL ROUTINE TYPEGEN(TLST) =
BEGIN
LOCAL BASE T1;
REGISTER BASE T2; REGISTER BASE R1:R2;
EXTERNAL SAVSPACE %(SIZE,LOC)%,STK,BLDARRAY %(ONEARRAY LIST POINTER)%;
!-----------------------------------------------------------------------
! THIS ROUTINE IS CALLED WITH THE PARAMETER TLST
! POINTING TO A LIST OF ELEMTNTS. EACH
! ELEMENT POINTS TO A LIST OF SCALAR OR ARRAY DEFINITIONS
! (ONEARRAY) FOLLOWED BY AN OPTIONAL LIST OF VALUES. UNTIL
! THE ROUTINES TO HANDLE DATA SPECIFICATIONS HAVE BEEN
! WRITTEN THESE VALUE LISTS WILL BE IGNORED.
!-----------------------------------------------------------------------
INCR DLST FROM @TLST TO @TLST+.TLST<LEFT> DO
BEGIN
MAP BASE DLST;
R1_.DLST[ELMNT];
!IF A VALUELIST IS PRESENT THEN BLDARRAY
!MUST SAVE ALL THE SCALAR AND ARRAY NAMES IT FINDS, PROBABLY ON THE STACK
IF BLDARRAY(.R1[ELMNT]) LSS 0 THEN RETURN .VREG;
IF.R1[ELMNT1] NEQ 0 THEN !OPTIONAL VALUELIST IS PRESENT
BEGIN
FATLEX(E84<0,0>); !OPTIONAL VALUE LIST NOT SUPPORTED
T1_.R1[ELMNT2]; !T1_LOC(VALUELIST)
! T2_.T1[ELMNT1]; !T2_LOC(LIST OF CONSTANTS)
! INCR CLST FROM @T2 TO @T2+.T2<LEFT> BY 2 DO
! BEGIN
! MAP BASE CLST;
! IF .CLST[ELMNT] EQL 1 THEN !CONSTANT POSSIBLY A REPEAT COUNT
! BEGIN
! R1_.CLST[ELMNT1];
! IF .R1[ELMNT1] NEQ 0 THEN
! BEGIN !SAVE REPEATED CONSTANT SPACE
! R2_.R1[ELMNT2];SAVSPACE(.R2<LEFT>,@R2)
! END;
! SAVSPACE(.R1<LEFT>,@R1); !SAVE CONSTANT SPACE
! END;
! END; SAVSPACE(.T2<LEFT>,@T2); !SAVE CONSTANT LIST SPACE
SAVSPACE(.T1<LEFT>,.T1); !SAVE VALUE LIST SPACE
END
END;
END;
GLOBAL ROUTINE TMPGEN (TYPE) =
BEGIN
EXTERNAL TMPCNT[4],TBLSEARCH %()%;
BIND TMPNAM=PLIT(
%0% SIXBIT 'TM.000',
%1% SIXBIT 'MF.000',
%2% SIXBIT 'OF.000',
%3% SIXBIT 'SZ.000');
REGISTER BASE R3,R2,R1;MACHOP IDIVI=#231,LSHC=#246;
R1_.TMPCNT[.TYPE]_.TMPCNT[.TYPE]+1;
DECR I FROM 2 TO 0 DO (IDIVI(R1,10);LSHC(R2,-6));
ENTRY[0]_.TMPNAM[.TYPE]+.R3<LEFT>;
NAME_IDTAB;R3_TBLSEARCH();
IF .TYPE EQL 0 THEN R3[OPR1]_VARFL;
RETURN .R3
END;
GLOBAL ROUTINE BLDDIM (SSLST) =
BEGIN
REGISTER BASE R1:R2:T1;
LOCAL HISIGN,LOSIGN;
EXTERNAL NEWENTRY %()%,SAVSPACE %(SIZE,LOC)%,IDTYPE,STK,CORMAN %()%,TBLSEARCH %()%,ONEPLIT,FARRY;
EXTERNAL GENLAB; !ROUTINE TO ADD A LABEL TABLE ENTRY FOR A COMPILER GENERATED LABEL
REGISTER T2=2; MAP BASE T2;
MAP BASE FARRY;
EXTERNAL E125,E126;
!**[410] BLDDIM @4029 SJW 1-JUL-76
%[410]% EXTERNAL DTABPTR; ! HEAD OF DIM ENTRY LIST
%[V5]% LABEL LDECR, CHECKTHIS;
MACRO ERR46 = FATLEX(.FARRY[IDSYMBOL], E125<0,0>)$;
MACHOP BLT=#251;
!----------------------------------------------------------------------------------------------------------
!SSLST POINTS TO A LIST OF SUBSCRIPTS OF THE FORM:
!
!CHOICE 1 - SUBSCRIPT IS A CONSTANT
! CONSTANT (21^18+LOC)
!CHOICE 2 - SUBSCRIPT IS AN IDENTIFIER
! IDENTIFIER (20^18+LOC)
!OPTION 0 - SUBSCRIPT IS UPPER BOUND, LOWER BOUND IS ONE
!OPTION 1 - SUBSCRIPT IS LOWER BOUND
! COUNT^18+LOC - POINTER TO UPPER BOUND
! DIVIDE
! CHOICE 1 - SUBSCRIPT IS A CONSTANT
! CONSTANT (21^18+LOC)
! CHOICE 2 - SUBSCRIPT IS AN IDENTIFIER
! IDENTIFIER (20^18+LOC)
!
!SINCE THE KNOWLEDGE OF WETHER OR NOT THE DIMENSIONS ARE ADJUSTABLE OR IN ERROR IS NOT KNOWN UNTIL THE
!LIST HAS BEEN SCANNED, A PSEUDO DIMENSION NODE IS CREATED ON THE UNUSED PORTION OF THE STACK
! (STK[2] - STK[100]).
!----------------------------------------------------------------------------------------------------------
BIND ADJUSTABLE=STK[2],DNUM=STK[3]<LEFT>,ASIZE=STK[3]<RIGHT>,AOFF=STK[4],MF=1,OS=2,SZ=3;
%[V5]% BIND DLBL = STK [5] <LEFT>, ! TEMP ARADLBL
%[V5]% ALINK = STK [5] <RIGHT>, ! TEMP ARALINK
%[V5]% A0F = STK [7] <RIGHT>; ! TEMP DFACTOR (0)
!**[571] BLDDIM @4076 SJW 11-MAY-77
![571] REMOVE DEFINITION OF ARALINK; IT IS NOW IN TABLES.BLI
!----------------------------------------------------------------------------------------------------------
!OMITTING THE EXTRA CODE TO FETCH CONSTANTS AND STORE VALUES, THE ARRAY SIZE, ARRAY OFFSET, AND
!SUBSCRIPT MULTIPLICATION FACTOR ARE CALCULATED IN THE FOLLOWING MANNER:
!
!IF .IDTYPE GEQ DOUBLPREC THEN WORDSIZE_2 ELSE WORDSIZE_1;
!ARRAYSIZE_.WORDSIZE;ARRAYOFFSET_0;
!INCR I FROM 1 TO NUMBEROF DIMENSIONS DO
!BEGIN
! FACTOR(.I)_.ARRAYSIZE;
! ARRAYOFFSET_.ARRAYOFFSET+.FACTOR(.I)*.LOWERLIMIT(.I);
! SUBSCRIPTSIZE_.UPPERLIMIT(.I)-.LOWERLIMIT(.I)+1;
! ARRAYSIZE_.ARRAYSIZE*.SUBSCRIPTSIZE;
!END;
!
!FOR EXAMPLE:
!
!DOUBLE PRECISION A(2/5,3/5,4/5)
!
!WOULD PRODUCE
!
!FACTOR= 2 8 24
!ARRAYOFFSET= 4 28 124
!SUBSCRIPTSIZE= 4 3 2
!ARRAYSIZE= 8 24 48
!
!THUS USING BLISS NOTATION, THE SECOND ELEMENT OF A, A(3,3,4) IS
!.(A+2*3+8*3+24*4-124) WHICH EQUALS .(A+2) . THE ARRAY SIZE SPECIFIES THE
!NUMBER OF WORDS OCCUPIED BY THE ARRAY, THUS IN THE ABOVE EXAMPLE ARRAY A OCCUPIES LOCATIONS A THRU A+47.
!----------------------------------------------------------------------------------------------------------
EXTERNAL INITLTEMP;
ROUTINE ERRA =
BEGIN
RETURN FATLEX(FARRY[IDSYMBOL], E31<0,0>)
END;
ROUTINE ERRB (X)=
BEGIN
MAP BASE X;
RETURN FATLEX(.X[IDSYMBOL],E126<0,0>)
END;
ROUTINE AJDIMSTK( PTR ) =
BEGIN
%SAVE THIS VARIABLE NAME ON A STACK BECAUSE IT IS
CURRENTLY NOT IN COMMON OR A DUMMY BUT IT
MIGHT BE AFTER SOME ENTRY
STATEMENTS %
EXTERNAL DIMSTK,NAME,CORMAN,LEXLINE;
REGISTER R1;
NAME<LEFT> _ 2; !2 WORD ENTRIES
R1 _ CORMAN();
IF .DIMSTK EQL 0
THEN
BEGIN
DIMSTK<LEFT> _ .R1
END;
(.R1)<RIGHT> _ .DIMSTK<RIGHT>;
DIMSTK<RIGHT> _ .R1;
(.R1+1)<RIGHT> _ .PTR;
(.R1+1)<LEFT>_ .LEXLINE
END;
T2_STK[3]<0,0>;
IF .IDTYPE GEQ DOUBLPREC THEN ASIZE_2 ELSE ASIZE_1;
ADJUSTABLE_AOFF_DNUM_0;
INCR SS FROM @SSLST TO @SSLST+.SSLST<LEFT> DO
BEGIN
MAP BASE SS;
HISIGN_LOSIGN_0;
T2[DVARFLGS(0)]_0;T1_.SS[ELMNT];
IF .T1[ELMNT] NEQ 0
THEN(IF .T1[ELMNT] EQL 2 THEN HISIGN_-1;
T1_.T1+2;
)
ELSE T1_.T1+1;
R1_.T1[ELMNT1];
IF .R1[VALTYPE] NEQ INTEGER THEN RETURN ERRA();
CASE .T1[ELMNT2] OF SET
BEGIN !OPTION 0 - LOWER LIMIT IS 1 BY DEFAULT
T2[DIMENL(0)]_.ONEPLIT;
IF .T1[ELMNT] EQL 1 THEN
BEGIN !CHOICE 1 - R1 = CONSTANT POINTER
%DO THIS BUSINESS IN CASE OF NEGITIVE PARAMETER VALUES%
IF .HISIGN NEQ 0
THEN R1 _ MAKECNST(INTEGER,0,-.R1[CONST2]); !MAKE NEG CONST NODE
IF .R1[CONST2] LSS 0 THEN ERR46;!NO NEGATIVE DIMENSION
!**;[460], ACT1 @4125, DCE, 24-SEP-76
!**;[460], THE FOLLOWING PATCHES TO BLDDIM CURE A WHOLE
!**;[460], HOST OF PROBLEMS CONCERNING ERROR DETECTION
!**;[460], AND RECOVERY DURING DIMENSION PROCESSING, ESPECIALLY
!**;[460], REGARDING ARRAYS WHICH ARE TOO LARGE TO HANDLE.
%[460]% IF .R1[CONST2] EQL 0
%[460]% THEN FATLEX(FARRY[IDSYMBOL],E74<0,0>);
!**;[460], DO NOT TEST FOR TOO LARGE A SUBSCRIPT HERE -
!**;[460], WILL CATCH THIS LATER ON
T2[DIMENU(0)]_.R1;
END
ELSE
BEGIN !CHOICE 2 - R1 = IDENTIFIER POINTER
LOCAL SAV;
IF .HISIGN NEQ 0 THEN ERR46;
SAV _ .R1[IDATTRIBUT(NOALLOC)]; !SAVE IN CASE ITS NOT DUMMY YET
IF NAMREF(VARIABL1,.R1) LSS 0 THEN RETURN .VREG;
%**;[230],ROUTINE BLDDIM, REPLACE @ 4111,MD,11/17/74 %
%[230]% IF .R1[OPERSP] NEQ FORMLVAR AND NOT .R1[IDATTRIBUT(INCOM)] THEN
%[230]% (
%[230]% AJDIMSTK(.R1); ! CREATE AN ENTRY
%[230]% R1[IDATTRIBUT(NOALLOC)] _ .SAV; !RESTORE
%[230]% );
T2[DVARUBFLG(0)]_1;T2[DIMENU(0)]_@R1;ADJUSTABLE_-1;
END;
IF .ADJUSTABLE EQL 0 THEN
BEGIN
!**;[460], BLDDIM @4145, DCE, 24-SEP-76
!**;[460], NEW VARIABLES TO TEST AND REPORT ARRAY SIZE PROBLEM
%[460]% LOCAL SAV; ! NEED FULL WORD TO TEST OVERFLOW
!**;[460], ERROR 141 GIVES ARRAY NAME TOO LARGE
%[460]% EXTERNAL E141; ! NEW ERROR MESSAGE
NAME_CONTAB;ENTRY[0]_0;ENTRY[1]_.ASIZE;SYMTYPE_INTEGER;
T2[DFACTOR(0)]_TBLSEARCH();
!**;[460], BLDDIM @4148, DCE, 24-SEP-76
!**;[460], AS THE COMPLETE ARRAY SIZE IS COMPUTED, DO NOT LET
!**;[460], IT GET TOO LARGE WITHOUT REPORTING THE ERROR
%[460]% AOFF_.AOFF-.ASIZE;
%[460]% SAV_.ASIZE*.R1[CONST2]; !FULL WORD SIZE
%[460]% IF .SAV GEQ 1^18 THEN FATLEX(.FARRY[IDSYMBOL],E141<0,0>);
!**;[460], NOW IT IS SAFE TO PUT THIS INTO A HALF WORD WHETHER
!**;[460], OR NOT THERE IS A TRUNCATION!
%[460]% ASIZE_.SAV;
END
ELSE
BEGIN
T2[DVARFACTFLG(0)]_1;T2[DFACTOR(0)]_0;
END;
END;
BEGIN !OPTION 1 - BOTH LOWER AND UPPER LIMITS ARE SPECIFIED
LOCAL SAVPTR; !FOR SAVING PTR FOR CALL TO SAVSPACE
IF .T1[ELMNT] EQL 2 THEN
BEGIN !CHOICE 2 - R1=IDENTIFIER POINTER
LOCAL SAV;
IF .HISIGN NEQ 0 THEN ERR46;
SAV _ .R1[IDATTRIBUT(NOALLOC)]; !SAVE IN CASE ITS NOT DUMMY YET
IF NAMREF(VARIABL1,.R1) LSS 0 THEN RETURN .VREG;
%**;[230],ROUTINE BLDDIM, DELETE @ 4134 , MD ,11/17/74 %
%**;[230],ROUTINE BLDDIM, REPLACE @ 4135,MD,11/17/74 %
%[230]% IF .R1[OPERSP] NEQ FORMLVAR AND NOT .R1[IDATTRIBUT(INCOM)] THEN
%[230]% (
%[230]% AJDIMSTK(.R1); ! CREATE AN ENTRY
%[230]% R1[IDATTRIBUT(NOALLOC)] _ .SAV; !RESTORE
%[230]% );
T2[DVARLBFLG(0)]_1;ADJUSTABLE_-1;
END;
T1_.T1[ELMNT3]; !GET PTR TO UPPER BOUND BLOCK
SAVPTR _ .T1; !SAVING PTR FOR SAVSPACE CALL LATER
IF .R1[OPERSP] EQL CONSTANT
THEN
!**;[460], BLDDIM @4217, DCE, 24-SEP-76
!**;[460], DO NOT NEED TO CHECK HERE FOR ARRAY BOUND SIZE
%[460]% IF .HISIGN NEQ 0
%[460]% THEN R1 _ MAKECNST(INTEGER,0,-.R1[CONST2]); !MAKE NEG CONST NODE
T2[DIMENL(0)] _ .R1; !LOWER BOUND
!T1 NOW POINTS TO UPPER BOUND PART
!SEE IF IT IS SIGNED
!
IF .T1[ELMNT2] NEQ 0 !ELMNT0-1 IS THE SLASH OR COLON
THEN(IF .T1[ELMNT2] EQL 2 THEN HISIGN _ -1 ELSE HISIGN _ 0;
T1 _ .T1+3;
)
ELSE (HISIGN_0; T1 _ .T1+2;);
R2_.T1[ELMNT2];
IF .R2[VALTYPE] NEQ INTEGER THEN RETURN ERRA();
IF .T1[ELMNT1] EQL 2 THEN
BEGIN !CHOICE 2 - R2 = IDENTIFIER POINTER
LOCAL SAV;
IF .HISIGN NEQ 0 THEN ERR46;
%**;[230],ROUTINE BLDDIM, REPLACE @ 4164,MD,11/17/74 %
%[230]% SAV _ .R2[IDATTRIBUT(NOALLOC)]; !SAVE IN CASE ITS NOT DUMMY YET
IF NAMREF(VARIABL1,.R2) THEN RETURN .VREG;
%**;[230],ROUTINE BLDDIM, DELETE @ 4166 , MD, 11/17/74 %
%**;[230],ROUTINE BLDDIM, REPLACE @ 4167,MD,11/17/74 %
%[230]% IF .R2[OPERSP] NEQ FORMLVAR AND NOT .R2[IDATTRIBUT(INCOM)] THEN
%[230]% (
%[230]% AJDIMSTK(.R2); ! CREATE AN ENTRY
%[230]% R2[IDATTRIBUT(NOALLOC)] _ .SAV; !RESTORE
%[230]% );
T2[DVARUBFLG(0)]_1;ADJUSTABLE_-1;
END;
IF .R2[OPERSP] EQL CONSTANT
THEN
!**;[460], BLDDIM @4253, DCE, 24-SEP-76
!**;[460], DO NOT TEST ON INDIVIDUAL ELEMENTS HERE!
%[460]% IF .HISIGN NEQ 0
%[460]% THEN R2 _ MAKECNST(INTEGER,0,-.R2[CONST2]);
T2[DIMENU(0)]_.R2;
IF .ADJUSTABLE EQL 0 THEN
BEGIN
!**;[460], BLDDIM @4263, DCE, 24-SEP-76
!**;[460], ALSO NEED TO CHECK THE CASE WITH UPPER AND
!**;[460], LOWER BOUNDS.
%[460]% LOCAL SAV;
%[460]% EXTERNAL E141; ! ARRAY TOO LARGE
IF .R1[CONST2] %LOWER BOUND%
GTR .R2[CONST2] %UPPER BOUND%
THEN FATLEX( FARRY[IDSYMBOL],E74<0,0>);
!ERROR IF LOWER GTR UPPER BOUND
NAME_CONTAB;ENTRY[0]_0;ENTRY[1]_.ASIZE;SYMTYPE_INTEGER;
T2[DFACTOR(0)]_TBLSEARCH();
AOFF_.AOFF-.ASIZE*.R1[CONST2];
!**;[460], BLDDIM @4271, DCE, 24-SEP-76
!**;[460], CHECK FOR TOTAL SPACE NEEDED FOR THIS ARRAY
%[460]% SAV_.ASIZE*(.R2[CONST2]-.R1[CONST2]+1);
%[460]% IF .SAV GEQ 1^18 THEN FATLEX(.FARRY[IDSYMBOL],E141<0,0>);
%[460]% ASIZE_.SAV; !SAFE NOW TO SET UP ASIZE
END
ELSE
BEGIN
T2[DVARFACTFLG(0)]_1;T2[DFACTOR(0)]_0;
END;
SAVSPACE(.SAVPTR<LEFT>,.SAVPTR);
END
TES;
T1_.SS[ELMNT]; !FOR SAVSPACE CALL
SAVSPACE(.T1<LEFT>,.T1);DNUM_.DNUM+1;T2_.T2+2;
END;
!----------------------------------------------------------------------------------------------------------
!STK[2] THRU STK[(.DNUM+1)*2] NOW CONTAINS A DIMENSION NODE. USE THE CORMAN ROUTINE TO CREATE
!A REAL DIMENSION NODE AND COPY THE NODE FROM THE STACK.
!----------------------------------------------------------------------------------------------------------
IF .ADJUSTABLE NEQ 0 THEN
BEGIN
!--------------------------------------------------------------------------------------------------
!IF THE DIMENSIONS ARE ADJUSTABLE CREATE A SPECIAL SET OF TEMPS TO BE USED BY ADJ. TO
!CALCULATE THE MULTIPLICATIVE FACTORS. ALSO SET ADJDIMFLG
!--------------------------------------------------------------------------------------------------
!FOR ADJ. THEY MUST BE IN A SPECIAL ORDER
!ASIZE
!OFFSET
!FACTOR N-1
! .
! .
! .
!FACTOR 1
EXTERNAL FATLEX,E137;
!**[571] BLDDIM @4326 SJW 11-MAY-77
%[571]% LOCAL BASE PTR;
%[V5]% LOCAL DIMENTRY E;
%CHECK TO SEE IF ADJUSTABLES ARE LEGAL %
IF .FLGREG<PROGTYP> NEQ SUPROG
AND .FLGREG<PROGTYP> NEQ FNPROG
THEN RETURN FATLEX(E137<0,0>);
!CHECK FOR ADJUSTABLE ARRAY NOT A DUMMY
IF NOT .FARRY[IDATTRIBUT(DUMMY)] THEN AJDIMSTK(.FARRY);
ASIZE_INITLTEMP(INTEGER);
AOFF<LEFT>_INITLTEMP(INTEGER);
%[V5]% A0F_ IF .FARRY [DBLFLG] ! SET ELEMENT SIZE
%[V5]% THEN MAKECNST (INTEGER, 0, 2)
%[V5]% ELSE .ONEPLIT;
%[V5]% DECR I FROM .DNUM - 1 TO 1 DO
LDECR: BEGIN %[V5]%
%[V5]% T2 _ .T2 - 2; ! DIMSUBENTRY (I)
%[V5]% IF .T2 [DFACTOR (0)] NEQ 0
%[V5]% THEN LEAVE LDECR;
%[V5]% IF NOT .T2 [DVARUBFLG (0)] OR
%[414]% .T2 [DIMENL (0)] NEQ .ONEPLIT OR
%[414]% .I NEQ 1
%[V5]% THEN BEGIN
%[V5]% T2 [DFACTOR (0)] _ INITLTEMP (INTEGER);
%[V5]% LEAVE LDECR;
%[V5]% END;
%[414]%! I == 1 => T2 [...(0)] IS FOR 2ND DIM
%[V5]% PTR _ .DTABPTR <RIGHT>;
%[V5]% WHILE .PTR NEQ 0
%[V5]% DO BEGIN
%[V5]% E _ .PTR;
CHECKTHIS: BEGIN %[V5]%
!**[423] BLDDIM @4328 SJW 13-AUG-76 DIMNUM IS 1 RELATIVE NOT 0
%[423]% IF .E [DIMNUM] LSS 2
%[V5]% THEN LEAVE CHECKTHIS;
%[V5]% IF NOT .E [ADJDIMFLG]
%[V5]% THEN LEAVE CHECKTHIS;
%[V5]% IF .E [DFACTOR (0)] NEQ .A0F ! SAME ELEMENT SIZE
%[V5]% THEN LEAVE CHECKTHIS;
%[414]%! IF DIM1 SAME THEN SHARE FACTOR FOR DIM2
%[414]% IF .E [DIMENU (0)] EQL .T2 [DIMENU (-1)] AND
%[414]% .E [DIMENL (0)] EQL .ONEPLIT
%[V5]% THEN BEGIN
!**[571] BLDDIM @4371 SJW 11-MAY-77
%[571]% PTR _ .E [DFACTOR (1)];
%[571]% T2 [DFACTOR (0)] _ .PTR;
%[571]% PTR [IDUSECNT] _ .PTR [IDUSECNT] + 1; ! UPDATE SHARING COUNT
%[V5]% LEAVE LDECR;
%[V5]% END;
%[V5]% END; ! OF CHECKTHIS
%[V5]% PTR _ .E [ARALINK]; ! NEXT ENTRY
%[V5]% END; ! OF WHILE .PTR NEQ 0
!**[571] BLDDIM @4377 SJW 11-MAY-77
%[571]% PTR _ INITLTEMP (INTEGER); ! NO MATCH FOUND
%[571]% T2 [DFACTOR (0)] _ .PTR;
%[571]% PTR [IDUSECNT] _ 1; ! 1ST USAGE: NO SHARING
%[V5]% END; ! OF LDECR
%[V5]% T2 _ .T2 - 2; ! SUBENTRY (0)
%[V5]% T2 [DVARFACTFLG (0)] _ 0;
%[V5]% T2 [ADJDIMFLG] _ 1;
%[V5]%
END
ELSE AOFF<LEFT> _ MAKECNST(INTEGER,0,.AOFF); !MAKE CONST NODE FOR OFFSET VALUE
SAVSPACE(.SSLST<LEFT>,@SSLST);
!
!NOW MAKE A REAL DIMENSION NODE TRANSFERING THE INFORMATION ON THE
!TEMPORARY STACK (STK) TO THE DIMENSION NODE OF SIZE (.DNUM+1)*2
!
NAME<LEFT>_T2_DIMSIZ+.DNUM*DIMSUBSIZE;
T2 _ .T2-1; !ONE LESS FOR UPCOMING BLT
T2_.T2+(T1_(NAME<RIGHT>_DIMTAB; NEWENTRY()));
!ADD THE PTR TO THE NEW DIMENSION NODE TO T2 (THE NUMBER OF WORDS IN THE BLOCK MINUS 1)
%[V5]% DLBL _ 0; ! FOR SAFETY
%[V5]% ALINK _ .DTABPTR <RIGHT>; ! LINK THIS ENTRY INTO LIST
%[V5]% DTABPTR <RIGHT> _ .T1; ! NEW LIST HEAD
BEGIN LOCAL SAVT1;
T1<LEFT>_STK[3]<0,0>;
SAVT1 _.T1; !SAVING T1 INCASE OF BLT INTERRUPT
BLT(T1,0,T2); !MOVE THE BLOCK TO NEW LOCATION
T1 _ .SAVT1;
END;
IF .FARRY[OPERSP] EQL FORMLARRAY
THEN
( IF .ADJUSTABLE EQL 0
THEN BEGIN
!MAKE A POINTER VARIABLE TO BE A COPY OF ARRAY'S SYMBOL TABLE NODE
!AND PUT IT IN THE DIMENSON NODE
LOCAL BASE PTRVAR;
ENTRY[0] _ .FARRY[IDSYMBOL]; NAME _ IDTAB;
PTRVAR _ NEWENTRY();
PTRVAR[IDATTRIBUT(NOALLOC)] _ 0; !LET THIS BE ALLOCATED
PTRVAR[VALTYPE] _ INTEGER;
PTRVAR[OPERSP] _ FORMLVAR; !MAKE IT A FORMAL DUMMY
T1[ARADDRVAR] _ .PTRVAR; !PTR VARIABLE TO DIMENSION NODE
END;
) ELSE T1[ARADDRVAR] _ 0;
RETURN .T1 !PTR TO DIMENSION NODE
END;
GLOBAL ROUTINE BLDARRAY (LPNT) =
BEGIN
REGISTER T2=2; MAP BASE T2;
REGISTER BASE T1;REGISTER BASE R2; LOCAL BASE R1;
EXTERNAL GENLAB; !ROUTINE TO ADD A COMPILER GEBERATED LABEL
EXTERNAL SAVSPACE %(SIZE,LOC)%,IDTYPE,FARRY,TYPE,STK,NAMDEF;
MACRO ERR4=
BEGIN
RETURN FATLEX( T1[IDSYMBOL],PLIT'VARIABLE',E4<0,0> )
END$;
MACRO ERR41=
BEGIN
RETURN FATLEX (T1[IDSYMBOL],FARRY[IDSYMBOL],E41<0,0>)
END$;
MACRO
ERR42=RETURN FATLEX(T1[IDSYMBOL], E42<0,0>)$,
ERR34(X)= RETURN FATLEX ( PLIT'X?0', T1[IDSYMBOL], E34<0,0>)$;
BIND BASE CBLOCK=STK[2];
LOCAL POINTER;
!**[571] BLDARRAY @4441 SJW 11-MAY-77
%[571]% LABEL OUT, CHECKTHIS;
%[571]% EXTERNAL DTABPTR, ONEPLIT, INITLTEMP;
%[571]% LOCAL BASE PTR; ! TO MARCH DOWN DIM ENTRY LIST
%[571]% LOCAL DIMENTRY E; ! ONE ELEMENT ON THAT LIST
ROUTINE CHKCOMMON ( T1 ) = !CHECKS COMMON DECLARATIONS
BEGIN
MAP BASE T1;
BEGIN !COMMON STATEMENT
IF .T1[IDATTRIBUT(INCOM)] THEN ERR42
ELSE IF .T1[IDATTRIBUT(DUMMY)] THEN ERR34(DUMMY);
T1[IDATTRIBUT(INCOM)]_1;
IF .CBLOCK<LEFT> EQL 0 THEN
BEGIN
CBLOCK<LEFT>_CBLOCK<RIGHT>_@T1;
END
ELSE
BEGIN
CBLOCK[IDCOLINK]_@T1;CBLOCK<RIGHT>_@T1;
END;
END
END; !OF CHKCOMMON
!----------------------------------------------------------------------------------------------------------
!THE PARAMETER LPNT POINTS TO A LIST OF ONEARRAY'S, THAT IS TO SAY EACH ELEMENT OF THE LIST POINTED TO
!BY LPNT IS A POINTER TO A LIST OF THE FORM:
!
!IDENTIFIER (20^18+LOC) - FIRST ARRAY NAME
!OPTION 0 OR OPTION 1 - ADDITIONAL ARRAY NAMES AND SUBSCRIPTS FOLLOW
! COUNT^18+LOC - LIST POINTER
!VARIABLE TYPE - ONLY IF THIS IS A TYPE STATEMENT
!
!THE LOCATION IDTYPE CONTAINS THE VARIABLE TYPE TO BE SET IN EACH ARRAY NAME. IF IDTYPE IS LESS THAN ZERO,
!NO TYPE IS SPECIFIED AND AN OPTION 0 (NO SUBSCRIPTS) IS ILLEGAL. IDTYPE IS SET LESS THAN ZERO FOR
!DIMENSION, AND GLOBAL STATEMENTS.
!IDTYPE FOR TYPE STATEMENTS IS NOW IN THE TREE IN ORDER TO IMPLIMENT THE *N TYPE OVERRIDE FEATURE
!----------------------------------------------------------------------------------------------------------
INCR OA FROM .LPNT TO .LPNT+.LPNT<LEFT> DO
BEGIN
MAP BASE OA; !OA STANDS FOR ONEARRAY
R1_.OA[ELMNT];
FARRY_T1_.R1[ELMNT];
IF .TYPE EQL 4 %TYPE STATEMENT%
THEN
BEGIN
IDTYPE _ .R1[ELMNT1]; !GET TYPE FROM TREE - POSSIBLE *N CONSTRUCT
R1 _ .R1 + 1; !SKIP TYPE
END
ELSE
IDTYPE_.T1[VALTYPE];
IF .R1[ELMNT1] EQL 0 THEN
BEGIN !OPTION 0 - NO SUBSCRIPTS
CASE .TYPE OF SET
ERR4; !DIMENSION
BEGIN !GLOBAL
!IF .T1[IDATTRIBUT(INCOM)]THEN ERR34(COMMON)
! ELSE IF .T1[IDATTRIBUT(INEXTERN)]THEN ERR34(EXTERNAL);
!T1[IDATTRIBUT(INGLOB)]_1
END;
BEGIN !EXTERNAL
!GONE
END;
BEGIN !PROTECT
!GONE
END;
BEGIN !TYPE STATEMENT
LOCAL DUB; !SET TO 4 FOR CONVERSION TO
! DOUBLE PRECISION AND
!TO 1 FOR CONVERSION TO
!SINGLE PECISION
LABEL ADJ;
IF .T1[IDDIM] NEQ 0
THEN
ADJ:BEGIN
IF .IDTYPE GEQ DOUBLPREC
THEN
BEGIN
IF .T1[VALTYPE] LSS DOUBLPREC
THEN DUB _ 4
ELSE LEAVE ADJ
END
ELSE
BEGIN
IF .T1[VALTYPE] GEQ DOUBLPREC
THEN DUB _ 1 !CONVERT TO SINGLE PRECISION
ELSE LEAVE ADJ
END;
R2 _ .T1[IDDIM];
IF NOT .R2[ADJDIMFLG]
THEN
BEGIN
R2[ARASIZ] _ (.R2[ARASIZ]*.DUB ) / 2;
T2 _ .R2[ARAOFFSET];
R2[ARAOFFSET] _ MAKECNST(INTEGER,0,( .T2[CONST2] * .DUB ) / 2 );
DECR I FROM .R2[DIMNUM]-1 TO 0 DO
BEGIN
T2 _ .R2[DFACTOR(.I)];
R2[DFACTOR(.I)] _ MAKECNST(INTEGER,0, ( .T2[CONST2] * .DUB ) / 2 );
END
END
ELSE
BEGIN !DO ONLY FOR FIRST FACTOR IF ADJUSTABLE
!**[571] BLDARRAY @4539 SJW 11-MAY-77
T2 _ .R2[DFACTOR(0)];
R2[DFACTOR(0)] _ MAKECNST(INTEGER,0, ( .T2[CONST2] * .DUB ) / 2 );
%[571]% OUT: BEGIN
%[571]% IF .R2 [DIMNUM] LSS 2
%[571]% THEN LEAVE OUT;
%[571]% IF NOT .R2 [DVARUBFLG (1)]
%[571]% THEN LEAVE OUT;
%[571]% IF .R2 [DIMENL (1)] NEQ .ONEPLIT
%[571]% THEN LEAVE OUT;
%[571]% T2 _ .R2 [DFACTOR (1)];
%[571]% T2 [IDUSECNT] _ .T2 [IDUSECNT] - 1;
%[571]% IF .T2 [IDUSECNT] EQL 0
%[571]% THEN T2 [IDATTRIBUT (NOALLOC)] _ 1; ! NOT SHARED NOW: DON'T ALLOC
%[571]% PTR _ .DTABPTR<RIGHT>;
%[571]% WHILE .PTR NEQ 0
%[571]% DO BEGIN
%[571]% E _ .PTR;
%[571]% CHECKTHIS: BEGIN
%[571]% IF .E EQL .R2 ! DON'T SHARE WITH YOURSELF
%[571]% THEN LEAVE CHECKTHIS;
%[571]% IF .E [DIMNUM] LSS 2
%[571]% THEN LEAVE CHECKTHIS;
%[571]% IF NOT .E [ADJDIMFLG]
%[571]% THEN LEAVE CHECKTHIS;
%[571]% IF .E [DFACTOR (0)] NEQ .R2 [DFACTOR (0)] ! SAME ELEMENT SIZE ?
%[571]% THEN LEAVE CHECKTHIS;
%[571]% IF .E [DIMENU (0)] NEQ .R2 [DIMENU (0)]
%[571]% THEN LEAVE CHECKTHIS;
%[571]% IF .E [DIMENL (0)] NEQ .ONEPLIT
%[571]% THEN LEAVE CHECKTHIS;
%[571]% ! DIM 1 SAME: SHARE FACTOR FOR DIM2
%[571]% PTR _ .E [DFACTOR (1)];
%[571]% R2 [DFACTOR (1)] _ .PTR;
%[571]% PTR [IDUSECNT] _ .PTR [IDUSECNT] + 1; ! UPDATE SHARING COUNT
%[571]% LEAVE OUT;
%[571]% END; ! OF CHECKTHIS
%[571]% PTR _ .E [ARALINK]; ! NEXT ENTRY
%[571]% END; ! OF WHILE .PTR NEQ 0
%[571]% IF .T2 [IDUSECNT] EQL 0 ! NO MATCH FOUND
%[571]% THEN T2 [IDATTRIBUT (NOALLOC)] _ 0 ! USE OLD .I WHICH WAS DEALLOCED
%[571]% ELSE T2 _ INITLTEMP (INTEGER); ! GET NEW .I TEMP
%[571]% R2 [DFACTOR (1)] _ .T2;
%[571]% T2 [IDUSECNT] _ 1; ! 1ST USAGE: NO SHARING
%[571]% END; ! OF OUT
END
END; !ADJ BLOCK
IF NAMDEF(IDDEFT, .T1) LSS 0 THEN RETURN .VREG;
T1[IDATTRIBUT(INTYPE)] _ 1;
T1[VALTYPE]_.IDTYPE;
R1 _ .R1 -1 !RESTORE FOR SAVSPACE
END;
BEGIN %COMMON%
IF NAMDEF( VARARY, .T1) LSS 0 THEN RETURN .VREG;
CHKCOMMON(.T1); !ROUTINE TO CHECK COMMON DECLARATION
END
TES;
END
ELSE
BEGIN !OPTION 1 - ARRAY NAMES AND SUBSCRIPTS
MAP BASE FARRY;
LOCAL SAVSTK;
MACRO IDCHECK =
BEGIN
CASE @TYPE OF SET
BEGIN %DIMENSION%
IF NAMDEF(ARRYDEF,.T1) LSS 0 THEN RETURN .VREG
END;
BEGIN !GLOBAL
!IF .T1[IDATTRIBUT(INCOM)] THEN ERR34(COMMON)
! ELSE IF .T1[IDATTRIBUT(INEXTERN)] THEN ERR34(EXTERNAL);
!T1[IDATTRIBUT(INGLOB)]_1
END;
BEGIN !EXTERNAL
END;
BEGIN !PROTECT
END;
BEGIN !TYPE STATEMENT
IF NAMDEF(ARRYDEFT,.T1) LSS 0 THEN RETURN .VREG;
T1[IDATTRIBUT(INTYPE)] _ 1;
T1[VALTYPE]_.IDTYPE;
R1 _ .R1-1 !RESTORE FOR SAVSPACE
END;
BEGIN %COMMON%
IF NAMDEF (ARRYDEF,.T1) LSS 0 THEN RETURN .VREG;
IF CHKCOMMON(.T1) LSS 0 THEN RETURN .VREG; !CHECK COMMON DECLARATIONS
END
TES;
IF .T1[OPERSP] EQL VARIABLE THEN T1[OPERSP]_ARRAYNAME
ELSE T1[OPERSP]_FORMLARRAY;
END$;
R2 _ .R1[ELMNT2];
IDCHECK;
SAVSTK_.STK[2]; !SAVING COMMON LIST POINTERS IF PROCESSING COMMON LISTS
IF (T2_BLDDIM(.R2[ELMNT])) LSS 0 THEN RETURN .VREG
ELSE
BEGIN
FARRY[IDDIM]_.T2;
IF .FLGREG<BOUNDS> !IF SS BOUNDS CHECKING IS TO BE PERFORMED
! ON ALL ARRAYS (USER "BOUNDS" SWITCH)
OR .FLGREG<DBGDIMN> !OR THE "DEBUG" SWITCH WAS SPECIFIED
THEN T2[ARADLBL]_GENLAB(); !GENERATE A LABEL TO GO ON THE BLOCK
! THAT WILL BE OUTPUT DESCRIBING THE DIMENSION
! INFORMATION FOR THIS ARRAY
END;
STK[2]_.SAVSTK;
END;SAVSPACE(.R1<LEFT>,@R1);
END;SAVSPACE(.LPNT<LEFT>,@LPNT);
END;
GLOBAL ROUTINE BLKSRCH (BLKNAME)=
BEGIN
REGISTER BASE R1:R2;
EXTERNAL NEWENTRY %()%,COMBLKPTR;
!---------------------------------------------------------------------------------
!THIS ROUTINE FINDS OR CREATES THE COMMON BLOCK "NAME" AND
!RETURNS A POINTER TO IT.
!---------------------------------------------------------------------------------
R1_.COMBLKPTR<LEFT>;
UNTIL .R1 EQL 0 DO
BEGIN
IF .R1[COMNAME] EQL .BLKNAME THEN RETURN .R1;
R1_.R1[NEXCOMBLK];
END;
ENTRY[0]_.BLKNAME;
NAME_COMTAB;R2_NEWENTRY();
RETURN .R2
END;
GLOBAL ROUTINE BLDVAR (VPNT)=
BEGIN
LOCAL BASE T2;
GLOBAL SETUSE; ! SET TO SET/USE BY CALLER
REGISTER BASE T1;REGISTER BASE R1:R2;
EXTERNAL SAVSPACE %(SIZE,LOC)%,NEWENTRY %()%,ARRXPND %(NAME,SUBSCRIPTS)%;
!--------------------------------------------------------------------------
!THE PARAMETER VPNT POINTS TO THE LIST:
!
!IDENTIFIER (20^18+LOC) - THE SCALAR OR ARRAY VARIABLE
!OPTION 0 OR OPTION 1 - SUBSCRIPTS FOLLOW
! 1^18+LOC - POINTER TO SUBSCRIPT LIST POINTER
! COUNT^18+LOC - POINTER TO A LIST OF SUBSCRIPT EXPRESSIONS
!--------------------------------------------------------------------------
T1_.VPNT;T2_.T1[ELMNT];!T2_LOC(IDENTIFIER)
IF .T1[ELMNT1] EQL 0 THEN
BEGIN %SCALAR%
IF .SETUSE EQL SETT
THEN NAMSET(VARYREF, .T2)
ELSE NAMREF(VARYREF,.T2);
IF .VREG LSS 0 THEN T2 _ -1
ELSE T2<LEFT>_IDENTIFIER ! USED BY ASSISTA AND GOTO - EVERYONE ELSE WILL
! ACCEPT AN UNSUBSCRIPTE ARRRAY REF HERE
END
ELSE
BEGIN
IF .SETUSE EQL SETT
THEN NAMSET(ARRAYNM1, .T2)
ELSE NAMREF(ARRAYNM1, .T2);
IF .VREG LSS 0 THEN RETURN .VREG;
R1_.T1[ELMNT2];R2_.R1[ELMNT];SAVSPACE(0,@R1); !CHANGED 1 TO 0
INCR SCR FROM @R2 TO @R2+.R2<LEFT> DO
BEGIN
MAP BASE SCR;MACRO SCRFLGS=0,0,LEFT$,SCRPTR=0,0,RIGHT$;
R1_.SCR[ELMNT]; SCR[SCRPTR]_@R1;SCR[SCRFLGS]_0;
END;
IF (T2_ARRXPND(@T2,@R2)) GTR 0
THEN T2<LEFT>_ARRAYREF;
END;
SAVSPACE(.VPNT<LEFT>,@VPNT);
RETURN .T2!RETURN POINTER TO SCALAR OR ARRAY EXPRESSION
END;
GLOBAL ROUTINE DATALIST (LPNT)=
BEGIN
LOCAL BASE T2;
REGISTER BASE T1;REGISTER BASE R1:R2;
EXTERNAL TBLSEARCH,SP,DOXPN;
EXTERNAL BLDVAR%(VPNT)%,SAVSPACE %(SIZE,LOC)%,TYPE,ONEPLIT,STK,CORMAN %()%;
EXTERNAL SETUSE;
EXTERNAL GENLAB,NEWENTRY,DATASUBCHK;
!**[572] DATALIST @4676 SJW 13-MAY-77
%[572]% EXTERNAL CKDOINDEX; ! CHECK DO INDEX ALREADY ACTIVE
%[572]% EXTERNAL DOCHECK; ! REMOVE DO LABEL FROM ACTIVE DO LIST
%[572]% EXTERNAL E21; ! DO INDEX ALREADY ACTIVE MESSAGE
%[572]% MACRO ADDOLAB (X,Y) = ! PUT INDEX ON ACTIVE DO LIST
%[572]% BEGIN
%[572]% EXTERNAL LASDOLABEL; ! PTR TO END LABEL,,INDEX OF MOST RECENT DO
%[572]% EXTERNAL CURDOINDEX; ! PTR TO CURRENT DO INDEX VARIABLE
%[572]% LOCAL BASE TEMP;
%[572]% NAME<LEFT> _ 2; ! LINK IN NEW LABEL
%[572]% TEMP _ CORMAN ();
%[572]% TEMP [ELMNT] _ .LASDOLABEL; ! SAVE LAST
%[572]% TEMP [ELMNT1] _ .CURDOINDEX; ! SAVE INDEX
%[572]% LASDOLABEL<LEFT> _ .TEMP;
%[572]% LASDOLABEL<RIGHT> _ X;
%[572]% CURDOINDEX _ Y; ! INDEX PTR
%[572]% END$;
LOCAL SAVEBOUNDSFLG; ! TO SAVE THE VALUE OF THE "BOUNDS"
! SWITCH WHILE PROCESSING THE DATA
! LIST FOR A DATA STMNT
MACRO
ERR38=(RETURN FATLEX(E38<0,0>))$, !INDEX VARIABLE NOT VARIABLE
ERR44=RETURN FATLEX(TDOSYM[IDSYMBOL],E44<0,0>)$;
LABEL IO1;
!
!MACROS FOR DATALIST NODE GENERATION FOR IOLISTS,DATA LISTS
!
MACRO SIZOFARRAY=
BEGIN
IF NOT .SYMBL[DBLFLG]
THEN(IF NOT .T2[ADJDIMFLG]
THEN MAKECNST(INTEGER,0,.T2[ARASIZ])
ELSE .T2[ARASIZ] !PTR TO TEMP FOR ADJ DIMENSION
)
ELSE(IF NOT .T2[ADJDIMFLG]
THEN MAKECNST(INTEGER,0,.T2[ARASIZ]/2)
ELSE( NAME _ EXPTAB;
T1 _ NEWENTRY();
!MAKE A DIVIDE NODE .T2[ARASIZ]/2
T1[ARG1PTR] _ .T2[ARASIZ];
T1[ARG2PTR] _ MAKECNST(INTEGER,0,2);
T1[A1VALFLG] _ T1[A2VALFLG] _ 1; !SETTING FLAGS
T1[OPERATOR] _ INTDIVIDE;
T1[PARENT] _ .R1; !POINTS BACK TO DATA LIST NODE
.T1 !PTR TO ASSIGN TO SCALLCT
)
)
END$;
MACRO IODATANODE(X)=
IO1: BEGIN
NAME _ IOLTAB; !IOLIST TABLE
R1_X;
T2 _ .R1[ELMNT];
IF .TYPE EQL READD THEN
SETUSE _ SETT !BLDVAR FLAG
ELSE
IF .TYPE EQL DATALST THEN
BEGIN
SETUSE _ SETT;
%**;[265],ACT1,JNT,11-APR-75%
%**;[265],IN DATALIST @ 4574%
IF .T2[IDATTRIBUT(INDATA)] EQL 1 ![265] SEE IF IT'S
%**;[272],ACT1,JNT,04-MAY-75%
%**;[272],IN DATALIST IN EDIT 265 @ 4574%
AND .T2[IDDIM] EQL 0 ![272] NOT AN ARRAY BUT
THEN ![265] ALREADY IN A DATA STATEMENT
FATLEX(T2[IDSYMBOL],E139<0,0>); ![265] WARN HIM
T2[IDATTRIBUT(INDATA)] _ 1;
IF .T2[IDATTRIBUT(DUMMY)] THEN (FATLEX( T2[IDSYMBOL],E66<0,0>); LEAVE IO1);
END
ELSE SETUSE _ USE;
IDOFSTATEMENT _ IF .R1[ELMNT1] NEQ 0 THEN DATACALL
ELSE (R1_.R1[ELMNT]; !PTR TO SYMBOL
IF .R1[IDDIM] NEQ 0 THEN (NAME<LEFT>_ 3;SLISTCALL) ELSE DATACALL
);
R1_NEWENTRY();
R1[OPERSP] _ .IDOFSTATEMENT; !DATACALL OR SLISTCALL
IF .LISTLINK EQL 0
THEN (LISTLINK<LEFT>_LISTLINK<RIGHT>_.R1)
ELSE (LISTLINK[CLINK] _ .R1; LISTLINK<RIGHT>_.R1);
R1[OPRCLS] _ IOLSCLS; !IOLIST CLASS
R1[DCALLELEM] _ BLDVAR(X);
IF .VREG LSS 0 THEN (R1[DCALLELEM] _ 0; RETURN -1); !VREG IS -1 IF BLDVAR FOUND AN ERROR
IF .R1[OPERSP] EQL SLISTCALL
THEN BEGIN
LOCAL BASE SYMBL;
!FIX UP OPERSP BECAUSE NEWENTRY
!HAS SET SRCID
R1[SRCID]_0;
R1[OPERSP]_SLISTCALL;
SYMBL _ .R1[DCALLELEM];
T2 _ .SYMBL[IDDIM]; !PTR TO DIMENSION NODE
R1[SCALLCT] _ SIZOFARRAY; !PTR TO NODE CONTAINING NUM OF ELEMENTS IN ARRAY
END;
END$;
MACRO IODONODE(X)=
BEGIN
IDOFSTATEMENT_NAME_DODATA;
NAME<RIGHT> _ IOLTAB;
T1_NEWENTRY();
T1[CLINK]_ .X<LEFT>; X<LEFT>_ .T1;
T1[OPRCLS]_STATEMENT;
T1[DOLBL] _ .IOLBL; !PSEUDO LABEL MADE BY IOCONTNODE
T2_.IOLBL[SNDOLNK];
IOLBL[SNDOLVL] _ .IOLBL[SNDOLVL]+1;
NAME<LEFT> _ 1; IOLBL[SNDOLNK] _ CORMAN();
(.VREG)<LEFT>_.T1; (.VREG)<RIGHT>_.T2; !LINKING IN ENDING LBL TO DO NODE AND LABEL TABLE
END$;
!**[572] DATALIST @4770 SJW 16-MAY-77 REMOVE FORMAL X
%[572]% MACRO IOCONTNODE =
BEGIN
IDOFSTATEMENT_NAME_CONTDATA; !NODE IDENTIFICATION AND SIZE
NAME<RIGHT> _ IOLTAB;
T1_NEWENTRY();
T1[OPRCLS]_STATEMENT;
!**[572} DATALIST @4776 SJW 16-MAY-77 REMOVE REFERENCES TO X
IOLBL _ T1[SRCLBL]_ GENLAB();
IOLBL[SNREFNO]_2; !REFERENCE COUNT OF 2
IOLBL[SNHDR] _ .T1 !PTR TO CONTINUE IN LABEL TABLE NODE
END$;
!**[572] DATALIST @4781 SJW 16-MAY-77 DEFINE NEW MACRO
%[572]% MACRO ADDCONTNODE (X) =
%[572]% BEGIN
%[572]% T1 _ .IOLBL [SNHDR]; ! GET NODE FROM IOCONTNODE
%[572]% X [CLINK] _ .T1; ! LINK IN CONT NODE AT END OF LOOP
%[572]% X<RIGHT> _ .T1; ! POINT TO NEW END OF DATALIST
%[572]% END$;
LOCAL BASE LISTLINK; !PTR TO FIRST<LEFT> AND LAST<RIGHT> NODES IN DATALIST CHAIN
!---------------------------------------------------------------------
!THIS ROUTINE IS CALLED WITH LPNT POINTING TO A LIST OF
!DATAITEMS. EACH DATAITEM CONSISTS OF:
!
!CHOICE-1
! DATAITEM-(LOC)
!CHOICE-2
! LIST-(COUNT^18+LOC)
! DATAITEM
! OPTION-0 OR
! OPTION-1
! LOOPPART
!---------------------------------------------------------------------
SAVEBOUNDSFLG_.FLGREG<BOUNDS>; !PRESERVE THE VALUE OF THE "BOUNDS"
! SWITCH (USED BY THE USER TO REQUEST ARRAY BOUNDS CHECKING)
IF .TYPE EQL DATALST !IF WE ARE PROCESSING THE DATA LIST FOR A DATA STATEMENT
! (NOT AN IO STMNT)
THEN
FLGREG<BOUNDS>_0; !TURN OFF THE BOUNDS FLAG UNTIL ARE THROUGH WITH THIS STMNT
! (ELSE THE ARRAY SS CALC WILL BE TURNED INTO A CALL TO
! A RUN-TIME FUNCTION)
LISTLINK_0; !INITIALIZING FOR LIST INPARENS
INCR DATLST FROM @LPNT TO @ LPNT+.LPNT<LEFT> BY 2 DO
BEGIN
MAP BASE DATLST;
IF .DATLST[ELMNT] EQL 1 THEN !A DATAITEM
BEGIN
IODATANODE(.DATLST[ELMNT1]);
END
ELSE !AN IMPLIED DO LOOP OR LIST ENCLOSED IN PARENS
BEGIN
LOCAL BASE LNKLST; !TEMPORARY HOLDER OF LINKLIST
LOCAL BASE TDOSYM; !TEMPORARY HOLDER OF DO INDEX SYMBOL PTR
EXTERNAL E128;
!**[572] DATALIST @4815 SJW 13-MAY-77
%[572]% LOCAL BASE DONOD:IOLBL; !LABEL OF CONTINUE ENDING IMPLIED DO LOOP
LNKLST _ 0; !INIT LOCAL
R1_.DATLST[ELMNT1];R2_.R1[ELMNT]; !R2_LOC(DATAITEM LIST)
IF .R1[ELMNT1] NEQ 0
THEN (!IMPLIED DO LOOP COMING UP ; R2 HAS PTR TO IMPLIED DO LIST
%FIRST CHECK TO SEE THAT THERE HAVE BEEN
SOME VARIABLES FOR THIS DO SPEC %
IF .R2<LEFT> EQL 1
THEN RETURN FATLEX (E128<0,0>);
T1_@R2+.R2<LEFT>;
T2 _ .T1[ELMNT];
!**[572] DATALIST @4825 SJW 13-MAY-77
%[572]% IOCONTNODE ; ! GEN A CONTINUE NODE
%DON'T LET SUBSCRIPTED IMPLICIT DO INDECES GO UNDETECTED%
IF .T2[ELMNT1] NEQ 0 THEN RETURN FATLEX(E115<0,0>);
T2 _ TDOSYM _ .T2[ELMNT];
IF .T2[OPRCLS] NEQ DATAOPR THEN ERR38
ELSE IF .T2[OPRSP1] NEQ VARIABL1 THEN ERR38;
IF .T2[VALTYPE] NEQ INTEGER THEN RETURN FATLEX(E104<0,0>);
IF .TYPE EQL DATALST
THEN
BEGIN
STK[SP_.SP+1] _.T2; !SAV PTR TO INDEX SYMBOL ON STACK
END
!**[572] DATALIST @4837 SJW 13-MAY-77
%[572]% ELSE BEGIN
%[572]% IF NAMSET (VARIABL1,.T2) LSS 0
%[572]% THEN RETURN .VREG;
%[572]% END;
!**[601] DATALIST MOVE [572] FROM @4837 TO @4840 SJW 4-AUG-77
%[601]% IF CKDOINDEX (.T2)
%[601]% THEN RETURN FATLEX (T2 [IDSYMBOL], E21<0,0>); ! DO INDEX ALREADY ACTIVE
%[601]% ADDOLAB (.IOLBL, .T2); ! THIS INDEX IS CURRENTLY MOST ACTIVE
R2<LEFT>_.R2<LEFT>-2; !RESET LIST PTR SO THAT LAST ITEM (INDEX PTR)
!DOESN'T GET PROCESSED AS AN IODATANODE
);
!**[572] DATALIST @4843 SJW 13-MAY-77
%[572]% IF (LNKLST _ DATALIST (.R2)) LSS 0
%[572]% THEN BEGIN
%[572]% T2 _ .VREG;
%[572]% IF .R1 [ELMNT1] NEQ 0 ! IMPLIED DO LOOP
%[572]% THEN DOCHECK (.IOLBL); ! REMOVE LABEL FROM ACTIVE DO LIST
%[572]% RETURN .T2;
%[572]% END;
IF .R1[ELMNT1] NEQ 0 THEN !IMPLIED DO LOOP
BEGIN
!**[572] DATALIST @4846 SJW 13-MAY-77
%[572]% DOCHECK (.IOLBL); ! REMOVE LABEL FROM ACTIVE DO LIST
%[572]% ADDCONTNODE (LNKLST); ! LINK IN CONT NODE
IODONODE(LNKLST); !GEN A DO LOOP NODE
DONOD_.LNKLST<LEFT>; !SET UP BY IODONODE
DONOD[DOSYM]_.TDOSYM; !STK[2]_LOC(INDEX VARIABLE)
R2_.R1[ELMNT2]; SAVSPACE(.R1<LEFT>,.R1); !R2_LOC(LOOPPART)
R1_.R2[ELMNT];
!R1 POINTS TO INITIAL VALUE
IF .TYPE EQL DATALST THEN
IF .R1[OPR1] NEQ CONSTFL THEN ERR44;
IF .R1[VALTYPE] NEQ INTEGER THEN ERR44;
DONOD[DOM1]_@R1;R1_.R2[ELMNT1]; !_LOC(INITIAL VALUE)
!R1 POINTS TO FINAL VALUE
IF .TYPE EQL DATALST THEN
IF .R1[OPR1] NEQ CONSTFL THEN ERR44;
IF .R1[VALTYPE] NEQ INTEGER THEN ERR44;
DONOD[DOM2]_@R1; !_LOC(FINAL VALUE)
IF .R2[ELMNT2] EQL 0 THEN !INPLIED INCREMENT OF 1
BEGIN
DONOD[DOM3]_.ONEPLIT;
END
ELSE !INCREMENT SPECIFIED
BEGIN
T1_.R2[ELMNT3];R1_.T1[ELMNT];SAVSPACE(0,.T1);
IF .TYPE EQL DATALST THEN
IF .R1[OPR1] NEQ CONSTFL THEN ERR44;
IF .R1[VALTYPE] NEQ INTEGER THEN ERR44;
DONOD[DOM3]_.R1<RIGHT>;
END;
IF .TYPE EQL DATALST
THEN IF .SP GTR 0
THEN ( DATASUBCHK(.DONOD[CLINK],.SP,STK[1]<0,0>);
SP _ .SP-1;
);
SAVSPACE(.R2<LEFT>,.R2);
END;
IF .LISTLINK EQL 0
THEN LISTLINK_.LNKLST
ELSE (LISTLINK[CLINK]_.LNKLST<LEFT>;
LISTLINK<RIGHT> _ .LNKLST<RIGHT>
);
END;
END;
FLGREG<BOUNDS>_.SAVEBOUNDSFLG; !RESTORE THE "BOUNDS" FLAG TO ITS ORIGINAL VAL
RETURN .LISTLINK !POINTS TO FIRST ELEMENT IN LIST
END;
GLOBAL ROUTINE BLDFORMAT (FPNT)=
BEGIN
REGISTER BASE T1:T2; MAP BASE FPNT;REGISTER BASE R1:R2;
GLOBAL NAMLSTOK; !SET TO 1 BY CALLER IF NAMELIST IS A VIABLE ARGUMENT
EXTERNAL SAVSPACE %(SIZE,LOC)%,STK,BLDVAR %(VPNT)%,TBLSEARCH %()%,
TYPE;
MACRO
ERR25=(RETURN FATLEX(E25<0,0>))$,
ERR19=(RETURN FATLEX(E19<0,0>))$,
ERR15(X)=BEGIN
RETURN FATLEX( X,R2[IDSYMBOL],E15<0,0>)
END$,
ERR34=RETURN FATLEX(PLIT'PARAMETER',R2[IDSYMBOL],E34<0,0>)$;
ROUTINE EOE=
BEGIN
!--------------------------------------------------------------------------------------------------
!R2=LOC (END OR ERR IDENTIFIER)
!T1=LOC (LABEL CHOICE)
!T2=LOC (LABEL )
!--------------------------------------------------------------------------------------------------
EXTERNAL NONIOINIO,LABREF;
% THESE LABELS ARE PICKED UP AS CONSTANTS AND THEN
CONVERTED TO LABELS BECAUSE THEY ARE EXECUTABLE
LABEL REFERENCES IN AN IO STATEMENT %
IF .T2[VALTYPE] NEQ INTEGER
THEN RETURN FATLERR(.LEXNAM[LABELEX],.LEXNAM[CONSTLEX],.ISN,E0<0,0>);
NONIOINIO _ 1;
ENTRY[1] _ .T2[CONST2];
T2 _ LABREF();
T2[SNREF] _ .T2[SNREF]-1; !DON'T COUNT REFERENES
!TO FORMAT LABELS IN I/O STATEMENTS
SAVSPACE(.T1<LEFT>,@T1);
IF .R2[IDSYMBOL] EQL SIXBIT 'END' THEN
(IF .STK[6] EQL 0 THEN STK[6]_@T2 ELSE ERR34)
ELSE IF .R2[IDSYMBOL] EQL SIXBIT 'ERR' THEN
(IF .STK[5] EQL 0 THEN STK[5]_@T2 ELSE ERR34)
ELSE ERR15 (PLIT'END OR ERR ');
END;
!----------------------------------------------------------------------------------------------------------
!THIS ROUTINE IS CALLED WITH THE PARAMETER FPNT POINTING TO
!A FORMAT SPECIFICATION. SEE EXPANSION OF METASYMBOL IOSPEC FOR
!DETAILS. THE FORMAT POINTER IS RETURNED IN STK[4]. IT MAY BE
!A LABEL (LOC), ASTERISK -