Trailing-Edge
-
PDP-10 Archives
-
BB-4157F-BM_1983
-
fortran/compiler/outmod.bli
There are 26 other files named outmod.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
! OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1973, 1983
!AUTHOR: F. INFANTE/MD/DCE/JNG/TFV/CDM/AHM/RVM/EGM
MODULE OUTMOD(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND OUTMOV = 7^24 + 0^18 + #1703; ! Version Date: 17-DEC-82
%(
***** 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 Revision History *****
)%
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE REQREL.BLI;
SWITCHES LIST;
FORWARD
CHADDR2BP(1),
SIZEINCHARS(1),
LSTHDR(3),
OUTDATA(3),
LISTSYM(1),
SUBPROGLIST,
ALLSCAA,
ALLCOM,
ALLOCAT,
DUMPFORMAT, ! 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;
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,
%1522% CGERR, ! Routine to report an internal compiler error
CHAROUT,
%1245% CHDSTART,
%1261% CNSTEVAL, ! For evaluating subscript expression if necessary
COMBLKPTR,
%1274% COMTSIZ, ! Current total size of COMMON including blank common
DANCHOR, ! Pointer to the start of the .Dnnnn variables
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"
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
%1437% HIORIGIN, ! Start of Hi-seg
INIRLBUFFS, ! To init .REL file buffers
ISN,
%1006% KISNGL, ! KISNGL is now in UTIL.BLI
LITPOINTER,
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,
%1274% QANCHOR,
%1274% QMAX,
RADIX50,
RDATWD,
RELBLOCK,
RELDATA,
RELOCWD,
RELOUT,
%1511% SAVALL, ! SAVE statement with no args given
STRNGOUT,
%1434% TBLSEARCH, ! Routine to lookup symbol table entries
%1245% TCNT,
WARNERR,
%1526% ZCODE, ! Outputs a word using type 1 or 1010 rel blocks
ZOUDECIMAL,
ZOUOFFSET,
ZOUTBLOCK,
ZOUTMSG, ! Message outputter
ZOUTOCT,
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$;
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>);
! LEFT HALF OF BYTE POINTER TO BYTE 1,2,...,5
ROUTINE CHADDR2BP (A) = ! [1261] Convert character address A to
! equivalent byte pointer
(.A/5) OR .BPLH [.A MOD 5];
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 OUTDATA(SYMADDR,SYMVALUE,SYMPT)=
BEGIN
! Instructs the loader about initialization of lowseg data as
! specified in DATA statements. SYMPT is the pointer to the symbol
! being initialized. SYMVALUE is the value to store. SYMADDR is the
! allocated address of the symbol.
MAP BASE R2:SYMPT;
IF NOT .FLGREG<OBJECT> ! Producing REL file ?
THEN RETURN; ! No
%1544% IF EXTENDED ! Psected object code ?
THEN ! Yes
BEGIN
! Set the default psect before we dump the
! data. Note that all the data are in .DATA.
RDATWD = PXDATA; ! Index for .DATA.
ZOUTBLOCK(RPSECTORG,RELN) ! Psect index rel block
%1544% END;
IF .SYMPT[IDATTRIBUT(INCOM)]
THEN
BEGIN ! Do special fixup
IF .MAINRLBF[RDATCNT] GTR RBLKSIZ-5 ! 3 words left ?
THEN DMPMAINRLBF(); ! No, make room
R2 _ .SYMPT[IDCOMMON]; ! Pointer to COMMON block node
R2 _ .R2[COMNAME]; ! Fetch the block name
RDATWD _ RGLOBREQ+RADIX50(); ! Convert to a symbol request
ZOUTBLOCK(RDATBLK,RELN); ! Put it out
RDATWD _ (1^18)+.SYMADDR<RIGHT>;! One word at /COMMON/+SYMADDR
ZOUTBLOCK(RDATBLK,RELN) ! Output count and offset
END
ELSE
BEGIN
IF .MAINRLBF[RDATCNT] GTR RBLKSIZ-4 ! 2 words left ?
THEN DMPMAINRLBF(); ! No, make room
RDATWD _ (1^18)+.SYMADDR<RIGHT>;! One word at SYMADDR
ZOUTBLOCK(RDATBLK,RELRI); ! Output count and address
END;
RDATWD _ .SYMVALUE; ! The value to be stored
ZOUTBLOCK(RDATBLK,RELN) ! Output it
END; ! of OUTDATA
GLOBAL ROUTINE LISTSYM(PTR)=
BEGIN
MAP BASE PTR;
LABEL BLNK;
R2 _ .PTR[IDSYMBOL];
% NOTE INSTANCES OF NO EXPLICIT DEFINITION %
BLNK:BEGIN
IF NOT .PTR[IDATTRIBUT(INTYPE)]
THEN IF .PTR[OPRSP1] NEQ ARRAYNM1
THEN
IF .R2<30,6> NEQ SIXBIT"." !FORGET COMPLER DEFINED VARS
THEN ( CHAROUT( "*" ); LEAVE BLNK );
CHAROUT( " " );
END; %BLNK%
ZOUTSYM();
CHR _ #11; LSTOUT(); !TAB
%1261% IF .PTR[VALTYPE] NEQ CHARACTER ! If numeric, list address
THEN (R2<LEFT> _ .PTR[IDADDR]; ZOUTOCT())
%1261% ELSE ZOUTBP(.PTR[IDCHBP]); ! If character, 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;
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
%[735]% LSTHDR(4,3,PLIT '?M?JSCALARS AND ARRAYS [ "*" NO EXPLICIT DEFINITION - "%" NOT REFERENCED ]?M?J?M?J?0');
%[735]% HDRFLG_0;
SCNT_0;
DECR I FROM SSIZ-1 TO 0 DO ! 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
![473], LISTING FOR SCALARS AND ARRAYS IS A BIT TOO WIDE
%[703]% IF .SCNT LSS 4
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 lowseg
! data. Descriptor is allocated
! in high seg after hisg seg is
! inited.
%1406% PTR[IDCHBP] = BPGEN(.LOWLOC)
ELSE
! Dummy character data get descriptor
! allocated to lowseg and pointed
! to by IDADDR. Other data types
! get IDADDR pointing to low seg data.
PTR[IDADDR] _ .LOWLOC;
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
! Character data size is in characters, others are in words
IF .PTR[VALTYPE] EQL CHARACTER
%1406% THEN LOWLOC _ .LOWLOC + CHWORDLEN(.ARRAPT[ARASIZ])
ELSE LOWLOC _ .LOWLOC + .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. Character data size is in characters
%1406% LOWLOC _ .LOWLOC + CHWORDLEN(.PTR[IDCHLEN]);
END ! Character scalar
ELSE
BEGIN ! Non-character scalar
! Output one or two words based on variable size
IF .PTR[DBLFLG]
THEN LOWLOC _ .LOWLOC + 2
ELSE LOWLOC _ .LOWLOC + 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);
%[703]% IF .SCNT LSS 4
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 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
!
! 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 2. The one that remains a group has
! EQVAVAIL set to 0. At the end of this processing, the groups with
! EQVAVAIL = 2 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.
GLOBAL ROUTINE ALLCOM=
BEGIN
%ROUTINE ALLOCATES RELATIVE ADDRESSES TO ALL VARIABLES DECLARED IN COMMON.
THE ADDRESSES OF THE VARIABLES / ARRAYS IN A COMMON BLOCK ARE ARLATIVE TO THE
BEGINNING OF THE BLOCK IN WHICH THEY ARE DECLARED. EACH BLOCK HAS AN ORIGIN
OF ZERO. AT LOAD TIME THE LOADER WILL ASSIGN ACTUAL LOCATIONS TO
COMMON BLOCKS BASED ON THEIR SIZES AND ORDER OF
APPEARANCE TO LOADER. IN THE RLOACTABLE BINARY, REFERENCES TO
COMMON VARIABLES WILL USE ADDITIVE GLOBAL FIXUPS.
THE CALL TO THIS ROUTINE OCCURS AFTER ANY EQUIVALENCE RELATIONS
HAVE BEEN PROCESSED BY ROUTINE PROCEQUIV
%
REGISTER ICNT;
REGISTER BASE CSYMPTR;
LOCAL BASE CCOMPTR;
%1261% LOCAL FLAGWRD;
%1261% BIND CHARSEEN = FLAGWRD<0,1>, ! BLOCK CONTAINS CHARACTER DATA
%1261% NUMSEEN = FLAGWRD<1,1>; ! BLOCK CONTAINS NUMERIC DATA
%1630% IF EXTENDED AND .FLGREG<OBJECT> ! Psected object code ?
%1615% THEN ! Yes
%1615% BEGIN
! 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. We assume that all variables are in .DATA. for now.
%1615% RDATWD = PXDATA; ! Index for .DATA.
%1615% ZOUTBLOCK(RPSECTORG,RELN) ! Psect index rel block
%1615% END;
ICNT _ 0;
%1511% ! If bare SAVE, then zero count. May have specified non-bare
%1511% ! COMMON, and that would mess up our count.
%1511% IF .SAVALL EQL TRUE
%1511% THEN NUMSAVCOMMON = 0;
%[735]% LSTHDR(5,3,PLIT'?M?JCOMMON BLOCKS?M?J?0');
CCOMPTR _ .FIRCOMBLK; !PTR TO FIRST COMMON BLOCK DECLARED
WHILE 1 DO %1%
BEGIN
%1511% ! Bare SAVE statement. Save the number of commons processed for
%1511% ! later output of the rel block.
%1511% IF .SAVALL
%1531% THEN NUMSAVCOMMON = .NUMSAVCOMMON + 1;
%1261% ! CONVERT COMSIZE BACK TO WORDS
%1406% CCOMPTR[COMSIZE] _ CHWORDLEN(.CCOMPTR[COMSIZE]);
!START BY OUTPUTTING NAME OF BLOCK
IF .FLGREG<LISTING>
THEN
BEGIN
CRLF;
HEADCHK();
CHR_"/";LSTOUT();
R2 _ .CCOMPTR[COMNAME]; ZOUTSYM();
CHR _ "/"; LSTOUT();
CHR _ "("; LSTOUT();
R1 _ .CCOMPTR[COMSIZE]; ZOUOFFSET();
CHR _ ")"; LSTOUT();
END;
!RELOCATABLE BINARY IF NECESSARY
IF .FLGREG<OBJECT>
THEN (R2 _ .CCOMPTR[COMNAME]; !FOR RADIX 50 CONVERSION
RDATWD_RGLOBDEF+RADIX50(); ZOUTBLOCK(RCOMMON,RELN);
RDATWD_ .CCOMPTR[COMSIZE]; ZOUTBLOCK(RCOMMON,RELN);
);
%1261% !CONVERT IDADDR FROM CHARACTERS TO WORDS
%1261%
%1261% FLAGWRD _ 0; ! CLEAR CHARSEEN AND NUMSEEN
%1261% CSYMPTR _ .CCOMPTR[COMFIRST]; ! POINT TO FIRST SYMBOL IN COMMON BLOCK
%1261% DO
%1261% BEGIN
%1261% IF .CSYMPTR[VALTYPE] NEQ CHARACTER
%1261% THEN
%1261% BEGIN !NUMERIC
%1261% NUMSEEN _ 1;
%1261% IF .CSYMPTR[IDADDR] MOD CHARSPERWORD NEQ 0
%1261% THEN FATLERR(.CSYMPTR[IDSYMBOL],E167<0,0>);
%1261% ! "Must be word aligned"
%1261% CSYMPTR[IDADDR] _ .CSYMPTR[IDADDR] / CHARSPERWORD;
%1261% ! CONVERT CHAR ADDRESS TO WORD ADDRESS
%1261% END !NUMERIC
%1261% ELSE
%1261% BEGIN !CHARACTER
%1261% CHARSEEN _ 1;
%1261% CSYMPTR[IDCHBP] _ CHADDR2BP(.CSYMPTR[IDADDR]);
%1261% ! CONVERT CHAR ADDRESS TO BYTE POINTER
%1261% CSYMPTR[IDADDR] _ 0; ! AND CLEAR IDADDR, WHICH WILL BE
%1261% ! USED FOR ADDRESS OF DESCRIPTOR
%1261% END; !CHARACTER
%1261% END
%1261% WHILE (CSYMPTR _ .CSYMPTR[IDCOLINK]) NEQ 0; ! LOOP THROUGH ALL SYMBOLS
! IN THIS COMMON BLOCK
%1261% IF .CHARSEEN AND .NUMSEEN ! IF BLOCK CONTAINS BOTH CHAR & NUMERIC
%1675% THEN WARNERR(UPLIT 'mixed in COMMON?0',0,E168<0,0>);
!NOW LIST THE SYMBOLS IN THE BLOCK
IF .FLGREG<LISTING> THEN
BEGIN
CSYMPTR _ .CCOMPTR[COMFIRST];
CRLF;!CR/LF
HEADCHK();
WHILE 1 DO %2%
BEGIN
R2 _ .CSYMPTR[IDSYMBOL]; ZOUTSYM();
CHR _ #11; LSTOUT(); !TAB
%1261% IF .CSYMPTR[VALTYPE] NEQ CHARACTER
THEN (R1 _ .CSYMPTR[IDADDR]; ZOUOFFSET())
%1261% ELSE (CHAROUT("+"); ZOUTBP(.CSYMPTR[IDCHBP]));
!BE SURE TO OUTPUT CRLF AFTER LAST COMMON BLOCK NAME
IF (CSYMPTR _ .CSYMPTR[IDCOLINK]) EQL 0 THEN
!RESET ICNT SO THAT WE DO NOT GET LINE WITH SINGLE
! ELEMENT BY ACCIDENT!
(ICNT_0; CRLF; HEADCHK();
EXITLOOP);
IF (ICNT _ .ICNT +1) EQL 5
THEN (ICNT _ 0; CRLF; HEADCHK()) ELSE (CHR _ #11; LSTOUT() %TAB% );
END; !OF %2%
END;
IF (CCOMPTR _ .CCOMPTR[NEXCOMBLK]) EQL 0 THEN RETURN;
END
END; ! of ALLCOM
ROUTINE ALLOCAT=
BEGIN
%ALOCATES RELATIVE ADDRESSES TO ALL VARIABLES AND STORAGE
IN THE LOW SEGMENT,EXCEPT TEMPORARIES WHICH ARE ALLOCATED AFTER
CODE GENERATION.
THIS ROUTINE CONTROLS THE ALLOCATION BY CALLING THE ACTUAL ROUTINES
THAT DO THE ALLOCATION AND PROCESSING OF VARIABLES,COMMON BLOCKS,EQUIVALENCE
GROUPS ,DATA FIXUPS ETC.
%
%1547% COMTSIZ = PROCCOM(); ! Compute size of COMMON blocks
IF .EQVPTR NEQ 0 THEN PROCEQUIV(); !PROCESS EQUIVALENCE GROUPS
IF .COMBLKPTR NEQ 0 THEN ALLCOM(); !ALLOCATE COMMON NOW
!
!NOW ALLOCATE AND LIST ALL VARIABLES,ARRAYS ETC.
!
!LIST SUBPROGRAMS CALLED IF ANY
!
IF .FLGREG<LISTING> THEN SUBPROGLIST();
ALLSCAA(); !ALLOCATE SCALARS AND ARRAYS
END; ! of ALLOCAT
GLOBAL ROUTINE DUMPFORMAT =
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 DUMPFORMAT
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. Also RETURNS the
! total number of words of COMMON the program unit uses.
REGISTER
CBLKSIZ, ! Size of current COMMON block
TCOMSIZ, ! Size of all COMMON blocks
BASE CCOMPTR: ! Pointer to current COMMON block
CSYMPTR; ! Pointer to current STE
XTRAC;
TCOMSIZ = 0; ! Total size of all COMMON blocks
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
%1547% TCOMSIZ = .TCOMSIZ + CHWORDLEN(.CBLKSIZ); ! Add it to the total
CCOMPTR = .CCOMPTR[NEXCOMBLK] ! Point to the next common block
END; ! Loop back for more common blocks
RETURN .TCOMSIZ
END; ! of ROUTINE
ROUTINE EQERRLIST(GROUP)=
BEGIN
!LIST THE GROUP OF EQUIVALENCE VARIABLES IN CONFLICT
!
MAP BASE GROUP:R2;
LOCAL BASE SYMPTR;
SYMPTR _ .GROUP[EQVFIRST];
%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');
WHILE 1 DO( R2 _ .SYMPTR[EQLID];
R2 _ .R2[IDSYMBOL]; ZOUTSYM();
IF (SYMPTR _ .SYMPTR[EQLLINK]) EQL 0 THEN( STRNGOUT(PLIT')?M?J'); HEADCHK(); EXITLOOP)
ELSE (C _ ","; LSTOUT());
);
END; ! of EQERRLIST
ROUTINE GROUPTOCOMMON(COMSYM,NEWGRP,ELIM,GRPDISPL)=
BEGIN
!COMSYM POINTS TO SYMBOL ALREADY IN COMMON
!NEWGRP POINTS TO NEW EQV GROUP GOING TO COMMON
!ELIM IS THE EQVLIMIT OF GROUP TO WHICH COMSYM BELONGS
!GRPDISPL IS THE DISPLACEMENT OF THE MATCH ITEM IN NEWGRP
!
MAP BASE COMSYM :NEWGRP;
LOCAL BASE COMBLPTR :LASCOMSYM :DIMPTR :NEWSYM :NEWITEM;
LOCAL SYMSIZ;
NEWITEM _ .NEWGRP[EQVFIRST]; !FIRST ITEM IN NEW GROUP
WHILE 1 DO
BEGIN
NEWSYM _ .NEWITEM[EQLID]; !PTR TO SYMBOL TABLE NODE
IF .COMSYM NEQ .NEWSYM
THEN IF NOT .NEWSYM[IDATTRIBUT(INCOM)]
THEN
BEGIN
IF (NEWSYM[IDADDR] _ .COMSYM[IDADDR] + .NEWITEM[EQLDISPL] - .GRPDISPL) LSS 0
THEN
BEGIN
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);
NEWGRP[EQVAVAIL] _ 3; 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 ITEMS IN GROUP2 INTO GROUP1 WHEN EITHER GROUP IS IN COMMON
!TO ALLOW FOR FURTHER SEARCHING OF GROUP1 BY LATER GROUPS
!
MAP BASE GROUP1 :GROUP2 :G1SYM;
LOCAL BASE G1ITEM :G2ITEM :NEXG2ITEM;
G2ITEM _ .GROUP2[EQVFIRST];
WHILE 1 DO
BEGIN
NEXG2ITEM _ .G2ITEM[EQLLINK];
IF .G1SYM NEQ .G2ITEM[EQLID]
THEN (G1ITEM _ .GROUP1[EQVLAST];
G1ITEM[EQLLINK] _ .G2ITEM;
GROUP1[EQVLAST] _ .G2ITEM;
G2ITEM[EQLLINK] _ 0;
);
IF (G2ITEM _ .NEXG2ITEM) EQL 0 THEN RETURN .VREG;
END; !OF WHILE 1
END; ! of LINKGROUPS
ROUTINE ELISTSRCH(ECLASS,EGROUP)=
BEGIN
%SEARCH EACH ITEM IN GROUP POINTED TO BY EGROUP AGAINST ALL ITEMS IN
CLASS POINTED TO BY ECLASS. WHEN MATCH IS FOUND IF AT ALL, THEN LINK
ITEMS IN EGROUP INTO ECLASS IF NEITHER EGROUP NOR ECLASS IS IN COMMON.
IF EITHER (BUT NOT BOTH)ARE IN COMMON THEN ADD NEW ITEMS
NOT IN COMMON INTO COMMON BLOCK OF WHICH ECLASS OR EGROUP ITEMS ARE MEMBERS.
ERRORS OCCUR IF BOTH ECLASS AND EGROUP ARE IN COMMON.
%
%1511% ! Massive reformatting and indenting
LABEL ELIS1,ELIS2;
LOCAL EGSYM, !SYMBOL BEING SEARCHED IN GROUP
EGSYMPTR, !PTR TO SYMBOL TABLE OF SYMBOL BING SEARCHED
EGITEM, !PTR TO CURRENT EQUIVLIST ITEM IN GROUP
CITEM, !PTR TO LIST ITEM IN CLASS ECLASS
CSYMPTR; !PTR TO SYMBOL TABLE OF ITEM IN ECLASS
MAP BASE ECLASS :EGROUP :EGSYMPTR :CITEM :CSYMPTR :EGITEM;
!
XTRAC; !FOR DEBUGGING TRACE
!
EGITEM _ .EGROUP[EQVFIRST]; !FIRST LIST ITEM IN EGROUP
ELIS1: BEGIN
WHILE 1 DO
BEGIN
!SEARCH FOR MATCH OF ITEM IN ECLASS WITH ITEM IN EGROUP
EGSYMPTR _ .EGITEM[EQLID];
EGSYM _ .EGSYMPTR[IDSYMBOL]; !GET THE SYMBOL
CITEM _ .ECLASS[EQVFIRST]; !THE PTR TO FIRST LIST ITEM IN ECLASS
ELIS2: WHILE 1 DO %2%
BEGIN
CSYMPTR _ .CITEM[EQLID]; !SYMBOL TABLE PTR
IF .EGSYM EQL .CSYMPTR [IDSYMBOL]
THEN LEAVE ELIS1; !WITH (-1);
IF .CITEM[EQLLINK] EQL 0
THEN LEAVE ELIS2
ELSE CITEM _ .CITEM[EQLLINK];
END; !OF %2%
IF .EGITEM[EQLLINK] EQL 0
THEN RETURN 0 !No match between ECLASS and EGROUP
ELSE EGITEM _ .EGITEM[EQLLINK];
END !OF WHILE %1%
END;
! ) EQL 0 THEN RETURN 0; !RETURN 0 IF NO MATCH BETWEEN ECLASS AND EGROUP
!
!WE GET HERE IF AN ITEM IN EGROUP MATCHES AN ITEM IN ECLASS
!CITEM POINTS TO THE ITEM IN ECLASS AND EGITEM POINTS TO THE
!ITEM IN EGROUP. WE NOW CHECK FOR COMMON EQUIVALENCE INTERACTION
!AND DECIDE WHETHER TO LINK THE NEW ITEMS INTO ECLASS OR TO ADD NEW ITEMS TO
!THE COMMON BLOCK OF WHICH ECLASS OR EGROUP (BUT NOT BOTH) IS A PART
!
BEGIN
LOCAL EGDISPL,ELIM,ECDISPL;
IF .CSYMPTR[IDATTRIBUT(INCOM)] THEN
IF NOT .ECLASS[EQVINCOM]
THEN
BEGIN
ECLASS[EQVINCOM] _ 1;
IF
ECLASS[EQVLIMIT] _ GROUPTOCOMMON(.CSYMPTR,.ECLASS,.ECLASS[EQVLIMIT],.CITEM[EQLDISPL])
LSS 0 THEN RETURN -1
END;
!
!CSYMPTR CONTAINS PTR TO MATCHED SYMBOL IN ECLASS
!EGSYMPTR CONTAINS PTR TO MATCHED SYMBOL IN EGROUP
!
ELIM _ .ECLASS[EQVLIMIT]; !LIMIT OF GROUP
EGDISPL _ .EGITEM[EQLDISPL];
ECDISPL _ .CITEM[EQLDISPL];
EGITEM _ .EGROUP[EQVFIRST];
EGSYMPTR _ .EGITEM[EQLID]; !SET PTR TO FIRST ITEM IN GROUP
%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
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
MAP BASE R1;
R1 _ .CSYMPTR[IDCOMMON];
RETURN FATLERR(R1[COMNAME],.ISN,E33<0,0>)
END;
!ERROR EQUIVALENCE ITEM EXTENDS COMMON BACKWARD
%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
EQERRLIST(.EGROUP);
EGROUP[EQVAVAIL] _ 3;
RETURN -1
END;
!TESTING FOR END OF CHAIN OF GROUP GOING INTO COMMON
IF .EGITEM[EQLLINK] NEQ 0
THEN
BEGIN
EGITEM _ .EGITEM[EQLLINK];
EGSYMPTR _ .EGITEM[EQLID];
END
ELSE
BEGIN
LINKGROUPS(.ECLASS,.EGROUP,.CSYMPTR);
ECLASS[EQVINCOM] _ 1;
!THIS IS A SUCCESSFUL TRIP - RETURN 1!
EGROUP[EQVAVAIL] _ 2;
EGROUP[EQVINCOM]_1;
RETURN 1
END;
END; !OF LOOP%1%
END; !END OF IF INCOMMON
!
!HERE IF NEITHER GROUP NOR CLASS IN COMMON
!LINK ITEMS IN EGROUP INTO ECLASS, MARK EACH GROUP UNAVAILABLE
!CHECK FOR ERRORS OF FORM
! EQUIVALENCE (A(5),B(2)),(C(2),B(2)),(C(2),A(4))
!
EGITEM _ .EGROUP[EQVFIRST];
WHILE 1 DO
BEGIN
LOCAL ENEXITEM,NEWDISPL;
ENEXITEM _ .EGITEM[EQLLINK]; !PTR TO NEXT ITEM IN GROUP TO BE LINKED TO CLASS
EGSYMPTR _ .EGITEM[EQLID];
EGSYM _ .EGSYMPTR[IDSYMBOL];
!NOW SEARCH FOR EGSYM IN ECLASS
CITEM _ .ECLASS[EQVFIRST]; !PTR TO FIRST ITEM IN CLASS
NEWDISPL _ .ECDISPL + .EGITEM[EQLDISPL] -.EGDISPL;
IF WHILE 1 DO
BEGIN %2%
CSYMPTR _ .CITEM[EQLID];
IF .EGSYM EQL .CSYMPTR[IDSYMBOL]
THEN EXITLOOP (-1);
IF .CITEM[EQLLINK] EQL 0
THEN EXITLOOP (0)
ELSE CITEM _ .CITEM[EQLLINK]
END !OF %2%
NEQ 0
THEN !MAKE SURE DISPLACEMENTS OF MATCHING ITMES ARE OK
BEGIN
IF .NEWDISPL NEQ .CITEM[EQLDISPL]
THEN
BEGIN
EQERRLIST(.EGROUP); !INCONSISTENT OR CONFLICTING EQUIVALENCES
EGROUP[EQVAVAIL] _ 3;
RETURN -1
END;
END
ELSE 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 (ALLITEMS IN EGROUP LINKED TO ECLASS)
ELSE EGITEM _ .ENEXITEM;
END; !OF %1%
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;
%1261% LOCAL FLAGWRD;
%1261% BIND CHARSEEN = FLAGWRD<0,1>, ! BLOCK CONTAINS CHARACTER DATA
%1261% NUMSEEN = FLAGWRD<1,1>; ! BLOCK CONTAINS NUMERIC DATA
%
THE ADDRESS OF ANITEM IN ECLASS IS COMPUTED AS FOLLOWS
ADDR _ .LOWLOC + (RELATIVE DISPLACEMENT OF ITEM IN ECLASS (CITEM[EQLDISPL]
- SMALLEST RELATIVE DISPLACEMENT IN ECLASS (ECLASS[EQVADDR])
%
CNT _ 0;
IF .FLGREG<LISTING> THEN( HEADCHK(); STRNGOUT(PLIT '?M?J( ?0'));
%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);
%1261% TLOC _ .LOWLOC * CHARSPERWORD - .ECLASS[EQVADDR];
%1261% FLAGWRD _ 0; ! CLEAR CHARSEEN & NUMSEEN
CITEM _ .ECLASS[EQVFIRST];
WHILE 1 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
%1261% CHARSEEN _ 1; ! REMEMBER CLASS CONTAINS CHAR DATA
%1261% END !NUMERIC
%1261% ELSE
%1261% BEGIN !CHARACTER
%1261% CSYMPTR[IDCHBP] _ CHADDR2BP(.CSYMPTR[IDADDR]); ! CONVERT TO BYTE POINTER
%1261% CSYMPTR[IDADDR] _ 0; ! AND CLEAR IDADDR, DESCRIPTOR ADDRESS
%1261% NUMSEEN _ 1; ! REMEMBER CLASS CONTAINS NUMERIC DATA
%1261% END; !CHARACTER
IF .FLGREG<LISTING>
THEN(LISTSYM(.CSYMPTR);
IF .CNT LSS 5 THEN CNT _ .CNT+1
ELSE (CNT _ 0; CRLF; HEADCHK());
);
IF .CITEM[EQLLINK] EQL 0
THEN( IF .FLGREG<LISTING> THEN STRNGOUT(PLIT')?M?J'); HEADCHK(); EXITLOOP) ELSE CITEM _ .CITEM[EQLLINK];
END;
%1261% IF .CHARSEEN AND .NUMSEEN ! IF CLASS CONTAINS BOTH CHAR & NUMERIC
%1675% THEN WARNERR(UPLIT 'EQUIVALENCE-d?0',.ISN,E168<0,0>);
%1406% LOWLOC _ .LOWLOC + CHWORDLEN(.ECLASS[EQVLIMIT] - .ECLASS[EQVADDR]);
!
!LOWLOC + SPAN OF THE CLASS
!
END; ! of EQCALOC
ROUTINE GRPSCAN=
BEGIN
!
!SCAN ALL GROUPS FOR ITEMS IN COMMON BUT GROUP WAS NOT FLAGGED
!
LOCAL BASE ECLASS :ELIST :EITEM : LAST;
ECLASS _ .EQVPTR<LEFT>;
WHILE 1 DO
BEGIN
LAST _ ELIST _ .ECLASS[EQVFIRST];
IF NOT .ECLASS[EQVINCOM]
THEN
UNTIL .ELIST EQL 0
DO
BEGIN
EITEM _ .ELIST[EQLID];
IF .EITEM[IDATTRIBUT(INCOM)]
THEN
BEGIN
% CHECK FOR MORE THAN ONE COMMON VAR%
IF .ECLASS[EQVINCOM]
THEN ( FATLERR(.ISN,E48<0,0>); EXITLOOP );
ECLASS[EQVINCOM] _ 1;
ECLASS[EQVHEAD] _ .ELIST;
IF .LAST NEQ .ELIST
THEN
BEGIN
%MOVE IT TO TOP OF THE LIST%
LAST[EQLLINK] _ .ELIST[EQLLINK];
ELIST[EQLLINK] _ .ECLASS[EQVFIRST];
!IF THE COMMON ELEMENT WAS THE LAST ONE IN THE GROUP,
! THEN THE PTR TO IT [EQVLAST] MUST BE CHANGED TOO
ECLASS[EQVFIRST] _ .ELIST;
IF .ECLASS[EQVLAST] EQL .ELIST
THEN ECLASS[EQVLAST]_.LAST
END
END;
LAST _ .ELIST;
ELIST _ .ELIST[EQLLINK]
END;
IF (ECLASS _ .ECLASS[EQVLINK]) EQL 0 THEN RETURN .VREG;
END;
END; ! of GRPSCAN
ROUTINE PROCEQUIV=
BEGIN
%PROCESSES EQUIVALNCE GROUPS AS DECLARED IN THE SOURCE -N RESOLVING
IMPLICIT EQUIVALENCES AND EQUIVALENCES INTO COMMON. CHECKS FOR
ALLOCATION ERRORS DUE TO IMPROPER EQUIVALENCES. ASSIGNS TEMPORARY
ADDRESSES TO EQUIVALENCE VARIABLES AND NEW VARIABLES EQUIVALENCED INTO COMMON.
%
LOCAL BASE EQVCPTR, !PTR TO CURRENT EQUIV CLASS HEADER
ECOMMPTR, !PTR COMMON ITEM IF GROUP IS IN COMMON
ECOMMHDR, !PTR TO COMMON BLOCK HDR
LCLHD; !PTR TO LOCAL HEAD OF A GROUP FOR ALLOCATION PURPOSES
REGISTER BASE EQLPTR; !PTR TO EQUIV LIST NODE
LOCAL BASE EQLPT2; !OTHER PTR TO EQUIV LIST NODE
LABEL COMN1,LOOP2;
LOCAL SAVEBOUNDSFLG; !TO SAVE THE VALUE OF THE "BOUNDS" SWITCH WHILE
! PROCESSING EQUIVALENCE STMNTS
SAVEBOUNDSFLG_.FLGREG<BOUNDS>; !SAVE THE VALUE OF THE "BOUNDS" SWITCH
! (THAT SPECIFIES WHETHER ARRAY BOUNDS
! CHECKING IS TO BE PERFORMED)
FLGREG<BOUNDS>_0; !TURN OFF THE BOUNDS FLAG WHILE PROCESSING
! EQUIVALENCE STATEMENTS
%1120% HDRFLG_0; !Remember that no header has been output yet
!
!THE FIRST STEP IS TO COMPUTE RELATIVE DISPLACEMENTS OF EACH ITEM IN
!AND EQUIVALENCE GROUP. THIS IS SIMPLY 1 MINUS THE SUBSCRIPT
!VALUE OF EACH ITEM IN THE GROUP.
!I.E A(1) HAS DISPLACEMENT 0 AND A(4) HAS DISPLACEMENT -3
!
!
!SCAN GROUPS FOR IN COMMON ITEMS
!
GRPSCAN();
!
EQVCPTR _ .EQVPTR<LEFT>; !PTR TO FIRST GROUP
WHILE 1 DO %1%
BEGIN
ISN _ .EQVCPTR[EQVISN]; !SET ISN INCASE OF ERRORS
ECOMMPTR _ 0; !INITIALIZING
!IF GROUP IS IN COMMON THEN FIND THE ELEMENT IN COMMON
COMN1: IF .EQVCPTR[EQVINCOM]
THEN( LOCAL BASE COMPTR;
EQLPTR _ .EQVCPTR[EQVHEAD]; !PTR TO LIST ITEM THAT IS IN COMMON
COMPTR_ .EQLPTR[EQLID];
ECOMMPTR _ .EQLPTR; !PTR TO COMMON ITEM EQL LIST ITEM
ECOMMHDR _ .COMPTR[IDCOMMON];
LCLHD _ .EQLPTR[EQLID];
)
ELSE LCLHD _ 0;
EQLPTR _ .EQVCPTR[EQVFIRST]; !PTR TO FIRST ITEM IN GROUP
R2 _ R1 _ 0; !EQVLIMIT IN R2, SMALLEST DISPLACEMENT IN R1
LOOP2: WHILE 1 DO %2%
BEGIN LOCAL BASE ESYM, EQSIZ;
IF .EQLPTR[EQLINDIC] NEQ 0
THEN (LOCAL BASE PT1:PT2:PT3;
PT1 _ .EQLPTR[EQLID];
IF .PT1[IDDIM] EQL 0 THEN
BEGIN
FLGREG<BOUNDS>_.SAVEBOUNDSFLG;
RETURN FATLERR(.ISN,E93<0,0>);
END;
EQLPTR[EQLINDIC] _ 0;
IF .EQLPTR[EQLLIST]^(-18) NEQ 0
THEN
BEGIN %MULTIPLE SUBSCRIPTS%
! 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
%1261% EQLPTR[EQLDISPL] _ -CNSTEVAL(.PT1[ARG2PTR])
%1261% - EXTSIGN(.PT1[TARGADDR]);
%1261% PT3 _ .EQLPTR[EQLID]; ! GET PTR TO SYMBOL
%1261% IF .PT3[VALTYPE] NEQ CHARACTER ! IF NONCHARACTER,
%1261% THEN EQLPTR[EQLDISPL] _ .EQLPTR[EQLDISPL] * 5; ! CONVERT WORDS
%1261% ! TO CHARS
END
ELSE
BEGIN %SINGLE SUBSCRIPT%
PT1 _ @.EQLPTR[EQLLIST]; !POINTER TO SUBSCRIPT
IF .PT1[OPR1] NEQ CONSTFL OR .PT1[VALTYPE] NEQ INTEGER
THEN RETURN FATLERR(.ISN,E53<0,0>); !NON-CONSTANT SUBSCRIPT
%NOW GENERATE THE OFFSET%
EQLPTR[EQLDISPL] _ -.PT1[CONST2] !CONSTANT VALUE
+( PT3 _ .EQLPTR[EQLID];
PT2 _ .PT3[IDDIM];
PT2 _ .PT2[DIMENL(0)];
.PT2[CONST2] %OFFSET%
);
IF .EQLPTR[EQLDISPL] LEQ -(1^18)
OR .EQLPTR[EQLDISPL] GEQ 1^18
THEN RETURN FATLERR(.ISN, E103<0,0>); !OUT OF RANGE
%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;
END
);
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
%1262% 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 (R1 _ .EQLPTR[EQLDISPL]; LCLHD _ .EQLPTR[EQLID]);
IF .ECOMMPTR NEQ 0
THEN IF .EQLPTR NEQ .ECOMMPTR
THEN( LOCAL BASE LINK:COM;
MAP BASE ECOMMHDR :ECOMMPTR;
LINK _ .EQLPTR[EQLID];
COM _ .ECOMMPTR[EQLID]; !PTR TO ITEM IN CO MMON
IF NOT .LINK[IDATTRIBUT(INCOM)]
THEN(
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],
%1531% .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 ( FATLERR(ECOMMHDR[COMNAME],.ISN,E33<0,0>);
LEAVE LOOP2;
);
IF .ECOMMHDR[COMSIZE] LSS (.LINK[IDADDR] + .EQSIZ)
THEN ECOMMHDR[COMSIZE] _(.LINK[IDADDR] + .EQSIZ);
)
ELSE IF (.COM[IDADDR]-.ECOMMPTR[EQLDISPL]) NEQ (.LINK[IDADDR]-.EQLPTR[EQLDISPL])
!IF BOTH THE GROUP AND THE ELEMENT ARE IN
! COMMON, MAKE SURE IT IS THE SAME COMMON
! BLOCK! OTHERWISE AN ERROR FOR SURE.
OR (.COM[IDCOMMON] NEQ .LINK[IDCOMMON])
THEN (EQERRLIST(.EQVCPTR); EQVCPTR[EQVAVAIL] _ 3;LEAVE LOOP2);
!
!CHECKING THE DECLARATIONS FOR VIOLATING BEGINNING OF COMMON BLOCK
!
);
!
!CHECKING FOR END OF CHAIN OF ITEMS
!
IF .EQLPTR[EQLLINK] EQL 0
THEN EXITLOOP !END OF CHAIN
ELSE EQLPTR _ .EQLPTR[EQLLINK]
END; !OF WHILE %2%
!
EQVCPTR[EQVADDR] _ .R1; !LOWEST RELATIVE DISPLACEMENT
! EQVCPTR[EQVHEAD] _ .LCLHD; !PTR TO HED OF GROUP
EQVCPTR[EQVLIMIT] _ .R2; !SPAN OF GROUP RELATIVE TO 0
!
!REAL SPAN (#OF WORDS OCCUPIED BY ALL ELEMNTS OF GROUP)
!IS EQVLIMIT - EQVADDR
!
%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
%1450% EQVCPTR[EQVAVAIL] _ 3; ! mark group to prevent
%1450% ! further processing
%1450% END;
%1450% EQLPT2 _ .EQLPT2[EQLLINK];
%1450% END;
%1450% EQLPTR _ .EQLPTR[EQLLINK];
%1450% END;
IF .EQVCPTR[EQVLINK] EQL 0
THEN EXITLOOP !END OF CHAIN OF GROUPS
ELSE EQVCPTR _ .EQVCPTR[EQVLINK]
END; !OF %1%
!
!NOW START TO MAKE EQUIVALENCE CLASSES BY COMBINING GROUPS IF POSSIBLE
!
EQVCPTR _ .EQVPTR<LEFT>; !START WITH FIRST GROUP
WHILE 1 DO %1%
BEGIN
WHILE 1 DO %2% !GROUP(I) BECOMING A CLASS
BEGIN
IF .EQVCPTR[EQVAVAIL] EQL 0 !GROUP AVAILABLE FOR CLASS
THEN ( MACRO EQGPPTR = EQLPTR$;
ISN _ .EQVCPTR[EQVISN]; !SET ISN INCASE OF ERRORS
EQVCPTR[EQVAVAIL] _ 2; !MAKE GROUP A CLASS
EQGPPTR _ .EQVCPTR; !BEGIN SRCH OF OTHER GROUPS ON CURRENT GROUP
DO
BEGIN
IF .EQGPPTR[EQVAVAIL] EQL 0
THEN (
IF (ELISTSRCH(.EQVCPTR,.EQGPPTR)) GTR 0
THEN ( EQGPPTR[EQVAVAIL] _ 2;
EQGPPTR _ .EQVCPTR ); !SEE IF ANY OF THE REJECTS FIT NOW
!
!IF ERROR OCCURRED IN ELSTSRCH THEN EQGPPTR[EQVAVAIL]
!WILL BE SET TO 3 (ERROR)
!
);
END
WHILE (EQGPPTR _ .EQGPPTR[EQVLINK]) NEQ 0;
IF NOT .EQVCPTR[EQVINCOM]
THEN IF .EQVCPTR[EQVAVAIL] NEQ 3
%[735]% THEN ( IF .HDRFLG EQL 0 THEN LSTHDR(4,2,PLIT'?M?JEQUIVALENCED VARIABLES?M?J?0');
%[735]% EQCALLOC(.EQVCPTR); !ALLOCATE CLASS POINTED TO BY EQVCPTR
%[735]% HDRFLG_1);
); !END OF IF AVAIL TEST
IF .EQVCPTR[EQVLINK] EQL 0
THEN EXITLOOP !NO MORE GROUPS TO PROCESS INTO CLASS
ELSE EQVCPTR _ .EQVCPTR[EQVLINK]; !NEXT GROUP TO BE A CLASS
END; !OF LOOP %2%
IF (EQVCPTR _ .EQVCPTR[EQVLINK]) EQL 0 THEN (FLGREG<BOUNDS>_.SAVEBOUNDSFLG; RETURN);
!
!ALL GROUPS PROCESSED IF RETURN TAKEN
!
END; ! OF LOOP %1%
FLGREG<BOUNDS>_.SAVEBOUNDSFLG; !RESTORE THE "BOUNDS" SWITCH
END; ! of 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;
! 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
%1526% ZCODE(PSDATA,PSCODE); ! Output byte pointer to hiseg, relocating right half to lowseg
HILOC _ .HILOC + 1;
RDATWD _ .CPTR[LITLEN]; ! Length of character constant
%1526% ZCODE(PSABS,PSCODE); ! Output length to hiseg without relocation
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
%1526% ZCODE(PSABS,PSCODE); ! output the byte pointer, no relocation
%1261% R2 _ .PTR[IDCOMMON]; ! get pointer to common block
%1512% ZSYMBOL(GLB18ADDFIX,.R2[COMNAME],.HILOC,PSCODE) ! Fixup is for descriptor at HILOC
%1261% END ! COMMON
%1526% ELSE ZCODE(.PTR[IDPSCHARS],PSCODE); ! Output BP to high seg with RH relocation
%1434% END
%1434% ELSE
%1434% BEGIN ! function is declared external
%1434% RDATWD = 1^35; ! IFIW bit
%1526% ZCODE(PSABS,PSCODE);
%1512% ZSYMBOL(GLB18CHNFIX,.PTR[IDSYMBOL],.HILOC,PSCODE) ! Fixup descriptor at HILOC
%1434% END;
HILOC _ .HILOC + 1;
RDATWD _ .PTR[IDCHLEN]; ! Length of character scalar or array
%1526% ZCODE(PSABS,PSCODE); ! Output length to high
! seg with no relocation
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
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
%1526% ZCODE(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
%1512% ZSYMBOL(GLB18ADDFIX,.R2[COMNAME],.HILOC,PSCODE)
%1451% END
%1526% ELSE ZCODE(.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>
%1526% THEN ZCODE(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
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
! Output the start address of character data as addr(charpos)
REGISTER BASE BP;
MAP
BASE R2,
BASE OBP;
! Convert #010700,,FOO-1 TO #440700,,FOO
IF .OBP<LEFT> EQL #010700
THEN BP = #440700 ^ 18 + .OBP<RIGHT> + 1
ELSE BP = .OBP;
R2<LEFT> _ .BP<RIGHT>; ! Get the address of data
ZOUTOCT(); ! Output it
CHAROUT("("); ! Output a (
R1 _ .BP<30,6>; ! Get P field of byte pointer
R1 _ (43 - .R1) / 7; ! Compute charpos 1-5
ZOUDECIMAL(); ! Output it
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
! Output "*" if not explicitly defined
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);
IF .BP<RIGHT> LSS #10000
THEN TABOUT(); ! Output an extra TAB
END; ! Output character constant data address
%1434% END
%1434% ELSE
BEGIN ! Output character constant data address
ZOUTBP(.BP);
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
%1274% REGISTER LEN,BASE SYMPTR;
! Now (for either subprogram or main program, allocate and list
! the temps generated by local register allocation
%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;
IF .TCNT GTR 5
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
%1525% ! 24- PSECT HEADER
%1526% ! 22- PSECT INDEX
! 6 - NAME
!********************************************************
REGISTER
%1434% BASE ENT;
LOCAL
MYRELBUF[5]; ! Holds various REL block types
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
%1525% DATAORG = #1300000,
%1525% CODEORG = #1000140,
%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;
![1525] Define the psect names, attributes, indices and origins. Load
![1525] a private psected FORLIB for good measure during extended
![1525] addressing development. And set a default psect index so that
![1525] LINK doesn't mistake us for lowly TWOSEGged code.
%1525% IF EXTENDED
THEN
BEGIN
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,
! the following three paragraps should be changed.
MYRELBUF[0] = RPSECTHEAD^18 OR 3; ! Type and count
MYRELBUF[1] = 0; ! No relocation
MYRELBUF[2] = SIXBIT '.CODE.'; ! Psect name
MYRELBUF[3] = RPSSINGLE OR RPSNONZERO OR RPSCONCAT OR RPSRONLY
OR PXCODE; ! Psect attributes and index
MYRELBUF[4] = CODEORG; ! Psect origin
DMPRLBLOCK(MYRELBUF,5);
MYRELBUF[2] = SIXBIT '.DATA.';
MYRELBUF[3] = RPSSINGLE OR RPSNONZERO OR RPSCONCAT OR RPSWRITE
OR PXDATA;
MYRELBUF[4] = DATAORG;
DMPRLBLOCK(MYRELBUF,5);
MYRELBUF[2] = SIXBIT '.LARG.';
MYRELBUF[3] = RPSNONZERO OR RPSCONCAT OR RPSWRITE OR PXLARGE;
MYRELBUF[4] = LARGEORG;
DMPRLBLOCK(MYRELBUF,5);
! Before we get a chance to output a type 6 name block
! later on and declare our Fortranness to LINK, this
! is the opportunity to set a default psect index.
! The only reason for setting a default index here is
! that if LINK sees a Fortran REL file that has
! selected a default psect index, it will not try to
! force high segment code into the low segment. This
! is helpful, since we don't have a low segment.
RDATWD = PXCODE; ! Select the code psect
ZOUTBLOCK(RPSECTORG,RELN) ! as the default
%1525% 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
END; ! of RELINIT
END
ELUDOM