Trailing-Edge
-
PDP-10 Archives
-
bb-4157h-bm_fortran20_v10_16mt9
-
fortran-compiler/srca.bli
There are 12 other files named srca.bli in the archive. Click here to see a list.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
!AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!AUTHOR: F. INFANTE/HPW/NEA/DCE/SJW/CDM/TFV/AHM/PLB/AlB/RVM
MODULE SRCA(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND SRCAV = #10^24 + 0^18 + #2464; ! Version Date: 8-Oct-84
%(
***** Begin Revision History *****
41 ----- ----- REWRITE CORMAN TO ALLOCATE IN PAGES OR
K DEPENDING UPON PROCESSOR
REWRITE CORMAN TO ELIMINATE REFERENCES
TO BREG
MAKE ERROUT EXTERNAL IN NEWENTRY
42 ----- ----- FIX NEWENTRY TO USE OPERSP INSTEAD OF SRCID
IN I/O LIST NODES
43 ----- ----- TAKE OUT 42
44 ---- ----- PUNT
45 ----- ----- PUNT + 1
46 ----- ----- ADD MAKEPR TO THIS MODULE
47 ----- ----- HAVE NEWENTRY SET THE NOALLOC BIT FOR SYMBOL
TABLE ENTRIES GENERATED WHILE IN PHASE 1
48 ---- ----- CHANGE THE NAME OF LIBSRCH TO SRCHLIB ( JUST TO
GET ALL REFERENCES) AND ITS PARAMETER TO A
SYMBOL TABLE POINTER RATHER THAN A NAME.
THEN REJECT AND NAMES THAT HAVE BEEN TYPED WITH
A CONFLICTING TYPE EVEN THOUGH THEY ARE LIBRARY
FUNCTION NAMES
49 355 18132 ALLOCATE MORE THAN ONE CORE BLOCK AT A TIME, (DCE)
***** Begin Version 5A *****
50 543 NONE FIX THE BINARY SEARCH FOR LIBRARY FUNCTIONS
51 574 NONE REWRITE BINARY SEARCH IN SRCHLIB TO WORK AFTER
EDIT 543, (SJW)
***** Begin Version 5B *****
52 707 27153 CHANGE SAVSPACE TO REDUCE JOBFF IF POSSIBLE, (DCE)
***** Begin Version 6 *****
53 1133 TFV 28-Sep-81 ------
Keep track of the maximum size of the compiler lowseg in MAXFF
for /STATISTICS output.
***** Begin Version 7 *****
54 1270 CDM 6-Oct-81
Changed SRCHLIB not to give up when it finds a library name that
was declared in a type declaration. (deleted code)
55 1406 TFV/CDM 18-Dec-81
Write NEWDVAR to create a .Dnnnn variable for a
compile-time-constant character descriptor. The entries are all
linked together. They have an OPRCLS of DATAOPR and an OPERSP
of VARIABLE. Either one word (byte pointer only) or two words
(byte pointer and length) are generated based on the flag
IDGENLENFLG. One word .Dnnnn variables are used for SUBSTRINGs
with constant lower bounds and non-constant upper bounds.
1526 AHM 11-May-82
Make GENLAB always set SNPSECT of the label table entry it is
creating to the .CODE. psect.
1530 TFV 4-May-82
Cleanup CORMAN and SAVSPACE. Symbolize the number of FREELISTs
using FLSIZ. Free nodes of at least FLSIZ words are linked onto
FREELIST[0]. Free nodes of SIZE words are linked onto
FREELIST[.SIZE].
1535 CDM 28-Jun-82
Moved MAKLIT to here.
1521 CDM 29-Jun-82
Moved routine SECDESC to here from RELBUF.
1567 CDM 1-Jul-82
Changed name of SECSESC to CHEXLEN (CHaracter EXpression LENgth).
1600 PLB 9-Jul-82
Convert CORMAN to use CORUUO simulated CORE UUO from
COMMAN.MAC, so as to avoid spurious NXP interupts.
Added REQUIRE for FTTENX.
***** End V7 Development *****
1732 CDM 17-March-83
Change CLINK to LITLINK, set PRVLIT.
***** Begin Version 10 *****
2200 TFV 11-Mar-83
Link INQUIRE statement into IOFIRST, IOLAST linked list.
2205 CDM 21-JUN-83
Add manipulation of EFIW tables to NEWENTRY, TBLSEARCH,
TESTENTRY, THASH, add MAKEFIW.
Obliterate macro references BP, BPR, BASEPOINT and replace them
with the global symbol BASEPTR, which they defined as. Also
kill macro PARM which was defined to be ENTRY, and not even
used!
2322 CDM 18-Apr-84
Fix array subscript calculations for /EXTEND. In PROCEQUIV and
BLDDIM, correct maximum size of an array of a legal array
declaration /EXTEND. In BLDDIM, call CNSTCM for array size
calculations to give proper underflow/overflow messages for
illegal declarations. Otherwise arrays that are too large may
not be detected. Add routines ADDINT, MULINT, and SUBINT.
2236 AlB 11-Nov-83
Jam PSDATA into the psect field (COMPSECT) of the Common Block
entry when it is built. This code could be removed when the
command handler recognizes Common in the /EXTEND switch.
Routine: NEWENTRY
2343 RVM 18-Apr-84
Create the FNDCOMMON routine to manipulate ECTAB, the table of
COMMON blocks named in /EXTEND:[NO]COMMON. Use FNDCOMMON to
correctly set the psect of COMMON blocks as they are created
in NEWENTRY. The edit supersedes 2236.
2356 AHM 8-May-84
Make NEWENTRY set the new flag globals LCOMP or SCOMP when
creating COMMON blocks in a particular psect.
2464 AHM 8-Oct-84
Have MAKEFIW pass a variable's IDPSECT instead of 0 in
ENTRY[2] when calling TBLSEARCH.
++++ PLB 25-Oct-84
Add code to support COMPLEX parameter arithmetic. Routines
handle operations on scaled double precision numbers.
***** End V10 Development *****
***** End Revision History *****
)%
REQUIRE 'FTTENX.REQ'; ![1600] O/S Feature test
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
FORWARD
ADDLOOP(1),
TBLSEARCH,
THASH,
SRCHLIB(1),
NEWENTRY,
TESTENTRY,
SAVSPACE(2),
CORMAN,
GENLAB,
MAKEPR(5),
MAKPR1(6),
NEWDVAR, ! Create new .Dnnnn variable
%2205% MAKEFIW(4), ! Returns EFIW table entry (new or used)
%2322% ADDINT(2), ! Integer add routine using CNSTCM
%2322% MULINT(2), ! Integer mul routine using CNSTCM
%2322% SUBINT(2); ! Integer sub routine using CNSTCM
EXTERNAL
%2322% C1H, ! High word of argument
%2322% C1L, ! Low word of argument
%2322% C2H, ! High word of argument
%2322% C2L, ! Low word of argument
CGERR,
CHAR,
%2322% CNSTCM, ! Does acurate arithmetic (Constant combine)
%2322% COPRIX, ! Argument to CNSTCM
CORERR,
%1600% CORUUO, ! Simulated CORE UUO
%1406% DANCHOR, ! Pointer to start of linked list of .Dnnnn variables.
! They are used for compile-time-constant character
! descriptors. They are not reused.
%1406% DCNT, ! Counter to use when generating the next .Dnnnn
DELETPTR,
%2343% DFCMPS, ! Default psect for COMMON blocks (set by /EXTEND).
DLOOPTREE,
%2343% VECTOR ECHASH, ! Hash table of COMMON blocks named in /EXTEND switch.
%2343% ECHSHL, ! Length of the hash table for list of COMMON blks.
%2343% VECTOR ECTAB, ! Table of COMMON blocks named in /EXTEND switch.
%2343% ECTABL, ! Number of common blocks which can be named in a
%2343% ! /EXTEND switch.
%2343% ECRECL, ! Size of an entry in ECTAB
%2343% ECUSED, ! Number of entries in ECTAB
%2205% BASE EFIWTBL, ! EFIW hash table
ENTRY,
FREELIST, ! Vector of free nodes. Nodes of at least FLSIZ
! words are linked onto FREELIST[0] and are not
! reused. All other nodes are linked onto
! FREELIST[.SIZE].
ILABIX,
IOLSPTR,
JOBFF,
JOBREL,
LASLVL0,
%1406% BASE LASTD, ! Pointer to the last .Dnnnn variable created
%2356% LCOMP, ! Flag for at least one COMMON block in .LARG.
LIBATTRIBUTES,
LIBFUNTAB,
LITERL,
%1133% MAXFF, ! Maximum size of compiler lowseg
NAME,
NAMLPTR,
%1732% PRVLIT, ! Previous literal in linked literal list.
PUTMSG,
QUEUE,
%2356% SCOMP, ! Flag for at least one COMMON block in .DATA.
SEGINCORE,
SPACEFREE,
STTTYP,
TABSPACE,
TTOTAL;
GLOBAL ROUTINE ADDLOOP(LEVEL)=
BEGIN
!***************************************************************
! Add DO loop node to tree. This routine builds a tree that
! describes the DO loops of a program. See the DO tree node
! description in FIRST.BLI. The tree is binary in the sense
! that it points to only one parallel loop and one loop at a
! deeper level.
!***************************************************************
LOCAL BASE DOFATHER;
OWN TEM1;
REGISTER BASE DONODE;
MAP BASE SORCPTR;
XTRAC; ! For debugging trace
NAME<LEFT> = DONODESIZ;
TEM1 = CORMAN(); ! Reserve space for entry
IF .DLOOPTREE EQL 0
THEN
BEGIN
DONODE = .TEM1;
DLOOPTREE = .DONODE;
LASLVL0 = .DONODE;
DONODE[LEVL] = 1;
SORCPTR[INNERDOFLG] = 1;
DONODE[DOSRC] = .LASTSRC;
RETURN .DONODE
END;
DONODE = .LASLVL0<RIGHT>; ! Set up search
WHILE 1 DO
BEGIN
WHILE .DONODE[PARLVL] NEQ 0 DO DONODE = .DONODE[PARLVL];
IF .DONODE[LEVL] EQL .LEVEL
THEN
BEGIN ! Equal level of DO. First time through .LEVEL
! must equal 0 to do the setup
DONODE[PARLVL] = .TEM1; ! The parallel level
DONODE = .TEM1;
DONODE[LEVL] = .LEVEL; ! Set level
! Set last level for next search
IF .LEVEL EQL 1 THEN LASLVL0 = .DONODE;
SORCPTR[INNERDOFLG] = 1;
DONODE[NEXTDO] = 0; ! Zero next DO level
DONODE[DOSRC] = .LASTSRC;
RETURN .DONODE
END; ! Equal level of DO. First time through .LEVEL
! must equal 0 to do the setup
DO
BEGIN
WHILE .DONODE[PARLVL] NEQ 0
DO DONODE = .DONODE[PARLVL];
IF .DONODE[NEXTDO] EQL 0
THEN
BEGIN
DOFATHER = .DONODE[DOSRC];
DOFATHER[INNERDOFLG] = 0;
DONODE[NEXTDO] = .TEM1; ! Deeper level of DO
DONODE = .TEM1; ! New ptr to deepest DO
SORCPTR[INNERDOFLG] = 1;
DONODE[LEVL] = .LEVEL;
DONODE[DOSRC] = .LASTSRC;
RETURN .DONODE
END;
DONODE = .DONODE[NEXTDO];
END
WHILE .DONODE[LEVL] LSS .LEVEL;
END; ! of WHILE 1 DO
END; ! of ADDLOOP
GLOBAL ROUTINE TBLSEARCH=
BEGIN
!***************************************************************
! Makes an entry into a dynamic table as specified by the global
! NAME. Existing table entries are searched to see if an
! identical entry has already been made. It returns a pointer
! to the table entry made or found and also sets FLAG (in
! FLGREG). If the entry was already in the table, FLAG is set to
! -1, otherwise 0.
!
! Global arguments:
! NAME - entry size ,, table number
! ENTRY - Vector of arguments to be looked up and/or
! entered in a table.
!***************************************************************
BIND
%2205% LISTX = UPLIT( SYMTBL<0,0>, ! 0
%2205% CONTBL<0,0>, ! 1
%2205% EXPTBL<0,0>, ! 2
%2205% LABTBL<0,0>, ! 3
%2205% 0, ! 4
%2205% 0, ! 5
%2205% 0, ! 6
%2205% 0, ! 7
%2205% 0, ! 8
%2205% 0, ! 9
%2205% 0, ! 10
%2205% 0, ! 11
%2205% 0, ! 12
%2205% 0, ! 13
%2205% 0, ! 14
%2205% EFIWTBL<0,0>), ! 15
%2205%
%2205% ITEM = .LISTX[.NAME<RIGHT>];
LOCAL I;
MAP BASE DELETPTR;
%2205% MACRO NOTHASHED =
%2205% BEGIN
NEWENTRY();
FLAG = 0;
RETURN .BASEPTR ! NEWENTRY resets BASEPTR
%2205% END$;
XTRAC; ! For debugging trace
%2205% CASE .NAME<RIGHT> OF SET
%2205% BEGIN END; ! 0 Symbol table - Hash below
%2205% BEGIN END; ! 1 Constant table - Hash below
%2205% BEGIN END; ! 2 Common subexpression - Hash below
%2205% BEGIN END; ! 3 Label table - Hash below
%2205% NOTHASHED; ! 4 COMMON block
%2205% NOTHASHED; ! 5 Encoded source
%2205% NOTHASHED; ! 6 Dimension
%2205% NOTHASHED; ! 7 Expression
%2205% NOTHASHED; ! 8 Iolist
%2205% NOTHASHED; ! 9 Literal
%2205% NOTHASHED; ! 10 Library funcion id
%2205% NOTHASHED; ! 11 Equivalence group
%2205% NOTHASHED; ! 12 Equivalence list
%2205% RETURN; ! 13 Data group - Don't process
%2205% RETURN; ! 14 Namelist group - Don't process
%2205% BEGIN END; ! 15 - EFIW table - Hash below
%2205% TES;
! Table is to be hashed
I = THASH(); ! Get hash position
BASEPTR = .ITEM[.I]; ! Get hash table entry value
IF .BASEPTR EQL 0
THEN
BEGIN ! Unique hash - generate a new entry
NEWENTRY(); ! Initialize BASEPTR and setup data
ITEM[.I] = .BASEPTR;
BASEPTR[CLINK] = 0;
FLAG = 0;
RETURN .BASEPTR;
END ! Unique hash - generate a new entry
ELSE
BEGIN ! See if an entry is in the linked list for the hash I
WHILE 1 DO
BEGIN ! Search through each link off this hash
IF TESTENTRY() ! TESTENTRY may create an EFIW
! table entry.
THEN
BEGIN ! The entry is equal to an existing hash
FLAG = -1; ! Old entry
RETURN .BASEPTR;
END
ELSE ! Entry not equal
IF .BASEPTR[CLINK] NEQ 0
THEN BASEPTR = .BASEPTR[CLINK]
ELSE
BEGIN ! Last chance, no equal hash
NEWENTRY();
BASEPTR[CLINK] = .ITEM[.I]<RIGHT>;
ITEM[.I]<RIGHT> = .BASEPTR;
FLAG = 0; ! New entry
RETURN .BASEPTR;
END;
END ! Search through each link off this hash
END ! See if an entry is in the linked list for the hash I
END; ! of TBLSEARCH
GLOBAL ROUTINE THASH=
BEGIN
!***************************************************************
! Returns position in hash table. NAME to defines the table
! concerned.
!
! Global arguments:
! ENTRY - Vector of what to put in the table reference.
! NAME - Contains which table we're working on.
!***************************************************************
XTRAC; ! For debugging trace
RETURN ABS(CASE .NAME OF SET
.ENTRY MOD SSIZ; ! 0 - Symbol table
(.(ENTRY + 1) XOR .ENTRY) MOD CSIZ; ! 1 - Constant table
%2205% CGERR(); ! 2 - (Not used) Common sub-expression
%2205% .ENTRY MOD LASIZ; ! 3 - Statement number table
%2205% CGERR(); ! 4 - (Not used)
%2205% CGERR(); ! 5 - (Not used)
%2205% CGERR(); ! 6 - (Not used)
%2205% CGERR(); ! 7 - (Not used)
%2205% CGERR(); ! 8 - (Not used)
%2205% CGERR(); ! 9 - (Not used)
%2205% CGERR(); ! 10 - (Not used)
%2205% CGERR(); ! 11 - (Not used)
%2205% CGERR(); ! 12 - (Not used)
%2205% CGERR(); ! 13 - (Not used)
%2205% CGERR(); ! 14 - (Not used)
%2205% (.ENTRY[0] XOR .ENTRY[2]) MOD EFSIZ ! 15 - EFIW table
TES)
END; ! of THASH
GLOBAL ROUTINE SRCHLIB(NODE) =
BEGIN
!***************************************************************
! Search the library function table for the sixbit name in the
! IDSYMBOL field of NODE. If found then returns a pointer to
! the table entry. If not found then returns -1. Binary search
! is algorithm B in 6.2.1 of Knuth Vol. 3.
!***************************************************************
MAP
BASE NODE,
LIBATTSTR LIBATTRIBUTES;
OWN
TOP,
BOTTOM;
REGISTER
PARAM,
CENTER;
PARAM = .NODE [IDSYMBOL]; ! Get candidate name
TOP = LIBFUNTAB<0,0>; ! First table entry
! Note that ONEAFTERLIB is a counted plit
BOTTOM = (ONEAFTERLIB - 2)<0,0>; ! Last table entry
WHILE 1 DO
BEGIN
IF .BOTTOM LSS .TOP THEN RETURN -1; ! Entry not found
CENTER = (.TOP + .BOTTOM) / 2; ! Find mid-point
! Return pointer to table entry if desired entry found
%1270% IF .PARAM EQL @@CENTER THEN RETURN .CENTER<RIGHT>;
IF .PARAM GTR @@CENTER
THEN TOP = .CENTER + 1 ! Ignore old top thru center
ELSE BOTTOM = .CENTER - 1; ! Ignore center thru old bottom
END; ! of WHILE 1 DO
END; ! of SRCHLIB
GLOBAL ROUTINE FNDCOMMON(NAME, INSERT) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine searches ECTAB (the table of COMMON blocks named
! in an /EXTEND switch) for an entry for a particular COMMON
! block. If the entry is not found, this routine will create
! the entry if requested to do so.
!
! FORMAL PARAMETERS:
!
! NAME The SIXBIT name of the COMMON block to be search
! for or inserted.
! INSERT A flag: If true, then a new common block entry for
! NAME will be created if none exists. If false, no
! new entry will be created and a zero will be returned.
!
! IMPLICIT INPUTS:
!
! ECHASH Hash table for ECTAB.
! ECHSHL Length of the ECHASH.
! ECTAB Table of COMMON blocks named in /EXTEND.
! ECTABL Number of common blocks which can be named in a
! /EXTEND switch.
! ECRECL Size of an entry in ECTAB.
! ECUSED Number of entries in ECTAB.
!
! IMPLICIT OUTPUTS:
!
! ECHASH On INSERT, hash chain modified.
! ECTAB On INSERT, new entry created.
! ECUSED On INSERT, set to number of entries in ECTAB.
!
! ROUTINE VALUE:
!
! The address of the table entry for the COMMON block or zero. The
! zero has different interpretations depending on the value of the
! INSERT argument. If INSERT is true, this routine returns zero if
! the table overflowed and no new entry could be created. If INSERT
! is false, this routine returns zero if the entry for the COMMON
! block could not be found.
!
! SIDE EFFECTS:
!
! None
!
!--
![2343] New Routine
BEGIN
REGISTER HASH, BASE ENTRY;
! Calculate hash value
HASH = ABS(.NAME MOD ECHSHL<0,0>);
ENTRY = .ECHASH[.HASH];
WHILE .ENTRY NEQ 0
DO
BEGIN !Search for entry
IF .ENTRY[ECNAME] EQL .NAME THEN RETURN .ENTRY;
ENTRY = .ENTRY[ECLINK];
END; !Search for entry
! There is no entry matching NAME. See if a new entry should be
! created.
IF .INSERT
THEN
BEGIN !Create New Entry
!Get address of new entry
ENTRY = ECTAB[.ECUSED*ECRECL<0,0>]<0,0>;
ECUSED=.ECUSED+1;
! See if this entry overflows the table
IF .ECUSED GTR ECTABL<0,0> THEN RETURN 0;
ENTRY[ECNAME] = .NAME;
ENTRY[ECLINK] = .ECHASH[.HASH];
ECHASH[.HASH] = .ENTRY;
RETURN .ENTRY;
END; !Create New Entry
! No entry matched (and none was created).
RETURN 0;
END; ! of FNDCOMMON
GLOBAL ROUTINE NEWENTRY=
BEGIN
!***************************************************************
! Make a new table entry. The right half of the global NAME
! specifies which table.
!
! Global arguments:
! ENTRY, NAME
!***************************************************************
MAP
BASE COMBLKPTR,
BASE DATASPTR,
BASE EQVPTR,
BASE IOLSPTR,
BASE LABLOFSTATEMENT,
BASE LITPOINTER,
BASE NAMLPTR,
BASE SORCPTR;
OWN
TOP,
BOTTOM;
XTRAC; ! For debugging trace
! Get space - NAME<LEFT> defines the number of words. CORMAN
! zeroes the space before returning
BASEPTR = CORMAN();
! Keep count of tables space being used
! TABSPACE[.NAME] _ .TABSPACE[.NAME]+.NAME<LEFT>;
CASE .NAME OF SET
BEGIN ! 0 - Symbol table
BASEPTR[VALTYPE] = .SYMTYPE;
BASEPTR[IDSYMBOL] = .ENTRY;
BASEPTR[OPRCLS] = DATAOPR;
BASEPTR[OPERSP] = VARIABLE; ! Node is a variable
! Set the noallocate bit until the name is referenced It
! will be cleared by NAMSET/NAMREF
IF .SEGINCORE EQL 1
THEN BASEPTR[IDATTRIBUT(NOALLOC)] = 1;
END; ! 0 - Symbol table
BEGIN ! 1 - Constant table
BASEPTR[CONST1] = .ENTRY;
BASEPTR[CONST2] = .ENTRY[1];
BASEPTR[OPRCLS] = DATAOPR;
BASEPTR[VALTYPE] = .SYMTYPE;
BASEPTR[OPERSP] = CONSTANT;
END; ! 1 - Constant table
BEGIN END; ! 2 - (Not used) Common sub-expression
BEGIN ! 3 - Statement number table
BASEPTR[SNUMBER] = .ENTRY;
BASEPTR[OPRCLS] = LABOP;
! Initialize SNHDR to 0 and SNREFNO to 1. This makes
! the reference count one larger than it actually is -
! for unfortunate historical reasons.
BASEPTR[SNREF] = 1;
END; ! 3 - Statement number table
BEGIN ! 4 - COMMON block table
IF .LASCOMBLK EQL 0
THEN LASCOMBLK = FIRCOMBLK = .BASEPTR
ELSE
BEGIN
COMBLKPTR[NEXCOMBLK] = .BASEPTR;
LASCOMBLK = .BASEPTR;
END;
BASEPTR[COMNAME] = .ENTRY; ! Store name
%2343% ! Put the COMMON block into the proper psect
%2343% IF EXTENDED
%2343% THEN
%2343% BEGIN !/EXTEND
%2343% REGISTER BASE ECENTRY;
%2343% ! Look in the table of COMMON blocks set up
%2343% ECENTRY = FNDCOMMON(.ENTRY, FALSE);
%2343% ! If found an entry, then use its value. Otherwise
%2343% ! use the default set by /EXTEND.
%2343% IF .ECENTRY NEQ 0
%2343% THEN BASEPTR[COMPSECT] = .ECENTRY[ECPSECT]
%2343% ELSE BASEPTR[COMPSECT] = .DFCMPS;
%2343% END !/EXTEND
%2343% ELSE BASEPTR[COMPSECT] = PSDATA;
! Finally, set one of two flags depending on whether
! the COMMON block will reside in the small or large
! data psect at runtime.
%2356% IF .BASEPTR[COMPSECT] EQL PSDATA ! In the small psect?
%2356% THEN SCOMP = 1 ! Yes, set small flag
%2356% ELSE LCOMP = 1; ! No, set large flag
END; ! 4 - COMMON block table
BEGIN ! 5 - Executable source table
IF .SORCPTR NEQ 0
THEN SORCPTR[CLINK] = .BASEPTR
ELSE
BEGIN ! Make a dummy CONTINUE node as first statement
FIRSTSRC = LASTSRC = .BASEPTR;
BASEPTR[SRCID] = CONTID;
BASEPTR[SRCISN] = 0;
BASEPTR[OPRCLS] = STATEMENT;
BASEPTR = CORMAN(); ! Make a CONTINUE node
SORCPTR[CLINK] = .BASEPTR; ! Link to CONTINUE
END; ! Make a dummy CONTINUE node as first statement
LASTSRC = .BASEPTR;
BASEPTR[SRCISN] = .ISN; ! Internal sequence number
BASEPTR[SRCID] = .IDOFSTATEMENT;
BASEPTR[OPRCLS] = STATEMENT;
IF ((.IDOFSTATEMENT<RIGHT> GEQ STOPID)
AND (.IDOFSTATEMENT<RIGHT> LEQ OPENID)
AND (.IDOFSTATEMENT<RIGHT> NEQ ENDID)
%2200% OR (.IDOFSTATEMENT<RIGHT> EQL INQUID)) ! Link in INQUIRE
THEN
IF .IOFIRST EQL 0
THEN IOFIRST = IOLAST = .BASEPTR
ELSE
BEGIN
IOLSPTR[IOLINK] = .BASEPTR; ! Link in new I/O statement
IOLAST = .BASEPTR;
END;
BASEPTR[SRCLBL] = .LABLOFSTATEMENT; ! If any
IF .LABLOFSTATEMENT NEQ 0
THEN LABLOFSTATEMENT[SNHDR] = .BASEPTR;
END; ! 5 - Executable source table
BEGIN END; ! 6 - Dimension entries for arrays
BEGIN ! 7 - Expressions (not hashed)
! Call NEWENTRY directly; EXPTAB should be loaded into NAME
BASEPTR[ARG1PTR] = .ENTRY; ! First operand
BASEPTR[ARG2PTR] = .ENTRY[1]; ! Second operand
BASEPTR[TARGET] = 0;
BASEPTR[VALTYPE] = .SYMTYPE;
END; ! 7 - Expressions (not hashed)
BEGIN ! 8 - Iolist node or data intialization
BASEPTR[SRCID] = .IDOFSTATEMENT;
END; ! 8 - Iolist node or data intialization
BEGIN ! 9 - Literal table
MACRO
FIRLIT = LITPOINTER<LEFT>$,
LASTLIT = LITPOINTER<RIGHT>$;
IF .FIRLIT EQL 0
THEN FIRLIT = LASTLIT = .BASEPTR
ELSE
BEGIN
%1732% PRVLIT = .LASTLIT; ! Save last literal
%1732% LITPOINTER[LITLINK] = .BASEPTR; ! Link from last lit
LASTLIT = .BASEPTR
END;
END; ! 9 - Literal table
BEGIN ! 10 - Search for library function in library table
CGERR();
END; ! 10 - Search for library function in library table
BEGIN ! 11 - Equivalence group or class entry
IF .EQVPTR EQL 0
THEN EQVPTR<LEFT> = EQVPTR<RIGHT> = .BASEPTR
ELSE
BEGIN
EQVPTR[EQVLINK] = .BASEPTR; ! Link in new group
EQVPTR<RIGHT> = .BASEPTR ! Pointer to last group made
END;
! ENTRY has pointer to first EQVITEM made by case 12 for
! current EQVGROUP
BASEPTR[EQVFIRST] = BASEPTR[EQVLAST] = .ENTRY;
END; ! 11 - Equivalence group or class entry
BEGIN END; ! 12 - Equivalence list entry
BEGIN ! 13 - Data group nodes for DATA statements
IF .DATASPTR EQL 0
THEN DATASPTR<LEFT> = DATASPTR<RIGHT> = .BASEPTR
ELSE
BEGIN
DATASPTR[DATALNK] = .BASEPTR; ! Point to last
DATASPTR<RIGHT> = .BASEPTR;
END;
END; ! 13 - Data group nodes for DATA statements
BEGIN ! 14 - NAMELIST list header
IF .NAMLPTR EQL 0
THEN NAMLPTR<LEFT> = NAMLPTR<RIGHT> = .BASEPTR
ELSE
BEGIN
NAMLPTR[CLINK] = .BASEPTR;
NAMLPTR<RIGHT> = .BASEPTR;
END;
END; ! 14 - NAMELIST list header
%2205% BEGIN ! 15 - EFIW table
%2205%
%2205% REGISTER BASE SYMTAB;
%2205%
%2205% BASEPTR[EFSYMPTR] = SYMTAB = .ENTRY[1]; ! Symbol table entry
%2205%
%2205% BASEPTR[IDATTRIBUT(ALLOFTHEM)] = ! Symbol table flags
%2205% .SYMTAB[IDATTRIBUT(ALLOFTHEM)];
%2205% BASEPTR[VALTYPE] = .SYMTAB[VALTYPE]; ! Copy from the id
%2205% BASEPTR[OPRCLS] = EFIWREF; ! Leave OPERSP 0.
%2205%
%2205% BASEPTR[EFADDR] = .ENTRY[0]; ! I, X, Y
%2205%
%2205% BASEPTR[EFEXTERN] = .ENTRY[2]; ! External name
%2205%
%2205% ! Representative node. Will be reset later if this is
%2205% ! not the fist in the list of Similar entrys.
%2205% BASEPTR[EFREP] = .BASEPTR;
%2205%
%2205% END; ! 15 - EFIW table
TES;
! IF DEBUG
! THEN
! BEGIN
! XAREA0<LEFT> = .NAME<LEFT>;
! XAREA0<RIGHT> = .BASEPTR<RIGHT>;
! XAREA();
! END;
RETURN .BASEPTR
END; ! of NEWENTRY
GLOBAL ROUTINE TESTENTRY=
BEGIN
!***************************************************************
! Test an existing table entry vs the desired entry to see if
! they're equal. If so, we can just reuse an existing table
! entry.
!
! Returns:
! -1 if there is a match,
! 0 otherwise.
!
! Global arguments:
! ENTRY - The table entry we want.
! BASEPTR - Node to check against.
!***************************************************************
%2205% REGISTER BASE SIMILAR; ! Similar nodes in EFIW table processing
XTRAC; ! For debugging trace
%2205% CASE .NAME OF SET
BEGIN ! 0 - Symbol table
%2205% RETURN IF .BASEPTR[IDSYMBOL] EQL .ENTRY THEN -1 ELSE 0
END; ! 0 - Symbol table
BEGIN ! 1 - Constant table
%2205% RETURN
IF .SYMTYPE EQL .BASEPTR[VALTYPE]
THEN
BEGIN
IF .BASEPTR[VALTP1] NEQ INTEG1
THEN
BEGIN
IF .BASEPTR[CONST1] EQL .ENTRY
THEN IF .BASEPTR[CONST2] EQL .(ENTRY + 1)
THEN -1
ELSE 0
END
ELSE IF .BASEPTR[CONST2] EQL .(ENTRY+1)
THEN -1
ELSE 0
END
END; ! 1 - Constant table
BEGIN END; ! 2 - Common subexpression (not used)
BEGIN ! 3 - Statement number table
%2205% RETURN
IF .BASEPTR[SNUMBER] EQL .ENTRY
THEN
BEGIN
BASEPTR[SNREF] = .BASEPTR[SNREF] + 1;
-1
END
ELSE 0
END; ! 3 - Statement number table
%2205% RETURN CGERR(); ! 4 - Not used
%2205% RETURN CGERR(); ! 5 - Not used
%2205% RETURN CGERR(); ! 6 - Not used
%2205% RETURN CGERR(); ! 7 - Not used
%2205% RETURN CGERR(); ! 8 - Not used
%2205% RETURN CGERR(); ! 9 - Not used
%2205% RETURN CGERR(); ! 10 - Not used
%2205% RETURN CGERR(); ! 11 - Not used
%2205% RETURN CGERR(); ! 12 - Not used
%2205% RETURN CGERR(); ! 13 - Not used
%2205% RETURN CGERR(); ! 14 - Not used
%2205% BEGIN ! 15 - EFIW table
%2205%
%2205% LABEL LOOP; ! So we can leave a loop...
%2205%
%2205% ! If I, X, Y and the sixbit external symbol are all
%2205% ! equal to the entry we're testing, then we have a
%2205% ! similar node. Two id's equivalenced together will be
%2205% ! similar, but not equal.
%2205%
%2205% IF .BASEPTR[EFADDR] EQL .ENTRY[0] ! I, X, Y
%2205% AND .BASEPTR[EFEXTERN] EQL .ENTRY[2] ! External
%2205% THEN
%2205% BEGIN ! Hashed and entry are similar
%2205%
%2205% ! If we can find an entry that is equal, return
%2205% ! it. Otherwise make one, add it into the
%2205% ! similar linking, and make believe that we
%2205% ! found it.
%2205%
%2205% SIMILAR = .BASEPTR; ! 1st similar
%2205%
%2205% LOOP: WHILE TRUE
%2205% DO
%2205% BEGIN ! Step through each linked similar EFIW
%2205%
%2205% ! Symbol table entry equal?
%2205% IF .ENTRY[1] EQL .SIMILAR[EFSYMPTR]
%2205% THEN
%2205% BEGIN ! Entry is equal to an existing one.
%2205% BASEPTR = .SIMILAR;
%2205% RETURN -1;
%2205% END;
%2205%
%2205% ! If the link to the next similar table
%2205% ! is 0, then we have the last one. We
%2205% ! want to exit this loop, preserving the
%2205% ! value in SIMILAR (not zeroing it),
%2205% ! since we need it below to link a new
%2205% ! one in.
%2205% IF .SIMILAR[EFSIMILAR] EQL 0
%2205% THEN LEAVE LOOP ! Leave
%2205% ELSE SIMILAR = .SIMILAR[EFSIMILAR]; ! Next
%2205%
%2205% END; ! Step through each linked similar EFIW
%2205% ! (of label LOOP)
%2205%
%2205% ! Make a new node and thread it in.
%2205%
%2205% ! -------------------------
%2205% ! ->+-->| | CLINK | ----> ...
%2205% ! | -------------------------
%2205% ! | | EFREF | EFSIMILAR |
%2205% ! | -------------------------
%2205% ! +<----| |
%2205% ! ^ |
%2205% ! | V
%2205% ! | -------------------------
%2205% ! | | |
%2205% ! | -------------------------
%2205% ! ----| EFREP | EFSIMILAR = 0 |
%2205% ! -------------------------
%2205%
%2205% ! Get a new EFIW entry. Returned in BASEPTR.
%2205% NEWENTRY();
%2205%
%2205% ! Make the last node now point to this new node.
%2205% SIMILAR[EFSIMILAR] = .BASEPTR;
%2205% BASEPTR[EFREP] = .SIMILAR[EFREP];
%2205%
%2205% RETURN -1; ! Found similar
%2205%
%2205% END ! Hash and entry are similar
%2205% ELSE RETURN 0; ! Not equal at all...
%2205%
%2205% END; ! 15 - EFIW table
TES;
END; ! of TESTENTRY
GLOBAL ROUTINE SAVSPACE(SIZE,POINTER)=
BEGIN
!***************************************************************
! Free up space by linking a node onto the FREELISTs. SIZE is
! actually one less than the number of words in the entry.
! POINTER points to the node to free. All nodes of at least
! FLSIZ words are linked onto FREELIST[0] and are never reused.
! This is used for literals which assume that their space is
! never reused.
!***************************************************************
%1530% ! Rewritten by TFV on 4-May-82
! OWN FREETOTAL[FLSIZ];
XTRAC; ! For debugging trace
! Keep track of maximum compiler lowseg size
%1133% IF .JOBFF GTR .MAXFF THEN MAXFF = .JOBFF;
SIZE = .SIZE + 1; ! The front end counts relative to 0
%707% ! Bring JOBFF back down if possible - prevents fragmentation
%707% IF (.POINTER + .SIZE) EQL .JOBFF
%707% THEN JOBFF = .JOBFF - .SIZE
%707% ELSE IF .SIZE GEQ FLSIZ
THEN
BEGIN ! Large entries are linked on FREELIST[0]
(.POINTER)<RIGHT> = .FREELIST[0]<RIGHT>;
FREELIST[0]<RIGHT> = .POINTER;
! FREETOTAL[0] = .FREETOTAL[0] + .SIZE;
END ! Large entries are linked on FREELIST[0]
ELSE
BEGIN ! Reusable node
(.POINTER)<RIGHT> = .FREELIST[.SIZE]<RIGHT>;
FREELIST[.SIZE]<RIGHT> = .POINTER;
! FREETOTAL[.SIZE] = .FREETOTAL[.SIZE] + .SIZE;
END; ! Reusable node
! TTOTAL = .TTOTAL + .SIZE;
.VREG
END; ! of SAVSPACE
GLOBAL ROUTINE CORMAN=
BEGIN
!***************************************************************
! Allocate a new node in memory. The parameter for this routine
! is the global NAME which contains the entry size in the left
! half. If FREELIST[.SIZE] is non-zero, a free node of the
! right size exists and is reused. Literals assume that nodes
! of at least FLSIZ words are built at JOBFF and that succesive
! CORMAN calls append to the literal.
!***************************************************************
%1530% ! Rewritten by TFV on 4-May-82
REGISTER
SIZE, ! Size of the created node
BASE POINTER, ! Pointer to the created node
BASE BLTPTR; ! Used to BLT the node to zero
! OWN BLKLIM; ! Limit of area to be returned
! The next line is for debugging and performance anaylsis
! OWN BLKS[FLSIZ];
XTRAC; ! For debugging trace
SIZE = .NAME<LEFT>; ! The number of words in the node
! The next line is for debugging and performance analysis
! IF .SIZE LSS FLSIZ
! THEN BLKS[.SIZE] = .BLKS[.SIZE] + 1
! ELSE BLKS[0] = .BLKS[0] + 1;
IF .SIZE LSS FLSIZ
THEN POINTER = .FREELIST[.SIZE]<RIGHT> ! Try to reuse a free node
ELSE POINTER = 0; ! Can't reuse a node
IF .POINTER NEQ 0
THEN
BEGIN ! Reuse a free node
FREELIST[.SIZE]<RIGHT> = @.POINTER;
! TTOTAL = .TTOTAL - .SIZE;
END ! Reuse a free node
ELSE
BEGIN ! Allocate a new node
POINTER = .JOBFF; ! Pointer to the node
JOBFF = .JOBFF + .SIZE; ! Update JOBFF
SPACEFREE = .JOBREL - .JOBFF; ! Compute remaining free space
IF .SPACEFREE LSS 0
THEN
BEGIN ! Allocate more memory
! May have to allocate more than 1 core block so
! allocate all you need
%1600% IF FTTENEX
%1600% THEN CORUUO(.JOBFF) ! TOPS-20
%1600% ELSE
%1600% BEGIN ! TOPS-10
%1600% POINTER = .JOBFF; ! Put into an AC
CALLI(POINTER,#11); ! Do a CORE UUO
CORERR() ! Did not skip - error
%1600% END; ! TOPS-10
SPACEFREE = .JOBREL - .JOBFF;
POINTER = .JOBFF - .SIZE;
%1133% ! Keep track of maximum compiler lowseg size
%1133% IF .JOBFF GTR .MAXFF THEN MAXFF = .JOBFF;
END; ! Allocate more memory
END; ! Reuse a free node
(.POINTER)<FULL> = 0; ! Clear first word in node for BLT
IF .SIZE NEQ 1 THEN
BEGIN
BLTPTR<LEFT> = #0[.POINTER]<0,0>;
BLTPTR<RIGHT> = #1[.POINTER]<0,0>;
BLT(BLTPTR,(.SIZE - 1)[.POINTER]);
END;
RETURN .POINTER;
END; ! of CORMAN
GLOBAL ROUTINE GENLAB=
BEGIN
! Create a label table entry for a new internal label. ILABIX
! is initialized to 100000 to distinguish internal labels from
! FORTRAN program labels.
REGISTER
%1526% BASE LAB;
ENTRY = .ILABIX;
NAME = LABTAB;
ILABIX = .ILABIX+1;
LAB = TBLSEARCH();
%1526% LAB[SNPSECT] = PSCODE; ! Generated labels are always in the hiseg
RETURN .LAB; ! Return pointer to label table entry
END; ! of GENLAB
GLOBAL ROUTINE MAKEPR(CLAS,SPECFI,VTYPE,A1PTR,A2PTR) =
BEGIN
!***************************************************************
! Make an expression node for phase 2 skeleton and phase 2
!***************************************************************
REGISTER PEXPRNODE T;
NAME<LEFT> = 4; ! Entry is 4 words long
T = CORMAN(); ! Get space for entry
T[FIRSTWORD] = 0; ! First word is zero
T[EXPFLAGS] = 0; ! flags are zero
T[OPRCLS] = .CLAS; ! Operator class
T[OPERSP] = .SPECFI; ! specific operator
T[VALTYPE] = .VTYPE; ! value type
T[TARGET] = 0; ! Zero target word
T[ARG1PTR] = .A1PTR; ! Argument one
T[ARG2PTR] = .A2PTR; ! Argument two
RETURN .T
END; ! of MAKEPR
GLOBAL ROUTINE MAKPR1(PARPTR,CLAS,SPECFI,VTYPE,A1PTR,A2PTR)=
BEGIN
!***************************************************************
! Make an expression node for phase 1 array expansion, and
! value-type analysis - also for phase 2 skeleton and phase 2.
! Sets VALFLGS and puts in parent pointers.
!***************************************************************
MAP
PEXPRNODE A1PTR,
PEXPRNODE A2PTR;
REGISTER
PEXPRNODE T;
NAME<LEFT> = 4; ! Expression node is 4 words long
T = CORMAN(); ! Get space for entry
T[FIRSTWORD] = 0; ! First word is zero
T[EXPFLAGS] = 0; ! Flags are zero
T[OPRCLS] = .CLAS; ! Operator class
T[OPERSP] = .SPECFI; ! Specific operator
T[VALTYPE] = .VTYPE; ! Value type
T[TARGET] = 0; ! Zero target word
T[ARG1PTR] = .A1PTR; ! Argument one
T[ARG2PTR] = .A2PTR; ! Argument two
T[PARENT] = .PARPTR; ! Parent pointer field for this node
IF .A1PTR NEQ 0
THEN
BEGIN
IF .A1PTR[OPRCLS] EQL DATAOPR OR .A1PTR[OPRCLS] EQL CMNSUB
THEN T[A1VALFLG] = 1
ELSE A1PTR[PARENT] = .T;
END;
IF .A2PTR NEQ 0
THEN
BEGIN
IF .A2PTR[OPRCLS] EQL DATAOPR OR .A2PTR[OPRCLS] EQL CMNSUB
THEN T[A2VALFLG] = 1
ELSE A2PTR[PARENT] = .T;
END;
RETURN .T
END; ! of MAKPR1
GLOBAL ROUTINE NEWDVAR(GENLEN)=
BEGIN
!***************************************************************
! Create a .Dnnnn variable for a compile-time-constant character
! descriptor. The entries are all linked together. They have
! an OPRCLS of DATAOPR and an OPERSP of VARIABLE. Either one
! word (byte pointer only) or two words (byte pointer and
! length) are generated based on the flag IDGENLENFLG. One word
! .Dnnnn variables are used for SUBSTRINGs with constant lower
! bounds and non-constant upper bounds.
!***************************************************************
%1406% ! Written by TFV on 27-Oct-81
REGISTER PEXPRNODE DVAR; ! Pointer to entry
NAME<LEFT> = IDSIZ; ! Use a symbol table like entry
DVAR = CORMAN(); ! Get space for new .D variable
IF .DANCHOR EQL 0
THEN DANCHOR = .DVAR ! Setup DANCHOR to point to .D0000
ELSE LASTD[CLINK] = .DVAR; ! Link in the .D variable
LASTD = .DVAR; ! Update lastd used
DVAR[OPRCLS] = DATAOPR; ! Data operator OPRCLS
DVAR[OPERSP] = VARIABLE; ! Specific operator is VARIABLE
DVAR[VALTYPE] = CHARACTER; ! VALTYPE is CHARACTER
DVAR[IDGENLENFLG] = .GENLEN; ! Set flag for 1 word or 2 words
DVAR[IDSYMBOL] = SIXBIT'.D0000' + ! Make the .Dnnnn name
(.DCNT<9,3>)^18 +
(.DCNT<6,3>)^12 +
(.DCNT<3,3>)^6 +
(.DCNT<0,3>);
DCNT = .DCNT + 1; ! Increment DCNT
RETURN .DVAR
END; ! of NEWDVAR
GLOBAL ROUTINE MAKLIT (LEN) = ! [1527] New
! [1535] name changed to MAKLIT
! Returns an empty literal table entry LEN characters long
BEGIN
REGISTER WLEN;
REGISTER BASE RESULT;
%1535% WLEN = CHWORDLEN(.LEN) + 1;
NAME<LEFT> = .WLEN + LTLSIZ;
NAME<RIGHT> = LITTAB;
RESULT = NEWENTRY();
RESULT[LITLEN] = .LEN;
RESULT[LITSIZ] = .WLEN;
RESULT[OPERATOR] = CHARCONST;
RESULT[LITEXWDFLG] = 1;
RETURN .RESULT;
END; ! MAKLIT
GLOBAL ROUTINE CHEXLEN(CNODE)= ![1521] New
! Routine to find the length of a character node (the node is assumed to be
! character before this routine is called). For argument descriptor blocks.
! PASSED: CNODE -Argument node to check
! RETURNS: -Size of character variable in bytes or
! -LENSTAR (Size not known at compile time)
BEGIN
MAP BASE CNODE;
REGISTER BASE SYMTAB; ! For symbol table entries
! If this has a compile time length, then put out a secondary
! descriptor
IF .CNODE[OPRCLS] EQL DATAOPR
THEN
BEGIN ! Symbol table entry
IF .CNODE[OPERSP] EQL CONSTANT
THEN RETURN .CNODE[LITLEN];
IF .CNODE[OPERSP] EQL VARIABLE
THEN RETURN .CNODE[IDCHLEN];
IF .CNODE[OPERSP] EQL FORMLVAR
THEN RETURN .CNODE[IDCHLEN];
IF .CNODE[OPERSP] EQL FNNAME
THEN RETURN .CNODE[IDCHLEN];
IF .CNODE[OPERSP] EQL FORMLFN
THEN RETURN .CNODE[IDCHLEN];
! Array - return size of entire array
IF .CNODE[DATOPS1] EQL ARRAYNM1 OR
.CNODE[OPERSP] EQL FORMLARRAY
THEN
BEGIN
REGISTER DIMENTRY DIMENTAB;
DIMENTAB = .CNODE[IDDIM]; ! Dimension Table
IF NOT .DIMENTAB[ADJDIMFLG] ! Not adjustably dim.
THEN RETURN .DIMENTAB[ARASIZ] ! Size of array
ELSE RETURN LENSTAR; ! Length not known yet.
END;
END; ! Symbol table entry
IF .CNODE[OPRCLS] EQL ARRAYREF
THEN
BEGIN ! Array reference - single element in array.
SYMTAB = .CNODE[ARG1PTR]; ! Symbol table for array
RETURN .SYMTAB[IDCHLEN]; ! Length for single element
END; ! Array reference
! If argument is a character function call, return the length
! given in the symbol table for that function.
IF .CNODE[OPRCLS] EQL FNCALL
THEN
BEGIN
SYMTAB = .CNODE[ARG1PTR]; !Symbol table entry
RETURN .SYMTAB[IDCHLEN];
END;
RETURN LENSTAR; !Descriptor not needed
END; ! of CHEXLEN
GLOBAL ROUTINE MAKEFIW(I,X,Y,SYMTAB)= ![2205] New
!++
! FUNCTIONAL DESCRIPTION:
!
! Returns EFIW table reference for the symbol reference passed.
! Called during code generation phase of the compiler.
!
! FORMAL PARAMETERS:
!
! I EFIW's indirect bit.
!
! X EFIW's index register field.
!
! Y EFIW's 30 bit address field.
!
! SYMTAB Location of identifier's symbol table entry.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! ENTRY Smashed when passing arguments to TBLSEARCH.
!
! NAME Smashed when passing arguments to TBLSEARCH.
!
! ROUTINE VALUE:
!
! Address of EFIW table entry.
!
! SIDE EFFECTS:
!
! None
!
!--
![2205] Mike likes comments.
BEGIN
MAP BASE SYMTAB;
REGISTER BASE EXTERN; ! External name (if any)
! No business being here if a non symbol was passed
IF .SYMTAB[OPRCLS] NEQ DATAOPR
THEN CGERR(); ! Give an ICE
! Set up ENTRY to contain the values of the EFIW entry we want
! to make.
! Enter the I, X, and Y. Be defensive and mask off any stray
! bits beyond the size of each field.
ENTRY[0] = (.I AND 1)^34 + (.X AND #17)^30 + (.Y AND #7777777777);
ENTRY[1] = .SYMTAB; ! Symbol table id
! Assign name for fixup or psect for relocation
IF .SYMTAB[IDATTRIBUT(INCOM)]
THEN ! In COMMON?
BEGIN ! INCOM
EXTERN = .SYMTAB[IDCOMMON]; ! Common table entry
ENTRY[2] = .EXTERN[COMNAME]; ! Common name in SIXBIT
END ! INCOM
%2464% ELSE IF .SYMTAB[OPR1] EQL FMLARRFL ! Nope, formal array?
%2464% THEN ENTRY[2] = PSABS ! Yep, not relocated
ELSE IF .SYMTAB[OPR1] EQL FNNAMFL ! Nope, external routine name
THEN ENTRY[2] = .SYMTAB[IDSYMBOL] ! Yep, use the name
%2464% ELSE ENTRY[2] = .SYMTAB[IDPSECT]; ! Nope, STE is a local variable
! Get an EFIW table. TBLSEARCH will decide whether to make it
! or use an existing one.
NAME = EFIWTAB; ! What kind we want
RETURN TBLSEARCH(); ! Do it.
END; ! of MAKEFIW
GLOBAL ROUTINE ADDINT(INT1,INT2)= ![2322] New
!++
! FUNCTIONAL DESCRIPTION:
!
! Adds two integers using the accurate constant combine
! routines which checks for overflows and underflows.
!
! FORMAL PARAMETERS:
!
! INT1 Integer
!
! INT2 Integer
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! (These are not returned values, but are changed)
!
! C1L Low word of argument
!
! C1H High word of argument
!
! C2L Low word of argument
!
! C2H High word of argument
!
! ROUTINE VALUE:
!
! Integer result of addition, INT1 + INT2
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN
C2H = C1H = 0; ! No high order words for integers
C1L = .INT1; ! First integer
C2L = .INT2; ! Second integer
COPRIX = KKARITHOP(INTEG1,ADDOP); ! Do integer add
CNSTCM(); ! Do it
RETURN .C2L; ! Return value
END; ! of ADDINT
GLOBAL ROUTINE MULINT(INT1,INT2)= ![2322] New
!++
! FUNCTIONAL DESCRIPTION:
!
! Mutiplies two integer constants using the accurate CNSTCM
! constant combine routines.
!
! FORMAL PARAMETERS:
!
! INT1 Integer
!
! INT2 Integer
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! (These are not returned values, but are changed)
!
! C1L Low word of argument
!
! C1H High word of argument
!
! C2L Low word of argument
!
! C2H High word of argument
!
! ROUTINE VALUE:
!
! Integer result of multiplication, INT1 * INT2
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
C2H = C1H = 0; ! No high order words for integers
C1L = .INT1; ! First integer
C2L = .INT2; ! Second integer
COPRIX = KKARITHOP(INTEG1,MULOP); ! Do integer multiply
CNSTCM(); ! Do it
RETURN .C2L; ! Return value
END; ! Of MULINT
GLOBAL ROUTINE SUBINT(INT1,INT2)= ![2322] New
!++
! FUNCTIONAL DESCRIPTION:
!
! Subtracts two integers using the accurate constant combine
! routines which checks for overflows and underflows.
!
! FORMAL PARAMETERS:
!
! INT1 Integer to subtract INT2 from
!
! INT2 Integer that is subtracted from INT1
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! (These are not returned values, but are changed)
!
! C1L Low word of argument
!
! C1H High word of argument
!
! C2L Low word of argument
!
! C2H High word of argument
!
! ROUTINE VALUE:
!
! Integer result of subtraction, INT1 - INT2
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN
C2H = C1H = 0; ! No high order words for integers
C1L = .INT1; ! First integer
C2L = .INT2; ! Second integer
COPRIX = KKARITHOP(INTEG1,SUBOP); ! Do integer subtract
CNSTCM(); ! Do it
RETURN .C2L; ! Return value
END; ! Of SUBINT
%( Description of double scaled arithmetic used for compiler
COMPLEX arithmetic:
Ideally COMPLEX arthmetic should be performed in G-floating,
since it would provide a larger number of bits of accuracy
(compared to single precision), as well as an expanded
exponent range allowing straightforward computations to be
performed. However, G-floating hardware is not available in
all configurations that FORTRAN-10/20 must function under.
Therefore for *, /, and ** COMPLEX numbers are stored as
double precision numbers, with an integer scale factor. The
double precision number will at all times have an exponent
between 0 and +100 octal. If before (or after) any complex
operation the exponent should exceed this range the integer
scale factor will be incremented (or decremented) and the
exponent will be adjusted down (up) by 100.
The final result can be converted to single precision and
FSC'ed by 100 (octal) times the scale factor. Overflow or
underflow will happen only if the final result cannot be
represented as a single precision number. Under or overflow
should NEVER occur as a result of a scaled operation.
Storage format:
+================+
| H.O. OF DOUBLE |
+----------------+
| L.O. OF DOUBLE |
+----------------+
| INTEGER SCALE |
+================+
)%
MACHOP DFAD = #110, !DOUBLE FLOATING ADD
DFSB = #111, !DOUBLE FLOATING SUBTRACT
DFMP = #112, !DOUBLE FLOATING MULTIPLY
DFDV = #113, !DOUBLE FLOATING DIVIDE
DMOVE = #120, !DOUBLE MOVE
DMOVN = #121, !DOUBLE MOVE NEGATED
DMOVEM = #124; !DOUBLE MOVE TO MEMORY
! FIELD DESCRIPTORS FOR SCALED DOUBLE 3 WORD BLOCK
MACRO DOUBL1 = 0,0,0,36$, !HIGH ORDER WORD OF DOUBLE FLOAT
EXPONENT = 0,0,27,8$, !EXPONENT OF DOUBLE
DOUBL2 = 0,1,0,36$, !LOW ORDER WORD OF DOUBLE
SCALE = 0,2,0,36$; !SCALE FACTOR
MACRO ADR = 0,0 $; !GET ADDRESS OF A VAR
GLOBAL ROUTINE ADJUST(A) =
!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
! This routine ensures that the exponent of a scaled double is
! within the range 0 to 100 (octal). If this is not the case,
! the exponent, and scale factor are adjusted until the number
! is in normal scaled form.
!
! FORMAL PARAMETERS:
!
! A is a pointer to a 3 word block holding a scaled double.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! Scaled result is stored back into block addressed by A.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
! This routine is called from CNSTCM.MAC
!
!--
BEGIN !ADJUST
LOCAL I,NEGFLG;
MAP BASE A;
IF .A[DOUBL1] EQL 0 !IF FIRST WORD IS ZERO
THEN IF .A[DOUBL2] EQL 0 !*****
THEN !NUMBER IS ZERO
BEGIN !NUMBER IS ZERO
A[SCALE] = 0; !ENSURE ZERO SCALE
RETURN .VREG !RETURN NOW
END; !NUMBER IS ZERO
IF .A[DOUBL1] LSS 0 !IF NEGATIVE TAKE ABSOLUTE
THEN
BEGIN !NEGATIVE NUMBER
A[DOUBL1] = -.A[DOUBL1]; !ENSURE POSITIVE NUMBER
NEGFLG = 1 !SET FLAG SO WE CAN RESTORE SIGN
END !NEGATIVE NUMBER
ELSE NEGFLG = 0; !NOT NEGATIVE
I = .A[EXPONENT] - #200; !GET SIGNED EXPONENT
IF .I GTR 0
THEN
BEGIN !POSITIVE EXPONENT
IF .I GTR #100
THEN
BEGIN !POSITIVE EXPONENT .GT. #100
A[EXPONENT] = .I - #100 + #200; !ADJUST EXPONENT DOWN
A[SCALE] = .A[SCALE] + 1 !INCREMENT SCALE FACTOR
END !POSITIVE EXPONENT .GT. #100
END !POSITIVE EXPONENT
ELSE
BEGIN !NEGATIVE EXPONENT
WHILE .I LSS 0
DO
BEGIN !WHILE EXPONENT .LT. 0
I = .I + #100; !BUMP EXPONENT UP BY #100
A[SCALE] = .A[SCALE] - 1 !DECREMENT SCALE FACTOR
END; !WHILE EXPONENT .LT. 0
A[EXPONENT] = .I + #200 !RESTORE EXPONENT
END; !NEGATIVE EXPONENT
IF .NEGFLG NEQ 0 !IF STARTING NUMBER WAS NEGATIVE
THEN A[DOUBL1] = -.A[DOUBL1]; !RESTORE SIGN
RETURN .VREG !RETURN NO VALUE
END; !ADJUST
ROUTINE MULTIPLY(A,B,C) =
!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
! Perform multiplication of two scaled double numbers.
!
! FORMAL PARAMETERS:
!
! A, B, and C are pointers to 3 word blocks for storing scaled
! doubles. A will recieve the result of multiplying the numbers
! contained in B and C.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! Scaled result is stored back into block addressed by A.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN
REGISTER REG[2];
MAP BASE A:B:C;
DMOVE (REG,.B); !FETCH B
DFMP (REG,.C); !MULTIPLY BY C
DMOVEM (REG,.A); !STORE IN A
A[SCALE] = .B[SCALE] + .C[SCALE]; !COMPUTE SCALE
ADJUST(.A)
END;
ROUTINE DIVIDE(A,B,C) =
!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
! Perform scaled double division; Divide the two doubles and
! calculate new scale.
!
! FORMAL PARAMETERS:
!
! A, B, and C are pointers to 3 word blocks for storing scaled
! doubles. A will recieve the result of dividingthe numbers
! contained in B and C.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! Scaled result is stored back into block addressed by A.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN
REGISTER REG[2];
MAP BASE A:B:C;
DMOVE (REG,.B); !FETCH B
DFDV (REG,.C); !DIVIDE BY C
DMOVEM (REG,.A); !STORE IN A
A[SCALE] = .B[SCALE] - .C[SCALE]; !COMPUTE SCALE
ADJUST(.A)
END;
ROUTINE SCADD(A,B,C) =
!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
! Add two scaled doubles. If the scales are identical, the
! numbers may be added. However, if the scales differ by one,
! the number with the smaller scale must be multiplied by 2 **
! -#100 to avoid the possibility of losing bits. If the scales
! differ by more than one, the numbers cannot overlap and the
! result is the number with the larger scale.
!
! If either number is zero, the result is the result is the
! other one.
!
! FORMAL PARAMETERS:
!
! A, B, and C are pointers to 3 word blocks for storing scaled
! doubles. A will recieve the result of adding the numbers
! contained in B and C.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! Scaled result is stored back into block addressed by A.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN !SCADD
MAP BASE A:B:C;
REGISTER BASE L:S; !LARGER, SMALLER (SCALE)
LOCAL DELTA; !POSITIVE SCALE DIFFERENCE
! CHECK FOR A = 0 + C
IF .B[SCALE] EQL 0 !ZERO SCALE?
THEN IF .B[DOUBL1] EQL 0 !IS IT ZERO?
THEN IF .B[DOUBL2] EQL 0 !******
THEN
BEGIN
A[DOUBL1] = .C[DOUBL1]; !RESULT IS C
A[DOUBL2] = .C[DOUBL2];
A[SCALE] = .C[SCALE];
RETURN .VREG !RETURN NOVALUE
END;
! CHECK FOR A = B + 0
IF .C[SCALE] EQL 0 !ZERO SCALE?
THEN IF .C[DOUBL1] EQL 0 !IS IT ZERO?
THEN IF .C[DOUBL2] EQL 0 !****
THEN
BEGIN
A[DOUBL1] = .B[DOUBL1]; !RESULT IS B
A[DOUBL2] = .B[DOUBL2];
A[SCALE] = .B[SCALE];
RETURN .VREG !RETURN NOVALUE
END;
! FIND WHICH HAS LARGER SCALE FACTOR
IF .B[SCALE] GTR .C[SCALE]
THEN
BEGIN !B IS LARGER
L = .B;
S = .C
END !B IS LARGER
ELSE
BEGIN !B IS SMALLER (OR SAME)
L = .C;
S = .B
END; !B IS SMALLER (OR SAME)
DELTA = .L[SCALE] - .S[SCALE]; !GET POSITIVE DIFFERENCE
IF .DELTA EQL 0
THEN
BEGIN !SCALES ARE EQUAL
REGISTER REG[2];
DMOVE (REG,.L); !FETCH LARGER
DFAD (REG,.S); !ADD SMALLER
DMOVEM (REG,.A); !STORE IN A
A[SCALE] = .B[SCALE]; !COPY SCALE (ANY SINCE THEY ARE EQL)
RETURN .VREG !RETURN NOVALUE
END; !SCALES ARE EQUAL
! HERE WHEN SCALES ARE NOT EQUAL
IF .DELTA EQL 1
THEN
BEGIN !SCALES DIFFER BY 1
REGISTER REG[2];
REG[0] = #101400^18; !2.0 ** -#100
REG[1] = #0;
DFMP (REG,.S); !MULTIPLY SMALLER BY 2.**-64.
DFAD (REG,.L); !ADD IN LARGER
DMOVEM (REG,.A); !STORE IN A
A[SCALE] = .L[SCALE] !COPY SCALE FROM LARGER
END !SCALES DIFFER BY 1
ELSE
BEGIN !SCALES DIFFER BY 2 OR MORE
A[DOUBL1] = .L[DOUBL1]; !RESULT IS LARGER
A[DOUBL2] = .L[DOUBL2];
A[SCALE] = .L[SCALE]
END; !SCALES DIFFER BY 2 OR MORE
RETURN .VREG !RETURN NOVALUE
END; !SCADD
ROUTINE SUBTRACT(A,B,C) =
!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
! Subtract scaled doubles by negation and addition.
!
! FORMAL PARAMETERS:
!
! A, B, and C are pointers to 3 word blocks for storing scaled
! doubles. A will recieve the result of subtracting the numbers
! contained in B and C.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! Scaled result is stored back into block addressed by A.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN !SUBTRACT
MAP BASE A:B:C;
LOCAL TEMP[3];
REGISTER R[2];
DMOVN (R,.C); !GET C, NEGATED
DMOVEM (R,TEMP); !STORE IN TEMP
TEMP[2] = .C[SCALE]; !COPY SCALE
SCADD(.A,.B,TEMP<ADR>) !PERFORM ADDITION
END; !SUBTRACT
GLOBAL ROUTINE COMPMUL(A,B,C,D) =
!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
! Perform double COMPLEX multiplication on scaled double
! coefficents (A,B) and (C,D).
!
! (A + Bi) * (C + Di) == (AC - BD) + (AD + BC)i
!
! FORMAL PARAMETERS:
!
! A, B, C, and D are pointers to three word blocks
! holding scaled double precision numbers.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! Real part of result is stored back into block pointed to by A.
! Imaginary part of result is stored back into block pointed to by B.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
! This routine is called from CNSTCM.MAC
!
!--
BEGIN !COMPMUL
MAP BASE A:B:C:D;
LOCAL TEMP1[3],TEMP2[3],TEMP3[3];
MULTIPLY(TEMP1<ADR>,.A,.C); !TEMP1 := A * C
MULTIPLY(TEMP2<ADR>,.B,.D); !TEMP2 := B * D
SUBTRACT(TEMP1<ADR>,TEMP1<ADR>,TEMP2<ADR>); !TEMP1 := TEMP1 - TEMP2
MULTIPLY(TEMP2<ADR>,.B,.C); !TEMP2 := B * C
MULTIPLY(TEMP3<ADR>,.A,.D); !TEMP3 := A * D
SCADD(.B,TEMP2<ADR>,TEMP3<ADR>); !B := TEMP2 + TEMP3
A[DOUBL1] = .TEMP1[0];
A[DOUBL2] = .TEMP1[1];
A[SCALE] = .TEMP1[2]
END; !COMPMUL
GLOBAL ROUTINE COMPDIV(A,B,C,D) =
!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
! Perform COMPLEX division on scaled double coefficients (A,B) and (C,D).
!
! (A + Bi) (AC + BD) + (BC - AD)i
! -------- == ----------------------
! (C + Di) 2 2
! C + D
!
! FORMAL PARAMETERS:
!
! A, B, C, and D are pointers to three word blocks
! holding scaled double precision numbers.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! Real part of result is stored back into block pointed to by C.
! Imaginary part of result is stored back into block pointed to by D.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
! This routine is called from CNSTCM.MAC
!
!--
BEGIN !COMPDIV
MAP BASE A:B:C:D;
LOCAL COMSUB[3],TEMP1[3],TEMP2[3];
MULTIPLY(COMSUB<ADR>,.C,.C); !COMSUB := C * C
MULTIPLY(TEMP1<ADR>,.D,.D); !TEMP1 := D * D
SCADD(COMSUB<ADR>,COMSUB<ADR>,TEMP1<ADR>); !COMSUB := COMSUB + TEMP1
MULTIPLY(TEMP1<ADR>,.A,.C); !TEMP1 := A * C
MULTIPLY(TEMP2<ADR>,.B,.D); !TEMP2 := B * D
SCADD(TEMP1<ADR>,TEMP1<ADR>,TEMP2<ADR>); !TEMP1 := TEMP1 + TEMP2
DIVIDE(TEMP1<ADR>,TEMP1<ADR>,COMSUB<ADR>); !TEMP1 := TEMP1 / COMSUB
MULTIPLY(TEMP2<ADR>,.B,.C); !TEMP2 := B * C
MULTIPLY(.D,.A,.D); !D := A * D
SUBTRACT(.D,TEMP2<ADR>,.D); !D := TEMP2 - D
DIVIDE(.D,.D,COMSUB<ADR>); !D := D / COMSUB
C[DOUBL1] = .TEMP1[0];
C[DOUBL2] = .TEMP1[1];
C[SCALE] = .TEMP1[2]
END; !COMPDIV
GLOBAL ROUTINE COMPSQ(A,B) =
!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
! Perform double COMPLEX square on scaled double coefficents
! (A,B).
!
! Formula from a preliminary technical report by Ned Anderson
! entitled: "A Note on Accurate Computation of Complex-Valued
! Functions"
!
! (A,B)*(A,B) = (A+B)*(A-B) + i(2*A*B)
!
! FORMAL PARAMETERS:
!
! A and B are pointers to three word blocks holding scaled
! double precision numbers.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! Real part of result is stored back into block pointed to by A.
! Imaginary part of result is stored back into block pointed to by B.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
! This routine is called from CNSTCM.MAC
!
!--
BEGIN !COMPSQ
MAP BASE A:B;
LOCAL TEMP1[3],TEMP2[3];
! EVALUATE REAL PART INTO TEMP1
SCADD(TEMP1<ADR>,.A,.B); !TEMP1 := A + B
SUBTRACT(TEMP2<ADR>,.A,.B); !TEMP2 := A - B
MULTIPLY(TEMP1<ADR>,TEMP1<ADR>,TEMP2<ADR>); !TEMP1 := TEMP1 * TEMP2
! EVALUATE IMAG PART INTO B
MULTIPLY(TEMP2<ADR>,.A,.B); !TEMP2 := A * B
SCADD(.B,TEMP2<ADR>,TEMP2<ADR>); !B := TEMP2 + TEMP2
! COPY TEMP1 INTO A
A[DOUBL1] = .TEMP1[0];
A[DOUBL2] = .TEMP1[1];
A[SCALE] = .TEMP1[2]
END; !COMPSQ
END
ELUDOM