Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_Alpha_31-jul-86
-
listou.bli
There are 26 other files named listou.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1973, 1986
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
!AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!AUTHOR F.INFANTE/DCE/SJW/JNG/TFV/CKS/RVM/AHM/CDM/AlB/PLB/MEM
MODULE LISOUT(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND LISTOV = #11^24 + 0^18 + #4535; ! Version Date: 13-May-86
%(
***** Begin Revision History *****
39 ----- ------ GENERATE SYMBOL TABLE ENTRIES FOR FORMAT STMNTS,
USE THE SYMBOL "STMNT-NUMBER F"
40 ----- ----- FIX BUG IN EDIT 39
41 ----- ----- ADD ROUTINE "LSTFORMATS" TO LIST ALL FORMAT STMNTS
AT THE END OF A MACRO-EXPANDED LISTING
42 ----- ----- FIX BUG IN LSTFORMATS TO LIST RELATIVE ADDRS
CORRECTLY
43 ----- ----- CHANGE "OUTMDA" SO THAT WHEN PSYMPTR IS THE CODE
"PBFFORMAT" WE EXPECT THE RIGHT HALF OF THE INSTR
IN THE PEEPHOLE BUFFER TO CONTAIN A PTR TO THE
FORMAT STMNT (RATHER THAN THE REL ADDR OF THE FORMAT STRING)
44 ----- ----- TAKE OUT DEFINITIONS OF LOADER BLOCK TYPES - PUT
THEM INTO A SEPARATE "REQUIRE" FILE.
ALSO REMOVE THE ROUTINES "ZOUTBLOCK" AND
"ZDMPBLK". ZOUTBLOCK HAS BEEN MOVED TO THE MODULE
RELBUF. ZDMPBLK IS NO LONGER NEEDED.
ALSO, EDIT "ZENDALL" TO OUTPUT ANY CODE
LEFT IN THE BUFFERS SYMRLBF,LOCRLBF, AND MAINRLBF.
ALSO REMOVE THE ROUTINE "DATAOUT", MAKE OUTDATA CALL
ZOUTBLOCK INSTEAD.
ALSO REMOVE THE ROUTINE DMPRELONLST.
ALSO REMOVE ALL REFERENCES TO "RELOCPTR" AND "RELBLOCK"
AND DELETE THEIR DEFINITIONS.
45 ----- ----- REMOVE THE ROUTINES: ZOUTMSG,ZOUTSYM,ZOUTOCT,RADIX50,
ZOUDECIMAL,ZOUOFFSET.
THESE HAVE BEEN PUT INTO THE MODULE "RELBUFF"
46 ----- ----- REMOVE THE ROUTINE LSTRLWD WHICH HAS BEEN
PUT INTO THE MODULE RELBUF
47 ----- ----- TAKE OUT DEF OF THE MACRO "CRLF" - IT IS NOW
IN THE REQUIRE FILE "REQREL"
48 ----- ----- REMOVE THE ROUTINE OUTDATA - ITS NOT NEEDED IN
FORTG
49 ----- ----- IN ZENDALL - MUST CALL DMPMAINRLBF (TO DUMP
ANY CODE IN THE BUFFER) BEFORE DUMPING
THE CONTENTS OF THE FIXUP BUFFERS
50 ----- ----- IN LSTINST MOVE THE OUTPUT OF THE MACRO
LISTING HEADING TO PHA3 SO THAT THE SIXBIT FUNCTION
NAME WILL COME OUT AFTER THE HEADING
IN OUTMDA - CHANGE IT SO THAT IT PUTS OUT
A CRLF AT THE BEGINNING OF EACH LINE INSTEAD OF
AT THE END. THIS WILL MATCH THE WAY LSTINST DOES
IT AND STRAIGHTEN OUT THE LISTING
PUT PAGEHEADING CHECKS IN BOTH OF THE ABOVE ROUTINES
51 ----- ----- PUT OUT F LABELS AT THE END OF FORMAT STRINGS IF
THE FLAG "DBGLABL" IS SET; OUTPUT L LABELS FOR
THE LINES IF THE FLAG "DBGLABL" IS SET. HAVE P
LABELS AT START OF FORMAT STMNTS.
52 ----- ----- PUT OUT THE SYMBOL '.VEND' AFTER THE END
OF THE SCALARS AND ARRAYS
53 ----- ------ DO NOT PUT OUT THE EXIT UUO (HAVE CALL TO FOROTS
EXIT.)
54 15349 247 CHANGE ALL REFERENCES TO FORMAT LABELS TO XXXXP, (JNT)
55 QAR 317 FIX 247 TO STILL PUT XXF ON END, FIX SYMBOL TABLE, (JNT)
56 18015 356 PUT OUT GLOBAL MAIN. FOR MAIN PROG, (DCE)
57 19477 461 CHECK SIZES OF HIGH AND LOW SEGMENTS FOR OVERFLOW, (DCE)
58 QA754 464 ADD LINE/OCTAL MAP OUTPUT IF NO MACRO LISTING, (SJW)
59 QA754 476 MAKE LINE/OCTAL MAP OPTIONAL UNDER /MAP=MAPFLG, (SJW)
***** Begin Version 5A *****
60 22281 555 FIX MAP WITH ENTRY POINTS, (DCE)
61 23760 614 OUTPUT ONLY NON-BLANK LINES IN /LNMAP, (SJW)
***** Begin Version 5B *****
62 23066 636 DON'T DUMP LABELS TO THE REL FILE THAT WE DON'T
KNOW THE VALUE OF. ALSO SET SNDEFINED WHEN
WE FILL IN THE SNADDR FIELD., (JNG)
63 25249 645 ENTRY POINTS CAUSE LINE COUNT TO BE OFF BY ONE, (DCE)
64 25250 646 SIXBIT SUBROUTINE NAMES HAVE LOCATION 0, (DCE)
65 25247 650 IMPROVE LISTING FILE WITH RESPECT TO DOUBLE
PRECISION AND STRING LITERAL CONSTANTS, (DCE)
66 26442 705 USE NAME FROM PROGRAM STATEMENT AS THE ENTRY
POINT FOR THE MAIN PROGRAM, (DCE)
67 ----- 734 ONLY PRINT DP CONSTANTS IN LISTING WHEN APPROPRIATE,
(DCE)
***** Begin Version 6 *****
68 761 TFV 1-Mar-80 -----
Adjust mnemonic table offset to deal with GFAD, etc.
Print double octal literals for GFAD, etc. (/GFLOATING)
69 1003 TFV 1-Jul-80
Add global symbol ..GFL. if compiling /GFLOATING for FORDDT
support. Suppress DDT output of .VEND and ..GFL. .
***** Begin Version 7 *****
70 1221 CKS 4-Jun-81
Use LIT1 and LIT2 instead of CONST1 and CONST2 when referring to
literal nodes. Also test for end of ASCIZ string by using word
count instead of literal-entry[CW5] EQL 0 check.
71 1224 CKS 12-Jun-81
One more try at 1221... Remove dependence of ASCIZ lister on LITSIZ;
have it output the whole string. For the record, LITSIZ is the number
of words in the character string including the null word at the end.
72 1245 TFV 3-Aug-81 ------
Fix ROUSYM to handle HISEG character descriptors.
73 1251 CKS 14-Aug-81 ------
LSTINST types addresses as NAME+OFFSET or NAME-OFFSET. The calculation
it uses to get the offset is OFFSET = EXTSIGN(ADDR) - NAME. This does
not work if ADDR is above 400000 octal. Make it EXTSIGN(ADDR-NAME).
74 1261 CKS 21-Sep-81
Do not output common block fixup for descriptor of character variable
75 1274 TFV 20-Oct-81 ------
Fix DMPSYMTAB to output all the .Qnnnn variables to the DDT symbol
table
76 1406 TFV 27-Oct-81 ------
Fix DMPSYMTAB to output all the .Dnnnn variables to the DDT symbol
table
77 1424 RVM 19-Nov-81
Precede the formats in the object program and in the listed code
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.
78 1433 RVM 14-Dec-81
Rewrite LSTFORMAT to print as much format text per line as possible,
instead of listing format text one word at a time. Also, suppress
listing nulls in format text.
79 1434 TFV 14-Dec-81 ------
Fix ROUSYM to handle external character functions. In argument
blocks, it should use the decriptor for the function, not a global
request for its address.
1506 AHM 14-Mar-82
Delete call to ENDISNRLBLK in ZENDALL since the output of
statement labels in DEBUG is now done with ZOUTBLOCK.
1512 AHM 26-Mar-82
Convert all calls to ZOUTBLOCK that created symbols (RSYMBOL
rel blocks) to call the ZSYMBOL routine instead. Also make
flushing of SYMRLBF in ZENDALL work properly for 1070 blocks.
1525 AHM 1-Apr-82
Various changes for psected REL files. Emit type 22 psect
index blocks before dumping the type 10 local fixup buffer and
before writing the type 7 start address block. Write out type
24 psect end blocks with the values of LOWLOC, HILOC and
LARGELOC. Also, write out a single segment break of zero
because LINK still needs a type 5 END block. Finally, don't
emit polish for instructions with negative Y fields that look
like hiseg references.
1526 AHM 7-Apr-82
Change all the calls to ZOUTBLOCK for RCODE (type 1) blocks to
calls to ZCODE to prepare for psected REL files. Call CGERR
if a peephole buffer entry of type PBF2LABREF is encountered,
since I can't find anything that uses them. If LARGELOC
exceeds 30 bits, give the error message "Program too large".
Use the proper relocation counter to allocate space for each
psect instead of always using HILOC to tell ZOUTBLOCK what
address is being output. Make DUMPSYMTAB use SNPSECT when
defining labels.
1547 AHM 1-Jun-82
Make ZENDALL complain if the size of all the COMMON blocks
plus the sizes of the high and low segments exceeds 18 bits of
address space, or if .LARG. exceeds 30 bits of address space.
1562 TFV 18-Jun-82
Fix ROUSYM to handle TYPECNV nodes in argument lists. These are
inserted over .Qnnnn variables used as the result descriptor for
concatenations. They cause the VALTYPE for the .Qnnnn variable
to be CHARACTER.
1564 AHM 21-Jun-82
Make ZENDALL output /SYMSEG and /PVBLOCK to LINK if compiling
/EXTENDED.
1567 CDM 24-Jun-82
Don't put out .Dnnn variables if NOALLOC is lit.
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
Move the call to ARGCHECK for arg checking rel blocks from PHA3
to ZENDALL, after symbol table is dumped.
***** Begin Version 10 *********
2306 AlB 13-Feb-84
Added code to DMPSYMTAB to put out global definitions of FLGVX.
and FLG77. if Compatibility Flaggng is being done.
FLGVX. is defined as all ones if /FLAG:VAX is used.
FLG77. is defined as all ones if /FLAG:STANDARD is used.
2311 PLB 19-Feb-84 FREEDOM IS SLAVERY
Use new routine ZOUSMOFFSET instead of ZOUOFFSET.
OUTOFFSET now uses ZOUTADDR and outputs 24 bits
and we are outputting instruction offsets to listing.
2321 AHM 13-Mar-84
Make ROUSYM recognize references to EFIW table entries. It
calls a new routine named ROUEFIW to process such references.
2334 AHM 5-Apr-84
Make the type 7 (Start) rel block output by ZENDALL reference
the entry vector which lives in .DATA. under /EXTEND.
2337 CDM 8-Apr-84
Output EFIW references /LISTING/MACRO.
2346 AHM 23-Apr-84
Get rid of EXTERNAL for COMTSIZ, since no one uses it anymore,
and the variable has been removed from GLOBAL.
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!
2455 MEM 30-Aug-84
Replace all occurrences of VAX with VMS.
2464 AHM 10-Oct-84
When listing an EFIW in LSTEFIW don't output the variable name
or use IDADDR in the offset computation for an EFIW with PSABS
in EFEXTERN - it is an unrelocated formal array reference.
***** End V10 Development *****
***** End Revision History *****
4512 CDM 26-Aug-85
Delete old never called routines. TMPGEN, STRNGSCAN, ZSIXBIT.
4513 CDM 12-Sep-85
Improvements to /STATISTICS for reporting symbol table size
and COMMON block size.
4520 MEM 17-Sep-85
Change reference of CLINK to DLINK.
4527 CDM 1-Jan-86
VMS Long symbols phase II. Convert all internal symbols from
one word of Sixbit to [length,,pointer]. The lengths will be one
(word) until a later edit, which will store and use long symbols.
4530 MEM 17-Feb-86
Add long symbol support in routine ROUSYM.
4531 MEM 17-Feb-86
Output secondary symbol table for FORDDT.
4535 CDM 13-May-86
Make Link do a 30 bit fixup for a one word pointer to a label
/EXTEND. This shows up in NAMELIST processing, since we have
labels pointing to Sixbit for the names.
Also clean up peephole buffer output in LISTOU to stop using
magic numbers.
ENDV11
)%
! The routines in this module are for the purpose of generating the
! macro expanded listing of the code generated and the generation of
! the relocatable binary information in the .REL file.
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE REQREL.BLI;
SWITCHES LIST;
FORWARD
%2321% ROUEFIW, ! Output a reference to an EFIW
GMULENTRY, ! Generate a global symbol definition for multiple
! entry point names
%2337% LSTEFIW; ! Outputs an EFIW ref to the listing file
EXTERNAL
CHDSTART,
%1526% CGERR, ! Fatal error message
%4531% CMPSYM, ! Compare two long symbols
CODELINES,
%1406% DANCHOR, ! Start of .Dnnnn variable linked list
DEFISN, ! Routine called for first instruction of each line to
! put out a label corresponding to the line seq number
DMPRLBLOCK, ! Routine to dump a buffered rel-file block out
DMPMAINRLBF, ! Routine to dump the main rel-file buffer
ENDSCAA,
%2334% ENTADDR, ! Address of entry vector
ERROUT,
FORMPTR, ! Pointer to the first format statement in program
HEADCHK, ! Checks line count and outputs headings
HEADING,
HILOC, ! Current hiseg available location
HIORIGIN, ! Origin of high segment for twoseg compilations
ISN,
LABTBL,
%1526% LARGELOC, ! Next available location in .LARG.
LMCONO, ! Current map column number
LMLINO, ! Current source line number
LMRONO, ! Current map row number
LOCRLBF, ! Rel file buffer
%4530% LONGREL, ! Boolean indicating whether long symbols are put out
%4530% LONGUSED, ! Boolean indicating whether long symbols were used
LOWLOC, ! Current lowseg available location
LSTOUT,
MAINRLBF, ! Rel file buffer
%4513% NSYMTBL, ! Number of buckets in symbol table.
%4527% ONEWPTR, ! Returns [1,,pointer] to Sixbit argument passed
OPMNEM,
OUTMSG,
%645% PAGELINE,
%4527% BASE PROGNAME,
%1274% QANCHOR, ! Start of .Qnnnn variable linked list
RADIX50,
%2321% OBJECTCODE RDATWD, ! Contains current rel data word
RELBLOCK, ! Relocatable binary block
RELDATA, ! Data word - current block number,,current data count
RELOCWD, ! The relocation word for the block
RELOUT,
%4530% STADDR, ! Program start address
%650% STRNGOUT,
SYMRLBF, ! Rel file buffer
SYMTBL,
%1614% ZARGCHECK, ! Argument checking rel block routine.
%4531% Z30CODE,
%1526% ZCODE, ! Outputs type 1 or 1010 data blocks to rel file
ZLABLMAK,
%4530% ZNEWBLOCK,
ZOUDLB, ! Routine to add to the macro expanded listing a
! label that is inserted on the first instruction of
! each statement when the user has specified /DEBUG
ZOUDECIMAL,
%2337% ZOUOFFSET, ! Output 18 or 30 bit offset to listing
ZOUTBLOCK,
ZOUTMSG,
ZOUTOCT,
%2311% ZOUSMOFFSET, ! Outputs (+/-) offset to listing file
ZOUTSYM,
%1512% ZSYMBOL; ! Outputs a type 2 or 1070 symbol block to the REL file
MACRO
CHROUT(C) = (CHR = (C); LSTOUT()) $, ! Outputs a char to the listing
! Argument "C" must be in
! double (") rather than single
! (') quotes.
%2337% DECOUT(X) = (R1 = (X); ZOUDECIMAL()) $, ! Outputs a decimal number
%2337% OCTOUT(X) = (R2<LEFT> = (X); ZOUTOCT()) $; ! Outputs an octal number
ROUTINE DMPSECSYMTAB = !New [4531]
!++
! FUNCTIONAL DESCRIPTION:
!
! Dumps out entire secondary symbol table to rel file if /DEBUG and long
! symbols used. Entry points will always be dumped out even if not /DEBUG
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! FLGREG ! Flag register containing /DEBUG flags
!
! HILOC
!
! IMPLICIT OUTPUTS:
!
! HILOC
!
! RDATWD
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! Can flush main rel buffer to rel file
!
!--
BEGIN
BIND DEBUGFLGS =
! FLGREG bit positions for the various
! DEBUG modifiers
1^DBGDIMNBR +
1^DBGINDXBR +
1^DBGLABLBR +
1^DBGTRACBR +
1^DBGBOUNBR +
1^DBGARGMBR;
! fields in a secondary symbol table entry
MACRO SPTR = 0,30$, ![4531] Pointer to name
SCNT = 30,3$, ![4531] word count
SFLG = 33,3$; ![4531] flag
BIND LOCL = 1, !LOCAL
GLOBL = 2, !GLOBAL
PNAME = 6; !PROGRAM NAME
LOCAL BASE SYMPTR,
DEBUGSPECIFIED, ! Boolean is true if /DEBUG was specified
NAMOFFSET,
NSYMTB, ! Number of long symbols
BASE TMP; ! Ptr to common block name
! Set DEBUGSPECIFIED to true if any /DEBUG flags are set
DEBUGSPECIFIED = (.FLGREG<FULL> AND DEBUGFLGS) NEQ 0;
NAMOFFSET = .HILOC;
NSYMTB = 1;
! Dump out program name
INCR J FROM 0 TO .PROGNAME<SYMLENGTH>-1
DO
BEGIN
RDATWD=@(.PROGNAME<SYMPOINTER> +.J);
Z30CODE(PSABS,PSCODE);
HILOC = .HILOC + 1;
END;
DECR I FROM SSIZ-1 TO 0
DO !Loop through symbol table
IF (SYMPTR _ .SYMTBL[.I]) NEQ 0 !If we have an non-zero entry here
THEN
BEGIN
DO !Loop through this entry and its collisions
BEGIN
IF .SYMPTR[OPRSP1] NEQ FNNAME1 ! not function name
THEN IF NOT CMPSYM(.SYMPTR[IDSYMBOL],.PROGNAME) !not program name
THEN IF (.DEBUGSPECIFIED AND .LONGUSED) ! /DEBUG and long symbols
OR .SYMPTR[IDATTRIBUT(FENTRYNAME)]! entry point
THEN
BEGIN
! FOR /DEBUG we put out 2 entries for arrays
IF .FLGREG<DBGDIMN>
AND .SYMPTR[OPRSP1] EQL ARRAYNM1
AND ((NOT .SYMPTR[IDATTRIBUT(NOALLOC)])
OR .SYMPTR[IDATTRIBUT(INCOM)]) !PUT IN COMMON
THEN NSYMTB = .NSYMTB + 2
ELSE NSYMTB = .NSYMTB + 1;
INCR J FROM 0 TO .SYMPTR[IDSYMLENGTH]-1
DO
BEGIN
RDATWD=@(.SYMPTR[IDSYMPOINTER] +.J);
Z30CODE(PSABS,PSCODE);
HILOC = .HILOC + 1;
END;
END;
END
WHILE (SYMPTR _ .SYMPTR[CLINK]) NEQ 0;
END;
! Associate label on symtable with this loc
ZSYMBOL(LOCDEF,ONEWPTR(SIXBIT '.SYMTB'),.HILOC,PSCODE);
! Put out the count
RDATWD = .NSYMTB;
IF .DEBUGSPECIFIED ! If /DEBUG then put out entire symbol table
THEN IF .LONGUSED ! Long symbols exist
THEN RDATWD<LEFT> = -1;
Z30CODE(PSABS,PSCODE);
HILOC = .HILOC + 1;
! Output count,,pointer to program name
RDATWD = 0;
RDATWD<SPTR> = .NAMOFFSET;
RDATWD<SCNT> = .PROGNAME<SYMLENGTH>;
RDATWD<SFLG> = PNAME; !PROGRAM NAME
Z30CODE(PSCODE,PSCODE);
HILOC = .HILOC + 1;
! Output pointer to symbol value
RDATWD = IF .FLGREG<PROGTYP> EQL MAPROG THEN .STADDR
ELSE .STADDR + .PROGNAME<SYMLENGTH> + 2;
Z30CODE(PSCODE,PSCODE);
HILOC = .HILOC + 1;
NAMOFFSET = .NAMOFFSET + .PROGNAME<SYMLENGTH>;
IF .NSYMTB GTR 1
THEN DECR I FROM SSIZ-1 TO 0
DO !Loop through symbol table
BEGIN
IF (SYMPTR _ .SYMTBL[.I]) NEQ 0 !If we have an non-zero entry here
THEN
DO !Loop through this entry and its collisions
BEGIN
IF .SYMPTR[OPRSP1] NEQ FNNAME1 ! not function name
THEN IF NOT CMPSYM(.SYMPTR[IDSYMBOL],.PROGNAME) !not program name
THEN IF (.DEBUGSPECIFIED AND .LONGUSED) ! /DEBUG and long symbols
OR .SYMPTR[IDATTRIBUT(FENTRYNAME)]! entry point
THEN
BEGIN ! Long symbol
! Output count and pointer to name
RDATWD = 0;
RDATWD<SPTR> = .NAMOFFSET; !ptr to symbol
RDATWD<SCNT> = .SYMPTR[IDSYMLENGTH];
IF .SYMPTR[IDATTRIBUT(FENTRYNAME)] !GLOBAL?
THEN RDATWD<SFLG> = GLOBL !GLOBAL
ELSE RDATWD<SFLG> = LOCL; !LOCAL
Z30CODE(PSCODE,PSCODE);
HILOC = .HILOC + 1;
! Output pointer to symbol value
RDATWD = .SYMPTR[IDADDR];
IF .SYMPTR[IDATTRIBUT(INCOM)]
AND .SYMPTR[VALTYPE] NEQ CHARACTER
THEN
BEGIN
! The Y field is the
! subject of a fixup because of a
! reference to COMMON so
! don't relocate it.
Z30CODE(PSABS, PSCODE);
! Output a a global additive fixup to
! add the external's value to the
! COMMON's Y field.
TMP = .SYMPTR[IDCOMMON];
ZSYMBOL(GLB30ADDFIX, .TMP[COMNAME],
.HILOC, PSCODE);
END
ELSE Z30CODE(.SYMPTR[IDPSECT],PSCODE);
HILOC = .HILOC + 1;
IF .FLGREG<DBGDIMN> !IF USER SPECIFIED THE "DEBUG" SWITCH
THEN ! THEN FOR ALL ARRAYS WE WANT TO
! PUT A PTR IN THE SYMBOL TABLE ENTRY POINTING
! TO THE DIMENSION INFORMATION FOR THE ARRAY
BEGIN
IF .SYMPTR[OPRSP1] EQL ARRAYNM1
AND ((NOT .SYMPTR[IDATTRIBUT(NOALLOC)])
OR .SYMPTR[IDATTRIBUT(INCOM)]) !PUT IN COMMON
THEN
BEGIN
! Use the kluge of adding a 2nd entry for the same symbol immediately
! after its true definition which points to the dimension information.
! Note that since FORDDT searches the symbol table forwards, this means
! it will see the symbol for the variable before it sees the pointer to
! the dimension table.
REGISTER BASE T1;
T1_.SYMPTR[IDDIM]; !PTR TO DIMENS TABLE ENT
T1_.T1[ARADLBL]; !PTR TO LABEL TABLE ENTRY FOR
!LABEL ON DIMENS INFO ARG BLOCK
! Output count and pointer to name
RDATWD = 0;
RDATWD<SPTR> = .NAMOFFSET; !ptr to symbol
RDATWD<SCNT> = .SYMPTR[IDSYMLENGTH];
RDATWD<SFLG> = LOCL; !LOCAL
Z30CODE(PSCODE,PSCODE);
HILOC = .HILOC + 1;
! Output pointer to symbol value (ptr to dimension info)
RDATWD = .T1[SNADDR];
Z30CODE(.T1[SNPSECT],PSCODE);
HILOC = .HILOC + 1;
END
END;
! Increment to next name
NAMOFFSET = .NAMOFFSET + .SYMPTR[IDSYMLENGTH];
END; ! Long name
END
WHILE (SYMPTR _ .SYMPTR[CLINK]) NEQ 0;
END;
END; ! of DMPSECSYMTAB
ROUTINE DMPSYMTAB =
!++
!DUMPS THE SYMBOL TABLE TO REL FILE
!--
BEGIN
OWN LABL;
%1274% REGISTER BASE SYMPTR; ! Pointer to the symbol to be output
ROUTINE BLDLABL=
%(***************************
LOCAL ROUTINE TO BUILD THE SIXBIT FOR THE
DECIMAL FORM OF THE STMNT NUMBER IN THE REG "R1".
CALLED WITH THE VAR "LABL" CONTAINING ONE
SIXBIT CHAR IN THE LEFTMOST SIX BITS. LEAVES "LABL" CONTAINING
THE STMNT NUMBER FOLLOWED BY THAT CHAR.
****************************)%
BEGIN
DO (
LABL _ .LABL ^(-6);
R2 _ .R1 MOD 10; R1 _ .R1/10;
LABL<30,6> _ (#20[.R2]<0,0>); !MAKING ROOM FOR NEXT
IF .R1 EQL 0 THEN EXITLOOP;
) WHILE 1;
END;
%(**DUMP THE SYMBOL TABLE***)%
DECR I FROM SSIZ-1 TO 0 DO
BEGIN
IF (SYMPTR _ .SYMTBL[.I]) NEQ 0
THEN
BEGIN
DO
BEGIN
%4513% NSYMTBL = .NSYMTBL + 1; ! One more symbol
IF .FLGREG<DBGDIMN> !IF USER SPECIFIED THE "DEBUG" SWITCH
THEN ! THEN FOR ALL ARRAYS WE WANT TO
! PUT A PTR IN THE SYMBOL TABLE ENTRY POINTING
! TO THE DIMENSION INFORMATION FOR THE ARRAY
BEGIN
IF .SYMPTR[OPRSP1] EQL ARRAYNM1
AND ((NOT .SYMPTR[IDATTRIBUT(NOALLOC)])
OR .SYMPTR[IDATTRIBUT(INCOM)]) !PUT IN COMMON
THEN
BEGIN
! Use the kluge of adding a 2nd entry for the same symbol immediately
! before its true definition which points to the dimension information.
! Note that since FORDDT searches the symbol table backwards, this means
! it will see the symbol for the variable before it sees the pointer to
! the dimension table.
REGISTER BASE T1;
T1_.SYMPTR[IDDIM]; !PTR TO DIMENS TABLE ENT
T1_.T1[ARADLBL]; !PTR TO LABEL TABLE ENTRY FOR
!LABEL ON DIMENS INFO ARG BLOCK
%1512% ZSYMBOL(LOCSUPDEF,.SYMPTR[IDSYMBOL],.T1[SNADDR],PSCODE)
END
END;
IF .SYMPTR[IDATTRIBUT(INCOM)]
%1261% AND .SYMPTR[VALTYPE] NEQ CHARACTER
THEN
BEGIN
MAP BASE R2;
%1512% ZSYMBOL(LOCDEF,.SYMPTR[IDSYMBOL],.SYMPTR[IDADDR],PSABS); ! Common block offset
R2 _ .SYMPTR[IDCOMMON]; ! Add to symbol when the
%1512% ZSYMBOL(GLBSYMFIX,.R2[COMNAME],.SYMPTR[IDSYMBOL],PSABS) ! common address is set
END
ELSE IF .SYMPTR[OPRSP1] NEQ FNNAME1
AND NOT .SYMPTR[IDATTRIBUT(NOALLOC)]
%1512% THEN ZSYMBOL(LOCDEF,.SYMPTR[IDSYMBOL],.SYMPTR[IDADDR],.SYMPTR[IDPSECT]) ! Define vanilla symbol as
! an unsuppressed local
END WHILE (SYMPTR _ .SYMPTR[CLINK]) NEQ 0;
END;
END;
! Output a symbol for the word after the end of the scalars and
! arrays. ENDSCAA contains the location after the end of arrays and
! scalars and is set in ALLSCA.
%1003% ! Suppress DDT output of .VEND
%4527% ZSYMBOL(LOCSUPDEF,ONEWPTR(SIXBIT '.VEND'),.ENDSCAA,PSDATA);
%1003% ! Output the global symbol ..GFL. if compiling /GFLOAT for FORDDT
%1003% ! support
%1003% IF .GFLOAT ! Give it the value of 1
%4527% THEN ZSYMBOL(GLBSUPDEF,ONEWPTR(SIXBIT '..GFL.'),1,PSABS);
![2455] Output the global symbols FLGV. (if /FLAG:VMS) and FLG77. (if
![2306] /FLAG:STANDARD). These globals tell FOROTS that there is Compatibility
![2306] flagging to do at runtime.
%2455% IF FLAGVMS
%4527% THEN ZSYMBOL(GLBSUPDEF,ONEWPTR(SIXBIT 'FLGV.'),-1,PSABS);
%2306% IF FLAGANSI
%4527% THEN ZSYMBOL(GLBSUPDEF,ONEWPTR(SIXBIT 'FLG77.'),-1,PSABS);
%4531% DMPSECSYMTAB();
! Dump the local labels now
DECR I FROM LASIZ-1 TO 0 DO
BEGIN
IF (SYMPTR _ .LABTBL[.I]) NEQ 0 THEN
BEGIN
DO BEGIN
%636% IF .SYMPTR[SNDEFINED]
%636% THEN
%636% BEGIN
LABL _ 0;
R1 _ .SYMPTR[SNUMBER];
LABL<30,6> _ IF .R1 GTR 99999 THEN (R1 _ .R1-99999; SIXBIT "M" ) ELSE SIXBIT "P";
BLDLABL(); !IN "LABL" BUILD THE SIXBIT FOR
! THE STMNT NUMBER IN R1 (FOLLOWED BY THE CHAR
! ALREADY IN "LABL"
%4527% ZSYMBOL(LOCDEF,ONEWPTR(.LABL),.SYMPTR[SNADDR],
%1526% .SYMPTR[SNPSECT])
%636% END;
END WHILE (SYMPTR _ .SYMPTR[CLINK]) NEQ 0;
END;
END;
%1274% ! Dump the .Qnnnn variable names
%1274% SYMPTR = .QANCHOR; ! Start at the beginning (including those used
! for statement functions)
%1274% WHILE .SYMPTR NEQ 0 DO
%1274% BEGIN
%1512% ZSYMBOL(LOCDEF,.SYMPTR[IDSYMBOL],.SYMPTR[IDADDR],PSDATA);
%1274% SYMPTR = .SYMPTR[CLINK]
%1274% END;
%1406% ! Dump the .Dnnnn variable names
%1406% SYMPTR = .DANCHOR; ! Start at the beginning
%1406% WHILE .SYMPTR NEQ 0 DO
%1406% BEGIN
%1567% ! Only if we want to allocate it.
%1567% IF NOT .SYMPTR[IDATTRIBUT(NOALLOC)]
%1567% THEN
%1567% BEGIN
%1512% ZSYMBOL(LOCDEF,.SYMPTR[IDSYMBOL],.SYMPTR[IDADDR],
%1512% PSCODE);
%1567% END;
%4520% SYMPTR = .SYMPTR[DLINK]
%1406% END;
!DEFINE A LABEL OF THE FORM <STMNT NUMBER>F ON THE LAST WD
! OF EACH FORMAT STRING
IF .FLGREG<DBGLABL>
THEN
!
BEGIN
REGISTER BASE FPTR; !PTR TO FORMAT STMNT NODE
FPTR_.FORMPTR<LEFT>; !1ST FORMAT STMNT IN PROGRAM
UNTIL .FPTR EQL 0
DO
BEGIN
SYMPTR_.FPTR[SRCLBL]; !STMNT NUMBER TABLE
! ENTRY FOR THE LABEL ON THE FORMAT
R1_.SYMPTR[SNUMBER]; !STMNT NUMBER ON THE FORMAT STMNT
LABL_0;
LABL<30,6>_SIXBIT"F";
BLDLABL(); !SET "LABL" TO THE SIXBIT FOR
! <STMNT NUMBER>F
%1512% ! Address of last word of string
%4527% ZSYMBOL(LOCDEF, ONEWPTR(.LABL),
%1512% .FPTR[FORADDR]+.FPTR[FORSIZ]-1, PSDATA);
FPTR_.FPTR[FMTLINK] !GO ON TO NEXT FORMAT
END;
END;
END; ! of DMPSYMTAB
%650% ROUTINE ZDOUTCON(WORD2)=
%650% BEGIN
%650% !LIST A DOUBLE WORD CONSTANT IN OCTAL
%650% !WORD ONE IS IN R2; SECOND WORD IS IN WORD2
%650%
%650% STRNGOUT(PLIT ASCIZ '[EXP ');
%650%
%650% DECR I FROM 11 TO 0 DO
%650% BEGIN
%650% R1_0; LSHC(R1,3);
%650% CHR_.R1+#60; LSTOUT();
%650% END;
%650%
%650% CHR_","; LSTOUT();
%650%
%650% R2_.WORD2;
%650% DECR I FROM 11 TO 0 DO
%650% BEGIN
%650% R1_0; LSHC(R1,3);
%650% CHR_.R1+#60; LSTOUT();
%650% END;
%650%
%650% CHR_"]"; LSTOUT();
%650% END; ! of ZDOUTCON
%650% ROUTINE ZSOUTCON(ADDR)=
%650% BEGIN
%650% !OUTPUT A STRING STARTING FROM ADDR AND BEING NO
%650% !MORE THAN 10 CHARACTERS. THE FORMAT WILL BE:
%1224% ! [ASCIZ /STRING/]
%650% MAP BASE ADDR;
%650%
%650% STRNGOUT(UPLIT ASCIZ '[ASCIZ /');
%1224% STRNGOUT(ADDR[LIT1]);
%1224% STRNGOUT(UPLIT ASCIZ '/]');
%650% END; ! of ZSOUTCON
ROUTINE ZOUTCON=
BEGIN
!LIST A CONSTANT IN OCTAL ; R2 CONTAINS VALUE
CHR _ "["; LSTOUT();
DECR I FROM 11 TO 0 DO
BEGIN
R1 _ 0; LSHC(R1,3);
CHR _ .R1 + #60; LSTOUT();
END;
CHR _ "]"; LSTOUT()
END; ! of ZOUTCON
ROUTINE COMCOM=
!++
! Outputs two commas ",,"
!--
BEGIN
CHR_",";
LSTOUT();
LSTOUT()
END; ! of COMCOM
ROUTINE LSTINST(IPTR)=
!++
! FUNCTIONAL DESCRIPTION:
!
! Lists the MACRO-10 mnemonics of the instructions being generated
! in the listing file.
!
! FORMAL PARAMETERS:
!
! IPTR Pointer to peephole buffer containing the
! instruction being output.
!
! IMPLICIT INPUTS:
!
! Unknown
!
! IMPLICIT OUTPUTS:
!
! Unknown
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! Instruction line is output to the listing file.
!
!--
BEGIN
MACRO
IISN = (@IPTR)<FULL>$, !LINENUMBER OF INSTRUCTION
ILABEL = (@IPTR+1)<LEFT>$,
IADDRPTR = (@IPTR+1)<RIGHT>$,
IOPCODE = (@IPTR+2)<27,9>$,
IAC = (@IPTR+2)<23,4>$,
IINDIR = (@IPTR+2)<22,1>$,
IINDEX = (@IPTR+2)<18,4>$,
IEFFADDR = (@IPTR+2)<RIGHT>$;
MACRO HEADRSW = CODELINES<LEFT>$;
LOCAL OPPOINT;
BIND ZADDR = IADDRPTR;
MAP BASE ZADDR,
BASE R2;
ROUTINE ZLABLMAK(ILABLPT)=
BEGIN
! R1 contains label in binary
MAP BASE ILABLPT;
R1_.ILABLPT[SNUMBER];
IF .R1 GTR 99999 THEN R1 _ .R1-99999; !REDUCE TO NICE RANGE
ZOUDECIMAL(); !OUTPUT VALUE OF R1 IN DECIMAL
IF .ILABLPT[SNUMBER] GTR 99999
THEN CHR _ "M"
ELSE CHR _ "P";
LSTOUT();
.VREG
END; !Of ZMAKLABL
%734% LOCAL DINSTF; !DOUBLE WORD INSTRUCTION FLAG
IF .HEADRSW NEQ #777777
THEN
BEGIN
CODELINES _ 0;
HEADRSW _ #777777
END;
CRLF;
HEADCHK();
IF (R1 _ .IISN) GEQ 0
THEN IF .R1 EQL 0
THEN
BEGIN
CHR _ "*";
LSTOUT()
END
ELSE ZOUDECIMAL();
CHR _ #11;
LSTOUT(); !TAB
IF .IADDRPTR EQL PBFENTRY
THEN
BEGIN
!ENTRY NAME TAKES UP ONE LISTING LINE - ACCOUNT FOR IT
%645% CRLF;
%645% PAGELINE_.PAGELINE-1;
%645% CHR_#11;
%645% LSTOUT();
R2 _ .IEFFADDR;
R2 _ .R2[IDSYMBOL];
ZOUTSYM();
CHR _ ":";
LSTOUT();
RETURN
END;
!GEN THE RELATIVE LOCATION (OCTAL)
R2<LEFT> _ .CODELINES<RIGHT>;
ZOUTOCT();
CHR _ #11;
LSTOUT(); ! TAB
CODELINES _ .CODELINES + 1;
IF .ILABEL NEQ 0 !LIST A LABEL
THEN
BEGIN
LOCAL BASE LABPT;
LABPT _ .ILABEL;
DO
BEGIN
ZLABLMAK(.LABPT);
CHR _ ":";
LSTOUT();
CRLF;
HEADCHK();
CHR _ #11;
LSTOUT();
LSTOUT(); !TAB
END
WHILE (LABPT _ .LABPT[SNNXTLAB]) NEQ 0;
END;
! IF THE USER SPECIFIED THE "DEBUG" SWITCH THEN IF THIS INSTR
! STARTS A STMNT, LIST AN "L" LABEL ON THIS INSTR
IF (R1_.IISN) GTR 0 AND .FLGREG<DBGLABL>
THEN ZOUDLB();
CHR _ #11;
LSTOUT(); !TAB
%734% DINSTF_0;
! Now do the instruction listing
IF .IOPCODE NEQ 0
THEN
BEGIN
!First mnemonic is now GFAD (#103)
%761% OPPOINT _ (OPMNEM-#103)[.IOPCODE]<0,6>; !MNEMONIC TABLE POINTER
INCR I FROM 0 TO 5 DO
BEGIN
CHR _SCANI(OPPOINT,CHR); !GET A CHARACTER
IF(CHR _ .CHR + #40 ) LEQ #100 THEN EXITLOOP;
! PICK UP FIRST CHAR OF INSTRUCTION
%734% IF .I EQL 0 THEN DINSTF_.CHR;
LSTOUT()
END
END;
CHR _ #11;
LSTOUT(); !TAB
!AC field
%2337% OCTOUT(.IAC);
CHR _ ",";
LSTOUT();
! Output address field of instruction. Do it differently if we
! have an EFIWREF.
%2337% IF .ZADDR[OPRCLS] EQL EFIWREF
%2337% THEN LSTEFIW(.ZADDR)
%2337% ELSE
%2337% BEGIN ! Not EFIWREF
! Indirect bit. Output "@".
IF .IINDIR NEQ 0
THEN
BEGIN
CHR _ "@";
LSTOUT();
END;
!Address field in instruction
IF .IADDRPTR GTR PBF2LABREF
THEN
BEGIN
IF SYMBOL(ZADDR)
THEN
BEGIN ! Symbol
R2 _ .ZADDR[IDSYMBOL];
ZOUTSYM()
END
ELSE
BEGIN ! Not symbol
IF .ZADDR[OPERSP] EQL CONSTANT
THEN
BEGIN ! Constant
IF .ZADDR[DBLFLG]
OR .ZADDR[VALTYPE] EQL REAL
THEN
BEGIN ! Double prec or real
IF .ZADDR[CONADDR] EQL .IEFFADDR
%650% THEN
BEGIN
! 1st word of constant
R2 _ .ZADDR[CONST1];
%734% ! Only print as double
%734% ! octal if instruction
%734% ! is double word, i.
%734% ! e., the first
%734% ! character begins with
%734% ! "D" or "G" (avoid
%734% ! CAMxx).
%761% IF .ZADDR[DBLFLG] AND
%761% (.DINSTF EQL "D"
%761% OR .DINSTF EQL "G")
%761% THEN RETURN ZDOUTCON(.ZADDR[CONST2])
END
ELSE R2 _ .ZADDR[CONST2]
END ! Double prec or real
ELSE R2 _ .ZADDR[CONST2]; ! INTEGER or LOGICAL or BYTE
RETURN ZOUTCON();
END ! Constant
ELSE
BEGIN ! Not constant
R2_.ZADDR[IDSYMBOL];
ZOUTSYM();
END;
END; ! Not symbol
%1251% IF (R1 _ EXTSIGN(.IEFFADDR -.ZADDR[IDADDR])) NEQ 0
%2311% THEN ZOUSMOFFSET(); !OUTPUT 18 BIT OFFSET
END
ELSE IF .IADDRPTR GTR 3
THEN BEGIN END
ELSE IF .IADDRPTR GTR 2
THEN
BEGIN
MAP BASE R2;
R2_.IEFFADDR;
R2 _ .R2[IDSYMBOL];
ZOUTSYM()
END
ELSE IF .IADDRPTR GTR 1
THEN !DOTTED FUNCTION NAME
BEGIN
%4527% R2 = ONEWPTR( @(.IEFFADDR) );
ZOUTSYM()
END
ELSE IF .IADDRPTR GTR 0 !NO SYMBOLIC ADDR
THEN
BEGIN
R2<LEFT> _ .IEFFADDR;
ZOUTOCT() !IMMEDIATE MODE VALUE
END
ELSE ZLABLMAK(.IEFFADDR);
!Index field "(register)"
IF .IINDEX NEQ 0
%2337% THEN
%2337% BEGIN
%2337% CHROUT("(");
%2337% OCTOUT(.IINDEX); ! Register to use
%2337% CHROUT(")");
%2337% END;
%2337% END; ! Not EFIWREF
END; ! of LSTINSTF
ROUTINE LINEMAP (IPTR) =
!LIST ON LISTING DEVICE A LINE-NUMBER/OCTAL-LOCATION MAP IF
! NO MACRO LISTING WAS REQUESTED
BEGIN
MACRO IISN = (@IPTR)<FULL>$,
IADDRPTR = (@IPTR+1)<RIGHT>$,
HEADRSW = CODELINES<LEFT>$;
IF .HEADRSW NEQ #777777
THEN
BEGIN
CODELINES _ 0;
HEADRSW _ #777777;
END;
IF .IADDRPTR EQL PBFENTRY
THEN RETURN;
IF .IISN GTR 0
AND .LMLINO LSS .IISN ! BEWARE 1 LINE NUM FOR >1 OCTAL LOC
THEN
BEGIN
DO
BEGIN
IF (LMCONO _ .LMCONO + 1) EQL 10
THEN BEGIN
LMCONO _ 0;
CRLF;
HEADCHK ();
CHR _ "0";
IF (LMRONO _ (.IISN DIV 10) - 1) LSS 999
THEN BEGIN
LSTOUT ();
IF .LMRONO LSS 99
THEN BEGIN
LSTOUT ();
IF .LMRONO LSS 9
THEN LSTOUT ();
END
END;
R1 _ LMRONO _ .LMRONO + 1;
ZOUDECIMAL ();
CHR _ "0";
LSTOUT ();
CHR _ " ";
LSTOUT ();
CHR _ ":";
LSTOUT ();
CHR _ " ";
LSTOUT ();
LMLINO _ .LMRONO * 10 - 1;
END
ELSE CHROUT("?I")
END
WHILE (LMLINO _ .LMLINO + 1) LSS .IISN;
R2<LEFT> _ .CODELINES<RIGHT>;
ZOUTOCT ();
END;
CODELINES _ .CODELINES + 1;
END; ! of LINEMAP
ROUTINE ROUIMFUN(FUNCPTR,FUNAME)= !OUTPUT FUNCTION REQUEST GLOBAL
BEGIN
RDATWD = .FUNCPTR<LEFT>^18;
%1526% ZCODE(PSABS,PSCODE); ! Output PUSHJ P,0 to .CODE.
! Output a chained global fixup request so that LINK will place the
! address of the start of the named routine in the right half of the
! PUSHJ instruction when the global symbol named in FUNAME is defined.
%1512% ZSYMBOL(GLB18CHNFIX,.FUNAME,.HILOC,PSCODE)
END; ! of ROUIMFUN
ROUTINE ROURLABEL(LABLPTR)=
BEGIN
MAP
BASE LABLPTR;
REGISTER
%1526% MYPSECT; ! Psect to relocate the RH of the reference by
RDATWD<LEFT> _ .LABLPTR<LEFT>;
! Instructions that reference labels are either defined (backward
! references) or not defined (forward references). If the label is
! defined, then it is in .CODE. unless it is for a FORMAT statement in
! .DATA. ASSIGN statements that reference FORMATs come through here,
! while I/O argument blocks are done right in OUTMDA. If the label is
! not defined, then the first reference to the label gets an
! unrelocated 0 put out to mark the end of a fixup chain and the rest
! of the references become the address of the previous instruction in
! the .CODE. psect.
%1526% IF .LABLPTR[SNSTATUS] EQL OUTPBUFF ! Is the label defined ?
%1526% THEN MYPSECT = .LABLPTR[SNPSECT] ! Yes, use its psect
%1526% ELSE IF .LABLPTR[SNDEFINED] ! No, first reference ?
%1526% THEN MYPSECT = PSCODE ! No, the fixup uses .CODE.
%636% ELSE ! Yes, the first reference in a
%636% BEGIN ! chain contains absolute 0
%1526% MYPSECT = PSABS; ! So don't relocate it
%636% LABLPTR[SNADDR]_0; ! Store the zero
%636% LABLPTR[SNDEFINED]_TRUE ! Say SNADDR is valid
%636% END;
RDATWD<RIGHT> _ .LABLPTR[SNADDR];
! At this point RDATWD<RIGHT> contains either 0 (if first time label
! referenced) or a hiseg chain address if not first reference and
! still undefined or the hiseg or lowseg address of the location the
! label defines. The value OUTPBUFF means the label has been defined
! to the loader.
%4535% ! If /EXTEND and nothing to overwrite in the left half (like
%4535% ! an instruction!), then do a 30 bit fixup. We need this for
%4535% ! a word pointing to a label. Link must insert any section
%4535% ! number.
%4535%
%4535% IF EXTENDED AND .RDATWD<LEFT> EQL 0
%4535% THEN Z30CODE(.MYPSECT,PSCODE) ! 30 bit relocation
%4535% ELSE
%1526% ZCODE(.MYPSECT,PSCODE); ! Relocate with the right psect
%636% IF .LABLPTR[SNSTATUS] NEQ OUTPBUFF
%636% THEN
%636% BEGIN
%636% LABLPTR[SNADDR] _ .HILOC; !CHAIN THE REQUEST
%636% LABLPTR[SNDEFINED]_TRUE;
%636% END;
END; ! of ROURLABEL
ROUTINE ROUEFIW(INSTRUCTION, EFIW) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Output an instruction or arg block which references an EFIW.
!
! Clear the index field and set the indirect bit so that the
! EFIW will be used as an indirect word.
!
! Place a fixup backpointer to previous EFIW references in the
! instruction's Y field and relocate it by .CODE. If this is
! the first reference to the EFIW, use unrelocated zero instead.
!
! Update the header of the fixup chain in the EFIW table entry's
! TARGADDR field to point to the current instruction.
!
! FORMAL PARAMETERS:
!
! INSTRUCTION Instruction word to be output.
!
! EFIW Pointer to EFIW table entry for instruction.
! This is used to find the representative EFIW,
! which holds the head of the fixup chain.
!
! IMPLICIT INPUTS:
!
! HILOC Unrelocated object address of the instruction
! to be output to .CODE.
!
! IMPLICIT OUTPUTS:
!
! EFIW[EFREP][TARGADDR]
! Representative's TARGADDR gets updated with
! the new head of this EFIW's fixup chain.
!
! RDATWD Destroyed.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! Can flush main rel buffer to the object file.
!
!--
BEGIN ![2321] New
MAP
BASE EFIW; ! Points to an EFIW table entry
RDATWD = .INSTRUCTION; ! Get instruction for object file
RDATWD[OTSIND] = 1; ! Set indirect bit
RDATWD[OTSINX] = 0; ! Clear out index register field
EFIW = .EFIW[EFREP]; ! Find the representative EFIW
RDATWD[OBJADDR] = .EFIW[TARGADDR]; ! Point at the most recent
! reference, or 0 if none
IF .EFIW[TARGADDR] EQL 0 ! Is there a fixup chain?
THEN ZCODE(PSABS,PSCODE) ! No, this is the start, absolute 0
ELSE ZCODE(PSCODE,PSCODE); ! Yes, back pointer points to hiseg
EFIW[TARGADDR] = .HILOC; ! Remember where the most recent
! reference to the EFIW is
END; ! of ROUEFIW
ROUTINE ROUSYM(INSTRUCTION,INSADDR,INARGBLOCK)=
BEGIN
! Relocatable symbolic output
MACRO ADD=3$,SUBT=4$;
%4530% MACRO LADD=100$;
MAP BASE R2;
%4530% LOCAL SYM; ! count,,ptr to common block name
LOCAL BASE SYMPTR; SYMPTR _ .INSADDR<RIGHT>;
%2321% IF .SYMPTR[OPRCLS] EQL EFIWREF ! Is it an EFIW?
%2321% THEN ! Yes, process specially
%2321% BEGIN ! EFIWREF
%2321% ROUEFIW(.INSTRUCTION, .SYMPTR); ! Emit the EFIW reference
%2321% RETURN; ! Punt immediately
%2321% END ! EFIWREF
%2321% ELSE IF NOT SYMBOL(SYMPTR) ! No, is it a CONSTANT or TEMPORARY ?
THEN ! Yes
BEGIN
RDATWD = .INSTRUCTION;
%1526% IF .SYMPTR[OPERATOR] EQL CHARCONST ! Character constant ?
%1526% THEN ZCODE(PSCODE,PSCODE) ! Yes, descriptor is in hiseg
%1526% ELSE ZCODE(PSDATA,PSCODE); ! No, data is in lowseg
RETURN
END
%1562% ELSE IF .SYMPTR[OPRCLS] EQL TYPECNV
%1562% THEN ! Type convert node above .Qnnnn TEMPORARY
%1562% BEGIN
%1562% RDATWD = .INSTRUCTION;
%1562% ZCODE(PSDATA, PSCODE); ! TEMPORARY is in the lowseg
%1562% RETURN ! Done
%1562% END;
! Now check for subroutine or function call
IF .SYMPTR[OPRSP1] EQL FNNAME1
THEN IF (NOT .SYMPTR[IDATTRIBUT(FENTRYNAME)])
THEN IF (NOT .SYMPTR[IDATTRIBUT(DUMMY)])
%1434% THEN IF NOT (.SYMPTR[IDATTRIBUT(INEXTERN)] AND
%1434% .SYMPTR[VALTYPE] EQL CHARACTER AND .INARGBLOCK EQL 1)
THEN
BEGIN
ROUIMFUN(.INSTRUCTION,.SYMPTR[IDSYMBOL]);
RETURN
END;
! Here if not a function call or subroutine call, unless it is a
! character external function in an argument block since they now have
! descriptors.
RDATWD _ .INSTRUCTION;
%1245% ! Don't try to output polish for character descriptors
%1245% IF .SYMPTR[IDPSECT] EQL PSCODE
%1245% THEN
%1245% BEGIN
%1526% ZCODE(PSCODE,PSCODE);
%1245% RETURN
%1245% END;
! Does an array offset look like a hiseg address ?
IF EXTSIGN(.INSTRUCTION<RIGHT>) LSS -#400
%1525% AND NOT EXTENDED ! Don't need kludge for psects
THEN ! Yes, do polish fixup for instruction
BEGIN
RDATWD<RIGHT> _ 0;
%1526% ZCODE(PSABS,PSCODE);
IF NOT .SYMPTR[IDATTRIBUT(INCOM)] ! In common ?
THEN ! No, normal fixup
%1245% BEGIN
%1245% RDATWD _ ADD^18+1; !MEANS NEXT WD IS FULL WD OPERAND
%1245% ZOUTBLOCK(RPOLISH,RELN);
%1245% RDATWD _ EXTSIGN(.INSTRUCTION<RIGHT>); !FULL WORD
%1245% ZOUTBLOCK(RPOLISH,RELN);
%1245% RDATWD _ 0;
%1245% ZOUTBLOCK(RPOLISH,RELRI);
%1526% RDATWD _ #777777^18 + (.HILOC+.HIORIGIN); ! Right half chained fixup,,address
%1245% ZOUTBLOCK(RPOLISH,RELRI)
END
ELSE ! Operand is in common, additive global
BEGIN ! fixup needed
R2 _ .SYMPTR[IDCOMMON];
%4530% IF .LONGUSED AND .LONGREL
%4530% THEN
%4530% BEGIN
%4530% SYM = .R2[COMNAME];
%4530% RDATWD = LADD^18 + 010 + (.SYM<SYMLENGTH>*2)-1;
%4530% ZNEWBLOCK(RLONGPOLISH);!NEXT WD IS GLOBAL REQUEST
%4530% INCR I FROM 0 TO .SYM<SYMPOINTER> - 1
%4530% DO
%4530% BEGIN !Loop to dump out name
%4530% RDATWD = @(.SYM<SYMPOINTER>)[.I];
ZNEWBLOCK(RLONGPOLISH);
%4530% END;
%4530%
%4530% RDATWD = 001001^18 + #777777;
%4530% ZNEWBLOCK(RLONGPOLISH);
%4530% RDATWD = .INSTRUCTION<RIGHT>^18 + #000777;
%4530% ZNEWBLOCK(RLONGPOLISH);
%4530% RDATWD = (.HILOC+.HIORIGIN)^18;
%4530% ZNEWBLOCK(RLONGPOLISH);
%4530% END
%4530% ELSE !SHORT SYMBOLS
%4530% BEGIN
RDATWD _ ADD^18+2; !NEXT WD IS GLOBAL REQUEST
ZOUTBLOCK(RPOLISH,RELN);
%4530% SYM = @@R2[COMNPTR];
RDATWD _ RGLOBDEF + RADIX50(); !A GLOBAL REQUEST POLISH FIXUP
ZOUTBLOCK(RPOLISH,RELN);
RDATWD _ #1777777; !1^18 + -1
ZOUTBLOCK(RPOLISH,RELN);
RDATWD _ .INSTRUCTION<RIGHT>^18+#777777;
ZOUTBLOCK(RPOLISH,RELN);
%1526% RDATWD _ (.HILOC+.HIORIGIN)^18;
ZOUTBLOCK(RPOLISH,RELL) ! Emit the fixup address
%4530% END;
END
END ! So much for strange polish
ELSE IF .SYMPTR[IDATTRIBUT(INCOM)] ! In common ?
THEN ! Yes, need additive global fixup
BEGIN
%1526% ZCODE(PSABS,PSCODE); ! Output the instruction
R2 _ .SYMPTR[IDCOMMON]; ! Get pointer to common block
! Add the address of the common block to the RH of the instruction
! when LINK defines it.
%1512% ZSYMBOL(GLB18ADDFIX,.R2[COMNAME],.HILOC,PSCODE)
END
%1526% ELSE ZCODE(.SYMPTR[IDPSECT],PSCODE) ! Not in common, normal case
END; ! of ROUSYM
ROUTINE OUTMOD(CODEPTR,COUNT)=
BEGIN
! Generates the relocatable binary instructions for the compiler.
! Also responsible for calling routines that generate the macro code
! listing and the routines that generate symbol information for the
! loader. The arguments are a pointer to the peephole buffer
! containing code to be generated, and the number of peephole buffer
! entries to emit code for.
MAP
PEEPHOLE CODEPTR,
BASE R2;
REGISTER
CODEBLOCK;
CODEBLOCK = .CODEPTR<RIGHT>;
! Output line-number/octal-location map only if no macro listing
IF .FLGREG<LISTING>
THEN INCR I FROM 0 TO .COUNT-1
DO IF .FLGREG<MACROCODE>
%4535% THEN LSTINST ((.CODEBLOCK)[.I*PBFENTSIZE])
ELSE IF .FLGREG<MAPFLG>
%4535% THEN LINEMAP ((.CODEBLOCK)[.I*PBFENTSIZE]);
! Start relocatable binary generation if requested
IF .FLGREG<OBJECT>
THEN INCR I FROM 0 TO (.COUNT-1)
DO
BEGIN
IF .CODEPTR[.I,PBFSYMPTR] GTR PBFENTRY ! Symbolic reference ?
%1434% THEN ROUSYM(.CODEPTR[.I,PBFINSTR],.CODEPTR[.I,PBFSYMPTR],0)
ELSE CASE .CODEPTR[.I,PBFSYMPTR] OF
SET
! Either not symbolic, or label or function call or call to a dotted
! library function
! Label address - pointer to label in RH of instruction
% PBFLABREF % ROURLABEL(.CODEPTR[.I,PBFINSTR]);
! No symbolic address, output the instruction
% PBFNOSYM % BEGIN
RDATWD = .CODEPTR[.I,PBFINSTR];
%1526% ZCODE(PSABS,PSCODE)
END;
! Implicitly called function, RH points directly to SIXBIT name
% PBFIMFN % ROUIMFUN(.CODEPTR[.I,PBFINSTR],
%4527% ONEWPTR( @(.CODEPTR[.I,PBFADDR]) ));
! Explicitly called function, RH points to STE for name
% PBFEXFN % BEGIN
R2 = .CODEPTR[.I,PBFADDR];
ROUIMFUN(.CODEPTR[.I,PBFINSTR],.R2[IDSYMBOL])
END;
! Used in OUTMDA, not here
% PBF2LABREF % BEGIN
END;
! Used in OUTMDA, not here
% PBF2NOSYM % BEGIN
END;
! Used in OUTMDA, not here
% PBFFORMAT % BEGIN
END;
! Used in OUTMDA, not here
% PBFLLABREF % BEGIN
END;
! A global entry symbol definition
% PBFENTRY % BEGIN
! Special case for global entry definitions (generates no data or instructions)
GMULENTRY(.CODEPTR[.I,PBFADDR]);
! Decrement HILOC to make up for the increment coming at end of the
! INCR loop so that the next instruction will have the same address as
! that assigned to the entry symbol
HILOC = .HILOC-1
END
TES;
! If there are labels on the present peephole buffer entry, output them
IF .CODEPTR[.I,PBFLABEL] NEQ 0
THEN
BEGIN REGISTER BASE LINLABEL;
LINLABEL = .CODEPTR[.I,PBFLABEL];
DO ! Loop over all labels
BEGIN
%636% IF .LINLABEL[SNDEFINED]
THEN
BEGIN
RDATWD = .LINLABEL[SNADDR]^18+.HILOC;
ZOUTBLOCK(RLOCAL,RELB)
END;
LINLABEL[SNSTATUS] = OUTPBUFF; !DEFINE IT (HAS
! PASSED THRU
! PBUFF)
LINLABEL[SNADDR] = .HILOC; !DEFINING THE
! SYMBOL NOW
%636% LINLABEL[SNDEFINED] = TRUE
END WHILE (LINLABEL = .LINLABEL[SNNXTLAB]) NEQ 0
END;
! If this instruction starts a source line and the user specified the
! /DEBUG:LABELS switch, output a label for this instruction.
IF .CODEPTR[.I,PBFISN] GTR 0 AND .FLGREG<DBGLABL>
THEN DEFISN(.CODEPTR[.I,PBFISN]);
HILOC = .HILOC + 1 !INCREMENT HISEG AVAILABLE LOCATION
END; !END OF INCR LOOP
.VREG
END; ! of OUTMOD
GLOBAL ROUTINE OUTMDA(ARPTR,ARCOUNT)=
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! Outputs to the REL file the arg blocks for all statements that use
! them. These include I/O lists, function or subroutine argument
! lists, and other arg lists.
!
! The call to this routine is made with a pointer to the argument code
! words and a count of the number of words to generate. The format of
! the block of words is the similar to that used in a call to OUTMOD
! to output instructions.
!
! FORMAL PARAMETERS:
!
! Unknown
!
! IMPLICIT INPUTS:
!
! Unknown
!
! IMPLICIT OUTPUTS:
!
! Unknown
!
! ROUTINE VALUE:
!
! Unknown
!
! SIDE EFFECTS:
!
! Unknown
!
!--
MAP
BASE R1:R2;
%4535% REGISTER PPEEPFRAME PTR; ! Register to use in macros;
MACRO
%4535% ILABEL = (PTR = (@ARPTR)[.I]; PTR[PBFLABEL]) $,
%4535% IADDRPTR = (PTR = (@ARPTR)[.I]; PTR[PBFSYMPTR]) $,
%4535% ILADDR = (PTR = (@ARPTR)[.I]; PTR[PBFLINSTR]) $,
%4535% IRADDR = (PTR = (@ARPTR)[.I]; PTR[PBFADDR]) $,
%4535% IARGWD = (PTR = (@ARPTR)[.I]; PTR[PBFINSTR]) $;
LOCAL
%2337% BASE CNODE;
%4535% INCR I FROM 0 TO (.ARCOUNT-1) * PBFENTSIZE BY PBFENTSIZE
DO
BEGIN
IF .FLGREG<LISTING>
THEN IF .FLGREG<MACROCODE>
THEN
BEGIN
CRLF;
HEADCHK();
CHROUT("?I");
! Subroutine SIXBIT name should not print location 0 (none at all!)
%646% IF .CODELINES<RIGHT> NEQ 0
%646% THEN
%646% BEGIN
%646% R2<LEFT> = .CODELINES<RIGHT>;
%646% ZOUTOCT()
%646% END;
%646% CHROUT("?I");
CODELINES = .CODELINES+1;
IF .ILABEL NEQ 0
THEN
BEGIN
ZLABLMAK(.ILABEL);
CHROUT(":")
END;
CHROUT("?I")
END
ELSE IF .FLGREG<MAPFLG>
THEN CODELINES = .CODELINES+1; ! Update octal location counter
! for entry points
SELECT .IADDRPTR OF NSET
PBFLABREF: EXITSELECT
(
IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE> THEN
BEGIN
R2<LEFT> = .ILADDR; ZOUTOCT();
COMCOM(); ! ",,"
ZLABLMAK(.IRADDR);
END;
IF .FLGREG<OBJECT> THEN
ROURLABEL(.IARGWD);
);
PBFNOSYM: EXITSELECT
(
IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE> THEN
BEGIN
R2<LEFT> = .ILADDR; ZOUTOCT();
COMCOM();
R2<LEFT> = .IRADDR; ZOUTOCT();
END;
IF .FLGREG<OBJECT> THEN
%1526% (RDATWD = .IARGWD; ZCODE(PSABS,PSCODE));
);
PBF2NOSYM: EXITSELECT
(
IF .FLGREG<LISTING>
THEN IF .FLGREG<MACROCODE>
THEN
BEGIN
R2<LEFT> = .ILADDR; ZOUTOCT();
COMCOM();
R2<LEFT> = .IRADDR; ZOUTOCT();
END;
IF .FLGREG<OBJECT>
THEN
BEGIN
RDATWD = .IARGWD;
%1526% ZCODE(PSABS,PSCODE)
END;
);
PBFIMFN: EXITSELECT
(
IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE>
THEN
BEGIN
R2<LEFT> = .ILADDR; ZOUTOCT();
COMCOM();
%4527% R2 = CNODE = ONEWPTR( @.IRADDR );
ZOUTSYM();
END;
IF .FLGREG<OBJECT>
%4527% THEN ROUIMFUN(.IARGWD, .CNODE);
);
PBFEXFN: EXITSELECT
(
IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE> THEN
BEGIN
R2<LEFT> = .ILADDR; ZOUTOCT();
COMCOM();
R2 = .IRADDR; R2 = .R2[IDSYMBOL]; ZOUTSYM();
END;
IF .FLGREG<OBJECT> THEN
(R2 = .IRADDR; ROUIMFUN(.IARGWD,.R2[IDSYMBOL]));
);
PBF2LABREF: EXITSELECT
%1526% (CGERR(); ! Label,,label is no longer used as of V6
! IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE> THEN
! BEGIN
! ZLABLMAK(.ILADDR); COMCOM(); ZLABLMAK(.IRADDR);
! END;
! IF .FLGREG<OBJECT> THEN
! (R1 = .ILADDR; R2 = .IRADDR;
! RDATWD = .R1[SNADDR]^18 + .R2[SNADDR];
! ZOUTBLOCK(RCODE,RELB);
! );
);
PBFFORMAT: EXITSELECT
BEGIN
REGISTER BASE TPTR; !TEMPORARY PTR
IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE> THEN
BEGIN
R2<LEFT> = .ILADDR; ZOUTOCT();
COMCOM();
!TYPE THE P LABEL FOR THE RIGHT HALF
TPTR = .IRADDR; !PTR TO THE FORMAT STMNT
TPTR = .TPTR[SRCLBL]; !STMNT NUMBER TABLE ENTRY FOR THE LABEL
R1 = .TPTR[SNUMBER]; ZOUDECIMAL(); !THE STMNT NUMBER OF THE FORMAT
CHROUT("P"); !FOLLOWED BY "P"
END;
IF .FLGREG<OBJECT> THEN
BEGIN
TPTR = .IRADDR; !PTR TO FORMAT STMNT
RDATWD = .ILADDR^18 !LEFT HALF OF OUTPUT WD COMES DIRECTLY FROM PBUFF
+ .TPTR[FORADDR]; !RIGHT HALF IS REL ADDR OF THE FORMAT STMNT
%1526% ZCODE(PSDATA,PSCODE)
END;
END;
OTHERWISE:
BEGIN
IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE>
THEN
BEGIN ! /LIST/MACRO
CNODE = .IADDRPTR;
%2337% IF .CNODE[OPRCLS] EQL EFIWREF
%2337% THEN
%2337% BEGIN ! EFIW
%2337%
%2337% MAP OBJECTCODE R2;
%2337%
%2337% R2<LEFT> = .ILADDR;
%2337% R2[OTSIND] = 1; ! Indirect
%2337% R2[OTSINX] = 0; ! No register
%2337% ZOUTOCT(); ! Arg in R2<LEFT>
%2337% COMCOM(); ! ",,"
%2337%
%2337% LSTEFIW(.CNODE); ! List EFIW
%2337%
%2337% END ! EFIW
%2337% ELSE
%2337% BEGIN ! Not EFIW
R2<LEFT> = .ILADDR;
ZOUTOCT();
COMCOM();
R2 = .IADDRPTR;
IF .R2[OPERSP] EQL CONSTANT
%650% THEN
%650% BEGIN ! Constant
![650] IN ARGUMENT LISTS, TAKE
![650] CARE OF ARGUMENTS BASED
![650] ON THEIR TYPE.
%650% LOCAL TMP;
TMP = .(@ARPTR)[.I+2]<23,4>;
! Output constant depending
! on what type it is.
%650% IF .TMP EQL #17
%1245% THEN ZSOUTCON(.R2) ! Hollerith
%1245% ELSE IF .TMP EQL #15
%1245% THEN
%1245% BEGIN ! Character
%1245%
%1245% STRNGOUT(UPLIT
%1245% ASCIZ
%1245% '.HSCHD');
%1245% R1 = .R2[IDADDR]
%1245% - .CHDSTART;
%2311% ZOUSMOFFSET(); !OUTPUT 18 BIT OFFSET
%1245% END
%1245% ELSE
%650% IF .R2[DBLFLG]
%650% THEN
%650% BEGIN !DP OR COMPLEX CONSTANT
%650% TMP = .R2[CONST2];
%650% R2 = .R2[CONST1];
%650% ZDOUTCON(.TMP)
%650% END
%650% ELSE
%650% BEGIN
%650% IF .R2[VALTYPE] EQL REAL
%650% THEN R2 = .R2[CONST1]
%650% ELSE R2 = .R2[CONST2];
%650% ZOUTCON();
%650% END;
%650%
%650% END ! Constant
ELSE
BEGIN ! Not constant
R2 = .R2[IDSYMBOL];
ZOUTSYM();
R2 = .IADDRPTR;
%2311% !Output offset
%1251% IF (R1 = EXTSIGN(.IRADDR
%1251% - .R2[IDADDR])) NEQ 0
%2311% THEN ZOUSMOFFSET();
END; ! Not constant
%2337% END; ! Not EFIW
END; ! /LIST/MACRO
%1434% IF .FLGREG<OBJECT> THEN ROUSYM(.IARGWD,.IADDRPTR,1);
END;
TESN;
IF .FLGREG<OBJECT>
THEN
BEGIN ! Create .REL file
IF .ILABEL NEQ 0
THEN
BEGIN
REGISTER BASE LABENT;
LABENT = .ILABEL;
%636% IF .LABENT[SNDEFINED]
THEN
BEGIN
RDATWD = .LABENT[SNADDR]^18+.HILOC;
ZOUTBLOCK(RLOCAL,RELB)
END;
LABENT[SNSTATUS] = OUTPBUFF; !THRU THE OUTPUT BUFFFER
LABENT[SNADDR] = .HILOC; !DEFINING THE SYMBOL NOW
%636% LABENT[SNDEFINED] = TRUE;
END;
HILOC = .HILOC + 1; !INCREMENT HISEG AVAILABLE LOCATION
END; ! Create .REL file
END; !Of INCR I DO
END; ! of OUTMDA
GLOBAL ROUTINE ZENDALL =
!++
! FUNCTIONAL DESCRIPTION:
!
! Finishes output of REL file for current program unit. Dumps
! symbol table. Defines global symbol(s) for start of main
! program. Flushes symbol, local fixup and main rel buffers.
! Outputs type 1120 (argument descriptor), type 7 (start), type
! 23 (psect break) and type 5 (end) rel blocks. Puts LINK
! switches in the object file in ASCII.
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! ENTADDR Address of the entry vector (relative to
! beginning of lowseg). This contains valid
! data only under /EXTEND.
!
! F2<EXTENDFLAG> Flag for /EXTEND.
!
! FLGREG<PROGTYP> Distinguishes main programs from other kinds
! of program units.
!
! PROGNAME Name of main program from PROGRAM statement
!
! PSECTS Relocation counters of all the psects. Output
! as the psect breaks in type 23 blocks.
!
! IMPLICIT OUTPUTS:
!
! RDATWD Smashed numerous times by output to REL buffer.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! Outputs many kinds of REL blocks to the object file.
!
!--
BEGIN
BIND
%1564% PDVTEXT = PLIT(ASCIZ '/SYMSEG:PSECT:.DATA./PVBLOCK:PSECT:.CODE.');
! Note: The length of every PLIT (in words) is stored as the word
! preceding the PLIT. Hence, in the last example, .PDVTEXT[-1] = 9.
MAP RELBUFF
SYMRLBF: ! Holds type 2 and 1070 symbol data
LOCRLBF: ! Holds type 10 local fixup data
MAINRLBF; ! Holds all other types of data
LOCAL
%1525% MYRELBUF[3]; ! Holds type 22 block for E/A
! Dump the symbol table to REL file. This merely stuffs data
! into SYMRLBF, it does not guarantee that the symbols are
! output to the rel file yet.
%4531% DMPSYMTAB();
! Dump any local requests, global requests, and symbol definitions
! that are still in their buffers
DMPMAINRLBF(); ! Must output any code blocks to the REL file
! before dumping local and global requests
! (This routine call only dumps MAINRLBF)
! Put out a global symbol for main program so LINK can warn
! about two main programs.
IF .FLGREG<PROGTYP> EQL MAPROG THEN
BEGIN
%4527% ZSYMBOL(GLBDEF,ONEWPTR(SIXBIT 'MAIN.'),.STADDR,PSCODE);
%705% ! If a real program name was given to the program, use it
%705% ! as an entry point for the main program - this is the only
%705% ! way (short of a MACRO program) to get this effect.
%4527% IF @@PROGNAME<SYMPOINTER> NEQ SIXBIT 'MAIN.'
%1512% THEN ZSYMBOL(GLBDEF,.PROGNAME,.STADDR,PSCODE)
END;
IF .SYMRLBF[RDATCNT] NEQ 0
THEN
%1512% BEGIN
%1512% IF .SYMRLBF[RTYPE] EQL RSYMBOL
%1512% THEN DMPRLBLOCK(SYMRLBF,.SYMRLBF[RDATCNT]+2)
%1512% ELSE DMPRLBLOCK(SYMRLBF,.SYMRLBF[RDATCNT]+1)
%1512% END;
%1614% ! Output the argument checking rel blocks for subprogram calls.
%1614% ! We output it here so that Link will have the symbol table
%1614% ! values for better error message diagnostics.
%2433% ZARGCHECK();
IF .LOCRLBF[RDATCNT] NEQ 0 ! Anything left in the fixup buffer ?
THEN ! Yes, dump it
BEGIN
! We always set the default psect index every time we
! output a block which depends on it. This is because
! LINK is suspected of destroying the variable that
! holds the default during the processing for some
! blocks. It will work if it is set before every
! block that depends on it, however.
%1525% IF EXTENDED ! Psected object code ?
%1525% THEN ! Yes, set the default psect index
%1525% BEGIN
%1525% MYRELBUF[0] = RPSECTORG^18 OR 1;
%1525% MYRELBUF[1] = 0; ! No relocation
%1525% MYRELBUF[2] = PXCODE; ! All local fixups are for code
%1525% DMPRLBLOCK(MYRELBUF,3)
%1525% END;
DMPRLBLOCK(LOCRLBF,.LOCRLBF[RDATCNT]+2)
END;
IF .FLGREG<PROGTYP> EQL MAPROG
THEN
BEGIN
%1525% IF EXTENDED ! If doing psected object code, then set the
%1525% THEN ! default psect index. See comment above
%1525% BEGIN ! about why we always set the index
%1564% DMPRLBLOCK(PDVTEXT,.PDVTEXT[-1]); ! Pass LINK switches
%2334% RDATWD = PXDATA; ! Relocate by .DATA.
%1525% ZOUTBLOCK(RPSECTORG,RELN);
%2334% RDATWD = ENTVECSIZE^18 OR .ENTADDR ! Entry vector
%1525% END
%1526% ELSE RDATWD = .STADDR + .HIORIGIN; ! Not psected, hisegize
! the start address
ZOUTBLOCK(RSTART,RELRI) ! Start address block
END;
! Time to output the segment breaks or psect breaks (type 5 or 23)
%1525% IF EXTENDED ! Psected REL file ?
%1525% THEN ! Yes, output psect breaks
%1525% BEGIN ! Psected REL files tell LINK where their psects end
%1525%
%1525% RDATWD = PXCODE; ! Psect index
%1525% ZOUTBLOCK(RPSECTEND,RELN);
%1525% RDATWD = .HILOC; ! Psect break
%1525% ZOUTBLOCK(RPSECTEND,RELRI);
%1525% DMPMAINRLBF(); ! Only one psect per block
%1525%
%1525% RDATWD = PXDATA; ! Again for .DATA.
%1525% ZOUTBLOCK(RPSECTEND,RELN);
%1525% RDATWD = .LOWLOC;
%1525% ZOUTBLOCK(RPSECTEND,RELRI);
%1525% DMPMAINRLBF();
%1525%
%1525% RDATWD = PXLARGE; ! And again for .LARG.
%1525% ZOUTBLOCK(RPSECTEND,RELN);
%1525% RDATWD = .LARGELOC;
%1525% ZOUTBLOCK(RPSECTEND,RELRI);
%1525% DMPMAINRLBF();
%1525%
%1525% ! Even though we have an entirely psected REL file,
%1525% ! the signal that LINK expects to recieve to tell it
%1525% ! that it is done with a program unit is the reading
%1525% ! of a type 5 END block. So we will output one, but
%1525% ! it will only give the lower segment break, and that
%1525% ! will be 0. (Just putting out header and relocation
%1525% ! words would be better, but it gets LINK upset).
%1525%
%1525% RDATWD = 0; ! Say as little as possible
%1525% ZOUTBLOCK(REND,RELN) ! Output the block
%1525% END
%1525% ELSE ! NOT EXTENDED
%1525% BEGIN
%1526% RDATWD = .HILOC+.HIORIGIN;
ZOUTBLOCK(REND,RELRI);
RDATWD = .LOWLOC;
ZOUTBLOCK(REND,RELRI)
%1525% END;
IF .MAINRLBF[RDATCNT] NEQ 0
THEN DMPRLBLOCK(MAINRLBF,.MAINRLBF[RDATCNT]+2)
END; ! of ZENDALL
ROUTINE GMULENTRY(MULSYM)=
BEGIN
! Generate a global definition in rel file for multiple entry names.
! OUTMOD must have already been called to dump any code in PBUFF.
MAP BASE MULSYM;
%1512% ZSYMBOL(GLBDEF,.MULSYM[IDSYMBOL],.HILOC,PSCODE)
END; ! of GMULENTRY
GLOBAL ROUTINE LSTFORMATS=
!*** [1433] Rewritten to print multiple words of format text per line
%(***************************************************************************
Routine to list all the format stmnts in a program.
Assumes that the global "FORMPTR" points to the 1st
FORMAT stmt. Each FORMAT stmt is linked to the
next by the "FMTLINK" field.
***************************************************************************)%
BEGIN
!(*** Define some handy macros: ***)
!(*** TAB outputs a tab ***)
MACRO TAB = CHROUT(#11) $;
BIND LINEWIDTH = 55; !Number of characters of format text per line
LOCAL CHARSLEFT; !Number of chars left to print in format text
LOCAL LISTLABEL; !Flag controling the printing of the label
! on the first line of format text
LOCAL BASE SNENTRY; !The stmt number table entry for the stmt
! number for a given format stmt
REGISTER BASE FORMAT; !Ptr to the format stmt being printed
REGISTER RLOC; !Relative loc in low seg of the wd being listed
REGISTER TEXTPTR; !Byte ptr to the character in the string
! to be listed
!(*** If there are no format stmnts in this program ***)%
IF (FORMAT_.FORMPTR<LEFT> ) EQL 0
THEN RETURN;
%(*** Print header ***)%
IF ( PAGELINE_.PAGELINE-4) LEQ 0
THEN ( HEADING(); PAGELINE_.PAGELINE-4);
STRNGOUT(PLIT ASCIZ'?M?J?M?JFORMAT STATEMENTS (IN LOW SEGMENT):?M?J?M?J');
%(*** List all format stmts in program ***)%
UNTIL .FORMAT EQL 0
DO
BEGIN !Loop to list all format stmts in program
!(*** The first line for this format--the size word ***)
DECOUT(.FORMAT[SRCISN]); !ISN line number of the format stmt
TAB;
OCTOUT(.FORMAT[FORADDR]-1); !Relative address of the count of
! the number of words in the format
TAB;
TAB;
OCTOUT(.FORMAT[FORSIZ]); !Count of number of words in format
CRLF;
HEADCHK();
!(*** Second through N lines--Format text ***)
TEXTPTR = (.FORMAT[FORSTRING])<36,7>; !Byte pointer to fmt text
CHARSLEFT = .FORMAT[FORSIZ] * 5; !Five chars per word
LISTLABEL = TRUE; !Label goes on 1st line
RLOC = .FORMAT[FORADDR];
!(*** Loop while there is text in this format to be listed ***)
WHILE .CHARSLEFT GTR 0
DO
BEGIN ! While text to print in this format
TAB;
OCTOUT(.RLOC); !Relative address of the 1st wd of the
! format text
TAB;
!(*** If this is the first line of text for this ***)
!(*** then list the stmt label of the format ***)
IF .LISTLABEL
THEN
BEGIN ! List the statement label
!(*** Get the label table entry for format ***)
!(*** Print the stmt number followed by a ***)
!(*** "P" and a colon. ***)
SNENTRY_.FORMAT[SRCLBL];
DECOUT(.SNENTRY[SNUMBER]);
CHROUT("P");
CHROUT(":");
!(*** Any other lines of text for this ***)
!(*** format do have stmt labels ***)
LISTLABEL = FALSE;
END; ! of list the statement label
TAB;
!(*** Output the at least 'LINEWIDTH' chars of ***)
!(*** format text ***)
DECR I FROM (IF LINEWIDTH LSS .CHARSLEFT THEN LINEWIDTH ELSE .CHARSLEFT) TO 1
DO
BEGIN
CHR = SCANI(TEXTPTR);
IF .CHR NEQ 0 THEN CHROUT(.CHR);
END;
CRLF;
HEADCHK();
CHARSLEFT = .CHARSLEFT - LINEWIDTH;
RLOC = .RLOC + LINEWIDTH / 5;
END; ! of while text to print in this format
FORMAT_.FORMAT[FMTLINK]; !Go on to the next format stmt
END; ! of loop to list all format stmts in program
END; ! of LSTFORMATS
ROUTINE LSTEFIW(EFIW)= ![2337] New
!++
! FUNCTIONAL DESCRIPTION:
!
! Output EFIW references to the listing file. (/MACRO is assumed
! to have been given).
!
! Format:
!
! "@[.EFIW " [ name ] [ ( "+" | "-" ) offset ] [ "(" register ")" ] "]"
!
! FORMAL PARAMETERS:
!
! EFIW The EFIW reference to output.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! CHR Global argument to LSTOUT in CHROUT.
!
! R1 Global argument to ZOUOFFSET.
!
! R2 Global argument to ZOUTSYM.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! An EFIW reference is output to the listing file.
!
!--
BEGIN
MAP BASE EFIW,
BASE R2;
REGISTER
BASE SYMTAB; ! Pointer to the symbol table reference.
SYMTAB = .EFIW[EFSYMPTR]; ! Symbol table pointer
STRNGOUT(UPLIT ASCIZ '@[.EFIW '); ! Indirection through literal
! Output symbol name
%2464% IF .EFIW[EFEXTERN] NEQ PSABS ! Absolute reference?
%2464% THEN ! Nope, output the variable name
%2464% BEGIN ! NOT PSABS
R2 = .SYMTAB[IDSYMBOL]; ! Symbol; argument to ZOUTSYM
ZOUTSYM();
%2464% END; ! NOT PSABS
IF (R1 = .EFIW[EFY]) NEQ 0 ! Does offset exist?
THEN
BEGIN ! Has offset
! If negative, then extend the sign of the
! offset.
IF .EFIW[EFYSIGN] THEN R1 = .R1 OR #770000000000;
%2464% IF .EFIW[EFEXTERN] NEQ PSABS ! Absolute reference?
%2464% THEN R1 = .R1 - .SYMTAB[IDADDR]; ! Nope, subtract base
! Output ("+" | "-") offset if there still is one.
IF .R1 NEQ 0 THEN ZOUOFFSET();
END; ! Has offset
! Output index field, if it exists
IF .EFIW[EFX] NEQ 0
THEN
BEGIN
! "(" index ")"
CHROUT("(");
OCTOUT(.EFIW[EFX]); ! Index register
CHROUT(")");
END;
CHROUT("]"); ! End of literal
END; ! of LSTEFIW
END
ELUDOM