Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_V7wLink_Feb83
-
listou.bli
There are 26 other files named listou.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/DCE/SJW/JNG/TFV/CKS/RVM/AHM/CDM
MODULE LISOUT(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND LISTOV = 7^24 + 0^18 + #1614; ! Version Date: 16-Aug-82
%(
***** 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.
***** End Revision History *****
)%
! 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 GMULENTRY;
EXTERNAL
%1614% ARGCHK, ! If TRUE, then output argument checking rel blocks.
CHDSTART,
%1526% CGERR, ! Fatal error message
CODELINES,
%1547% COMTSIZ, ! Total size of all common blocks in words
%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,
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
LOWLOC, ! Current lowseg available location
LSTOUT,
MAINRLBF, ! Rel file buffer
OPMNEM,
OUTMSG,
%645% PAGELINE,
PROGNAME,
%1274% QANCHOR, ! Start of .Qnnnn variable linked list
RADIX50,
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,
%650% STRNGOUT,
SYMRLBF, ! Rel file buffer
SYMTBL,
%1614% ZARGCHECK, ! Argument checking rel block routine.
%1526% ZCODE, ! Outputs type 1 or 1010 data blocks to rel file
ZLABLMAK,
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,
ZOUTBLOCK,
ZOUTMSG,
ZOUTOCT,
ZOUOFFSET,
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
ROUTINE DMPSYMTAB=
BEGIN
!DUMPS THE SYMBOL TABLE TO REL FILE
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
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
%1512% ZSYMBOL(LOCSUPDEF,SIXBIT '.VEND',.ENDSCAA,PSDATA);
![1003] Output the global symbol ..GFL. if compiling /GFLOAT for FORDDT support
%1003% IF .GFLOAT
%1512% THEN ZSYMBOL(GLBSUPDEF,SIXBIT '..GFL.',1,PSABS); ! Give it the value of 1
! 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"
%1526% ZSYMBOL(LOCDEF,.LABL,.SYMPTR[SNADDR],.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;
%1406% SYMPTR = .SYMPTR[CLINK]
%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% ZSYMBOL(LOCDEF,.LABL,.FPTR[FORADDR]+.FPTR[FORSIZ]-1,PSDATA); ! Address of last word of string
FPTR_.FPTR[FMTLINK] !GO ON TO NEXT FORMAT
END;
END;
END; ! of DMPSYMTAB
ROUTINE ZSIXBIT(ZVAL)= !CONVERT ZVAL TO SIXBIT SYMBOL
BEGIN
R2 _ SIXBIT 'P';
DECR I FROM 5 TO 0 DO
BEGIN
R2 _ .R2^(-6); R2<30,6> _ (.ZVAL MOD 10) + #40; ZVAL _ .ZVAL/10;
IF .ZVAL EQL 0 THEN EXITLOOP;
END;
RETURN .R2
END; ! of ZSIXBIT
%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=
BEGIN
CHR_",";LSTOUT();LSTOUT()
END; ! of COMCOM
ROUTINE LSTINST(IPTR)=
BEGIN
%
ROUTNE LISTS ON LISTING DEVICE THE MACRO -10 MNEMONICS OF THE INSTRUCTIONS BEING GENERATED
%
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;
!
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 ROUTINE ZMAKLABL
%734% LOCAL DINSTF; !DOUBLE WORD INSTRUCTION FLAG
IF .HEADRSW NEQ #777777
THEN( CODELINES _ 0;
HEADRSW _ #777777
);
CRLF;
HEADCHK();
IF (R1 _ .IISN) GEQ 0
THEN IF .R1 EQL 0 THEN ( CHR _ "*"; LSTOUT()) ELSE ZOUDECIMAL();
CHR _ #11; LSTOUT(); !TAB
IF .IADDRPTR EQL PBFENTRY
THEN(MAP BASE R2;
!ENTRY NAME TAKES UP ONE LISTING LINE - ACCOUNT FOR IT
%645% CRLF; PAGELINE_.PAGELINE-1; CHR_#11; LSTOUT();
R2 _ .IEFFADDR; R2 _ .R2[IDSYMBOL]; ZOUTSYM();
CHR _ ":"; LSTOUT();
RETURN
);
!
!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 (
LOCAL BASE LABPT;
LABPT _ .ILABEL;
DO
(
ZLABLMAK(.LABPT);
CHR _ ":"; LSTOUT(); CRLF; HEADCHK();
CHR _ #11; LSTOUT(); LSTOUT(); !TAB
) WHILE (LABPT _ .LABPT[SNNXTLAB]) NEQ 0;
);
IF (R1_.IISN) GTR 0 AND .FLGREG<DBGLABL> !IF THE USER SPECIFIED THE "DEBUG" SWITCH
! THEN IFTHIS INSTR STARTS A STMNT, LIST
! AN "L" LABEL ON THIS INSTR
THEN ZOUDLB();
CHR _ #11; LSTOUT(); !TAB
%734% DINSTF_0;
!NOW DO THE INSTRUCTION LISTING
!
IF .IOPCODE NEQ 0
THEN(
!First mnemonic is now GFAD (#103)
%761% OPPOINT _ (OPMNEM-#103)[.IOPCODE]<0,6>; !MNEMONIC TABLE POINTER
INCR I FROM 0 TO 5 DO
(CHR _SCANI(OPPOINT,CHR); !GET A CHARACTER
IF(CHR _ .CHR + #40 ) LEQ #100 THEN EXITLOOP;
%734% IF .I EQL 0 THEN DINSTF_.CHR; ! PICK UP FIRST CHAR OF INSTRUCTION
LSTOUT()
)
);
CHR _ #11; LSTOUT(); !TAB
!AC FIELD
!
IF .IAC LEQ 7
THEN (CHR _ .IAC + #60; LSTOUT())
ELSE (CHR _ "1"; LSTOUT();
CHR _ (.IAC + #50); LSTOUT()
);
CHR _ ","; LSTOUT();
!
!INDIRECT BIT
!
IF .IINDIR NEQ 0 THEN (CHR _ "@"; LSTOUT());
!
!ADDRESS
!
BEGIN BIND ZADDR = IADDRPTR; MAP BASE ZADDR;
IF .IADDRPTR GTR PBF2LABREF
THEN
(IF SYMBOL(ZADDR)
THEN ( R2 _ .ZADDR[IDSYMBOL];
ZOUTSYM()
)
ELSE IF .ZADDR[OPERSP] EQL CONSTANT
THEN ( IF .ZADDR[DBLFLG] OR .ZADDR[VALTYPE] EQL REAL
THEN(IF .ZADDR[CONADDR] EQL .IEFFADDR
![650] IN THE CONSTANT CASE, DISTINGUISH BETWEEN SINGLE AND
![650] DOUBLE WORD CONSTANTS.
%650% THEN (R2 _ .ZADDR[CONST1];
![734] ONLY PRINT AS DOUBLE OCTAL IF INSTRUCTION IS DOUBLE WORD, I. E.,
![734] THE FIRST CHARACTER BEGINS WITH "D" (AVOID CAMXX).
![761] also if instruction starts with "G" (GFAD, etc.)
%761% IF .ZADDR[DBLFLG] AND
%761% (.DINSTF EQL "D" OR .DINSTF EQL "G")
%761% THEN RETURN ZDOUTCON(.ZADDR[CONST2]))
ELSE R2 _ .ZADDR[CONST2]
)
ELSE R2 _ .ZADDR[CONST2]; !ELSE INTEGER OR LOGICAL OR BYTE
RETURN ZOUTCON()
)
ELSE
(R2_.ZADDR[IDSYMBOL]; ZOUTSYM(););
%1251% IF (R1 _ EXTSIGN(.IEFFADDR -.ZADDR[IDADDR])) NEQ 0 THEN ZOUOFFSET();
)
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
(R2 _@(.IEFFADDR);
ZOUTSYM()
)
ELSE IF .IADDRPTR GTR 0 !NO SYMBOLIC ADDR
THEN (R2<LEFT> _ .IEFFADDR; ZOUTOCT()) !IMMEDIATE MODE VALUE
ELSE ZLABLMAK(.IEFFADDR);
END;
!
!INDEX FIELD
!
IF .IINDEX NEQ 0
THEN ( CHR _ "("; LSTOUT();
IF .IINDEX LEQ 7
THEN (CHR _ .IINDEX +#60; LSTOUT())
ELSE (CHR _ "1"; LSTOUT();CHR _ .IINDEX +#50; LSTOUT()
);
CHR _ ")"; LSTOUT();
);
END; ! of LSTINST
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.
%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 ROUSYM(INSTRUCTION,INSADDR,INARGBLOCK)=
BEGIN
! Relocatable symbolic output
MACRO ADD=3$,SUBT=4$;
MAP BASE R2;
LOCAL BASE SYMPTR; SYMPTR _ .INSADDR<RIGHT>;
IF NOT SYMBOL(SYMPTR) ! 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
RDATWD _ ADD^18+2; !NEXT WD IS GLOBAL REQUEST
ZOUTBLOCK(RPOLISH,RELN);
R2 _ .SYMPTR[IDCOMMON]; R2 _ .R2[COMNAME];
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
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>
THEN LSTINST ((.CODEBLOCK)[.I*3])
ELSE IF .FLGREG<MAPFLG>
THEN LINEMAP ((.CODEBLOCK)[.I*3]);
! 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],@(.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
! 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.
MAP
BASE R1:R2;
MACRO
ILABEL = (@ARPTR)[.I+1]<LEFT>$,
IADDRPTR = (@ARPTR)[.I+1]<RIGHT>$,
ILADDR = (@ARPTR)[.I+2]<LEFT>$,
IRADDR = (@ARPTR)[.I+2]<RIGHT>$,
IARGWD = (@ARPTR)[.I+2]<FULL>$;
INCR I FROM 0 TO (.ARCOUNT-1)*3 BY 3
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();
R2 = @.IRADDR; ZOUTSYM();
END;
IF .FLGREG<OBJECT> THEN
ROUIMFUN(.IARGWD,@.IRADDR);
);
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
(
R2<LEFT> = .ILADDR; ZOUTOCT();
COMCOM();
R2 = .IADDRPTR;
IF .R2[OPERSP] EQL CONSTANT
![650] IN ARGUMENT LISTS, TAKE CARE OF ARGUMENTS BASED ON THEIR TYPE.
%650% THEN BEGIN
%650% LOCAL TMP;
TMP = .(@ARPTR)[.I+2]<23,4>;
%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 ASCIZ '.HSCHD');
%1245% R1 = .R2[IDADDR] - .CHDSTART;
%1245% ZOUOFFSET();
%1245% END
%1245% ELSE
%650% IF .R2[DBLFLG] THEN !DP OR COMPLEX CONSTANT
%650% (TMP = .R2[CONST2];
%650% R2 = .R2[CONST1];
%650% ZDOUTCON(.TMP))
%650% ELSE (IF .R2[VALTYPE] EQL REAL
%650% THEN R2 = .R2[CONST1]
%650% ELSE R2 = .R2[CONST2];
%650% ZOUTCON());
%650% END
ELSE (R2 = .R2[IDSYMBOL]; ZOUTSYM();
R2 = .IADDRPTR;
%1251% IF (R1 = EXTSIGN(.IRADDR - .R2[IDADDR])) NEQ 0 THEN ZOUOFFSET();
);
);
%1434% IF .FLGREG<OBJECT> THEN ROUSYM(.IARGWD,.IADDRPTR,1);
END;
TESN;
IF .FLGREG<OBJECT> THEN
(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; !OF INCR I DO
END; ! of OUTMDA
GLOBAL ROUTINE ZENDALL(STADDR,ENTADDR)=
BEGIN
! Arguments (object addresses which are relative to beginning of hiseg):
! STADDR - Start address
! ENTADDR - Address of a one word entry vector
! (this only contains valid data under /EXTEND)
! Finishes output of REL file for current program unit. Dumps symbol
! table. Dumps newly defined symbols. Outputs type 7 start, type 5
! END and type 22 psect break rel blocks. Puts LINK switches in the
! object file in ASCII.
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 SYBRLBF, it does not guarantee that the symbols are
! output to the rel file yet.
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
%1512% ZSYMBOL(GLBDEF,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.
%705% IF .PROGNAME 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.
%1614% IF .ARGCHK THEN 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
%1525% RDATWD = PXCODE;
%1525% ZOUTBLOCK(RPSECTORG,RELN);
%1576% RDATWD = 1^18 OR .ENTADDR ! One word 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 ***)
!(*** OCTOUT outputs an octal number ***)
!(*** DECOUT outputs a decimal number ***)
MACRO TAB = CHROUT(#11) $,
OCTOUT(X) = (R2<LEFT> = X; ZOUTOCT()) $,
DECOUT(X) = (R1 = X; ZOUDECIMAL()) $;
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
END ELUDOM