Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-BB_1985_short
-
relbuf.bli
There are 26 other files named relbuf.bli in the archive. Click here to see a list.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
!AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!AUTHOR: S. MURPHY/CKS/AHM/CDM/PLB
MODULE RELBUF(RESERVE(0,1,2,3), SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
GLOBAL BIND RELBUV = #10^24 + 0^18 + #2517; ! Version Date: 1-FEB-85
%(
***** 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 EXTERNPSECT 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 V7 Development *****
1770 CDM 25-Jul-83
Perform argument checking for length of numeric arrays when the
length is known at compile time. Create SECDESC to return the
length needed for a secondary descriptor (or 0 if none is
needed).
2022 CDM 1-Dec-83
Writable overlay blocks (type 1045) were put out for the
following program:
PROGRAM FOO
SAVE /FOO/
END
ZSAVEOUT deletes undeclared common blocks (FOO above) from the
list of those to put in the rel block, but does not check to see
if there is a reason to put ANY 1045 block out after deleting
these undeclared commons. If there are no delcared commons, and
no local variable to SAVE, then do not put out a 1045 block.
2075 CDM 22-Jan-85
Fix for edit 2022, output writeable overlay rel block if
blank COMMON is seen, even if no other common blocks are
declared and used.
2216 PLB 27-Sep-83
Modifications for output of OWGs for use in one section. The
section is specified in the global OWGBPSECTION. OUTCHDATA
must convert back to OWL format until there is a LINK block
for OWG sparse data.
2254 AHM 28-Dec-83
Make type 1070 local and global symbol definitions use 30 bit
relocation instead of 18 bit RH relocation. Unlike type 2
blocks, 1070 blocks do not use LINK's kludge of relocating the
whole symbol value if the left half is zero.
2267 AHM 16-Jan-84
Complete the work of edit 2254 (I hope). Make type 1070 RH
chained and additive fixups also use 30 bit relocation instead
of 18 bit RH relocation.
2311 PLB 19-Feb-84 IGNORANCE IS STRENGTH
Add routine ZOUTADDR to output 24 bits to listing; ZOUTOFFSET
now uses ZOUTADDR. New routine ZOUSMOFFSET uses ZOUTOCT like
in days of yore.
2323 AHM 14-Mar-84
Create a new routine named Z30CODE which will output R30CODE
(type 1030) 30 bit relocation rel blocks under /EXTEND. It
calls ZCODE under /NOEXTEND. Also, make ZOUTBLOCK recognize
that type 1030 blocks need a loading address put in the first
word of a buffer, just like 1 and 1010 blocks. Finally, make
DMPMAINRLBF recognize that all blocks greater than or equal to
1000 are long count blocks.
2330 AHM 28-Mar-84
Make OUTCHDATA use EXTENDED instead of .OWGBPSECTION NEQ 0 as
the test for changing OWGBPs to OWLBPs when generating type
1004 byte initialization REL blocks. This removes all
references to OWGBPSECTION from this module.
2342 AHM 17-Apr-84
Make DATA statements work for some variables in .LARG. Make
OUTCHDATA use the psect indices in the variables it is passed
instead of always using .DATA. Move EXTERNPSECT into a GLOBAL
BIND in GLOBAL so that OUTDATA in OUTMOD can reference it.
This should allow CHARACTER variables in the first section of
.LARG. to be statically initialized by DATA statements.
2423 AHM 17-Jul-84
Move OUTCHDATA to DATAST, where it can share secret OWNs for
buffering Ultimate Sparse Data REL blocks.
2434 CDM 23-Jul-84
Enhance argument checking to differentiate between character
expressions /EXTEND and /NOEXTEND. We do not want to pass a one
word LOCAL byte pointer where a GLOBAL is wanted. This
condition could reference data in the wrong section.
2502 CDM 20-Nov-84
Correct argument checking in the coercion block to have LINK
complain about calling a function as if it were a subroutine.
Module:
RELBUF
2517 CDM 1-Feb-85
Enhancements to argument checking, upgrading for statement
functions to be up with external routines, and a few bug fixes in
statement functions. Added checks for structure in arguments;
singleton (scalar), array, routine. Added character length
checking in statement functions.
***** End V10 Development *****
***** 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
EVALTAB EVALU, ! Table for conversion from Fortran [valtype] to
! type codes for LINK.
%2432% EXTERNPSECT, ! Table of external psect indices
! indexed by internal psect indices
%1521% HIORIGIN, ! Origin of HISEG
LSTOUT, ! Routine to output a character to the listing
RELBUFF LOCRLBF,! Buffer for type 10 local request rel blocks
! (Does fixups for forward refs to a label)
RELBUFF MAINRLBF, ! Main rel file buffer - used for type 1 and 1010
! (code and data) as well as miscellaneous
! (hiseg, end, etc.)
%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
RELBUFF SYMRLBF;! Buffer for type 2 and 1070 symbol rel blocks
! (Symbol definitions and global requests)
FORWARD
ZCODE, ! Output a data word in a type 1 or 1010 block
%2323% Z30CODE, ! Output a 1030 block or pass the buck to ZCODE
%1512% ZSYMBOL, ! Outputs symbols to the REL file
ZOUTBLOCK, ! Buffers a word to the REL file
%1512% ZNEWBLOCK, ! Buffers a word of an unrelocated block type
BUFFOUT, ! Stores a data word into a particular rel buffer
DMPMAINRLBF,
INIRLBUFFS, ! Initializes all 3 REL file buffers
DMPRLBLOCK,
LSTRLWD, ! List a word of the rel file for /EXPAND
ZOUTMSG, ! Prints an ASCIZ string
ZOUTSYM, ! Lists a SIXBIT symbol
ZOUTOCT, ! List octal half word
ZOUTADDR, ! Output 24 bit octal address to listing file
RADIX50, ! Return Radix-50 of the sixbit word in R2
ZOUDECIMAL, ! Output a decimal number
ZOUOFFSET, ! List a value as a signed octal offset
ZOUSMOFFSET, ! List an 18 bit (small) signed offset
ZSAVEOUT,
%1521% ZARGCHECK, ! Puts out type checking blocks for subprog calls.
%1521% SIXTO7, ! Sixbit to ASCIZ conversion.
%1521% TPARGDES, ! Fills in buffer for each argument.
%1521% ZSFARGCHECK, ! Puts out type checking blocks for subprog definitions
%1521% ZCOERCION, ! Puts out coercion blocks for type checking.
%1770% SECDESC; ! Returns size needed for secondary descriptor in
%1770% ! argument checking.
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 Z30CODE(EAPSECT,LOADPSECT) =
!++
! FUNCTIONAL DESCRIPTION:
!
! If /NOEXTEND, then let ZCODE output the data word in RDATWD,
! passing EAPSECT and LOADPSECT unchanged as arguments.
! Otherwise, do the following:
!
! Call CGERR if called with EAPSECT or LOADPSECT set to PSOOPS.
!
! Set up CURADDRESS and CURPSECT from LOADPSECT in case a new
! REL buffer needs the current loading address.
!
! Call ZOUTBLOCK to place RDATWD in an R30CODE (type 1030) REL
! block, relocated by EAPSECT.
!
! FORMAL PARAMETERS:
!
! EAPSECT Internal index of psect to relocate the Y of RDATWD.
!
! LOADPSECT Internal index of RDATWD's destination psect.
!
! IMPLICIT INPUTS:
!
! PSECTS Table of relocation counters, indexed by
! internal psect index.
!
! RDATWD The word to be output to the REL file.
!
! IMPLICIT OUTPUTS:
!
! CURADDRESS The object address that RDATWD will be loaded into.
!
! CURPSECT The external index of psect that RDATWD will go into.
!
! PSECTS Updated relocation counter for current psect.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! May flush MAINRLBF, which will cause output to the REL file.
!
! May ICE the compiler if a PSOOPS psect index is encountered.
!
!--
BEGIN ![2323] New
IF NOT EXTENDED ! /EXTEND?
THEN ZCODE(.EAPSECT,.LOADPSECT) ! No, use 18 bit RH relocation
ELSE
BEGIN ! EXTENDED
IF .EAPSECT EQL PSOOPS ! Bad psect index for E/A?
THEN CGERR() ! Yes, cause an ICE
ELSE IF .LOADPSECT EQL PSOOPS ! No, how about load address?
THEN CGERR(); ! Yes, die horribly
CURADDRESS = .PSECTS[.LOADPSECT]; ! Get loading address
CURPSECT = .EXTERNPSECT[.LOADPSECT]; ! Translate into
! external psect index
ZOUTBLOCK(R30CODE,.EXTERNPSECT[.EAPSECT]); ! Output word
END; ! EXTENDED
END; ! of Z30CODE
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,RLSR30), ![2254]
%LOCSUPDEF:% TYPE1070FILL(RLSLOCAL OR RLSSUPPRESS,RLSR30), ![2254]
%GLBDEF:% TYPE1070FILL(RLSGLOBAL,RLSR30), ![2254]
%GLBSUPDEF:% TYPE1070FILL(RLSGLOBAL OR RLSSUPPRESS,RLSR30), ![2254]
%GLBSYMFIX:% TYPE1070FILL(RLSGLOBAL OR RLSSYMBOL OR RLS30FIX,RLSRABS),![1570]
%GLB18CHNFIX:% TYPE1070FILL(RLSGLOBAL OR RLSCHAIN OR RLSRHFIX,RLSR30), ![2267]
%GLB18ADDFIX:% TYPE1070FILL(RLSGLOBAL OR RLSADDITIVE OR RLSRHFIX,RLSR30),![2267]
%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
%2323% OR .ZBLKTYPE EQL R30CODE
%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
%2323% IF .MAINRLBF[RTYPE] GEQ RLNGCNTBLK ! Long count block?
%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 ZOUTSYM
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 ZOUTADDR= ![2311] /PLB
!++
! FUNCTIONAL DESCRIPTION:
!
! OUTPUT 24 BIT OCTAL ADDRESS TO LISTING FILE; 24 BITS (8 OITS)
! IS THE ADDRESS SPACE IMPLEMENTED BY THE EXTENDED KL.
!
! FORMAL PARAMETERS:
!
! NONE
!
! IMPLICIT INPUTS:
!
! ADDRESS IN GLOBAL REGISTER R2
!
! IMPLICIT OUTPUTS:
!
! TRASHES R1, R2, CHR
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! OUTPUT TO LISTING FILE
!
!--
BEGIN
MACHOP
LSH=#242;
REGISTER
I;
R1 = 0;
I = 8; !THIS MANY OITS
LSH(R2,12); !MAKE BITS LEFT JUSTIFIED
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 ZOUTADDR
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
!LIST IN ASCII THE VALUE OF R1 A REGISTER
IF .R1 LSS 0 THEN CHR _ "-" ELSE CHR _ "+";
LSTOUT();
%2311% IF EXTENDED
%2311% THEN
%2311% BEGIN
%2311% R2 _ ABS(.R1);
%2311% ZOUTADDR()
%2311% END
%2311% ELSE
%2311% BEGIN
R2<LEFT> _ ABS(.R1);
ZOUTOCT() !OCTAL OUTPUT VALUE IN R2<LEFT>
%2311% END
END; ! of ZOUOFFSET
GLOBAL ROUTINE ZOUSMOFFSET= ![2311] /PLB
!++
! FUNCTIONAL DESCRIPTION:
!
! OUTPUT AN 18 BIT (SMALL) SIGNED OFFSET TO THE LISTING FILE
!
! FORMAL PARAMETERS:
!
! NONE
!
! IMPLICIT INPUTS:
!
! SIGNED BINARY OFFSET IN GLOBAL REGISTER R1
!
! IMPLICIT OUTPUTS:
!
! TRASHES R1, R2, CHR
!
! ROUTINE VALUE:
!
! TRASH
!
! SIDE EFFECTS:
!
! OUTPUT TO LISTING
!
!--
BEGIN
IF .R1 LSS 0 THEN CHR _ "-" ELSE CHR _ "+"; !GET CHAR FOR SIGN
LSTOUT(); !OUTPUT IT
R2<LEFT> _ ABS(.R1); !GET ABSOLUTE VALUE FOR ZOUTOCT
ZOUTOCT() !OCTAL OUTPUT VALUE IN R2<LEFT>
END; ! of ZOUSMOFFSET
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 ! Blank SAVE not specified
! 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
! If we don't have any common blocks left, and there were
! not any local variables delclared in SAVE or blank common
! blocks in the program, then return now and don't bother
! outputting a rel block.
%2022% IF (.NUMSAVCOMMON EQL 0) ! No commns left
%2075% THEN IF NOT (.SAVLOC OR .SAVBLC) ! No locals or blk comm
%2022% THEN RETURN; ! SAVE not needed.
END; ! Blank SAVE not specified
! Fill in header word
MAINRLBF[SVTYPE] = RWRITELINK; ! Block type
MAINRLBF[SVCOUNT] = 1 + .NUMSAVCOMMON; ! Number of words in rel block
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. If needed, add one to the
! count of words in the rel block.
DECR CNT FROM .ARGLIST[ARGCOUNT] TO 1
%1770% DO IF SECDESC(.ARGLIST[.CNT,ARGNPTR]) NEQ 0
THEN MAINRLBF[TPRELSIZE] =
.MAINRLBF[TPRELSIZE] + 1; ! Extra word
! If this is a character function, we must
! include the function's return value (and check
! if a secondary descriptor's needed) twice.
! The first time is for the physical location
! which is the first argument in arg block and
! the second is for the dummy location we put as
! the last argument 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;
! Bump the count if we need an extra
! word for a secondary descriptor.
%1770% IF SECDESC(.ARGLIST[1,ARGNPTR]) NEQ 0
THEN MAINRLBF[TPRELSIZE] =
.MAINRLBF[TPRELSIZE] + 1;
%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
!++
! FUNCTIONAL DESCRIPTION:
!
! 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.
!
! FORMAL PARAMETERS:
!
! ARGOFFSET Offset into buffer MAINRLBF.
! Returned as either +1, +2, or reset to zero.
!
! CNODE Node to retrieve information from.
!
! IMPLARG Flag on whether this argument is implicit.
!
! IMPLICIT INPUTS:
!
! Unknown
!
! IMPLICIT OUTPUTS:
!
! Unknown
!
! ROUTINE VALUE:
!
! Returns current offset into buffer.
!
! SIDE EFFECTS:
!
! Outputs 1120 blocks to the .REL file.
!
!--
BEGIN
MAP BASE CNODE;
MAP RELBUFFER MAINRLBF; ! Buffer to put information into.
REGISTER ARGSIZE, ! Size in bytes of a character variable from
! CHEXLEN.
%2517% TMP; ! Temporary. Used for structure calculation.
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;
%1770% IF .CNODE[OPR1] EQL CONSTFL
THEN
BEGIN ! Argument is constant
%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, except for a "few"
! special cases.
IF .CNODE[OPRCLS] EQL LABOP
THEN MAINRLBF[.ARGOFFSET,TPTYP] = ADDRTYPE ! Alternate return lab
ELSE
%2434% BEGIN ! Not Label
%2434%
%2434% ! We want Character /EXTEND to be different so we can tell
%2434% ! the difference between passing a one word LOCAL byte pointer
%2434% ! and a one word GLOBAL byte pointer.
%2434%
%2517% IF NOT (.CNODE[OPR1] EQL FNNAMFL ! Don't give a type
%2517% AND .CNODE[IDSUBROUTINE]) THEN ! to a subroutine name
%2434% IF (.CNODE[VALTYPE] EQL CHARACTER) AND EXTENDED
%2434% THEN MAINRLBF[.ARGOFFSET,TPTYP] = TYPEXTCHARACTER
%2434% ELSE ! Index into table based on type of variable
MAINRLBF[.ARGOFFSET,TPTYP] = .EVALU[.CNODE[VALTYPE]];
%2434%
%2434% END; ! Not Label
%2517% ! Insert argument structure code. We have three types of
%2517% ! structures:
%2517% !
%2517% ! o Singleton (single unit)
%2517% ! o Array (multi unit)
%2517% ! o Routine
%2517% !
%2517% ! DATAOPR's have this built into the DATOPS1 field, expressions
%2517% ! of any sort are singleton.
%2517%
%2517% IF .CNODE[OPRCLS] EQL DATAOPR
%2517% THEN
%2517% BEGIN ! DATAOPR's have DATOPS1 defined
%2517%
%2517% CASE .CNODE[DATOPS1] OF SET
%2517%
%2517% TMP = TPSINGLETON; ! Constant/temp
%2517% TMP = TPSINGLETON; ! VARIABL1
%2517% TMP = TPARRAY; ! ARRAYNM1
%2517% TMP = TPROUTINE; ! FNNAME1
%2517%
%2517% TES;
%2517%
%2517% IF .CNODE[IDATTRIBUT(FENTRYNAME)] ! Function entry
%2517% THEN TMP = TPROUTINE; ! name?
%2517%
%2517% END ! DATAOPR's have DATOPS1 defined
%2517% ELSE TMP = TPSINGLETON; ! Non DATAOPR
%2517%
%2517% MAINRLBF[.ARGOFFSET,TPSTR] = .TMP; ! Store calc'd structure
%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.
%1770% IF (ARGSIZE = SECDESC(.CNODE)) NEQ 0
THEN
BEGIN ! Secondary descriptor needed
MAINRLBF[.ARGOFFSET,TPSND] = 1; ! 1 secondary descriptor
ARGOFFSET = .ARGOFFSET + 1;
MAINRLBF[.ARGOFFSET,FULL] = 0;
! Set length(formal) =< length(actual) for allowable
! conditions. This is according to the ANSI-77 standard,
! section 15.9.3.1. This has been extended to include
! character 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
! Puts out 1120 arg checking blocks for SUBROUTINE and FUNCTION
! statements. Routine walks through any and all ENTRY points linked
! together to put out this rel block.
! Must be careful 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
DECR CNT FROM .ARGCNT TO 1 DO
BEGIN ! For each argument
CNODE = .ARGLIST[.CNT,ARGNPTR];
IF .CNODE NEQ 0 THEN ! Return label
%1770% IF SECDESC(.CNODE) NEQ 0
THEN MAINRLBF[TPRELSIZE] =
.MAINRLBF[TPRELSIZE] + 1;
END;
! If this is a character function, we must include the
! function's return value (and check if a secondary
! descriptor's needed) twice. The first time is for the
! physical location which is the first argument in the
! arg block and the second is for the dummy location we
! put as the last argument 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
%1770% IF SECDESC(.ARGLIST[1,ARGNPTR]) NEQ 0
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=
!++
! FUNCTIONAL DESCRIPTION:
!
! 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.
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! MAINRLBF The buffer used to output rel blocks.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! A coercion rel block is output the the .rel file.
!
!--
BEGIN
MAP RELBUFFER MAINRLBF; ! Buffer to output block.
%1674% LOCAL HEADRWORD; ! Header word for rel block.
! The information format is:
! +---------------------+-----------------------+
! | Field code | Action to take |
! +---------------------+-----------------------+
! | Formal attribute | Actual attribute |
! +---------------------+-----------------------+
MACRO COERCE(FIELD, ACTION, FORMAL, ACTUAL)
= ((FIELD)^18 OR ACTION), ! 1st word
((FORMAL)^18 OR ACTUAL)$; ! 2nd word
BIND YES=1,
NO=0;
! Table used if /DEBUG:ARGUMENTS is NOT specifed
! Must be a PLIT so that we have a word count of the table.
%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),
%2434% ! Can't pass a one word LOCAL byte pointer when the routine
%2434% ! expects a one word GLOBAL byte pointer.
%2434%
%2434% COERCE(CBTYP, CBNOACTION, TYPCHARACTER, TYPEXTCHARACTER),
%2434% COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPCHARACTER)
); ! Table used if /DEBUG:ARGUMENTS is NOT specifed
! Table used if /DEBUG:ARGUMENTS is specified.
! Must be a PLIT so that we have a word count of the table.
%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 funtion return value on either side.
%1674%
%1674% COERCE(CBRETVAL, CBWARNING, NO, YES),
%2502% COERCE(CBRETVAL, CBWARNING, YES, NO),
%1674% ! Complain for character argument length missmatches
%1674%
%1674% COERCE(CBARGLEN, CBWARNING, 0, 0),
%2434% ! Can't pass a one word LOCAL byte pointer when the routine
%2434% ! expects a one word GLOBAL byte pointer.
%2434%
%2434% COERCE(CBTYP, CBNOACTION, TYPCHARACTER, TYPEXTCHARACTER),
%2434% COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPCHARACTER),
%2517% ! Give warnings for invalid structure mixups. Mixing up of
%2517% ! singleton and array names with routine names are an
%2517% ! error. Mixing of arrays and singletons are probably done
%2517% ! by the users (ugh) and are not. Mixing with "not
%2517% ! specified" means a program compiled prior to this edit,
%2517% ! since the field would be zero for that case.
%2517%
%2517% COERCE(CBSTRUCTURE, CBNOACTION, TPSINGLETON, TPARRAY),
%2517% COERCE(CBSTRUCTURE, CBWARNING, TPSINGLETON, TPROUTINE),
%2517% COERCE(CBSTRUCTURE, CBNOACTION, TPSINGLETON, TPNOTSPECIFIED),
%2517%
%2517% COERCE(CBSTRUCTURE, CBNOACTION, TPARRAY, TPSINGLETON),
%2517% COERCE(CBSTRUCTURE, CBWARNING, TPARRAY, TPROUTINE),
%2517% COERCE(CBSTRUCTURE, CBNOACTION, TPARRAY, TPNOTSPECIFIED),
%2517%
%2517% COERCE(CBSTRUCTURE, CBWARNING, TPROUTINE, TPSINGLETON),
%2517% COERCE(CBSTRUCTURE, CBWARNING, TPROUTINE, TPARRAY),
%2517% COERCE(CBSTRUCTURE, CBNOACTION, TPROUTINE, TPNOTSPECIFIED),
%2517%
%2517% COERCE(CBSTRUCTURE, CBNOACTION, TPNOTSPECIFIED, TPSINGLETON),
%2517% COERCE(CBSTRUCTURE, CBNOACTION, TPNOTSPECIFIED, TPARRAY),
%2517% COERCE(CBSTRUCTURE, CBNOACTION, TPNOTSPECIFIED, TPROUTINE),
! 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),
%2434% COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, 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),
%2434% COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, 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),
%2434% COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, 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),
%2434% COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, 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),
%2434% COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, 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),
%2434% COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, 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),
%2434% COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, 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),
! Character Actual /EXTEND
%2434% COERCE(CBTYP, CBWARNING, TYPLABEL, TYPEXTCHARACTER),
%2434% COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPEXTCHARACTER),
%2434% COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPEXTCHARACTER),
%2434% COERCE(CBTYP, CBWARNING, TYPREAL, TYPEXTCHARACTER),
%2434% COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPEXTCHARACTER),
%2434% COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPEXTCHARACTER),
%2434% COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPEXTCHARACTER),
! 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),
%2434% COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, 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),
%2434% COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPDBLOCTAL),
! Hollerith actual
%1674% COERCE(CBTYP, CBWARNING, TYPLABEL, TYPHOLLERITH),
COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPHOLLERITH),
%2434% COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPHOLLERITH)
); ! Table used if /DEBUG:ARGUMENTS is specified.
! 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
GLOBAL ROUTINE SECDESC(ARG)= ![1770] New
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! SECDESC returns the length needed for a secondary descriptor for
! argument checking for the argument passed or 0. 0 is returned
! if the size is not calculable at compile time (length star
! character) or not significant (non array numeric).
!
! FORMAL PARAMETER:
!
! ARG Is an argument expression to be passed to a user
! subprogram.
!
! IMPLICIT INPUTS:
!
! FLGREG
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! Returns size of argument found; bytes for character, words for
! numeric arrays, or 0 if a secondary descriptor isn't needed.
! The size of the entire element is returned, so a bare array gets
! all of its elements.
!
! SIDE EFFECTS:
!
! None
!
!--
MAP BASE ARG; ! Argument expression
REGISTER
BASE EXPRLEN, ! Expression length
BASE DIMTAB; ! Dimension table entry
! Unless /DEBUG:ARGUMENTS is specified, there's no point in
! putting out the secondary descriptors.
IF NOT .FLGREG<DBGARGMNTS> THEN RETURN 0;
! Return the value, if possible, of the character expression or
! numeric array.
IF .ARG[VALTYPE] EQL CHARACTER
THEN
BEGIN ! Character argument
! Length * means that the length is not calculable at
! compile time.
IF (EXPRLEN = CHEXLEN(.ARG)) NEQ LENSTAR
THEN RETURN .EXPRLEN;
END
ELSE
BEGIN ! Numeric argument
! We're not interested unless this is a bare array. A
! bare array is the only numeric quantity that may have
! multiple elements to check the length of.
IF .ARG[OPR1] EQL ARRAYFL
OR .ARG[OPR1] EQL FMLARRFL
THEN
BEGIN ! Array
DIMTAB = .ARG[IDDIM]; ! Dimens table ref
! Size is not calculable at compile time
! if the array is assumed size or adjustably
! dimensioned.
IF NOT .DIMTAB[ASSUMESIZFLG] THEN
IF NOT .DIMTAB[ADJDIMFLG]
THEN RETURN .DIMTAB[ARASIZ]; ! return size
END; ! Array
END; ! Numeric argument
RETURN 0; ! No secondary descriptor needed
END; ! of SECDESC
END
ELUDOM