Trailing-Edge
-
PDP-10 Archives
-
BB-4157E-BM
-
fortran-compiler/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,1981 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: F. INFANTE/MD/DCE/JNG/TFV/AHM
MODULE OUTMOD(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 OUTMOV = 6^24 + 0^18 + 85; ! Version Date: 28-Sep-81
%(
***** Begin 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,
(MD/DT)
64 241 ----- CORRECT HIGH SEG START ADDR FOR LINK
IF LOW SEG SIZE IS GREATER THAN 128K, (MD)
65 337 17305 ROUND UP IMMEDIATE CONSTANTS CORRECTLY, (DCE)
66 364 18251 CORRECT EQUIVALENCE PROCESSING, (DCE)
67 436 19427 DON'T ALLOW 2 BLOCK COMMON VARIABLES TO
BE EQUIVALENCED IF BLOCKS ARE DIFFERENT, (DCE)
68 470 20744 MAKE SURE HIGH SEG STARTS AT LEAST 1000 LOCS
ABOVE END OF LOW SEG, (JNG)
69 472 20494 IF COMMON ITEM IS LAST IN GROUP,
MOVE IT TO BEGINNING CORRECTLY, (DCE)
70 473 20478 SCALARS AND ARRAYS LISTING TOO WIDE, (DCE)
71 474 20479 SHOULD GIVE CRLF AFTER COMMON BLOCK NAMES, (DCE)
***** Begin Version 5A *****
72 604 23425 FIX LISTING OF COMMON BLOCK ELEMENTS, (DCE)
***** Begin Version 5B *****
73 636 23066 SET SNDEFINED WHEN DEFINING A LABEL, (JNG)
74 645 25249 SCALARS AND ARRAYS INCREMENTS LINE COUNT BY
ONE TOO MANY, (DCE)
75 702 ----- LISTING OF SUBPROGRAMS CALLED CAN BE INCORRECT, (DCE)
76 703 ----- LISTING OF SCALARS AND ARRAYS CAN GIVE BLANK PAGE, (DCE)
77 735 28528 CLEAN UP LISTING OF VARIOUS HEADERS, (DCE)
***** Begin Version 6 *****
78 761 TFV 1-Mar-80 -----
Clean up KISNGL to use CNSTCM. Remove KA10FLG.
Output GFLOATING FORTRAN as compiler type in .REL file
79 1003 TFV 1-Jul-80 ------
Use binds for processor type and compiler id in REL blocks.
80 1006 TFV 1-July-80 ------
Move KISNGL to UTIL.BLI (It is also in CGEXPR.BLI.)
86 1120 AHM 9-Sep-81 Q10-06505
Fix edit 735 by always clearing a flag so that the
"EQUIVALENCED VARIABLES" header is produced again.
87 1133 TFV 28-Sep-81 ------
Setup CHDSTART to be the start of the hiseg for /STATISTICS.
***** End Revision History *****
)%
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 LSTHDR( MINLINE, HDRLINES, HDRPTR) =
![735] THIS ROUTINE PUTS OUT VARIOUS HEADING LINES FOR THE LISTING FILE
![735] AND MAKES SURE THAT THERE IS ROOM FOR THEM ON THE CURRENT LISTING
![735] PAGE. THE PARAMETERS ARE:
![735] MINLINE - THERE MUST BE THIS MANY LINES LEFT ON THE CURRENT
![735] PAGE OR THE NEXT PAGE WILL BE STARTED - THIS MAY INCLUDE
![735] THE FIRST (OR MORE) LINE(S) AFTER THE HEADER.
![735] HDRLINES - THIS IS THE ACTUAL NUMBER OF LINES WHICH ARE
![735] CAUSED TO BE OUTPUT BY THE HEADER ALONE.
![735] HDRPTR - THIS IS A POINTER TO THE ACTUAL MESSAGE TEXT, AN
![735] ASCIZ STRING TO BE PUT INTO THE LISTING.
%[735]% IF .FLGREG<LISTING> THEN
%[735]% BEGIN
%[735]% EXTERNAL HEADING, PAGELINE;
%[735]% IF .PAGELINE LEQ .MINLINE
%[735]% THEN %NO ROOM ON THIS PAGE% HEADING();
%[735]% PAGELINE _ .PAGELINE-.HDRLINES;
%[735]% STRNGOUT(.HDRPTR);
%[735]% END;
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
%[735]% LOCAL BASE SYMPTR,COUNT,HDRFLG;
EXTERNAL HEADING,PAGELINE;
%[702]% COUNT_0;
%[735]% HDRFLG _ 0; !NO HEADING LINE OUTPUT YET
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
%[702]% IF .COUNT LEQ 0 THEN HEADCHK();
%[735]% IF .HDRFLG EQL 0 THEN
%[735]% BEGIN
%[735]% HDRFLG _ 1;
%[735]% LSTHDR(5,4,PLIT'?M?J?M?JSUBPROGRAMS CALLED?M?J?M?J?0');
%[735]% END;
R2 _ .SYMPTR[IDSYMBOL]; ZOUTSYM();
IF (COUNT _ .COUNT+1) GTR 5
%[702]% THEN (COUNT _ 0; CRLF)
ELSE (C _ #11; LSTOUT());
END;
END WHILE (SYMPTR _ .SYMPTR[CLINK]) NEQ 0;
END;
%[702]% IF .COUNT NEQ 0 THEN CRLF;
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;
%[735]% LOCAL HDRFLG; !SCALARS AND ARRAYS LISTING HEADER FLAG
EXTERNAL ENDSCAA;
LOCAL BASE ARRAPT;
LABEL L1,L2;
MAP BASE PTR;
%[735]% ROUTINE HDRSAA=
%[735]% LSTHDR(4,3,PLIT '?M?JSCALARS AND ARRAYS [ "*" NO EXPLICIT DEFINITION - "%" NOT REFERENCED ]?M?J?M?J?0');
%[735]% HDRFLG_0;
SCNT_0;
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
%[703]% IF .SCNT LEQ 0 THEN HEADCHK();
%[735]% IF .HDRFLG EQL 0 THEN (HDRFLG_1; HDRSAA());
%[703]% LISTSYM(.PTR);
%[703]% IF .SCNT LSS 4 THEN SCNT_.SCNT+1 ELSE (SCNT_0;CRLF);
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
%[703]% IF .SCNT LEQ 0 THEN HEADCHK();
%[735]% IF .HDRFLG EQL 0 THEN (HDRFLG_1; HDRSAA());
R2_.PTR[IDSYMBOL];
CHAROUT("%");
ZOUTSYM();
CHAROUT(#11); !TAB
CHAROUT(#11); !TAB
!LISTING FOR SCALARS AND ARRAYS IS A BIT TOO WIDE
%[703]% IF .SCNT LSS 4 THEN SCNT _ .SCNT+1 ELSE (SCNT _ 0; CRLF);
END
END
END;
END WHILE (PTR _ .PTR[CLINK]) NEQ 0
END
END;
%[703]% IF .FLGREG<LISTING> THEN IF .SCNT NEQ 0 THEN CRLF;
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;
%[735]% LSTHDR(5,3,PLIT'?M?JCOMMON BLOCKS?M?J?0');
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();
!BE SURE TO OUTPUT CRLF AFTER LAST COMMON BLOCK NAME
IF (CSYMPTR _ .CSYMPTR[IDCOLINK]) EQL 0 THEN
!RESET ICNT SO THAT WE DO NOT GET LINE WITH SINGLE
! ELEMENT BY ACCIDENT!
(ICNT_0; CRLF; HEADCHK();
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
%[636]% SNUMENTRY[SNDEFINED]_TRUE; !REMEMBER THAT SNADDR IS VALID
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;
!THIS IS A SUCCESSFUL TRIP - RETURN 1!
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];
!IF THE COMMON ELEMENT WAS THE LAST ONE IN THE GROUP,
! THEN THE PTR TO IT [EQVLAST] MUST BE CHANGED TOO
ECLASS[EQVFIRST] _ .ELIST;
IF .ECLASS[EQVLAST] EQL .ELIST
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
%[735]% HDRFLG, !FLAG TO KEEP TRACK OF WHETHER EQUIVALENCE LISTING
%[735]% ! HEADER HAS BEEN OUTPUT YET.
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
%1120% HDRFLG_0; !Remember that no header has been output yet
!
!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
!
!
!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]; !PTR TO FIRST ITEM IN GROUP
R2 _ R1 _ 0; !EQVLIMIT IN R2, SMALLEST DISPLACEMENT IN R1
LOOP2: WHILE 1 DO %2%
BEGIN LOCAL BASE ESYM, EQSIZ;
IF .EQLPTR[EQLINDIC] NEQ 0
THEN (LOCAL BASE PT1:PT2:PT3;
EXTERNAL E53,E103;
PT1 _ .EQLPTR[EQLID];
IF .PT1[IDDIM] EQL 0 THEN
BEGIN
EXTERNAL ISN,FATLERR,E93;
FLGREG<BOUNDS>_.SAVEBOUNDSFLG;
RETURN FATLERR(.ISN,E93<0,0>);
END;
EQLPTR[EQLINDIC] _ 0;
IF .EQLPTR[EQLLIST]^(-18) NEQ 0
THEN
BEGIN %MULTIPLE SUBSCRIPTS%
PT1 _ ARRXPN(.EQLPTR[EQLID],.EQLPTR[EQLLIST]);
IF .PT1[ARG2PTR] NEQ 0
THEN RETURN FATLERR(.ISN,E53<0,0>); !NON-CONSTANT SUBSCRIPT
EQLPTR[EQLDISPL] _ -(EXTSIGN(.PT1[TARGET])); !GET - DISPLACEMENT
END
ELSE
BEGIN %SINGLE SUBSCRIPT%
PT1 _ @.EQLPTR[EQLLIST]; !POINTER TO SUBSCRIPT
IF .PT1[OPR1] NEQ CONSTFL OR .PT1[VALTYPE] NEQ INTEGER
THEN RETURN FATLERR(.ISN,E53<0,0>); !NON-CONSTANT SUBSCRIPT
%NOW GENERATE THE OFFSET%
EQLPTR[EQLDISPL] _ -.PT1[CONST2] !CONSTANT VALUE
+( PT3 _ .EQLPTR[EQLID];
PT2 _ .PT3[IDDIM];
PT2 _ .PT2[DIMENL(0)];
.PT2[CONST2] %OFFSET%
);
IF .EQLPTR[EQLDISPL] LEQ -(2^18)
OR .EQLPTR[EQLDISPL] GEQ 2^18
THEN RETURN FATLERR(.ISN, E103<0,0>); !OUT OF RANGE
IF .PT3[DBLFLG] THEN EQLPTR[EQLDISPL] _ .EQLPTR[EQLDISPL]*2;
END
);
!
!
!NOW CHECK FOR NEW EQVLIMIT (R2) FOR THIS GROUP
ESYM _ .EQLPTR[EQLID]; !PTR TO SYMBOL TABLE
!
EQSIZ _ IF .ESYM[IDDIM] NEQ 0
THEN (ESYM _.ESYM[IDDIM]; .ESYM[ARASIZ])
ELSE IF .ESYM[DBLFLG] THEN 2 ELSE 1;
IF (.EQLPTR[EQLDISPL] + .EQSIZ) GTR .R2 %EQVLIMIT%
THEN R2 _ (.EQLPTR[EQLDISPL] +.EQSIZ);
!
!NOW CHECK FOR NEW MIN(R(I)) RELATIVE DISPLACEMENT
!
IF .EQLPTR[EQLDISPL] LSS .R1
THEN (R1 _ .EQLPTR[EQLDISPL]; LCLHD _ .EQLPTR[EQLID]);
IF .ECOMMPTR NEQ 0
THEN IF .EQLPTR NEQ .ECOMMPTR
THEN( LOCAL BASE LINK:COM;
MAP BASE ECOMMHDR :ECOMMPTR;
LINK _ .EQLPTR[EQLID];
COM _ .ECOMMPTR[EQLID]; !PTR TO ITEM IN CO MMON
IF NOT .LINK[IDATTRIBUT(INCOM)]
THEN(
EXTERNAL FATLERR,ISN,E33;
LINK _ .ECOMMHDR[COMLAST];
ECOMMHDR[COMLAST] _ .EQLPTR[EQLID];
LINK _ LINK[IDCOLINK] _ .EQLPTR[EQLID]; !PTR TO SYMBOL TABLES NODE
LINK[IDATTRIBUT(INCOM)] _ 1; !SET IN COMMON
LINK[IDCOMMON] _ .ECOMMHDR;
LINK[IDCOLINK] _ 0;
IF (LINK[IDADDR] _ (.EQLPTR[EQLDISPL] - .ECOMMPTR[EQLDISPL] + .COM[IDADDR]) ) LSS 0
THEN ( FATLERR(ECOMMHDR[COMNAME],.ISN,E33<0,0>);
LEAVE LOOP2;
);
IF .ECOMMHDR[COMSIZE] LSS (.LINK[IDADDR] + .EQSIZ)
THEN ECOMMHDR[COMSIZE] _(.LINK[IDADDR] + .EQSIZ);
)
ELSE IF (.COM[IDADDR]-.ECOMMPTR[EQLDISPL]) NEQ (.LINK[IDADDR]-.EQLPTR[EQLDISPL])
!IF BOTH THE GROUP AND THE ELEMENT ARE IN
! COMMON, MAKE SURE IT IS THE SAME COMMON
! BLOCK! OTHERWISE AN ERROR FOR SURE.
OR (.COM[IDCOMMON] NEQ .LINK[IDCOMMON])
THEN (EQERRLIST(.EQVCPTR); EQVCPTR[EQVAVAIL] _ 3;LEAVE LOOP2);
!
!CHECKING THE DECLARATIONS FOR VIOLATING BEGINNING OF COMMON BLOCK
!
);
!
!CHECKING FOR END OF CHAIN OF ITEMS
!
IF .EQLPTR[EQLLINK] EQL 0
THEN EXITLOOP !END OF CHAIN
ELSE EQLPTR _ .EQLPTR[EQLLINK]
END; !OF WHILE %2%
!
EQVCPTR[EQVADDR] _ .R1; !LOWEST RELATIVE DISPLACEMENT
! EQVCPTR[EQVHEAD] _ .LCLHD; !PTR TO HED OF GROUP
EQVCPTR[EQVLIMIT] _ .R2; !SPAN OF GROUP RELATIVE TO 0
!
!REAL SPAN (#OF WORDS OCCUPIED BY ALL ELEMNTS OF GROUP)
!IS EQVLIMIT - EQVADDR
!
IF .EQVCPTR[EQVLINK] EQL 0
THEN EXITLOOP !END OF CHAIN OF GROUPS
ELSE EQVCPTR _ .EQVCPTR[EQVLINK]
END; !OF %1%
!
!NOW START TO MAKE EQUIVALENCE CLASSES BY COMBINING GROUPS IF POSSIBLE
!
EQVCPTR _ .EQVPTR<LEFT>; !START WITH FIRST GROUP
WHILE 1 DO %1%
BEGIN
WHILE 1 DO %2% !GROUP(I) BECOMING A CLASS
BEGIN
IF .EQVCPTR[EQVAVAIL] EQL 0 !GROUP AVAILABLE FOR CLASS
THEN ( MACRO EQGPPTR = EQLPTR$;
ISN _ .EQVCPTR[EQVISN]; !SET ISN INCASE OF ERRORS
EQVCPTR[EQVAVAIL] _ 2; !MAKE GROUP A CLASS
EQGPPTR _ .EQVCPTR; !BEGIN SRCH OF OTHER GROUPS ON CURRENT GROUP
DO
BEGIN
IF .EQGPPTR[EQVAVAIL] EQL 0
THEN (
IF (ELISTSRCH(.EQVCPTR,.EQGPPTR)) GTR 0
THEN ( EQGPPTR[EQVAVAIL] _ 2;
EQGPPTR _ .EQVCPTR ); !SEE IF ANY OF THE REJECTS FIT NOW
!
!IF ERROR OCCURRED IN ELSTSRCH THEN EQGPPTR[EQVAVAIL]
!WILL BE SET TO 3 (ERROR)
!
);
END
WHILE (EQGPPTR _ .EQGPPTR[EQVLINK]) NEQ 0;
IF NOT .EQVCPTR[EQVINCOM]
THEN IF .EQVCPTR[EQVAVAIL] NEQ 3
%[735]% THEN ( IF .HDRFLG EQL 0 THEN LSTHDR(4,2,PLIT'?M?JEQUIVALENCED VARIABLES?M?J?0');
%[735]% EQCALLOC(.EQVCPTR); !ALLOCATE CLASS POINTED TO BY EQVCPTR
%[735]% HDRFLG_1);
); !END OF IF AVAIL TEST
IF .EQVCPTR[EQVLINK] EQL 0
THEN EXITLOOP !NO MORE GROUPS TO PROCESS INTO CLASS
ELSE EQVCPTR _ .EQVCPTR[EQVLINK]; !NEXT GROUP TO BE A CLASS
END; !OF LOOP %2%
IF (EQVCPTR _ .EQVCPTR[EQVLINK]) EQL 0 THEN (FLGREG<BOUNDS>_.SAVEBOUNDSFLG; RETURN);
!
!ALL GROUPS PROCESSED IF RETURN TAKEN
!
END; ! OF LOOP %1%
FLGREG<BOUNDS>_.SAVEBOUNDSFLG; !RESTORE THE "BOUNDS" SWITCH
END; !OF ROUTINE PROCEQUIV
GLOBAL ROUTINE ALCCON=
BEGIN
!ALLOCATE (USING HILOC) ALL THE CONSTANTS THAT HAVE
!THE FLAG CNTOBEALCFLG SET. THIS FLAG IS SET BY CALLS TO
!ALOCONST.
EXTERNAL LOWLOC,HILOC,RDATWD,ZOUTBLOCK,C2H,C2L;
%[1006]% EXTERNAL KISNGL;
EXTERNAL LITPOINTER;
BIND HI=R1,LOW=R2;
MACHOP ADDI=#271,TLZE=#623,TLO=#661,LSH=#242,DFN=#131;
MACRO EXPON=27,8$;
MACRO RELCONST(CXPTR)= !DUMPS CONSTANTS ONTO REL FIE
BEGIN
MAP BASE CXPTR;
IF .CXPTR[VALTP1] EQL INTEG1
THEN RDATWD _ .CXPTR[CONST2]
ELSE RDATWD _ .CXPTR[CONST1]; !HIGH ORDER FOR REAL OR DOUBLE
ZOUTBLOCK(RCODE,RELN);
HILOC_.HILOC+1;
IF .CXPTR[DBLFLG] !IF DOUBLE OR COMPLEX CONSTANT
THEN ( RDATWD _ .CXPTR[CONST2]; ZOUTBLOCK(RCODE,RELN);
HILOC_ .HILOC+1;
);
END$;
EXTERNAL ALODIMCONSTS; !ROUTINE TO SET "CNTOBEALCFLG" IN ALL
! CONSTANTS USED FOR DIMENSIONING ARRAYS
! THAT ARE TO HAVE BOUNDS CHECKING PERFORMED ON THEM
LOCAL BASE CPTR,SAVHILOC;
%(***ALLOCATE CORE FOR ALL CONSTS USED IN DIMENSIONING ARRAYS THAT WILL
HAVE BOUNDS CHECKING PERFORMED ON THEM
*****)%
ALODIMCONSTS();
SAVHILOC _ .HILOC;
HILOC _ .LOWLOC; !RESET HILOC
INCR I FROM 0 TO CSIZ-1 DO
BEGIN
IF .CONTBL[.I] NEQ 0 THEN
BEGIN
CPTR_.CONTBL[.I];
WHILE .CPTR NEQ 0 DO
BEGIN
!NOW CHECK FOR KA-10 DP CONSTANT O/P
IF .CPTR[CONST1] NEQ 0
THEN
IF .CPTR[VALTYPE] EQL REAL
!WHEN ROUNDING TO SINGLE PRECISION, ZERO SECOND WORD
THEN (CPTR[CONST1] _ KISNGL(.CPTR[CONST1],.CPTR[CONST2]);
CPTR[CONST2]_0);
IF .CPTR[CNTOBEALCFLG] THEN
BEGIN
CPTR[IDADDR]_.HILOC;
%NOW PUT CONSTANT OUT IN REL FILE
REMEMBER THAT THIS ROUTINE IS EXECUTED WITHIN
A TEST FOR THE REL FILE GENERATION%
RELCONST(CPTR); !IN MACRO ABOVE
END;
CPTR_.CPTR[CLINK];
END;
END;
END;
IF (CPTR _ .LITPOINTER<LEFT>) NEQ 0
THEN DO
(IF .CPTR[CNTOBEALCFLG] THEN
BEGIN
CPTR[LITADDR] _ .HILOC;
INCR I FROM 0 TO .CPTR[LITSIZ]-1 DO
(RDATWD _ .(CPTR[LIT1]+.I);
ZOUTBLOCK(RCODE,RELN);
HILOC _ .HILOC+1; !INCREMENTING FOR ZOUTBLOCK
);
END;
) WHILE (CPTR _ .CPTR[LITLINK]) NEQ 0;
LOWLOC _ .HILOC;
HILOC _ .SAVHILOC; !RESTORING
END;
GLOBAL ROUTINE ALCTMPS=
BEGIN
!ROUTINE CLEANS UP ALL THE ALLOCATION OF VARIABLES.
!THIS IS A THREE STEP PROCESS.
! 1. GO THROUGH THE SYMBOL TABLE AND ALLOCATE ALL
! THOSE PREVIOUSLY UNALLOCATED. THIS IS PRIMARILY
! THE TEMPS GENERATED FOR REGISTER SAVE/RESTORE
! FOR A SUBROUTINE OR FUNCTION.
! 2. THE SECOND REASON WENT AWAY. HURRAY!
! 3. THE TEMPS GENERATED IN THE LOCAL REGISTER
! ALLOCATION PROCESS.
EXTERNAL SYMTBL,LOWLOC,ADJHEAD,ANCHOR,PROGNAME;
%[735]% LOCAL CNT,HDRFLG;
%[735]% ROUTINE HDRTMP=
%[735]% LSTHDR(4,3,PLIT'?M?JTEMPORARIES?M?J?M?J?0');
!FIRST THE SYMBOL TABLE
%[735]% HDRFLG _ CNT _ 0;
INCR K FROM 0 TO SSIZ-1 DO
BEGIN
REGISTER BASE T;
T_.SYMTBL[.K];
WHILE .T NEQ 0 DO
BEGIN
IF .T[IDADDR] EQL 0
THEN IF NOT .T[IDATTRIBUT(INCOM)] AND .T[OPRSP1] NEQ FNNAME1
AND NOT .T[IDATTRIBUT(NOALLOC)] AND NOT .T[IDATTRIBUT(COMBL)] THEN
BEGIN
T[IDADDR]_.LOWLOC;
LOWLOC_.LOWLOC+1+.T[DBLFLG];
IF .FLGREG<LISTING> THEN
%[735]% ( IF .HDRFLG EQL 0 THEN (HDRFLG_1;HDRTMP());
%[735]% LISTSYM(.T);
IF (CNT _ .CNT+1) GTR 5 THEN (CNT_0; CRLF; HEADCHK());
);
END;
T_.T[CLINK];
END;
END;
!NOW (FOR EITHER SUBPROGRAM OR MAIN PROGRAM, THE TEMPS
!GENERATED BY LOCAL REGISTER ALLOCATION
WHILE .ANCHOR NEQ 0 DO
BEGIN
MAP BASE ANCHOR;
ANCHOR[IDADDR]_.LOWLOC;
LOWLOC_.LOWLOC+1;
IF .FLGREG<LISTING>
%[735]% THEN ( IF .HDRFLG EQL 0 THEN (HDRFLG_1;HDRTMP());
%[735]% LISTSYM(.ANCHOR);
IF (CNT _ .CNT+1) GTR 5 THEN (CNT_0; CRLF; HEADCHK());
);
!**NOTE**
!THESE ARE ALSO SINGLE CELL. NXTTMP TAKES
!CARE OF GETTING TWO FOR A DOUBLE WORD QUANTITY
ANCHOR_.ANCHOR[CLINK];
END;
IF .FLGREG<LISTING> THEN (CRLF; HEADCHK());
END;
GLOBAL ROUTINE HISEGBLK=
BEGIN
!ROUTINE GENERATES A HISEG BLOCK IN THE THE REL FILE
!WORD 1 OF THE HISEG BLOCK IS THE TWOSEG PSEUDO OP ID
!WORD 2 IS THE SIZE OF THE LOWSEG IN WORDS IN THE LEFT HALF
! AND ZERO IN THE RIGHT HALF
!WORD 2 IS ONLY USEFUL IF WE WISH TO LOAD EXECUTABLE CODE IN THE LOWSEG
! INSTEAD OF THE HISEG
%1133% EXTERNAL CHDSTART,RADIX50;
EXTERNAL RDATWD,ZOUTBLOCK,LOWLOC;
HILOC _ #400000; !USUALLY THAT
IF .LOWLOC GEQ (#400000-#1000) !BIG LOW SEG
THEN HILOC_(.LOWLOC+#777+#1000)AND NOT #777; !ROUND UP
%1133% CHDSTART _ .HILOC; ! Start of character descriptors
RDATWD_.HILOC^18 + .HILOC; !IN BOTH HALVES
ZOUTBLOCK(RHISEG,RELRI);
RDATWD _ .LOWLOC^18 + 0;
ZOUTBLOCK(RHISEG,RELN);
END; !OF HISEGBLK
GLOBAL ROUTINE RELINIT= !INITIALIZES REL FILE
BEGIN
%
GENERATES BLOCKS 4 - ENTRY
6 - NAME
3 - HISEG
%
EXTERNAL RELDATA,RELOCWD,PROGNAME,MULENTRY,HILOC;
EXTERNAL INIRLBUFFS; !TO INIT REL FILE BUFFERS
MAP BASE MULENTRY; !PTR TO CHAIN OF MULTIPLE ENTRIES OF THIS SUBPROGRAM
%[1003]% BIND KSCPU = 1^33, ! KS10 cpu type
%[1003]% KLCPU = 1^32, ! KL10
%[1003]% KICPU = 1^31, ! KI10
%[1003]% KACPU = 1^30, ! KA10 - no longer supported
%[1003]% FTNID = #10^18, ! compiled /NOGFLOATING
%[1003]% GFTNID =#23^18; ! compiled /GFLOATING
!
INIRLBUFFS(); !INITIALIZE THE REL FILE BUFFERS
!INIT FIRST BLOCK
!
R2 _.PROGNAME;
WHILE 1 DO
(
RDATWD _ RADIX50();
ZOUTBLOCK(RENTRY,RELN);
IF .MULENTRY NEQ 0
THEN (R2 _ .MULENTRY[IDSYMBOL]; MULENTRY _ .MULENTRY[IDENTLNK])
ELSE EXITLOOP;
);
RDATWD _ (R2 _ .PROGNAME; RADIX50());
ZOUTBLOCK(RNAME,RELN); !NAME BLOCK
![1003] Output compiler and processor bits to .REL file based on /GFLOATING
%[1003]% IF .GFLOAT
%[1003]% THEN RDATWD _ KLCPU + GFTNID
%[1003]% ELSE RDATWD _ KSCPU + KLCPU + KICPU + FTNID;
ZOUTBLOCK(RNAME,RELN); !THE FORTRAN-IV IDENTIFER
!NOW FOR HISEG
.VREG
END;
END
ELUDOM