!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 THEN CREFIT( .ID, SETT ); % CHECK THE ATTRIBUTES % IF ( R _ .DEFMASK[.TYPE] 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 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 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 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 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+.T1DO BEGIN MAP BASE ALST; T2_.T2+1; IF .ALST[ELMNT] EQL 1 THEN !DUMMY ARGUMENT BEGIN T2[ELMNT]_R2_.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 EQL FNPROG THEN IF .R2 EQL .R1 THEN ! ARGUMENT IS SAME AS FUNCTION FATLEX( R2[IDSYMBOL], E71<0,0>); END ELSE( EXTERNAL E129; FLGREG _ 1; !SET DUMMY LABLES FLAG IF .FLGREG 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,@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 _ T2_ .T2+2; !ARG BLOCK CONTAINS 2+ NUM OF ARGS T2_.T2-1+(T1_R2_CORMAN()); T1_STK[2]<0,0>; BLT(T1,0,T2);!COPY ARG LIST FROM STACK END; NAME_IDOFSTATEMENT_ENTRDATA;NAME_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,@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 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 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,@R2) ! END; ! SAVSPACE(.R1,@R1); !SAVE CONSTANT SPACE ! END; ! END; SAVSPACE(.T2,@T2); !SAVE CONSTANT LIST SPACE SAVSPACE(.T1,.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; 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],ASIZE=STK[3],AOFF=STK[4],MF=1,OS=2,SZ=3; %[V5]% BIND DLBL = STK [5] , ! TEMP ARADLBL %[V5]% ALINK = STK [5] , ! TEMP ARALINK %[V5]% A0F = STK [7] ; ! 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 _ 2; !2 WORD ENTRIES R1 _ CORMAN(); IF .DIMSTK EQL 0 THEN BEGIN DIMSTK _ .R1 END; (.R1) _ .DIMSTK; DIMSTK _ .R1; (.R1+1) _ .PTR; (.R1+1)_ .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 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,.SAVPTR); END TES; T1_.SS[ELMNT]; !FOR SAVSPACE CALL SAVSPACE(.T1,.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 NEQ SUPROG AND .FLGREG 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_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 ; %[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 _ MAKECNST(INTEGER,0,.AOFF); !MAKE CONST NODE FOR OFFSET VALUE SAVSPACE(.SSLST,@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_T2_DIMSIZ+.DNUM*DIMSUBSIZE; T2 _ .T2-1; !ONE LESS FOR UPCOMING BLT T2_.T2+(T1_(NAME_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 ; ! LINK THIS ENTRY INTO LIST %[V5]% DTABPTR _ .T1; ! NEW LIST HEAD BEGIN LOCAL SAVT1; T1_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 EQL 0 THEN BEGIN CBLOCK_CBLOCK_@T1; END ELSE BEGIN CBLOCK[IDCOLINK]_@T1;CBLOCK_@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 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; %[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 !IF SS BOUNDS CHECKING IS TO BE PERFORMED ! ON ALL ARRAYS (USER "BOUNDS" SWITCH) OR .FLGREG !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,@R1); END;SAVSPACE(.LPNT,@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; 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_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 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_ARRAYREF; END; SAVSPACE(.VPNT,@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 _ 2; ! LINK IN NEW LABEL %[572]% TEMP _ CORMAN (); %[572]% TEMP [ELMNT] _ .LASDOLABEL; ! SAVE LAST %[572]% TEMP [ELMNT1] _ .CURDOINDEX; ! SAVE INDEX %[572]% LASDOLABEL _ .TEMP; %[572]% LASDOLABEL _ 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_ 3;SLISTCALL) ELSE DATACALL ); R1_NEWENTRY(); R1[OPERSP] _ .IDOFSTATEMENT; !DATACALL OR SLISTCALL IF .LISTLINK EQL 0 THEN (LISTLINK_LISTLINK_.R1) ELSE (LISTLINK[CLINK] _ .R1; LISTLINK_.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 _ IOLTAB; T1_NEWENTRY(); T1[CLINK]_ .X; X_ .T1; T1[OPRCLS]_STATEMENT; T1[DOLBL] _ .IOLBL; !PSEUDO LABEL MADE BY IOCONTNODE T2_.IOLBL[SNDOLNK]; IOLBL[SNDOLVL] _ .IOLBL[SNDOLVL]+1; NAME _ 1; IOLBL[SNDOLNK] _ CORMAN(); (.VREG)_.T1; (.VREG)_.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 _ 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 _ .T1; ! POINT TO NEW END OF DATALIST %[572]% END$; LOCAL BASE LISTLINK; !PTR TO FIRST AND LAST 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; !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_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 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 EQL 1 THEN RETURN FATLEX (E128<0,0>); T1_@R2+.R2; 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_.R2-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; !SET UP BY IODONODE DONOD[DOSYM]_.TDOSYM; !STK[2]_LOC(INDEX VARIABLE) R2_.R1[ELMNT2]; SAVSPACE(.R1,.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; END; IF .TYPE EQL DATALST THEN IF .SP GTR 0 THEN ( DATASUBCHK(.DONOD[CLINK],.SP,STK[1]<0,0>); SP _ .SP-1; ); SAVSPACE(.R2,.R2); END; IF .LISTLINK EQL 0 THEN LISTLINK_.LNKLST ELSE (LISTLINK[CLINK]_.LNKLST; LISTLINK _ .LNKLST ); END; END; FLGREG_.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,@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 %:**;[235],ROUTINE BLDFORMAT, REPLACE @ LINE 4816,DT/MD,11/18/74 % %[235]% LOCAL NAMROUT; !TO PUT ROUTINE TO CALL %[235]% LOCAL BASE NMLST:NAMCOM; STK[4]_@R2; %[235]% IF NAMREF( NMLSTREF,.R2) LSS 0 THEN RETURN .VREG; %[235]% %NOTE REFERENCE OR SETTING OF EACH ITEM IN LIST % %[235]% NAMROUT _ IF .TYPE EQL READD THEN NAMSET ELSE NAMREF; !DETERMINE ROUTINE TO CALL %[235]% NAMCOM_.R2[IDCOLINK]; !GET POINTER TO NAMELIST NODE %[235]% NMLST_.NAMCOM[NAMLIST]; !GET POINTER TO LIST OF ITEMS %[235]% WHILE .NMLST LSS (.NAMCOM[NAMLIST] + .NAMCOM[NAMCNT]) DO %[235]% BEGIN %[235]% R1 _ .NMLST[ELMNT]; %[235]% (.NAMROUT)(.R1[OPRSP1],.R1); !CALL THE ROUTINE %[235]% NMLST _ .NMLST+1; !NEXT ITEM %[235]% END; !OF WHILE ... DO %[235]% 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,@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 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 %**;[232], ROUTINE BLDUNIT , REPLACE @ LINE 4885 , MD,11/18/74 % %[232]% STK[3] _ .R1[ELMNT3]; %[232]% T1 _ @@STK[3]; IF .T1[VALTP1] NEQ INTEG1 %[232]% THEN (.STK[3]) _ CNVNODE(.T1,INTEGER,0); END ELSE ( NAMLSTOK _ 1; STK[3]_0 ) ; SAVSPACE(.R1,@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 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],.FMT[ELMNT]); END; T1 _ .R2[ELMNT]; SAVSPACE(.T1,.T1); END; NAMLSTOK _ 0; SAVSPACE(.UPNT,@UPNT); END; END ELUDOM