Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-SB_FORTRAN10_V10
-
outmod.bli
There are 26 other files named outmod.bli in the archive. Click here to see a list.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1973, 1985
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
!AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!AUTHOR: F. INFANTE/MD/DCE/JNG/TFV/CDM/AHM/RVM/EGM/PLB/AlB/MEM
MODULE OUTMOD(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND OUTMOV = #10^24 + 0^18 + #2507; ! Version Date: 20-Dec-84
%(
***** 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.
***** Begin version 6A *****
97 1146 EGM 5-Jan-82 20-17060
Pass the ISN of the illegal Equivalance group for error IED.
1151 EGM 25-Mar-81
Report ?Program too large for COMMON 512P and up
***** Begin Version 7 *****
81 1246 CDM 1246 ------
Edit SUBPROGLIST so that inline functions names are not printed
out in listings.
82 1232 TFV 24-Jun-81 ------
Rewrite ALLSCAA and ALCCON to handle character data and character
constants. Output character data to the .REL file. Write LSCHD to
output the descriptors to the low seg for dummy args; write HSCHD to
output descriptors to the high seg for non-dummy arg character data;
also write HSLITD to output descriptors to the high seg for character
constants. Also add a new section to the .LST file for character data.
Write LISTCHD to list character variable and array names, descriptor
locations, location and character position for the start of the data,
and the length of the data.
83 1261 CKS 17-Sep-81
Modify common and equivalence allocation to support type CHARACTER.
Have all equivalence processing done in characters instead of words.
Convert back to words at the end.
84 1262 CKS 22-Sep-81
Allow substrings in character EQUIVALENCE classes
85 1264 CDM 24-Sep-81
Revise edit to that "SUBPROGRAMS CALLED" is not put on program
listings for inline functions.
88 1272 RVM 15-Oct-81
Convert REAL constants from DOUBLE PRECISION, even if the constant
is part of a MOVEI.
89 1274 TFV 16-Oct-81 ------
Fix ALCQVARS to handle multi-word .Q variables.
90 1406 TFV 27-Oct-81 ------
Write HSDDESC to output .Dnnnn compile-time-constant character
descriptors to the .REL file. Either one word (byte pointer
only) or two words (byte pointer and length) are output based on
the flag IDGENLENFLG. One word .Dnnnn variables are used for
SUBSTRINGs with constant lower bounds and non-constant upper
bounds. Use BPGEN to create byte pointers that are output to
the .REL file.
91 1424 RVM 19-Nov-81
Precede the formats in the object program by a count of the number
of words in the format (in other words, make formats look like
BLISS-10 PLIT's). This is needed for assignable formats.
92 1434 TFV 14-Dec-81 ------
Fix multi-entry character functions. All the entry points share the
same descriptor. The descriptor is generated in ALLSCAA for the
main entry point. Fixup the other entry points so that their IDADDR
fields point to the descriptor for the main entry point. Fix HSCHD
to generate descriptors for character functions that are declared
external.
93 1443 RVM 17-Dec-81
ALLFORM never thought that there could be backwards references to
format statements, and so never set up the SNSTATUS field. With
ASSIGNed FORMATs, there can be backwards references.
94 1437 CDM 16-Dec-81
Create and initialize new global variable HIORIGIN to store the
origin of the Hi-seg.
95 1450 CKS 30-Dec-81
Detect the error in EQUIVALENCE (A(1),A(2))
96 1451 CKS 30-Dec-81
Fix HSDDESC to handle common variables as subnodes of .D descriptors.
98 1454 RVM 7-Jan-82
Consolidate the routines ALLFORM and DMPFORMAT into one routine that
both allocates addresses to the formats and (if needed) dumps the
formats to the .REL file. The new routine is called DUMPFORMAT.
99 1455 TFV 5-Jan-82 ------
Fix ALLSCAA to allocate character statement function names.
They have an extra argument. It is the descriptor for the
result. It is stored into the space allocated for the statement
function name.
1511 CDM 17-Mar-82
Count the number of COMMON blocks for a SAVE statement with no
arguments. (All common blocks must be output in the rel block
for SAVE processing). Also error processing for variables
which suddenly become in common through equivalencing.
1512 AHM 26-Mar-82
Change all calls to ZOUTBLOCK that used RSYMBOL (rel block
type 2) to call ZSYMBOL instead.
1522 TFV 29-Mar-82
Fix error diagnostic for length star variables and arrays.
Length star is legal only for dummy arguments and character
parameters. Cause an ICE if a .Dnnnn variable has a length less
than 1.
1525 AHM 1-Apr-82
Various changes for psected REL files. Suppress generation of
the type 3 HISEG block. Generate type 24 psect header blocks
for each psect. Put in a type 17 .REQUEST FORLIB:FORLIB block
for development to read in a private FORLIB that is psected
instead of being TWOSEG. Turn off KS bit in the type 6 name
block when compiling /EXTENDED.
1526 AHM 7-Apr-82
Pave the way for psected rel files by converting all calls to
ZOUTBLOCK for outputting RCODE (type 1) rel blocks to call
ZCODE instead. Use the proper relocation counter to allocate
space for each psect instead of always using HILOC to tell
ZOUTBLOCK what address is being output. Fix bug caused by
mixing edits 1261 and 1151 which caused rejection of common
blocks longer than 1/5th of a section.
1527 CKS 29-Apr-82
Do not allocate storage for PARAMETER variables. They get into
the symbol table as scalars when they appear in type declaration
statements, but no storage should be allocated for them.
1531 CDM 14-May-82
Make changes for new use of NUMSAVPTR and change error message
E192 to E197 for SAVE error processing.
1534 CKS 17-May-82
Fix output of character constants in the listing. Use uparrow
format instead of sending the control character directly.
1537 AHM 20-May-82
Prepend some innocuous entries to the BPLH UPLIT so that bad
negative character addresses propagated from users trying to
extend common blocks backward don't get junk listings of the
byte pointers.
1544 AHM 26-May-82
Output type 22 default psect index blocks for the .DATA. psect
before type 21 or 1004 sparse data blocks so that they have a
chance to work while the new psected sparse data blocks are
not in LINK. This edit is only for V8 development and will be
removed when the LINK support is finally in.
1547 AHM 1-Jun-82
Make PROCCOM change the size of a COMMON block from characters
to words before it is added into the total size of all COMMON
blocks.
1564 AHM 21-Jun-82
Don't put out a .REQUEST FORLIB:FORLIB block in RELINIT under
/EXTEND - it isn't needed anymore. Also, uncomment the
section 1 psect origins.
1567 CDM 24-Jun-82
Don't output .Dnnn variables if NOALLOC is lit.
1615 AHM 16-Aug-82
Change the default psect index to .DATA. before outputting
common block sizes in ALLCOM. LINK will be changed to
allocate common blocks in the default psect when reading
psected .REL files.
1627 CKS 31-Aug-82
Do not allocate .D variables to hold the result of CHAR function when
CHAR(constant-expr) in a PARAMETER statement has been replaced by a
simple constant.
1630 AHM 1-Sep-82
Fix bug introduced by edit 1615. Don't output a default psect
index if there is no .REL file being generated.
1666 TFV 8-Nov-82
Fix RELINIT to always use FORTRAN for the compiler id. The id
for GFLOATING FORTRAN is no longer used. Type coercion is now
used for DP actuals passed to GFLOATING formals and vice versa.
1675 RVM 11-Nov-82 Q10-03032
Implement a suggestion to include more information in the
warning message E168.
1703 CDM 17-Dec-82
Do not output any processor type to rel file. V5A only puts out
KI, and V7 will not work on a KI, so if we tell Link the truth,
users with libraries will get Link-time warnings.
***** End V7 Development *****
1733 RJD 21-Mar-83 SPR 10-33670
Set ISN to zero when in ALCCON as any over/underflows that
may occur at that time are not associated with a particular
line number.
***** Begin Version 10 *****
2207 CDM 21-Jul-83
Reformat and comment equivalence routines ALLOCAT, EQERRLIST,
LINKGROUPS, ELISTSEARCH, GRPSCAN, PROCEQUIV. Delete macro
EQGPPTR which was defined to be EQLPTR in PROCEQUIV.
2210 AHM 27-Jul-83
Rename DUMPFORMAT to DMPFORMAT to reserve DUMP?? for SIX12.
2216 PLB 27-Sep-83
Modify ZOUTBP and CHADDR2BP to handle OWGBPs, Depending on
state of OWGBPSECTION global; Create routine BPADD to replace
MACRO from TABLES.
2232 RVM 8-Nov-83
Allocate variables into the proper psect. The IDADDR and
IDPSCHARS now get their values based on the IDPSECT and
IDPSCHARS fields, respectively. IDPSECT and IDPSCHARS contain
"psect indexes," which are indexes into the vector PSECTS.
The PSECTS vector contains the next allocated offsets into the
low and high segments (/NOEXTEND) or the next allocated
offsets into .DATA., .CODE., or .LARG. psects (/EXTEND).
Pretty much, this edit consisted of replacing LOWLOC and
LARGELOC by PSECTS[.SYMBOL[IDPSECT]].
2233 AlB 9-Nov-83
Move the calculation of the total size of common from PROCCOM
to ALLCOM, so that this total will reflect any influence by
the EQUIVALENCE statement. Changes to ALLOCAT, PROCCOM, ALLCOM.
2235 AlB 10-Nov-83
1. Worry about the effect of extended addressing on EQUIVALENCE
and COMMON processing. Essentially, if any variable is
equivalenced to a common variable, the former variable takes
the psect of the common block. If any equivalence group
contains all non-common, then the psect for all items in that
group becomes .LARG. if any one of the items is .LARG., and
.DATA. otherwise.
2. Clean up some WHILE 1 DO code to better illustrate what is
happening. (Change to UNTIL x EQL 0 DO).
3. Replace all literal values associated with EQVAVAIL with
named constants.
4. Change reference to LOWLOC to refer to PSECTS table. This is
code that was not changed by Edit 2232.
Changes to ALLCOM, PROCCOM, ELISTSRCH, EQCALLOC, GRPSCAN and
PROCEQUIV
2236 AlB 11-Nov-83
Remove the code which jams PSDATA into COMPSECT. That code now
resides in NEWENTRY of module SRCA.
Routine affected: PROCCOM
2266 AHM 13-Jan-84
Change the origin of the .CODE. psect (CODEORG) in RELINIT
from 1,,140 to 1,,1000 so that the program's fake JOBDAT page
is not read only.
2271 AlB 18-Jan-84
1) If single subscript used on multi-dimensioned array in EQUIVALENCE,
put out compatibility warning.
2) Do range checking on that single subscript.
3) Generate compatibility warning if logical and numeric data are
in the same EQUIVALENCE list.
4) Change the 'Char and Non-Char' warning to be generated only if
we are doing compatibility flagging (COMMON and EQUIVALENCE).
Routines:
ALLCOM EQCALLOC PROCEQUIV
2310 CDM 13-Feb-84
Output type 1131 rel block for PSECT redirection of segments
into psects. The command scanner sets the names for the psects
and the code generator dumps the rel block. Discontinue putting
out type 22 blocks in same region of code.
2311 PLB 19-Feb-84 WAR IS PEACE
Modify symbol listings under /EXTEND
2322 CDM 27-Apr-84
Fix array subscript calculations for /EXTEND to use a full word
to calculate arithmetic. In PROCEQUIV and BLDDIM, check an
array reference against the correct maximum size of an array
declaration /EXTEND. In BLDDIM, call CNSTCM for array
calculations to give underflow/overflow messages for illegal
declarations. Otherwise arrays that are too large may not be
detected since their size will overflow.
2330 AHM 28-Mar-84
Remove all uses of global OWGBPSECTION. Use EXTENDED flag to
decide when to deal with OWGBPs instead of OWLBPs. Use
Z30CODE to generate all byte pointers. Generate 30 bit
additive fixups for OWGBPs that reference COMMON. Use EFIWs
for CHARACTER FUNCTION descriptors under /EXTEND to make
multiple sections of code work.
2342 AHM 17-Apr-84
Make DATA statements work for some variables in .LARG. Make
OUTDATA use the psect indices in the variables it is passed
instead of always using .DATA. This should allow numeric
variables in the first section of .LARG. to be statically
initialized by DATA statements.
2344 PLB 19-Apr-84
Make ZOUTBP output 0(?) if BP to output is equal to zero.
2345 AHM 20-Apr-84
Make HSCHD in OUTMOD use additive fixups to generate the
indirect words for external CHARACTER function descriptors.
This makes the code agree with the comments and design spec,
and avoids a LINK bug with deferred 30 bit chained fixups.
2346 AHM 23-Apr-84
Make ALLCOM keep separate totals of the sizes of small and
large COMMON blocks in the new globals SCOMSZ and LCOMSZ.
ALLCOM no longer has a return value, since no one cares about
the sum of the sizes of all COMMON blocks.
2356 AHM 8-May-84
Add support for individual specification of the psects for
COMMON blocks. Do it by putting the body of the outermost
loop in ALLCOM in a new routine named ALCCOMMON, and having
ALLCOM call it to walk the list of COMMON blocks once for each
of .DATA. and .LARG. Also, change the default psect origin
for .DATA. to 1000140 and .CODE. to 1300000. This way, the
impure data areas have the lowest addresses in both section 0
and non-zero sections.
2357 AHM 14-May-84
Keep LINK from getting ?LNKIPX Invalid psect index when
loading programs with COMMON blocks compiled /NOEXTEND.
During COMMON block allocation (ALLCOM) only output type 22
(RPSECTORG) REL blocks under /EXTEND.
2414 AlB 5-Jul-84
When an array is referenced in an EQUIVALENCE statement, the
subscripts are now checked for 'out of bounds'. The check used
to be done (badly) for the case of single subscripts with
multi-dimensioned arrays; it was never done for multiple subscripts.
The 'out of bounds' message is a warning only; old sources will
still work, albeit with a warning.
2423 AHM 17-Jul-84
Move OUTDATA to DATAST, where it can share secret OWNs for
buffering Ultimate Sparse Data REL blocks.
2440 RVM 1-Aug-84
Change the origin of the PSDATA psect from 1000140 to 1001000.
FORDDT and FOROTS have reserved the first page of every section
which contains code.
2446 MEM 31-JUL-84
Have RELINIT produce type 1050 rel blocks when /EXTEND is given,
instead of type 24 rel blocks. This will now store psect names up to
72 characters.
2454 RVM 28-Aug-84
Move the definition of DEFLON (the default value for LONAME)
and DEFHIN (the default value for HINAME) from CMND20 into
GLOBAL. Then make OUTMOD use DEFLON and DEFHIN where in the
twoseg redirection rel block.
2455 MEM 30-Aug-84
Replace all occurrences of VAX with VMS.
2507 CDM 20-Dec-84
Add enhancement for IMPLICIT NONE (edit 2473) after code inpsection.
Check more cases, and add a symbol table walk at the back
end to catch unreferenced variables.
***** End V10 Development *****
***** End Revision History *****
)%
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE REQREL.BLI;
SWITCHES LIST;
FORWARD
CHADDR2BP(1),
SIZEINCHARS(1),
LSTHDR(3),
LISTSYM(1),
SUBPROGLIST,
ALLSCAA,
ALLOCAT,
ALLCOM, ! Allocates all the COMMON blocks
%2356% ALCCOMMON, ! Allocates all COMMON blocks in a given psect
%2210% DMPFORMAT, ! Allocates FORMATs and dumps them to .REL file
PROCCOM,
EQERRLIST(1),
GROUPTOCOMMON(4),
LINKGROUPS(3),
ELISTSRCH(2),
EQCALLOC(1),
GRPSCAN,
PROCEQUIV,
ALCCON,
HSLITD,
HSCHD,
HSDDESC,
HDRCHD,
TABOUT,
ZOUTBP(1),
LISTCHD(2),
ALCQVARS,
HDRTMP,
HISEGBLK,
RELINIT,
%2446% TYPE1050,
%2310% PSREDIRECT, ! Outputs PSECT redirection rel blocks
%2507% CIMPLNONE; ! Check symbols for IMPLICIT NONE
EXTERNAL
ALODIMCONSTS, ! Routine to set "CNTOBEALCFLG" in all constants used
! for dimensioning arrays that are to have bounds
! checking performed on them
ARRXPN, ! For expanding array references in EQUIVALENCE items
C2H,
C2L,
%2455% CFLAGB, ! Put out "Fortran-77 or VMS: ...." flagger warning
%1522% CGERR, ! Routine to report an internal compiler error
CHAROUT,
%1245% CHDSTART,
%1261% CNSTEVAL, ! For evaluating subscript expression if necessary
COMBLKPTR,
DANCHOR, ! Pointer to the start of the .Dnnnn variables
%2454% DEFLON, ! Default name for the data psect
%2454% DEFHIN, ! Default name for the code psect
DMPMAINRLBF, ! Routine to output the contents of the main .REL file
! buffer and reiinitialize it
%1525% DMPRLBLOCK, ! Outputs data to the object and listing files
E33,
E48,
E49,
E53,
E93,
E103,
%1261% E162,
%1261% E165,
E166,
E167,
E168,
E194,
%1531% E197, ! "<foo> EQUIVALENCE-d to COMMON is illegal"
%2455% E249, ! "VMS incompatibility: Mixing Logical and Numeric in EQUIV"
%2271% E274, ! "Extension to Fortran-77: Single dimension with multi.."
%2271% E293, ! "Subscript out of range for array xxxx"
%2507% E304, ! Warning - IMPLICIT NONE
ENDSCAA,
%1434% ENTRY, ! Pointer to a sixbit name for an identifer
EQVPTR, ! Pointer to first and last EQUIVALENCE groups
FATLERR,
FORMPTR,
%735% HDRFLG, ! Scalars and arrays listing header flag
HEADCHK, ! Checks for end of listng page
%[735]% HEADING,
HILOC, ! Next available address in the high seg
%2310% HINAME, ! Name of the high (code) PSECT in SIXBIT.
%1437% HIORIGIN, ! Start of Hi-seg
%2507% IMPNONE, ! Flag for IMPLICIT NONE
INIRLBUFFS, ! To init .REL file buffers
ISN,
%1006% KISNGL, ! KISNGL is now in UTIL.BLI
%2356% LCOMP, ! Flag for at least one COMMON block in .LARG.
%2346% LCOMSZ, ! Sum of the sizes of all large COMMON blocks in words
LITPOINTER,
%2310% LONAME, ! Name of the low (data) PSECT in SIXBIT.
LOWLOC, ! Next available address in the low seg
LSTOUT,
RELBUFF MAINRLBF, ! Main .REL file buffer
BASE MULENTRY, ! Pointer to the list of entries for this subprogram
%1434% NAME, ! Table to search for tblsearch lookups
%1511% NUMSAVCOMMON, ! Pointer to SAVE-d common blocks
PAGELINE,
PROGNAME,
%2232% PSECTS, ! Vector of next available address for each PSECT
%1274% QANCHOR,
%1274% QMAX,
RADIX50,
RDATWD,
RELBLOCK,
RELDATA,
RELOCWD,
RELOUT,
%1511% SAVALL, ! SAVE statement with no args given
%2356% SCOMP, ! Flag for at least one COMMON block in .DATA.
%2346% SCOMSZ, ! Sum of the sizes of all small COMMON blocks in words
%2507% SRCHLIB, ! Searches if a name is a library function
STRNGOUT,
%2507% SYMTBL, ! Hashed symbol table
%1434% TBLSEARCH, ! Routine to lookup symbol table entries
%1245% TCNT,
%2322% VMSIZE, ! Size of virtual memory
WARNERR,
%2330% Z30CODE, ! Outputs a word using type 1 or 1030 rel blocks
%1526% ZCODE, ! Outputs a word using type 1 or 1010 rel blocks
ZOUDECIMAL,
ZOUOFFSET,
%2311% ZOUTADDR, ! OUTPUT LONG ADDR IN R2
ZOUTBLOCK,
ZOUTMSG, ! Message outputter
ZOUTOCT, ! OUTPUT HALFWORD IN R2<LH>
ZOUTSYM,
%1512% ZSYMBOL; ! Outputs type 2 or 1070 rel blocks
MACRO MODULO (A,B) = ! [1261] Positive remainder of A / B
BEGIN
REGISTER T1;
T1 _ (A) MOD (B);
IF .T1 LSS 0 THEN T1 _ .T1 + (B);
.T1
END$;
! LEFT HALF OF OWL BYTE POINTER INDEX BY BYTE NUMBER -4:4
BIND VECTOR BPLH = 4 + UPLIT (0<29,7>,0<22,7>,0<15,7>,0<8,7>, ![1537] -4:-1
0<36,7>,0<29,7>,0<22,7>,0<15,7>,0<8,7>); ! 0:4
%2216% ! P&S FIELD OF OWG BYTE POINTERS INDEXED BY BYTE NUMBER -4:4
%2311% BIND VECTOR OWGP&S = 4 + UPLIT (#62^30,#63^30,#64^30,#65^30, ! -4:-1
%2311% #61^30,#62^30,#63^30,#64^30,#65^30); !0:4
ROUTINE CHADDR2BP (A) = ! [1261] Convert character address A to
! equivalent byte pointer
%2330% IF EXTENDED !CHECK IF MAKING OWG BPs
%2330% THEN (.A/5) OR .OWGP&S[.A MOD 5] !YES
%2216% ELSE (.A/5) OR .BPLH[.A MOD 5]; !NO, USE OWL LEFT HALF
GLOBAL ROUTINE BPADD (BP,N)= ![2216] DO ADJBP FOR OWL OR **7-BIT** OWGBP
! Example: XXX = BPADD(.SYM[IDCHBP],.SYM[IDCHLEN])
! PTR = BPADD(.PTR,-1)
! BP = byte pointer
! N = value to increment BP by
IF .N NEQ 0 !NON-ZERO ADJUSTMENT?
THEN !YES, CHECK IF USING OWG/OWL
%2330% IF EXTENDED !/EXTEND?
THEN !YES!, ADJUST OWG
BEGIN !OWG
! UGLY BUT VERY FAST CODE
VREG = .BP<0,30>; !GET 30 BIT ADDR
VREG = .VREG * 5; !MAKE CHARACTER ADDR
VREG = .VREG + .N; !ADD OFFSET
VREG = .VREG - #61; !SUBTRACT OWG OFFSET
VREG = .VREG + .BP<30,6>; !ADD OWG P&S FIELD
RETURN .OWGP&S[.VREG MOD 5] OR (.VREG/5) !CONVERT BACK
END !OWG
ELSE !NOT EXTENDED
BEGIN !OWL
MACHOP ADJBP=#133;
REGISTER T1;
T1 _ .N;
RETURN ADJBP(T1,BP)
END
ELSE !ADJUST BY ZERO
RETURN .BP; !RETURN UNCHANGED (ADJBP CONONICALIZES THO)
ROUTINE SIZEINCHARS (SYMPTR) = ! [1261] Find size of scalar or array, given
! address of its symbol table entry
BEGIN
MAP BASE SYMPTR;
IF .SYMPTR[IDDIM] NEQ 0
THEN
BEGIN !ARRAY
REGISTER BASE DIMPTR;
DIMPTR _ .SYMPTR[IDDIM];
IF .SYMPTR[VALTYPE] EQL CHARACTER
THEN .DIMPTR[ARASIZ] ! ARASIZ chars for character array
ELSE .DIMPTR[ARASIZ] * CHARSPERWORD ! ARASIZ words for numeric array
END !ARRAY
ELSE
BEGIN !SCALAR
IF .SYMPTR[VALTYPE] EQL CHARACTER
THEN .SYMPTR[IDCHLEN] ! IDCHLEN chars for character scalar
ELSE IF .SYMPTR[DBLFLG]
THEN 2 * CHARSPERWORD ! 10 chars for double word numeric
ELSE CHARSPERWORD ! 5 chars for single word numeric
END ! SCALAR
END; ! of SIZEINCHARS
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]% IF .PAGELINE LEQ .MINLINE
%[735]% THEN %NO ROOM ON THIS PAGE% HEADING();
%[735]% PAGELINE _ .PAGELINE-.HDRLINES;
%[735]% STRNGOUT(.HDRPTR);
%[735]% END; ! of LSTHDR
GLOBAL ROUTINE LISTSYM(PTR)=
BEGIN
MAP BASE PTR;
LABEL BLNK;
R2 _ .PTR[IDSYMBOL];
%2311% % NOTE INSTANCES OF LARGE, NO EXPLICIT DEFINITION %
BLNK:BEGIN
%2311% IF .PTR[VALTYPE] EQL CHARACTER
%2311% THEN
%2311% BEGIN !CHECK FOR LARGE CHARACTER
%2311% IF .PTR[IDPSCHARS] EQL PSLARGE
%2311% THEN ( CHAROUT( "!" ); LEAVE BLNK ); !FLAG IT
%2311% END !CHECK FOR LARGE CHARACTER
%2311% ELSE !CHECK FOR LARGE NUMBERIC
%2311% IF .PTR[IDPSECT] EQL PSLARGE !VARIABLE IN .LARG. ?
%2311% THEN ( CHAROUT( "!" ); LEAVE BLNK ); !YES, FLAG IT
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
%2311% IF .PTR[VALTYPE] NEQ CHARACTER
%2311% THEN
%2311% BEGIN !LIST ADDR FOR NUMERIC
%2311% IF EXTENDED
%2311% THEN
%2311% BEGIN !EXTENDED
%2311% R2 _ .PTR[IDADDR]; !GET NUMERIC ADDR
%2311% ZOUTADDR(); !OUTPUT LONG ADDR
%2311% IF .PTR[IDADDR] LSS 1^21 !TOO SMALL?
%2311% THEN (CHR_#11; LSTOUT()) !ADD A TAB
%2311% END !EXTENDED
%2311% ELSE
%2311% BEGIN !NOT EXTENDED
%2311% R2<LEFT> _ .PTR[IDADDR]; !GET ADDR<RH>
%2311% ZOUTOCT() !OUTPUT 18 BITS
%2311% END !NOT EXTENDED
%2311% END !LIST ADDR FOR NUMERIC
%2311% ELSE
%2311% ZOUTBP(.PTR[IDCHBP]); !IF CHAR, LIST ADDR(POS)
CHR_#11;LSTOUT(); !TAB
END; ! of LISTSYM
ROUTINE SUBPROGLIST=
BEGIN
!
!Lists called subprograms on list device in allocation summary
!
%[735]% LOCAL BASE SYMPTR,COUNT;
%[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
!1246 Output function name only if not an inline function.
IF .SYMPTR[OPRSP1] EQL FNNAME1
THEN IF NOT .SYMPTR[IDATTRIBUT(NOALLOC)]
%1264% AND NOT .SYMPTR[IDINLINFLG]
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 SUBPROGLIST
ROUTINE ALLSCAA=
BEGIN
! 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.
! Allocates low seg descriptors for character dummy args. Also
! generates scalar and array section of .LST file for non-character
! data. This is done all at once since scanning the symbol table can
! be slow.
%1232% ! Routine rewritten by TFV, 24-Jun-81
%1232% ! Character data allocation added and block structure fixed up
OWN PTR,SCNT;
%2311% LOCAL HOWIDE; !NUMBER OF SYMBOLS / LISTING LINE
LOCAL BASE ARRAPT;
LABEL L1,L2;
MAP BASE PTR;
ROUTINE LSCHD=
BEGIN
! Outputs lowseg descriptor for character dummy args. IDADDR
! points to descriptor. We init the count word with the
! length unless dummy is length *
LOWLOC _ .LOWLOC + 1; ! Byte pointer to character data copied in at
! subroutine/function entrance; skip a word
! If length *, actual length copied in at subroutine/function
! entrance. Otherwise init the length word in the .REL file.
IF .PTR[IDCHLEN] NEQ LENSTAR AND .FLGREG<OBJECT>
%1526% THEN IF EXTENDED
%1526% THEN ! Use type 1010 blocks
%1526% BEGIN
%1526% DMPMAINRLBF(); ! Storing in different location
! Can't let this get appended
! to a previous type 1010 block
%1526% RDATWD _ .PTR[IDCHLEN]; ! Use declared length
%1526% ZCODE(PSABS,PSDATA); ! Output length to .DATA. using
! code block with no relocation
%1526% DMPMAINRLBF() ! Can't let this get prepended
! to the next type 1010 block
%1526% END
%1526% ELSE ! NOT EXTENDED
BEGIN ! Use type 21 blocks
IF .MAINRLBF[RDATCNT] GTR RBLKSIZ-4
THEN DMPMAINRLBF(); ! No room left in buffer for
! 2 words
RDATWD _ (1^18) + .LOWLOC; ! count,,relocatable address
! of descriptor length word
ZOUTBLOCK(RDATBLK,RELRI); ! Output using sparse data
! block, relocate the
! address
RDATWD _ .PTR[IDCHLEN]; ! Use declared length
ZOUTBLOCK(RDATBLK,RELN); ! Output length to low seg
! using sparse data block
! with no relocation
END;
LOWLOC _ .LOWLOC + 1 ! Increment LOWLOC since we
! outputted or skipped a word
END; ! of LSCHD
%[735]% ROUTINE HDRSAA= ! Routine to output scalar and array banner
%2311% IF EXTENDED
%2311% THEN
%2311% LSTHDR(5,4,PLIT '
?JSCALARS AND ARRAYS [ "*" NO EXPLICIT DEFINITION - "%" NOT REFERENCED ]
?J [ "!" VARIABLE STORED IN .LARG. ]?M?J?M?J?0')
%2311% ELSE
%[735]% LSTHDR(4,3,PLIT '?M?JSCALARS AND ARRAYS [ "*" NO EXPLICIT DEFINITION - "%" NOT REFERENCED ]?M?J?M?J?0');
%2311% IF .FLGREG<LISTING> !IF LISTING
%2311% THEN
%2311% HOWIDE = IF EXTENDED THEN 2 !3 /EXTENDED SYMBOLS / LINE
%2311% ELSE 4; !FIVE OTHERWISE
%[735]% HDRFLG_0;
SCNT_0;
DECR I FROM SSIZ-1 TO 0 DO ! Walk through hash table entries
BEGIN
PTR _ .SYMTBL[.I]; ! Entry for this hash
WHILE .PTR NEQ 0 DO ! Walk down linked list of symbols
BEGIN
IF NOT .PTR[IDATTRIBUT(INCOM)]
AND NOT .PTR[IDATTRIBUT(NAMNAM)]
%1527% AND NOT .PTR[IDATTRIBUT(PARAMT)]
%1455% AND (NOT .PTR[OPERSP] EQL FNNAME OR
%1455% (.PTR[VALTYPE] EQL CHARACTER AND .PTR[IDATTRIBUT(SFN)]))
THEN
! Neither in common, namelist, parameter, nor
! function name. Allocate character statement
! function names.
IF .PTR[IDATTRIBUT(NOALLOC)]
THEN
BEGIN
! Note names which have been declared but never
! referenced and thus never allocated.
! List never allocated character variables also
IF .FLGREG<LISTING>
THEN
BEGIN ! Output symbol to listing with '%'
IF .PTR[OPRSP1] EQL ARRAYNM1
OR .PTR[IDATTRIBUT(INTYPE)]
OR .PTR[IDATTRIBUT(DUMMY)]
THEN
BEGIN ! Declared in dimension, type, or as dummy arg
%[703]% IF .SCNT LEQ 0 THEN HEADCHK();
%[735]% IF .HDRFLG EQL 0
THEN
BEGIN
! Output Scalar and array banner
HDRFLG_1;
HDRSAA();
END;
R2_.PTR[IDSYMBOL];
CHAROUT("%"); ! Flag never referenced with '%'
ZOUTSYM();
CHAROUT(#11); ! Tab
CHAROUT(#11); ! Tab
%2311% IF EXTENDED !/EXTEND?
%2311% THEN CHAROUT(#11); !ONE MORE
%2311% IF .SCNT LSS .HOWIDE
THEN SCNT _ .SCNT+1
ELSE
BEGIN
SCNT _ 0;
CRLF;
END;
END ! Declared in dimension, type, or dummy arg
END ! Output symbol to listing with '%'
END
ELSE
BEGIN
! Symbol is defined and referenced so allocate
! space for it. Not in common, namelist, nor
! function name. Non-dummy character data gets
! allocated in the lowseg; descriptor in hiseg
! Dummy character data gets IDADDR pointing to
! the descriptor in the lowseg.
! Other data has IDADDR pointing to data
IF NOT .PTR[IDATTRIBUT(INEQV)]
! Equivalenced vars are listed but not allocated here
THEN
BEGIN ! Not equivalenced
IF .PTR[VALTYPE] EQL CHARACTER AND NOT .PTR[IDATTRIBUT(DUMMY)]
THEN
! Non-dummy arg character data.
! Byte pointer points to data
! either in the .DATA. psect
! (low segment /NOEXTEND) or in
! the .LARG. psect. Descriptor
! is allocated in high seg
! after hisg seg is inited.
%2232% PTR[IDCHBP] = BPGEN(.PSECTS[.PTR[IDPSCHARS]])
ELSE
! Dummy character data get descriptor
! allocated to lowseg and pointed to
! by IDADDR. Other data types get
! IDADDR pointing to low seg data
! under /NOEXTEND or the .DATA. or
! .LARG. psect under /EXTEND.
%2232% PTR[IDADDR] _ .PSECTS[.PTR[IDPSECT]];
IF .PTR[OPRSP1] EQL ARRAYNM1
THEN
BEGIN
! Arrays
ARRAPT _ .PTR[IDDIM]; ! Ptr to dimension node
IF .PTR[IDATTRIBUT(DUMMY)]
THEN
BEGIN
! Dummy array arg
IF NOT .ARRAPT[ADJDIMFLG] AND .PTR[VALTYPE] NEQ CHARACTER
THEN
BEGIN
! Non-adjustably dimensioned
! Non-character dummy
! arrays get pointer
! to base address for array
LOCAL BASE PTRVAR;
PTRVAR _ .ARRAPT[ARADDRVAR];
PTRVAR[IDADDR] _ .LOWLOC;
END;
IF .PTR[VALTYPE] EQL CHARACTER
THEN
! Output low seg descriptor for
! character dummy arrays
LSCHD()
ELSE
! allocate space for base address
! for non-character dummy array
LOWLOC _ .LOWLOC + 1;
END
ELSE
BEGIN
! Non-dummy arrays are allocated in the low seg under
! /NOEXTEND or in the .DATA. or .LARGE. psects under
! /EXTEND. Character data size is in characters, others
! are in words
IF .PTR[VALTYPE] EQL CHARACTER
%2232% THEN PSECTS[.PTR[IDPSCHARS]] _ .PSECTS[.PTR[IDPSCHARS]]
+ CHWORDLEN(.ARRAPT[ARASIZ])
%2232% ELSE PSECTS[.PTR[IDPSECT]] _ .PSECTS[.PTR[IDPSECT]]
+ .ARRAPT[ARASIZ];
END
END ! Arrays
ELSE
BEGIN
! Scalars
IF .PTR[VALTYPE] EQL CHARACTER
THEN
BEGIN
! Character scalar
IF .PTR[IDATTRIBUT(DUMMY)]
THEN
BEGIN
! Output low seg descriptor
! for character dummy scalars.
! Only output descriptor for
! the main entry point for multi-entry
! character functions
%1434% IF NOT .PTR[IDATTRIBUT(FENTRYNAME)] OR
%1434% .PTR[IDSYMBOL] EQL .PROGNAME
%1434% THEN LSCHD()
END
ELSE
! Non-dummy character scalars are allocated in the
! low seg./NOEXTEND or in the .DATA. or .LARG.
! psect/EXTEND. Character data size is in
! characters
%2232% PSECTS[.PTR[IDPSCHARS]] _ .PSECTS[.PTR[IDPSCHARS]]
+ CHWORDLEN(.PTR[IDCHLEN]);
END ! Character scalar
ELSE
BEGIN ! Non-character scalar
! Output one or two words based on variable size
IF .PTR[DBLFLG]
THEN PSECTS[.PTR[IDPSECT]] _ .PSECTS[.PTR[IDPSECT]] + 2
ELSE PSECTS[.PTR[IDPSECT]] _ .PSECTS[.PTR[IDPSECT]] + 1;
END; ! Non-character scalar
END; ! Scalars
END; ! Not equivalenced
IF .FLGREG<LISTING> AND .PTR[VALTYPE] NEQ CHARACTER
THEN
BEGIN
! List non-character scalars and arrays
%[703]% IF .SCNT LEQ 0 THEN HEADCHK();
%[735]% IF .HDRFLG EQL 0
THEN
BEGIN
! Output scalar and array banner
HDRFLG_1;
HDRSAA();
END;
%[703]% LISTSYM(.PTR);
%2311% IF .SCNT LSS .HOWIDE
THEN SCNT_.SCNT+1
ELSE
BEGIN
SCNT_0;
CRLF;
END;
END; ! List non-character scalars and arrays
END; ! Symbol is defined and referenced so allocate space for it.
PTR _ .PTR[CLINK]; ! Next linked list entry
END; ! Walk down linked list
END; ! Walk through hash table entries
%[703]% IF .FLGREG<LISTING> THEN IF .SCNT NEQ 0 THEN CRLF;
ENDSCAA_.LOWLOC; !LOC AFTER LAST ARRAY/SCALAR
END; ! of ALLSCAA
!***********************************************************************
! 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.
!***********************************************************************
! EQUIVALENCE processing
!***********************************************************************
! EQUIVALENCE processing is rather hairy to describe. The following description
! of the problem is adapted from Aho and Ullman, Principles of Compiler Design.
! (The algorithm is the not from that book, however.)
!
!
! The first algorithms for processing equivalence statements appeard in
! assemblers rather than compilers. Since these algorithms can be a bit
! complex, especially when interactions between COMMON and EQUIVALENCE
! statements are considered, let us treat first a situation typical of an
! assembly language, where the only EQUIVALENCE statements are of the form
!
! EQUIVALENCE A,B+offset
!
! where A and B are the names of locations. The effect of this statement is to
! make A denote the location which is OFFSET memory units beyond the location
! for B.
!
! A sequence of EQUIVALENCE statements groups names into equivalence sets whose
! positions relative to one another are all defined by the EQUIVALENCE
! statements. For example, the sequence of EQUIVALENCE statements
!
! EQUIVALENCE A,B+100
! EQUIVALENCE C,D-40
! EQUIVALENCE A,C+30
! EQUIVALENCE E,F
!
! groups names into the sets {A,B,C,D} and {E,F}. E and F denote the same
! location. C is 70 locations after B; A is 30 after C and D is 10 after A.
!
! 0 70 100 110
! ------------------------------------------------------------
! ! !
! ------------------------------------------------------------
! B C A D
!
! To compute the equivalence sets we represent each set as a linked list. We
! then look for variables which occur in more than one set and combine the sets.
! This is repeated until we get a collection of disjoint equivalence classes.
!
! In the above example, we start with
!
! {A,B+100}
! {C,D-40}
! {A,C+30}
! {E,F}
!
! First notice that A appears in the first and third sets. Combine these to
! give
!
! {A,B+100,C+30}
! {C,D-40}
! {E,F}
!
! Now C occurs in the first and second sets. If C = D-40 then C+30 = D-10 so we
! get
!
! {A,B+100,C+30,D-10}
! {E,F}
!
! These sets are disjoint, so we're done.
!
! The last union contains the calculation "if C=D-40 then C+30=D-10". In
! general, this situation occurs when the offsets in the first set are from one
! variable, A, and the offsets in the second set are from a different variable,
! C. We must first rewrite the offsets in the second set so that everything is
! in terms of A. In the terminology used by the compiler, each set has a
! "head", the first element in the set. The offsets in the set are offsets from
! the head. When we union two sets, we must rewrite the offsets in one set in
! terms of the head of the other set.
!
! There are several additional features that must be appended to this algorithm
! to make it work for FORTRAN. First, we must determine whether an equivalence
! set is in COMMON, which is true if any variable in the set has been declared
! in a COMMON statement. Second, in an assembly language, one member of an
! equivalence set will pin down the entire set to reality by being a label of a
! statement, thus allowing the addresses denoted by all names in the set to be
! computed relative to that one location. In Fortran, however, it is the
! compiler's job to determine storage locations, so an equivalence set not in
! COMMON may be viewed as "floating" until the compiler determines the position
! of the whole set. To do so correctly, the compiler needs to know the extent
! of the equivalence set, that is, the number of locations which the names in
! the set collectively occupy. To handle this problem we attach to each set two
! fields, LOW and HIGH, giving the offsets relative to the leader of the lowest
! and highest locations used by any member of the equivalence set.
!
! When we merge two sets containing the same variable, we must compute LOW and
! HIGH for the merged set.
!
!
! LOW1 HIGH1
! ------------------------------------------------------------
! ! X !
! ------------------------------------------------------------
! ^
! ^
! ------------------------------------------------------------
! ! X !
! ------------------------------------------------------------
! LOW2 HIGH2
!
! LOW = min(LOW1,LOW2+offs) HIGH = max(HIGH1,HIGH2+offs)
!
! where offs is the number added to the offsets of set 2 to convert them from
! being relative to the set 2 head to being relative to the set 1 head.
!
!
! In the compiler, there are several additional little whizzies to make life
! interesting. For variables in COMMON, the offsets aren't allowed to go
! negative, so the algorithms all have to be careful that the head of each set
! is the element of the set with the lowest address.
!
! As usual, the compiler data structures contain several fields which change
! meaning dynamically as the code goes from place to place. A summary of most
! of the relevant fields follows.
!
! All offsets and lengths are calculated in characters. (There are 5 characters
! per word. Address 0 contains characters 0-4, address 1 contains characters
! 5-9, and so on.) These character addresses are converted back to word
! addresses at the very end.
!
! Equivalence group node, one for each parenthesized list in an EQUIVALENCE stmt
!
! (The complete list of this fields can be found in FIRST.)
!
! EQVHEAD pointer to equiv list node of head of set
! EQVFIRST pointer to equiv list node of first element of set
! EQVLAST pointer to equiv list node of last element of set
! EQVADDR character displacement of class head from 0, like LOW above
! EQVLIMIT like HIGH above (chars required to allocate storage for the
! class is EQVLIMIT-EQVADDR)
! EQVALIGN contains 0 if this group can start on any byte in a word,
! or 1-5 if the group must start on that byte in order for the
! numeric variables in the group to land on word boundaries
! when addresses are assigned.
!
! Equivalence list node, one for each element of an equivalence group
!
! EQLID pointer to symbol table entry of identifier
! EQLDISPL character displacement of this symbol from group head
!
!
! Things are organized so that, after all the calculations are complete and the
! dust settles, the address to be assigned to a name is EQLDISPL + the address
! of the equivalence class. EQVADDR is set to the minimum EQLDISPL in the
! class. Thus, to actually allocate storage for a class, EQVLIMIT-EQVADDR chars
! are allocated, a variable (TLOC) is set to LOWLOC-EQVADDR, and then the
! address of each variable is given by TLOC + EQLDISPL.
!
!
!***********************************************************************
! Organization of common/equivalence processing:
!
!
! ALLOCAT is the driver routine. It calls PROCCOM, PROCEQUIV, ALLCOM.
!
! PROCCOM goes through the COMMON statements and assigns addresses to each
! variable that is explicitly declared in COMMON.
!
! PROCEQUIV goes through the EQUIVALENCE statements and
! - finds groups that are in COMMON because one of their members is declared
! in common. Sets EQVINCOM flag in such groups. [using GRPSCAN]
! - sets EQLDISPL for array elements to the word offset from the base address
! of the array to the given element. EQLDISPL for non-array elements is 0.
! - sets EQVLIMIT to max(EQVLIMIT,EQLDISPL+ARASIZ) where ARASIZ is the declared
! size of the array or 1 (or 2) for scalars
! - sets LCLHD to {either the (unique?) element of the group declared in common
! or} the one with the minimum EQLDISPL. At this point, EQLDISPL is the
! offset from the start of the array.
! - if the group contains a symbol declared in COMMON, check all other symbols
! to see that if they are also declared in common that they are in the same
! block and have the same offset. If they are not also declared in common,
! declare them in the same COMMON block as the equivalenced variable. Add
! them to the linked list of variables in the common block. Give them all the
! same IDADDR (offset from start of common) field.
! - Set in the group node: EQVADDR = min(EQLDISPL) over the group, EQVHEAD =
! symbol with the min EQLDISPL, EQVLIMIT = number of words in group
! - finds variables which occur in more than group and unions the groups
! together into classes. [ELISTSRCH] When two groups are found which
! contain the same variable, one of them is chosen to be a "class", ie, the
! one that gets the other unioned into it. The one that is the "class" has
! a magic field, EQVAVAIL, set to EQVCLASS. The one that remains a group
! has EQVAVAIL set to EQVIGNORE. At the end of this processing, the groups
! with EQVAVAIL = EQVCLASS are the ones that contain all the info from all
! the equivalence statements.
! - call EQCALLOC to allocate the classes
!
! ALLCOM is misnamed; it doesn't allocate anything but does print the common
! block info on the listing. It also converts all of the common block offsets
! from characters to words.
ROUTINE ALLOCAT=
BEGIN
!***********************************************************************
! Allocates 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.
!***********************************************************************
%2507% ! Output warning messages for any symbols not declared in type
%2507% ! statements that should be and haven't gottten warning messages
%2507% ! yet. This catches unallocated variables (which haven't been
%2507% ! referenced). We do this here, since we want the messages before
%2507% ! other things in the listing, such as EQUIVALENCE and COMMON
%2507% ! tables.
%2507% IF .IMPNONE THEN CIMPLNONE();
%2233% PROCCOM(); ! Compute size of each COMMON block
IF .EQVPTR NEQ 0 THEN PROCEQUIV(); ! Process equivalence groups
%2233% IF .COMBLKPTR NEQ 0 ! If we have common,
%2346% THEN ALLCOM(); ! allocate it now
! Now allocate and list all variables, arrays etc. List
! subprograms called, if any
IF .FLGREG<LISTING> THEN SUBPROGLIST();
ALLSCAA(); ! Allocate scalars and arrays
END; ! of ALLOCAT
GLOBAL ROUTINE ALLCOM=
!++
! FUNCTIONAL DESCRIPTION:
!
! Allocates relative addresses to all variables declared in
! COMMON, and computes the total size of all COMMON blocks. The
! type 20 (RCOMMON) REL blocks will be output to the REL file
! with the COMMON blocks grouped together by psect.
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! F2<EXTENDFLAG> True if program is compiled with /EXTEND.
!
! FLGREG<OBJECT> True if an object file is being generated.
!
! LCOMP True if there are large COMMON blocks.
!
! SAVALL True if a SAVE without arguments was seen.
!
! SCOMP True if there are small COMMON blocks.
!
! IMPLICIT OUTPUTS:
!
! LCOMSZ Updated sum of sizes of large common blocks.
!
! NUMSAVCOMMON Number of COMMON blocks that need to be saved.
! (SAVALL causes this to be recomputed).
!
! RDATWD Smashed by object file I/O.
!
! SCOMSZ Updated sum of sizes of small common blocks.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! Outputs type 22 (RPSECTORG) REL blocks to the object file.
! Also, outputs headers to the listing file.
!
!--
![2356] Rewritten for support of COMMON blocks in different psects
BEGIN
%1511% ! If bare SAVE, then zero count. May have specified non-bare
%1511% ! COMMON, and that would mess up our count.
%1511% IF .SAVALL
%1511% THEN NUMSAVCOMMON = 0;
%2356% IF .LCOMP ! Large COMMONs?
%2311% THEN LSTHDR(5,3, ! Yes, print larger legend
%2311% PLIT'?M?JCOMMON BLOCKS [ "!" STORED IN .LARG. ]?M?J?0')
%735% ELSE LSTHDR(5,3,PLIT'?M?JCOMMON BLOCKS?M?J?0');
! Set the default psect before we define the COMMON blocks.
! LINK will allocate COMMON blocks in the default psect when
! reading a psected REL file.
IF .SCOMP ! Are there any small COMMON blocks?
THEN ! Yes, process them
BEGIN ! Small
%1630% IF .FLGREG<OBJECT> ! Object file ?
%2357% AND EXTENDED ! and /EXTEND?
%1615% THEN ! Yes, have to set default psect
%1615% BEGIN ! OBJECT
%1615% RDATWD = PXDATA; ! Select .DATA.
%1615% ZOUTBLOCK(RPSECTORG,RELN); ! Psect index rel block
%1615% END; ! OBJECT
%2346% SCOMSZ = ALCCOMMON(PSDATA); ! Allocate small COMMON blocks
END; ! Small
IF .LCOMP ! Are there any large COMMON blocks?
THEN ! Yes, process them
BEGIN ! Large
IF .FLGREG<OBJECT> ! Object file ?
%2357% AND EXTENDED ! and /EXTEND?
THEN ! Yes, have to set default psect
BEGIN ! OBJECT
RDATWD = PXLARGE; ! Select .LARG.
ZOUTBLOCK(RPSECTORG,RELN);
END; ! OBJECT
%2346% LCOMSZ = ALCCOMMON(PSLARGE); ! Allocate large COMMON blocks
END; ! Large
END; ! of ALLCOM
GLOBAL ROUTINE ALCCOMMON(PSECT)=
!++
! FUNCTIONAL DESCRIPTION:
!
! Assigns relative addresses to all COMMON variables declared in
! a given psect. Outputs the block sizes to the object and
! listing files. Also lists the names and offsets of the
! variables. Totals the sizes of the COMMON blocks.
!
! The addresses of the variables and arrays in a COMMON block
! are relative 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 order of appearance to LOADER. In the relocatable
! binary, references to COMMON variables will use additive
! global fixups.
!
! FORMAL PARAMETERS:
!
! PSECT Psect that is undergoing COMMON allocation.
!
! IMPLICIT INPUTS:
!
! COMBLKPTR Pointers to first and last COMMMON blocks.
! Many of the fields are used in this routine.
!
! F2<EXTENDFLAG> True if program is compiled with /EXTEND.
!
! FLGREG<LISTING> True if a listing file is being generated.
!
! FLGREG<OBJECT> True if an object file is being generated.
!
! NUMSAVCOMMON Number of COMMON blocks in SAVE statements.
!
! SAVALL True if a SAVE without arguments was seen.
!
! IMPLICIT OUTPUTS:
!
! CHR (C) Smashed during listing file I/O.
!
! COMBLOCK[COMSIZE] COMMON block gets its size converted from
! units of characters to words.
!
! ISN Smashed during compatibility flagging
!
! NUMSAVCOMMON Updated number of COMMON blocks in SAVE statements.
!
! R1, R2 Smashed during listing file I/O.
!
! RDATWD Smashed during object file I/O.
!
! ROUTINE VALUE:
!
! Total number of words used for COMMON in the given psect.
!
! SIDE EFFECTS:
!
! Outputs type 20 (RCOMMON) REL blocks to the object file.
! Also, outputs COMMON block information to the listing file.
!
!--
![2356] Added for support of COMMON blocks in different psects
BEGIN
REGISTER
BASE CCOMPTR, ! Runs through list of COMMONs
BASE CSYMPTR, ! Runs through IDCOLINK variable list
ICNT; ! Listing column counter
LOCAL
%1261% FLAGWRD, ! Contains flags defined below
TOTAL; ! Total size of COMMONs in this psect
BIND
%1261% CHARSEEN = FLAGWRD<0,1>, ! Block contains CHARACTER data
%1261% NUMSEEN = FLAGWRD<1,1>; ! Block contains numeric data
TOTAL = 0; ! No COMMONs allocated yet
CCOMPTR = .FIRCOMBLK; ! Pointer to first COMMON block
%2235% WHILE .CCOMPTR NEQ 0 ! Loop over all COMMON blocks
DO
BEGIN ! CCOMPTR NEQ 0
IF .CCOMPTR[COMPSECT] EQL .PSECT ! In the right psect?
THEN ! Yes
BEGIN ! [COMPSECT] EQL .PSECT
! First, process the COMMON block itself
%1511% ! Bare SAVE statement. Save the number of
%1511% ! COMMONs processed for later output of the
%1511% ! rel block.
%1511% IF .SAVALL
%1531% THEN NUMSAVCOMMON = .NUMSAVCOMMON + 1;
%1261% ! Convert COMSIZE back to words
%2346% CCOMPTR[COMSIZE] = CHWORDLEN(.CCOMPTR[COMSIZE]);
TOTAL = .TOTAL+.CCOMPTR[COMSIZE]; ! Total blocks
IF .FLGREG<LISTING> ! Output name of block
THEN
BEGIN ! LISTING
CRLF;
HEADCHK();
CHAROUT("/");
R2 = .CCOMPTR[COMNAME];
ZOUTSYM();
CHAROUT("/");
CHAROUT("(");
R1 = .CCOMPTR[COMSIZE];
ZOUOFFSET();
%2356% IF .PSECT EQL PSLARGE ! COMMON in .LARG.?
%2311% THEN CHAROUT("!"); ! Flag as such
CHAROUT(")");
CRLF;
HEADCHK();
%2346% ICNT = 0;
END; ! LISTING
IF .FLGREG<OBJECT> ! Relocatable binary?
THEN ! Yes, necessary
BEGIN ! OBJECT
R2 = .CCOMPTR[COMNAME]; ! For radix 50
RDATWD = RGLOBDEF+RADIX50(); ! conversion
ZOUTBLOCK(RCOMMON,RELN);
RDATWD = .CCOMPTR[COMSIZE];
ZOUTBLOCK(RCOMMON,RELN);
END; ! OBJECT
! Next, process all the variables in the COMMON block
%1261% FLAGWRD = 0; ! Clear CHARSEEN and NUMSEEN
%1261% CSYMPTR = .CCOMPTR[COMFIRST]; ! Point to first symbol
%1261% DO ! in COMMON block
%1261% BEGIN ! CSYMPTR NEQ NIL
%1261%
%1261% ! Convert IDADDR from characters to words
%1261%
%1261% IF .CSYMPTR[VALTYPE] NEQ CHARACTER
%1261% THEN
%1261% BEGIN ! NUMERIC
%1261% NUMSEEN = 1;
%1261% ! Must be word aligned
%1261% IF .CSYMPTR[IDADDR] MOD CHARSPERWORD
%1261% NEQ 0
%1261% THEN FATLERR(.CSYMPTR[IDSYMBOL],
%1261% E167<0,0>);
%1261% ! Convert character address
%1261% ! to word address
%1261% CSYMPTR[IDADDR] =
%1261% .CSYMPTR[IDADDR]/CHARSPERWORD;
%2356% CSYMPTR[IDPSECT] = .PSECT;
%1261% END ! NUMERIC
%1261% ELSE
%1261% BEGIN ! CHARACTER
%1261% CHARSEEN = 1;
%1261% ! Convert char address to byte
%1261% ! pointer and clear IDADDR,
%1261% ! which will be used for
%1261% ! address of descriptor
%1261% CSYMPTR[IDCHBP] =
%1261% CHADDR2BP(.CSYMPTR[IDADDR]);
%1261% CSYMPTR[IDADDR] = 0;
%2356% CSYMPTR[IDPSCHARS] = .PSECT;
%1261% END; ! CHARACTER
! Now list the symbol
IF .FLGREG<LISTING>
THEN
BEGIN ! LISTING
%2311% LOCAL HOWIDE; ! Symbols / line
%2311% HOWIDE = IF EXTENDED ! /EXTEND?
%2311% THEN 3 ! Only 3 fit
%2311% ELSE 5; ! 5 like good ole days
R2 = .CSYMPTR[IDSYMBOL];
ZOUTSYM(); ! Output the name
CHAROUT("?I"); ! Tab
%1261% IF .CSYMPTR[VALTYPE] NEQ CHARACTER
THEN
%2311% BEGIN ! NUMERIC
%2311% R1 = .CSYMPTR[IDADDR];
%2311% ZOUOFFSET();
%2311% IF EXTENDED
%2311% THEN IF .CSYMPTR[IDADDR]
%2311% LSS #1^18
%2311% THEN CHAROUT("?I"); ! Tab
%2311% END ! NUMERIC
%1261% ELSE
%2311% BEGIN ! CHARACTER
CHAROUT("+");
! List the byte pointer
ZOUTBP(.CSYMPTR[IDCHBP]);
%2311% IF EXTENDED
%2330% THEN IF .CSYMPTR[IDCHBP]
<OWGBPADDR>
%2330% LSS #1000
%2311% THEN CHAROUT("?I"); ! Tab
%2311% END; ! CHARACTER
ICNT = .ICNT+1;
%2311% IF .ICNT EQL .HOWIDE ! Enough on
THEN ! this line?
BEGIN ! EQL HOWIDE
ICNT = 0; ! New line
CRLF;
HEADCHK();
END ! EQL HOWIDE
ELSE CHAROUT("?I"); ! No, tab over
END; ! LISTING
CSYMPTR = .CSYMPTR[IDCOLINK];
%1261% END ! CSYMPTR NEQ 0
%1261% WHILE .CSYMPTR NEQ 0; ! Loop through all symbols in
! this COMMON block
! If doing any compatibility checking,
! complain if block contains both character &
! numeric variables
%2271% IF FLAGEITHER
%2271% THEN IF .CHARSEEN AND .NUMSEEN
%2271% THEN
%2271% BEGIN ! MIXED
%2271% ISN=0; ! Call flagger with no line number
%2271% CFLAGB(UPLIT 'mixed in COMMON?0',E168<0,0>)
%2271% END; ! MIXED
IF .FLGREG<LISTING> ! Listing file?
THEN ! Yes, finish up COMMON block
BEGIN ! LISTING
CRLF; ! Be sure to output CRLF after
HEADCHK(); ! last COMMON block name
END; ! LISTING
END; ! [COMPSECT] EQL .PSECT
%2235% CCOMPTR = .CCOMPTR[NEXCOMBLK] ! Loop until all blocks seen
%2235% END;
RETURN .TOTAL; ! Return amount of space in COMMON
END; ! of ALCCOMMON
GLOBAL ROUTINE DMPFORMAT = ![2210]
BEGIN
![1424] Rewritten by RVM on 19-Nov-81
%(**********************************************************************
This routine allocates address to formats and dumps the formats
preceded by their size words to the .REL file (if there is a .REL
file). Formats are allocated after all other low segment data.
Note that this routine should be called after the optimizer has
done its work. This routine does setup the values in the label
table entries for the format labels. This conflicts with the
optimizer, who thinks it can freely use the fields in the label
table for its own use.
After the routine is called, LOWLOC is the address of the first
word not used in the low segment.
**********************************************************************)%
%1454% REGISTER RELFILE, BASE FORMAT, BASE STMTLABEL;
!(*** Get pointer to first format in the linked list of formats ***)
FORMAT = .FORMPTR<LEFT>;
%1454% !(*** Get the flag that tells if we need a .REL file ***)
%1454% RELFILE = .FLGREG<OBJECT>;
%1454% !(*** Dump out the code block immediately ***)
%1454% IF .RELFILE THEN DMPMAINRLBF();
!(*** Loop until the end of the linked list of formats is reached ***)
WHILE .FORMAT NEQ 0
DO
BEGIN !Loop through linked list of all formats
%1454% !(*** Fill in the address word of the FORMAT entry with ***)
%1454% !(*** the address of the format text. ***)
%1454% !(*** Then fill in the label table entry for the format ***)
%1454% !(*** label. ***)
%1454% STMTLABEL = .FORMAT[SRCLBL];
%1526% STMTLABEL[SNADDR] = FORMAT[FORADDR] = .LOWLOC + 1;
%1454% STMTLABEL[SNDEFINED] = TRUE; !* Label is defined
%1454% STMTLABEL[SNSTATUS] = OUTPBUFF; !* Label is nailed down
%1454% !(*** Now, if there is a .REL file, dump the format ***)
%1454% IF .RELFILE
%1454% THEN
%1454% BEGIN
RDATWD = .FORMAT[FORSIZ]; ! Fetch size word
%1526% ZCODE(PSABS,PSDATA); ! Output it
%1526% LOWLOC = .LOWLOC+1; ! Point to next word
!(*** Loop to dump the format string ***)
INCR I FROM 0 TO .FORMAT[FORSIZ] - 1
DO
BEGIN !Dump FORMAT string
RDATWD = @(.FORMAT[FORSTRING])[.I];
%1526% ZCODE(PSABS,PSDATA);
%1526% LOWLOC = .LOWLOC + 1
END; ! of dump the format string
%1454% END ! of dump FORMAT to .REL file
%1526% ELSE LOWLOC = .LOWLOC + .FORMAT[FORSIZ] + 1; !* Bump LOWLOC
!(*** Get next format in linked list ***)
FORMAT = .FORMAT[FMTLINK];
END; ! of loop through linked list of all formats
%1454% !(*** Dump out the code block immediately. ***)
%1454% IF .RELFILE THEN DMPMAINRLBF()
END; ! of DMPFORMAT ![2210]
ROUTINE PROCCOM=
BEGIN
!***********************************************************************
! Makes a pass through 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.
!***********************************************************************
REGISTER
CBLKSIZ, ! Size of current COMMON block
BASE CCOMPTR: ! Pointer to current COMMON block
CSYMPTR; ! Pointer to current STE
XTRAC;
CCOMPTR = .FIRCOMBLK; ! Pointer to first COMMON block
WHILE .CCOMPTR NEQ 0 DO ! Loop on list of COMMON blocks
BEGIN
CBLKSIZ = 0; ! Clear size of this COMMON block
CSYMPTR = .CCOMPTR[COMFIRST]; ! Get first STE in COMMON block
WHILE .CSYMPTR NEQ 0 ! Loop on list of symbols in block
DO
BEGIN
! If numeric (non-character) variables are encountered, place the
! start of the variable on a word boundary by rounding the offset up
! to be a multiple of 5 characters.
%1261% IF .CSYMPTR[VALTYPE] NEQ CHARACTER ! Numeric variable?
%1261% THEN CBLKSIZ = CHWORDLEN(.CBLKSIZ)*CHARSPERWORD;
! Yes, round up
! 500 Washington St, Hoboken
! A taste treat that can't be beat
%1261% CSYMPTR[IDADDR] = .CBLKSIZ; ! Set offset of this variable
%1261% CBLKSIZ = .CBLKSIZ + SIZEINCHARS(.CSYMPTR);
%1261% ! Increment offset by size of this variable
CSYMPTR = .CSYMPTR[IDCOLINK] ! Point to next variable
END; ! Loop back for more variables
CCOMPTR[COMSIZE] = .CBLKSIZ; ! Save the size of this common block
CCOMPTR = .CCOMPTR[NEXCOMBLK] ! Point to the next common block
END; ! Loop back for more common blocks
END; ! of ROUTINE
ROUTINE EQERRLIST(GROUP)=
BEGIN
!***********************************************************************
! Error routine to list the group of EQUIVALENCE variables in conflict.
!***********************************************************************
MAP BASE GROUP:R2;
LOCAL BASE SYMPTR;
%1146% FATLERR(.GROUP[EQVISN],E49<0,0>); !SAME MSG AS BELOW
IF NOT .FLGREG<LISTING> THEN RETURN;
HEADCHK();
STRNGOUT(PLIT '?M?J CONFLICTING VARIABLES( ?0');
SYMPTR _ .GROUP[EQVFIRST];
WHILE 1 DO
BEGIN
R2 _ .SYMPTR[EQLID]; ! Symbol table entry
R2 _ .R2[IDSYMBOL]; ! SIXBIT value of id
ZOUTSYM();
IF (SYMPTR _ .SYMPTR[EQLLINK]) EQL 0
THEN
BEGIN ! End of the symbols
STRNGOUT(PLIT')?M?J');
HEADCHK();
EXITLOOP
END
ELSE
BEGIN ! More symbols to come
C _ ",";
LSTOUT()
END;
END;
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
COMBLPTR _ .COMSYM[IDCOMMON];
RETURN FATLERR(COMBLPTR[COMNAME],.ISN,E33<0,0> );
END;
%1511% ! Give error if this symbol is in SAVE, can't also be in
%1511% ! COMMON
%1511% IF .NEWSYM[IDSAVVARIABLE]
%1511% THEN FATLERR(.NEWSYM[IDSYMBOL],
%1531% .ISN,E197<0,0>);
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);
%2235% NEWGRP[EQVAVAIL] _ EQVERROR; RETURN -1
);
IF .NEWITEM[EQLLINK] EQL 0
THEN RETURN .ELIM
ELSE NEWITEM _ .NEWITEM[EQLLINK];
END; !OF WHILE 1
END; ! of GROUPTOCOMMON
ROUTINE LINKGROUPS(GROUP1,GROUP2,G1SYM)=
BEGIN
!***********************************************************************
!Link equivalence 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, ! List item in group 1
BASE G2ITEM, ! List item in group 2
BASE NEXG2ITEM; ! Next item in group 2
G2ITEM _ .GROUP2[EQVFIRST]; ! First GROUP2 list
WHILE 1 DO
BEGIN ! Each GROUP2 list
NEXG2ITEM _ .G2ITEM[EQLLINK]; ! Save next symbol in list
IF .G1SYM NEQ .G2ITEM[EQLID] ! Symbols equal
THEN
BEGIN ! Make this the last list in GROUP1.
G1ITEM _ .GROUP1[EQVLAST];
G1ITEM[EQLLINK] _ .G2ITEM;
GROUP1[EQVLAST] _ .G2ITEM;
G2ITEM[EQLLINK] _ 0;
END;
IF (G2ITEM _ .NEXG2ITEM) EQL 0 THEN RETURN .VREG;
END; ! Each GROUP2 list
END; ! of LINKGROUPS
ROUTINE ELISTSRCH(ECLASS,EGROUP)=
BEGIN
!***********************************************************************
! Tries to find overlap in the equivalence groups ECLASS and EGROUP.
! Searches each item in group EGROUP against all items in group ECLASS.
! If a match is found, links 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.
! Returns:
! 1 Successful, match found.
! 0 Unsuccessful.
! <0 Error in processing, illegal condition found.
%1511% ! Massive reformatting and indenting
%2235% LABEL ELIS1;
LOCAL EGSYM, !SYMBOL BEING SEARCHED IN GROUP
EGSYMPTR, !PTR TO SYMBOL TABLE OF SYMBOL BEING 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
! Search for match of item in ECLASS with item in EGROUP.
! Return to caller if we find no match.
%2235% !The search is terminated if a match is found
%2235% ELIS1: UNTIL .EGITEM EQL 0 DO
BEGIN ! For each item in EGROUP
EGSYMPTR _ .EGITEM[EQLID]; ! Symbol table entry
EGSYM _ .EGSYMPTR[IDSYMBOL]; ! SIXBIT symbol
CITEM _ .ECLASS[EQVFIRST]; ! First item in ECLASS
%2235% UNTIL .CITEM EQL 0 DO
BEGIN ! For each group in ECLASS
CSYMPTR _ .CITEM[EQLID]; !SYMBOL TABLE PTR
! If symbols are equal, then we found
! a common symbol between EGROUP and
! ECLASS.
IF .EGSYM EQL .CSYMPTR [IDSYMBOL]
THEN LEAVE ELIS1; ! Exit the search
%2235% CITEM = .CITEM[EQLLINK] !Next class item
%2235% END; ! For each item in ECLASS
%2235% IF (EGITEM = .EGITEM[EQLLINK]) EQL 0
THEN RETURN 0 !No match between ECLASS and EGROUP
%2235% END; ! For each item in 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;
%2235% IF .EGROUP[EQVSMALL] THEN ECLASS[EQVSMALL] = 1; !Copy 'small' flag
%2235% IF .EGROUP[EQVLARGE] THEN ECLASS[EQVLARGE] = 1; !Copy 'large' flag
IF .CSYMPTR[IDATTRIBUT(INCOM)] THEN
IF NOT .ECLASS[EQVINCOM]
THEN
BEGIN
ECLASS[EQVINCOM] _ 1;
%2235% ECLASS[EQVPSECT] = .EGROUP[EQVPSECT]; !Psect for the common
%2235% IF (ECLASS[EQVLIMIT] = GROUPTOCOMMON(.CSYMPTR,.ECLASS,.ECLASS[EQVLIMIT],.CITEM[EQLDISPL])) LSS 0
THEN RETURN -1
END;
!
!CSYMPTR CONTAINS PTR TO MATCHED SYMBOL IN ECLASS
!
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
%1261% ! Check that alignment requirements of class and group match each other.
%1261% ! The required condition is
%1261% ! CLASS-ALIGNMENT + CLASS-DISPL = GROUP-ALIGNMENT + GROUP-DISPL (mod 5)
%1261%
%1261% IF .ECLASS[EQVALIGN] EQL 0 ! If class has no alignment requirement
%1261% THEN IF .EGROUP[EQVALIGN] NEQ 0 ! but group does
%1261% THEN ! give group's requirement to class too
%1261% ECLASS[EQVALIGN] _ 1 +
%1261% MODULO(.EGROUP[EQVALIGN] + .EGDISPL - .ECDISPL - 1, CHARSPERWORD);
%1261%
%1261% IF .EGROUP[EQVALIGN] NEQ 0 ! If group has an alignment requirement
%1261% THEN ! check if things will still be aligned
%1261% ! when group is merged with class
%1261% IF (.ECDISPL + .ECLASS[EQVALIGN] - .EGDISPL - .EGROUP[EQVALIGN]) MOD CHARSPERWORD
%1261% NEQ 0
%1261% THEN FATLERR(.ISN,E166<0,0>); !"Numeric var must be word aligned"
!
!TEST FOR GROUP OR CLASS IN COMMON
!
IF .ECLASS[EQVINCOM] OR .EGROUP[EQVINCOM]
THEN
BEGIN ! One group in common
IF .EGROUP[EQVINCOM]
THEN
BEGIN ! Assign common addresses to ECLASS
ELIM _ .EGROUP[EQVLIMIT];
EGDISPL _ .CITEM[EQLDISPL];
ECDISPL _ .EGITEM[EQLDISPL];
CSYMPTR _ .EGITEM[EQLID];
EGITEM _ .ECLASS[EQVFIRST];
EGSYMPTR _ .EGITEM[EQLID];
END;
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;
IF (EGSYMPTR[IDADDR] _ .CSYMPTR[IDADDR] + .EGITEM[EQLDISPL] -.EGDISPL) LSS 0
THEN
BEGIN !Error equivalence item extends common backward
MAP BASE R1;
R1 _ .CSYMPTR[IDCOMMON];
RETURN FATLERR(R1[COMNAME],.ISN,E33<0,0>)
END;
%1511% ! Give error if this symbol is in SAVE, can't
%1511% ! also be in COMMON
%1511% IF .EGSYMPTR[IDSAVVARIABLE]
%1511% THEN FATLERR(.EGSYMPTR[IDSYMBOL],
%1531% .ISN,E197<0,0>);
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
%1261% EGSYMSIZ _ SIZEINCHARS(.EGSYMPTR);
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
BEGIN ! Testing for end of chain of group
! going into common
EQERRLIST(.EGROUP);
%2235% EGROUP[EQVAVAIL] _ EQVERROR; ! Error in group
RETURN -1 ! Error
END;
IF .EGITEM[EQLLINK] NEQ 0
THEN
BEGIN
EGITEM _ .EGITEM[EQLLINK];
EGSYMPTR _ .EGITEM[EQLID];
END
ELSE
BEGIN ! Link ECLASS and EGROUP with common symbol
! CSYMPTR.
LINKGROUPS(.ECLASS,.EGROUP,.CSYMPTR);
ECLASS[EQVINCOM] _ 1; ! In common
%2235% EGROUP[EQVAVAIL] = EQVIGNORE; ! Has been searched
EGROUP[EQVINCOM]_1; ! In common
RETURN 1 ! Success!! Merged groups
END;
END; !OF LOOP%1%
END; ! One group in common
! Here if neither EGROUP nor ECLASS 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))
! (This tries to equivalence A(4) to A(5), which is quite illegal!)
EGITEM _ .EGROUP[EQVFIRST]; ! First list of EGROUP.
WHILE 1 DO
BEGIN ! For each EGROUP
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;
! Find the matching id's and make sure that the displacements
! are equal.
IF WHILE 1 DO
BEGIN %2%
CSYMPTR _ .CITEM[EQLID]; ! Symbol id
! Check if symbols match
IF .EGSYM EQL .CSYMPTR[IDSYMBOL]
THEN EXITLOOP (-1); ! They do - Give a true
! End of ECLASS?
IF .CITEM[EQLLINK] EQL 0
THEN EXITLOOP (0) ! Give a false
ELSE CITEM _ .CITEM[EQLLINK] ! Next symbol
END !OF %2%
NEQ 0
THEN
BEGIN ! Make sure displacements of matching items are ok
! This is where we catch such things as equivalencing
! A(4) and A(5) to each other.
IF .NEWDISPL NEQ .CITEM[EQLDISPL]
THEN
BEGIN ! Displacements not equal.
EQERRLIST(.EGROUP); ! Conflicting equivalences
%2235% EGROUP[EQVAVAIL] = EQVERROR;
RETURN -1
END;
END ! Make sure displacements of matching items are ok
ELSE ! Put the item from the group into the class.
CITEM[EQLLINK] _ .EGITEM;
EGITEM[EQLLINK] _ 0; !CLEAR LINK
EGITEM[EQLDISPL] _ .NEWDISPL;
IF .NEWDISPL LSS .ECLASS[EQVADDR]
THEN ECLASS[EQVADDR] _ .NEWDISPL;
BEGIN !Now compute new EQVLIMIT
LOCAL BASE ESYM, EQSIZ;
%1261% EQSIZ _ SIZEINCHARS(.EGSYMPTR);
IF (.EGITEM[EQLDISPL] + .EQSIZ) GTR .ECLASS[EQVLIMIT]
THEN ECLASS[EQVLIMIT] _ (.EGITEM[EQLDISPL] + .EQSIZ);
END;
IF .ENEXITEM EQL 0
THEN RETURN 1 !Good return (all items in EGROUP linked to ECLASS)
ELSE EGITEM _ .ENEXITEM;
END; ! For each EGROUP item
END;
END; ! of ELISTSRCH
ROUTINE EQCALLOC(ECLASS)=
BEGIN
%
ALLOCATE RELOCATABLE ADDRESSES TO AN EQUIVALENCE CLASS (ECLASS)
%
MAP BASE ECLASS;
LOCAL BASE CITEM :CSYMPTR;
LOCAL TLOC;
OWN CNT;
%2311% LOCAL HOWIDE; !SYMBOLS PER LISTING LINE
%2235% LOCAL SECTION; !The psect for this group
%1261% LOCAL FLAGWRD;
%2271% BIND
%2271% CHARSEEN = FLAGWRD<0,1>, ! Block contains Character data
%2271% NUMSEEN = FLAGWRD<1,1>, ! Block contains Numeric data
%2271% LOGSEEN = FLAGWRD<2,1>; ! Block contains Logical data
%
THE ADDRESS OF ANITEM IN ECLASS IS COMPUTED AS FOLLOWS
ADDR _ .PSECTS[.SECTION] + (RELATIVE DISPLACEMENT OF ITEM IN ECLASS (CITEM[EQLDISPL]
- SMALLEST RELATIVE DISPLACEMENT IN ECLASS (ECLASS[EQVADDR])
%
%2235% IF .ECLASS[EQVLARGE]
%2235% THEN SECTION = ECLASS[EQVPSECT] = PSLARGE
%2235% ELSE SECTION = ECLASS[EQVPSECT] = PSDATA;
CNT _ 0;
IF .FLGREG<LISTING>
THEN
BEGIN
%2311% HOWIDE = IF EXTENDED THEN 2 !CAN ONLY FIT 3 SYMBOLS / LINE W/ /EXTEND
%2311% ELSE 5; !DO SIX THE REST OF THE TIME
HEADCHK();
STRNGOUT(PLIT '?M?J( ?0')
END;
%1261% ! TLOC is the CHARACTER address of the beginning of this equivalence class
%1261% IF .ECLASS[EQVALIGN] NEQ 0 ! If class must be aligned on a
%1261% THEN ! particular byte
%1261% ECLASS[EQVADDR] _ .ECLASS[EQVADDR] -
%1261% MODULO (.ECLASS[EQVADDR] + .ECLASS[EQVALIGN] - 1, CHARSPERWORD);
%2235% TLOC = .PSECTS[.SECTION] * CHARSPERWORD - .ECLASS[EQVADDR];
%2271% FLAGWRD = 0; ! Clear CHARSEEN, NUMSEEN and LOGSEEN
CITEM _ .ECLASS[EQVFIRST];
%2235% UNTIL .CITEM EQL 0 DO
BEGIN
CSYMPTR _ .CITEM[EQLID]; !PTR TO SYMBOL
CSYMPTR[IDADDR] _ .CITEM[EQLDISPL] + .TLOC;
%1261% IF .CSYMPTR[VALTYPE] NEQ CHARACTER ! CONVERT FROM CHAR ADDRESS
%1261% THEN
%1261% BEGIN
%1261% CSYMPTR[IDADDR] _ .CSYMPTR[IDADDR] / CHARSPERWORD; ! CONVERT TO WORD ADDRESS
%2235% CSYMPTR[IDPSECT] = .SECTION; !The psect
%2271% IF .CSYMPTR[VALTYPE] EQL LOGICAL
%2271% THEN LOGSEEN = 1 ! Class contains logical data
%2271% ELSE NUMSEEN = 1; ! Class contains numeric data
%1261% END
%1261% ELSE
%1261% BEGIN !CHARACTER
%1261% CSYMPTR[IDCHBP] _ CHADDR2BP(.CSYMPTR[IDADDR]); ! CONVERT TO BYTE POINTER
%1261% CSYMPTR[IDADDR] _ 0; ! AND CLEAR IDADDR, DESCRIPTOR ADDRESS
%2235% CSYMPTR[IDPSCHARS] = .SECTION; !The psect
%2235% CHARSEEN = 1; ! Remember class contains character data
%1261% END; !CHARACTER
IF .FLGREG<LISTING>
THEN(LISTSYM(.CSYMPTR);
%2311% IF .CNT LSS .HOWIDE THEN CNT _ .CNT+1
ELSE (CNT _ 0; CRLF; HEADCHK());
);
%2235% CITEM = .CITEM[EQLLINK] !Next item
%2235% END; !of loop through the items
%2235% IF .FLGREG<LISTING>
%2235% THEN (STRNGOUT(PLIT')?M?J'); HEADCHK());
%2271% IF FLAGEITHER
%2271% THEN
%2271% BEGIN ! Doing compatibility checks
%2271% ISN=0; ! ISN for any errors (error appears after allocation listing)
%2271% IF .CHARSEEN AND (.NUMSEEN OR .LOGSEEN)
%2271% THEN ! List contains both Char and Non-Char
%2271% CFLAGB(UPLIT 'EQUIVALENCE-d?0',E168<0,0>);
%2455% IF FLAGVMS ! Compatibility check for VMS
%2271% THEN IF .LOGSEEN AND .NUMSEEN ! Mixing logical and numeric
%2271% THEN WARNERR(.ISN,E249<0,0>);
%2271% END; ! Doing compatibility checks
%2235% PSECTS[.SECTION] = .PSECTS[.SECTION] +
%2235% CHWORDLEN(.ECLASS[EQVLIMIT] - .ECLASS[EQVADDR]);
!
!PSECTS[SECTION] + SPAN OF THE CLASS
!
END; ! of EQCALLOC
ROUTINE GRPSCAN=
BEGIN
!***********************************************************************
! Mark all equivalence groups that have an item (list) in COMMON.
! Force psect of groups with element in common to have the common psect.
! Set the EQVSMALL and EQVLARGE flags in group header entries.
!***********************************************************************
LOCAL BASE ECLASS :ELIST :EITEM : LAST;
%2235% LOCAL BASE COMPTR; !Pointer to common block
ECLASS _ .EQVPTR<LEFT>; ! First equivalence group
%2235% UNTIL .ECLASS EQL 0 DO
BEGIN ! Walk through all groups
LAST _ ELIST _ .ECLASS[EQVFIRST];
IF NOT .ECLASS[EQVINCOM]
THEN ! Group not already marked as in common
UNTIL .ELIST EQL 0
DO
BEGIN ! For each symbol in the group
EITEM _ .ELIST[EQLID]; ! Symbol
IF .EITEM[IDATTRIBUT(INCOM)]
THEN
BEGIN ! Symbol is in common
! Check for more than one common var
! in this group.
IF .ECLASS[EQVINCOM]
THEN
BEGIN
FATLERR(.ISN,E48<0,0>);
EXITLOOP;
END;
%2235% !Force psect to match common
%2235% COMPTR = .EITEM[IDCOMMON];
%2235% ECLASS[EQVPSECT] = .COMPTR[COMPSECT];
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; ! Symbol is in common
%2235% ! Set either 'small' or 'large' flag in group header
%2235% ! depending upon psect for the item
%2235% IF (.EITEM[VALTYPE] EQL CHARACTER
%2235% AND .EITEM[IDPSCHARS] EQL PSLARGE)
%2235% OR (.EITEM[VALTYPE] NEQ CHARACTER
%2235% AND .EITEM[IDPSECT] EQL PSLARGE)
%2235% THEN ECLASS[EQVLARGE] = 1
%2235% ELSE ECLASS[EQVSMALL] = 1;
LAST _ .ELIST;
ELIST _ .ELIST[EQLLINK]
END; ! For each symbol in the group
%2235% ECLASS = .ECLASS[EQVLINK] !Walk through
%2235% END; ! all groups
END; ! of GRPSCAN
ROUTINE PROCEQUIV=
!++
! FUNCTIONAL DESCRIPTION:
!
! Processes equivalence groups as declared in the source.
! 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.
!
! - finds groups that are in COMMON because one of their members
! is declared in common. Sets EQVINCOM flag in such groups.
! [using GRPSCAN]
! - sets EQLDISPL for array elements to the word offset from the
! base address of the array to the given element. EQLDISPL for
! non-array elements is 0.
! - sets EQVLIMIT to max(EQVLIMIT,EQLDISPL+ARASIZ) where ARASIZ is
! the declared size of the array or 1 (or 2) for scalars
! - sets LCLHD to {either the (unique?) element of the group
! declared in common or} the one with the minimum EQLDISPL. At
! this point, EQLDISPL is the offset from the start of the array.
! - if the group contains a symbol declared in COMMON, check all
! other symbols to see that if they are also declared in common
! that they are in the same block and have the same offset. If
! they are not also declared in common, declare them in the same
! COMMON block as the equivalenced variable. Add them to the
! linked list of variables in the common block. Give them all the
! same IDADDR (offset from start of common) field.
! - Set in the group node: EQVADDR = min(EQLDISPL) over the group,
! EQVHEAD = symbol with the min EQLDISPL, EQVLIMIT = number of
! words in group
! - finds variables which occur in more than group and unions the
! groups together into classes. [ELISTSRCH] When two groups are
! found which contain the same variable, one of them is chosen to
! be a "class", ie, the one that gets the other unioned into it.
! The one that is the "class" has a magic field, EQVAVAIL, set to
! EQVCLASS. The one that remains a group has EQVAVAIL set to
! EQVIGNORE. At the end of this processing, the groups with
! EQVAVAIL = EQVCLASS are the ones that contain all the info from
! all the equivalence statements.
! - call EQCALLOC to allocate the classes
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! Unknown
!
! IMPLICIT OUTPUTS:
!
! Unknown
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! Unknown
!
!--
BEGIN
LOCAL BASE EQVCPTR, !PTR TO CURRENT EQUIV CLASS HEADER
ECOMMPTR, !PTR COMMON ITEM IF GROUP IS IN COMMON
ECOMMHDR, !PTR TO COMMON BLOCK HDR
BASE EQLPT2, !OTHER PTR TO EQUIV LIST NODE
BASE LCLHD, !PTR TO LOCAL HEAD OF A GROUP FOR ALLOCATION PURPOSES
SAVEBOUNDSFLG, !TO SAVE THE VALUE OF THE "BOUNDS" SWITCH WHILE
! PROCESSING EQUIVALENCE STMNTS
%2235% BASE SYMPTR; !Ptr to symbol table entry
REGISTER BASE EQLPTR; !PTR TO EQUIV LIST NODE
%2235% LABEL LOOP2;
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.
! Make sure that every group that has a symbol in COMMON is marked.
GRPSCAN();
EQVCPTR _ .EQVPTR<LEFT>; ! Ptr to first group
%2235% UNTIL .EQVCPTR EQL 0 DO
BEGIN ! For each equivalence group
ISN _ .EQVCPTR[EQVISN]; ! Set ISN in case of errors
ECOMMPTR _ 0; ! Initializing
!If group is in common then find the element in common
%2235% IF .EQVCPTR[EQVINCOM]
THEN
BEGIN ! Group has element in common
EQLPTR _ .EQVCPTR[EQVHEAD]; ! Ptr to list item that's in common
LCLHD _ .EQLPTR[EQLID]; ! Symbol table entry
ECOMMPTR _ .EQLPTR; ! Ptr to common item eql list item
ECOMMHDR _ .LCLHD[IDCOMMON]; ! Common table entry
END
ELSE LCLHD _ 0;
EQLPTR _ .EQVCPTR[EQVFIRST]; ! Ptr to first item in group
R2 _ 0; ! EQVLIMIT in R2
R1 _ 0; ! Smallest displacement in R1
%2235% LOOP2:
%2235% UNTIL .EQLPTR EQL 0 DO
BEGIN ! For each list in ECLASS
LOCAL BASE ESYM, EQSIZ;
IF .EQLPTR[EQLINDIC] NEQ 0
THEN
BEGIN ! Has dimensions
%2414% LOCAL BASE PT1:PT2:PT3:PTL:PTU:PTS; ! Scratch pointers
%2414% LOCAL NUMELM; ! Number of elements
PT1 _ .EQLPTR[EQLID]; ! Symbol table
IF .PT1[IDDIM] EQL 0 THEN
BEGIN ! Not declared with dimensions - error!
FLGREG<BOUNDS>_.SAVEBOUNDSFLG;
RETURN FATLERR(.ISN,E93<0,0>);
END;
EQLPTR[EQLINDIC] _ 0;
IF .EQLPTR[EQLLIST]^(-18) NEQ 0
THEN
BEGIN ! Multiple subscripts
%2414% ! Check the constant subscripts to verify that
%2414% ! they are within bounds.
%2414% PT3=.EQLPTR[EQLID]; ! Pointer to symbol
%2414% PT1=.EQLPTR[EQLLIST]; ! Pointer to subscripts
%2414% PT2=.PT3[IDDIM]; ! Dimension table
%2414% INCR I FROM 0 TO .PT2[DIMNUM]-1
%2414% DO
%2414% BEGIN ! Loop for subscript check
%2414% PTL=.PT2[DIMENL(.I)]; ! Lower bound
%2414% PTU=.PT2[DIMENU(.I)]; ! Upper bound
%2414% PTS=@(.PT1+.I); ! Subscript
%2414% IF .PTS[CONST2] LSS .PTL[CONST2] OR
%2414% .PTS[CONST2] GTR .PTU[CONST2]
%2414% THEN ! Subscript out of range
%2414% WARNERR(PT3[IDSYMBOL],.ISN,E293<0,0>);
%2414% END; ! Loop for subscript check
! Set EQLDISPL to negative of subscript expression
PT1 _ ARRXPN(.EQLPTR[EQLID],.EQLPTR[EQLLIST]);
IF .PT1[ARG2PTR] EQL 0
THEN EQLPTR[EQLDISPL] _ -(EXTSIGN(.PT1[TARGADDR]))
%1261% ELSE EQLPTR[EQLDISPL] _ -CNSTEVAL(.PT1[ARG2PTR])
%1261% - EXTSIGN(.PT1[TARGADDR]);
%1261% ! If noncharacter, convert words to chars
%1261% IF .PT3[VALTYPE] NEQ CHARACTER
%2271% THEN EQLPTR[EQLDISPL] = .EQLPTR[EQLDISPL] * CHARSPERWORD;
%2322% ! Check if the array reference is too large for
%2322% ! the amount of addressable memory on the
%2322% ! machine. /EXTEND allows larger arrays. If
%2322% ! too large, give a fatal error message.
%2322%
%2322% IF .EQLPTR[EQLDISPL] LEQ -(.VMSIZE * CHARSPERWORD)
%2322% OR .EQLPTR[EQLDISPL] GEQ (.VMSIZE * CHARSPERWORD)
%2322% THEN RETURN FATLERR(PT3[IDSYMBOL], .ISN, E103<0,0>);
END ! Multiple subscripts
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
PT3 _ .EQLPTR[EQLID]; ! Symbol table
PT2 _ .PT3[IDDIM]; ! Dimension table
%2271% IF FLAGANSI
%2271% THEN ! Compatibility checks
%2271% IF .PT2[DIMNUM] NEQ 1 ! Should be single dimension
%2271% THEN WARNERR(PT3[IDSYMBOL],.ISN,E274<0,0>);
%2414% ! Compute size of array, and check to see if the
%2414% ! subscript is within range.
%2414% ! The subscript is considered to be within range
%2414% ! if it is not less than the lower bound of the
%2414% ! first dimension, and not greater than the number
%2414% ! of elements offset by that first lower bound.
%2414% NUMELM=1; ! Will hold the computed number of elements
%2414% DECR I FROM .PT2[DIMNUM]-1 TO 0
%2414% DO
%2414% BEGIN ! Loop to compute number of elements
%2414% PTL=.PT2[DIMENL(.I)]; ! Lower bound
%2414% PTU=.PT2[DIMENU(.I)]; ! Upper bound
%2414% NUMELM=.NUMELM*(.PTU[CONST2]-.PTL[CONST2]+1);
%2414% END; ! Loop to compute number of elements
%2414% IF .PT1[CONST2] GTR (.NUMELM+.PTL[CONST2]-1) OR
%2414% .PT1[CONST2] LSS .PTL[CONST2]
%2414% THEN !Subscript out of range
%2414% WARNERR(PT3[IDSYMBOL],.ISN,E293<0,0>);
EQLPTR[EQLDISPL] _ - .PT1[CONST2] !CONSTANT VALUE
+ .PTL[CONST2]; !OFFSET
%1261% IF .PT3[VALTYPE] EQL CHARACTER ! MULTIPLY BY ELEMENT
%1261% THEN ! LENGTH IN CHARACTERS
%1261% EQLPTR[EQLDISPL] _ .EQLPTR[EQLDISPL] * .PT3[IDCHLEN]
%1261% ELSE
%1261% IF .PT3[DBLFLG]
%1261% THEN EQLPTR[EQLDISPL] _ .EQLPTR[EQLDISPL] * 2 * CHARSPERWORD
%1261% ELSE
%1261% EQLPTR[EQLDISPL] _ .EQLPTR[EQLDISPL] * CHARSPERWORD;
%2322% ! Check if the array reference is too large for
%2322% ! the amount of addressable memory on the
%2322% ! machine. /EXTEND allows larger arrays. If
%2322% ! too large, give a fatal error message.
%2322%
%2322% IF .EQLPTR[EQLDISPL] LEQ -(.VMSIZE * CHARSPERWORD)
%2322% OR .EQLPTR[EQLDISPL] GEQ (.VMSIZE * CHARSPERWORD)
%2322% THEN RETURN FATLERR(PT3[IDSYMBOL], .ISN, E103<0,0>);
END ! Single subscript
END; ! Has dimensions
ESYM _ .EQLPTR[EQLID]; !PTR TO SYMBOL TABLE
%1262% ! ADD IN SUBSTRING OFFSET FOR CHARACTER VARIABLES
%1262% IF .EQLPTR[EQLSSTRING] ! IF THIS LIST ELEMENT IS A SUBSTRING
%1262% THEN
%1262% IF .ESYM[VALTYPE] NEQ CHARACTER ! BASE IDENTIFIER MUST BE CHARACTER
%1262% THEN FATLERR(.ISN,E162<0,0>) ! "Substring of non-CHARACTER"
%1262% ELSE IF .EQLPTR[EQLLOWER] LSS 0 OR .EQLPTR[EQLLOWER] GEQ .ESYM[IDCHLEN]
%1262% THEN FATLERR(.ISN,E165<0,0>); ! Substring bound out of range
%1262% EQLPTR[EQLDISPL] _ .EQLPTR[EQLDISPL] - .EQLPTR[EQLLOWER];
%1261% ! IF EQUIVALENCED VARIABLE IS NUMERIC, THIS GROUP MUST BE WORD ALIGNED
%1261% IF .ESYM[VALTYPE] NEQ CHARACTER
%1261% THEN EQVCPTR[EQVALIGN] _ 1;
!NOW CHECK FOR NEW EQVLIMIT (R2) FOR THIS GROUP
!
%1261% EQSIZ _ SIZEINCHARS(.ESYM);
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
BEGIN
R1 _ .EQLPTR[EQLDISPL]; ! New smallest displacement
LCLHD _ .EQLPTR[EQLID];
END;
IF .ECOMMPTR NEQ 0 THEN
IF .EQLPTR NEQ .ECOMMPTR
THEN
BEGIN
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
BEGIN ! Not in common
LINK _ .ECOMMHDR[COMLAST];
ECOMMHDR[COMLAST] _ .EQLPTR[EQLID];
LINK _ LINK[IDCOLINK] _ .EQLPTR[EQLID]; !PTR TO SYMBOL TABLES NODE
%1511% ! Can't be in both SAVE and Common
%1511% IF .LINK[IDSAVVARIABLE]
%1511% THEN FATLERR(.LINK[IDSYMBOL],.ISN,E197<0,0>);
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
BEGIN
FATLERR(ECOMMHDR[COMNAME],.ISN,E33<0,0>);
LEAVE LOOP2;
END;
IF .ECOMMHDR[COMSIZE] LSS (.LINK[IDADDR] + .EQSIZ)
THEN ECOMMHDR[COMSIZE] _ (.LINK[IDADDR] + .EQSIZ);
END ! Not in common
ELSE ! Checking the declarations for violating
! beginning of common block
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.
OR (.COM[IDCOMMON] NEQ .LINK[IDCOMMON])
THEN
BEGIN
EQERRLIST(.EQVCPTR); ! List out vars
%2235% EQVCPTR[EQVAVAIL] = EQVERROR;
LEAVE LOOP2;
END;
END;
%2235% EQLPTR = .EQLPTR[EQLLINK] !Next list item
%2235% END; ! For each list in ECLASS
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
!
%1450% ! Check for EQUIVALENCE (A(1),A(2))
%1450% EQLPTR _ .EQVCPTR[EQVFIRST]; ! Step through all variables
%1450% WHILE .EQLPTR NEQ 0 DO ! in equivalence list
%1450% BEGIN
%1450% EQLPT2 _ .EQLPTR[EQLLINK]; ! Step through all subsequent
%1450% WHILE .EQLPT2 NEQ 0 DO ! variables in list
%1450% BEGIN ! Look for duplicates
%1450% IF .EQLPTR[EQLID] EQL .EQLPT2[EQLID] ! If variable is
%1450% THEN ! the same
%1450% IF .EQLPTR[EQLDISPL] NEQ .EQLPT2[EQLDISPL] ! displ must
%1450% THEN ! also be the same
%1450% BEGIN
%1450% EQERRLIST(.EQVCPTR); ! error, type message
%2235% EQVCPTR[EQVAVAIL] = EQVERROR;! mark group to prevent
%1450% ! further processing
%1450% END;
%1450% EQLPT2 _ .EQLPT2[EQLLINK];
%1450% END;
%1450% EQLPTR _ .EQLPTR[EQLLINK];
%1450% END;
%2235% EQVCPTR = .EQVCPTR[EQVLINK] !Next group
%2235% END; ! For each equivalence group
! Now start to make equivalence classes by combining groups if possible
EQVCPTR _ .EQVPTR<LEFT>; ! Start with first group
%2235% UNTIL .EQVCPTR EQL 0 DO
%2235% BEGIN ! Walk through each equivalence group
%2235% IF .EQVCPTR[EQVAVAIL] EQL EQVGROUP
THEN
BEGIN ! Group available for Class
ISN _ .EQVCPTR[EQVISN]; ! Set ISN in case of errors
%2235% EQVCPTR[EQVAVAIL] = EQVCLASS; ! Make Group a Class
EQLPTR _ .EQVCPTR; ! Begin search of other groups on current Group
DO
BEGIN ! Walk through all groups after EQVCPTR
%2235% IF .EQLPTR[EQVAVAIL] EQL EQVGROUP
THEN
BEGIN ! Ok to search this group
! Try to combine the groups into a single one.
IF (ELISTSRCH(.EQVCPTR,.EQLPTR)) GTR 0
THEN
BEGIN ! Groups were combined
%2235% EQLPTR[EQVAVAIL] = EQVIGNORE; ! Have searched
EQLPTR _ .EQVCPTR ; !SEE IF ANY OF THE REJECTS FIT NOW
END;
! If error occurred in ELSTSRCH then
%2235% ! EQLPTR[EQVAVAIL] will be set to EQVERROR
END; ! Ok to search this group
END ! Walk through all groups after EQVCPTR
WHILE (EQLPTR _ .EQLPTR[EQVLINK]) NEQ 0;
IF NOT .EQVCPTR[EQVINCOM]
%2235% THEN IF .EQVCPTR[EQVAVAIL] EQL EQVCLASS
%[735]% THEN
%[735]% BEGIN ! No error in searching, not in common
%[735]% IF .HDRFLG EQL 0
%2311% THEN
%2311% IF EXTENDED
%2311% THEN
%2311% LSTHDR(4,2,PLIT'?M?JEQUIVALENCED VARIABLES [ "!" VARIABLE STORED IN .LARG. ]?M?J?0')
%2311% ELSE
%[735]% LSTHDR(4,2,PLIT'?M?JEQUIVALENCED VARIABLES?M?J?0');
%[735]% EQCALLOC(.EQVCPTR); ! Allocate Class
%[735]% HDRFLG_1;
%[735]% END;
END; ! Group available for Class
%2235% EQVCPTR = .EQVCPTR[EQVLINK] !Next class or group
%2235% END; ! Walk through each equivalence group
FLGREG<BOUNDS> = .SAVEBOUNDSFLG; !RESTORE THE "BOUNDS" SWITCH
END; ! of PROCEQUIV
GLOBAL ROUTINE ALCCON=
BEGIN
! Allocate all the constants that have the flag CNTOBEALCFLG set.
! this flag is set by calls to ALOCONST.
%1232% ! Rewritten by TFV, 17-Jun-81
%1232% ! Fixup block structure and allocate hollerith and character constants
BIND HI=R1,LOW=R2;
MACHOP ADDI=#271,TLZE=#623,TLO=#661,LSH=#242,DFN=#131;
MACRO EXPON=27,8$;
REGISTER BASE CPTR;
%1733% ! The over/underflows that may occur in this routine are not associated
%1733% ! with any particular line, so set ISN to zero (which means no line
%1733% ! number is known). It is safe to do this because this routine is
%1733% ! called so late in the back end.
%1733% ISN = 0;
! Set CNTOBEALCFLG for all consts used in dimensioning arrays that will
! have bounds checking performed on them
ALODIMCONSTS();
INCR I FROM 0 TO CSIZ-1 DO ! Walk through hash table entries
BEGIN
CPTR_.CONTBL[.I]; ! Get next hash table entry
WHILE .CPTR NEQ 0 DO ! Walk down linked list for each hash
BEGIN
%1272% ! Convert real constants from DP to SP form, even if
%1272% ! the constant lives in a MOVEI.
IF .CPTR[CONST1] NEQ 0
THEN
BEGIN
! Convert real constants from DP to SP
! form, 0 is a special case
IF .CPTR[VALTYPE] EQL REAL
THEN
BEGIN
! When rounding to single
! precision, zero second word
CPTR[CONST1] _ KISNGL(.CPTR[CONST1],
.CPTR[CONST2]);
CPTR[CONST2]_0;
END;
END;
%1272% IF .CPTR[CNTOBEALCFLG] THEN
%1272% BEGIN
%1272% ! Constant to be allocated
%1526% CPTR[IDADDR]_.LOWLOC;
! Now put constant out in REL file.
! Remember that this routine is
! executed within a test for the .REL
! file generation
IF .CPTR[VALTP1] EQL INTEG1 ! Output first or only word of data
THEN RDATWD _ .CPTR[CONST2] ! Only word
ELSE RDATWD _ .CPTR[CONST1]; ! High order for double or complex
! Output to low seg with no relocation
IF .FLGREG<OBJECT>
%1526% THEN ZCODE(PSABS,PSDATA);
%1526% LOWLOC _ .LOWLOC + 1;
IF .CPTR[DBLFLG]
THEN
BEGIN
! Output low order word for double and complex
RDATWD _ .CPTR[CONST2];
! Output to low seg with no relocation
IF .FLGREG<OBJECT>
%1526% THEN ZCODE(PSABS,PSDATA);
%1526% LOWLOC _ .LOWLOC + 1
END
END; ! Constant to be allocated
CPTR_.CPTR[CLINK] ! Get next linked list item
END; ! Walk down linked list for each hash
END; ! Walk through hash table entries
! Output HOLLERITH and CHARACTER constants to lowseg. They
! are in writable storage since they can be actuals passed to
! dummy arrays and updated. FORTRAN 66 also allows reading
! into FORMAT specs. LINK will fixup character constant
! actuals passed to non-character dummy args by converting the
! character constant to hollerith. This is done by
! substituting a pointer to the actual constant for a pointer
! to the character descriptor. Because of this character
! constants must look the same as hollerith; they are blank
! filled to a full word and followed by a zero word (ASCIZ).
CPTR _ .LITPOINTER<LEFT>;
WHILE .CPTR NEQ 0 DO ! walk down linked list
BEGIN
IF .CPTR[CNTOBEALCFLG]
THEN
BEGIN
! Literal to be allocated
! LITADDR points to the literal in the lowseg.
! Character constants will have character
! descriptors generated in the high seg
! pointing to the low seg data and LITADDR
! will be modified to point to the descriptor.
%1526% CPTR[LITADDR] _ .LOWLOC;
IF .FLGREG<OBJECT>
THEN
BEGIN
INCR I FROM 0 TO .CPTR[LITSIZ] - 1 DO
BEGIN
! Output LITSIZ words
RDATWD _ .(CPTR[LIT1] + .I); ! Get next word
%1526% ZCODE(PSABS,PSDATA);
%1526% LOWLOC _ .LOWLOC + 1;
END
END
%1526% ELSE LOWLOC _ .LOWLOC + .CPTR[LITSIZ];
END; ! Literal to be allocated
CPTR _ .CPTR[LITLINK] ! Get next linked list item
END ! of walk down linked list
END; ! of ALCCON
GLOBAL ROUTINE HSLITD=
BEGIN
%1232% ! Written by TFV, 17-Jun-81
! Output hiseg descriptors for character constants. Called after
! hiseg is inited. Fixup IDADDR to point to descriptor. Descriptor
! points to lowseg character constant data.
REGISTER
BASE CPTR,
BP;
CPTR _ .LITPOINTER<LEFT>;
WHILE .CPTR NEQ 0 DO ! walk down linked list
BEGIN
IF .CPTR[CNTOBEALCFLG] AND .CPTR[LITOPER] EQL CHARCONST
THEN
BEGIN
! Character constant to be allocated
! LITADDR points to the character descriptor generated
! in the high seg which points to the low seg data.
%1406% BP = RDATWD = BPGEN(.CPTR[LITADDR]); ! Byte pointer to low seg data
CPTR[LITADDR] _ .HILOC; ! Pointer to descriptor
IF .FLGREG<OBJECT>
THEN
BEGIN ! .REL being generated
![2330] Output byte pointer to hiseg,
![2330] relocating address field to lowseg
%2330% Z30CODE(PSDATA,PSCODE);
HILOC _ .HILOC + 1;
RDATWD _ .CPTR[LITLEN]; ! Length of constant
![2330] Output length to hiseg without
![2330] relocation
%2330% Z30CODE(PSABS,PSCODE);
HILOC _ .HILOC + 1;
END ! of .REL being generated
ELSE HILOC _ .HILOC + 2;
! List symbol name, descriptor address, lowseg
! data position, and length
IF .FLGREG<LISTING> AND .FLGREG<MACROCODE>
THEN LISTCHD(.CPTR,.BP);
END; ! Literal to be allocated
CPTR _ .CPTR[LITLINK] ! Get next linked list item
END; ! Walk down linked list
END; ! of HSLITD
GLOBAL ROUTINE HSCHD=
BEGIN
REGISTER
BASE PTR,
%1434% BASE ENT,
%1434% BASE FUNC;
MAP
%1261% BASE R2;
%1232% ! Written by TFV, 17-Jun-81
! Generate hiseg descriptors for non-dummy character scalars and
! arrays. Called after the hiseg is inited. Only called if a
! character declaration or an implicit character declaration has been
! seen. Calls LISTCHD to list the character data name, descriptor
! location, start of character data, and length.
DECR I FROM SSIZ-1 TO 0 DO ! Walk through hash table entries
BEGIN
PTR = .SYMTBL[.I]; ! Entry for this hash
WHILE .PTR NEQ 0 DO ! Walk down linked list of symbols
BEGIN
%1422% ! Generate descriptors for character variables and for the
%1422% ! function name and entry points for this program unit, but
%1422% ! not for functions it calls. Generate descriptors for
%1422% ! character functions that are declared external. Generate
%1422% ! only one descriptor for multi-entry character functions.
IF .PTR[VALTYPE] EQL CHARACTER THEN
%1422% IF NOT .PTR[IDATTRIBUT(NOALLOC)] THEN
%1434% IF (.PTR[IDATTRIBUT(FENTRYNAME)] AND .PTR[IDSYMBOL] EQL .PROGNAME) OR
%1434% (.PTR[OPERSP] EQL FNNAME AND (.PTR[IDATTRIBUT(INEXTERN)] OR .PTR[IDATTRIBUT(SFN)])) OR
%1434% (NOT .PTR[IDATTRIBUT(FENTRYNAME)] AND .PTR[OPERSP] NEQ FNNAME)
THEN
BEGIN
IF NOT .PTR[IDATTRIBUT(DUMMY)]
THEN
BEGIN
! Non-dummy arg character scalars and
! arrays have a hiseg descriptor, so
! generate it. Point IDADDR to
! descriptor. Descriptor is in the
! .CODE. psect
PTR[IDADDR] = .HILOC;
PTR[IDPSECT] = PSCODE;
IF .FLGREG<OBJECT>
THEN
BEGIN ! .REL being generated
%1434% IF NOT .PTR[IDATTRIBUT(INEXTERN)]
%1434% THEN
%1434% BEGIN
! Byte pointer to low seg data
RDATWD = .PTR[IDCHBP];
%1261% IF .PTR[IDATTRIBUT(INCOM)]
%1261% THEN ! Output byte pointer with
%1261% ! a RH fixup request
%1261% BEGIN ! COMMON
! Output byte pointer,
! no relocation
%2330% Z30CODE(PSABS,PSCODE);
! Get pointer to
! COMMON block
%1261% R2 _ .PTR[IDCOMMON];
![2330] Output additive
![2330] fixup for
![2330] descriptor at
![2330] HILOC - use
![2330] EXTENDED flag
![2330] to decide on
![2330] 18 or 30 bit.
%2330% IF EXTENDED
%2330% THEN ZSYMBOL(
%2330% GLB30ADDFIX,
%2330% .R2[COMNAME],
%2330% .HILOC,
%2330% PSCODE)
%1512% ELSE ZSYMBOL(
%1512% GLB18ADDFIX,
%1512% .R2[COMNAME],
%1512% .HILOC,
%1512% PSCODE);
%1261% END ! COMMON
%2330% ELSE ! NOT INCOM
%2330% BEGIN ! NOT COMMON
![2330] Output BP to
![2330] high seg with
![2330] relocation
%2330% Z30CODE(
%1526% .PTR[IDPSCHARS],
%1526% PSCODE);
%2330% END ! NOT COMMON
%1434% END
%1434% ELSE
%1434% BEGIN ! function is declared external
![2330] Store address at HILOC
![2330] with additive fixup.
![2330] Use an IFIW under
![2330] /NOEXTEND to keep
![2330] things section
![2330] independant, in case
![2330] someone wants to
![2330] execute by mapping into
![2330] a non-zero section.
%2330% IF EXTENDED ! N sections?
%2330% THEN
%2330% BEGIN ! EXTENDED
%2330% RDATWD = 0; ! EFIW
%2330% Z30CODE(PSABS,PSCODE);
%2345% ZSYMBOL(GLB30ADDFIX,
%2330% .PTR[IDSYMBOL],
%2330% .HILOC,PSCODE);
%2330% END ! EXTENDED
%2330% ELSE ! One section, use IFIW
%2330% BEGIN ! NOT EXTENDED
%1434% RDATWD = 1^35; ! IFIW
%2330% Z30CODE(PSABS,PSCODE);
%2345% ZSYMBOL(GLB18ADDFIX,
%1512% .PTR[IDSYMBOL],
%1512% .HILOC,PSCODE);
%2330% END; ! NOT EXTENDED
%1434% END;
HILOC _ .HILOC + 1;
! Length of character scalar or array
RDATWD _ .PTR[IDCHLEN];
! Output length to high seg with no
! relocation
%2330% Z30CODE(PSABS,PSCODE);
HILOC _ .HILOC + 1
END ! of .REL being generated
ELSE HILOC _ .HILOC + 2
END; ! Non- dummy
! List symbol name, descriptor address, low seg data position, and length
IF .FLGREG<LISTING>
THEN LISTCHD(.PTR,.PTR[IDCHBP]);
%1522% ! Check for illegal length star declaration.
%1522% ! Length star is legal only for dummy arguments
%1522% ! and character parameters.
%1522% IF NOT .PTR[IDATTRIBUT(DUMMY)]
%1522% THEN IF .PTR[IDCHLEN] EQL LENSTAR
%1522% THEN FATLERR(.PTR[IDSYMBOL],0,E194<0,0>)
END; ! Character
PTR _ .PTR[CLINK]; ! Next linked list entry
END ! Walk down linked list
END; ! Walk through hash table entries
%1434% ! Now setup all character entry points to use the descriptor of
%1434% ! the main entry point
%1434% IF .FLGREG<PROGTYP> EQL FNPROG THEN
%1434% IF .MULENTRY NEQ 0
%1434% THEN
%1434% BEGIN
%1434% ENTRY = .PROGNAME; ! Lookup the symbol table entry
%1434% ! for the function name
%1434% NAME = IDTAB; ! It's an identifier
%1434% FUNC = TBLSEARCH(); ! Search for it
%1434% IF .FUNC[VALTYPE] EQL CHARACTER
%1434% THEN
%1434% BEGIN ! Multi-entry character function
%1434% ENT = .MULENTRY; ! Linked list of entry points
%1434% ! Copy IDADDR field of function name into IDADDR fields for the entry points
%1434% DO ENT[IDADDR] = .FUNC[IDADDR]
%1434% WHILE (ENT = .ENT[IDENTLNK]) NEQ 0;
%1434% END; ! Multi-entry character function
%1434% END;
END; ! of HSCHD
GLOBAL ROUTINE HSDDESC=
BEGIN
%1406% ! Written by TFV on 27-Oct-81
! Output .Dnnnn compile-time-constant character descriptors to the
! .REL file. Either one word (byte pointer only) or two words
! (byte pointer and length) are output based on the flag
! IDGENLENFLG. One word .Dnnnn variables are used for SUBSTRINGs
! with constant lower bounds and non-constant upper bounds. Fill
! in the IDADDR field with the address of the descriptor. Use
! LISTCHD to output the descriptor to the .LST file.
REGISTER BASE DPTR: SUBNODE;
MAP BASE R2;
DPTR = .DANCHOR; ! Start at first .Dnnnn variable
WHILE .DPTR NEQ 0 DO ! Walk down linked list
BEGIN
%1567% IF NOT .DPTR[IDATTRIBUT(NOALLOC)]
%1627% THEN IF .DPTR[IDADDR] NEQ 0 ! skip .D's allocated for function
%1627% ! return values where the function was
%1627% ! CHAR(constant) in a parameter stmt
%1567% THEN
%1567% BEGIN ! Do only if we want to allocate this .Dnnn
! Get the subnode for the data from either a .Qnnnn
! variable (function calls and concatenation) or a symbol
! table entry for a scalar (substring) or array (arrayref)
SUBNODE = .DPTR[IDADDR];
DPTR[IDPSECT] = PSCODE; ! Descriptor is in the hiseg
DPTR[IDPSCHARS] = .SUBNODE[IDPSCHARS]; ! Psect for the data
! Form the byte pointer from the byte pointer in the subnode
IF .DPTR[IDBPOFFSET] NEQ 0
%2216% THEN RDATWD = BPADD(.SUBNODE[IDCHBP],.DPTR[IDBPOFFSET])
ELSE RDATWD = .SUBNODE[IDCHBP];
DPTR[IDCHBP] = .RDATWD; ! Put byte pointer in IDCHBP
DPTR[IDADDR] = .HILOC; ! Location of the descriptor
! Output byte pointer
IF .FLGREG<OBJECT> THEN
%1451% BEGIN ! generating .REL file
%1451% IF .SUBNODE[IDATTRIBUT(INCOM)]
%1451% THEN ! If byte pointer is in common
%1451% BEGIN ! Output with RH fixup request
%2330% Z30CODE(PSABS,PSCODE); ! Output byte pointer,
%1451% ! no relocation
%1451% R2 _ .SUBNODE[IDCOMMON]; ! COMMON block name
! Output RH additive fixup request to LINK for word at HILOC
%2330% IF EXTENDED ! /EXTEND?
%2330% THEN ZSYMBOL(GLB30ADDFIX,.R2[COMNAME],
%2330% .HILOC,PSCODE)
%2330% ELSE ZSYMBOL(GLB18ADDFIX,.R2[COMNAME],
%1512% .HILOC,PSCODE);
%1451% END
%2330% ELSE Z30CODE(.DPTR[IDPSCHARS],PSCODE); ! Use RH relocation
%1451% END; ! generating .REL file
HILOC = .HILOC + 1;
IF .DPTR[IDGENLENFLG]
THEN
BEGIN ! Output length to hiseg with no relocation
! SUBSTRING nodes with a constant lower bound and
! non-constant upper bound only use the byte pointer
RDATWD = .DPTR[IDCHLEN];
IF .FLGREG<OBJECT>
%2330% THEN Z30CODE(PSABS,PSCODE);
HILOC = .HILOC + 1;
END; ! of outputting length
! List symbol name, descriptor address, lowseg data position,
! and length
IF .FLGREG<LISTING> AND .FLGREG<MACROCODE>
THEN LISTCHD(.DPTR,.DPTR[IDCHBP]);
%1522% ! Cause an internal compiler error if the .Dnnnn
%1522% ! variable has a length less than 1.
%1522% IF .DPTR[IDGENLENFLG] THEN
%1522% IF .DPTR[IDCHLEN] LEQ 0 THEN CGERR();
%1567% END; ! Want to allocate
DPTR = .DPTR[CLINK] ! Get next linked list entry
END ! Walk down linked list
END; ! of HSDDESC
GLOBAL ROUTINE HDRCHD=
BEGIN
%1232% ! Written by TFV, 17-Jun-81
! Output header to .LST file for character data section
%2311% IF EXTENDED
%2311% THEN
%2311% LSTHDR(7, 6, PLIT '?M?JCHARACTER DATA [ "*" NO EXPLICIT DEFINITION - "!" VARIABLE STORED IN .LARG. ]
?J NAME ?I?IDESCRIPTOR ADDRESS ?ISTART OF DATA ?ILENGTH
?J?I?I?I?I?IADDR(POSITION)?M?J?M?J?0')
%2311% ELSE
LSTHDR(7, 6, PLIT '?M?JCHARACTER DATA [ "*" NO EXPLICIT DEFINITION ]
?J NAME ?I?IDESCRIPTOR ADDRESS ?ISTART OF DATA ?ILENGTH
?J?I?I?I?I?IADDR(POSITION)?M?J?M?J?0');
END; ! of HDRCHD
GLOBAL ROUTINE TABOUT=
BEGIN
%1232% ! Written by TFV, 17-Jun-81
! Output a tab to the listing
CHR _ #11; ! TAB
LSTOUT();
END; ! of TABOUT
GLOBAL ROUTINE ZOUTBP(OBP)=
BEGIN
%1232% ! Written by TFV, 17-Jun-81
REGISTER BASE BP;
MAP
BASE R2,
BASE OBP;
! Output the start address of character data as addr(charpos)
%2330% IF NOT EXTENDED ! Local byte pointers?
%2216% THEN
! Convert #010700,,FOO-1 TO #440700,,FOO
IF .OBP<LEFT> EQL #010700
THEN BP = #440700 ^ 18 + .OBP<RIGHT> + 1
ELSE BP = .OBP
%2216% ELSE ! Convert #66ssss,,FOO-1 TO #61ssss,,FOO
%2216% IF .OBP<30,6> EQL #66
%2216% THEN BP = #61^30 + .OBP<0,30> + 1
%2216% ELSE BP = .OBP;
%2330% IF EXTENDED ! Global byte pointers?
%2311% THEN
%2311% BEGIN !/EXTEND
%2311% R2 _ .BP<0,30>; !GET LONG ADDR
%2311% ZOUTADDR(); !OUTPUT IT
%2311% END !/EXTEND
%2311% ELSE
%2311% BEGIN !NO /EXTEND
R2<LEFT> _ .BP<RIGHT>; ! Get the address of data
ZOUTOCT() ! Output it
%2311% END; !NO /EXTEND
CHAROUT("("); ! Output a (
%2344% IF .OBP NEQ 0 ! Was the BP good?
%2344% THEN
%2344% BEGIN ! Good BP
%2330% IF NOT EXTENDED ! Local byte pointers?
%2216% THEN ! Yes
%2216% BEGIN ! NOT EXTENDED
R1 _ .BP<30,6>; ! Get P field of byte pointer
R1 _ (43 - .R1) / 7; ! Compute charpos 1-5
%2216% END ! NOT EXTENDED
%2216% ELSE ! No, global byte pointers
%2216% BEGIN ! EXTENDED
%2216% R1 _ .OBP<30,6>; ! Get P&S field of byte pointer
%2311% R1 _ (.R1-#60); ! Compute charpos 1-5
%2216% END; ! EXTENDED
%2344% ZOUDECIMAL() ! Output byte offset
%2344% END ! Good BP
%2344% ELSE CHAROUT("??"); ! No, bad BP, be silly
CHAROUT(")"); ! Output a )
END; ! of ZOUTBP
GLOBAL ROUTINE LISTCHD(PTR,BP)=
BEGIN
%1232% ! Written by TFV, 17-Jun-81
! Output character data name, descriptor address, start of data, and length
MAP BASE PTR:R2;
IF .HDRFLG EQL 0 ! Output header if needed
THEN
BEGIN ! Output character data banner
HDRFLG_1;
HDRCHD();
END; ! Output character data banner
! Output variable name or TAB for constants
IF .PTR[OPERATOR] EQL CHARCONST
THEN
BEGIN ! Character constant
%1534% REGISTER COL,CC,C;
%1534% LOCAL CP;
! Output 'cccccc' to listing
%1534% CHAROUT("'"); ! start with '
%1534% COL = 2; ! we are now at col 2
%1534% CP = PTR[LITC1]; ! set character pointer
%1534% CC = .PTR[LITLEN]; ! and character count
%1534% WHILE (.CC GTR 0) AND (.COL LEQ 11) ! print up to 10 chars
%1534% DO
%1534% BEGIN
%1534% C = SCANI(CP); ! get char from string
%1534% IF .C EQL #177 THEN C = -1; ! print rubout as ^?
%1534% IF .C LSS #40 ! control char?
%1534% THEN (CHAROUT("^"); CHAROUT(.C+#100); COL = .COL + 1)
%1534% ELSE CHAROUT(.C); ! no, print normally
%1534% COL = .COL + 1; ! increment col count
%1534% CC = .CC - 1; ! decrement char count
%1534% END;
%1534%
%1534% CHAROUT("'"); ! print closing '
%1534% IF .CC GTR 0 THEN STRNGOUT(UPLIT ASCIZ '...');
%1534% ! print dots if whole
%1534% ! constant didn't get
%1534% ! printed
%1534% IF .COL LSS 8 THEN TABOUT(); ! print extra tab to
%1534% ! line up tab stops
END ! Character constant
ELSE
BEGIN ! Character variable
R2 _ .PTR[IDSYMBOL]; ! Name of variable
%2311% ! Output "!" if stored in .LARG. else,
! output "*" if not explicitly defined.
%2311% ! (IE; Large overrides not defined)
%2311% ! Information can be lost when a variable is
%2311% ! by IMPLICIT CHARACTER*<bignumber>.
%2311% IF .PTR[IDPSCHARS] EQL PSLARGE !IF LARGE CHARACTER DATA
%2311% THEN CHAROUT("!") ! FLAG FROM LARGE PSECT W/ A BANG!
%2311% ELSE
IF NOT .PTR[IDATTRIBUT(INTYPE)] AND .PTR[OPRSP1] NEQ ARRAYNM1
THEN
BEGIN ! Don't output "*" for .Dnnnn variables
IF .R2<30,6> NEQ SIXBIT "." THEN CHAROUT("*")
END ! Don't output "*" for .Dnnnn variables
ELSE CHAROUT(" ");
ZOUTSYM(); ! Output it
TABOUT(); ! Output a TAB
END; ! Character variable
TABOUT(); ! Output a TAB
! Output descriptor address
IF .PTR[OPERATOR] NEQ CHARCONST AND .PTR[IDPSECT] EQL PSDATA
THEN
BEGIN ! It's a lowseg address
R2<LEFT> _ .PTR[IDADDR]; ! Lowseg address
ZOUTOCT(); ! Output it to listing
TABOUT(); ! Output extra TAB
END ! It's a lowseg address
ELSE
BEGIN ! It's a hiseg address
STRNGOUT(UPLIT ASCIZ '.HSCHD'); ! Address of start of hiseg descriptors
R1 _ .PTR[IDADDR] - .CHDSTART; ! Offset from .HSCHD
ZOUOFFSET(); ! Output + offset
END; ! It's a hiseg address
TABOUT(); ! Output a TAB
TABOUT(); ! Output another TAB
! Output start of character data as addr(charpos)
! charpos is 1 for first char, 5 for last in word
%1434% IF .PTR[OPERATOR] NEQ CHARCONST
%1434% THEN
%1434% BEGIN
%1434% IF .PTR[IDATTRIBUT(DUMMY)]
THEN STRNGOUT(UPLIT ASCIZ '(argument)') ! Dummy argument
%1434% ELSE IF .PTR[IDATTRIBUT(INEXTERN)]
%1434% THEN STRNGOUT(UPLIT ASCIZ '(external)') ! External function
%1434% ELSE
BEGIN ! Output character constant data address
ZOUTBP(.BP); !OUTPUT BP
%2330% IF EXTENDED ! Global byte pointers?
%2311% THEN !IF /EXTENDED
%2311% (IF .BP<0,30> LSS #10000 !CHECK 30 BITS OF OWG
%2311% THEN TABOUT()) !OUTPUT TAB IF NEEDED
%2311% ELSE !IF /NOEXTEND
%2311% (IF .BP<RIGHT> LSS #10000 !CHECK 18 BITS
%2311% THEN TABOUT()); ! Output an extra TAB
END; ! Output character constant data address
%1434% END
%1434% ELSE
BEGIN ! Output character constant data address
ZOUTBP(.BP);
%2330% IF EXTENDED ! Global byte pointers?
%2311% THEN
%2311% (IF .BP<0,30> LSS #10000
%2311% THEN TABOUT())
%2311% ELSE
IF .BP<RIGHT> LSS #10000
THEN TABOUT(); ! Output an extra TAB
END; ! Output character constant data address
TABOUT(); ! Output a TAB
! Output the length
IF .PTR[OPERATOR] EQL CHARCONST
THEN R1 _ .PTR[LITLEN]
ELSE R1 _ .PTR[IDCHLEN];
IF .R1 EQL LENSTAR ! Is it length *
THEN STRNGOUT(UPLIT ASCIZ '(*)') ! Output a (*)
ELSE ZOUDECIMAL(); ! Output the length
CRLF; ! Output a CRLF
HEADCHK(); ! Check for bottom of listing page
END; ! of LISTCHD
%[735]% ROUTINE HDRTMP=
%[735]% LSTHDR(4,3,PLIT'?M?JTEMPORARIES?M?J?M?J?0');
GLOBAL ROUTINE ALCQVARS=
BEGIN
! Routine cleans up the allocation of .Qnnnn variables.
! These are the temps generated by the local register allocator
%2311% LOCAL HOWIDE; !NUMBER OF SYMBOLS / LISTING LINE
%1274% REGISTER LEN,BASE SYMPTR;
! Now (for either subprogram or main program, allocate and list
! the temps generated by local register allocation
%2311% IF .FLGREG<LISTING>
%2311% THEN
%2311% HOWIDE = IF EXTENDED THEN 3 !THIS MANY SYBOLS / LINE UNDER /EXTEND
%2311% ELSE 5; !OTHERWISE DO MORE
%1274% SYMPTR = .QANCHOR; ! Start at the beginning
%1274% WHILE .SYMPTR NEQ 0 DO
BEGIN
%1274% LEN = .SYMPTR[IDADDR]; ! Address in .Q space for this variable
%1274% SYMPTR[IDADDR] = .LOWLOC + .LEN; ! Actual address for this variable
%1406% SYMPTR[IDCHBP] = BPGEN(.SYMPTR[IDADDR]); ! Setup byte pointer
IF .FLGREG<LISTING>
%[735]% THEN
BEGIN
IF .HDRFLG EQL 0
THEN
BEGIN
HDRFLG = 1;
HDRTMP();
END;
%1274% LISTSYM(.SYMPTR);
TCNT = .TCNT + 1;
%2311% IF .TCNT GTR .HOWIDE
THEN
BEGIN
TCNT = 0;
CRLF;
HEADCHK();
END
END;
%1274% SYMPTR = .SYMPTR[CLINK]; ! Next .Q to allocate
END; ! WHILE .SYMPTR NEQ 0
%1274% LOWLOC = .LOWLOC + .QMAX; ! Set up lowloc to after end of .Q space
IF .FLGREG<LISTING>
THEN
BEGIN
CRLF;
HEADCHK();
END;
END; ! of ALCQVARS
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
%1526% CHDSTART = HILOC = 0; ! First free location in .CODE.
%1245% ! and start of character descriptors
%470% IF .LOWLOC LSS #400000-#1000 ! Will the lowseg overlap the hiseg ?
%1526% THEN HIORIGIN = #400000 ! No, start at halfway point
%1526% ELSE HIORIGIN = (.LOWLOC+#777+#1000) AND #777000; ! Yes, round up
IF .FLGREG<OBJECT>
THEN
BEGIN
%1525% IF EXTENDED ! Psected compilation ?
%1525% THEN DMPMAINRLBF() ! Yes, flush out lowseg constants
%1525% ELSE ! No, define segments
%1525% BEGIN
%1526% RDATWD = .HIORIGIN^18 + .HIORIGIN; ! In both halves
ZOUTBLOCK(RHISEG,RELRI);
RDATWD = .LOWLOC^18 + 0;
ZOUTBLOCK(RHISEG,RELN)
%1525% END;
%1245% ! Output symbol .HSCHD for character data listing section
%1512% ZSYMBOL(LOCSUPDEF,SIXBIT '.HSCHD',.CHDSTART,PSCODE)
END;
END; ! of HISEGBLK
GLOBAL ROUTINE RELINIT=
BEGIN
!++
!********************************************************
! Initializes .REL file, generating these LINK blocks
!
! 4 - ENTRY
! 6 - NAME
![2446] 1050 - PSECT HEADER
! 1131 - Segment redirection (/EXTEND only)
!
!********************************************************
!--
LOCAL
INDEX, ! last psect index
NAME[2]; ! Holds single word psect names
REGISTER
%1434% BASE ENT;
BIND
! Various bits for the name block
%1003% KSCPU = 1^33, ! KS10 cpu type
%1003% KLCPU = 1^32, ! KL10
%1666% FTNID = #10^18, ! FORTRAN compiler id
! Origins for the various segments
%2440% DATAORG = #1001000,
%2356% CODEORG = #1300000,
%1525% LARGEORG = #2000000;
INIRLBUFFS(); ! Initialize the .REL file buffers
! Initialize the entry block
%1434% R2 = .PROGNAME; ! First the program name
%1434% RDATWD = RADIX50();
%1434% ZOUTBLOCK(RENTRY,RELN);
%1434% ENT = .MULENTRY; ! Now any entry points
%1434% WHILE .ENT NEQ 0 DO
%1434% BEGIN
%1434% R2 = .ENT[IDSYMBOL]; ! Get the entry name
%1434% RDATWD = RADIX50();
%1434% ZOUTBLOCK(RENTRY,RELN);
%1434% ENT = .ENT[IDENTLNK];
%1434% END;
R2 = .PROGNAME;
RDATWD = RADIX50();
ZOUTBLOCK(RNAME,RELN); !NAME BLOCK
![1003] Output compiler type to .REL file.
%1666% RDATWD = FTNID;
%1703% ! To include a processor type into the rel file, include some
%1703% ! part(s) of the below lines to the assignment to RDATWD. We
%1703% ! are not specifying any processor, since V5A specified only KI,
%1703% ! and V7 will not run on a KI. If we tell the truth, then V7
%1703% ! users with a V5A library will get Link-time warnings.
%1703% ![1525] KS processors are non-extended and non-gfloating.
%1703% ! OR KLCPU OR
%1703% ! (IF NOT .GFLOAT AND NOT EXTENDED THEN KSCPU ELSE 0);
%1666% ZOUTBLOCK(RNAME,RELN); ! FORTRAN compiler id and CPU bits
%1525% IF EXTENDED
THEN
BEGIN ! /EXTEND switch given
! Define the psect names, attributes, indices and
! origins.
DMPMAINRLBF(); ! Make sure the type 4 blocks
! gets out first
! Note that LINK has a hidden restriction that you
! must define psects in increasing psect index order.
! If the values of PXCODE, PXDATA and PXLARGE change,
%2446% ! the following paragraphs should be changed.
%2446% NAME[0] = 1;
%2446% NAME[1] = SIXBIT '.LARG.';
%2446% TYPE1050(HINAME,PXCODE,PACODE,CODEORG);
%2446% TYPE1050(LONAME,PXDATA,PADATA,DATAORG);
%2446% TYPE1050(NAME,PXLARGE,PALARGE,LARGEORG);
%2446% INDEX = PXLARGE; ! last psect index
%2446% IF (.HINAME[0] NEQ 1) OR (.HINAME[1] NEQ SIXBIT ".CODE.")
%2446% THEN
%2446% BEGIN
%2446% NAME[1] = SIXBIT '.CODE.';
%2446% TYPE1050(NAME,INDEX=.INDEX+1,PACODE,CODEORG);
%2446% END;
%2446% IF (.LONAME[0] NEQ 1) OR (.LONAME[1] NEQ SIXBIT ".DATA.")
%2446% THEN
%2446% BEGIN
%2446% NAME[1] = SIXBIT '.DATA.';
%2446% TYPE1050(NAME,INDEX=.INDEX+1,PADATA,DATAORG);
%2446% END;
%2310% ! Output PSECT redirection information rel block
%2310%
%2310% PSREDIRECT();
%1525% END; ! /EXTEND switch given
END; ! of RELINIT
GLOBAL ROUTINE TYPE1050(NAME,INDEX,ATTRIB,ORIGIN)=
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine puts out a type 1050 rel block
!
! FORMAL PARAMETERS:
!
! NAME word 0 = number of words in psect name
! word 1-12 = psect name
! INDEX psect index
! ATTRIB psect attributes
! ORIGIN psect origin
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
!--
! New [2446] MEM
BEGIN
STRUCTURE
PVECTOR[WD]= ! Structure for a pointer to a vector
(@.PVECTOR + .WD);
MAP
PVECTOR NAME;
LOCAL
MYRELBUF[17], ! Holds various REL block types
! 13 words are needed for the psect name and long count
! plus words for block type / long count, index,
! attributes, origin
NAMELEN, ! number of words in the psect name
ATTINDX; ! index into MYRELBLOCK of attributes
MYRELBUF[1] = .INDEX;
NAMELEN = .NAME[0]; ! number of words in psect name
IF .NAMELEN EQL 1
THEN
BEGIN
MYRELBUF[2] = .NAME[1];
MYRELBUF[3] = .ATTRIB;
MYRELBUF[4] = .ORIGIN;
! Don't specify an origin if it is not .DATA.,.CODE. or .LARG.
IF (.NAME[1] NEQ SIXBIT '.DATA.') AND
(.NAME[1] NEQ SIXBIT '.CODE.') AND
(.NAME[1] NEQ SIXBIT '.LARG.')
THEN
BEGIN
MYRELBUF[0] = RLONGPSECTHEAD^18 OR 3;
DMPRLBLOCK(MYRELBUF,4);
END
ELSE
BEGIN
MYRELBUF[0] = RLONGPSECTHEAD^18 OR 4;
DMPRLBLOCK(MYRELBUF,5);
END;
END
ELSE
BEGIN
MYRELBUF[2] = .NAMELEN;
INCR I FROM 1 TO .NAMELEN DO MYRELBUF[.I+2] = .NAME[.I];
ATTINDX = 3 + .NAMELEN;
MYRELBUF[.ATTINDX] = .ATTRIB;
MYRELBUF[0] = RLONGPSECTHEAD^18 OR
(.ATTINDX); ! type & count
DMPRLBLOCK(MYRELBUF,.ATTINDX+1);
END;
END;
GLOBAL ROUTINE PSREDIRECT= ![2310] New
!++
! FUNCTIONAL DESCRIPTION:
!
! Output a type 1131 PSECT redirection block for LINK when
! compiling /EXTEND. This will make all low segment code go into
! a specific PSECT and all high segment code go into another (the
! names can be given by the user). The caller decides if
! compilation is done /EXTEND.
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! DEFLON Default name of the low (data) PSECT. Word 0 is
! the count of the number of SIXBIT words in name.
!
! DEFHIN Default name of the high (code) PSECT. Word 0 is
! the count of the number of SIXBIT words in name.
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! Outputs a rel block.
!
!--
BEGIN
LOCAL HEADERWD;
! Make sure we've finished dumping out other rel blocks.
DMPMAINRLBF();
! Dump our block. Output 1 word at a time. The names and
! lengths of the PSECT's may vary, so we must use variables.
%2454% HEADERWD = RREDIRECT^18 OR (.DEFLON[0]+.DEFHIN[0]+2);
%2446% DMPRLBLOCK(HEADERWD, 1); ! Header; 1131,,count
%2454% DMPRLBLOCK(DEFLON, .DEFLON[0]+1); ! Count and Name of data psect
%2454% DMPRLBLOCK(DEFHIN, .DEFHIN[0]+1); ! Count and Name of code psect
END; ! of PSREDIRECT
ROUTINE CIMPLNONE= ! [2507] New
!++
! FUNCTIONAL DESCRIPTION:
!
! Walk the symbol table to check for any symbols that should be
! output for IMPLICIT NONE that haven't been yet. We primarily
! will catch the unallocated variables at this point.
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! E304 Warning for IMPLICIT NONE
!
! SYMTBL Hashed symbol table entries
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN
REGISTER BASE SYM; ! The symbol table entry
! Go through every symbol in the symbol table.
DECR CNT FROM SSIZ-1 TO 0
DO
BEGIN ! Walk each hash bucket in the symbol table
SYM = .SYMTBL[.CNT]; ! This hash entry
! If this isn't zero, then there's a symbol here. The
! entries are linked together within a hash bucket, so walk
! all of them in this bucket and check them.
WHILE (.SYM NEQ 0)
DO
BEGIN ! Contents of each bucket in the symbol table
! If IMPLICIT NONE is given, then we must insure that
! the variable is declared in a type statement,
! Unless:
! - The warning has already been given for
! this symbol
! - The symbol was in a type statement
! - The symbol is a Fortran temporary (has
! "." as first char)
! - The symbol is a NAMELIST name
! - The symbol is a COMMON block name, but not
! in a COMMON statement;
! COMMON /FOO/ A,FOO,B
! - The symbol is a subroutine name, and not
! also a variable name (can only happen in a
! subroutine program)
! - The symbol is a valid subroutine name
! (for the form of calling a function)
! - The symbol is a library function
! - The symbol is a function entry name and
! we're compiling a MAIN program (so the name
! is a main program name)
! - The symbol has a library function name
! (The symbol table reference for the
! original undotted name appears just like a
! variable)
! This is structured to not slow down the majority
! of cases, since the entire symbol table is
! walked. IF THEN's generate faster code than
! IF AND's.
IF NOT .SYM[IDIMPLNONE] ! Message already given
THEN IF NOT .SYM[IDATTRIBUT(INTYPE)] ! Declared
THEN IF .SYM[IDDOT] NEQ SIXBIT"." ! Dotted name
THEN IF NOT .SYM[IDATTRIBUT(NAMNAM)] ! NAMELIST
THEN IF NOT (.SYM[IDATTRIBUT(COMBL)] ! COMMON block
AND NOT .SYM[IDATTRIBUT(INCOM)])
THEN IF NOT (.SYM[IDSUBROUTINE] ! Subroutine
AND .SYM[IDATTRIBUT(NOALLOC)]) ! or var?
THEN IF NOT (.SYM[OPR1] EQL FNNAMFL ! External name
AND (.SYM[IDLIBFNFLG] ! library fn
OR .SYM[IDSUBROUTINE])) ! subroutine
THEN IF NOT (.FLGREG<PROGTYP> EQL MAPROG ! Main program
AND .SYM[IDATTRIBUT(FENTRYNAME)])
THEN IF SRCHLIB(.SYM) EQL -1 ! Not lib fn, undotted
! name would appear to
! be a variable
THEN
BEGIN ! Give a warning, this symbol must be declared!
FATLERR(.SYM[IDSYMBOL], 0, E304<0,0>);
SYM[IDIMPLNONE] = 1; ! Gave message
END; ! Give a warning, this symbol must be declared!
SYM = .SYM[CLINK]; ! Next linked symbol (or 0)
END; ! Contents of each bucket in the symbol table
END; ! Walk each hash bucket in the symbol table
END; ! of CIMPLNONE
END
ELUDOM