Trailing-Edge
-
PDP-10 Archives
-
BB-4157D-BM
-
sources/outmod.bli
There are 26 other files named outmod.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) 1973,1977 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: F. INFANTE/MD/DCE/JNG
MODULE OPMOD(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE REQREL.BLI;
SWITCHES LIST;
GLOBAL BIND OPMOV = 5^24 + 1^18 + 72; !VERSION DATE: 9-AUG-77
%(
REVISION HISTORY
44 ----- ----- MODIFY "PROCEQUIV" TO TURN OFF THE "BOUNDS" FLAG
WHEN ARRXPN IS CALLED FOR AN EQUIVALENCE STMNT
45 ----- ----- MOVE DECLARATIONS OF LOADER BLOCK TYPES TO A
REQUIRE FILE.
46 ----- ----- REMOVE THE ROUTINES "ZOUTBLOCK" (WHICH
HAS MOVED TO THE MODULE "RELBUF") AND "ZDMPBLK"
(WHICH IS NO LONGER NEEDED)
ALSO REMOVE THE ROUTINE "DATAOUT" AND CHANGE "OUTDATA"
TO CALL "ZOUTBLOCK" RATHER THAN "DATAOUT". ALSO
CHANGE OUTDATA TO CALL "DMPRLBLOCK" OF "MAINRLBF"
WHEN THE BUFFER DOESNT HAVE ENOUGH ROOM RATHER
THAN CALLING "ZDMPBLK".
47 ----- ----- REMOVE DEFINITIONS OF CBLK AND ZDATCNT AND ALL
REFERENCES TO THEM.
ALSO, REMOVE ALL REFERENCES TO "RELOCPTR" AND
"RELBLOCK".
48 ----- ----- MODIFY "RELINIT" TO CALL "INITRLBUFFS" TO INITIALIZE
THE REL FILE BUFFERS.
49 ----- ----- DELETE THE ROUTINE "DMPRELONLS"
50 ----- ----- DELETE THE ROUTINES:
ZOUTMSG,ZOUTSYM,ZOUTOCT,RADIX50,ZOUDECIMAL,
ZOUOFFSET
51 ----- ----- MISSPELLED "INIRLBUFFS" (IN "RELINIT")
THESE HAVE BEEN MOVED TO THE MODULE "RELBUFF"
52 ----- ----- TAKE OUT THE DEF OF THE ROUTINE "CRLF" - IT IS
NOW A MACRO DEFINED IN THE REQUIRE FILE
"REQREL"
53 ----- ----- IN "OUTDATA", CALL "DMPMAINRLBF" TO CLEAR THE MAIN
REL FILE BUFFER RATHER THAN CALLING "DMPRLBLOCK"
DIRECTLY (SINCE DMPRLBLOCK DOES NOT REINIT THE BUFFER)
54 ----- ----- IN "DMPFORMAT", CALL "DMPMAINRLBF" RATHER THAN
DMPRLBLOCK
55 ----- ----- TAKE OUT UNUSED ROUITNE ROUIMFUN
56 ----- ----- CHANGE THE CHECKS IN VARIABLE ALLOCATION TTO
WORK PROPERLY
PUT IN LISTING HEADING CHECKS
PUT OUT A VALID ENTRY NAME BLOCK
57 ----- ----- IN "OUTDATA" PUT A CHECK FOR WHETHER A REL FILE
IS BEING PRODUCED (SINCE WANT TO EXECUTE
THE MAIN DATA STMNT PROCESSOR FOR ERROR
DETECTION EVEN IF NO REL FILE IS PRODUCED)
58 ---- ---- GRPSCAN - MAKE IT PUT THE COMMON VARIABLE IN AN
EQUIVALENCE GROUP FIRST IN THE LIST SO ITS
DISPLACEMENT WILL BE CALCULATED FIRST IF IT WAS
DELAYED.
ALSO CHECK FOR TWO COMMON VARIABLES IN EQUVALENCE
PROCEQUIV - CHECK TO BE SURE THAT AT LEAST IN THE
SINGLE SUBSCRIPT CASE THE EQUIVALENCE IS AN INTEGER
CONSTANT. NO VARIABLES OR EXPRESSIONS
59 ----- ---- CHECK POSITIVE AND NEGATIVE RANGE LIMITS
OF EQUIVALENCE SUBSCRIPTS
60 ----- ----- IN "ALLFORM", PUT THE ADDRESS OF THE FORMAT
INTO THE SNUMBER TABLE ENTRY FOR ITS LABEL
61 ----- ----- SET THE GLOBAL "ENDSCAA" TO THE ADDR AFTER END
OF ALL ARRAYS AND SCALARS
62 ----- ----- LISTSYM - SUBPROGLIST - ALLSCA
OUTPUT A WARNING PREFIX CHARACTER AFTER
VARIABLES, ARRAYS WHICH WERE NEVER EXPLICITLY
DEFINED OR WERE EXPLICITLY DEFINED BUT NEVER
REFERENCED
* - NOT EXPLICITLY DEFINED
PERCENT SIGN - DEFINED BUT NOT REFERENCED
63 236 14654 EQUIVALENCE ARRAY1-ARRAY2 FAILS AFTER ARRAY1-SCALAR
64 241 ----- CORRECT HIGH SEG START ADDR FOR LINK
IF LOW SEG SIZE IS GREATER THAN 128K
65 337 17305 ROUND UP IMMEDIATE CONSTANTS CORRECTLY
66 364 18251 CORRECT EQUIVALENCE PROCESSING
67 436 19427 DON'T ALLOW 2 BLOCK COMMON VARIABLES TO
BE EQUIVALENCED IF BLOCKS ARE DIFFERENT
68 470 20744 MAKE SURE HIGH SEG STARTS AT LEAST 1000 LOCS
ABOVE END OF LOW SEG
69 472 20494 IF COMMON ITEM IS LAST IN GROUP,
MOVE IT TO BEGINNING CORRECTLY
70 473 20478 SCALARS AND ARRAYS LISTING TOO WIDE
71 474 20479 SHOULD GIVE CRLF AFTER COMMON BLOCK NAMES
***** BEGIN VERSION 5A *****
72 604 23425 FIX LISTING OF COMMON BLOCK ELEMENTS
)%
EXTERNAL ZOUTMSG,ZOUTSYM,ZOUTOCT,RADIX50,ZOUDECIMAL,ZOUOFFSET;
EXTERNAL ZOUTBLOCK;
EXTERNAL STRNGOUT,CHAROUT;
EXTERNAL RDATWD,LSTOUT,FATLERR,RELDATA,RELBLOCK,HILOC,RELOCWD,RELOUT;
FORWARD ALLFORM,PROCCOM,PROCEQUIV;
EXTERNAL HEADCHK;
GLOBAL ROUTINE OUTDATA(SYMADDR,SYMVALUE,SYMPT)=
BEGIN
%
ROUTINE INSTRUCTS LOADER ABOUT INITIALIZATION OF LOW SEG DATA AS SPECIFIED
IN DATA STATEMENTS. SYMPT IS PTR TO SYMBOL BEING INITIALIZED.
SYMVALUE IS VALUE TO USE IN ITIALIZATION. SYMADDR IS THE ALLOCATED
ADDRESS OF THE SYMBOL
%
EXTERNAL DMPMAINRLBF; !ROUTINE TO OUTPUT THE CONTENTS OF THE MAIN
! REL FILE BUFFER AND REIINITIALIZE IT
EXTERNAL MAINRLBF; !MAIN REL FILE BUFFER
MAP RELBUFF MAINRLBF;
MAP BASE R2:SYMPT;
BIND RDATBLK = #21; !LOADER BLOCK TYPE FOR DATA FIXUP
IF NOT .FLGREG<OBJECT> THEN RETURN; !IF NO REL FILE IS TO BE PRODUCED
IF .SYMPT[IDATTRIBUT(INCOM)]
THEN BEGIN !DO SPECIAL BLOCK 1 FIXUP
IF .MAINRLBF[RDATCNT] GTR RBLKSIZ-5 !NO ROOM LEFT IN BUFFER FOR NEXT
! 3 WDS
THEN DMPMAINRLBF();
R2 _ .SYMPT[IDCOMMON]; !PTR TO COMMON BLOCK NODE
R2 _ .R2[COMNAME];
RDATWD _ RGLOBREQ + RADIX50();
ZOUTBLOCK(RDATBLK,RELN);
RDATWD _ (1^18) + .SYMADDR<RIGHT>;
ZOUTBLOCK(RDATBLK,RELN);
RDATWD _ .SYMVALUE;
ZOUTBLOCK(RDATBLK,RELN);
END
ELSE BEGIN
IF .MAINRLBF[RDATCNT] GTR RBLKSIZ-4
THEN DMPMAINRLBF(); !NO ROOM LEFT IN BUFFER FOR 2 WORDS
RDATWD _ (1^18)+.SYMADDR<RIGHT>;
ZOUTBLOCK(RDATBLK,RELRI);
RDATWD _ .SYMVALUE;
ZOUTBLOCK(RDATBLK,RELN);
END;
END; !OF OUTDATA
ROUTINE LISTSYM(PTR)=
BEGIN
EXTERNAL LSTOUT,ZOUTSYM,ZOUTOCT,ZOUTMSG,PROGNAME;
EXTERNAL CHAROUT;
MAP BASE PTR;
LABEL BLNK;
R2 _ .PTR[IDSYMBOL];
% NOTE INSTANCES OF NO EXPLICIT DEFINITION %
BLNK:BEGIN
IF NOT .PTR[IDATTRIBUT(INTYPE)]
THEN IF .PTR[OPRSP1] NEQ ARRAYNM1
THEN
IF .R2<30,6> NEQ SIXBIT"." !FORGET COMPLER DEFINED VARS
THEN ( CHAROUT( "*" ); LEAVE BLNK );
CHAROUT( " " );
END; %BLNK%
ZOUTSYM();
CHR _ #11; LSTOUT(); !TAB
R2<LEFT> _ .PTR[IDADDR]; ZOUTOCT();
CHR_#11;LSTOUT();!TAB
END;
ROUTINE SUBPROGLIST=
BEGIN
!
!LISTS CALLED SUBPROGRAMS ON LIST DEVICE IN ALLOCATION SUMMARY
!
EXTERNAL LSTOUT,ZOUTSYM,ZOUTMSG,PROGNAME;
EXTERNAL HEADCHK; !CHECKS FOR END OF LISTNG PAGE
LOCAL BASE SYMPTR,COUNT;
EXTERNAL HEADING,PAGELINE;
IF ( PAGELINE_.PAGELINE-4) LEQ 0
THEN ( HEADING(); PAGELINE_.PAGELINE-4);
STRNGOUT(PLIT'?M?J?M?JSUBPROGRAMS CALLED?M?J?M?J?0');
DECR I FROM SSIZ-1 TO 0 DO
BEGIN
IF (SYMPTR _ .SYMTBL[.I]) NEQ 0
THEN DO BEGIN
IF .SYMPTR[OPRSP1] EQL FNNAME1
THEN IF NOT .SYMPTR[IDATTRIBUT(NOALLOC)]
THEN BEGIN
R2 _ .SYMPTR[IDSYMBOL]; ZOUTSYM();
IF (COUNT _ .COUNT+1) GTR 5
THEN (COUNT _ 0; CRLF; HEADCHK())
ELSE (C _ #11; LSTOUT());
END;
END WHILE (SYMPTR _ .SYMPTR[CLINK]) NEQ 0;
END;
CRLF;
HEADCHK();
END; !OF ROUTINE SUBPROGLIST
ROUTINE ALLSCAA= !ALLOCATES STORAGE TO LOCAL SCALARS AND
!ARRAYS (NOT IN COMMON AND NOT IN EQUIVALENCE LISTS)
!SEARCHES SYMTBL
!ASSUMES ALL FIXUPS AND ALLOCATION FOR COMMON AND EQUIVALENCE
!HAVE ALREADY BEEN DONE.
BEGIN
OWN PTR,SCNT;
EXTERNAL LSTOUT,LOWLOC,ZOUTSYM,ZOUTOCT,ZOUTMSG,PROGNAME;
EXTERNAL ENDSCAA;
LOCAL BASE ARRAPT;
LABEL L1,L2;
MAP BASE PTR;
SCNT_0;
IF .FLGREG<LISTING>
THEN
BEGIN
EXTERNAL HEADING,PAGELINE;
IF ( PAGELINE_.PAGELINE-4) LEQ 0
THEN ( HEADING(); PAGELINE_ .PAGELINE-4);
STRNGOUT(PLIT '?M?JSCALARS AND ARRAYS [ "*" NO EXPLICIT DEFINITION - "%" NOT REFERENCED ]?M?J?M?J');
END;
DECR I FROM SSIZ-1 TO 0 DO
BEGIN
IF (PTR _ .SYMTBL[.I]) NEQ 0
THEN BEGIN
DO BEGIN
L1: IF NOT .PTR[IDATTRIBUT(INCOM)]
AND NOT .PTR[IDATTRIBUT(NAMNAM)]
AND NOT .PTR[OPERSP] EQL FNNAME
%ALLOCATE SPACE FOR FORMAL FUNCTIONS%
THEN
IF NOT .PTR[IDATTRIBUT(NOALLOC)]
THEN( IF NOT .PTR[IDATTRIBUT(INEQV)]
%EQUIVALENCED VARS ARE LISTED BUT NOT ALLOCATED HERE%
THEN
L2:BEGIN
!
!ALLOACATE AN ADDRESS ONLY IF ALL ABOVE TESTS PASSED
!
PTR[IDADDR] _ .LOWLOC;
IF .PTR[OPRSP1] EQL ARRAYNM1 !IS IT AN ARRAY?
THEN( ARRAPT _ .PTR[IDDIM]; !PTR TO DIMENSION NODE
IF NOT .PTR[IDATTRIBUT(DUMMY)]
THEN (
LOWLOC _ .LOWLOC+ .ARRAPT[ARASIZ];
LEAVE L2;
)
ELSE IF NOT .ARRAPT[ADJDIMFLG]
THEN (LOCAL BASE PTRVAR;
PTRVAR _ .ARRAPT[ARADDRVAR];
PTRVAR[IDADDR] _ .LOWLOC;
);
LOWLOC _ .LOWLOC + 1;
LEAVE L2
);
IF .PTR[DBLFLG] !IS THE VARIABLE DOUBLE LENGTH?
THEN LOWLOC _ .LOWLOC + 2
ELSE LOWLOC _ .LOWLOC + 1
END;
IF .FLGREG<LISTING>
THEN
BEGIN
LISTSYM(.PTR);
!**;[473], ALLSCAA @3440, DCE, 8-OCT-76
!**;[473], LISTING FOR SCALARS AND ARRAYS IS A BIT TOO WIDE
%[473]% IF .SCNT LSS 4 THEN SCNT _ .SCNT+1 ELSE (SCNT _ 0; CRLF; HEADCHK());
END;
)
ELSE
BEGIN
IF .FLGREG<LISTING>
THEN
BEGIN
%NOTE NAMES WHICH HAVE BEEN DECLARED
BUT NEVER REFERENCED AND THUS NEVER
ALLOCATED%
IF .PTR[OPRSP1] EQL ARRAYNM1
OR .PTR[IDATTRIBUT(INTYPE)]
OR .PTR[IDATTRIBUT(DUMMY)]
THEN
BEGIN
R2_.PTR[IDSYMBOL];
CHAROUT("%");
ZOUTSYM();
CHAROUT(#11); !TAB
CHAROUT(#11); !TAB
!**;[473], ALLSCAA @3461, DCE, 8-OCT-76
!**;[473], LISTING FOR SCALARS AND ARRAYS IS A BIT TOO WIDE
%[473]% IF .SCNT LSS 4 THEN SCNT _ .SCNT+1 ELSE (SCNT _ 0; CRLF; HEADCHK());
END
END
END;
END WHILE (PTR _ .PTR[CLINK]) NEQ 0
END
END;
IF .FLGREG<LISTING> THEN (CRLF; HEADCHK() );
ENDSCAA_.LOWLOC; !LOC AFTER LAST ARRAY/SCALAR
END;
!THE ROUTINES IN THIS MODULE ARE FOR THE PURPOSE
!OF GENERATING THE FOLLOWING THINGS:
% THE CORRECT ALLOCATION OF ADDRESSES TO THE VARIABLES,ARRAYS
CONSTANTS,STRINGS ETC., IN THE SUBPROGRAM BEING COMPILED
.THE STATISTICS LISTING OF THE SCALARS,ARRAYS ,COMMON,
CONSTANTS,TEMPORARIES ETC. THAT THE SUBPROGRAM DEFINES.
%
!
ROUTINE ALLCOM=
BEGIN
%ROUTINE ALLOCATES RELATIVE ADDRESSES TO ALL VARIABLES DECLARED IN COMMON.
THE ADDRESSES OF THE VARIABLES / ARRAYS IN A COMMON BLOCK ARE ARLATIVE TO THE
BEGINNING OF THE BLOCK IN WHICH THEY ARE DECLARED. EACH BLOCK HAS AN ORIGIN
OF ZERO. AT LOAD TIME THE LOADER WILL ASSIGN ACTUAL LOCATIONS TO
COMMON BLOCKS BASED ON THEIR SIZES AND ORDER OF
APPEARANCE TO LOADER. IN THE RLOACTABLE BINARY, REFERENCES TO
COMMON VARIABLES WILL USE ADDITIVE GLOBAL FIXUPS.
THE CALL TO THIS ROUTINE OCCURS AFTER ANY EQUIVALENCE RELATIONS
HAVE BEEN PROCESSED BY ROUTINE PROCEQUIV
%
REGISTER ICNT;
EXTERNAL COMBLKPTR,EQVPTR;
REGISTER BASE CSYMPTR;
LOCAL BASE CCOMPTR;
MACRO COMBLOK=#20$;
ICNT _ 0;
IF .FLGREG<LISTING>
THEN
BEGIN
EXTERNAL HEADING,PAGELINE;
IF ( PAGELINE_.PAGELINE-4) LEQ 0
THEN ( HEADING(); PAGELINE_ .PAGELINE-4);
STRNGOUT(PLIT'?M?J?M?JCOMMON BLOCKS?M?J?0');
END;
CCOMPTR _ .FIRCOMBLK; !PTR TO FIRST COMMON BLOCK DECLARED
WHILE 1 DO %1%
BEGIN
!START BY OUTPUTTING NAME OF BLOCK
IF .FLGREG<LISTING> THEN
BEGIN
CRLF;
HEADCHK();
CHR_"/";LSTOUT();
R2 _ .CCOMPTR[COMNAME]; ZOUTSYM();
CHR _ "/"; LSTOUT();
CHR _ "("; LSTOUT(); R1 _ .CCOMPTR[COMSIZE]; ZOUOFFSET(); CHR _ ")"; LSTOUT();
END;
!RELOCATABLE BINARY IF NECESSARY
IF .FLGREG<OBJECT>
THEN (R2 _ .CCOMPTR[COMNAME]; !FOR RADIX 50 CONVERSION
RDATWD_RGLOBDEF+RADIX50(); ZOUTBLOCK(COMBLOK,RELN);
RDATWD_ .CCOMPTR[COMSIZE]; ZOUTBLOCK(COMBLOK,RELN);
);
!NOW LIST THE SYMBOLS IN THE BLOCK
IF .FLGREG<LISTING> THEN
BEGIN
CSYMPTR _ .CCOMPTR[COMFIRST];
CRLF;!CR/LF
HEADCHK();
WHILE 1 DO %2%
BEGIN
R2 _ .CSYMPTR[IDSYMBOL]; ZOUTSYM();
CHR _ #11; LSTOUT(); !TAB
R1 _ .CSYMPTR[IDADDR]; ZOUOFFSET();
!**;[474], ALLCOM @3540, DCE, 11-OCT-76
!**;[474], BE SURE TO OUTPUT CRLF AFTER LAST COMMON BLOCK NAME
%[474]% IF (CSYMPTR _ .CSYMPTR[IDCOLINK]) EQL 0 THEN
!**;[604], ALLCOM @3565, DCE, 9-AUG-77
!**;[604], RESET ICNT SO THAT WE DO NOT GET LINE WITH SINGLE
!**;[604], ELEMENT BY ACCIDENT!
%[604][474]% (IF .ICNT NEQ 0 THEN (ICNT_0; CRLF; HEADCHK());
%[474]% EXITLOOP);
IF (ICNT _ .ICNT +1) EQL 5
THEN (ICNT _ 0; CRLF; HEADCHK()) ELSE (CHR _ #11; LSTOUT() %TAB% );
END; !OF %2%
END;
IF (CCOMPTR _ .CCOMPTR[NEXCOMBLK]) EQL 0 THEN RETURN;
END
END; !OF ALLCOM ROUTINE
ROUTINE ALLOCAT=
BEGIN
%ALOCATES RELATIVE ADDRESSES TO ALL VARIABLES AND STORAGE
IN THE LOW SEGMENT,EXCEPT TEMPORARIES WHICH ARE ALLOCATED AFTER
CODE GENERATION.
THIS ROUTINE CONTROLS THE ALLOCATION BY CALLING THE ACTUAL ROUTINES
THAT DO THE ALLOCATION AND PROCESSING OF VARIABLES,COMMON BLOCKS,EQUIVALENCE
GROUPS ,DATA FIXUPS ETC.
%
EXTERNAL LSTOUT,FATLERR,FORMPTR,COMBLKPTR,EQVPTR,
LOWLOC, !LOW SEG AVAILABLE ADDRESS
COMSIZ; !CURRENT TOTAL SIZE OF COMMON INCLUDING BLANK
COMSIZ _ 0;
IF .COMBLKPTR NEQ 0 THEN COMSIZ _ PROCCOM(); ! PROCESS COMMON BLOCKS
IF .EQVPTR NEQ 0 THEN PROCEQUIV(); !PROCESS EQUIVALENCE GROUPS
IF .COMBLKPTR NEQ 0 THEN ALLCOM(); !ALLOCATE COMMON NOW
!
!NOW ALLOCATE AND LIST ALL VARIABLES,ARRAYS ETC.
!
!LIST SUBPROGRAMS CALLED IF ANY
!
IF .FLGREG<LISTING> THEN SUBPROGLIST();
ALLSCAA(); !ALLOCATE SCALARS AND ARRAYS
IF .FORMPTR NEQ 0 THEN ALLFORM(); !ALLOCATE FORMAT STRINGS
END;
ROUTINE DMPFORMAT=
BEGIN
!
!DUMPS FORMAT STRING DEFINITIONS TO REL FILE AFTER ALL LOWSEG
!ALLOCATION HAS BEEN DONE
!
LOCAL SAVHILOC;
REGISTER BASE ZFORPTR;
EXTERNAL LOWLOC,FORMPTR,HILOC,DMPMAINRLBF;
ZFORPTR _ .FORMPTR<LEFT>; !PTR TO FIRST FORMAT STRING
SAVHILOC _ .HILOC; HILOC _ .ZFORPTR[FORADDR]; !TO PUT DATA BLOCK IN LOWSEG
DO
BEGIN
INCR I FROM 0 TO .ZFORPTR[FORSIZ]-1 DO
(RDATWD _ .(.ZFORPTR[FORSTRING])[.I]<FULL>;
ZOUTBLOCK(RCODE,RELN);
HILOC _ .HILOC+1; !INCREMENT FOR POSSIBLE USE IN ZOUTBLOCK
);
END WHILE (ZFORPTR _ .ZFORPTR[FMTLINK]) NEQ 0;
DMPMAINRLBF(); !DUMP OUT THE CODE BLOCK IMMEDIATELY
HILOC _ .SAVHILOC;
RETURN .VREG
END;
ROUTINE ALLFORM=
BEGIN
%ALLOCATES LOW SEG STORAGE ADDRESS TO FORMAT STRINGS
BUT DOES NOT TELL THE LOADER YET
%
REGISTER BASE ZFORPTR;
EXTERNAL LOWLOC,FORMPTR,HILOC;
ZFORPTR _ .FORMPTR<LEFT>; !PTR TO FIRST FORMAT STRING
WHILE 1 DO
BEGIN
REGISTER BASE SNUMENTRY;
SNUMENTRY_.ZFORPTR[SRCLBL];
ZFORPTR[FORADDR] _ .LOWLOC;
SNUMENTRY[SNADDR]_.LOWLOC; !SET ADDRESS OF THE LABEL
LOWLOC _ .LOWLOC+.ZFORPTR[FORSIZ];
IF .ZFORPTR[FMTLINK] EQL 0
THEN EXITLOOP
ELSE ZFORPTR _ .ZFORPTR[FMTLINK]
END;
RETURN .VREG
END;
ROUTINE PROCCOM=
BEGIN
%ROUTINE MAKES A FAST PASS THRU THE LINKED LISTS OF COMMON BLOCKS
AND ASSOCIATED SYMBOL TABLE ENTRIES COMPUTING THE DECLARED SIZE OF EACH
BLOCK AND ASSIGNING A TEMPORARY ADDRESS TO THE VARIABLES IN EACH
BLOCK RELATIVE TO THE BEGINNING OF THE BLOCK
%
EXTERNAL COMBLKPTR;
MACRO CBLKSIZ = R1$, !SIZE OF CURRENT BLOCK
TCOMSIZ = R2$;
REGISTER BASE CSYMPTR;
LOCAL BASE CCOMPTR;
!
XTRAC;
!
TCOMSIZ _ 0;
CCOMPTR _ .FIRCOMBLK; !PTR TO FIRST COMMON BLOCK
WHILE 1 DO %1% !LOOP ON LINKED LIST
BEGIN
CSYMPTR _ .CCOMPTR[COMFIRST]; !PTR TO FIRST SYMBOL ENTRY IN BLOCK
CBLKSIZ _ 0;
WHILE 1 DO %2% !LOOP ON LINKEDLIST OF SYMBOLS IN BLOCK
BEGIN
CSYMPTR[IDADDR] _.CBLKSIZ;
IF .CSYMPTR[IDDIM] NEQ 0
THEN (LOCAL BASE DIMPTR;
DIMPTR _ .CSYMPTR[IDDIM];
CBLKSIZ _ .CBLKSIZ + .DIMPTR[ARASIZ];
)
ELSE (IF .CSYMPTR[VALTYPE] GTR REAL
THEN CBLKSIZ _ .CBLKSIZ + 2
ELSE CBLKSIZ _ .CBLKSIZ + 1
);
IF .CSYMPTR[IDCOLINK] EQL 0 THEN EXITLOOP
ELSE CSYMPTR _ .CSYMPTR[IDCOLINK];
END;! OF %2% LOOP
!NOW UPDATE TOTAL SIZE OF COMMON
CCOMPTR[COMSIZE] _ .CBLKSIZ;
TCOMSIZ _ .TCOMSIZ + .CBLKSIZ;
IF .CCOMPTR[NEXCOMBLK] EQL 0
THEN EXITLOOP
ELSE CCOMPTR _ .CCOMPTR[NEXCOMBLK];
END; !OF %1% LOOP
RETURN .TCOMSIZ
END; !OF ROUTINE
ROUTINE EQERRLIST(GROUP)=
BEGIN
!LIST THE GROUP OF EQUIVALENCE VARIABLES IN CONFLICT
!
EXTERNAL LSTOUT,ZOUTMSG,ISN,E49;
MAP BASE GROUP:R2;
LOCAL BASE SYMPTR;
SYMPTR _ .GROUP[EQVFIRST];
FATLERR(.ISN,E49<0,0>); !SAME MSG AS BELOW
IF NOT .FLGREG<LISTING> THEN RETURN;
HEADCHK();
STRNGOUT(PLIT '?M?J CONFLICTING VARIABLES( ?0');
WHILE 1 DO( R2 _ .SYMPTR[EQLID];
R2 _ .R2[IDSYMBOL]; ZOUTSYM();
IF (SYMPTR _ .SYMPTR[EQLLINK]) EQL 0 THEN( STRNGOUT(PLIT')?M?J'); HEADCHK(); EXITLOOP)
ELSE (C _ ","; LSTOUT());
);
END; !OF EQERRLIST
ROUTINE GROUPTOCOMMON(COMSYM,NEWGRP,ELIM,GRPDISPL)=
BEGIN
!COMSYM POINTS TO SYMBOL ALREADY IN COMMON
!NEWGRP POINTS TO NEW EQV GROUP GOING TO COMMON
!ELIM IS THE EQVLIMIT OF GROUP TO WHICH COMSYM BELONGS
!GRPDISPL IS THE DISPLACEMENT OF THE MATCH ITEM IN NEWGRP
!
MAP BASE COMSYM :NEWGRP;
LOCAL BASE COMBLPTR :LASCOMSYM :DIMPTR :NEWSYM :NEWITEM;
LOCAL SYMSIZ;
NEWITEM _ .NEWGRP[EQVFIRST]; !FIRST ITEM IN NEW GROUP
WHILE 1 DO
BEGIN
NEWSYM _ .NEWITEM[EQLID]; !PTR TO SYMBOL TABLE NODE
IF .COMSYM NEQ .NEWSYM
THEN IF NOT .NEWSYM[IDATTRIBUT(INCOM)]
THEN
BEGIN
IF (NEWSYM[IDADDR] _ .COMSYM[IDADDR] + .NEWITEM[EQLDISPL] - .GRPDISPL) LSS 0
THEN
BEGIN
EXTERNAL FATLERR,ISN,E33;
COMBLPTR _ .COMSYM[IDCOMMON];
RETURN FATLERR(COMBLPTR[COMNAME],.ISN,E33<0,0> );
END;
NEWSYM[IDATTRIBUT(INCOM)] _ 1; !PUT SYMBOL INCOMMON
COMBLPTR _ .COMSYM[IDCOMMON];
LASCOMSYM _ .COMBLPTR[COMLAST]; !LAST SYMBOL IN COMMON BLOCK
LASCOMSYM[IDCOLINK] _ .NEWSYM; !POINT TO NEW SYMBOL
NEWSYM[IDCOLINK] _ 0;
NEWSYM[IDCOMMON] _ .COMBLPTR; !SYMBOL POINTS TO COMMON BLOCK
COMBLPTR[COMLAST] _ .NEWSYM;
SYMSIZ _ IF .NEWSYM[IDDIM] NEQ 0
THEN (DIMPTR _ .NEWSYM[IDDIM]; .DIMPTR[ARASIZ])
ELSE IF .NEWSYM[DBLFLG] THEN 2 ELSE 1;
IF (.NEWITEM[EQLDISPL] + .SYMSIZ) GTR .ELIM
THEN ELIM _ (.NEWITEM[EQLDISPL] + .SYMSIZ);
IF .COMBLPTR[COMSIZE] LSS ( .NEWSYM[IDADDR] + .SYMSIZ)
THEN
COMBLPTR[COMSIZE] _ (.NEWSYM[IDADDR] + .SYMSIZ);
END
ELSE IF (.NEWSYM[IDADDR] - .NEWITEM[EQLDISPL])
NEQ (.COMSYM[IDADDR] - .GRPDISPL)
THEN ( EQERRLIST(.NEWGRP);
NEWGRP[EQVAVAIL] _ 3; RETURN -1
);
IF .NEWITEM[EQLLINK] EQL 0
THEN RETURN .ELIM
ELSE NEWITEM _ .NEWITEM[EQLLINK];
END; !OF WHILE 1
END; !OF SUBROUTINE GROUPTO COMMON
ROUTINE LINKGROUPS(GROUP1,GROUP2,G1SYM)=
BEGIN
!LINK ITEMS IN GROUP2 INTO GROUP1 WHEN EITHER GROUP IS IN COMMON
!TO ALLOW FOR FURTHER SEARCHING OF GROUP1 BY LATER GROUPS
!
MAP BASE GROUP1 :GROUP2 :G1SYM;
LOCAL BASE G1ITEM :G2ITEM :NEXG2ITEM;
G2ITEM _ .GROUP2[EQVFIRST];
WHILE 1 DO
BEGIN
NEXG2ITEM _ .G2ITEM[EQLLINK];
IF .G1SYM NEQ .G2ITEM[EQLID]
THEN (G1ITEM _ .GROUP1[EQVLAST];
G1ITEM[EQLLINK] _ .G2ITEM;
GROUP1[EQVLAST] _ .G2ITEM;
G2ITEM[EQLLINK] _ 0;
);
IF (G2ITEM _ .NEXG2ITEM) EQL 0 THEN RETURN .VREG;
END; !OF WHILE 1
END; !OF LINKGROUPS
ROUTINE ELISTSRCH(ECLASS,EGROUP)=
BEGIN
%SEARCH EACH ITEM IN GROUP POINTED TO BY EGROUP AGAINST ALL ITEMS IN
CLASS POINTED TO BY ECLASS. WHEN MATCH IS FOUND IF AT ALL, THEN LINK
ITEMS IN EGROUP INTO ECLASS IF NEITHER EGROUP NOR ECLASS IS IN COMMON.
IF EITHER (BUT NOT BOTH)ARE IN COMMON THEN ADD NEW ITEMS
NOT IN COMMON INTO COMMON BLOCK OF WHICH ECLASS OR EGROUP ITEMS ARE MEMBERS.
ERRORS OCCUR IF BOTH ECLASS AND EGROUP ARE IN COMMON.
%
LABEL ELIS1,ELIS2;
LOCAL EGSYM, !SYMBOL BEING SEARCHED IN GROUP
EGSYMPTR, !PTR TO SYMBOL TABLE OF SYMBOL BING SEARCHED
EGITEM, !PTR TO CURRENT EQUIVLIST ITEM IN GROUP
CITEM, !PTR TO LIST ITEM IN CLASS ECLASS
CSYMPTR; !PTR TO SYMBOL TABLE OF ITEM IN ECLASS
MAP BASE ECLASS :EGROUP :EGSYMPTR :CITEM :CSYMPTR :EGITEM;
!
XTRAC; !FOR DEBUGGING TRACE
!
EGITEM _ .EGROUP[EQVFIRST]; !FIRST LIST ITEM IN EGROUP
IF
ELIS1: (WHILE 1 DO
BEGIN
!SEARCH FOR MATCH OF ITEM IN ECLASS WITH ITEM IN EGROUP
EGSYMPTR _ .EGITEM[EQLID]; EGSYM _ .EGSYMPTR[IDSYMBOL]; !GET THE SYMBOL
CITEM _ .ECLASS[EQVFIRST]; !THE PTR TO FIRST LIST ITEM IN ECLASS
ELIS2: WHILE 1 DO %2%
BEGIN
CSYMPTR _ .CITEM[EQLID]; !SYMBOL TABLE PTR
IF .EGSYM EQL .CSYMPTR [IDSYMBOL]
THEN LEAVE ELIS1 WITH (-1);
IF .CITEM[EQLLINK] EQL 0
THEN LEAVE ELIS2
ELSE CITEM _ .CITEM[EQLLINK];
END; !OF %2%
IF .EGITEM[EQLLINK] EQL 0
THEN LEAVE ELIS1 WITH (0)
ELSE EGITEM _ .EGITEM[EQLLINK];
END !OF WHILE %1%
) EQL 0 THEN RETURN 0; !RETURN 0 IF NO MATCH BETWEEN ECLASS AND EGROUP
!
!WE GET HERE IF AN ITEM IN EGROUP MATCHES AN ITEM IN ECLASS
!CITEM POINTS TO THE ITEM IN ECLASS AND EGITEM POINTS TO THE
!ITEM IN EGROUP. WE NOW CHECK FOR COMMON EQUIVALENCE INTERACTION
!AND DECIDE WHETHER TO LINK THE NEW ITEMS INTO ECLASS OR TO ADD NEW ITEMS TO
!THE COMMON BLOCK OF WHICH ECLASS OR EGROUP (BUT NOT BOTH) IS A PART
!
BEGIN LOCAL EGDISPL,ELIM,ECDISPL;
IF .CSYMPTR[IDATTRIBUT(INCOM)] THEN IF NOT .ECLASS[EQVINCOM]
THEN BEGIN
ECLASS[EQVINCOM] _ 1;
IF
ECLASS[EQVLIMIT] _ GROUPTOCOMMON(.CSYMPTR,.ECLASS,.ECLASS[EQVLIMIT],.CITEM[EQLDISPL])
LSS 0 THEN RETURN -1
END;
!
!CSYMPTR CONTAINS PTR TO MATCHED SYMBOL IN ECLASS
!EGSYMPTR CONTAINS PTR TO MATCHED SYMBOL IN EGROUP
!
ELIM _ .ECLASS[EQVLIMIT]; !LIMIT OF GROUP
EGDISPL _ .EGITEM[EQLDISPL];
ECDISPL _ .CITEM[EQLDISPL];
EGITEM _ .EGROUP[EQVFIRST];
EGSYMPTR _ .EGITEM[EQLID]; !SET PTR TO FIRST ITEM IN GROUP
!
!TEST FOR GROUP OR CLASS IN COMMON
!
IF .ECLASS[EQVINCOM] OR .EGROUP[EQVINCOM]
THEN
BEGIN
EXTERNAL ISN,FATLERR,E48;
! IF .ECLASS[EQVINCOM] AND .EGROUP[EQVINCOM]
! THEN ( IF .ECLASS[EQVHEAD] NEQ .EGROUP[EQVHEAD]
! THEN (FATLERR(.ISN,E48<0,0>); RETURN -1;); !TWO COMMON ITEMS EQUIVALENCED
! )
! ELSE
IF .EGROUP[EQVINCOM]
THEN( !ASSIGN COMMON ADDRESSES TO ECLASS
ELIM _ .EGROUP[EQVLIMIT];
EGDISPL _ .CITEM[EQLDISPL]; ECDISPL _ .EGITEM[EQLDISPL];
CSYMPTR _ .EGITEM[EQLID];
EGITEM _ .ECLASS[EQVFIRST]; EGSYMPTR _ .EGITEM[EQLID];
);
WHILE 1 DO %1%
BEGIN
!NOW CHECK NEW COMMON ADDRESS NOW AND LINK NEW ITEM INTO EXISTING COMMON BLOCK
IF .CSYMPTR NEQ .EGSYMPTR
THEN
IF NOT (.ECLASS[EQVINCOM] AND .EGROUP[EQVINCOM])
THEN IF NOT .EGSYMPTR[IDATTRIBUT(INCOM)]
THEN
BEGIN LOCAL BASE CLCOMPTR :GPCOMPTR :COMSYM :ESYM;
LOCAL EGSYMSIZ;
EXTERNAL FATLERR,E33,ISN;
IF (EGSYMPTR[IDADDR] _ .CSYMPTR[IDADDR] + .EGITEM[EQLDISPL] -.EGDISPL) LSS 0
THEN (MAP BASE R1;
R1 _ .CSYMPTR[IDCOMMON];
RETURN FATLERR(R1[COMNAME],.ISN,E33<0,0>)
);
!ERROR EQUIVALENCE ITEM EXTENDS COMMON BACKWARD
EGSYMPTR[IDATTRIBUT(INCOM)] _ 1; !MAKE SYMBOL IN COMMON
CLCOMPTR _ .CSYMPTR[IDCOMMON]; !PTR TO COMMON BLOCK HDR
COMSYM _ .CLCOMPTR[COMLAST]; !PTR TO LAST SYMBOL IN BLOCK
COMSYM[IDCOLINK] _ .EGSYMPTR; !LINK IN NEW SYMBOL
CLCOMPTR[COMLAST] _ .EGSYMPTR;
EGSYMPTR[IDCOLINK] _ 0; !NEW END OF LINK
EGSYMPTR[IDCOMMON] _ .CLCOMPTR; !SYMBOL TO POINT TO BLOCK
! COMPUTE NEW BLOCK SIZE
!
EGSYMSIZ _ IF .EGSYMPTR[IDDIM] NEQ 0
THEN (ESYM _ .EGSYMPTR[IDDIM]; .ESYM[ARASIZ])
ELSE IF .EGSYMPTR[DBLFLG] THEN 2 ELSE 1;
IF (.EGITEM[EQLDISPL] + .EGSYMSIZ) GTR .ELIM
THEN ELIM _ (.EGITEM[EQLDISPL] + .EGSYMSIZ);
IF .CLCOMPTR[COMSIZE] LSS (R1 _ .EGSYMPTR[IDADDR] + .EGSYMSIZ)
THEN CLCOMPTR[COMSIZE] _ .R1;
END
ELSE IF (.EGSYMPTR[IDADDR]-.EGITEM[EQLDISPL])
NEQ (.CSYMPTR[IDADDR]-.EGDISPL)
THEN (EQERRLIST(.EGROUP); EGROUP[EQVAVAIL] _ 3; RETURN -1);
!
!TESTING FOR END OF CHAIN OF GROUP GOING INTO COMMON
IF .EGITEM[EQLLINK] NEQ 0
THEN (EGITEM _ .EGITEM[EQLLINK]; EGSYMPTR _ .EGITEM[EQLID])
ELSE (
LINKGROUPS(.ECLASS,.EGROUP,.CSYMPTR);
ECLASS[EQVINCOM] _ 1;
!**;[364], ELISTSRCH @3888, DCE, 31-MAR-76
!**;[364], THIS IS A SUCCESSFUL TRIP - RETURN 1!
%[364]% EGROUP[EQVAVAIL] _ 2; EGROUP[EQVINCOM]_1;RETURN 1
);
END; !OF LOOP%1%
END; !END OF IF INCOMMON
!
!HERE IF NEITHER GROUP NOR CLASS IN COMMON
!LINK ITEMS IN EGROUP INTO ECLASS, MARK EACH GROUP UNAVAILABLE
!CHECK FOR ERRORS OF FORM
! EQUIVALENCE (A(5),B(2)),(C(2),B(2)),(C(2),A(4))
!
EGITEM _ .EGROUP[EQVFIRST];
WHILE 1 DO
BEGIN LOCAL ENEXITEM,NEWDISPL;
ENEXITEM _ .EGITEM[EQLLINK]; !PTR TO NEXT ITEM IN GROUP TO BE LINKED TO CLASS
EGSYMPTR _ .EGITEM[EQLID];
EGSYM _ .EGSYMPTR[IDSYMBOL];
!NOW SEARCH FOR EGSYM IN ECLASS
!
CITEM _ .ECLASS[EQVFIRST]; !PTR TO FIRST ITEM IN CLASS
NEWDISPL _ .ECDISPL + .EGITEM[EQLDISPL] -.EGDISPL;
IF WHILE 1 DO
BEGIN %2%
CSYMPTR _ .CITEM[EQLID];
IF .EGSYM EQL .CSYMPTR[IDSYMBOL]
THEN EXITLOOP (-1);
IF .CITEM[EQLLINK] EQL 0
THEN EXITLOOP (0)
ELSE CITEM _ .CITEM[EQLLINK]
END !OF %2%
NEQ 0
THEN !MAKE SURE DISPLACEMENTS OF MATCHING ITMES ARE OK
( IF .NEWDISPL NEQ .CITEM[EQLDISPL]
THEN (EQERRLIST(.EGROUP); !INCONSISTENT OR CONFLICTING EQUIVALENCES
EGROUP[EQVAVAIL] _ 3; RETURN -1
);
)
ELSE (CITEM[EQLLINK] _ .EGITEM;
);
EGITEM[EQLLINK] _ 0; !CLEAR LINK
EGITEM[EQLDISPL] _ .NEWDISPL;
IF .NEWDISPL LSS .ECLASS[EQVADDR]
THEN ECLASS[EQVADDR] _ .NEWDISPL;
!
!NOW COMPUTE NEW EQVLIMIT
!
BEGIN LOCAL BASE ESYM, EQSIZ;
EQSIZ _ IF .EGSYMPTR[IDDIM] NEQ 0
THEN (ESYM _ .EGSYMPTR[IDDIM]; .ESYM[ARASIZ])
ELSE IF .EGSYMPTR[DBLFLG] THEN 2 ELSE 1;
IF (.EGITEM[EQLDISPL] + .EQSIZ) GTR .ECLASS[EQVLIMIT]
THEN ECLASS[EQVLIMIT] _ (.EGITEM[EQLDISPL] + .EQSIZ);
END;
IF .ENEXITEM EQL 0 THEN RETURN 1 !GOOD RETURN (ALLITEMS IN EGROUP LINKED TO ECLASS)
ELSE EGITEM _ .ENEXITEM;
END; !OF %1%
END;
END; !OF ROUTINE ELISTSRCH
ROUTINE EQCALLOC(ECLASS)=
BEGIN
%
ALLOCATE RELOCATABLE ADDRESSES TO AN EQUIVALENCE CLASS (ECLASS)
%
EXTERNAL LOWLOC; !THE LOW SEG AVAILABLE LOCATION
MAP BASE ECLASS;
LOCAL BASE CITEM :CSYMPTR;
LOCAL TLOC;
OWN CNT;
%
THE ADDRESS OF ANITEM IN ECLASS IS COMPUTED AS FOLLOWS
ADDR _ .LOWLOC + (RELATIVE DISPLACEMENT OF ITEM IN ECLASS (CITEM[EQLDISPL]
- SMALLEST RELATIVE DISPLACEMENT IN ECLASS (ECLASS[EQVADDR])
%
CNT _ 0;
IF .FLGREG<LISTING> THEN( HEADCHK(); STRNGOUT(PLIT '?M?J( ?0'));
TLOC _ .LOWLOC - .ECLASS[EQVADDR];
CITEM _ .ECLASS[EQVFIRST];
WHILE 1 DO
BEGIN
CSYMPTR _ .CITEM[EQLID]; !PTR TO SYMBOL
CSYMPTR[IDADDR] _ .CITEM[EQLDISPL] + .TLOC;
IF .FLGREG<LISTING>
THEN(LISTSYM(.CSYMPTR);
IF .CNT LSS 5 THEN CNT _ .CNT+1
ELSE (CNT _ 0; CRLF; HEADCHK());
);
IF .CITEM[EQLLINK] EQL 0
THEN( IF .FLGREG<LISTING> THEN STRNGOUT(PLIT')?M?J'); HEADCHK(); EXITLOOP) ELSE CITEM _ .CITEM[EQLLINK];
END;
LOWLOC _ .LOWLOC + .ECLASS[EQVLIMIT] - .ECLASS[EQVADDR];
!
!LOWLOC + SPAN OF THE CLASS
!
END; !OF EQCALOC
ROUTINE GRPSCAN=
BEGIN
!
!SCAN ALL GROUPS FOR ITEMS IN COMMON BUT GROUP WAS NOT FLAGGED
!
EXTERNAL EQVPTR;
LOCAL BASE ECLASS :ELIST :EITEM : LAST;
ECLASS _ .EQVPTR<LEFT>;
WHILE 1 DO
BEGIN
LAST _ ELIST _ .ECLASS[EQVFIRST];
IF NOT .ECLASS[EQVINCOM]
THEN
UNTIL .ELIST EQL 0
DO
BEGIN
EITEM _ .ELIST[EQLID];
IF .EITEM[IDATTRIBUT(INCOM)]
THEN
BEGIN
EXTERNAL E48,FATLERR;
% CHECK FOR MORE THAN ONE COMMON VAR%
IF .ECLASS[EQVINCOM]
THEN ( FATLERR(.ISN,E48<0,0>); EXITLOOP );
ECLASS[EQVINCOM] _ 1;
ECLASS[EQVHEAD] _ .ELIST;
IF .LAST NEQ .ELIST
THEN
BEGIN
%MOVE IT TO TOP OF THE LIST%
LAST[EQLLINK] _ .ELIST[EQLLINK];
ELIST[EQLLINK] _ .ECLASS[EQVFIRST];
!**;[472], GRPSCAN @4014, DCE, 6-OCT-76
!**;[472], IF THE COMMON ELEMENT WAS THE LAST ONE IN THE GROUP,
!**;[472], THEN THE PTR TO IT [EQVLAST] MUST BE CHANGED TOO
%[472]% ECLASS[EQVFIRST] _ .ELIST;
%[472]% IF .ECLASS[EQVLAST] EQL .ELIST
%[472]% THEN ECLASS[EQVLAST]_.LAST
END
END;
LAST _ .ELIST;
ELIST _ .ELIST[EQLLINK]
END;
IF (ECLASS _ .ECLASS[EQVLINK]) EQL 0 THEN RETURN .VREG;
END;
END;
ROUTINE PROCEQUIV=
BEGIN
%PROCESSES EQUIVALNCE GROUPS AS DECLARED IN THE SOURCE -N RESOLVING
IMPLICIT EQUIVALENCES AND EQUIVALENCES INTO COMMON. CHECKS FOR
ALLOCATION ERRORS DUE TO IMPROPER EQUIVALENCES. ASSIGNS TEMPORARY
ADDRESSES TO EQUIVALENCE VARIABLES AND NEW VARIABLES EQUIVALENCED INTO COMMON.
%
EXTERNAL EQVPTR, !PTR TO FIRST AND LAST EQUIVALENCE GROUPS
ARRXPN, !FOR EXPANDING ARRAY REFERENCES IN EQUIVALENCE ITEMS
ZOUTMSG, !MESSAGE OUTPUTTER
ELISTSRCH, !ROUTINE THAT SEARCHES FOR A MATCH OF ONE ITEM
!IN A CLASS IN ANY AVAILABLE GROUP
EQCALLOC; !ALLOCATION OF EQUIVALENCE CLASSES
LOCAL BASE EQVCPTR, !PTR TO CURRENT EQUIV CLASS HEADER
ECOMMPTR, !PTR COMMON ITEM IF GROUP IS IN COMMON
ECOMMHDR, !PTR TO COMMON BLOCK HDR
LCLHD; !PTR TO LOCAL HEAD OF A GROUP FOR ALLOCATION PURPOSES
REGISTER BASE EQLPTR;
LABEL COMN1,LOOP2;
LOCAL SAVEBOUNDSFLG; !TO SAVE THE VALUE OF THE "BOUNDS" SWITCH WHILE
! PROCESSING EQUIVALENCE STMNTS
SAVEBOUNDSFLG_.FLGREG<BOUNDS>; !SAVE THE VALUE OF THE "BOUNDS" SWITCH
! (THAT SPECIFIES WHETHER ARRAY BOUNDS
! CHECKING IS TO BE PERFORMED)
FLGREG<BOUNDS>_0; !TURN OFF THE BOUNDS FLAG WHILE PROCESSING
! EQUIVALENCE STATEMENTS
!
!THE FIRST STEP IS TO COMPUTE RELATIVE DISPLACEMENTS OF EACH ITEM IN
!AND EQUIVALENCE GROUP. THIS IS SIMPLY 1 MINUS THE SUBSCRIPT
!VALUE OF EACH ITEM IN THE GROUP.
!I.E A(1) HAS DISPLACEMENT 0 AND A(4) HAS DISPLACEMENT -3
!
IF .FLGREG<LISTING>
THEN
BEGIN
EXTERNAL HEADING,PAGELINE;
IF ( PAGELINE_.PAGELINE-4) LEQ 0
THEN ( HEADING(); PAGELINE_ .PAGELINE-4);
STRNGOUT(PLIT'?M?JEQUIVALENCED VARIABLES?M?J?M?J?0');
END;
!
!SCAN GROUPS FOR IN COMMON ITEMS
!
GRPSCAN();
!
EQVCPTR _ .EQVPTR<LEFT>; !PTR TO FIRST GROUP
WHILE 1 DO %1%
BEGIN
ISN _ .EQVCPTR[EQVISN]; !SET ISN INCASE OF ERRORS
ECOMMPTR _ 0; !INITIALIZING
!IF GROUP IS IN COMMON THEN FIND THE ELEMENT IN COMMON
COMN1: IF .EQVCPTR[EQVINCOM]
THEN( LOCAL BASE COMPTR;
EQLPTR _ .EQVCPTR[EQVHEAD]; !PTR TO LIST ITEM THAT IS IN COMMON
COMPTR_ .EQLPTR[EQLID];
ECOMMPTR _ .EQLPTR; !PTR TO COMMON ITEM EQL LIST ITEM
ECOMMHDR _ .COMPTR[IDCOMMON];
LCLHD _ .EQLPTR[EQLID];
)
ELSE LCLHD _ 0;
EQLPTR _ .EQVCPTR[EQVFIRST];