Trailing-Edge
-
PDP-10 Archives
-
BB-4157F-BM_1983
-
fortran/compiler/srca.bli
There are 12 other files named srca.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
! OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1983
!AUTHOR: F. INFANTE/HPW/NEA/DCE/SJW/CDM/TFV/AHM/PLB
MODULE SRCA(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND SRCAV = 6^24 + 0^18 + #1600; ! Version Date: 9-Jul-82
%(
***** 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 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
EXTERNAL
CGERR,
CHAR,
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,
DLOOPTREE,
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
LIBATTRIBUTES,
LIBFUNTAB,
LITERL,
%1133% MAXFF, ! Maximum size of compiler lowseg
NAME,
NAMLPTR,
PUTMSG,
QUEUE,
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
!***************************************************************
! Lookup an entry in the the various dynamic tables. It also
! makes entries into tables for new entries and returns a
! pointer to the table entry just made or found and also sets a
! flag (FLAG). If the entry was already in the table, the value
! of flag is set to -1, if the entry was not already in the
! table the value is set to 0.
!
! The parameters for this routine are two global variables NAME
! and ENTRY. NAME contains the table number in the right half
! and the entry size in the left half. ENTRY is the address of
! the first word of the table argument to be looked up and/or
! entered in a table. .ENTRY is the value of the first word of
! the argument.
!***************************************************************
BIND
LISTX = UPLIT(SYMTBL,CONTBL,EXPTBL,LABTBL,SRCTBL,
DIMTBL,DATTBL,NAMTBL,LITTBL),
ITEM = .LISTX[.NAME<RIGHT>]<RIGHT>;
LOCAL I;
MAP BASE DELETPTR;
XTRAC; ! For debugging trace
IF .NAME<RIGHT> GTR 12 THEN RETURN;
IF .NAME<RIGHT> GTR 3
THEN
BEGIN
NEWENTRY();
FLAG = 0;
RETURN .BASEPOINT ! NEWENTRY resets BASEPOINT
END;
I = THASH();
BASEPOINT = .ITEM[.I]; ! Get hash table entry value
IF .BASEPOINT EQL 0
THEN
BEGIN ! Unique hash - generate a new entry
NEWENTRY(); ! Initialize BASEPOINT and setup data
ITEM[.I] = .BASEPOINT;
BASEPTR[CLINK] = 0;
FLAG = 0;
RETURN .BASEPOINT
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
IF TESTENTRY()
THEN
BEGIN
FLAG = -1;
RETURN .BASEPOINT
END
ELSE IF .BASEPTR[CLINK] NEQ 0
THEN BASEPOINT = .BASEPTR[CLINK]
ELSE
BEGIN
NEWENTRY();
BASEPTR[CLINK] = .ITEM[.I]<RIGHT>;
ITEM[.I]<RIGHT> = .BASEPOINT;
FLAG = 0;
RETURN .BASEPOINT
END;
END; ! of WHILE 1 DO
END ! See if an entry is in the linked list for the hash I
END; ! of TBLSEARCH
GLOBAL ROUTINE THASH=
BEGIN
!***************************************************************
! Develop hash code from possible entry using .NAME to define
! the table needed.
!***************************************************************
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
BEGIN END; ! 2 - (Not used) Common sub-expression
IF .ENTRY GEQ LASIZ ! 3 - Statement number table
THEN .ENTRY MOD LASIZ
ELSE .ENTRY;
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 NEWENTRY=
BEGIN
!***************************************************************
! Enter a new item into the table defined by the right half of
! NAME.
!***************************************************************
MAP
BASE COMBLKPTR,
BASE DATASPTR,
BASE EQVPTR,
BASE IOLSPTR,
BASE LABLOFSTATEMENT,
BASE LITPOINTER,
BASE NAMLPTR,
BASE SORCPTR;
MACRO
PARAM = ENTRY$,
BP = BASEPTR$;
OWN
TOP,
BOTTOM;
XTRAC; ! For debugging trace
BP = CORMAN(); ! Get space - NAME<LEFT> defines the number of words.
! CORMAN zeroes the space before returning
! Keep count of tables space being used
! TABSPACE[.NAME] _ .TABSPACE[.NAME]+.NAME<LEFT>;
CASE .NAME OF SET
BEGIN ! 0 - Symbol table
BP[VALTYPE] = .SYMTYPE;
BP[IDSYMBOL] = .ENTRY;
BP[OPRCLS] = DATAOPR;
BP[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 BP[IDATTRIBUT(NOALLOC)] = 1;
END; ! 0 - Symbol table
BEGIN ! 1 - Constant table
BP[CONST1] = .ENTRY;
BP[CONST2] = .ENTRY[1];
BP[OPRCLS] = DATAOPR;
BP[VALTYPE] = .SYMTYPE;
BP[OPERSP] = CONSTANT;
END; ! 1 - Constant table
BEGIN END; ! 2 - (Not used) Common sub-expression
BEGIN ! 3 - Statement number table
BP[SNUMBER] = .ENTRY;
BP[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.
BP[SNREF] = 1;
END; ! 3 - Statement number table
BEGIN ! 4 - COMMON block table
IF .LASCOMBLK EQL 0
THEN LASCOMBLK = FIRCOMBLK = .BASEPOINT
ELSE
BEGIN
COMBLKPTR[NEXCOMBLK] = .BASEPOINT;
LASCOMBLK = .BASEPOINT;
END;
BP[COMNAME] = .ENTRY; ! Store name
END; ! 4 - COMMON block table
BEGIN ! 5 - Executable source table
IF .SORCPTR NEQ 0
THEN SORCPTR[CLINK] = .BASEPOINT
ELSE
BEGIN ! Make a dummy CONTINUE node as first statement
FIRSTSRC = LASTSRC = .BASEPOINT;
BP[SRCID] = CONTID;
BP[SRCISN] = 0;
BP[OPRCLS] = STATEMENT;
BASEPOINT = CORMAN(); ! Make a CONTINUE node
SORCPTR[CLINK] = .BASEPOINT; ! Link to CONTINUE
END; ! Make a dummy CONTINUE node as first statement
LASTSRC = .BASEPOINT;
BP[SRCISN] = .ISN; ! Internal sequence number
BP[SRCID] = .IDOFSTATEMENT;
BP[OPRCLS] = STATEMENT;
IF (.IDOFSTATEMENT<RIGHT> GEQ STOPID)
AND (.IDOFSTATEMENT<RIGHT> LEQ OPENID)
AND (.IDOFSTATEMENT<RIGHT> NEQ ENDID) THEN
IF .IOFIRST EQL 0
THEN IOFIRST = IOLAST = .BP
ELSE
BEGIN
IOLSPTR[IOLINK] = .BP; ! Link in new I/O statement
IOLAST = .BP;
END;
BP[SRCLBL] = .LABLOFSTATEMENT; ! If any
IF .LABLOFSTATEMENT NEQ 0 THEN LABLOFSTATEMENT[SNHDR] = .BP;
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
BP[ARG1PTR] = .ENTRY; ! First operand
BP[ARG2PTR] = .ENTRY[1]; ! Second operand
BP[TARGET] = 0;
BP[VALTYPE] = .SYMTYPE;
END; ! 7 - Expressions (not hashed)
BEGIN ! 8 - Iolist node or data intialization
BP[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
LITPOINTER[CLINK] = .BASEPTR;
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> = .BP
ELSE
BEGIN
EQVPTR[EQVLINK] = .BP; ! Link in new group
EQVPTR<RIGHT> = .BP ! Pointer to last group made
END;
! ENTRY has pointer to first EQVITEM made by case 12 for
! current EQVGROUP
BP[EQVFIRST] = BP[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> = .BP
ELSE
BEGIN
DATASPTR[DATALNK] = .BP; ! Point to last
DATASPTR<RIGHT> = .BP;
END;
END; ! 13 - Data group nodes for DATA statements
BEGIN ! 14 - NAMELIST list header
IF .NAMLPTR EQL 0
THEN NAMLPTR<LEFT> = NAMLPTR<RIGHT> = .BP
ELSE
BEGIN
NAMLPTR[CLINK] = .BP;
NAMLPTR<RIGHT> = .BP;
END;
END; ! 14 - NAMELIST list header
TES;
! IF DEBUG
! THEN
! BEGIN
! XAREA0<LEFT> = .NAME<LEFT>;
! XAREA0<RIGHT> = .BASEPOINT<RIGHT>;
! XAREA();
! END;
RETURN .BASEPTR
END; ! of NEWENTRY
GLOBAL ROUTINE TESTENTRY=
BEGIN
!***************************************************************
! Test the current table entry against the search argument to
! see if there is a match. Returns -1 if there is a match.
!***************************************************************
XTRAC; ! For debugging trace
RETURN CASE .NAME OF SET
BEGIN ! 0 - Symbol table
IF .BASEPTR[IDSYMBOL] EQL .ENTRY THEN -1 ELSE 0
END; ! 0 - Symbol table
BEGIN ! 1 - Constant table
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
IF .BASEPTR[SNUMBER] EQL .ENTRY
THEN
BEGIN
BASEPTR[SNREF] = .BASEPTR[SNREF] + 1;
-1
END
ELSE 0
END; ! 3 - Statement number 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
END
ELUDOM