Trailing-Edge
-
PDP-10 Archives
-
BB-4157E-BM
-
fortran-compiler/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,1981 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: T.E. OSTEN/FJI/MD/SJW/JNG/DCE/TFV/AHM
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 = 6^24 + 0^18 + 128; ! Version Date: 19-Oct-81
%(
***** Begin 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, (MD)
100 232 ----- FIX BLDUNIT - IT NEEDED ONE MORE LEVEL OF
INDIRECTION IN THE RECORD NUMBER PROCESSING., (MD)
101 235 ----- FIX NAMELIST PROBLEMS
USING NEW PARAMETER NMLSTITM, (DT/MD)
102 265 15946 ADD CHECK FOR VARIABLE IN DATA STATEMENT TWICE, (JNT)
103 272 ----- CHANGE 102 TO ONLY CHECK SIMPLE VARIABLES, NOT ARRAYS,
(JNT)
***** Begin Version 5 *****
104 VER5 ----- SHARE .I OFFSET IN DIMENTRY FOR ARRAYS
WITH VARIABLE UPPER BOUND (LINK DIM ENTRIES), (SJW)
105 410 ----- MAKE DTABPTR GLOBAL SO WILL BE INITIALIZED TO 0, (SJW)
106 414 QA625 FIX SHARING .I OFFSET SO ONLY SHARES DIM2 .I
IF DIM1 SAME, (SJW)
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, (SJW)
109 460 19477 TEST FOR OVERSIZED DIMENSIONING CORRECTLY, (DCE)
***** 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, (SJW)
112 572 21825 CHECK IMPLIED DO INDEX FOR ALREADY ACTIVE (FROM
AN ENCLOSING IMPLIED OR REAL DO), (SJW)
113 601 Q20-26 FIX EDIT 572 TO CHECK IMPLIED DO INDEX IN DATA
STATEMENT FOR ALREADY ACTIVE FROM AN ENCLOSING
IMPLIED DO, (SJW)
***** Begin Version 5B *****
114 627 23755 FIX EDIT 571 TO CORRECTLY ADJUST ALL DIMENSION
TABLE MULTIPLICATIVE FACTORS BY THE RIGHT
CONSTANT IF AN ARRAY IS LATER DISCOVERED TO
REQUIRE A DIFFERENT NUMBER OF WORDS PER ENTRY
THAN ORIGINALLY THOUGHT. EDIT 571 ONLY FIXED
THE FIRST SUBSCRIPT., (JNG)
115 635 24868 FIX DATALIST TO RETURN -1 IF IT GETS E66
(CANNOT INIT DUMMY PARAMETER IN DATA), (JNG)
116 663 25643 FIX TYPING OF FORMAL FUNCTIONS (EXTERNAL STMNTS), (DCE)
117 717 26560 GIVE REASONABLE ERROR MESSAGE FOR
REPEATED PARAMETER STATEMENT, (DCE)
118 741 ----- ADD SLASHWARN ROUTINE, (DCE)
***** Begin Version 6 *****
119 760 TFV 1-Jan-80 -----
Add routines to handle keywords in I/O control lists
127 1132 AHM 22-Sep-81 Q10-06347
Fix casing of some error message fragments.
128 1136 AHM 19-Oct-81 Q20-01652,Q20-01656
Delete code that unjustifiably decremented SNREF for labels
in BLDKEY, since it screwed up optimizations.
***** End Revision History *****
)%
FORWARD
FUNCGEN, !
TYPEGEN, !
TMPGEN, !
BLDDIM, !
BLDARRAY, !
BLKSRCH, !
BLDVAR, !
DATALIST, !
BLDFORMAT, !
BLDUNIT, !
%[760]% BLDKEY,
%[760]% BLDKLIST,
%[760]% KORFBLD,
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 (
%1132% R18 NAMES R23 NAMES 'in EXTERNAL statement?0',
%1132% R22 NAMES 'as dummy parameter?0',
%1132% R19 NAMES 'in type statement?0',
%1132% R24 NAMES 'in DATA statement?0',
%1132% R26 NAMES 'in COMMON?0',
%1132% R27 NAMES 'in EQUIVALENCE?0',
%1132% R28 NAMES 'as an entry point name?0',
%1132% R33 NAMES 'as statement function?0',
%1132% R34 NAMES 'as COMMON block?0',
%1132% R35 NAMES 'as NAMELIST?0',
%1132% AYORFN NAMES ' as an array or FUNCTION?0',
%1132% AY NAMES 'as an array?0',
%1132% 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,
%PARADEF% NAMLST + CMNBLK + STFN + ENTPNT + EXTBTH + TYPED + EQVIN + COMIN + DATAIN + DUMIEE,
%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
![717] IF ALREADY DEFINED AS PARAMETER (IF THIS IS A REDUNDENT
![717] PARAMETER DEFINITION OR REDEFINITION) GIVE FATAL ERROR
%[717]% ELSE IF .ID[IDATTRIBUT(PARAMT)] THEN .LEXNAM[CONSTLEX]
END;
%NMLSTITM% BEGIN
IF .ID[OPRSP1] EQL FNNAME1 THEN FNN
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;
![663] WE ARE TRYING TO ASSIGN TYPE INFORMATION TO PARAMETERS OF
![663] SUBROUTINE AND ENTRY STATEMENTS. THERE MAY BE INFORMATION
![663] ALREADY PRESENT REGARDING THESE VARIABLES, SO WE NEED TO BE
![663] VERY CAREFUL. IF THE VARIABLE HAS ALREADY BEEN DIMENSIONED,
![663] THEN WE KNOW THAT IT IS A FORMLARRAY. OTHERWISE, WE MIGHT
![663] HAVE SEEN IT PREVIOUSLY IN AN EARLIER SUBROUTINE OR ENTRY
![663] STATEMENT IN WHICH CASE WE NEED TO RETAIN THE SAME TYPE.
![663] SO IF IT IS EITHER A FORMLFN OR A FORMLVAR, RETAIN THAT TYPE
![663] INFORMATION. FINALLY, IT MIGHT HAVE OCCURRED AS A FUNCTION
![663] NAME (AS IN AN EXTERNAL DECLARATION) - IN THIS CASE CHANGE
![663] THE TYPE TO FORMLFN SO THAT SPACE WILL BE ALLOCATED FOR THE
![663] VARIABLE NAME. IF NONE OF THE ABOVE, THEN THE VARIABLE
![663] IS A SIMPLE ONE - FORMLVAR.
%[663]% IF .R2[IDDIM] EQL 0 THEN
%[663]% (IF .R2[OPERSP] NEQ FORMLFN THEN
%[663]% IF .R2[OPERSP] EQL FNNAME
%[663]% THEN R2[OPERSP]_FORMLFN
%[663]% ELSE R2[OPERSP]_FORMLVAR)
%[663]% 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;
EXTERNAL DTABPTR; ! HEAD OF DIM ENTRY LIST
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;
BIND DLBL = STK [5] <LEFT>, ! TEMP ARADLBL
ALINK = STK [5] <RIGHT>, ! TEMP ARALINK
A0F = STK [7] <RIGHT>; ! TEMP DFACTOR (0)
!----------------------------------------------------------------------------------------------------------
!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;
![741] ROUTINE TO GIVE WARNING WHEN / ENCOUNTERED IN
![741] ANY BOUNDS FOR AN ARRAY DECLARATOR
%[741]% GLOBAL ROUTINE SLASHWARN=
%[741]% BEGIN
%[741]% EXTERNAL E145;
%[741]% WARNERR(.ISN,E145<0,0>); ! USE :, NOT /
%[741]% RETURN 0
%[741]% 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
!THE FOLLOWING CODE CURES A WHOLE
! HOST OF PROBLEMS CONCERNING ERROR DETECTION
! AND RECOVERY DURING DIMENSION PROCESSING, ESPECIALLY
! REGARDING ARRAYS WHICH ARE TOO LARGE TO HANDLE.
IF .R1[CONST2] EQL 0
THEN FATLEX(FARRY[IDSYMBOL],E74<0,0>);
!DO NOT TEST FOR TOO LARGE A SUBSCRIPT HERE -
! 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;
IF .R1[OPERSP] NEQ FORMLVAR AND NOT .R1[IDATTRIBUT(INCOM)] THEN
(
AJDIMSTK(.R1); ! CREATE AN ENTRY
R1[IDATTRIBUT(NOALLOC)] _ .SAV; !RESTORE
);
T2[DVARUBFLG(0)]_1;T2[DIMENU(0)]_@R1;ADJUSTABLE_-1;
END;
IF .ADJUSTABLE EQL 0 THEN
BEGIN
LOCAL SAV; ! NEED FULL WORD TO TEST OVERFLOW
EXTERNAL E141; ! NEW ERROR MESSAGE
NAME_CONTAB;ENTRY[0]_0;ENTRY[1]_.ASIZE;SYMTYPE_INTEGER;
T2[DFACTOR(0)]_TBLSEARCH();
!AS THE COMPLETE ARRAY SIZE IS COMPUTED, DO NOT LET
! IT GET TOO LARGE WITHOUT REPORTING THE ERROR
AOFF_.AOFF-.ASIZE;
SAV_.ASIZE*.R1[CONST2]; !FULL WORD SIZE
IF .SAV GEQ 1^18 THEN FATLEX(.FARRY[IDSYMBOL],E141<0,0>);
!NOW IT IS SAFE TO PUT THIS INTO A HALF WORD WHETHER
! OR NOT THERE IS A TRUNCATION!
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;
IF .R1[OPERSP] NEQ FORMLVAR AND NOT .R1[IDATTRIBUT(INCOM)] THEN
(
AJDIMSTK(.R1); ! CREATE AN ENTRY
R1[IDATTRIBUT(NOALLOC)] _ .SAV; !RESTORE
);
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
!DO NOT NEED TO CHECK HERE FOR ARRAY BOUND SIZE
IF .HISIGN NEQ 0
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;
SAV _ .R2[IDATTRIBUT(NOALLOC)]; !SAVE IN CASE ITS NOT DUMMY YET
IF NAMREF(VARIABL1,.R2) THEN RETURN .VREG;
IF .R2[OPERSP] NEQ FORMLVAR AND NOT .R2[IDATTRIBUT(INCOM)] THEN
(
AJDIMSTK(.R2); ! CREATE AN ENTRY
R2[IDATTRIBUT(NOALLOC)] _ .SAV; !RESTORE
);
T2[DVARUBFLG(0)]_1;ADJUSTABLE_-1;
END;
IF .R2[OPERSP] EQL CONSTANT
THEN
!DO NOT TEST ON INDIVIDUAL ELEMENTS HERE!
IF .HISIGN NEQ 0
THEN R2 _ MAKECNST(INTEGER,0,-.R2[CONST2]);
T2[DIMENU(0)]_.R2;
IF .ADJUSTABLE EQL 0 THEN
BEGIN
!ALSO NEED TO CHECK THE CASE WITH UPPER AND
! LOWER BOUNDS.
LOCAL SAV;
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];
!CHECK FOR TOTAL SPACE NEEDED FOR THIS ARRAY
SAV_.ASIZE*(.R2[CONST2]-.R1[CONST2]+1);
IF .SAV GEQ 1^18 THEN FATLEX(.FARRY[IDSYMBOL],E141<0,0>);
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;
LOCAL BASE PTR;
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);
A0F_ IF .FARRY [DBLFLG] ! SET ELEMENT SIZE
THEN MAKECNST (INTEGER, 0, 2)
ELSE .ONEPLIT;
DECR I FROM .DNUM - 1 TO 1 DO
LDECR: BEGIN
T2 _ .T2 - 2; ! DIMSUBENTRY (I)
IF .T2 [DFACTOR (0)] NEQ 0
THEN LEAVE LDECR;
IF NOT .T2 [DVARUBFLG (0)] OR
.T2 [DIMENL (0)] NEQ .ONEPLIT OR
.I NEQ 1
THEN BEGIN
T2 [DFACTOR (0)] _ INITLTEMP (INTEGER);
LEAVE LDECR;
END;
!I == 1 => T2 [...(0)] IS FOR 2ND DIM
PTR _ .DTABPTR <RIGHT>;
WHILE .PTR NEQ 0
DO BEGIN
E _ .PTR;
CHECKTHIS: BEGIN
IF .E [DIMNUM] LSS 2
THEN LEAVE CHECKTHIS;
IF NOT .E [ADJDIMFLG]
THEN LEAVE CHECKTHIS;
IF .E [DFACTOR (0)] NEQ .A0F ! SAME ELEMENT SIZE
THEN LEAVE CHECKTHIS;
!IF DIM1 SAME THEN SHARE FACTOR FOR DIM2
IF .E [DIMENU (0)] EQL .T2 [DIMENU (-1)] AND
.E [DIMENL (0)] EQL .ONEPLIT
THEN BEGIN
PTR _ .E [DFACTOR (1)];
T2 [DFACTOR (0)] _ .PTR;
PTR [IDUSECNT] _ .PTR [IDUSECNT] + 1; ! UPDATE SHARING COUNT
LEAVE LDECR;
END;
END; ! OF CHECKTHIS
PTR _ .E [ARALINK]; ! NEXT ENTRY
END; ! OF WHILE .PTR NEQ 0
PTR _ INITLTEMP (INTEGER); ! NO MATCH FOUND
T2 [DFACTOR (0)] _ .PTR;
PTR [IDUSECNT] _ 1; ! 1ST USAGE: NO SHARING
END; ! OF LDECR
T2 _ .T2 - 2; ! SUBENTRY (0)
T2 [DVARFACTFLG (0)] _ 0;
T2 [ADJDIMFLG] _ 1;
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)
DLBL _ 0; ! FOR SAFETY
ALINK _ .DTABPTR <RIGHT>; ! LINK THIS ENTRY INTO LIST
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;
LABEL OUT, CHECKTHIS;
EXTERNAL DTABPTR, ONEPLIT, INITLTEMP;
LOCAL BASE PTR; ! TO MARCH DOWN DIM ENTRY LIST
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
%[627]% DECR I FROM .R2[DIMNUM]-1 TO 0 DO
%[627]% IF NOT .R2[DVARFACTFLG(.I)] THEN
%[627]% BEGIN
%[627]% T2 _ .R2[DFACTOR(.I)];
%[627]% R2[DFACTOR(.I)] _ MAKECNST(INTEGER,0, ( .T2[CONST2] * .DUB ) / 2 );
%[627]% END;
OUT: BEGIN
IF .R2 [DIMNUM] LSS 2
THEN LEAVE OUT;
IF NOT .R2 [DVARUBFLG (1)]
THEN LEAVE OUT;
IF .R2 [DIMENL (1)] NEQ .ONEPLIT
THEN LEAVE OUT;
T2 _ .R2 [DFACTOR (1)];
T2 [IDUSECNT] _ .T2 [IDUSECNT] - 1;
IF .T2 [IDUSECNT] EQL 0
THEN T2 [IDATTRIBUT (NOALLOC)] _ 1; ! NOT SHARED NOW: DON'T ALLOC
PTR _ .DTABPTR<RIGHT>;
WHILE .PTR NEQ 0
DO BEGIN
E _ .PTR;
CHECKTHIS: BEGIN
IF .E EQL .R2 ! DON'T SHARE WITH YOURSELF
THEN LEAVE CHECKTHIS;
IF .E [DIMNUM] LSS 2
THEN LEAVE CHECKTHIS;
IF NOT .E [ADJDIMFLG]
THEN LEAVE CHECKTHIS;
IF .E [DFACTOR (0)] NEQ .R2 [DFACTOR (0)] ! SAME ELEMENT SIZE ?
THEN LEAVE CHECKTHIS;
IF .E [DIMENU (0)] NEQ .R2 [DIMENU (0)]
THEN LEAVE CHECKTHIS;
IF .E [DIMENL (0)] NEQ .ONEPLIT
THEN LEAVE CHECKTHIS;
! DIM 1 SAME: SHARE FACTOR FOR DIM2
PTR _ .E [DFACTOR (1)];
R2 [DFACTOR (1)] _ .PTR;
PTR [IDUSECNT] _ .PTR [IDUSECNT] + 1; ! UPDATE SHARING COUNT
LEAVE OUT;
END; ! OF CHECKTHIS
PTR _ .E [ARALINK]; ! NEXT ENTRY
END; ! OF WHILE .PTR NEQ 0
IF .T2 [IDUSECNT] EQL 0 ! NO MATCH FOUND
THEN T2 [IDATTRIBUT (NOALLOC)] _ 0 ! USE OLD .I WHICH WAS DEALLOCED
ELSE T2 _ INITLTEMP (INTEGER); ! GET NEW .I TEMP
R2 [DFACTOR (1)] _ .T2;
T2 [IDUSECNT] _ 1; ! 1ST USAGE: NO SHARING
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;
EXTERNAL CKDOINDEX; ! CHECK DO INDEX ALREADY ACTIVE
EXTERNAL DOCHECK; ! REMOVE DO LABEL FROM ACTIVE DO LIST
EXTERNAL E21; ! DO INDEX ALREADY ACTIVE MESSAGE
MACRO ADDOLAB (X,Y) = ! PUT INDEX ON ACTIVE DO LIST
BEGIN
EXTERNAL LASDOLABEL; ! PTR TO END LABEL,,INDEX OF MOST RECENT DO
EXTERNAL CURDOINDEX; ! PTR TO CURRENT DO INDEX VARIABLE
LOCAL BASE TEMP;
NAME<LEFT> _ 2; ! LINK IN NEW LABEL
TEMP _ CORMAN ();
TEMP [ELMNT] _ .LASDOLABEL; ! SAVE LAST
TEMP [ELMNT1] _ .CURDOINDEX; ! SAVE INDEX
LASDOLABEL<LEFT> _ .TEMP;
LASDOLABEL<RIGHT> _ X;
CURDOINDEX _ Y; ! INDEX PTR
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>)$;
!
!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)=
%[635]% 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;
IF .T2[IDATTRIBUT(INDATA)] EQL 1 !SEE IF IT'S
AND .T2[IDDIM] EQL 0 !NOT AN ARRAY BUT
THEN !ALREADY IN A DATA STATEMENT
FATLEX(T2[IDSYMBOL],E139<0,0>); !WARN HIM
T2[IDATTRIBUT(INDATA)] _ 1;
%[635]% IF .T2[IDATTRIBUT(DUMMY)] THEN RETURN FATLEX( T2[IDSYMBOL],E66<0,0>);
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$;
MACRO IOCONTNODE =
BEGIN
IDOFSTATEMENT_NAME_CONTDATA; !NODE IDENTIFICATION AND SIZE
NAME<RIGHT> _ IOLTAB;
T1_NEWENTRY();
T1[OPRCLS]_STATEMENT;
IOLBL _ T1[SRCLBL]_ GENLAB();
IOLBL[SNREFNO]_2; !REFERENCE COUNT OF 2
IOLBL[SNHDR] _ .T1 !PTR TO CONTINUE IN LABEL TABLE NODE
END$;
MACRO ADDCONTNODE (X) =
BEGIN
T1 _ .IOLBL [SNHDR]; ! GET NODE FROM IOCONTNODE
X [CLINK] _ .T1; ! LINK IN CONT NODE AT END OF LOOP
X<RIGHT> _ .T1; ! POINT TO NEW END OF DATALIST
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;
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];
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
ELSE BEGIN
IF NAMSET (VARIABL1,.T2) LSS 0
THEN RETURN .VREG;
END;
IF CKDOINDEX (.T2)
THEN RETURN FATLEX (T2 [IDSYMBOL], E21<0,0>); ! DO INDEX ALREADY ACTIVE
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
);
IF (LNKLST _ DATALIST (.R2)) LSS 0
THEN BEGIN
T2 _ .VREG;
IF .R1 [ELMNT1] NEQ 0 ! IMPLIED DO LOOP
THEN DOCHECK (.IOLBL); ! REMOVE LABEL FROM ACTIVE DO LIST
RETURN .T2;
END;
IF .R1[ELMNT1] NEQ 0 THEN !IMPLIED DO LOOP
BEGIN
DOCHECK (.IOLBL); ! REMOVE LABEL FROM ACTIVE DO LIST
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 - STANDARD FORMAT CONVERSIONS (-1)
!AN ARRAY NAME OR NAMELIST NAME (LOC[IDENTIFIER]) OR NOT SPECIFIED (0).
!THE END AND ERR BRANCH LOCATIONS ARE RETURNED IN STK[6] AND STK[5]
!RESPECITVELY. THEY MAY BE LABELS (LOC), VARIABLES (LOC) OR NOT
!SPECIFIED (0).
!----------------------------------------------------------------------------------------------------------
CASE .FPNT[ELMNT] OF SET
0;!NEVER OCCURS,INSERTED FOR SPEED ONLY
BEGIN!LABEL
IF .STK[4] NEQ 0 THEN RETURN FATLEX(E39<0,0>); ! ALREADY FOUND ONE
STK[4]_.FPNT[ELMNT1];
END;
BEGIN!ARRAY NAME NAMELIST NAME OR END/ERR
R1_.FPNT[ELMNT1];
%FLAG BEING SET INDICATES THAT BLDFORMAT WAS CALLED FROM
READ OR WRITE AND THUS HAS A SLIGHTLY DIFFERENT
SYNTAX TREE, POSSIBLY INCLUDING END/ERR= %
R2 _ IF .FLAG EQL 0 THEN .R1[ELMNT] %READ OR WRITE% ELSE .R1;
IF (.R1[ELMNT1] EQL 0) OR (.FLAG NEQ 0) THEN !ARRAY NAME OR NAMELIST NAME
!OR NO END= OR ERR= EXPECTED
BEGIN
IF .STK[4] NEQ 0 THEN RETURN FATLEX(E39<0,0>);
IF .R2[OPRSP1] EQL ARRAYNM1
THEN
BEGIN
STK[4]_.R2;
IF .TYPE EQL READD
THEN NAMSET(ARRAYNM1, .R2)
ELSE NAMREF(ARRAYNM1, .R2);
IF .VREG LSS 0 THEN RETURN .VREG;
END
ELSE IF .NAMLSTOK NEQ 0 THEN
IF .R2[IDATTRIBUT(NAMNAM)]
THEN
BEGIN
LOCAL NAMROUT; !TO PUT ROUTINE TO CALL
LOCAL BASE NMLST:NAMCOM;
STK[4]_@R2;
IF NAMREF( NMLSTREF,.R2) LSS 0 THEN RETURN .VREG;
%NOTE REFERENCE OR SETTING OF EACH ITEM IN LIST %
NAMROUT _ IF .TYPE EQL READD THEN NAMSET ELSE NAMREF; !DETERMINE ROUTINE TO CALL
NAMCOM_.R2[IDCOLINK]; !GET POINTER TO NAMELIST NODE
NMLST_.NAMCOM[NAMLIST]; !GET POINTER TO LIST OF ITEMS
WHILE .NMLST LSS (.NAMCOM[NAMLIST] + .NAMCOM[NAMCNT]) DO
BEGIN
R1 _ .NMLST[ELMNT];
(.NAMROUT)(.R1[OPRSP1],.R1); !CALL THE ROUTINE
NMLST _ .NMLST+1; !NEXT ITEM
END; !OF WHILE ... DO
R1 _ .FPNT[ELMNT1]; !RESTORE R1
END
ELSE ERR15(PLIT'ARRAY OR NAMELIST NAME')
ELSE ERR15(PLIT'ARRAY NAME');
END
ELSE !END=/ERR=
BEGIN
T1_.R1[ELMNT2];T2_.T1[ELMNT]; !T1 HAS PTR TO OPTIONAL (= CONST )
!T2 HAS PTR TO SYMBOL NODE THAT SHOULDCONTAIN
!'END' OR 'ERR'
IF EOE() LSS 0 THEN RETURN .VREG;
END;
IF .FLAG EQL 0 %READ/WRITE% THEN SAVSPACE( .R1<LEFT>,@R1);
END;
BEGIN!ASTERISK
IF .STK[4] NEQ 0 THEN RETURN FATLEX(E39<0,0>); ! ALREADY FOUND ONE
STK[4]_-1
END
TES;
END;
GLOBAL ROUTINE BLDUNIT (UPNT)=
BEGIN
MAP BASE UPNT; LOCAL BASE T2;REGISTER BASE R1:T1:R2;
EXTERNAL SAVSPACE %(SIZE,LOC)%,STK,BLDFORMAT %(FPNT)%,BLDVAR %(UPNT)%;
EXTERNAL SETUSE,NAMLSTOK;
EXTERNAL CNVNODE;
MACRO
ERR15(X)=RETURN FATLEX( INTGPLIT<0,0>, X, E15<0,0> ) $;
!----------------------------------------------------------------------------------------------------------
!THIS ROUTINE IS CALLED WITH THE PARAMETER UPNT POINTING
!TO A UNITSPEC OPTIONALLY FOLLOWED BY A FORMATID. SEE
!EXPANSIONS OF THE METASYMBOLS IOSPEC, UNITSPEC AND FORMATID FOR
!DETAILS. A UNIT NUMBER MAY BE AN INTEGER CONSTANT OR AN INTEGER
!VARIABLE. IF A FORMAT IS PRESENT THE ROUTINE BLDFORMAT IS CALLED
!TO SCAN THE FORMAT. UPON EXIT FROM THIS ROUTINE THE FOLLOWING
!LOCATIONS WILL BE DEFINED:
!
! STK[2]=UNIT
! STK[3]=RECORD
! STK[4]=FORMAT
! STK[5]=ERR
! STK[6]=END
!----------------------------------------------------------------------------------------------------------
R1_.UPNT[ELMNT];R2_.R1[ELMNT1]; !R2_LOC(CONSTANT OR VARIABLE)
IF .R1[ELMNT] EQL 1 THEN !INTEGER CONSTNAT
BEGIN
IF .R2[VALTYPE] NEQ INTEGER THEN ERR15 (PLIT SIXBIT 'UNIT');
STK[2]_.R2
END
ELSE !VARIABLE
BEGIN
T2 _ .R2[ELMNT]; !PTR TO IDENTIFIER OR CONSTANT NODE
IF .T2[VALTYPE] NEQ INTEGER THEN ERR15 (T2[IDSYMBOL]);
SETUSE _ USE;
IF (STK[2]_BLDVAR(.R2)) LSS 0 THEN RETURN .VREG;
%DON'T LET UNSUBSCRIPTED ARRAYS THROUGH%
IF .VREG<LEFT> EQL IDENTIFIER
THEN ( MAP BASE VREG;
IF .VREG[OPRSP1] EQL ARRAYNM1
THEN RETURN FATLEX( VREG[IDSYMBOL],ARPLIT<0,0>,E4<0,0>);
);
END;
IF .R1[ELMNT2] NEQ 0 THEN !RECORD NUMBER
BEGIN
STK[3] _ .R1[ELMNT3];
T1 _ @@STK[3];
IF .T1[VALTP1] NEQ INTEG1
THEN (.STK[3])<FULL> _ CNVNODE(.T1,INTEGER,0);
END ELSE ( NAMLSTOK _ 1; STK[3]_0 ) ;
SAVSPACE(.R1<LEFT>,@R1);
STK[4]_STK[5]_STK[6]_0;
IF .UPNT[ELMNT1] NEQ 0 THEN !FORMAT, END/ERR
BEGIN
R2_.UPNT[ELMNT2];
T1 _ .R2[ELMNT];
INCR FMT FROM .T1 TO .T1+.T1<LEFT> DO
BEGIN
MAP BASE FMT;
FLAG _ 0; !SIGNAL BLDFORMAT FOR POSSIBLE END= OR ERR=
IF BLDFORMAT(.FMT[ELMNT]) LSS 0 THEN ( NAMLSTOK _ 0; RETURN .VREG);
SAVSPACE(.FMT[ELMNT]<LEFT>,.FMT[ELMNT]);
END;
T1 _ .R2[ELMNT]; SAVSPACE(.T1<LEFT>,.T1);
END;
NAMLSTOK _ 0;
SAVSPACE(.UPNT<LEFT>,@UPNT);
END;
%[760]% GLOBAL ROUTINE BLDKLIST(KLPNT)=
%[760]% BEGIN
%[760]% MAP BASE KLPNT;
%[760]% REGISTER BASE R1:R2:R3;
%[760]% EXTERNAL BLDKEY,SAVSPACE;
%[760]%
%[760]% !--------------------------------------------------------
%[760]% ! This routine is called with KLPNT pointing to a list
%[760]% ! of keyspecs
%[760]% !--------------------------------------------------------
%[760]% R1_.KLPNT[ELMNT];
%[760]% SAVSPACE(.KLPNT<LEFT>,@KLPNT);
%[760]% R2_.R1[ELMNT];
%[760]% SAVSPACE(.R1<LEFT>,@R1);
%[760]%
%[760]% INCR LIST FROM @R2 TO @R2 + .R2<LEFT> DO
%[760]% BEGIN
%[760]% MAP BASE LIST;
%[760]% R3_.LIST[ELMNT];
%[760]% IF BLDKEY(.R3[ELMNT],R3[ELMNT1]) LSS 0 THEN RETURN .VREG;
%[760]% SAVSPACE(.R3<LEFT>,@R3);
%[760]% END;
%[760]% SAVSPACE(.R2<LEFT>,@R2);
%[760]% .VREG
%[760]% END;
%[760]%
%[760]% GLOBAL ROUTINE BLDKEY(KPNT,VALPNT)=
%[760]% BEGIN
%[760]%
%[760]% MAP BASE KPNT;
%[760]% MAP BASE VALPNT;
%[760]% LOCAL SPOS,TYPE,CHOICE,VAR;
%[760]% LABEL FINDK;
%[760]% REGISTER BASE R1:R2:R3;
%[760]% EXTERNAL NAMLSTOK, CGERR;
%[760]% EXTERNAL STK, LABREF, NONIOINIO, SETUSE, BLDVAR;
%[760]% !------------------------------------------------------------
%[760]% ! This routine is called with KPNT pointing to an identifier
%[760]% ! and VALPNT pointing to the list:
%[760]% ! CHOICE - 1 (constant), 2 (variable), 3 (asterisk)
%[760]% ! VALUE - pointer to symbol table entry for the choice
%[760]% !------------------------------------------------------------
%[760]%
%[760]% BIND CONOK = 1^0, ! CONSTANT OK
%[760]% VAROK = 1^1, ! VARIABLE OR ARRAY REF OK
%[760]% ARROK = 1^2, ! ARRAY NAME OR NAMELIST NAME OK
%[760]% LBLOK = 1^3, ! LABEL OK
%[760]% ASTOK = 1^4; ! ASTERISK OK
%[760]%
%[760]% BIND NUMKEYS = 6;
%[760]%
%[760]% BIND KEYWORDS = PLIT (
%[760]% SIXBIT 'END' ,6^18 +LBLOK,
%[760]% SIXBIT 'ERR' ,5^18 +LBLOK,
%[760]% SIXBIT 'FMT' ,4^18 +LBLOK +ARROK +ASTOK,
%[760]% SIXBIT 'IOSTAT' ,7^18 +VAROK,
%[760]% SIXBIT 'REC' ,3^18 +VAROK +CONOK,
%[760]% SIXBIT 'UNIT' ,2^18 +VAROK +CONOK +ASTOK);
%[760]%
%[760]% MACRO STKPOS(I)= (KEYWORDS[I]+1)<LEFT>$,
%[760]% KTYPE(I)= (KEYWORDS[I]+1)<RIGHT>$;
%[760]%
%[760]% MACRO ERR15(X) = (RETURN FATLEX(X,KPNT[IDSYMBOL],E15<0,0>))$,
%[760]% ERR15I(X) = (RETURN FATLEX(INTGPLIT<0,0>, X, E15<0,0>))$,
%[760]% ERR34 = (RETURN FATLEX(PLIT' ',KPNT[IDSYMBOL],E34<0,0>))$;
%[760]% ! Try to match a keyword
%[760]% FINDK: BEGIN
%[760]% INCR I FROM 0 TO (NUMKEYS - 1) * 2 BY 2 DO
%[760]% BEGIN
%[760]% IF .KPNT[IDSYMBOL] EQL @KEYWORDS[.I]
%[760]% THEN
%[760]% BEGIN
%[760]% SPOS_.STKPOS(.I);
%[760]% TYPE_.KTYPE(.I);
%[760]% LEAVE FINDK;
%[760]% END
%[760]% END;
%[760]% ! no match - invalid keyword
%[760]% ERR15( PLIT 'A KEYWORD')
%[760]% END;
%[760]%
%[760]% ! check for redundant keyword
%[760]% IF .STK[.SPOS] NEQ 0 THEN ERR34;
%[760]% CHOICE_.VALPNT[ELMNT];
%[760]% R1_.VALPNT[ELMNT1];
%[760]%
%[760]% CASE .CHOICE OF SET
%[760]% CGERR(); ! FOR SPEED
%[760]% BEGIN ! CONSTANT
%[760]% IF (.TYPE AND CONOK) NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% IF .R1[VALTYPE] NEQ INTEGER THEN ERR15I(R1[IDSYMBOL]);
%[760]% STK[.SPOS]_.R1;
%[760]% END
%[760]% ELSE IF (.TYPE AND LBLOK) NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% IF .R1[VALTYPE] NEQ INTEGER THEN ERR15I(R1[IDSYMBOL]);
%[760]% IF .SPOS EQL 4 THEN NONIOINIO_0 ELSE NONIOINIO_1;
%[760]% ENTRY[1]_.R1[CONST2];
%[760]% R2_LABREF();
%[760]% STK[.SPOS]_@R2;
%[760]% END
%[760]% ELSE ERR15(PLIT 'INTEGER OR LABEL');
%[760]% END;
%[760]% BEGIN ! VARIABLE
%[760]% IF (.TYPE AND VAROK) NEQ 0
%[760]% THEN
%[760]% BEGIN ! VARIABLE OR ARRAY REF
%[760]% IF .SPOS EQL 7 THEN SETUSE_SETT ELSE SETUSE_USE;
%[760]% R2_.R1[ELMNT];
%[760]% IF .R2[VALTYPE] NEQ INTEGER THEN ERR15I(R2[IDSYMBOL]);
%[760]% IF (VAR_BLDVAR(.R1)) LSS 0 THEN RETURN .VREG;
%[760]% ! BLDVAR allows unsubscripted arrays
%[760]% IF .VREG<LEFT> EQL IDENTIFIER
%[760]% THEN
%[760]% BEGIN
%[760]% MAP BASE VREG;
%[760]% IF .VREG[OPRSP1] EQL ARRAYNM1
%[760]% THEN ERR15(PLIT'A SCALAR');
%[760]% END;
%[760]% STK[.SPOS]_.VAR;
%[760]% END
%[760]% ELSE IF (.TYPE AND ARROK) NEQ 0
%[760]% THEN
%[760]% BEGIN ! ARRAY OR NAMELIST NAME
%[760]% R2_.R1[ELMNT];
%[760]% IF .R2[OPRSP1] EQL ARRAYNM1
%[760]% THEN
%[760]% BEGIN
%[760]% STK[.SPOS]_.R2;
%[760]% IF .TYPE EQL READD
%[760]% THEN NAMSET(ARRAYNM1, .R2)
%[760]% ELSE NAMREF(ARRAYNM1, .R2);
%[760]% IF .VREG LSS 0 THEN RETURN .VREG;
%[760]% END
%[760]% ELSE IF .NAMLSTOK NEQ 0 THEN
%[760]% IF .R2[IDATTRIBUT(NAMNAM)]
%[760]% THEN
%[760]% BEGIN
%[760]% LOCAL NAMROUT; !TO PUT ROUTINE TO CALL
%[760]% LOCAL BASE NMLST:NAMCOM;
%[760]% STK[.SPOS]_@R2;
%[760]% IF NAMREF( NMLSTREF,.R2) LSS 0 THEN RETURN .VREG;
%[760]% NAMROUT _ IF .TYPE EQL READD THEN NAMSET ELSE NAMREF; !DETERMINE ROUTINE TO CALL
%[760]% NAMCOM_.R2[IDCOLINK]; !GET POINTER TO NAMELIST NODE
%[760]% NMLST_.NAMCOM[NAMLIST]; !GET POINTER TO LIST OF ITEMS
%[760]% WHILE .NMLST LSS (.NAMCOM[NAMLIST] + .NAMCOM[NAMCNT]) DO
%[760]% BEGIN
%[760]% R3 _ .NMLST[ELMNT];
%[760]% (.NAMROUT)(.R3[OPRSP1],.R3); !CALL THE ROUTINE
%[760]% NMLST _ .NMLST+1; !NEXT ITEM
%[760]% END; !OF WHILE ... DO
%[760]% END
%[760]% ELSE ERR15(PLIT'ARRAY OR NAMELIST NAME')
%[760]% ELSE ERR15(PLIT'ARRAY NAME');
%[760]% END
%[760]% ELSE ERR15(PLIT'ALLOWED');
%[760]% END; ! VARIABLE
%[760]% BEGIN ! ASTERISK
%[760]% IF (.TYPE AND ASTOK) NEQ 0
%[760]% THEN STK[.SPOS]_-1
%[760]% ELSE ERR15(PLIT'ALLOWED');
%[760]% END;
%[760]% TES;
%[760]%
%[760]% .VREG
%[760]%
%[760]% END; ! BLDKEY
%[760]%
%[760]% GLOBAL ROUTINE KORFBLD(FPNT)=
%[760]% BEGIN
%[760]% MACRO ERR15(X) = (RETURN FATLEX(X,R2[IDSYMBOL],E15<0,0>))$;
%[760]%
%[760]% EXTERNAL BLDKEY,SAVSPACE,SETUSE,NAMLSTOK, CGERR;
%[760]% REGISTER BASE T1:R1:R2:R3;
%[760]% MAP BASE FPNT;
%[760]% !---------------------------------------------------------
%[760]% ! This routine is called with FPNT pointing to the list:
%[760]% ! choice 1 - label
%[760]% ! pointer to label
%[760]% ! or
%[760]% ! choice 2 - variablespec or keyword
%[760]% ! pointer to list:
%[760]% ! variablespec
%[760]% ! option if keyword
%[760]% ! pointer to choice of constant, variable,
%[760]% ! or asterisk
%[760]% ! or
%[760]% ! choice 3 - asterisk
%[760]% !----------------------------------------------------------
%[760]%
%[760]% SETUSE _ USE;
%[760]% CASE .FPNT[ELMNT] OF SET
%[760]% CGERR(); ! FOR SPEED
%[760]% BEGIN ! LABEL
%[760]% STK[4] _ .FPNT[ELMNT1];
%[760]% END;
%[760]% BEGIN ! VARIABLESPEC OR KEYWORD
%[760]% R1 _ .FPNT[ELMNT1];
%[760]% IF .R1[ELMNT1] EQL 0
%[760]% THEN
%[760]% BEGIN ! ARRAY OR NAMELIST NAME
%[760]% R3_.R1[ELMNT];
%[760]% R2_.R3[ELMNT];
%[760]% IF .R2[OPRSP1] EQL ARRAYNM1
%[760]% THEN
%[760]% BEGIN
%[760]% STK[4]_.R2;
%[760]% IF .TYPE EQL READD
%[760]% THEN NAMSET(ARRAYNM1, .R2)
%[760]% ELSE NAMREF(ARRAYNM1, .R2);
%[760]% IF .VREG LSS 0 THEN RETURN .VREG;
%[760]% END
%[760]% ELSE IF .NAMLSTOK NEQ 0 THEN
%[760]% IF .R2[IDATTRIBUT(NAMNAM)]
%[760]% THEN
%[760]% BEGIN
%[760]% LOCAL NAMROUT; !TO PUT ROUTINE TO CALL
%[760]% LOCAL BASE NMLST:NAMCOM;
%[760]% STK[4]_@R2;
%[760]% IF NAMREF( NMLSTREF,.R2) LSS 0 THEN RETURN .VREG;
%[760]% NAMROUT _ IF .TYPE EQL READD THEN NAMSET ELSE NAMREF; !DETERMINE ROUTINE TO CALL
%[760]% NAMCOM_.R2[IDCOLINK]; !GET POINTER TO NAMELIST NODE
%[760]% NMLST_.NAMCOM[NAMLIST]; !GET POINTER TO LIST OF ITEMS
%[760]% WHILE .NMLST LSS (.NAMCOM[NAMLIST] + .NAMCOM[NAMCNT]) DO
%[760]% BEGIN
%[760]% R3 _ .NMLST[ELMNT];
%[760]% (.NAMROUT)(.R3[OPRSP1],.R3); !CALL THE ROUTINE
%[760]% NMLST _ .NMLST+1; !NEXT ITEM
%[760]% END; !OF WHILE ... DO
%[760]% END
%[760]% ELSE ERR15(PLIT'ARRAY OR NAMELIST NAME')
%[760]% ELSE ERR15(PLIT'ARRAY NAME');
%[760]% END
%[760]% ELSE
%[760]% BEGIN ! KEYWORD
%[760]% R2 _ .R1[ELMNT];
%[760]% IF BLDKEY(.R2[ELMNT],.R1[ELMNT2]) LSS 0 THEN RETURN .VREG;
%[760]% R3 _ .R1[ELMNT2];
%[760]% SAVSPACE(.R3<LEFT>,@R3);
%[760]% END;
%[760]% END;
%[760]% BEGIN ! ASTERISK
%[760]% STK[4] _ -1;
%[760]% END;
%[760]% TES;
%[760]% .VREG
%[760]% END; ! KORFBLD
END
ELUDOM