Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_V7wLink_Feb83
-
relbuf.bli
There are 26 other files named relbuf.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 1974, 1983
!AUTHOR: S. MURPHY/CKS/AHM/CDM
MODULE RELBUF(RESERVE(0,1,2,3), SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
GLOBAL BIND RELBUV = 7^24 + 0^18 + #1674; ! Version Date: 9-Dec-82
%(
***** Begin Revision History *****
21 ----- ----- MOVE THE DECLARATIONS FOR THE STRUCTURES RELBUFF
AND PRELBUFF TO A REQUIRE FILE.
22 ----- ----- PUT A NUMBER OF UTILITY ROUTINES USED IN MAKING
LISTINGS THAT WERE REPEATED IN BOTH THE MODULES
"LISTOU" AND "OUTMOD" INTO THIS MODULE
ROUTINES ARE: ZOUTMSG,ZOUTSYM,ZOUTOCT,RADIX50,
ZOUDECIMAL,ZOUOFFSET
24 ----- ----- MOVE THE ROUTINE "DMPRLBLOCK" INTO THIS MODULE
25 ----- ----- MOVE THE ROUTINE "LSTRLWD" FROM LISTOU INTO THIS MODULE
26 ----- ----- SHOULD BE SHIFTING RELOCATION BITS LEFT BY (35-COUNT)
RATHER THAN (36-COUNT)
29 ----- ----- SHOULD BE SHIFTING RELOC BITS BY (36-COUNT*2)
30 ----- ----- MAKE "DMPMAINRLBF" INTO A GLOBAL ROUTINE RATHER
THAN LOCAL TO "ZOUTBLOCK"
***** Begin Version 7 *****
31 1242 CKS 29-Jul-81
Add routine OUTCHDATA to output the .REL block to initialize a
character variable
32 1403 AHM 26-Oct-81
Add support for having "$" in symbol names to routine RADIX50.
Needed for extended addressing development.
1474 TFV 15-Mar-82
Fix ZOUDECIMAL to handle up to 12 decimal digits.
1511 CDM 18-Mar-82
Added ZSAVEOUT to output rel blocks for SAVE statements.
1512 AHM 24-Mar-82
Add ZSYMBOL and ZNEWBLOCK to output type 2 or 1070 symbol
blocks depending on /EXTEND. Also reformat module slightly.
1521 CDM 26-Mar-82
Add routines TPARGDES, SECDESC, SIXTO7, ARGCHECK, ZCOERCION,
ZSFARGCHECK for argument checking.
Remove SECDES 29-Jun-82 to SRCA.
1525 AHM 1-Apr-82
If writing a psected REL file, always output a type 22 default
psect index block before flushing out the type 10 local fixup
block buffer. Also, use PXCODE instead of PXHIGH to relocate
argument descriptor entries that point to the argument block
and subroutine call.
1526 AHM 6-Apr-82
Add ZCODE routine to output type 2 or 1010 code blocks. Use
CURADDR and CURPSECT to specify the current address being
loaded into instead of always using HILOC. Also, don't
subtract HIORIGIN from the address of subroutine argument
blocks in ZARGCHECK, since we now never add it in.
1531 CDM 4-May-82
SAVE changes per code review.
1540 AHM 21-May-82
Don't output a default psect index block before calling
BUFFOUT, since it will flush the main rel buffer before
flushing the local fixup rel buffer. LINK is suspected of
destroying the current default psect index in arbitrary ways,
so the index should set immediately before the local fixups.
1544 AHM 26-May-82
Output type 22 default psect index blocks for the .DATA. psect
before type 21 or 1004 sparse data blocks so that they have a
chance to work while the new psected sparse data blocks are
not in LINK. This edit is only for V8 development and will be
removed when the LINK support is finally in.
1551 AHM 3-Jun-82
Make ZCODE and ZSYMBOL call CGERR if they are passed the psect
PSOOPS as an argument. Also change the EXTERNPSECTS uplit to
account for the new PS???? symbol values.
1566 CDM 24-Jun-82
Changes to not ouput SAVE-d named commons to writeable overlay
blocks that have not been declared in COMMON statements.
1567 CDM 1-Jul-82
Move SECDESC to SRCA.
Change name of SECDESC to CHEXLEN.
1570 AHM 25-Jun-82
Change the entry in LONGTAB so that type 1070 additive symbol
fixups for extended programs don't try to relocate a symbol
name (though since all the calls to ZSYMBOL with function
GLBSYMFIX used PSABS anyhow) and perform 30 bit fixups instead
of 18 bit fixups so that numerics in COMMON don't lose their
section numbers.
1613 CDM 13-Aug-82
Change /DEBUG:PARAMETERS to /DEBUG:ARGUMENTS.
1674 CDM 11-Nov-82
Fix argchecking further so that constant and expression
arguments get flagged as no-update, and character function
return values are implicit (not checked).
***** End Revision History *****
)%
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE REQREL.BLI;
SWITCHES LIST;
EXTERNAL
%1521% ARGLINKPT, ! Global pointer to begining of argument blocks.
%1512% CGERR, ! Routine to call on internal errors
%1526% CURADDRESS, ! Current loading address
%1526% CURPSECT, ! Current psect being loaded into
RELBUFF SYMRLBF: ! Buffer for type 2 and 1070 symbol rel blocks
! (Symbol definitions and global requests)
LOCRLBF: ! Buffer for type 10 local request rel blocks
! (Does fixups for forward refs to a label)
MAINRLBF, ! Main rel file buffer - used for type 1 and 1010
! (code and data) as well as miscellaneous
! (hiseg, end, etc.)
EVALTAB EVALU, ! Table for conversion from Fortran [valtype] to
! type codes for LINK.
%1521% HIORIGIN, ! Origin of HISEG
LSTOUT, ! Routine to output a character to the listing
%1526% PSECTS, ! Current free locations in each psect (LOWLOC, etc)
! indexed by psect index (PSDATA, etc)
RDATWD, ! Holds the data word for ZOUTBLOCK
%1567% CHEXLEN, ! Returns length of character expression or LENSTAR
%1521% SORCPTR; ! Pointer to 1st and last statement nodes
FORWARD
BUFFOUT, ! Stores a data word into a particular rel buffer
DMPMAINRLBF,
DMPRLBLOCK,
LSTRLWD, ! List a word of the rel file for /EXPAND
RADIX50, ! Return Radix-50 of the sixbit word in R2
%1512% ZNEWBLOCK, ! Buffers a word of an unrelocated block type
ZOUTBLOCK, ! Buffers a word to the REL file
ZSAVEOUT,
%1512% ZSYMBOL, ! Outputs symbols to the REL file
%1521% TPARGDES, ! Fills in buffer for each argument.
%1521% SIXTO7, ! Sixbit to ASCIZ conversion.
%1521% ZARGCHECK, ! Puts out type checking blocks for subprog calls.
%1521% ZCOERCION, ! Puts out coercion blocks for type checking.
%1521% ZSFARGCHECK; ! Puts out type checking blocks for subprog definitions
BIND ![1512] New
EXTERNPSECT = UPLIT( ! Mapping between internal STE psects and
! external REL file psect indices
%PSDATA:% PXDATA,
%PSCODE:% PXCODE,
%PSLARGE:% PXLARGE,
%PSABS:% PXABS
%1551% )-1; ! Well almost. We shifted things over by one
! so that a psect index of 0 was illegal.
GLOBAL ROUTINE ZCODE(EAPSECT,LOADPSECT)=!NOVALUE [1526] New
BEGIN
! Routine to output the a word with type 1 or 1010 blocks for loading
! data and instructions into memory. Takes three parameters:
! RDATWD (Global variable) - The word to be output
! EAPSECT (Argument) - PSECT index to relocate the right half of RDATWD by.
! LOADPSECT (Argument) - Index of the psect to load the word into.
! Format of an old-style type 1 block
! !=========================================================================!
! ! 1 ! Short count !
! !-------------------------------------------------------------------------!
! !L!R!L!R! . ! . ! . ! Relocation bits for each halfword !
! !=========================================================================!
! ! Loading address !
! !-------------------------------------------------------------------------!
! ! Data word !
! !-------------------------------------------------------------------------!
! \ \
! \ More data words \
! \ \
! !=========================================================================!
! Format of a new-style type 1010 block
! !=========================================================================!
! ! 1010 ! Long count !
! !-------------------------------------------------------------------------!
! !P1 !P2 ! . ! . ! . ! Two bit wide psect indices !
! !=========================================================================!
! ! Loading address !
! !-------------------------------------------------------------------------!
! ! Data word !
! !-------------------------------------------------------------------------!
! \ \
! \ More data words \
! \ \
! !=========================================================================!
IF .LOADPSECT EQL PSOOPS ! Loading into an unknown psect ?
THEN CGERR() ! Yes, give fatal error
ELSE IF .EAPSECT EQL PSOOPS ! No, are we relocating improperly ?
THEN CGERR(); ! Yes, give fatal error
CURADDRESS = .PSECTS[.LOADPSECT]; ! Get load address
IF EXTENDED ! Should we use TWOSEG or psected blocks ?
THEN ! Use psected blocks (new type 1010)
BEGIN
CURPSECT = .EXTERNPSECT[.LOADPSECT]; ! Store in given psect
ZOUTBLOCK(RRIGHTCODE,.EXTERNPSECT[.EAPSECT])
END
ELSE ! Use TWOSEG scheme (old type 1)
BEGIN
CURPSECT = RELRI; ! We relocate the loading address
IF .EAPSECT EQL PSCODE ! Pointing to the high segment ?
THEN RDATWD<RIGHT> = .RDATWD<RIGHT>+.HIORIGIN; ! Yes, hisegize
IF .LOADPSECT EQL PSCODE
THEN CURADDRESS<RIGHT> = .CURADDRESS<RIGHT>+.HIORIGIN;
IF .EAPSECT EQL PSABS ! Absolute right half ?
THEN ZOUTBLOCK(RCODE,RELN) ! Yes, say so
ELSE ZOUTBLOCK(RCODE,RELRI) ! No, relocate the right half
END
END; ! of ZCODE
GLOBAL ROUTINE ZSYMBOL(FUNC,NAM,VALUE,PSECT)=!NOVALUE [1512] New
BEGIN
! Routine to output the proper sequence of words in type 2 or 1070
! blocks for doing things with symbols (definitions, fixups, etc).
! First the new type 1070 blocks
! !=========================================================================!
! ! 1070 ! Long count !
! !=========================================================================!
! ! Function code ! 0 !Name size (0) !D! R ! 0 !
! !-------------------------------------------------------------------------!
! ! Left psect (0) ! Right psect !
! !-------------------------------------------------------------------------!
! ! Value !
! !-------------------------------------------------------------------------!
! ! Name in SIXBIT !
! !-------------------------------------------------------------------------!
! \ \
! \ More quads of names and values \
! \ \
! !=========================================================================!
MACRO
TYPE1070FILL(F,R)=((F)^27 OR ! Fill in the function code field
1^17 OR ! Always set the default (D) bit
! (There are psects in the next word)
(R)^14)$, ! Fill in the R field (what to relocate)
RFIELD=14,3$; ! R field in type 1070 block flag word
BIND
LONGTAB = UPLIT( ! A table entry is all the data that goes into
! the flag word of a type 1070 symbol
%LOCDEF:% TYPE1070FILL(RLSLOCAL,RLSRRH),
%LOCSUPDEF:% TYPE1070FILL(RLSLOCAL OR RLSSUPPRESS,RLSRRH),
%GLBDEF:% TYPE1070FILL(RLSGLOBAL,RLSRRH),
%GLBSUPDEF:% TYPE1070FILL(RLSGLOBAL OR RLSSUPPRESS,RLSRRH),
%GLBSYMFIX:% TYPE1070FILL(RLSGLOBAL OR RLSSYMBOL OR RLS30FIX,RLSRABS),![1570]
%GLB18CHNFIX:% TYPE1070FILL(RLSGLOBAL OR RLSCHAIN OR RLSRHFIX,RLSRRH),
%GLB18ADDFIX:% TYPE1070FILL(RLSGLOBAL OR RLSADDITIVE OR RLSRHFIX,RLSRRH),
%GLB30CHNFIX:% TYPE1070FILL(RLSGLOBAL OR RLSCHAIN OR RLS30FIX,RLSR30),
%GLB30ADDFIX:% TYPE1070FILL(RLSGLOBAL OR RLSADDITIVE OR RLS30FIX,RLSR30)
);
! Next the old type 2 blocks
! !=========================================================================!
! ! 2 ! Short count !
! !-------------------------------------------------------------------------!
! ! Relocation bits !
! !=========================================================================!
! ! Code ! Symbol name in Radix 50 !
! !-------------------------------------------------------------------------!
! ! Value of symbol !
! !-------------------------------------------------------------------------!
! \ \
! \ More pairs of names and values \
! \ \
! !=========================================================================!
MACRO
TYPE2FILL(A,B)=((A) OR (B)^(-18))$, ! Puts the left halves of its
! args into half words
R50NAME=LEFT$, ! The left half of a table entry is
! ORed into the radix 50 symbol name
! that is being output
R50VAL=RIGHT$; ! The right half of a table entry is
! ORed into the value in the same way
BIND
R50TAB = UPLIT( ! Radix-50 flag bits indexed by FUNC
%LOCDEF:% TYPE2FILL(RLOCDEF,0),
%LOCSUPDEF:% TYPE2FILL(RLOCDDTSUP,0),
%GLBDEF:% TYPE2FILL(RGLOBDEF,0),
%GLBSUPDEF:% TYPE2FILL(RGLOBDDTSUP,0),
%GLBSYMFIX:% TYPE2FILL(RGLOBREQ,RLOCFIX),
%GLB18CHNFIX:% TYPE2FILL(RGLOBREQ,RGLOB0^18),
%GLB18ADDFIX:% TYPE2FILL(RGLOBREQ,RGLOB4^18),
%GLB30CHNFIX:% TYPE2FILL(0,0),
%GLB30ADDFIX:% TYPE2FILL(0,0)
);
IF .PSECT EQL PSOOPS ! Defining in an unknown psect ?
THEN CGERR(); ! Yes, give fatal error
IF EXTENDED ! Should we use TWOSEG or psected symbols ?
THEN ! Non-zero section, use psected symbols
BEGIN
RDATWD = .LONGTAB[.FUNC]; ! Get proper flag word
IF .PSECT EQL PSABS ! Doing relocation ?
THEN RDATWD<RFIELD> = RLSRABS; ! No, emphasize this for LINK
ZNEWBLOCK(RLONGSYMBOL); ! There go the flags
RDATWD = .EXTERNPSECT[.PSECT]; ! Get the proper external psect
ZNEWBLOCK(RLONGSYMBOL);
RDATWD = .VALUE; ! Get the value
ZNEWBLOCK(RLONGSYMBOL);
RDATWD = .NAM; ! And get the name in SIXBIT
ZNEWBLOCK(RLONGSYMBOL)
END
ELSE ! NOT EXTENDED ! Use TWOSEG scheme (type 2)
BEGIN
! Convert the name to radix 50, place the correct
! flags in the first 4 bits of the name and output it
! to the rel file.
R2 = .NAM;
RDATWD = RADIX50() OR .R50TAB[.FUNC]<R50NAME>^18;
ZOUTBLOCK(RSYMBOL,RELN);
! Now accumulate the value
IF .FUNC EQL GLBSYMFIX ! Fixup of an existing symbol's value ?
THEN ! Yes, this is a special case
BEGIN
R2 = .VALUE; ! Convert name to radix 50 and set bits
RDATWD = RADIX50() OR .R50TAB[.FUNC]<R50VAL>^18
END
ELSE RDATWD = .VALUE OR .R50TAB[.FUNC]<R50VAL>^18;
%1526% IF .PSECT EQL PSCODE ! Meant for the high segment ?
%1526% THEN RDATWD<RIGHT> = .RDATWD<RIGHT>+.HIORIGIN; ! Yes, hisegize
IF .PSECT EQL PSABS ! Relocating the value ?
THEN ZOUTBLOCK(RSYMBOL,RELN) ! No
ELSE ZOUTBLOCK(RSYMBOL,RELRI) ! Yes
END
END; ! of ZSYMBOL
GLOBAL ROUTINE ZOUTBLOCK(ZBLKTYPE,RELBITS)=
BEGIN
! Buffers one data word that is to be output to the REL file.
! Called with the global RDATWD containing the data word and the args:
!
! 1. ZBLKTYPE - The REL file block type of the block into
! which this data word should be placed.
! 2. RELBITS - The 2 relocation bits that should be associated
! with this data word.
!
! We maintain the separate REL file buffers:
!
! 1. SYMRLBF - For REL file block types 2 and 1070 - this type code is used
! for symbol definitions and global requests
! 2. LOCRLBF - For REL file block type 10 - this type code is used
! for local requests (ie definition of labels to
! which there were forward references)
! 3. MAINRLBF - For all other block types (primarily this will
! be block type 1 - code and data - but it will
! also be used for other misc block types)
!
! When either SYMRLBF or LOCRLBF is full, we must first output
! anything in MAINRLBF before outputing the contents of the full
! buffer (since a local or global fixup cannot precede the word of
! data it refers to).
LABEL
BLOCKSELECT; ! SELECT statement that figures out which buffer to use
BLOCKSELECT:
SELECT .ZBLKTYPE OF
NSET
RSYMBOL: ! For a symbol definition or global request
BEGIN
BUFFOUT(SYMRLBF,.RELBITS);
LEAVE BLOCKSELECT
END;
RLOCAL:
BEGIN
%1526% IF NOT EXTENDED
%1526% THEN
%1526% BEGIN
%1526% ! Make the addresses refer to the high segment.
%1526%
%1526% RDATWD<LEFT> = .RDATWD<LEFT> + .HIORIGIN;
%1526% RDATWD<RIGHT> = .RDATWD<RIGHT> + .HIORIGIN
%1526% END;
BUFFOUT(LOCRLBF,.RELBITS);
LEAVE BLOCKSELECT
END;
OTHERWISE: ! For code and data, and for all other block types
BEGIN
! If the main buffer is full or is being used
! for some other block type than this data
! word should go into, then flush the buffer.
IF .MAINRLBF[RDATCNT] EQL RBLKSIZ-2
OR .MAINRLBF[RTYPE] NEQ .ZBLKTYPE
THEN
BEGIN
DMPMAINRLBF(); ! Output the contents of
! MAINRLBF and reinitialize it
MAINRLBF[RTYPE] = .ZBLKTYPE;
END;
! The first data word of a block of type 1,
! 1010 or 1030 block (code/data) should
! contain the address for the first word of
! code (and use the proper relocation or psect
! index for the address).
%1526% IF .MAINRLBF[RDATCNT] EQL 0
%1526% THEN IF .ZBLKTYPE EQL RCODE OR .ZBLKTYPE EQL RRIGHTCODE
%1526% THEN
%1526% BEGIN
%1526% MAINRLBF[1,RLDATWD] = .CURADDRESS;
%1526% MAINRLBF[RDATCNT] = 1;
%1526% MAINRLBF[RRELOCWD] = .CURPSECT^34
%1526% END;
! Increment the count of the data words, store
! the data word in the buffer and put the
! relocation bits for this data word into the
! relocation word at the ead of the buffer.
MAINRLBF[RDATCNT] = .MAINRLBF[RDATCNT]+1;
MAINRLBF[.MAINRLBF[RDATCNT],RLDATWD] = .RDATWD;
MAINRLBF[RRELOCWD] = .MAINRLBF[RRELOCWD]
OR .RELBITS^(36-.MAINRLBF[RDATCNT]*2);
END;
TESN;
END; ! of ZOUTBLOCK
GLOBAL ROUTINE ZNEWBLOCK(ZBLKTYPE)=!NOVALUE [1512] New
BEGIN
! Buffers one data word that is to be output to the REL file with no
! relocation. The present user is block type 1070 (long symbol name).
!
! Called with the global RDATWD containing the data word and the arg
! ZBLKTYPE containing the REL file block type of the block into which
! this data word should be placed.
!
! The REL file buffer that the data word is temporarily stored into is
! selected depending upon the REL block type.
!
! 1. SYMRLBF - For REL file block type 1070 - this type code is used
! for symbol definitions and global requests.
! 2. LOCRLBF - Not presently used for strange block types.
! 3. MAINRLBF - Not presently used for strange block types.
!
! When either SYMRLBF or LOCRLBF is full, we must first output
! anything in MAINRLBF before outputing the contents of the full
! buffer (since a local or global fixup cannot precede the word of
! data it refers to).
IF .ZBLKTYPE EQL RLONGSYMBOL ! Symbol definition or global request
THEN
BEGIN
IF .SYMRLBF[RDATCNT] GEQ SYMBOLMAX ! Any room left ?
THEN ! No, output what we have so far
BEGIN
DMPMAINRLBF(); ! Dump out code that might need fixups
DMPRLBLOCK(SYMRLBF,.SYMRLBF[RDATCNT]+1);
SYMRLBF[RDATCNT] = 0 ! Clear the word count
END;
! Drop off the word and increment the buffer count.
! Note that while block types that have a relocation
! word start dropping off words at buffer[1,RLDATWD],
! 2, 3, since type 1070 blocks don't have relocation,
! they drop off words at buffer[0,RLDATWD], 1, 2, etc.
SYMRLBF[.SYMRLBF[RDATCNT],RLDATWD] = .RDATWD;
SYMRLBF[RDATCNT] = .SYMRLBF[RDATCNT]+1
END
ELSE CGERR(); ! None of the above !
END; ! of ZNEWBLOCK
ROUTINE BUFFOUT(BUFFER,RELBITS)=
BEGIN
MAP
PRELBUFF BUFFER; ! BUFFER is a pointer to a REL file buffer
LOCAL
RELBUFF MYRELBUF[3];
! Puts the data word contained in the global RDATWD into the REL file
! buffer indicated by BUFFER. RELBITS specifies the relocation bits.
! If BUFFER is full, the contents of the main REL file buffer MAINRLBF
! will be output to the REL file, followed by the contents of BUFFER.
IF .BUFFER[RDATCNT] EQL RBLKSIZ-2 ! Is buffer full ?
THEN ! Yes
BEGIN
DMPMAINRLBF(); ! Output the contents of MAINRLBF
! and reinitialize MAINRLBF
%1540% IF .BUFFER[RTYPE] EQL RLOCAL ! Local fixups ?
THEN IF EXTENDED ! Yes, psected object code ?
THEN ! Yes, buffer is full
BEGIN
! Set the default psect before we dump the
! local fixups. Note that all fixups are in
! .CODE.
MYRELBUF[RTYPE] = RPSECTORG; ! Psect index rel block
MYRELBUF[RDATCNT] = 1; ! One data word
MYRELBUF[RRELOCWD] = 0; ! Don't relocate it
MYRELBUF[1,RLDATWD] = PXCODE; ! Index for .CODE.
DMPRLBLOCK(MYRELBUF,3) ! Output the data
%1540% END;
DMPRLBLOCK(.BUFFER,RBLKSIZ); ! Output the contents of BUFFER
BUFFER[RDATCNT] = 0; ! Clear the buffer's word count
BUFFER[RRELOCWD] = 0; ! and say there is no relocation
END;
BUFFER[RDATCNT] = .BUFFER[RDATCNT]+1; ! Bump count of stored words
BUFFER[RRELOCWD] = .BUFFER[RRELOCWD] OR ! Store the relocation bits
.RELBITS^(36-.BUFFER[RDATCNT]*2);
BUFFER[.BUFFER[RDATCNT],RLDATWD] = .RDATWD ! Store the data word
END; ! of BUFFOUT
GLOBAL ROUTINE DMPMAINRLBF=
BEGIN
! Outputs the contents of the main rel file buffer to the rel file and
! reinitializes the buffer. If the buffer is empty, does nothing.
IF .MAINRLBF[RDATCNT] EQL 0 ! Are there any word in the buffer ?
THEN RETURN; ! No, punt
%1526% IF .MAINRLBF[RTYPE] EQL RRIGHTCODE ! New block (only 1010 so far)?
%1526% THEN ! Yes, block count must include
%1526% BEGIN ! the relocation word
%1526% MAINRLBF[RDATCNT] = .MAINRLBF[RDATCNT]+1; ! Long count
%1526% DMPRLBLOCK(MAINRLBF,.MAINRLBF[RDATCNT]+1)
%1526% END ! No, old block
%1526% ELSE DMPRLBLOCK(MAINRLBF,.MAINRLBF[RDATCNT]+2); ! Use short count
MAINRLBF[RDATCNT] = 0; ! Set the buffer word count to zero
MAINRLBF[RRELOCWD] = 0 ! And say we have nothing
! to relocate so far
END; ! of DMPMAINRLBF
GLOBAL ROUTINE INIRLBUFFS=
BEGIN
! Initializes all 3 REL file buffers
! Initialize buffer used for symbol definition and global
! requests. First, set block type code used for symbol
! definitions and global requests
%1512% IF EXTENDED ! Using type 1070 or 2 ?
%1512% THEN SYMRLBF[RTYPE] = RLONGSYMBOL ! New style 1070
%1512% ELSE SYMRLBF[RTYPE] = RSYMBOL; ! Old style 2
SYMRLBF[RDATCNT] = 0; ! Count of data words in this block
SYMRLBF[RRELOCWD] = 0; ! Relocation bits for this block
LOCRLBF[RTYPE] = RLOCAL; ! Init buffer used for local requests
LOCRLBF[RDATCNT] = 0;
LOCRLBF[RRELOCWD] = 0;
MAINRLBF[RDATCNT] = 0; ! Init buffer used for code, data
MAINRLBF[RRELOCWD] = 0; ! and all other block types
END; ! of INIRLBUFFS
GLOBAL ROUTINE DMPRLBLOCK(RLBLK,WDCT)=
BEGIN
! Outputs a block of rel code pointed to by RLBLK to the REL file.
! WDCT is the number of words (including header words) in the block.
EXTERNAL
RELOUT; ! Writes a word in the rel file
STRUCTURE
PVECTOR[WD]= ! Structure for a pointer to a vector
(@.PVECTOR + .WD);
MAP
PVECTOR RLBLK;
INCR I FROM 0 TO .WDCT-1
DO
BEGIN
CHR = .RLBLK[.I];
RELOUT()
END;
IF .FLGREG<LISTING> ! If a listing was requested
AND .FLGREG<EXPAND> ! and /EXPAND was given
THEN
BEGIN
CRLF;
INCR I FROM 0 TO .WDCT-1
DO
BEGIN
R2 = .RLBLK[.I];
LSTRLWD() ! List each word in the block in octal
END
END;
END; ! of DMPRLBLOCK
GLOBAL ROUTINE LSTRLWD=
BEGIN
! Lists the REL file word in the global register R2
DECR J FROM 12 TO 1
DO
BEGIN
R1 = 0;
LSHC(R1,3); ! Move over three bits
CHR = "0"[.R1]<0,0>; ! Convert to ASCII
LSTOUT(); ! Print it
END;
CRLF;
END; ! of LSTRLWD
GLOBAL ROUTINE ZOUTMSG(PTR)=
BEGIN
! Prints an ASCIZ string
PTR = (.PTR)<36,7>;
UNTIL (CHR = SCANI(PTR)) EQL 0
DO LSTOUT();
END; ! of ZOUTMSG
GLOBAL ROUTINE ZOUTSYM=
BEGIN
! R2 contains symbol in SIXBIT to be listed
DECR I FROM 6 TO 1 ! Maximum of 6 characters listed
DO
BEGIN
R1 = 0; ! Clear out the character temp
LSHC(R1,6); ! Get the next character
IF .R1 GTR 0 ! Is it non blank ?
THEN ! Yes
BEGIN
CHR = .R1+#40; ! Convert to ASCII
LSTOUT() ! Print it
END
ELSE RETURN ! Blank - all done
END;
END; ! of ZOUTMSG
GLOBAL ROUTINE ZOUTOCT=
BEGIN
! List octal half word. R2<LEFT> contains half word octal value
REGISTER
I;
R1 = 0;
I = 6;
DO
BEGIN
LSHC(R1,3);
IF (I = .I-1) EQL 0
THEN EXITLOOP
END WHILE .R1 EQL 0;
DO
BEGIN
CHR = "0"[.R1]<0,0>;
LSTOUT();
R1 = 0;
LSHC(R1,3);
END WHILE (I = .I-1) GEQ 0;
.VREG
END; ! of ZOUTOCT
GLOBAL ROUTINE RADIX50= !R2 CONTAINS THE SYMBOL IN SIXBIT LEFT JUSTIFIED
!CONVERT IT TO RADIX 50
BEGIN
REGISTER R50;
MACRO SIXALPHA(X) =MOVEI(VREG,-#40,X) LEQ ("Z"-#100)$, !SIXBIT ALPHA
SIXDIGIT(X) =MOVEI(VREG,-#20,X) LEQ 9$; !SIXBIT DIGIT
R50_0;
DO (
R1 _ 0; LSHC(R1,6);
IF SIXALPHA(R1) THEN R1 _ .R1 -#26
ELSE IF SIXDIGIT(R1) THEN R1 _ .R1 -#17
%1403% ELSE IF .R1 EQL SIXBIT "$" THEN R1=#46
ELSE R1 _ #45; !A . BY DEFAULT
R50 _ .R50*#50; R50 _ .R50 + .R1;
) WHILE .R2 NEQ 0;
RETURN .R50
END; ! of RADIX50
GLOBAL ROUTINE ZOUDECIMAL=
BEGIN
! Output a decimal number - any number of digits
%1474% ! up to 12 (i.e. a full word)
LOCAL Z[12];
%1474% INCR I FROM 0 TO 12 DO
BEGIN
Z[.I] = (.R1 MOD 10);
R1 = .R1 / 10;
IF .R1 EQL 0
THEN
BEGIN
DECR J FROM .I TO 0 DO
BEGIN
CHR = .Z[.J] + #60;
LSTOUT();
END;
RETURN
END;
END;
END; ! of ZOUDECIMAL
GLOBAL ROUTINE ZOUOFFSET=
BEGIN
LOCAL Z[6];
!LIST IN ASCII THE VALUE OF R1 A REGISTER
IF .R1 LSS 0 THEN CHR _ "-" ELSE CHR _ "+";
LSTOUT();
R2<LEFT> _ ABS(.R1);
ZOUTOCT(); !OCTAL OUTPUT VALUE IN R2<LEFT>
END; ! of ZOUOFFSET
GLOBAL ROUTINE OUTCHDATA (BP,LEN,CONST,SYM) = ! [1242] New
! Routine to output a type 1004 .REL block to initialize a character string
! Args: BP = byte pointer to the string to initialize
! LEN = number of chars in the string
! CONST = pointer to literal table entry of a character constant
! SYM = pointer to symbol table entry of variable
!
! The constant is truncated or padded to the right length, if necessary, and
! put into the .REL file in a type 1004 block.
BEGIN ! OUTCHDATA
MAP BASE CONST;
MAP BASE SYM;
MAP BASE R2;
OWN BLKHDR[5];
REGISTER WDLENGTH; ! LENGTH OF STRING IN WORDS
REGISTER T1; ! TEMP
IF NOT .FLGREG<OBJECT> THEN RETURN; ! IF NO REL FILE, RETURN
%1544% IF EXTENDED ! Psected object code ?
THEN ! Yes
BEGIN LOCAL RELBUFF MYRELBUF[3];
DMPMAINRLBF(); ! Flush out possible previous type 21
! sparse data block so that it is next
! to its default psect index block
! Set the default psect before we dump the data. Note
! that all the data are in .DATA.
MYRELBUF[RTYPE] = RPSECTORG; ! Psect index rel block
MYRELBUF[RDATCNT] = 1; ! One data word
MYRELBUF[RRELOCWD] = 0; ! Don't relocate it
MYRELBUF[1,RLDATWD] = PXDATA; ! Index for .DATA.
DMPRLBLOCK(MYRELBUF,3) ! Output the data
%1544% END;
WDLENGTH _ (.LEN+4)/5; ! GET NUMBER OF WORDS OCCUPIED BY
! INITIALIZATION STRING
IF .SYM[IDATTRIBUT(INCOM)]
THEN
BEGIN ! IN COMMON
BLKHDR[0]<LEFT> _ RCHDATA; ! BLOCK TYPE 1004
BLKHDR[0]<RIGHT> _ .WDLENGTH + 4; ! LONG COUNT
BLKHDR[1] _ 0; ! RELOCATION WORD: NONE
R2 _ .SYM[IDCOMMON]; ! COMMON BLOCK NODE
BLKHDR[2] _ .R2[COMNAME]; ! SIXBIT COMMON BLOCK NAME
BLKHDR[3] _ .LEN; ! BYTE COUNT
BLKHDR[4] _ .BP; ! BYTE POINTER
DMPRLBLOCK(BLKHDR,5); ! DUMP BLOCK HEADER
END ! IN COMMON
ELSE
BEGIN ! NOT IN COMMON
BLKHDR[0]<LEFT> _ RCHDATA; ! BLOCK TYPE 1004
BLKHDR[0]<RIGHT> _ .WDLENGTH + 3; ! LONG COUNT
BLKHDR[1] _ RELRI ^ 32; ! RELOCATION WORD: RIGHT HALF RELOC
! OF BYTE POINTER WORD
BLKHDR[2] _ .LEN; ! BYTE COUNT
BLKHDR[3] _ .BP; ! BYTE POINTER
DMPRLBLOCK(BLKHDR,4); ! DUMP BLOCK HEADER
END; ! NOT IN COMMON
! Output the constant from the literal node. If the string to be
! initialized is exactly the same length as the constant, fine.
! If the string is shorter, only output enough words of the constant
! to fill the desired length of the string. There may be unused
! characters in the last word. If the string is longer, output the
! entire constant (which is padded with blanks in the last word), then
! output blanks until enough words have gone out.
R1 _ .CONST[LITSIZ]-1;
IF .R1 GTR .WDLENGTH THEN R1 _ .WDLENGTH;
DMPRLBLOCK (CONST[LIT1], .R1);
INCR I FROM .CONST[LITSIZ] TO .WDLENGTH DO
DMPRLBLOCK (UPLIT' ', 1);
END; ! OUTCHDATA
GLOBAL ROUTINE ZSAVEOUT= ! [1511] New [1566] Rewritten
! Processing to output a SAVE writable link overlay block. Block type
! 1045 is put out. It is assumed that if this routine is called that
! processing is necessary (the caller has determined this).
BEGIN
EXTERNAL
COMBLKPTR, ! Pointer to the list of common blocks
RELBUFFER MAINRLBF, ! Buffer to put out arg check blocks
NUMSAVCOMMON, ! Number of commons to save
PTRSAVCOMMON, ! Ptr to linked list for COMMONs to be SAVE-d
! [ptr] -> [ptr sym tab common,,ptr to next]
SAVALL, ! SAVE all - everything possible
SAVBLC, ! SAVE blank common
SAVLOC, ! SAVE local variables
SAVNED; ! SAVE rel block is needed
LOCAL
BASE COMPTR, ! Pointer to common block
BASE COMSYM, ! Symbol table entry for common block
BASE OLDCOMPTR; ! Old pointer to common
REGISTER
BOFFSET; ! Offset into MAINRLBF
MACRO SVTYPE=0,LEFT$, ! Rel SVock type
SVCOUNT=0,RIGHT$, ! Rel block count
SVLOCAL=1,34,1$, ! Bit whether locals must be saved
SVLOCWORD=1,FULL$; ! Word to zero out
! Clear out MAINRLBF for use
DMPMAINRLBF();
! If any named commons specified in a SAVE haven't been declared
! in a COMMON statement in the program unit, then don't put them
! out into the rel block. The standard requires that to SAVE a
! named common, all units using said common must SAVE it, so if
! this unit doesn't use it, it will be ignored.
IF NOT .SAVALL
THEN
BEGIN ! Walk through the list of common blocks. If we remove
! the common name, we must also decrement the count put
! out to the rel block before the MAINRLBF can be output
! (in case we have more than 18 blocks to SAVE).
OLDCOMPTR = PTRSAVCOMMON; ! Init to delete the first
DECR CNT FROM .NUMSAVCOMMON TO 1
DO
BEGIN ! For each common name SAVE
COMPTR = .OLDCOMPTR[CLINK]; ! Pointer to look at
COMSYM = .COMPTR[CW0L]; ! common symbol table entry
IF NOT .COMSYM[IDATTRIBUT(COMBL)]
THEN
BEGIN ! Block not declared COMMON - delete it
COMPTR = .COMPTR[CLINK];
OLDCOMPTR[CLINK] = .COMPTR;
NUMSAVCOMMON = .NUMSAVCOMMON - 1;
END
ELSE
BEGIN
OLDCOMPTR = .COMPTR; ! Save for next delete
COMPTR = .COMPTR[CLINK]; ! Next common
END;
END; ! For each common name SAVE
END;
! Fill in header word
! Block type
MAINRLBF[SVTYPE] = RWRITELINK;
! Number of words in rel block
MAINRLBF[SVCOUNT] = 1 + .NUMSAVCOMMON;
IF .SAVBLC THEN ! Extra for blank common
IF NOT .SAVALL ! Included in common walk
THEN MAINRLBF[SVCOUNT] = .MAINRLBF[SVCOUNT] + 1;
! Light bit to SAVE module being processed
MAINRLBF[SVLOCWORD] = 0;
IF .SAVLOC
THEN MAINRLBF[SVLOCAL] = 1; ! Yes, save it
BOFFSET = 1; ! Offset into MAINRLBF
IF .SAVBLC ! A blank common has appeared,
THEN ! must SAVE it from the devil!!
BEGIN
BOFFSET = .BOFFSET + 1;
MAINRLBF[.BOFFSET,FULL] = SIXBIT'.COMM.';
END;
! Ouput any COMMON blocks specified
IF NOT .SAVALL
THEN
BEGIN ! Use SAVE linked list
COMPTR = .PTRSAVCOMMON; ! Ptr to common
DECR CNT FROM .NUMSAVCOMMON TO 1
DO
BEGIN ! For each COMMON to be SAVE-d
! If offset > 20 then dump buffer and start
! refilling it again.
BOFFSET = .BOFFSET + 1;
IF .BOFFSET GEQ RBLKSIZ
THEN
BEGIN
DMPRLBLOCK(MAINRLBF,RBLKSIZ);
BOFFSET = 0;
END;
! Put sixbit symbol into rel file.
COMSYM = .COMPTR[CW0L]; ! Common symbol table entry
MAINRLBF[.BOFFSET,FULL] =
.COMSYM[IDSYMBOL]; ! Common name
COMPTR = .COMPTR[CLINK]; ! New pointer for next common
END; ! For each COMMON to be SAVE-d
END ! Use SAVE linked list
ELSE
BEGIN ! Save all COMMON-s
! This is a walk through all common blocks to output
! their names into the rel buffer.
BOFFSET = 1;
COMPTR = .FIRCOMBLK; ! First common block
DECR CNT FROM .NUMSAVCOMMON TO 1
DO
BEGIN ! For all COMMON blocks
! If offset > 20 then dump buffer and start
! refilling it again.
BOFFSET = .BOFFSET + 1;
IF .BOFFSET GEQ RBLKSIZ
THEN
BEGIN
DMPRLBLOCK(MAINRLBF,RBLKSIZ);
BOFFSET = 0;
END;
! Put sixbit symbol into rel block and get new
! pointer for next go around.
MAINRLBF[.BOFFSET,FULL] = .COMPTR[COMNAME]; ! Name
COMPTR = .COMPTR[NEXCOMBLK]; ! New pointer
END; ! For all COMMON blocks
END; ! Save all Commons
! Put out remaining rel block
DMPRLBLOCK(MAINRLBF,.BOFFSET+1);
BEGIN ! Redefine MAINRLBF
! Clears out MAINRLBF using the "proper" definition in case
! anyone else wants to re-use it. We're done with it.
MAP RELBUFF MAINRLBF;
MAINRLBF[RDATCNT] = 0;
MAINRLBF[RRELOCWD] = 0;
END ! Redefine MAINRLBF
END; ! of ZSAVEOUT
GLOBAL ROUTINE ZARGCHECK= ![1521] New
BEGIN
! Outputs argument checking 1120 rel blocks for calls to subroutines and
! functions. Starts at the begining of the argument block list and
! creates a buffer for each argument list which needs argument type
! checking.
REGISTER
ARGUMENTLIST ARGLIST, ! Used for each arg list
ARGOFFSET; ! Offset into the buffer being assigned
LOCAL
BASE CNODE, ! Used for examining nodes
%1674% IMPLARG, ! Flag for whether "this arg" is implicit
%1674% ! (link should not type check)
BASE PARNODE, ! Parent node of argument list
BASE SYMTAB; ! Symbol table entry
MAP RELBUFFER MAINRLBF;
! Insure that MAINRLBF is empty before using it. We simply
! use it as a buffer, we don't use the structure RELBUFF used
! elsewhere.
DMPMAINRLBF();
ARGLIST = .ARGLINKPT; ! 1st arg list in program
WHILE .ARGLIST NEQ 0 DO ! Do one arg list at a time.
BEGIN !Check each arg
%1674% IMPLARG = FALSE; ! 1st argument is not yet known
%1674% ! to be implicit
! Watch out for statements that may have been deleted by
! folding. ARGLABEL is 0 for these statements. Only
! user functions and subroutines need arg check blocks,
! check the flag when the arg list was made to see if we
! need one.
IF .ARGLIST[ARGLABEL] NEQ 0 THEN
IF .ARGLIST[ARGCHBLOCK]
THEN
BEGIN !Need arg check block
! Parent node above arg list
PARNODE = .ARGLIST[ARGPARENT];
IF .PARNODE[OPRCLS] EQL STATEMENT
THEN SYMTAB = .PARNODE[CALSYM] ! Call statement
ELSE SYMTAB = .PARNODE[ARG1PTR]; ! Function ref
! Type of rel block
MAINRLBF[TPRELTYPE] = RARGDESC;
! Count the number of words needed for the entire
! buffer. If a 5 or more letter name, we need more
! than 1 word to store it. If a non character
! function need extra word for return value. If
! character argument, may need 2nd word for
! secondary descriptor.
! Set ARGOFFSET according to the number of words
! needed to store the ASCIZ name and also put this
! information into the rel block while we have it.
MAINRLBF[TPNAME0] = 0; ! Zero out name in case
MAINRLBF[TPNAME1] = 0; ! it doesn't take full word
! Convert the SIXBIT name, put it and the number
! of bytes needed for storage into the rel file.
MAINRLBF[TPNAMSIZE] =
SIXTO7(.SYMTAB[IDSYMBOL],MAINRLBF[TPNAME0]);
! TPMIN is a "magic" number denoting the minimum
! number of words needed for a rel block (minus the
! size of the function name).
ARGOFFSET = TPMIN + CHWORDLEN(.MAINRLBF[TPNAMSIZE]);
! Number of words in block (minus the header block)
! Add to below, as needed.
MAINRLBF[TPRELSIZE] = .ARGOFFSET + .ARGLIST[ARGCOUNT];
! Functions need an extra word for their return
! values.
IF .PARNODE[OPRCLS] EQL FNCALL
THEN MAINRLBF[TPRELSIZE] =
.MAINRLBF[TPRELSIZE] + 1;
! Check each arg for secondary descriptor needed to
! be put out. Need an extra word if one is needed.
! Must not do if there are no arguments.
IF .ARGLIST[ARGCOUNT] NEQ 0
THEN
DECR CNT FROM .ARGLIST[ARGCOUNT] TO 1 DO
BEGIN
CNODE = .ARGLIST[.CNT,ARGNPTR];
IF .CNODE[VALTYPE] EQL CHARACTER THEN
%1567% IF CHEXLEN(.CNODE) NEQ LENSTAR
THEN MAINRLBF[TPRELSIZE] =
.MAINRLBF[TPRELSIZE] + 1; ! Extra word
END;
! If this is a character function, we must
! include the functions return value (and check
! for a secondary descriptor) twice. The first
! time is for the physical location which is in
! the arg block and the second is for the dummy
! location we put in the rel block for link to
! know the value of the function.
IF .PARNODE[OPRCLS] EQL FNCALL THEN
IF .PARNODE[VALTYPE] EQL CHARACTER THEN
%1674% BEGIN ! Character function call
%1674%
%1674% ! The first argument in the rel block
%1674% ! will be an "implicit" argument, not to
%1674% ! be type checked.
%1674% IMPLARG = TRUE;
%1567% IF CHEXLEN(.ARGLIST[1,ARGNPTR]) NEQ LENSTAR
THEN MAINRLBF[TPRELSIZE] =
.MAINRLBF[TPRELSIZE] + 1; ! Extra word
%1674% END;
! 2-bit byte relocation information. Only the
! argument block address and associated call
! address are relocated. The "psect indices"
! to use when writing a TWOSEGged REL file
! are: lowseg=1, hiseg=2.
%1525% IF EXTENDED
%1525% THEN MAINRLBF[TPNBITRELOC] = PXCODE^34 + PXCODE^32
%1525% ELSE MAINRLBF[TPNBITRELOC] = PXHIGH^34 + PXHIGH^32;
! Argument block address
CNODE = .ARGLIST[ARGLABEL]; ! Label table entry
%1526% MAINRLBF[TPARBLADD] = .CNODE[SNADDR]; ! Object addr
! Associated call address
MAINRLBF[TPASOCCALL] = .ARGLIST[ARGCALL];
! Loading address. Never load the descriptor.
MAINRLBF[TPLDADD] = 0;
! Clear flag bits for argument block.
MAINRLBF[.ARGOFFSET,LEFT] = 0;
! Complain if number of args for caller, callee are
! different if /DEBUG:ARGUMENTS was specified.
%1613% IF .FLGREG<DBGARGMNTS>
THEN MAINRLBF[.ARGOFFSET,TPCNT] = 1;
MAINRLBF[.ARGOFFSET,TPWHO] = 1; ! Call to a subprogram
MAINRLBF[.ARGOFFSET,TPLOD] = 0; ! Do not load descr
%1674% ! Complain if the caller and called can't agree
%1674% ! whether this is a subroutine or function.
%1674% MAINRLBF[.ARGOFFSET,TPSFERR] = 1;
! Count of args - doesn't include any secondary
! descriptors. Add one for functions.
! (Character functions have their return value
! as their 1st arg in the arg list).
IF .PARNODE[OPRCLS] EQL FNCALL
THEN
%1674% BEGIN
MAINRLBF[.ARGOFFSET,TPARGCOUNT] =
%1674% .ARGLIST[ARGCOUNT] + 1; ! function
%1674% MAINRLBF[.ARGOFFSET,TPVAL] = 1; ! Returns value
%1674% END
%1674% ELSE MAINRLBF[.ARGOFFSET,TPARGCOUNT] =
.ARGLIST[ARGCOUNT];
! Build argument descriptors for each argument.
! Call routine TPARGDES to put into MAINRLBF the
! information for each argument.
INCR CNT FROM 1 TO .ARGLIST[ARGCOUNT]
DO
%1674% BEGIN
ARGOFFSET = TPARGDES(.ARGOFFSET,
%1674% .ARGLIST[.CNT,ARGNPTR], .IMPLARG);
%1674%
%1674% IMPLARG = FALSE; ! No more are implicit
%1674% END;
! If a function call, then last argument is the
! func's return value. Put it in MAINRLBF
IF .PARNODE[OPRCLS] EQL FNCALL
THEN ARGOFFSET = TPARGDES(.ARGOFFSET,
%1674% .PARNODE[ARG1PTR], FALSE);
! Put out the .REL block for this argument list
DMPRLBLOCK(MAINRLBF,.ARGOFFSET+1);
END; ! Need arg check block
! Next arglist
ARGLIST = .ARGLIST[ARGLINK];
END; ! Check each arg
BEGIN ! Redefine MAINRLBF
! Clears out MAINRLBF using the "proper" definition in case
! anyone else wants to re-use it. We're done with it.
MAP RELBUFF MAINRLBF;
MAINRLBF[RDATCNT] = 0;
MAINRLBF[RRELOCWD] = 0;
END ! Redefine MAINRLBF
END; ! of ZARGCHECK
GLOBAL ROUTINE SIXTO7(SIX,SEV)= ![1521] New
! Converts one word of SIXBIT to ASCIZ, returning the size in bytes.
! PASSED: -SIXBIT value to convert
! -Address for destination for ASCIZ
! RETURNS: -Number of bytes + 1 (for the zero) of the name
BEGIN
REGISTER
COUNT, ! Number of bytes needed for ASCII name
DEST, ! Destination for movement
SOURCE; ! Source for movement
LOCAL WORD; ! Temp for shifting name to determine COUNT
! Count the number of bytes needed for ASCII name. Shift out
! letter by letter until the name is null.
COUNT = 0;
WORD = .SIX;
WHILE .WORD NEQ 0 DO
BEGIN ! Count letters in name
WORD = .WORD ^6;
COUNT = .COUNT + 1;
END;
! Convert from SIXBIT to ASCIZ
DEST = (.SEV)<36,7>; ! Byte pointer for destination
SOURCE = SIX<36,6>; ! " " for source
! Stuff in one letter at a time, converting to ASCII
DECR CNT FROM .COUNT TO 1
DO REPLACEI(DEST,SCANI(SOURCE)+#40);
REPLACEI(DEST,#0); ! Zero at end
! Number of bytes + zero byte
RETURN .COUNT + 1;
END; ! of SIXTO7
ROUTINE TPARGDES(ARGOFFSET,CNODE,IMPLARG)= ! [1521] New
! Routine to put the needed information for block type 1120 into the buffer
! for each argument node CNODE passed it. Adds to ARGOFFSET as neccessary.
! PASSED: ARGOFFSET -Offset into buffer MAINRLBF
! CNODE -Node to retrieve information from
! IMPLARG -Flag on whether this argument is implicit
! RETURNS: ARGOFFSET -Current offset into MAINRLBF
! Either +1 +2 or reset to zero.
BEGIN
MAP BASE CNODE;
MAP RELBUFFER MAINRLBF; ! Buffer to put information into.
REGISTER ARGSIZE; ! Size in bytes of a character variable from
! CHEXLEN.
ARGOFFSET = .ARGOFFSET + 1; ! Bump offset up
! If reached max size then output the current buffer and start the
! offset back at 0. Insure that we have at least 2 words (in case
! we need a secondary descriptor)
IF .ARGOFFSET GTR RBLKSIZ - 2
THEN
BEGIN
! ARGOFFSET is one too big which is the correct number to
! dump.
DMPRLBLOCK(MAINRLBF,.ARGOFFSET);
ARGOFFSET = 0;
END;
! Zero out the word before we start out
MAINRLBF[.ARGOFFSET,FULL] = 0;
! If the node passed is 0, then we have an alternate return label.
! No need to process any further, and in fact we can't, since there
! is no node to proccess.
IF .CNODE EQL 0
THEN
BEGIN ! Alternate return label
MAINRLBF[.ARGOFFSET,TPTYP] = #7; ! Arg type is label
%1674% MAINRLBF[.ARGOFFSET,TPNUP] = 1; ! Don't update
RETURN .ARGOFFSET;
END;
IF .CNODE[OPRCLS] EQL DATAOPR THEN
IF .CNODE[OPERSP] EQL CONSTANT
THEN
BEGIN
%1674% MAINRLBF[.ARGOFFSET,TPNUP] = 1; ! Don't update
MAINRLBF[.ARGOFFSET,TPCTC] = 1; ! Compile time constant
END;
%1674% ! On called side, fill in no update if the variable is not updated
%1674%
%1674% IF .CNODE[OPRCLS] EQL DATAOPR THEN
%1674% IF .CNODE[FORMLFLG] THEN
%1674% IF NOT .CNODE[IDATTRIBUT(STORD)] ! Not stored into here
%1674% THEN MAINRLBF[.ARGOFFSET,TPNUP] = 1; ! Is not updated here
IF .CNODE[VALTYPE] EQL CHARACTER
THEN MAINRLBF[.ARGOFFSET,TPPAS] = PASSDESCR ! Pass by descriptor
ELSE MAINRLBF[.ARGOFFSET,TPPAS] = PASSADDR; ! Pass by address
! Argument type code based on value of argument
IF .CNODE[OPRCLS] EQL LABOP
THEN MAINRLBF[.ARGOFFSET,TPTYP] = ADDRTYPE ! Alternate return lab
ELSE MAINRLBF[.ARGOFFSET,TPTYP] = .EVALU[.CNODE[VALTYPE]];
%1674% ! The physical character function return value argument should
%1674% ! not be checked by link. Light an "implicit argument" bit.
%1674%
%1674% IF .IMPLARG THEN MAINRLBF[.ARGOFFSET,TPIMPL] = 1;
! Decide if secondary descriptor is needed. If so, then put it out.
IF .CNODE[VALTYPE] EQL CHARACTER THEN
%1567% IF (ARGSIZE = CHEXLEN(.CNODE)) NEQ LENSTAR
THEN
BEGIN ! Secondary descriptor needed
MAINRLBF[.ARGOFFSET,TPSND] = 1; ! 1 secondary descriptor
ARGOFFSET = .ARGOFFSET + 1;
MAINRLBF[.ARGOFFSET,FULL] = 0;
! Set formal =< actual for allowable conditions. This is
! according to the ANSII-77 standard , section 15.9.3.1.
! This has been extended to include function references.
MAINRLBF[.ARGOFFSET,TPMCH] = TPFLEA;
! Set size of arg found
MAINRLBF[.ARGOFFSET,TPSIZ] = .ARGSIZE;
END; ! Secondary descriptor needed
RETURN .ARGOFFSET; ! Return last offset used.
END; ! of TPARGDES
GLOBAL ROUTINE ZSFARGCHECK= ![1521] New
! Routine which puts out arg checking blocks for definitions of subroutines
! and functions. Routine walks through any and all ENTRY points linked
! together to put out this rel block.
! Must be carefull of nonexistant argument lists, ARGLIST is 0 for no
! arguments (or no return value for character functions).
BEGIN
LOCAL
ARGCNT, ! Count of the number of arguments
ARGOFFSET, ! Offset into MAINRLBF
ARGUMENTLIST ARGLIST, ! Argument list
BASE CNODE, ! Structure used generally
BASE ENTSTAT, ! Entry point being worked on.
%1674% IMPLARG, ! Flag indicating implicit argument
BASE SYMTAB; ! Symbol table entry
MAP RELBUFFER MAINRLBF; ! Buffer to put out the blocks
%1674% IMPLARG = FALSE; ! 1st argument is not yet know to be
%1674% ! implicit
! Get the call node for the definition of the subprogram
ENTSTAT = .FIRSTSRC; ! 1st statement node
WHILE .ENTSTAT[SRCID] NEQ ENTRID ! Search for the ENTRY statmnt.
DO ENTSTAT = .ENTSTAT[SRCLINK]; ! Cant' be sure where it is!
! Insure that MAINRLBF is empty before using it. We simply use it
! as a buffer to put the information into, not using structure
! RELBUF.
DMPMAINRLBF();
WHILE .ENTSTAT NEQ 0 DO
BEGIN ! For each ENTRY statement
SYMTAB = .ENTSTAT[ENTSYM]; ! Symbol table for entry
ARGLIST = .ENTSTAT[ENTLIST]; ! Arg list for this ENTRY
IF .ARGLIST NEQ 0 ! Set number of arguments
THEN ARGCNT = .ARGLIST[ARGCOUNT]
ELSE ARGCNT = 0;
! Type of rel block
MAINRLBF[TPRELTYPE] = RARGDESC;
! Count the number of words needed for the entire buffer.
! If a 5 or more letter name, we need more than 1 word to
! store it. If a non character function, need estra word
! for the return value. If character argument is given,
! may need 2nd word for secondary descriptor.
! Set ARGOFFSET according to the number of words needed to
! store the ASCIZ name and also put this information into
! the rel block while we have it.
MAINRLBF[TPNAME0] = MAINRLBF[TPNAME1] = 0; ! Zero out
MAINRLBF[TPNAMSIZE] =
SIXTO7(.SYMTAB[IDSYMBOL],MAINRLBF[TPNAME0]);
! TPMIN is a "magic" number denoting the minimum number of
! words needed for a rel block (minus the size of the
! function name).
ARGOFFSET = TPMIN + CHWORDLEN(.MAINRLBF[TPNAMSIZE]);
! Number of words in block (minus the header block.) Add
! to this count as needed below.
MAINRLBF[TPRELSIZE] = .ARGOFFSET + .ARGCNT;
! Functions need an extra word for their return values.
IF .FLGREG<PROGTYP> EQL FNPROG
THEN MAINRLBF[TPRELSIZE] = .MAINRLBF[TPRELSIZE] + 1;
! Check each arg for secondary descriptor needed to be put
! out
IF .ARGCNT NEQ 0
THEN
DECR CNT FROM .ARGCNT TO 1 DO
BEGIN
CNODE = .ARGLIST[.CNT,ARGNPTR];
IF .CNODE NEQ 0 THEN ! Return label
IF .CNODE[VALTYPE] EQL CHARACTER THEN
%1567% IF CHEXLEN(.CNODE) NEQ LENSTAR
THEN MAINRLBF[TPRELSIZE] =
.MAINRLBF[TPRELSIZE] + 1;
END;
! If this is a character function, we must include the
! functions return value (and check for a secondary
! descriptor) twice. The first time is for the physical
! location which is in the arg block and the second is
! for the dummy location we put in the rel block for
! link to know the value of the function.
IF .FLGREG<PROGTYP> EQL FNPROG THEN
IF .SYMTAB[VALTYPE] EQL CHARACTER THEN
%1674% BEGIN
IF CHEXLEN(.ARGLIST[1,ARGNPTR]) NEQ LENSTAR
THEN MAINRLBF[TPRELSIZE] = .MAINRLBF[TPRELSIZE] + 1;
%1674%
%1674% IMPLARG = TRUE; ! First argument is implicit
%1674% END;
! N-Bit byte relocation information. Only the argument
! block address, associated call address and the loading
! address can be relocatable. Loading address is not used.
! 1=lowseg, 2=hiseg
MAINRLBF[TPNBITRELOC] = 0; !Nothing to relocate
! Argument block address
MAINRLBF[TPARBLADD] = 0;
! Assoc call address. There is no call, this is the
! definition of the subprogram.
MAINRLBF[TPASOCCALL] = 0;
! Load address. Never load this descriptor.
MAINRLBF[TPLDADD] = 0;
! Clear flag bits for argument block.
MAINRLBF[.ARGOFFSET,LEFT] = 0;
! Complain if number of args for caller and callee are
! different if /DEBUG:ARGUMENTS was specified.
%1613% IF .FLGREG<DBGARGMNTS> THEN MAINRLBF[.ARGOFFSET,TPCNT] = 1;
MAINRLBF[.ARGOFFSET,TPWHO] = 0; ! Definition of a subprogram
MAINRLBF[.ARGOFFSET,TPLOD] = 0; ! Do not load descriptor
%1674% ! Complain if the caller and called can't agree whether
%1674% ! this is a subroutine or function.
%1674% MAINRLBF[.ARGOFFSET,TPSFERR] = 1;
! Number of args. Does not include any secondary
! descriptors. Add one for functions. (Character
! functions have their return value as their 1st arg in
! the arg list).
IF .FLGREG<PROGTYP> EQL FNPROG
%1674% THEN
%1674% BEGIN ! Function
%1674% MAINRLBF[.ARGOFFSET,TPARGCOUNT] = .ARGCNT +1;
%1674% MAINRLBF[.ARGOFFSET,TPVAL] = 1; ! Returns value.
%1674% END
%1674% ELSE MAINRLBF[.ARGOFFSET,TPARGCOUNT] = .ARGCNT;
! Build argument descriptors for each argument. Call
! routine TPARGDES to put into MAINRLBF the information
! for each arg.
INCR CNT FROM 1 TO .ARGCNT
DO
%1674% BEGIN
ARGOFFSET = TPARGDES(.ARGOFFSET,
%1674% .ARGLIST[.CNT,ARGNPTR], .IMPLARG);
%1674%
%1674% IMPLARG = FALSE; ! No more implicit args
%1674% END;
! If a function call, then last argument is the function's
! return value.
IF .FLGREG<PROGTYP> EQL FNPROG
%1674% THEN ARGOFFSET = TPARGDES(.ARGOFFSET, .SYMTAB, FALSE);
! Put ot the rel block for this argument list
DMPRLBLOCK(MAINRLBF,.ARGOFFSET+1);
! Link to next entry point.
ENTSTAT = .ENTSTAT[ENTLINK];
END; ! For each ENTRY statement.
BEGIN ! Redefine MAINRLBF
! Clears out MAINRLBF using the "proper" definition in case
! anyone else wants to re-use it. We're done with it.
MAP RELBUFF MAINRLBF;
MAINRLBF[RDATCNT] = 0;
MAINRLBF[RRELOCWD] = 0;
END ! Redefine MAINRLBF
END; ! of ZSFARGCHECK
GLOBAL ROUTINE ZCOERCION=
BEGIN
! Outputs type 1130 Coercion blocks for LINK argument type checking.
! This block gives LINK the instructions of what to do when it
! encounters a difference between callee and caller.
! If /DEBUG:ARGUMENTS has been specified, then put out a larger block
! asking LINK to complain about more, otherwise Link does the special
! Fortran fixup of changing character constants to hollerith constants
! for old programs expecting numeric data.
MAP RELBUFFER MAINRLBF; ! Buffer to output block.
%1674% LOCAL HEADRWORD; ! Header word for rel block.
! The information format is:
! +---------------------+-----------------------+
! | Field code | Action |
! +---------------------+-----------------------+
! | Formal attribute | Actual attribute |
! +---------------------+-----------------------+
MACRO COERCE(FIELD,ACTION,FORMAL,ACTUAL)
= ((FIELD)^18 OR ACTION),
((FORMAL)^18 OR ACTUAL)$;
BIND YES=1,
NO=0;
! Table used if no /DEBUG:ARGUMENTS is specifed
%1613% BIND NOARGS =
PLIT(
! Fixup blocks for Character constant to hollerith conversion
COERCE(CBPAS, CBFIXUP, PASSADDR, PASSDESCR),
! Supress "informational messages"
COERCE(CBCONST, CBNOACTION, NO, YES), ! constant
%1674% COERCE(CBNOUPDATE, CBNOACTION, YES, NO), ! No update
%1674% COERCE(CBRETVAL, CBNOACTION, YES, NO), ! return val
%1674% ! Mixing of double precision and g-floating gets warnings
%1674%
%1674% COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPDOUBLPREC),
%1674% COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPGFLDBLPREC)
);
! Table used if /DEBUG:ARGUMENTS is specified.
%1613% BIND ARGS =
PLIT(
! Fixup blocks for Character constant to hollerith
! conversion. Same as entries in the table NOARGS above.
COERCE(CBPAS, CBFIXUP, PASSADDR, PASSDESCR),
! Don't complain about passing a constant to a non-constant.
COERCE(CBCONST, CBNOACTION, NO, YES),
%1674% ! Complain for no-update
%1674%
%1674% COERCE(CBNOUPDATE, CBWARNING, NO, YES),
%1674% COERCE(CBNOUPDATE, CBNOACTION, YES, NO),
%1674% ! Complain for number of arguments being different
%1674%
%1674% COERCE(CBNUMARG, CBWARNING, 0, 0),
%1674% ! Check for missing return value on the called side
%1674%
%1674% COERCE(CBRETVAL, CBWARNING, NO, YES),
%1674% COERCE(CBRETVAL, CBNOACTION, YES, NO),
%1674% ! Complain for character argument length missmatches
%1674%
%1674% COERCE(CBARGLEN, CBWARNING, 0, 0),
! Give warnings for the following invalid type mismatches:
! Logical Actual
COERCE(CBTYP, CBWARNING, TYPLABEL, TYPLOGICAL),
COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPLOGICAL),
COERCE(CBTYP, CBWARNING, TYPREAL, TYPLOGICAL),
COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPLOGICAL),
COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPLOGICAL),
COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPLOGICAL),
COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPLOGICAL),
! Integer Actual
COERCE(CBTYP, CBWARNING, TYPLABEL, TYPINTEGER),
COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPINTEGER),
COERCE(CBTYP, CBWARNING, TYPREAL, TYPINTEGER),
COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPINTEGER),
COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPINTEGER),
COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPINTEGER),
COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPINTEGER),
! Real Actual
COERCE(CBTYP, CBWARNING, TYPLABEL, TYPREAL),
COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPREAL),
COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPREAL),
COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPREAL),
COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPREAL),
COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPREAL),
COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPREAL),
! Double Precision Actual
COERCE(CBTYP, CBWARNING, TYPLABEL, TYPDOUBLPREC),
COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPDOUBLPREC),
COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPDOUBLPREC),
COERCE(CBTYP, CBWARNING, TYPREAL, TYPDOUBLPREC),
COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPDOUBLPREC),
COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPDOUBLPREC),
COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPDOUBLPREC),
! G-Floating Actual
COERCE(CBTYP, CBWARNING, TYPLABEL, TYPGFLDBLPREC),
COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPGFLDBLPREC),
COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPGFLDBLPREC),
COERCE(CBTYP, CBWARNING, TYPREAL, TYPGFLDBLPREC),
COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPGFLDBLPREC),
COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPGFLDBLPREC),
COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPGFLDBLPREC),
! Complex Actual
COERCE(CBTYP, CBWARNING, TYPLABEL, TYPCOMPLEX),
COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPCOMPLEX),
COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPCOMPLEX),
COERCE(CBTYP, CBWARNING, TYPREAL, TYPCOMPLEX),
COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPCOMPLEX),
COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPCOMPLEX),
COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPCOMPLEX),
! Label Actual
COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPLABEL),
COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPLABEL),
COERCE(CBTYP, CBWARNING, TYPREAL, TYPLABEL),
COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPLABEL),
COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPLABEL),
COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPLABEL),
COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPLABEL),
! Character Actual
COERCE(CBTYP, CBWARNING, TYPLABEL, TYPCHARACTER),
COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPCHARACTER),
COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPCHARACTER),
COERCE(CBTYP, CBWARNING, TYPREAL, TYPCHARACTER),
COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPCHARACTER),
COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPCHARACTER),
COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPCHARACTER),
! Octal actual
COERCE(CBTYP, CBWARNING, TYPLABEL, TYPOCTAL),
COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPOCTAL),
COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPOCTAL),
COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPOCTAL),
COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPOCTAL),
! Double Octal actual
COERCE(CBTYP, CBWARNING, TYPLABEL, TYPDBLOCTAL),
COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPDBLOCTAL),
COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPDBLOCTAL),
COERCE(CBTYP, CBWARNING, TYPREAL, TYPDBLOCTAL),
COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPDBLOCTAL),
! Hollerith actual
%1674% COERCE(CBTYP, CBWARNING, TYPLABEL, TYPHOLLERITH),
COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPHOLLERITH)
);
! Type of block being put out. We must have a separate word to
! output the header because PLIT's are put in the non-writable
! high seg on the 10, and we can't write into the PLIT.
%1674% HEADRWORD = RCOERCION^18;
! Output a coercion block depending on whether /DEBUG:ARGUMENTS
! was specified. Hi Tyrone! (He's never been in a compiler
! before!)
%1613% IF .FLGREG<DBGARGMNTS>
%1613% THEN
%1674% BEGIN ! /DEBUG:ARGUMENTS specified
%1674%
%1674% HEADRWORD<RIGHT> = .(ARGS-1); ! Header word
%1674% DMPRLBLOCK(HEADRWORD,1);
%1674%
%1613% DMPRLBLOCK(ARGS,.(ARGS-1)) ! Rest of rel block
%1674% END
%1613% ELSE
%1674% BEGIN ! /DEBUG:ARGUMENTS not specified
%1674%
%1674% HEADRWORD<RIGHT> = .(NOARGS-1); ! Header word
%1674% DMPRLBLOCK(HEADRWORD,1);
%1674%
%1613% DMPRLBLOCK(NOARGS,.(NOARGS-1)); ! Rest of rel block
%1674% END;
END; ! of ZCOERCION
END
ELUDOM