Trailing-Edge
-
PDP-10 Archives
-
bb-4157h-bm_fortran20_v10_16mt9
-
fortran-compiler/pha3.bli
There are 12 other files named pha3.bli in the archive. Click here to see a list.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 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: S MURPHY/SJW/EGM/CDM/AHM
MODULE PHA3(SREG=#17,VREG=#15,FREG=#16,DREGS=4,RESERVE(0,1,2,3),START) =
BEGIN
! REQUIRES FIRST, TABLES, REQREL
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE 'REQREL.BLI'; ![2325] REL block definitions
SWITCHES LIST;
GLOBAL BIND PHA3V = #10^24 + 0^18 + #2464; ! Version Date: 9-Oct-84
%(
***** Begin Revision History *****
46 ----- ----- CHANGE REFERENCES TO PROGNAME
47 ----- ----- OUTPUT THE MACRO LISTING HEADING IN PHA3 SO
THAT THE SIXBIT FUNCTION NAME WILL FOLLOW IT
48 ----- ----- IF THE "DBGTRAC" FLAG IS SET, CALL
INIFDDT TO OUTPUT
"XCT FDDT."
49 ----- ----- FIX ARGUMENT BLOCKS HEADING TO ONLY BE OUTPUT
IF MACROCODE IS REQUESTED
50 464 QA754 HANDLE HEADINGS FOR LINE-NUMBER/OCTAL-LOCATION
MAP IF NO MACRO LISTING REQUESTED, (SJW)
51 476 QA754 MAKE LINE/OCTAL MAP HEADING OPTIONAL UNDER
/MAP=MAPFLG, (SJW)
***** Begin Version 5A *****
52 607 22685 GENERATE ZERO-ARG-BLOCK ONLY IF NEEDED (IE, IF
NEDZER SET)
****** Begin version 6 ******
53 1047 EGM 22-Jan-81 Q10-05325
Add support for TOPS-10 execute only.
****** Begin version 7 ******
1511 CDM 17-Mar-82
Add hooks for SAVE statement processing. Call to ZSAVEOUT must
be un-commented.
1521 CDM 26-Mar-82
Add hooks for argument checking processing. ARGCHK=TRUE sets
arg checking on.
1531 CDM 4-May-82
SAVE statement code review.
1566 CDM 24-Jun-82
Enable writable overlay block (1045 for SAVE) output.
1572 AHM 29-Jun-82
Move check for ?Program too large from ZENDALL to MRP3 so that
the check is performed even if object code isn't generated.
1576 AHM 7-Jul-82
Make the compiler emit a JRST to the start address of programs
under /EXTENDED and have ZENDALL make that the entry vector.
1614 CDM 16-Aug-82
Moved call to ZARGCHECK from here to ZENDALL so that rel blocks
would be output after the symbol table was dumped.
1624 AHM 28-Aug-82
Don't call ZSAVEOUT in MRP3 if /EXTEND was specified, since we
don't support overlays for extended addressing and variables
are always preserved when not using overlays.
Module:
PHA3
***** Begin Version 10 *****
2210 AHM 27-Jul-83
Rename DUMPDIM to DMPDIM to reserve DUMP?? for SIX12.
2325 AHM 16-Mar-84
Create a new routine named DMPEFIW to dump the EFIW table to
the object file. It will output the EFIWs themselves,
additive fixups for their references to externals, and local
fixups to resolve references to the EFIWs from instructions
and arg blocks. Call DMPEFIW near the end of MRP3,
before the call to ZENDALL.
2334 AHM 5-Apr-84
Place the entry vector generated under /EXTEND in the lowseg.
Generate JRST MAIN. in the first location by hand with ZCODE.
2346 AHM 23-Apr-84
Make MRP3 in PHA3 use the new globals SCOMSZ and LCOMSZ when
computing the sizes of the psects in the test for the "?FTNPTL
Program too large" diagnostic.
2355 AHM 3-May-84
Put a JRST @[REENT.##] in the second word of the entry vector
that is generated under /EXTEND. Also, replace magic numbers
with symbols for all entry vector offsets.
2433 CDM 23-Jul-84
Use VMSIZE for the size of virtual memory in the decision
whether to declare the "Program too large". Should have been
done in edit 2322.
Also delete use of ARGCHK, used for disabling argument checking
in V7 field test. No reason to continue this!
2464 AHM 9-Oct-84
Teach DMPEFIW that if EFFIXEDUP is zero, EFEXTERN contains the
internal psect index to relocate EFY by.
***** End V10 Development *****
***** End Revision History *****
)%
FORWARD
MRP3,
%2325% DMPEFIW; ! Dump out the contents of the EFIW table
EXTERNAL
CGARGS,
CGASMNT,
CGIOARGS, !ROUTINES TO GENERATE ARG BLOCKS FOR
CGOPGEN,
CGSTMNT,
CGSTPAUARGS, ! IO STMNTS AND STOP/PAUSE STMNTS
CSTMNT, ! Current statement
DEFLAB,
%2210% DMPDIM, !ROUTINE TO OUTPUT ALL DIMENSION INFORMATION
! FOR ALL PROTECTED ARRAYS (FOR ALL ARRAYS
! WHEN THE USER SPECIFIES THE "DEBUG" SWITCH)
%2334% DMPMAINRLBF, ! Dumps the main REL buffer
DOSP,
DOSTAK,
%1572% E142, ! Error message - ? Program too large
%2325% EFIWTBL, ! Hash table of EFIWs
%2334% ENTADDR, ! Address of entry vector
%1572% FATLER, ! Prints error messages
GENLAB,
HILOC, ! Next free location in .CODE.
INIFDDT, !TO GENERATE "XCT FDDT."
INIISNRLBLK, !TO INIT BUFFER USED FOR
! THE LABELS INSERTED WHEN THE "DEBUG" SWITCH
! IS SPECIFIED BY THE USER
ISN, !INTERNAL SEQ NUMBER OF STMNT
%1572% LARGELOC, ! Next free location in .LARG.
%2346% LCOMSZ, ! Sum of the sizes of all large COMMON blocks in words
LSTFORMATS, !TO LIST FORMAT STMNTS IN THE MACRO-EXPANDED
! LISTING
%1572% LOWLOC, ! Next free location in .DATA.
NAMGEN, !TO GENERATE NAMELIST ENTRIES
NEDZER, ! FLAG TO INDICATE IF ZERO-ARG-BLOCK NEEDED
OBUFF,
OBUFFA,
OPDSPIX,
OPGRES,
OUTMDA,
OUTMOD,
PBFPTR,
PBOPWD,
PBUFF,
PHAZCONTROL,
PSYMPTR,
%2325% RDATWD, ! Holds word destined for the REL file
%1511% SAVNED, ! SAVE statement is needed
%2346% SCOMSZ, ! Sum of the sizes of all small COMMON blocks in words
SEGINCORE,
%2433% VMSIZE, ! Size of Virtual Memory
%2325% Z30CODE, ! Outputs a word in a type 1030 REL block
%2334% ZCODE, ! Outputs a word in a type 1010 REL block
%1521% ZCOERCION, ! Puts out coercion blocks
ZENDALL,
ZERBLK,
%2325% ZOUTBLOCK, ! Outputs arbitrary REL blocks
ZOUTMSG,
%1511% ZSAVEOUT, ! Processing for SAVE statement
%1521% ZSFARGCHECK, ! Arg checking blocks for defn of subprograms
%2325% ZSYMBOL; ! Outputs a type 2 or 1070 REL block
%[1047]% PORTAL ROUTINE MRP3 =
BEGIN
%(***OVERLAY TO DO CODE GENERATION****)%
MAP PPEEPFRAME PBFPTR;
MAP BASE CSTMNT;
MAP PEEPFRAME PBUFF;
LOCAL
%2334% SAVELOWLOC, ! Holds LOWLOC while ZCODE writes entry vector
STADDR; !PROGRAM STARTING ADDRESS
! If user specified the "DEBUG" switch init buffer used for
! labels inserted on each line.
IF .FLGREG<DBGLABL> THEN INIISNRLBLK();
! If the user specified the "TRACE" option of the DEBUG switch,
! init for generation of "XCT FDDT."
IF .FLGREG<DBGTRAC> THEN INIFDDT();
%(***INIT PTR TO DO-INFORMATION AREA***)%
DOSP_DOSTAK;
%(***DEFINE A LABEL TO CORRESPOND TO A ZERO-ARG-BLOCK FOR FOROTS - THIS
ARGBLOCK WILL BE USED FOR A NUMBER OF STMNTS***)%
NEDZER _ 0; ! INITIALIZE TO "ZERO-ARG-BLOCK NOT NEEDED"
ZERBLK_GENLAB();
IF .FLGREG<LISTING>
THEN
BEGIN
EXTERNAL HEADING, PAGELINE, STRNGOUT;
IF .FLGREG<MACROCODE>
THEN
BEGIN
IF (PAGELINE _ .PAGELINE - 4) LEQ 0
THEN
BEGIN
HEADING ();
PAGELINE _ .PAGELINE - 4;
END;
STRNGOUT(PLIT ASCIZ '?M?J?M?JLINE LOC LABEL GENERATED CODE?M?J');
END
ELSE
IF .FLGREG<MAPFLG>
THEN
BEGIN
IF (PAGELINE _ .PAGELINE - 7) LEQ 0
THEN
BEGIN
HEADING ();
PAGELINE _ .PAGELINE - 7;
END;
STRNGOUT (PLIT ASCIZ '?M?J?M?JLINE NUMBER/OCTAL LOCATION MAP');
STRNGOUT (PLIT ASCIZ '?M?J?M?J : 0?I1?I2?I3?I4?I5?I6?I7?I8?I9?M?J');
STRNGOUT (PLIT ASCIZ '------:-------------------------------------------------------------------------------');
STRNGOUT (PLIT ASCIZ '?M?J :?M?J00000 : ');
END;
END;
CSTMNT_.SORCPTR<LEFT>;
%(***SKIP 1ST STMNT OF PROGRAM - WHICH IS A DUMMY CONTINUE***)%
IF .CSTMNT NEQ 0
THEN
CSTMNT_.CSTMNT[SRCLINK];
PBFPTR_PBUFF; !INIT PTR TO NEXT AVAILABLE PEEPHOLER ENTRY
PBFPTR[PBFISN]_NOISN; !INIT INTERNAL SEQ NO FIELD FOR 1ST INSTR
%(****STARTING ADDRESS OF PROGRAM***)%
STADDR _ .HILOC;
%1521% ! Output coercion block for argument type checking blocks.
%1521% IF .FLGREG<OBJECT> THEN
%1521% IF .FLGREG<PROGTYP> NEQ BKPROG ! Not block data program
%1521% THEN ZCOERCION();
%(***GENERATE A CALL TO RESET. AT THE BEGINNING OF THE PROGRAM***)%
%(***FOR THE MAIN PROGRAM ONLY***)%
IF .FLGREG<PROGTYP> EQL MAPROG THEN
BEGIN
OPDSPIX_OPGRES;
CGOPGEN();
END;
%(***GENERATE CODE FOR ALL STMNTS OF THE PROGRAM****)%
WHILE .CSTMNT NEQ 0
DO
BEGIN
ISN_.CSTMNT[SRCISN];
CGSTMNT();
CSTMNT_.CSTMNT[SRCLINK];
END;
%(***OUTPUT ANY INSTRUCTIONS STILL REMAINING IN THE PEEPHOLE BUFFER AND SET THE
PTR TO NEXT AVAILABLE WD OF PEEPHOLE BUFFER BACK TO THE START OF BUFFER***)%
IF .PBFPTR NEQ PBUFF
THEN
BEGIN
OUTMOD(PBUFF, (.PBFPTR-PBUFF)/PBFENTSIZE );
PBUFF[PBFLABEL]_NOLABEL; !INIT LABEL FIELD OF 1ST INSTR
PBFPTR_PBUFF;
END;
%1521% ! If a subroutine or function, output the arg check blocks for the
%1521% ! definition of the subprogram
%1521% IF .FLGREG<OBJECT> THEN
%1521% IF .FLGREG<PROGTYP> EQL SUPROG OR .FLGREG<PROGTYP> EQL FNPROG
%1521% THEN ZSFARGCHECK();
%(***OUTPUT HEADINGS FOR ARG-BLOCKS***)%
IF .FLGREG<LISTING> THEN
IF .FLGREG<MACROCODE>
THEN
BEGIN
EXTERNAL HEADING,PAGELINE,STRNGOUT;
IF ( PAGELINE_.PAGELINE-4) LEQ 0
THEN ( HEADING(); PAGELINE_.PAGELINE-4);
%1521% STRNGOUT(PLIT ASCIZ '?M?J?M?JARGUMENT BLOCKS:?M?J?M?J')
END;
%(***OUTPUT A "ZERO-ARG-BLOCK" TO BE USED FOR EVERY FN AND SUBR CALL THAT
HAS NO ARGS (ALSO USED BY STOP PAUSE AND END WHEN THERE IS NO ARG).
BLOCK WILL BE 2 WDS OF 0. THE LABEL "ZERBLK" ON THE 2ND WD.
******)%
IF .NEDZER NEQ 0 ! IS ZERO-ARG-BLOCK NEEDED ?
THEN
BEGIN
PSYMPTR_PBF2NOSYM;
PBOPWD_0;
OBUFFA();
DEFLAB(.ZERBLK);
PSYMPTR_PBF2NOSYM;
PBOPWD_0;
OBUFFA();
END; ! OF IF .NEDZER NEQ 0 THEN BEGIN
%(*** Output the argument blocks for any call statements
or function references ***)%
CGARGS();
%(***WALK THRU ALL IO STMNTS OUTPUTTING ALL ARGLISTS FOR THEM***)%
CSTMNT_.IOFIRST; !PTR TO 1ST IO STMNT
WHILE .CSTMNT NEQ 0
DO
BEGIN
ISN_.CSTMNT[SRCISN];
IF .CSTMNT[SRCID] EQL STOPID OR .CSTMNT[SRCID] EQL PAUSID
THEN CGSTPAUARGS() !TO GENERATE ARG-BLOCK
! FOR STOP OR PAUSE
ELSE CGIOARGS(); !TO GENERATE ARG-BLOCK
! FOR AN IO STMNT
CSTMNT_.CSTMNT[IOLINK];
END;
%(****GENERATE NAMELISTS IF ANY EXIST****)%
NAMGEN();
%(***OUTPUT DIMENSION INFORMATION FOR ALL PROTECTED ARRAYS***)%
%2210% DMPDIM();
%(***OUTPUT ANY INSTRUCTIONS STILL REMAINING IN THE PEEPHOLE BUFFER***)%
IF .PBFPTR NEQ PBUFF
THEN OUTMDA(PBUFF,(.PBFPTR-PBUFF)/PBFENTSIZE);
%1511% ! Output anything required for the SAVE statement
%1531% IF .SAVNED ! Any SAVE-ing needed?
%1531% AND .FLGREG<OBJECT> ! Yes, producing a .REL file?
%1624% AND NOT EXTENDED ! Yes, hacking extended addressing?
%1511% THEN ZSAVEOUT(); ! No, program could get overlayed
%(**If user requested a macro-expanded listing, list the format
statements***)%
IF .FLGREG<LISTING> AND .FLGREG<MACROCODE> THEN LSTFORMATS();
IF .FLGREG<OBJECT>
THEN
%2325% BEGIN ! OBJECT
%2325% IF EXTENDED ! /EXTEND?
%2334% THEN
%2334% BEGIN ! EXTEND
%2325% DMPEFIW(); ! Dump EFIW table to the REL file
%2334% IF .FLGREG<PROGTYP> EQL MAPROG ! Main program?
%2334% THEN ! Yes, output entry vector
%2334% BEGIN ! MAPROG
%2334% DMPMAINRLBF(); ! Empty out the main REL buffer
! so that ZCODE outputs code
! to right address
%2334% SAVELOWLOC = .LOWLOC; ! Save the .DATA.
! relocation counter
%2355% LOWLOC = .ENTADDR+STARTOFF; ! Start word
%2334% RDATWD = JRSTOC OR .STADDR; ! JRST MAIN.
%2334% ZCODE(PSCODE, PSDATA); ! Output JRST
%2355% LOWLOC = .ENTADDR+REENTOFF; ! Reenter word
%2355% RDATWD = JRSTOC OR INDBIT
%2355% OR .ENTADDR+REEINDOFF; ! Output JRST @
%2355% ZCODE(PSDATA, PSDATA);
%2355% LOWLOC = .ENTADDR+VERSIONOFF; ! Version word
%2355% RDATWD = 0; ! Make it zero for fun
%2355% ZCODE(PSABS, PSDATA); ! Output it
%2355% LOWLOC = .ENTADDR+REEINDOFF; ! Reentry EFIW
%2355% RDATWD = 0; ! Zero it for fixup
%2355% ZCODE(PSABS, PSDATA); ! Output it
%2355% ZSYMBOL(GLB30ADDFIX, ! Make EXTERNAL request
%2355% SIXBIT 'REENT.',
%2355% .ENTADDR+REEINDOFF,
%2355% PSDATA);
%2334% LOWLOC = .SAVELOWLOC; ! Restore LOWLOC
%2334% END; ! MAPROG
%2334% END; ! EXTEND
! To terminate the REL file
%2334% ZENDALL(.STADDR); ! Pass object address of start address
%2325% END; ! OBJECT
! Check for section overflows if program too large
%2346% IF (.HILOC + .LOWLOC + .SCOMSZ) GEQ 1^18 ! Code
%2433% OR (.LARGELOC + .LCOMSZ) GEQ .VMSIZE ! Data
THEN FATLER(.ISN,E142<0,0>)
END; !END OF MRP3
ROUTINE DMPEFIW =
!++
! FUNCTIONAL DESCRIPTION:
!
! Output the contents of the EFIW table to the REL file and emit
! local fixups for the EFIW references. Emit additive fixups
! for EFIWs that reference common blocks or routine names.
!
! First, define a local symbol named "..EFIW" at the beginning
! of the region of .CODE. which will contain the EFIWs.
!
! Then loop over all entries in the EFIW table, following the
! CLINK list and outputting each entry as a data word in a type
! 1030 (R30CODE) 30 bit relocation data REL block. If an entry
! has a non-zero EFFIXEDUP field, output a 30 bit additive fixup
! with a type 1070 (RLONGSYMBOL) block to add the external's
! value to the EFIW's Y field, otherwise perform 30 bit
! relocation by the internal psect index in EFEXTERN. When each
! entry is output, also output a type 10 (RLOCAL) local fixup
! REL block, in order to fixup references to the EFIW in the
! previously generated code.
!
! After each data word is output by calling Z30CODE, HILOC will
! be updated in order to allocate space in the .CODE. psect.
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! EFIWTBL The hash table of EFIWs to be output to the REL file.
!
! HILOC Relocation counter for .CODE.
!
! IMPLICIT OUTPUTS:
!
! HILOC .CODE. relocation counter, updated to reflect
! the EFIWs which have been output.
!
! RDATWD Destroyed.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! Outputs RLOCAL, RPSECTORG, R30CODE and RLONGSYMBOL REL blocks
! to the REL file.
!
!--
![2325] New
BEGIN
REGISTER
BASE EFIW, ! Points to current EFIW
BASE STE; ! Points to EFIW's STE
! Define local symbol ..EFIW at start of dumped EFIWs
ZSYMBOL(LOCDEF, SIXBIT '..EFIW', .HILOC, PSCODE);
! Now start dumping the EFIW table out to the REL file
DECR I FROM EFSIZ-1 TO 0 ! Loop over all the buckets
DO ! in the EFIW table
BEGIN ! EFIW BUCKET
EFIW = .EFIWTBL[.I]; ! See what is in the bucket
WHILE .EFIW NEQ 0 ! Loop over all entries in the bucket
DO
BEGIN ! EFIW ENTRY
! First get the EFIW word itself and output it
! to the .CODE. psect.
RDATWD = .EFIW[EFADDR];
%2464% IF .EFIW[EFFIXEDUP] NEQ 0 ! Is a fixup needed?
THEN ! Yes
BEGIN ! FIXUP
! The Y field of the EFIW is the
! subject of a fixup because of a
! reference to COMMON or an external
! routine, don't relocate it.
Z30CODE(PSABS, PSCODE);
! Output a a global additive fixup to
! add the external's value to the
! EFIW's Y field.
ZSYMBOL(GLB30ADDFIX, .EFIW[EFEXTERN],
.HILOC, PSCODE);
END ! FIXUP
%2464% ELSE Z30CODE(.EFIW[EFEXTERN], PSCODE); ! Non-FIXUP
! Output the local fixup which backpatches all
! the references to the EFIW. Format is "head
! of chain,,value to substitute"
RDATWD = .EFIW[TARGADDR]^18+.HILOC;
ZOUTBLOCK(RLOCAL, RELB); ! Relocate both halves
HILOC = .HILOC+1; ! Allocate space for EFIW
EFIW = .EFIW[CLINK]; ! Get the next entry
END; ! EFIW ENTRY
END; ! EFIW BUCKET
END; ! of DMPEFIW
MACHOP POPJ=#263;
MRP3();
POPJ(#17,0)