Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-SB_FORTRAN10_V10
-
cgstmn.bli
There are 12 other files named cgstmn.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: S. MURPHY,N. ABEL/HPW/DCE/SJW/TFV/EGM/AHM/CKS/RVM/TJK/MEM
MODULE CGSTMN(SREG=#17,VREG=#15,FREG=#16,DREGS=4,RESERVE(0,1,2,3)) =
BEGIN
GLOBAL BIND CGSTMV = #10^24 + 0^18 + #2462; ! Version Date: 2-Oct-84
%(
***** Begin Revision History *****
105 ----- ----- ADD CODE GENERATION ROUTINES FOR E1LISTCALL AND
E2LISTCALL NODES
106 ----- ----- GENERATE ZERO INCREMENT FOR E1 OR E2 LISTCALL
NODES OUT OF LINE
107 ----- ----- GENERATE CODE FOR COMMON SUBS ON CALL STMNTS
108 ----- ----- FOR A REFERENCE TO A FORMAT STMNT, MAKE THE
PEEPHOLE BUFFER ENTRY POINT TO THE FORMAT STMNT RATHER
THAN SIMPLY CONTAINING THE RELATIVE ADDRESS OF THE STRING
109 ----- ----- FIX CAE1LIST AND CAE2LIST TO CALL IOPTR INSTEAD
OF ARGGEN
110 ----- ----- ADD CODE TO HANDLE ARBITRARY EXPRESSION AS THE VAL
OF AN ARG TO OPEN; ADD CODE TO HANDLE ARBITRARY EXPRESSION
AS A UNIT NUMBER
111 ----- ----- FIX BUG IN 110 (HAD LEFT OUT "FIND" AND "OPEN/CLOSE"
FOR EXPRESSIONS AS UNIT NOS)
112 ----- ----- COMMENT OUT THE ROUTINE "CGRELS" - WE CALL
"CGMTOP" FOR RELEASE STMNTS
113 ----- ----- FIX ERROR CALLS
114 ----- ----- FIX REFERENCES TO PROEPITYP AND PROGNAME
115 ----- ----- FIX CGDCALL TO SET INDIRECT BIT OVER FORMAL
ARRAYS UNDER DATACALL NODES
116 ----- ----- FIX CALLS TO IOPTR IN CAE1LIST AND CAE2LIST TO
CLEAR PBOPWD FIRST
117 ----- ----- CHANGE IOIMMED AS FOLLOWS:
FOROTS WILL NOW PERFORM THE INDIRECT
FOR ALL ARGUMENTS NOT IMMEDIATE MODE
CONSTANTS
DISTINGUISH IMMEDIATE MODE CONSTANTS FROM
IMMEDIATE MODE ARGUMENTS IN MEMORY
AS FOLLOWS:
CONSTANTS HAVE AN EMPTY LEFT HALF
OTHER VARIABLES HAVE TYPE FIELD SET
ONLY AN ARGUMENT PASSED IN THE FIRST
ELEMENT OF A FORMAL ARRAY
WILL HAVE THE INDIRECT BIT
SET
FOROTS WILL PERFORM AN EXTRA OPERATION
TO LOAD THE RIGHT HALF OF THE ARGUMENT
IN MEMORY
118 ----- ----- DO NOT CALL "IOENDERR" FOR FIND STMNTS,
SIMPLY PUT OUT 2 WDS OF 0 (THE STMNT NODE DOES NOT HAVE END/ERR FIELDS)
119 ----- ----- IN CGSTMN, IF THE FLAG "DBGTRAC" IS SET CALL
XCTFDDT TO GENERATE "XCT FDDT."
120 ----- ----- TAKE OUT CALLS TO FIN. FOR NAMELIST READ/WRITE
122 ----- ----- DONT CALL "XCTFDDT" FOR STMNT FNS AND ENTRIES
UNTIL AFTER THE LABELS ON THEM ARE DEFINED
123 ----- ----- FIX CODE GEN FOR "DIALOG" IN AN OPEN STMNT
124 306 16156 FIX OPEN/CLOSE TO GIVE FOROTS FORMAL ARRAYS RIGHT, (JNT)
125 367 18239 MAKE WRITE(3) GENERATE CORRECT CODE
126 376 18398 PREVENT CGRECNUM FROM CHANGING A1LABEL, (DCE)
***** Begin Version 5A *****
127 532 20323 SET INDIRECT BIT IN ARG BLOCK FOR ARRAY
REF AS ASSOCIATE VARIABLE, (DCE)
130 564 ----- MAKE CGREAD AND CGWRIT SYMMETRICAL:
MAKE CGREAD CHECK FOR NAMELIST ONLY IF IONAME
PTR NEQ 0;
MAKE CGWRIT GENERATE FIN CALL IF UNFORMATTED
131 607 22685 SET GLOBAL FLAG NEDZER IN CGEND, CGSTOP & CGPAUS
TO INDICATE ZERO-ARG-BLOCK NEEDED
***** Begin Version 5B *****
132 711 26754 PUT OUT FIN CALL WITH ENCODE/DECODE, (DCE)
***** Begin Version 6 *****
133 760 TFV 1-Oct-79 ------
Generate new argument blocks for I/O and OPEN/CLOSE statements
Arg blocks are now keyword based not positional
134 761 TFV 1-Mar-80 -----
Choose arg type based on /GFLOATING
135 1002 TFV 1-Jul-80 ------
MAP EVALU onto EVALTAB to get the argtype for argblock entries
136 1035 DCE 10-Dec-80 -----
For .IOLST calls, put out the correct argument count (add COUNTARGS).
138 1076 TFV 8-Jun-81
Allow list-directed I/O without an iolist.
140 1123 AHM 18-Sep-81 Q20-01650
Make CGIOENDERR and OPNFARGS work for IOSTAT=arrayref and IOSTAT=reg
142 1134 EGM 1-Oct-81 10-31654
For READ/WRITE/FIND, generate code for the record number, then the
unit number, since registers were allocated in that order. Also,
preserve the desired value of A1LABEL for FIND (more of edit 376).
***** Begin Version 7 *****
137 1206 DCE 20-Mar-81 -----
For F77 ELISTS, generate code for final implied loop values.
139 1223 DCE 9-Jun-81 -----
Put out special code for F77 SLISTs and ELISTs so FOROTS can tell.
141 1265 CKS 28-Sep-81
Allow character variables in IO lists
143 1401 AHM 5-Oct-81
Rewrite all code which outputs argument block entries so that extended
addressing and CHARACTER variable support will be easier to implement.
Make all FOROTS args go through IOPTR and IOIMMED. Delete routine
BLDIOIMWD. Create new routine ELISTINCR to merge two identical
streams of thought about ELIST increments. Remove superflous
declarations from routine level so that this module will CREF.
144 1432 RVM 8-Dec-81
Implement assigned formats. Fix IOFORMAT to not generate
an I/O arg block word for the format size, except when the format
is an array. Make IOFORMAT lie to FOROTS when an INTEGER variable
is used as a format: IOFORMAT sets the indirect bit in the format
address word and sets the type of the word to ADDRESS. This way
FOROTS does not need to distinguish between the case of the FMT=
keyword being the label of a format statement or being an INTEGER
variable that has been assigned a format label. Teach routine
CNTKEYS that the FMT= keyword generates only one word in the I/O
arg block for INTEGER variables, CHARACTER variables, and FORMAT
statements used as formats, and two words in the I/O arg block for
arrays used as formats.
145 1435 RVM 14-Dec-81
CNTKEYS is now smart enough to handle namelists correctly, so do
not subtract one from its count in REDORWRIT.
146 1471 RVM 5-Feb-82
Implement internal files. Modify CGREAD and CGWRIT to generate the
calls to the proper FOROTS routines to do internal file I/O. In
REDORWRIT, generate the OTSKEDSIZ keyword if the internal file is a
character array to tell FOROTS how many characters are in the file.
Note that the pointer in the I/O statement node to the number of
characters is stored in the half-word that normally holds the value
of the REC= keyword (random access I/O record number). This is OK
since random access I/O to internal files is illegal. Make IOIMMED
be not so fussy about what it considers to be a legal argument, since
it really can handle almost anything since it calls IOPTR.
147 1472 AHM 7-Feb-82
Make REDORWRIT generate an OTSKREC keyword for all the possible
cases that the REC= variable was not a CHARACTER array.
1502 AHM 26-Feb-82
Make NAMGEN divide the size of a character array by the size
of a character array element so that the size field in a
NAMELIST block is in number of array elements. Also make it
not divide character array factors by anything so that they
are in units of bytes. NAMGEN was dividing by 2 in both cases
because DBLFLG was set. Finally, change the array size and
offset fields to occupy separate words of the NAMELIST block
for extended addressing.
1507 AHM 14-Mar-82
Make all I/O list calls to IOIMMED use IOPTR instead to
eliminate immediate I/O list arguments. Also delete ELISTINCR
and make all its calls go to IOPTR since the problem with zero
immediate words looking like an I/O list end cannot occur.
1516 CKS 22-Mar-82
Reorder code in IOFORMAT to correctly generate code for character
expressions as FMT= specifiers. Also add CGFMT routine to call
CGETVAL when necessary to generate code for nontrivial format
expression.
1533 TFV 17-May-82
Modify code generation for I/O, OPEN and CLOSE statements and
iolists to generate calls to CHMRK. and CHUNW. for dynamic
character concatenations. Add the routine CGIOUNW to do the
code generation. It also generates special error handling code
to unwind before an END or ERR branch. Also generate a dummy
ERR branch if IOSTAT is specified but ERR is not.
1545 CKS 28-May-81 Q10-103
Fix check for namelist IO in CGREAD and CGWRITE to not detect
constants as namelists. Character constants are now possible
format specifiers.
1574 AHM 3-Jul-82
Make REDORWRIT supply a type code of 7 (TYPLABEL) for the
pointer to the namelist block in argument blocks for calls to
NLI. and NLO. It used to be a type 0 (immediate) argument.
1625 RVM 30-Aug-82
Don't output a format size keyword was for list-directed I/O.
1622 CKS/AHM 8-Sep-82
Or together indirect bits in IOPTR, don't add them. (Actually or
together whole index/indirect field, but the index field of one
operand must be zero.)
***** End V7 Development *****
2003 TJK 27-Sep-83
Add check to IOFORMAT to allow a format specifier to be
a REAL or LOGICAL variable (instead of just INTEGER).
2040 TJK 23-Feb-84
Reorder calls for complexity, register allocation, and code
generation of I/O keywords. Most of this was already done in
V10 in edit 2201, although register allocation for FIND was
still incorrect.
2056 TJK/MEM 4-Jun-84
Fix CGCGO to generate correct code for computed GOTOs when
they are the terminal statements of DO-loops. Previously, if
the index value was out of range, control would be transferred
to the next statement and out of the loop.
***** Begin Version 10 *****
2201 TFV 30-Mar-83
INQUIRE implementation. Add case to CGSTMNT and CGIOARGS.
Write CGINQUIRE to do the work. Modify OPNFARGS to handle
FILE=.
2314 AHM 26-Feb-84
Eliminate immediate arguments for OTSKFSIZ (format size)
FOROTS arguments because size of large arrays don't fit in 18
bits. Make IOFORMAT use ARACONSIZ field of dimension table
entries for size of non-adjustably dimensioned arrays.
2317 AHM 4-Mar-84
Make IOPTR and IOFORMAT use GENREF to construct memory
references instead of doing it themselves. Delete vestiges of
support for unimplemented IOREPEAT argument for MTOP. calls
from CGIOARGS (it used immediate arguments). Make CGDECARGS
generate a non-immediate OTSKEDSIZ argument for ENCODE/DECODE
record sizes.
2400 TJK 18-Jun-84
Have CAE1LIST and CAE2LIST use the new FOROTS argument types
OTSNSLIST, OTSNELIST, OTSNSLIST77, and OTSNELIST77. Note that
CGSLIST still uses OTSSLIST.
2462 AHM 2-Oct-84
Use execrable TRUE/FALSE/TRUTH/FALSITY miasma for booleans in
calls to GENREF to satisfy programming conventions.
***** End V10 Development *****
***** End Revision History *****
)%
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
FORWARD
CGSTMNT,
CGASMNT,
CGASSI,
CGAGO,
CGCGO,
CGLOGIF,
CGEND,
CGSTOP,
CGPAUSE,
CGARIF,
CGCMNSUB,
CGIOLST,
CGE1LIST(1),
CGE2LIST(1),
CGIOCALL(1),
COUNTARGS,
OIFIW,
CGIOLARGS,
CGDCALL,
CGSLIST,
CAE1LIST,
CAE2LIST,
CGSTPAUARGS,
%1533% CGIOUNW, ! Routine to generate calls to CHUNW.
CGMTOP,
CGENCO,
CGDECO,
CGRERE,
CGUNIT,
%1516% CGFMT,
CGRECNUM,
%1123% CGIOSTAT,
CGREAD,
CGWRIT,
CGOPLST,
CGOPEN,
CGFIND,
CGCLOS,
%2201% CGINQUIRE, ! INQUIRE
CGDECARGS,
IO1ARG(1),
OPNFARGS,
%760% CNTKEYS,
%1401% IOENDERR,
%1401% IOFORMAT,
IOPTR(1),
%1401% IOIMMED(1),
CGOPARGS,
CGIOARGS,
%1401% REDORWRIT,
NAMGEN;
EXTERNAL
A1LABEL,
PEXPRNODE A1NODE,
A2LABEL,
PEXPRNODE A2NODE,
A3LABEL,
C1H,
CGARGEVAL,
CGARGS,
CGARREF,
CGCBOOL,
%1533% CGCHMRK, ! Routine to generate a call to CHMRK.
%1533% CGCHUNW, ! Routine to generate a call to CHUNW.
CGDOEND,
CGDOLOOP,
CGEPILOGUE,
CGERR,
CGETVAL,
CGFNCALL,
CGOPGEN,
CGPROEPI,
CGREL1,
CGRETURN,
CGSBPRGM,
CGSFN,
%1401% BASE CSTMNT, ! Points to the statement being looked at
DEFLAB,
E91,
%1002% EVALTAB EVALU, ! Table of value-type codes
FATLERR,
%2317% GENREF, ! Constructs memory references
GENLAB,
MTOPFUN,
NAMLPTR,
NEDZER, ! Flag to indicate if zero-arg-block needed
OBUFF,
OBUFFA,
ONEPLIT, ! Points to the constant 1
%761% OPASIN,
%761% OPCMGET,
OPDSPIX,
OPGAI1,
OPGAI2,
OPGAIF,
%761% OPGARI,
%761% OPGASI,
OPGASR,
OPGBOOL,
OPGCGI,
OPGCGO,
OPGCLO,
%711% OPGDEC,
%711% OPGENC,
OPGENDISP,
%761% OPGETI,
OPGEXI,
%1401% OPGFIN, ! OPGNTA table entry for PUSHJ P,FIN.
OPGFND,
%1471% OPGIFI,
%1471% OPGIFO,
%1471% OPGIN,
%2001% OPGINF, ! INQUIRE by file
%2001% OPGINU, ! INQUIRE by unit
OPGIOL,
OPGMTO,
%1471% OPGNLI,
%1471% OPGNLO,
OPGOPE,
%1471% OPGOUT,
OPGPAU,
OPGREL,
%1471% OPGRTB,
%761% OPGSTI,
OPGSTP,
OPGVTS,
%1471% OPGWTB,
OUTMOD,
PPEEPFRAME PBFPTR,
%1401% OBJECTCODE PBOPWD, ! Gets the word to be output for calls
! to the routines OBUFF and OBUFFA
PEEPOPTIMZ,
%1401% PEXPRNODE PSYMPTR, ! Points to the STE (or constant table
! entry) to provide relocation info
REGFORCOMP,
PEXPRNODE TREEPTR,
XCTFDDT, ! Routine to generate "XCT FDDT."
ZERBLK;
OWN BASE TOPSTMNT; ! This variable points to the top level
! statement node when there is a statement
! embedded inside another (e.g. in logical IFs).
GLOBAL ROUTINE CGSTMNT=
BEGIN
!***************************************************************
! Perform code generation for a statement. Called with the
! global CSTMNT pointing to the statement for which code is to
! be generated. The complexity walk, allocation walk, and code
! generation walk must do the fields for each statement in the
! same order.
!***************************************************************
! If there is a label on this statement, associate that label
! with the current location
IF .CSTMNT[SRCLBL] NEQ 0
THEN DEFLAB(.CSTMNT[SRCLBL]);
! Set ISN field for next instruction to be generated
PBFPTR[PBFISN] = .CSTMNT[SRCISN];
IF .FLGREG<DBGTRAC> ! If user specified /DEB:TRACE
THEN IF .CSTMNT[SRCID] NEQ ENTRID AND .CSTMNT[SRCID] NEQ SFNID
THEN XCTFDDT(); ! Generate XCT FDDT.
! Generate code for the statement
CASE .CSTMNT[SRCID] OF SET
CGASMNT(); ! ASSIGNMENT
CGASSI(); ! ASSIGN
BEGIN ! CALL
IF .CSTMNT[SRCCOMNSUB] NEQ 0
THEN CGCMNSUB(); ! Generate code for common subs
CGSBPRGM(.CSTMNT[CALLIST],.CSTMNT[CALSYM]);
END;
BEGIN END; ! CONTINUE
CGDOLOOP(); ! DO
CGPROEPI(); ! ENTRY
CGASMNT(); ! COMMON SUBEXPR - SAME AS ASSIGNMENT
JRSTGEN(.CSTMNT[GOTOLBL]); ! GOTO
CGAGO(); ! ASSIGNED GOTO
CGCGO(); ! COMPUTED GOTO
CGARIF(); ! ARITHMETIC IF
CGLOGIF(); ! LOGICAL IF
CGRETURN(.CSTMNT[RETEXPR]); ! RETURN
CGSTOP(); ! STOP
CGREAD(); ! READ
CGWRIT(); ! WRITE
CGDECO(); ! DECODE
CGENCO(); ! ENCODE
CGRERE(); ! REREAD
CGFIND(); ! FIND
CGCLOS(); ! CLOSE
BEGIN END; ! INPUT (NOT IN RELEASE 1)
BEGIN END; ! OUTPUT (NOT IN RELEASE 1)
CGMTOP(); ! BACKSPACE
CGMTOP(); ! BACKFILE
CGMTOP(); ! REWIND
CGMTOP(); ! SKIP FILE
CGMTOP(); ! SKIP RECORD
CGMTOP(); ! UNLOAD
CGMTOP(); ! RELEASE
CGMTOP(); ! ENDFILE
CGEND(); ! END
CGPAUSE(); ! PAUSE
CGOPEN(); ! OPEN
CGSFN(); ! STATEMENT FN
BEGIN END; ! FORMAT - NO CODE GENERATED
BEGIN END; ! BLT (NOT IN RELEASE 1)
BEGIN END; ! OVERLAY ID
%2201% CGINQUIRE(); ! INQUIRE
TES;
! If this statement has a label, check for whether it ends a DO loop
IF .CSTMNT[SRCLBL] NEQ 0
THEN CGDOEND(.CSTMNT[SRCLBL]);
END; ! of CGSTMNT
GLOBAL ROUTINE CGASMNT=
BEGIN
!***************************************************************
! Generate code for assignment statements. Called with the
! global CSTMNT pointing to the statement for which code is to
! be generated.
!***************************************************************
%(***COMPUTE THE VALUES OF ANY COMMON SUBEXPRS ASSOCIATED WITH THIS STATEMENT***)%
IF .CSTMNT[SRCCOMNSUB] NEQ 0 THEN CGCMNSUB();
%(***GET THE VALUE OF THE LEFT HAND SIDE OF THE STATEMENT AND THE ADDRESS
OF THE RIGHT HAND SIDE WITHIN REACH OF ONE INSTRUCTION***)%
IF .CSTMNT[A1VALFLG]
OR (.CSTMNT[MEMCMPFLG] AND .CSTMNT[RVRSFLG]) !IF RHS IS COMPUTED DIRECTLY TO
! MEMORY LOC OF LHS AND VAL OF LHS NEEDNT BE PRELOADED
THEN
BEGIN
IF NOT .CSTMNT[A2VALFLG]
THEN
BEGIN
TREEPTR_.CSTMNT[RHEXP];
CGETVAL();
END;
END
ELSE
IF .CSTMNT[A2VALFLG]
THEN
BEGIN
TREEPTR_.CSTMNT[LHEXP];
CGETVAL();
END
ELSE
IF .CSTMNT[RVRSFLG]
THEN
%(***IF RIGHT-HAND SIDE SHOULD BE EVALUATED FIRST***)%
BEGIN
TREEPTR_.CSTMNT[RHEXP];
CGETVAL();
TREEPTR_.CSTMNT[LHEXP];
CGETVAL();
END
ELSE
%(***IF LEFT-HAND SIDE SHOULD BE EVALUATED FIRST***)%
BEGIN
TREEPTR_.CSTMNT[LHEXP];
CGETVAL();
TREEPTR_.CSTMNT[RHEXP];
CGETVAL();
END;
%(***IF THE RHS WAS NOT COMPUTED DIRECTLY INTO THE MEMORY LOC FOR THE LHS, PICK UP THE
RHS AND STORE IT INTO THE LHS*******)%
IF NOT .CSTMNT[MEMCMPFLG]
THEN
BEGIN
REGFORCOMP_GETASMNREG(CSTMNT);
%(***GET VAL OF RIGHT-HAND SIDE INTO REG FOR COMPUTATION OF THE STMNT***)%
A1NODE_.CSTMNT[RHEXP];
TREEPTR_.CSTMNT;
OPDSPIX_GETA2OPIX(CSTMNT,A1NODE);
CGOPGEN();
%(***STORE THE VALUE FROM REG-FOR-COMPUTATION INTO THE ADDRESS
SPECIFIED BY THE LEFT-HAND-SIDE***)%
IF NOT .CSTMNT[A1SAMEFLG]
THEN
BEGIN
TREEPTR_.CSTMNT[LHEXP];
OPDSPIX_ASNOPIX(CSTMNT,TREEPTR);
CGOPGEN();
END;
END;
END; ! of CGASMNT
GLOBAL ROUTINE CGASSI=
BEGIN
!***************************************************************
! Generate code for an ASSIGN statement. Note that the variable
! will always be loaded into register 1.
!***************************************************************
%(***IF THE ASSIGNED VAR IS AN ARRAYREF, GENERATE CODE TO COMPUTE ITS ADDR***)%
TREEPTR_.CSTMNT[ASISYM];
IF .TREEPTR[OPRCLS] EQL ARRAYREF
THEN
CGETVAL();
%(***COMPUTE THE ASSIGN*******)%
A1NODE_.CSTMNT[ASISYM];
A1LABEL_.CSTMNT[ASILBL];
OPDSPIX_OPASIN;
CGOPGEN();
END; ! of CGASSI
GLOBAL ROUTINE CGAGO=
BEGIN
!***************************************************************
! Generates code for ASSIGNed GOTO statement. Called with
! CSTMNT pointing to the statement to be processed. If a list
! of labels was specified for this statement, code generated is:
!
! HRRZ 1,VAR ; Get the local address
! CAIN 1,LAB1
! JRST LAB1
! CAIN 1,LAB2
! JRST LAB2
! ....
!
! If not, the code generated is:
!
! SKIPE 1,VAR
! JRST 0(1)
!***************************************************************
! Opcodes needed for code for ASSIGNed GOTO
BIND HRRZOC=#550^27,
CAINOC=#306^27,
SKIPEOC=#332^27;
! Always use register 1 to hold the assigned var
BIND AGOREG=1^23,
AGORGIX=1^18;
OWN AGOLSTPTR,
PEXPRNODE AGOVAR;
! Set up the globals PBOPWD and PSYMPTR used by the output routine to
! indicate an address reference to the assigned variable
AGOVAR_.CSTMNT[AGOTOLBL];
IF .AGOVAR[OPRCLS] EQL ARRAYREF
THEN ! Assigned var is an array reference
BEGIN
TREEPTR_.AGOVAR;
CGETVAL();
PSYMPTR_.AGOVAR[ARG1PTR]; ! STE for the array
PBOPWD_.AGOVAR[TARGET]; ! Address field to reference
! the array element desired
END
ELSE ! Assigned var is a scalar
BEGIN
PSYMPTR_.AGOVAR;
PBOPWD_.AGOVAR[IDADDR];
END;
IF .CSTMNT[GOTOLIST] EQL 0
THEN ! No list of labels was specified
BEGIN
PBOPWD_.PBOPWD OR SKIPEOC OR AGOREG; ! Generate SKIPE 1,VAR
OBUFF();
PSYMPTR_PBFNOSYM;
PBOPWD_JRSTOC OR AGORGIX; ! Generate JRST 0(1)
OBUFF();
END
ELSE ! A list of labels was specified
BEGIN
PBOPWD_.PBOPWD OR HRRZOC OR AGOREG; ! Generate HRRZ 1,VAR
OBUFF();
! For each label in the list, compare reg 1 with the label and if it
! is equal, transfer to the label
AGOLSTPTR_.CSTMNT[GOTOLIST];
DECR CT FROM .CSTMNT[GOTONUM] TO 1
DO
BEGIN
PBOPWD_CAINOC OR AGOREG OR @.AGOLSTPTR;
PSYMPTR_PBFLABREF;
OBUFF();
JRSTGEN(@.AGOLSTPTR);
AGOLSTPTR_.AGOLSTPTR+1;
END;
END;
END; ! of CGAGO
GLOBAL ROUTINE CGCGO=
BEGIN
!***************************************************************
! Generates code for the computed GOTO statement. Called with
! the global CSTMNT pointing to the statement. The generated
! code is:
! SKIPLE 01,VAL
! CAILE 01,CT
! JRST Y
! JRST @.(1)
! IFIW L1
! IFIW L2
! ....
!
%2056% ! Y: First instruction after computed GOTO code
%2056% ! (note -- Y may precede DO-loop code for a DO-loop
%2056% ! ending on the computed GOTO).
!***************************************************************
BIND SKIPLEOC=#333^27, ! Define opcodes used for computed GOTO
CAILEOC=#303^27,
SKIPAOC=#334^27;
BIND CGOREG=1^23, ! Use register 1 to hold the computed val
CGORGIX=1^18;
OWN PEXPRNODE CGOEXP;
OWN CLOC;
OWN CGOLSTPTR;
%2056% REGISTER BASE YLAB; ! Holds pointer to label Y (see comment at
%2056% ! beginning of routine)
! Compute the values of any common subexprs associated with this stmnt
IF .CSTMNT[SRCCOMNSUB] NEQ 0 THEN CGCMNSUB();
! If the expression is not a scalar or a common sub, evaluate it
CGOEXP=.CSTMNT[CGOTOLBL];
IF .CGOEXP[OPRCLS] NEQ DATAOPR AND .CGOEXP[OPRCLS] NEQ CMNSUB
THEN
BEGIN
TREEPTR=.CGOEXP;
CGETVAL();
END;
! Generate the SKIPLE, CAILE, JRST sequence
%2056% ! Create label Y (see comment at beginning of routine)
%2056%
%2056% A1LABEL = YLAB = GENLAB();
A1NODE=.CGOEXP;
C1H=.CSTMNT[GOTONUM];
! Have a special case when the expression is the loop index of a loop in
! which the index is stored in the right half of an AC. In this case
! generate:
! MOVEI 1,0(LOOPAC)
! JUMPLE 1,Y
! CAILE 1,CT
! JRST Y
IF .CSTMNT[A1IMMEDFLG] AND .CGOEXP[OPRCLS] EQL REGCONTENTS
THEN OPDSPIX=OPGCGI
ELSE OPDSPIX=OPGCGO;
CGOPGEN();
! Associate a label with the current loc
CLOC=GENLAB();
DEFLAB(.CLOC);
! Generate JRST @CLOC(1)
PBOPWD=JRSTOC OR INDBIT OR CGORGIX OR .CLOC;
PSYMPTR=PBFLABREF;
OBUFF();
! For each label listed, generate "IFIW label"
PSYMPTR=PBFLABREF;
CGOLSTPTR=.CSTMNT[GOTOLIST];
DECR CT FROM .CSTMNT[GOTONUM] TO 1
DO
BEGIN
[email protected];
%1401% PBOPWD[OTSIFIW]=1; ! Make this an IFIW
OBUFF();
CGOLSTPTR=.CGOLSTPTR+1
END;
%2056% ! Output label Y to peephole buffer (see comment at beginning of
%2056% ! routine).
%2056%
%2056% DEFLAB(.YLAB);
END; ! of CGCGO
GLOBAL ROUTINE CGLOGIF=
%(***************************************************************************
ROUTINE TO GENERATE CODE FOR LOGICAL IF STATEMENTS.
CALLED WITH THE GLOBAL CSTMNT POINTING TO THE STATEMENT FOR
WHICH CODE IS TO BE GENERATED.
A LOGICAL IF STATEMENT NODE MAY HAVE THE FLAG "A1NOTFLG" SET, WHICH
MEANS TO TAKE THE "NOT" (COMPLEMENT) OF THE CONDITION SPECIFIED.
BECAUSE "NOT" PROPAGATES OVER BOTH BOOLEANS AND RELATIONALS, IT IS ASSUMED
THAT THIS FLAG WILL NEVER BE SET WHEN THE CONDITION IS A BOOLEAN OR RELATIONAL.
***************************************************************************)%
BEGIN
OWN THENLAB,ELSELAB; !NEW LABEL TABLE ENTRIES
!WHICH WILL BE CREATED TO PROCESS
! THIS STMNT
OWN BASE SUBSTATMNT; !STATEMENT TO BE EXECUTED IF CONDITION HOLDS
OWN BASE SAVSTMNT; !SAVE PTR TO THE LOG IF STATEMENT
OWN PEXPRNODE CONDEXPR; !CONDITIONAL EXPRESSION TO BE TESTED
%(***EVALUATE ANY COMMON SUBEXPRESSIONS UNDER THIS STATEMENT***)%
IF .CSTMNT[SRCCOMNSUB] NEQ 0 THEN CGCMNSUB();
SUBSTATMNT_.CSTMNT[LIFSTATE];
CONDEXPR_.CSTMNT[LIFEXPR];
TREEPTR_.CSTMNT[LIFEXPR];
%(*****WHEN THE STATEMENT TO BE EXECUTED IF CONDITION IS TRUE IS A GOTO***)%
IF .SUBSTATMNT[SRCID] EQL GOTOID
THEN
BEGIN
%(****IF THE CONDITION TO BE TESTED IS A RELATIONAL***)%
IF .CONDEXPR[OPRCLS] EQL RELATIONAL
THEN
BEGIN
CGREL1(FALSE); !SKIP NEXT INSTR IF REL IS FALSE
%(***GENERATE A JRST TO THE GOTO-LABEL***)%
JRSTGEN(.SUBSTATMNT[GOTOLBL]);
END
%(***IF THE CONDITION TO BE TESTED IS A BOOLEAN***)%
ELSE
IF .CONDEXPR[OPRCLS] EQL BOOLEAN
THEN
BEGIN
ELSELAB_GENLAB(); !CREATE LABEL TABLE ENTRY FOR LABEL
! TO GO TO IF CONDITION IS FALSE
CGCBOOL(.SUBSTATMNT[GOTOLBL],.ELSELAB);
DEFLAB(.ELSELAB);
END
ELSE
%(***IF CONDITION IS NOT A RELATIONAL OR BOOLEAN, EVALUATE THE CONDEXPR AND
TEST WHETHER IS IS TRUE (SIGN BIT EQUAL 1) OR FALSE(SIGN=0) ***)%
BEGIN
CGETVAL();
%(***TEST VAL OF CONDEXPR,
IF "A1NOTFLG" IS SET, TRANSFER TO GOTO-LABEL IF ARG IS
FALSE, OTHERWISE TRANSFER TO GOTOLABEL IF ARG IS TRUE***)%
OPDSPIX_CNDVTRIX(CONDEXPR,(IF .CSTMNT[A1NOTFLG] THEN FALSE ELSE TRUE));
A1LABEL_.SUBSTATMNT[GOTOLBL];
TREEPTR_.CONDEXPR;
REGFORCOMP_GETTAC(TREEPTR);
CGOPGEN();
END;
END
%(****WHEN STATEMENT TO BE EXECUTED ON TRUE CONDITION IS NOT A GOTO***)%
ELSE
BEGIN
ELSELAB_GENLAB(); !CREATE LABEL TABLE ENTRY FOR LABEL
! TO GO TO WHEN CONDITION IS FALSE
%(***IF CONDITION TO BE TESTED IS A RELATIONAL***)%
IF .CONDEXPR[OPRCLS] EQL RELATIONAL
THEN
BEGIN
CGREL1(TRUE); !SKIP NEXT INSTR IF REL IS TRUE
%(***GENERTAE CODE TO GO TO THE LABEL ON THE CODE FOLLOWING THAT
FOR THE SUBSTATMNT OF THE IF STMNT***)%
JRSTGEN(.ELSELAB);
END
%(***IF THE CONDITION TO BE TESTED IS A BOOLEAN*****)%
ELSE
IF .CONDEXPR[OPRCLS] EQL BOOLEAN
THEN
BEGIN
THENLAB_GENLAB(); !CREATE LABEL TABLE ENTRY FOR LABEL TO
! GO TO WHEN CONDITION IS TRUE
CGCBOOL(.THENLAB,.ELSELAB);
DEFLAB(.THENLAB); !ASSOCIATE THIS LOC WITH THENLAB
END
%(***IF CONDITIONAL EXPRESSION IS NOT A REL OR BOOLEAN, EVALUATE IT AND
TEST WHETHER ITS VAL IS TRUE (SIGN=1) OR FALSE (SIGN=0)***)%
ELSE
BEGIN
CGETVAL();
%(***TEST VAL OF CONDEXPR,
IF "A1NOTFLG" IS SET, TRANSFER TO ELSELAB IF VAL IS TRUE
OTHERWISE TRANSFER TO ELSELAB IF VAL IS FALSE***)%
OPDSPIX_CNDVTRIX(CONDEXPR,(IF .CSTMNT[A1NOTFLG] THEN TRUE ELSE FALSE));
A1LABEL_.ELSELAB;
TREEPTR_.CONDEXPR;
REGFORCOMP_GETTAC(TREEPTR);
CGOPGEN();
END;
%(****GENERATE CODE FOR THE STATEMENT TO BE EXECUTED WHEN THE CONDITION IS TRUE***)%
TOPSTMNT_.CSTMNT; !SAVE A PTR TO THIS "TOP-LEVEL" STMNT
SAVSTMNT_.CSTMNT;
CSTMNT_.SUBSTATMNT;
CGSTMNT();
CSTMNT_.SAVSTMNT; !RESTORE THE GLOBAL CSTMNT
%(***ASSOCIATE THIS LOC WITH THE LABEL TRANSFERED TO WHEN THE CONDITION
IS FALSE****)%
DEFLAB(.ELSELAB);
END;
END; ! of CGLOGIF
GLOBAL ROUTINE CGEND=
%(*********************************************************
TO GENERATE CODE FOR AN END STATEMENT
**********************************************************)%
BEGIN
!AN END TRIGGERS A CALL TO EXIT ONLY IN A MAIN
!PROGRAM, NOT FOR A SUBPROGRAM
!IN A SUBPROGRAM THE END TRIGGERS A RETURN.
IF .FLGREG<PROGTYP> EQL MAPROG
THEN
BEGIN
NEDZER _ 1; ! FLAG ZERO-ARG-BLOCK NEEDED
A1LABEL_.ZERBLK; !ARGLIST FOR CALL TO EXIT IS ALWAYS
! 0 FOR THE END STMNT
OPDSPIX_OPGEXI;
CGOPGEN();
END
ELSE
!ALSO CHECK FOR A BLOCK DATA SUBPROGRAM
IF .FLGREG<PROGTYP> NEQ BKPROG
THEN
BEGIN
!IF THERE ARE MULTIPLE ENTRIES OR LABELS AS ARGS
IF .FLGREG<MULTENT> OR .FLGREG<LABLDUM>
! HAS MULTIPLE ENTRIES
THEN CGRETURN(0); ! GENERATE CODE TO "RETURN"
!FOR A SINGLE ENTRY SUBPROGRAM GENERATE THE
!EPILOGUE
IF NOT .FLGREG<MULTENT>
THEN
BEGIN
REGISTER BASE TSTMNT;
TSTMNT_.SORCPTR<LEFT>; !PTR TO 1ST STMNT IN PROG
WHILE .TSTMNT[SRCID] NEQ ENTRID
DO
BEGIN
TSTMNT_.TSTMNT[CLINK]; !(SKIP DUMMY CONTINUES)
IF .TSTMNT EQL 0 THEN CGERR() !IF NEVER FIND THE ENTRY
END;
CGEPILOGUE(.TSTMNT); !GENERATE THE EPILOGUE CORRESPONDING TO THIS ENTRY
END;
END
END; ! of CGEND
GLOBAL ROUTINE CGSTOP=
%(***************************************************************************
TO GENERATE CODE FOR A STOP STMNT
***************************************************************************)%
BEGIN
%(***USE THE ZERO-ARG-BLOCK AS THE ARG BLOCK FOR THIS CALL TO FOROTS***)%
A1LABEL_(IF .CSTMNT[STOPIDENT] EQL 0 !IF DO NOT HAVE A CNST
! TO PRINT OUT, THEN ARGLIST
! FOR EXIT WILL BE 0
THEN (NEDZER _ 1; .ZERBLK) ! FLAG ZERO-ARG-BLOCK NEEDED
ELSE GENLAB() ); !IF HAVE AN ARG TO
! PASS TO EXIT, ASSOCIATE A LABEL
! WITH THE ARGLIST TO BE GENERATED
CSTMNT[STOPLBL]_.A1LABEL; !SAVE LABEL TO BE USED
OPDSPIX_OPGSTP;
CGOPGEN();
END; ! of CGSTOP
GLOBAL ROUTINE CGPAUSE=
%(***************************************************************************
ROUTINE TO GENERATE CODE FOR PAUSE
***************************************************************************)%
BEGIN
A1LABEL_(IF .CSTMNT[PAUSIDENT] EQL 0 !IF DO NOT HAVE A CNST
! TO PRINT OUT, THEN ARGLIST
! FOR FOROTS "PAUSE" ROUTINE WILL BE 0
THEN (NEDZER _ 1; .ZERBLK) ! FLAG ZERO-ARG-BLOCK NEEDED
ELSE GENLAB() ); !IF HAVE AN ARG TO
! PASS TO FOROTS, ASSOCIATE A LABEL
! WITH THE ARGLIST TO BE GENERATED
CSTMNT[PAUSLBL]_.A1LABEL;
OPDSPIX_OPGPAU;
CGOPGEN();
END; ! of CGPAUSE
GLOBAL ROUTINE CGARIF=
%(***************************************************************************
ROUTINE TO GENERATE CODE FOR AN ARITHMETIC IF STATEMENT.
CALLED WITH THE GLOBAL CSTMNT POINTING TO THE STATEMENT
FOR WHICH CODE IS TO BE GENERATED.
***************************************************************************)%
BEGIN
OWN BASE NXTSTMNT;
OWN PEXPRNODE CONDEXPR; !THE ARITHMETIC EXPRESSION UNDER THIS STMNT
%(***COMPUTE ANY COMMON SUBEXPRESSIONS UNDER THIS NODE***)%
IF .CSTMNT[SRCCOMNSUB] NEQ 0 THEN CGCMNSUB();
%(***DETERMINE WHICH (IF ANY) OF THE 3 LABELS ASSOCIATED WITH
THIS NODE ARE EQUAL TO THE LABEL ON THE FOLLOWING STMNT***)%
NXTSTMNT_.CSTMNT[SRCLINK];
CSTMNT[AIFLBNXT]_
BEGIN
IF .CSTMNT[AIFLESS] EQL .NXTSTMNT[SRCLBL]
THEN LLBNXT
ELSE
IF .CSTMNT[AIFEQL] EQL .NXTSTMNT[SRCLBL]
THEN ELBNXT
ELSE
IF .CSTMNT[AIFGTR] EQL .NXTSTMNT[SRCLBL]
THEN GLBNXT
ELSE NOLBNXT
END;
%(***GET PTR TO THE CONDITIONAL EXPRESSION***)%
CONDEXPR_.CSTMNT[AIFEXPR];
TREEPTR_.CONDEXPR;
%(***COMPUTE THE VAL OF THE ARITH EXPR, THEN TEST IT****)%
%(***COMPUTE THE VAL OF THE ARITH EXPR***)%
IF NOT .CSTMNT[A1VALFLG]
THEN CGETVAL();
%(***IF THERE IS A NEG ON THE VALUE, EXCHANGE THE GTR AND LESS LABELS***)%
IF .CSTMNT[A1NEGFLG]
THEN
BEGIN
A1LABEL_.CSTMNT[AIFGTR];
A3LABEL_.CSTMNT[AIFLESS];
A2LABEL_.CSTMNT[AIFEQL];
%(***MODIFY THE "AIFLBNXT" FIELD WHICH INDICATED WHICH OF
THE 3 LABELS IS ON THE NEXT STMNT (CHANGE "GTR LABEL NEXT"
TO "LESS LABEL NEXT", "LESS LABEL NEXT" TO
"GTR LABEL NXT" LEAVE OTHERS UNCHANGED
MODIFY THE "AIFLBEQV" FIELD SO THAT "GTR LABEL SAME
AS EQL LABEL" BECOMES "LESS LABEL SAME AS EQL LABEL"
AND VICE-VERSA
****)%
SWPAIFFLGS(CSTMNT);
END
ELSE
BEGIN
A1LABEL_.CSTMNT[AIFLESS];
A3LABEL_.CSTMNT[AIFGTR];
A2LABEL_.CSTMNT[AIFEQL];
END;
%(***USE THE TABLE-DRIVER TO GENERATE CODE TO TEST THE VAL AND TRANSFER***)%
REGFORCOMP_GETAIFREG(CSTMNT);
OPDSPIX_AIFIX(CSTMNT,CONDEXPR);
A1NODE_.CONDEXPR;
CGOPGEN();
END; ! of CGARIF
GLOBAL ROUTINE CGCMNSUB=
%(***************************************************************************
GENERATE CODE TO EVLUATE ANY COMMON SUBEXPRESSIONS THAT OCCUR UNDER
THE STATEMENT NODE POINTED TO BY "CSTMNT"
***************************************************************************)%
BEGIN
OWN PEXPRNODE CCMNSUB;
%(***COMPUTE THE VALUES OF ANY COMMON SUBEXPRS ASSOCIATED WITH THIS STATEMENT***)%
CCMNSUB_.CSTMNT[SRCCOMNSUB];
UNTIL .CCMNSUB EQL 0
DO
BEGIN
IF NOT .CCMNSUB[A2VALFLG]
THEN
BEGIN
TREEPTR_.CCMNSUB[ARG2PTR];
CGETVAL();
END;
%(***IF THE COMMON SUBEXPR IS TO BE LEFT IN A DIFFERENT PLACE THAN
THAT INTO WHICH IT WAS COMPUTED, PUT IT THERE.
NOT THAT THIS CAN ONLY OCCUR WHEN THE PLACE IN WHICH
IT IS TO BE LEFT IS A REGISTER.
*******)%
IF NOT .CCMNSUB[A2SAMEFLG]
THEN
BEGIN
A1NODE_.CCMNSUB[ARG2PTR];
OPDSPIX_GETA2OPIX(CCMNSUB,A1NODE);
REGFORCOMP_GETTAC(CCMNSUB);
CGOPGEN();
END;
%(***IF THE VAL OF THIS COMMON SUB MUST BE STORED INTO A TMP, GENERATE
CODE TO DO SO***)%
IF .CCMNSUB[STOREFLG]
THEN
BEGIN
TREEPTR_.CCMNSUB;
REGFORCOMP_GETTAC(CCMNSUB);
OPDSPIX_STOROPIX(CCMNSUB);
CGOPGEN();
END;
CCMNSUB_.CCMNSUB[CLINK];
END;
END; ! of CGCMNSUB
GLOBAL ROUTINE CGIOLST=
BEGIN
!***************************************************************
! Perform code generation for an iolist. Called with the global
! CSTMNT pointing to the statement for which an iolist is to be
! processed. For each element in the iolist:
!
! 1. If the element is a statement (either a DO, a CONTINUE
! which terminates a DO loop, or an assignment), perform
! usual code generation for that type of statement.
! 2. Otherwise, the element is an IOLSCLS node (i.e. a
! DATACALL, SLISTCALL, IOLSTCALL, E1LISTCALL, or
! E2LISTCALL).
! 3. If the IOLSCLS node contains dynamic concatenations,
! generate the call to CHMRK.
! 4. Perform code generation for all elements under the
! IOLSCLS node.
! 5. Then generate:
!
! XMOVEI 16,ARGBLKP
! PUSHJ 17,IOLST.
!
! where ARGBLKP is a pointer to the argument list for this
! element.
! 6. If the IOLSCLS node contains dynamic concatenations,
! generate the call to CHUNW.
!***************************************************************
REGISTER
BASE SAVCSTMNT,
%1533% BASE SAVSTMNT,
BASE IOLELEM;
IOLELEM = .CSTMNT[IOLIST]; ! Pointer to first element of IOLIST
! Save pointer to current statement (CSTMNT is clobbered if
! there are implied Do loops in the IOLIST
SAVSTMNT = .CSTMNT;
WHILE .IOLELEM NEQ 0
DO
BEGIN ! Walk down the iolist
IF .IOLELEM[OPRCLS] EQL STATEMENT
THEN
BEGIN ! Statement
CSTMNT = .IOLELEM;
CGSTMNT();
! If the last element of the iolist for the
! statement is not an IOLSCLS node, generate:
! PUSHJ P,FIN.
IF .IOLELEM[CLINK] EQL 0
THEN
BEGIN
OPDSPIX = OPGFIN;
CGOPGEN();
END;
END ! Statement
ELSE IF .IOLELEM[OPRCLS] EQL IOLSCLS
THEN
BEGIN ! IOLSCLS node
%1533% ! If the IOLSCLS has dynamic concatenations under it
%1533% ! generate a call to CHMRK.
%1533% IF .IOLELEM[IOLDYNFLG]
%1533% THEN CGCHMRK(.SAVSTMNT[IOLMARK]);
! Evaluate all expressions under this element
CASE .IOLELEM[OPERSP] OF SET
BEGIN ! DATACALL
! Evaluate the expression under the node
TREEPTR = .IOLELEM[DCALLELEM];
IF .TREEPTR[OPRCLS] NEQ DATAOPR
THEN CGETVAL();
END; ! DATACALL
BEGIN ! SLISTCALL
! Evaluate the expression for the number
! of elements
TREEPTR = .IOLELEM[SCALLCT];
IF .TREEPTR[OPRCLS] NEQ DATAOPR
THEN CGETVAL();
END; ! SLISTCALL
! IOLSTCALL - evaluate all expressions under it
CGIOCALL(.IOLELEM);
BEGIN ! E1LISTCALL - optimized code only
SAVCSTMNT = .CSTMNT;
CSTMNT = .IOLELEM;
CGCMNSUB(); ! Evaluate common subs
CSTMNT = .SAVCSTMNT;
CGE1LIST(.IOLELEM)
END; ! E1LISTCALL - optimized code only
BEGIN ! E2LISTCALL - optimized code only
SAVCSTMNT = .CSTMNT;
CSTMNT = .IOLELEM;
CGCMNSUB(); ! Evaluate common subs
CSTMNT = .SAVCSTMNT;
CGE2LIST(.IOLELEM)
END ! E2LISTCALL - optimized code only
TES;
! Create a label table entry for the label
! associated with the argument list for this
! node
A1LABEL = GENLAB();
IOLELEM[IOLSTLBL] = .A1LABEL;
OPDSPIX = OPGIOL;
CGOPGEN(); ! Generate call to IOLST.
%1533% ! If the IOLSCLS has dynamic concatenations under it
%1533% ! generate a call to CHUNW.
%1533% IF .IOLELEM[IOLDYNFLG]
%1533% THEN CGCHUNW(.SAVSTMNT[IOLMARK]);
END ! IOLSCLS node
ELSE CGERR();
IOLELEM = .IOLELEM[CLINK];
END; ! Walk down the iolist
CSTMNT = .SAVSTMNT;
END; ! of CGIOLST
GLOBAL ROUTINE CGE1LIST(IOLELEM)=
%(**********************************************************************
ROUTINE TO GENERATE IN LINE CODE FOR
AN E1LISTCALL NODE
**********************************************************************)%
BEGIN
MAP BASE IOLELEM;
LOCAL BASE IOARRAY;
TREEPTR_.IOLELEM[ECNTPTR];
IF .TREEPTR[OPRCLS] NEQ DATAOPR
THEN CGETVAL();
TREEPTR_.IOLELEM[E1INCR];
IF .TREEPTR[OPRCLS] NEQ DATAOPR
THEN CGETVAL();
IOARRAY_.IOLELEM[ELSTPTR];
WHILE .IOARRAY NEQ 0 DO
BEGIN
TREEPTR_.IOARRAY[E2ARREFPTR];
IF .TREEPTR[OPRCLS] NEQ DATAOPR
THEN CGETVAL();
IOARRAY_.IOARRAY[CLINK]
END;
!**;[1206], CGE1LIST @4177, DCE, 20-Mar-81
!**;[1206], Output code for assignment statements to set final loop value(s)
%[1206]%
%[1206]% CSTMNT_.IOLELEM[ELPFVLCHAIN]; ! Get head of chain
%[1206]%
%[1206]% WHILE .CSTMNT NEQ 0 DO
%[1206]% BEGIN
%[1206]% CGASMNT(); ! Code for assignment statement
%[1206]% CSTMNT_.CSTMNT[CLINK] ! On to the next...
%[1206]% END;
END; ! of CGE1LIST
GLOBAL ROUTINE CGE2LIST(IOLELEM)=
%(**********************************************************************
ROUTINE TO GENERATE INLINE CODE FOR
AN E2LISTCALL NODE
**********************************************************************)%
BEGIN
MAP BASE IOLELEM;
LOCAL BASE IOARRAY;
TREEPTR_.IOLELEM[ECNTPTR];
IF .TREEPTR[OPRCLS] NEQ DATAOPR
THEN CGETVAL();
IOARRAY_.IOLELEM[ELSTPTR];
WHILE .IOARRAY NEQ 0 DO
BEGIN
TREEPTR_.IOARRAY[E2INCR];
IF .TREEPTR[OPRCLS] NEQ DATAOPR
THEN CGETVAL();
IOARRAY_.IOARRAY[CLINK]
END;
IOARRAY_.IOLELEM[ELSTPTR];
WHILE .IOARRAY NEQ 0 DO
BEGIN
TREEPTR_.IOARRAY[E2ARREFPTR];
IF .TREEPTR[OPRCLS] NEQ DATAOPR
THEN CGETVAL();
IOARRAY_.IOARRAY[CLINK]
END;
!**;[1206], CGE2LIST @4211, DCE, 20-Mar-81
!**;[1206], Output code for assignment statements to set final loop value(s)
%[1206]%
%[1206]% CSTMNT_.IOLELEM[ELPFVLCHAIN]; ! Get head of chain
%[1206]%
%[1206]% WHILE .CSTMNT NEQ 0 DO
%[1206]% BEGIN
%[1206]% CGASMNT(); ! Code for assignment statement
%[1206]% CSTMNT_.CSTMNT[CLINK] ! On to the next...
%[1206]% END;
END; ! of CGE2LIST
GLOBAL ROUTINE CGIOCALL(IOLSNODE)=
%(***************************************************************************
ROUTINE TO GENERATE THE CODE FOR AN IOLSTCALL NODE.
GENERATES CODE TO EVALUATE ALL EXPRESSIONS UNDER THE
IOLSTCALL.
***************************************************************************)%
BEGIN
MAP BASE IOLSNODE;
OWN BASE IOLELEM;
OWN SAVSTMNT;
%(***SAVE THE GLOBAL CSTMNT***)%
SAVSTMNT_.CSTMNT;
%(***GENERATE CODE FOR ANY COMMON SUBEXPRS UNDER THIS NODE***)%
CSTMNT_.IOLSNODE;
CGCMNSUB();
%(***WALK THRU THE ELEMS UNDER THIS IOLSTCALL***)%
IOLELEM_.IOLSNODE[IOLSTPTR];
UNTIL .IOLELEM EQL 0
DO
BEGIN
CASE .IOLELEM[OPERSP] OF SET
%(***FOR A DATACALL****)%
BEGIN
TREEPTR_.IOLELEM[DCALLELEM];
IF .TREEPTR[OPRCLS] NEQ DATAOPR
THEN CGETVAL();
END;
%(***FOR AN SLISTCALL (AN SLIST THAT HAS ONLY ONE ARRAYREF, AND
THAT ARRAYREF STARTS AT THE BASE OF THE ARRAY, AND THE
INCREMENT IS A CONSTANT) ***)%
BEGIN
TREEPTR_.IOLELEM[SCALLCT];
IF .TREEPTR[OPRCLS] NEQ DATAOPR
THEN CGETVAL();
END;
%(***AN IOLSTCALL NODE UNDER ANOTHER IOLSTCALL NODE IS ILLEGAL***)%
CGERR();
%(***FOR AN E1LISTCALL - OPTIMIZED CODE ONLY***)%
BEGIN
CGE1LIST(.IOLELEM)
END;
%(***FOR AN E2LISTCALL - OPTIMIZED CODE ONLY***)%
BEGIN
CGE2LIST(.IOLELEM)
END
TES;
IOLELEM_.IOLELEM[CLINK];
END;
%(***RESTORE CSTMNT***)%
CSTMNT_.SAVSTMNT;
END; ! of CGIOCALL
GLOBAL ROUTINE COUNTARGS=
BEGIN
! This routine walks an IOLSCLS node together with all its components to
! count the number of words which are to be generated for the
! corresponding argument list. It then puts out the -COUNT,,0 word
! which precedes the arguments. This routine is necessary since
! optimization may have performed transformations on the argument list,
! thereby changing the resulting argument list(s), and there are no
! fields to preserve the size of various IOLSCLS pieces. This would
! also consume a fair amount of space. Hence this routine. This entire
! routine is added by edit 1035.
LOCAL PEXPRNODE IOARRAY;
LOCAL SAVTREEPTR;
%1401% REGISTER ACNT; ! For counting the words in the argument list
ACNT_1; ! Initialize the count - block is always terminated
! by a zero word or a FIN call.
! The last shall be first...
CASE.TREEPTR[OPERSP] OF SET
%DATACALL%
ACNT_.ACNT+1; ! Only one item in a DATACALL node
%SLISTCALL%
ACNT_.ACNT+3; ! Count, increment, base address
%IOLSTCALL%
BEGIN
SAVTREEPTR_.TREEPTR;
TREEPTR_.TREEPTR[IOLSTPTR];
! Walk through the list, counting elements of each list item
UNTIL .TREEPTR EQL 0 DO
BEGIN
CASE .TREEPTR[OPERSP] OF SET
%DATACALL%
ACNT_.ACNT+1; ! Only one item in a DATACALL node
%SLISTCALL%
ACNT_.ACNT+3; ! Count, increment, base address
%IOLSTCALL%
CGERR(); ! IOLSTCALL under IOLSTCALL is illegal
%E1LISTCALL%
BEGIN
ACNT_.ACNT+2; ! Count, increment
IOARRAY_.TREEPTR[ELSTPTR];
WHILE .IOARRAY NEQ 0 DO
BEGIN
ACNT_.ACNT+1; ! Add one for each array
IOARRAY_.IOARRAY[CLINK] ! Get next array
END
END;
%E2LISTCALL%
BEGIN
ACNT_.ACNT+1; ! ELIST,,count
IOARRAY_.TREEPTR[ELSTPTR];
WHILE .IOARRAY NEQ 0 DO
BEGIN
ACNT_.ACNT+2; ! Increment and base address words
IOARRAY_.IOARRAY[CLINK]
END
END;
TES;
TREEPTR_.TREEPTR[CLINK]
END;
TREEPTR_.SAVTREEPTR;
END;
%E1LISTCALL%
BEGIN
ACNT_.ACNT+2; ! Count, increment
IOARRAY_.TREEPTR[ELSTPTR];
WHILE .IOARRAY NEQ 0 DO
BEGIN
ACNT_.ACNT+1; ! Add one for each array
IOARRAY_.IOARRAY[CLINK] ! Get next array
END
END;
%E2LISTCALL%
BEGIN
ACNT_.ACNT+1; ! ELIST,,count
IOARRAY_.TREEPTR[ELSTPTR];
WHILE .IOARRAY NEQ 0 DO
BEGIN
ACNT_.ACNT+2; ! Increment and base address words
IOARRAY_.IOARRAY[CLINK]
END
END;
TES;
! ACNT should now contain the count of argument words - put it out.
PBOPWD_ (-.ACNT)^18; ! Count to left half
PSYMPTR_PBF2NOSYM;
OBUFFA(); ! Put out -ACNT,,0
END; ! of COUNTARGS
GLOBAL ROUTINE OIFIW=
BEGIN
![1401] Created to support extended addressing
! Routine to turn a word into an IFIW and then output it via OBUFFA.
! Takes one implicit argument called PBOPWD which contains the word to
! be altered.
PBOPWD[OTSIFIW]=1; ! Make this an IFIW
OBUFFA() ! Put the word in the arg block buffer
END; ! of OIFIW
GLOBAL ROUTINE CGIOLARGS=
! Generates the arg blocks for an IOLIST. Called with the global
! TREEPTR pointing to the IOLIST.
BEGIN
OWN SAVTREEPTR;
! Walk thru all the elements on the IOLIST
UNTIL .TREEPTR EQL 0
DO
BEGIN
! Only generate arg blocks for nodes of OPRCLS IOLSCLS (ignore statement nodes)
IF .TREEPTR[OPRCLS] EQL IOLSCLS
THEN
BEGIN
![1035] Put out the -COUNT,,0 word for argument list
COUNTARGS(); ![1035]
%(***ASSOCIATE CURRENT LOC WITH THE LABEL ON THIS ARGBLOCK***)%
DEFLAB(.TREEPTR[IOLSTLBL]);
%(********GENERATE THE ARG BLOCK************************)%
CASE .TREEPTR[OPERSP] OF SET
%(***FOR DATACALL***)%
CGDCALL();
%(***FOR SLISTCALL***)%
CGSLIST();
%(***FOR IOLSTCALL***)%
BEGIN
%(***SAVE VAL OF TREEPTR***)%
SAVTREEPTR_.TREEPTR;
%(***WALK THRU THE ELEMENTS UNDER THIS NODE, GENERATING
ARG BLOCKS FOR THEM***)%
TREEPTR_.TREEPTR[IOLSTPTR];
UNTIL .TREEPTR EQL 0
DO
BEGIN
CASE .TREEPTR[OPERSP] OF SET
CGDCALL(); !FOR A DATACALL
CGSLIST(); !FOR AN SLIST
CGERR(); !IOLSTCALL IS ILLEGAL UNDER
! ANOTHER IOLSTCALL
CAE1LIST(); !E1LISTCALL NODE
CAE2LIST() !E2LISTCALL NODE
TES;
TREEPTR_.TREEPTR[CLINK];
END;
%(***RESTORE TREEPTR***)%
TREEPTR_.SAVTREEPTR;
END;
%(***FOR AN E1LISTCALL - OPTIMIZED CODE ONLY***)%
CAE1LIST();
%(***FOR AN E2LISTCALL - OPTIMIZED CODE ONLY***)%
CAE2LIST()
TES;
%(***IF THIS IS THE LAST ARG-BLOCK FOR THIS STMNT, GENERATE A FIN-BLOCK
AFTER IT; OTHERWISE GENERATE A ZERO-BLOCK AFTER IT***)%
PBOPWD_(IF .TREEPTR[CLINK] EQL 0 THEN OTSFINWD ELSE OTSZERWD);
PSYMPTR_PBF2NOSYM;
OBUFFA()
END;
%(***GO ON TO NEXT ELEMENT***)%
TREEPTR_.TREEPTR[CLINK];
END;
END; ! of CGIOLARGS
GLOBAL ROUTINE CGDCALL=
BEGIN
![1401] Rewritten to support extended addressing
! Generates an arg block for a DATACALL element in an IOLIST. Called
! with the global TREEPTR pointing to the DATACALL node for which the
! block is to be generated.
! !=========================================================================!
! !1!0! OTSDATA ! Type !I! Index ! Address !
! !=========================================================================!
PBOPWD=0; ! Init output word to 0
PBOPWD[OTSIDN]=OTSDATA; ! Set id field to indicate DATA
IOPTR(.TREEPTR[DCALLELEM]) ! Write out the right addr & relocation
END; ! of CGDCALL
GLOBAL ROUTINE CGSLIST=
BEGIN
![1401] Rewritten to support extended addressing
! Routine to generate an argument block for an SLIST call in an IOLIST.
! Called with the global TREEPTR pointing to the SLISTCALL node. This
! routine is used only for the SLISTs generated by phase 1 for
! statements of the form:
!
! READ 11,A
!
! where A is an array. Phase 2 skeleton recognizes IOLISTs that can be
! transformed into SLISTs and forms E1LISTCALL and E2LISTCALL nodes for
! these SLISTs (which may have more than one array and increments other
! than 1).
! !=========================================================================!
! !1!0! OTSSLIST ! Count !
! !-------------------------------------------------------------------------!
! !1!0! 0 ! 1 !
! !-------------------------------------------------------------------------!
! !1!0! 0 ! Type !I! Index ! Address !
! !=========================================================================!
! Output first word of argblock (contains code for SLIST and count)
PBOPWD=0; ! Init output word to 0
PBOPWD[OTSIDN]=OTSSLIST; ! Set IDN field to code for SLIST
%1507% IOPTR(.TREEPTR[SCALLCT]); ! Emit the count word
! Output the 2nd word of argblock (points to an increment of 1)
%1507% PBOPWD=0;
IOPTR(.ONEPLIT);
! Output the 3rd word (which contains a ptr to the array to be used)
PBOPWD=0;
IOPTR(.TREEPTR[SCALLELEM])
END; ! of CGSLIST
GLOBAL ROUTINE CAE1LIST=
BEGIN
! Generates code for an argblk for an E1LISTCALL node. The block
! consists of a count, an increment and a sequence of addresses of
! elements. Called with global TREEPTR pointing to E1LISTCALL node.
! !=========================================================================!
! !1!0! OTSNSLIST ! Count !
! !-------------------------------------------------------------------------!
! !1!0! 0 ! Increment !
! !=========================================================================!
! !1!0! 0 ! Type !I! Index ! Address !
! !-------------------------------------------------------------------------!
! \ \
! \ \
! \ \
! !=========================================================================!
REGISTER PEXPRNODE IOARRAY; ! Goes down the list of ELIST elements
! Output first word - contains "SLIST" and count
PBOPWD=0; ! Initialize word to 0
%1223% PBOPWD[OTSIDN]=(IF F77 ! Set ID field to proper SLIST
%2400% THEN OTSNSLIST77 ! New zero-trip
%2400% ELSE OTSNSLIST); ! New one-trip
%1507% IOPTR(.TREEPTR[ECNTPTR]); ! Fill in the count
! Output second word - contains increment
%1507% PBOPWD=0;
%1401% IOPTR(.TREEPTR[E1INCR]);
! Output one word for each ARRAYREF under ELSTPTR
IOARRAY=.TREEPTR[ELSTPTR]; ! Get the first
WHILE .IOARRAY NEQ 0 DO
BEGIN
PBOPWD=0; ! Clear target
IOPTR(.IOARRAY[E2ARREFPTR]); ! Generate argument
IOARRAY=.IOARRAY[CLINK] ! Go on to the next
END
END; ! of CAE1LIST
GLOBAL ROUTINE CAE2LIST=
BEGIN
! Routine to generate code for an argblk for an E2LISTCALL node. The
! block consists of a count and a sequence of pairs of increments and
! addresses of elements. Called with GLOBAL TREEPTR pointing to
! E2LISTCALL node.
! !=========================================================================!
! !1!0! OTSNELIST ! Count !
! !=========================================================================!
! !1!0! 0 ! Increment !
! !-------------------------------------------------------------------------!
! !1!0! 0 ! Type !I! Index ! Address !
! !-------------------------------------------------------------------------!
! \ \
! \ \
! \ \
! !=========================================================================!
REGISTER PEXPRNODE IOARRAY; ! Goes down the list of ELIST elements
! Output first word - contains "ELIST" and count
PBOPWD=0; ! Initialize word to 0
%1223% PBOPWD[OTSIDN]=(IF F77 ! Set ID field to proper ELIST
%2400% THEN OTSNELIST77 ! New zero-trip
%2400% ELSE OTSNELIST); ! New one-trip
%1507% IOPTR(.TREEPTR[ECNTPTR]); ! Fill in the count
! Output two words for each ARRAYREF under ELSTPTR
IOARRAY=.TREEPTR[ELSTPTR]; ! Get the first list entry
WHILE .IOARRAY NEQ 0 DO
BEGIN
! Output the word containing the increment
%1507% PBOPWD=0;
%1401% IOPTR(.IOARRAY[E2INCR]);
! Output the word containing the array address
PBOPWD=0; ! Clear target
IOPTR(.IOARRAY[E2ARREFPTR]); ! Generate argument
IOARRAY=.IOARRAY[CLINK] ! Get the next list entry
END
END; ! of CAE2LIST
GLOBAL ROUTINE CGSTPAUARGS=
BEGIN
! Routine to generate the arg block for a STOP/PAUSE statement. This
! block will have the form:
! ---------------------------------
! ! ARGCT ! 0 !
! ---------------------------------
!LABEL: ! !TYPE ! ! ARGPTR !
! ---------------------------------
! where LABEL is the arg-block label, ARGCT is the negative of the
! argument count and will always be -1 or 0, TYPE is the value type of
! the arg (LITERAL,OCTAL,INTEGER,REAL DOUBLE PREC, OR COMPLEX) and is in
! bits 9-12, and ARGPTR points to the arg this routine is called with.
! The global "CSTMNT" pointing to the STOP or PAUSE statement for which
! an arg-block is to be generated.
! If the STOP/PAUSE had no arg, will have used "ZERBLK" for the
! arg-block, so don't have to generate anything.
IF .CSTMNT[PAUSIDENT] EQL 0
THEN RETURN;
! If this statement was eliminated (by folding a logical IF), do not
! want to generate an arg list
IF .CSTMNT[PAUSLBL] EQL 0
THEN RETURN;
! Output the arg-count word
PSYMPTR_PBF2NOSYM;
PBOPWD_(-1)^18;
OBUFFA();
%(***ASSOCIATE THE LABEL FOR THIS ARG-LIST WITH THE 2ND WD***)%
DEFLAB(.CSTMNT[PAUSLBL]);
%(***OUTPUT THE PTR WD***)%
PSYMPTR_.CSTMNT[PAUSIDENT];
PBOPWD_0; !INIT WD TO BE OUTPUT TO 0
![1002] Choose arg type based on /GFLOATING
%1002% PBOPWD[OTSTYPE]_.EVALU[.PSYMPTR[VALTYPE]]; !SET TYPE FIELD OF WD
PBOPWD[OTSADDR]_.PSYMPTR[IDADDR]; ! Address of var, constant
! or literal to be output
%1401% OIFIW()
END; ! of CGSTPAUARGS
GLOBAL ROUTINE CGIOUNW=
BEGIN
!***************************************************************
! Generate code to call CHUNW. at the end of code generation for
! I/O, OPEN and CLOSE statements. Generate special error
! handling to UNWIND and JRST to the user END or ERR branch.
!***************************************************************
%1533% ! Written by TFV on 17-May-82
REGISTER
AFTERLAB, ! Label after the error handling code
ENDLAB, ! User specified END label
ERRLAB; ! User specified ERR label
IF .CSTMNT[IOIOSTAT] NEQ 0
THEN IF .CSTMNT[IOERR] EQL 0
THEN
BEGIN ! User specified IOSTAT but not ERR
! Make the argument list for the IN./OUT. call have ERR=CERR.
! After the last IOLST. or FIN. call generate:
!
! CERR: XMOVEI L,MARK
! PUSHJ P,CHUNW.
!
! If the user specified END=UEND, make the argument list for
! the IN./OUT. call have END=CEND and generate:
!
! JRST AFTER
! CEND: XMOVEI L,MARK
! PUSHJ P,CHUNW.
! JRST UEND
! AFTER:
! Generate an ERR label which is the same as the code to
! unwind at the end of the statement.
CSTMNT[IOERR] = GENLAB(); ! Generate an ERR branch
DEFLAB(.CSTMNT[IOERR]); ! Make it the current location
! Generate the CHUNW. call to unwind the dynamic
! concatenations under this statement
CGCHUNW(.CSTMNT[IOMARK]);
IF .CSTMNT[IOEND] NEQ 0
THEN
BEGIN ! Generate error handling code for END branch
! Create a label for location after error
! handling code
AFTERLAB = GENLAB();
JRSTGEN(.AFTERLAB); ! Generate JRST AFTERLAB
! Save the user's END label and replace it with
! a compiler generate label which points to the
! current location
ENDLAB = .CSTMNT[IOEND];
CSTMNT[IOEND] = GENLAB();
DEFLAB(.CSTMNT[IOEND]);
! Generate the CHUNW. call to unwind the
! dynamic concatenations under this statement
CGCHUNW(.CSTMNT[IOMARK]);
JRSTGEN(.ENDLAB); ! Generate JSRT ENDLAB
! Associate the current location with the label
! after the error handling code
DEFLAB(.AFTERLAB);
END; ! Generate error handling code for END branch
RETURN;
END; ! User specified IOSTAT but not ERR - generate ERR branch
! Generate the CHUNW. call to unwind the dynamic concatenations
! under this statement
CGCHUNW(.CSTMNT[IOMARK]);
IF .CSTMNT[IOEND] NEQ 0 OR .CSTMNT[IOERR] NEQ 0
THEN
BEGIN ! Generate error handling code for END or ERR
! After the last IOLST. or FIN. call generate:
!
! XMOVEI L,MARK
! PUSHJ P,CHUNW.
! JRST AFTER
!
! If the user specified END=UEND, make the argument list for
! the IN./OUT. call have END=CEND and generate:
!
! CEND: XMOVEI L,MARK
! PUSHJ P,CHUNW.
! JRST UEND
!
! If the user specified ERR=UERR, make the argument list for
! the IN./OUT. call have ERR=CERR and generate:
!
! CERR: XMOVEI L,MARK
! PUSHJ P,CHUNW.
! JRST UERR
!
! Finally define the label after:
!
! AFTER:
! Create a label for location after error handling code
AFTERLAB = GENLAB();
JRSTGEN(.AFTERLAB); ! Generate JRST AFTERLAB
IF .CSTMNT[IOEND] NEQ 0
THEN
BEGIN ! Generate error handling code for END branch
! Save the user's END label and replace it with
! a compiler generate label which points to the
! current location
ENDLAB = .CSTMNT[IOEND];
CSTMNT[IOEND] = GENLAB();
DEFLAB(.CSTMNT[IOEND]);
! Generate the CHUNW. call to unwind the
! dynamic concatenations under this statement
CGCHUNW(.CSTMNT[IOMARK]);
JRSTGEN(.ENDLAB); ! Generate JSRT ENDLAB
END; ! Generate error handling code for END branch
IF .CSTMNT[IOERR] NEQ 0
THEN
BEGIN ! Generate error handling code for ERR branch
! Save the user's ERR label and replace it with
! a compiler generate label which points to the
! current location
ERRLAB = .CSTMNT[IOERR];
CSTMNT[IOERR] = GENLAB();
DEFLAB(.CSTMNT[IOERR]);
! Generate the CHUNW. call to unwind the
! dynamic concatenations under this statement
CGCHUNW(.CSTMNT[IOMARK]);
! Generate JSRT ERRLAB
JRSTGEN(.ERRLAB);
END; ! Generate error handling code for ERR branch
! Associate the current location with the label after
! the error handling code
DEFLAB(.AFTERLAB);
END; ! Generate error handling code for END or ERR
END; ! of CGIOUNW
GLOBAL ROUTINE CGMTOP=
BEGIN
! Calls to MTOP for all statements BACKID thru ENDFID
CGUNIT(); !GENERATE CODE TO EVAL UNIT NUMBER (IF AN EXPRESSION)
%1123% CGIOSTAT(); ! Generate code for subscripted IOSTAT variables
!FILL IN IOARGLBL FIELD
A1LABEL_CSTMNT[IOARGLBL]_GENLAB();
OPDSPIX_OPGMTO;
CGOPGEN();
END; ! of CGMTOP
GLOBAL ROUTINE CGENCO=
BEGIN
!***************************************************************
! Code generation for ENCODE
!***************************************************************
%1533% ! If the FMT specifier or an iolist item is a dynamic
%1533% ! concatenation, generate a call to CHMRK.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGCHMRK(.CSTMNT[IOMARK]);
%1516% CGFMT(); ! Generate code to eval the format (if an expr)
%1123% CGIOSTAT(); ! Generate code for subscripted IOSTAT variables
! If the count field is an expression, evaluate it
TREEPTR_.CSTMNT[IOCNT];
CGETVAL();
%(***IF THE ENCODE VAR IS AN ARRAY-REF, GENERATE CODE FOR THE
SS CALCULATION***)%
TREEPTR_.CSTMNT[IOVAR];
CGETVAL();
!FILL IN IOARGLBL FIELD
A1LABEL_CSTMNT[IOARGLBL]_GENLAB();
OPDSPIX_OPGENC;
CGOPGEN();
![711] IF THE IOLIST IS NOT PRESENT, BE SURE TO PUT OUT A FIN CALL
![711] OTHERWISE ONE CAN END UP USING EXCESSIVE AMOUNTS OF CORE...
%[711]% IF .CSTMNT[IOLIST] EQL 0
%[711]% THEN (OPDSPIX_OPGFIN; CGOPGEN()) ! PUT OUT A FIN CALL
%[711]% ELSE CGIOLST();
%1533% ! If there are dynamic concatenations under this statement,
%1533% ! generate calls to CHUNW. and special error handling code for
%1533% ! END and ERR branches. If there is no unwinding to be done but
%1533% ! the user specified IOSTAT and not ERR, generate an ERR branch.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGIOUNW()
%1533% ELSE IF .CSTMNT[IOIOSTAT] NEQ 0
%1533% THEN IF .CSTMNT[IOERR] EQL 0
%1533% THEN
%1533% BEGIN ! User specified IOSTAT - generate an ERR branch
%1533% CSTMNT[IOERR] = GENLAB();
%1533% DEFLAB(.CSTMNT[IOERR]);
%1533% END; ! User specified IOSTAT - generate an ERR branch
END; ! of CGENCO
GLOBAL ROUTINE CGDECO=
BEGIN
!***************************************************************
! Generate code for decode
!***************************************************************
%1533% ! If the FMT specifier or an iolist item is a dynamic
%1533% ! concatenation, generate a call to CHMRK.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGCHMRK(.CSTMNT[IOMARK]);
%1516% CGFMT(); ! Generate code to eval the format (if an expr)
%1123% CGIOSTAT(); ! Generate code for subscripted IOSTAT variables
%(***IF THE COUNT FIELD IS AN EXPRESSION, EVALUATE IT***)%
TREEPTR_.CSTMNT[IOCNT];
CGETVAL();
%(***IF THE DECODE ARRAY IS AN ARRAYREF - CALCULATE THE
OFFSET***)%
TREEPTR_.CSTMNT[IOVAR];
CGETVAL();
!FILL IN IOARGLBL FIELD
A1LABEL_CSTMNT[IOARGLBL]_GENLAB();
OPDSPIX_OPGDEC;
CGOPGEN();
![711] IF THE IOLIST IS EMPTY, BE SURE TO PUT OUT A FIN CALL
%[711]% IF .CSTMNT[IOLIST] EQL 0
%[711]% THEN (OPDSPIX_OPGFIN; CGOPGEN()) ! PUT OUT A FIN CALL
%[711]% ELSE CGIOLST();
%1533% ! If there are dynamic concatenations under this statement,
%1533% ! generate calls to CHUNW. and special error handling code for
%1533% ! END and ERR branches. If there is no unwinding to be done but
%1533% ! the user specified IOSTAT and not ERR, generate an ERR branch.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGIOUNW()
%1533% ELSE IF .CSTMNT[IOIOSTAT] NEQ 0
%1533% THEN IF .CSTMNT[IOERR] EQL 0
%1533% THEN
%1533% BEGIN ! User specified IOSTAT - generate an ERR branch
%1533% CSTMNT[IOERR] = GENLAB();
%1533% DEFLAB(.CSTMNT[IOERR]);
%1533% END; ! User specified IOSTAT - generate an ERR branch
END; ! of CGDECO
GLOBAL ROUTINE CGRERE=
BEGIN
!***************************************************************
!CODE GENERATION FOR REREAD
!***************************************************************
%1533% ! If the FMT specifier or an iolist item is a dynamic
%1533% ! concatenation, generate a call to CHMRK.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGCHMRK(.CSTMNT[IOMARK]);
CGUNIT(); !GENERATE CODE TO EVAL THE UNIT NUMBER (IF AN EXPRESSION)
%1516% CGFMT(); ! Generate code to eval the format (if an expr)
%1123% CGIOSTAT(); ! Generate code for subscripted IOSTAT variables
!FILL IN IOARGLBL FIELD
A1LABEL_CSTMNT[IOARGLBL]_GENLAB();
OPDSPIX_OPGIN;
CGOPGEN();
IF .CSTMNT[IOLIST]EQL 0
THEN
BEGIN
%(***IF HAVE NO IOLIST GENERATE A CALL TO FIN***)%
OPDSPIX_OPGFIN;
CGOPGEN();
END
ELSE
CGIOLST();
%1533% ! If there are dynamic concatenations under this statement,
%1533% ! generate calls to CHUNW. and special error handling code for
%1533% ! END and ERR branches. If there is no unwinding to be done but
%1533% ! the user specified IOSTAT and not ERR, generate an ERR branch.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGIOUNW()
%1533% ELSE IF .CSTMNT[IOIOSTAT] NEQ 0
%1533% THEN IF .CSTMNT[IOERR] EQL 0
%1533% THEN
%1533% BEGIN ! User specified IOSTAT - generate an ERR branch
%1533% CSTMNT[IOERR] = GENLAB();
%1533% DEFLAB(.CSTMNT[IOERR]);
%1533% END; ! User specified IOSTAT - generate an ERR branch
END; ! of CGRERE
GLOBAL ROUTINE CGUNIT=
BEGIN
!***************************************************************
! Generate code to evaluate the unit number in an I/O statement.
! Called with CSTMNT pointing to an I/O statement.
!***************************************************************
%2201% ! only do UNIT= if specified
%2201% IF (TREEPTR = .CSTMNT[IOUNIT]) NEQ 0
%2201% THEN IF .TREEPTR[OPRCLS] NEQ DATAOPR
THEN CGETVAL()
END; ! of CGUNIT
GLOBAL ROUTINE CGFILE=
BEGIN
!***************************************************************
! Generate code to evaluate the unit number in an I/O statement.
! Called with CSTMNT pointing to an I/O statement.
!***************************************************************
%2201% ! Written by TFV on 30-Mar-83
! only do FILE= if specified
IF (TREEPTR = .CSTMNT[IOFILE]) NEQ 0
THEN IF .TREEPTR[OPRCLS] NEQ DATAOPR
THEN CGETVAL()
END; ! of CGFILE
GLOBAL ROUTINE CGFMT= ! [1516] New
%(***************************************************************************
GENERATE CODE TO EVALUATE THE FORMAT EXPRESSION IN AN IO STMNT
CALLED WITH CSTMNT POINTING TO AN IO STMNT
***************************************************************************)%
BEGIN
TREEPTR_.CSTMNT[IOFORM]; !PTR TO EXPRESSION NODE FOR FMT
IF .TREEPTR NEQ 0 ! IF FMT= WAS SPECIFIED
THEN IF EXTSIGN(.TREEPTR) NEQ -1 ! AND NOT FMT=*
THEN IF .TREEPTR[OPRCLS] NEQ DATAOPR ! AND FMT= IS A NONTRIVIAL EXPR
THEN CGETVAL() ! GENERATE CODE TO EVALUATE THE EXPR
END; ! CGFMT
GLOBAL ROUTINE CGRECNUM=
%(***************************************************************************
TO GENERATE THE CODE TO COMPUTE THE RECORD NUMBER FOR AN IO STMNT
THAT HAS AN EXPRESSION FOR A RECORD NUMBER (UGH!!!)
***************************************************************************)%
BEGIN
REGISTER PEXPRNODE RECNUM;
IF (RECNUM_.CSTMNT[IORECORD]) NEQ 0
THEN
BEGIN
IF .RECNUM[OPRCLS] NEQ DATAOPR
THEN
BEGIN
TREEPTR_.RECNUM;
CGETVAL()
END
END
END; ! of CGRECNUM
GLOBAL ROUTINE CGIOSTAT= %1123%
BEGIN ! Generate code to compute subscripts for an I/O statement that has
! an array reference for an IOSTAT specifier
REGISTER PEXPRNODE IOREF;
IOREF=.CSTMNT[IOIOSTAT];
IF .IOREF NEQ 0
THEN
BEGIN
TREEPTR_.IOREF;
CGETVAL()
END
END; ! of CGIOSTAT %1123%
GLOBAL ROUTINE CGREAD=
BEGIN
!***************************************************************
!CODE GENERATION FOR ALL TYPES OF READ
!***************************************************************
%1471% REGISTER BASE UNIT, BASE FORMAT;
%1533% ! If the FMT specifier or an iolist item is a dynamic
%1533% ! concatenation, generate a call to CHMRK.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGCHMRK(.CSTMNT[IOMARK]);
%1134% CGUNIT(); ! Generate code to eval the unit number (if an expr)
%1516% CGFMT(); ! Generate code to eval the format (if an expr)
%1134% CGRECNUM(); ! Generate code to eval the record number (if an expr)
%1123% CGIOSTAT(); ! Generate code to evaluate ARRAYREF subscripts, etc
A1LABEL_CSTMNT[IOARGLBL]_GENLAB(); ! Fill in IOARGLBL field
%1471% UNIT = .CSTMNT[IOUNIT];
%1471% FORMAT = .CSTMNT[IOFORM];
%1471% IF .UNIT[VALTYPE] EQL CHARACTER
%1471% THEN
%1471% BEGIN ! Internal file READ
%1471% IF .FORMAT EQL 0 THEN CGERR();
%1545% IF .FORMAT[OPR1] EQL VARFL
%1471% THEN IF .FORMAT[IDATTRIBUT(NAMNAM)] THEN CGERR();
%1471% OPDSPIX = OPGIFI;
%1471% CGOPGEN();
%1471% IF .CSTMNT[IOLIST] NEQ 0 THEN CGIOLST()
%1471% END ! of internal file READ
%1471% ELSE
%1471% BEGIN ! External file READ
!MAKE CGREAD AND CGWRIT SYMMETRICAL: DON'T MAKE A NAMELIST
! CHECK WITHOUT CHECKING FOR IONAME PTR = 0
IF .CSTMNT[IOLIST] EQL 0 ! NO IOLIST (BEWARE NAMELIST)
THEN
IF .FORMAT EQL 0 ! NO FORMAT
THEN BEGIN
OPDSPIX _ OPGRTB; ! UNFORMATTED READ
CGOPGEN ();
OPDSPIX _ OPGFIN; ! FIN CALL SINCE NO IOLIST
CGOPGEN ()
END
ELSE
%1545% IF .FORMAT [OPR1] EQL VARFL ! CHECK FOR NAMELIST
AND .FORMAT [IDATTRIBUT (NAMNAM)]
THEN BEGIN
OPDSPIX _ OPGNLI; ! NAMELIST READ
CGOPGEN ()
END
ELSE BEGIN
OPDSPIX _ OPGIN; ! FORMATTED READ
CGOPGEN ();
OPDSPIX _ OPGFIN; ! FIN CALL SINCE NO IOLIST
CGOPGEN ()
END
ELSE BEGIN ! THERE IS AN IOLIST
IF .FORMAT EQL 0 ! CHECK FOR FORMAT
THEN OPDSPIX _ OPGRTB ! UNFORMATTED READ
ELSE OPDSPIX _ OPGIN; ! FORMATTED READ
CGOPGEN ();
CGIOLST () ! PROCESS IOLIST
END
%1471% END; ! of external file READ
%1533% ! If there are dynamic concatenations under this statement,
%1533% ! generate calls to CHUNW. and special error handling code for
%1533% ! END and ERR branches. If there is no unwinding to be done but
%1533% ! the user specified IOSTAT and not ERR, generate an ERR branch.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGIOUNW()
%1533% ELSE IF .CSTMNT[IOIOSTAT] NEQ 0
%1533% THEN IF .CSTMNT[IOERR] EQL 0
%1533% THEN
%1533% BEGIN ! User specified IOSTAT - generate an ERR branch
%1533% CSTMNT[IOERR] = GENLAB();
%1533% DEFLAB(.CSTMNT[IOERR]);
%1533% END; ! User specified IOSTAT - generate an ERR branch
END; ! of CGREAD
GLOBAL ROUTINE CGWRIT=
BEGIN
!***************************************************************
! Code generation for WRITE statements of all forms
!***************************************************************
%1471% LOCAL BASE UNIT, BASE FORMAT;
%1533% ! If the FMT specifier or an iolist item is a dynamic
%1533% ! concatenation, generate a call to CHMRK.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGCHMRK(.CSTMNT[IOMARK]);
! Order things so that the call to CGREGNUM does not overwrite A1LABEL
! causing bad code fill in IOARGLBL field.
%1134% CGUNIT(); ! Generate code to eval the unit number (if an expr)
%1516% CGFMT(); ! Generate code to eval the format (if an expr)
%1134% CGRECNUM(); ! Generate code to eval the unit number (if an expr)
%1123% CGIOSTAT(); ! Generate code to evaluate ARRAYREF subscripts, etc
A1LABEL_CSTMNT[IOARGLBL]_GENLAB();
%1471% UNIT = .CSTMNT[IOUNIT];
%1471% FORMAT = .CSTMNT[IOFORM];
%1471% IF .UNIT[VALTYPE] EQL CHARACTER
%1471% THEN
%1471% BEGIN ! Internal file WRITE
%1471% IF .FORMAT EQL 0 THEN CGERR();
%1545% IF .FORMAT[OPR1] EQL VARFL
%1471% THEN IF .FORMAT[IDATTRIBUT(NAMNAM)] THEN CGERR();
%1471% OPDSPIX = OPGIFO;
%1471% CGOPGEN();
%1471% IF .CSTMNT[IOLIST] NEQ 0
%1471% THEN CGIOLST()
%1471% ELSE
%1471% BEGIN
%1471% OPDSPIX = OPGFIN;
%1471% CGOPGEN();
%1471% END;
%1471% END ! of internal file WRITE
%1471% ELSE
%1471% BEGIN ! External file WRITE
!MAKE CGREAD AND CGWRIT SYMMETRICAL: GENERATE A FIN CALL
! AFTER AN UNFORMATTED WRITE; REPLACE EDIT
IF .CSTMNT [IOLIST] EQL 0 ! NO IOLIST (BEWARE NAMELIST)
THEN
IF .FORMAT EQL 0 ! NO FORMAT
THEN BEGIN
OPDSPIX _ OPGWTB; ! UNFORMATTED WRITE
CGOPGEN ();
OPDSPIX _ OPGFIN; ! FIN CALL SINCE NO IOLIST
CGOPGEN ()
END
ELSE
%1545% IF .FORMAT [OPR1] EQL VARFL ! CHECK FOR NAMELIST
AND .FORMAT [IDATTRIBUT (NAMNAM)]
THEN BEGIN
OPDSPIX _ OPGNLO; ! NAMELIST WRITE
CGOPGEN ()
END
ELSE BEGIN
OPDSPIX _ OPGOUT; ! FORMATTED WRITE
CGOPGEN ();
OPDSPIX _ OPGFIN; ! FIN CALL SINCE NO IOLIST
CGOPGEN ()
END
ELSE BEGIN ! THERE IS AN IOLIST
IF .FORMAT EQL 0 ! CHECK FOR FORMAT
THEN OPDSPIX _ OPGWTB ! UNFORMATTED WRITE
ELSE OPDSPIX _ OPGOUT; ! FORMATTED WRITE
CGOPGEN ();
CGIOLST () ! PROCESS IOLIST
END
%1471% END; ! of external file WRITE
%1533% ! If there are dynamic concatenations under this statement,
%1533% ! generate calls to CHUNW. and special error handling code for
%1533% ! END and ERR branches. If there is no unwinding to be done but
%1533% ! the user specified IOSTAT and not ERR, generate an ERR branch.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGIOUNW()
%1533% ELSE IF .CSTMNT[IOIOSTAT] NEQ 0
%1533% THEN IF .CSTMNT[IOERR] EQL 0
%1533% THEN
%1533% BEGIN ! User specified IOSTAT - generate an ERR branch
%1533% CSTMNT[IOERR] = GENLAB();
%1533% DEFLAB(.CSTMNT[IOERR]);
%1533% END; ! User specified IOSTAT - generate an ERR branch
END; ! of CGWRIT
GLOBAL ROUTINE CGOPLST=
%(***************************************************************************
ROUTINE TO GENERATE CODE TO EVALUATE ANY EXPRESSIONS THAT
OCCUR AS VALS OF ARGS UNDER AN OPEN/CLOSE STMNT
***************************************************************************)%
BEGIN
REGISTER OPENLIST ARVALLST; ! List of args and their vals
CGUNIT(); ! Generate code for UNIT= that is an expression
%2201% CGFILE(); ! Generate code for FILE= that is an expression
%1123% CGIOSTAT(); ! Generate code for IOSTAT= arrayref
ARVALLST_.CSTMNT[OPLST];
INCR I FROM 0 TO (.CSTMNT[OPSIZ]-1) !LOOK AT EACH ARG
DO
BEGIN
TREEPTR_.ARVALLST[.I,OPENLPTR]; !PTR TO THE EXPRESSION NODE FOR THE VAL OF THIS ARG
IF .TREEPTR EQL 0 !FOR "DIALOG", CAN HAVE NULL VAL
THEN BEGIN END
ELSE
IF .TREEPTR[OPRCLS] NEQ DATAOPR THEN CGETVAL()
END
END; ! of CGOPLST
GLOBAL ROUTINE CGOPEN=
BEGIN
!***************************************************************
!CODE GENERATION FOR THE CALL TO OPEN.
!***************************************************************
%1533% ! If an argument is a dynamic concatenation, generate a call to
%1533% ! CHMRK.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGCHMRK(.CSTMNT[IOMARK]);
CGOPLST(); !GENERATE CODE TO EVAL ANY EXPRESSIONS THAT OCCUR AS VALS OF ARGS
!FILL IN IOARGLBL FIELD
A1LABEL_CSTMNT[IOARGLBL]_GENLAB();
OPDSPIX_OPGOPE;
CGOPGEN();
%1533% ! If there are dynamic concatenations under this statement,
%1533% ! generate calls to CHUNW. and special error handling code for
%1533% ! END and ERR branches. If there is no unwinding to be done but
%1533% ! the user specified IOSTAT and not ERR, generate an ERR branch.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGIOUNW()
%1533% ELSE IF .CSTMNT[IOIOSTAT] NEQ 0
%1533% THEN IF .CSTMNT[IOERR] EQL 0
%1533% THEN
%1533% BEGIN ! User specified IOSTAT - generate an ERR branch
%1533% CSTMNT[IOERR] = GENLAB();
%1533% DEFLAB(.CSTMNT[IOERR]);
%1533% END; ! User specified IOSTAT - generate an ERR branch
END; ! of CGOPEN
!GLOBAL ROUTINE CGRELS=
!BEGIN
! !CODE GENERATION FOR RELAEASE STATEMENT
!
! EXTERNAL OPGREL;
! !FILL IN IOARGLBL FIELD
!
! A1LABEL_CSTMNT[IOARGLBL]_GENLAB();
! OPDSPIX_OPGREL;
! CGOPGEN();
!
!END; ! of CGRELS
GLOBAL ROUTINE CGFIND=
BEGIN
! Code generation for FIND
%1134% CGUNIT(); ! Generate code for unit number
%1134% CGRECNUM(); ! Generate code for record number expressions
%1123% CGIOSTAT(); ! Generate code for subscripted IOSTAT variables
A1LABEL_CSTMNT[IOARGLBL]_GENLAB(); ! Fill in IOARGLBL field
OPDSPIX_OPGFND;
CGOPGEN()
END; ! of CGFIND
GLOBAL ROUTINE CGCLOS=
BEGIN
!***************************************************************
! CODE GENERATION FOR CLOSE STATEMENT
!***************************************************************
%1533% ! If an argument is a dynamic concatenation, generate a call to
%1533% ! CHMRK.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGCHMRK(.CSTMNT[IOMARK]);
CGOPLST(); !GENERATE CODE TO EVAL ANY EXPRESSIONS THAT OCCUR AS VALS OF ARGS
!FILL IN IOARGLBL FIELD
A1LABEL_CSTMNT[IOARGLBL]_GENLAB();
OPDSPIX_OPGCLO;
CGOPGEN();
%1533% ! If there are dynamic concatenations under this statement,
%1533% ! generate calls to CHUNW. and special error handling code for
%1533% ! END and ERR branches. If there is no unwinding to be done but
%1533% ! the user specified IOSTAT and not ERR, generate an ERR branch.
%1533% IF .CSTMNT[IOMARK] NEQ 0
%1533% THEN CGIOUNW()
%1533% ELSE IF .CSTMNT[IOIOSTAT] NEQ 0
%1533% THEN IF .CSTMNT[IOERR] EQL 0
%1533% THEN
%1533% BEGIN ! User specified IOSTAT - generate an ERR branch
%1533% CSTMNT[IOERR] = GENLAB();
%1533% DEFLAB(.CSTMNT[IOERR]);
%1533% END; ! User specified IOSTAT - generate an ERR branch
END; ! of CGCLOS
GLOBAL ROUTINE CGINQUIRE=
BEGIN
!***************************************************************
! CODE GENERATION FOR CLOSE STATEMENT
!***************************************************************
%2201% ! Written by TFV, on 30-Mar-83
! If an argument is a dynamic concatenation, generate a call to
! CHMRK.
IF .CSTMNT[IOMARK] NEQ 0
THEN CGCHMRK(.CSTMNT[IOMARK]);
! Generate code to eval any expressions that occur as vals of args
CGOPLST();
! fill in ioarglbl field
A1LABEL = CSTMNT[IOARGLBL] = GENLAB();
! Choose call to INQU. (by unit) or INQF. (by file)
IF .CSTMNT[IOUNIT] NEQ 0
THEN OPDSPIX = OPGINU ! INQUIRE by unit
ELSE OPDSPIX = OPGINF; ! INQUIRE by file
CGOPGEN();
! If there are dynamic concatenations under this statement,
! generate calls to CHUNW. and special error handling code for
! END and ERR branches. If there is no unwinding to be done but
! the user specified IOSTAT and not ERR, generate an ERR branch.
IF .CSTMNT[IOMARK] NEQ 0
THEN CGIOUNW()
ELSE IF .CSTMNT[IOIOSTAT] NEQ 0
THEN IF .CSTMNT[IOERR] EQL 0
THEN
BEGIN ! User specified IOSTAT - generate an ERR branch
CSTMNT[IOERR] = GENLAB();
DEFLAB(.CSTMNT[IOERR]);
END; ! User specified IOSTAT - generate an ERR branch
END; ! of CGINQUIRE
GLOBAL ROUTINE CGDECARGS=
BEGIN
! Generates the arg block for an ENCODE or DECODE statement. Arg block
! has the form:
! --------------------------------------------------
! ! -CT ! 0 !
! --------------------------------------------------
! LAB: ! 13 !TYPE !I! X ! CHAR CT !
! --------------------------------------------------
! ! 4 !TYPE !I! X ! END= !
! --------------------------------------------------
! ! 5 !TYPE !I! X ! ERR= !
! --------------------------------------------------
! ! 6 !TYPE !I! X ! IOSTAT= !
! --------------------------------------------------
! ! 2 !TYPE !I! X ! FORMAT ADDR !
! --------------------------------------------------
! ! 3 !TYPE !I! X ! FORMAT SIZE !
! --------------------------------------------------
! ! 12 !TYPE !I! X ! VAR ARRAY ADDR !
! --------------------------------------------------
! where the arglist ptr points to the word containing the char count.
! END/ERR/IOSTAT/FORMAT SIZE are optional ( 3 <= CT <= 7 ).
! Output word containing the count of words in the arglist
%[760]% PBOPWD=(-CNTKEYS())^18; ! Count in left half word
PSYMPTR=PBF2NOSYM;
OBUFFA();
! Associate the label on the arglist with this loc
DEFLAB(.CSTMNT[IOARGLBL]);
! Set up the count of chars to be processed in the 1st word of the arg block
![760] Set up keyword value
%[760]% PBOPWD=0; ! Clear word
%[760]% PBOPWD[OTSKEY]=OTSKEDSIZ; ! Output the char count
%2317% IOPTR(.CSTMNT[IOCNT]);
IOENDERR(); ! Output the END/ERR/IOSTAT args
IOFORMAT(); ! Output the FORMAT args
! Output a ptr to the array
![760] Set up keyword value
%[760]% PBOPWD=0; ! clear word
%[760]% PBOPWD[OTSKEY]=OTSKEDARR; ! output the array address
IOPTR(.CSTMNT[IOVAR])
END; ! of CGDECARGS
ROUTINE IO1ARG(NUMB)=
BEGIN
! Routine to output 2 words of the form:
! -------------------------------------------------
! ! -CT ! !
! -------------------------------------------------
! LAB: ! "UNIT"! TYPE !I! X ! UNIT #(Immediate) !
! -------------------------------------------------
%(***OUTPUT MINUS THE CT OF WDS IN THE ARG BLOCK***)%
PBOPWD_(-.NUMB)^18; !CT IN LEFT HALF WD
PSYMPTR_PBF2NOSYM;
OBUFFA();
! Associate the label on the arg block with this loc
DEFLAB(.CSTMNT[IOARGLBL]);
! Output an "immediate" mode arg for the unit
![760] Set up keyword value
%[760]% PBOPWD_0; ! clear word
%[760]% PBOPWD[OTSKEY]_OTSKUNIT; ! output the unit
IOIMMED(.CSTMNT[IOUNIT])
END; ! of IO1ARG
ROUTINE OPNFARGS=
BEGIN
%2201% ! rewritten by TFV, on 30-Mar-83
! Output first words of OPEN/CLOSE/INQUIRE arg block. Note that ERR and
! IOSTAT are optional. UNIT is required for OPEN and CLOSE while FILE
! is optional. For INQUIRE, one and only one of UNIT and FILE must be
! specified.
!
! -------------------------------------------------
! ! -CT ! !
! -------------------------------------------------
! LAB: ! 36 ! TYPE !I! X ! UNIT !
! -------------------------------------------------
! ! 6 ! TYPE !I! X ! FILE !
! -------------------------------------------------
! ! 37 ! TYPE !I! X ! ERR !
! -------------------------------------------------
! ! 21 ! TYPE !I! X ! IOSTAT !
! -------------------------------------------------
REGISTER CT;
! Output minus the count of words in the arg block
CT = .CSTMNT[OPSIZ]; ! Number of args on stack
IF .CSTMNT[IOUNIT] NEQ 0 THEN CT = .CT+1; ! Add in UNIT=
IF .CSTMNT[IOFILE] NEQ 0 THEN CT = .CT+1; ! Add in FILE=
IF .CSTMNT[IOERR] NEQ 0 THEN CT = .CT+1; ! Add in ERR=
IF .CSTMNT[IOIOSTAT] NEQ 0 THEN CT = .CT+1; ! Add in IOSTAT=
PBOPWD = (-.CT)^18; ! Count in left half word
PSYMPTR = PBF2NOSYM;
OBUFFA();
! Associate the label on the arg block with this loc
DEFLAB(.CSTMNT[IOARGLBL]);
IF .CSTMNT[IOUNIT] NEQ 0
THEN
BEGIN ! Output the UNIT= word if non zero - must be first arg
PBOPWD = 0; ! clear word
PBOPWD[OTSKEY] = OPNCUNIT; ! output the unit
IOPTR(.CSTMNT[IOUNIT]);
END; ! Output the UNIT= word if non zero - must be first arg
IF .CSTMNT[IOFILE] NEQ 0
THEN
BEGIN ! Output the FILE= word if non zero - must be first or second
PBOPWD = 0; ! clear word
PBOPWD[OTSKEY] = OPNCFILE; ! output the unit
IOPTR(.CSTMNT[IOFILE]);
END; ! Output the FILE= word if non zero - must be first or second
IF .CSTMNT[IOERR] NEQ 0
THEN
BEGIN ! Output the ERR= word if non zero
PBOPWD = 0; ! Clear the word
PBOPWD[OTSKEY] = OPNCERREQ; ! ERR=
PBOPWD[OTSTYPE] = ADDRTYPE; ! Type is "address"
PBOPWD[OTSADDR] = .CSTMNT[IOERR];
PSYMPTR = PBFLABREF; ! It's a statement label
%1401% OIFIW()
END; ! Output the ERR= word if non zero
IF .CSTMNT[IOIOSTAT] NEQ 0
THEN
BEGIN ! Output the IOSTAT= word if non zero
PBOPWD = 0; ! Clear the word
PBOPWD[OTSKEY] = OPNCIOSTAT; ! The IOSTAT= word
%1123% IOPTR(.CSTMNT[IOIOSTAT])
END; ! Output the IOSTAT= word if non zero
END; ! of OPNFARGS
GLOBAL ROUTINE CNTKEYS=
%(***********************
Count up the number of words in arg block to use for keywords.
Note that FMT= may use two words (address and optional size).
*************************)%
BEGIN
%1432% REGISTER COUNT, BASE FORMAT;
%[760]%
%[760]% COUNT=0;
%[760]%
%[760]% IF .CSTMNT[IOUNIT] NEQ 0 THEN COUNT=.COUNT+1;
%1432% IF .CSTMNT[IOFORM] NEQ 0 !If there is a format
%1432% THEN
%1432% BEGIN
%1625% IF EXTSIGN(.CSTMNT[IOFORM]) EQL -1
%1625% THEN COUNT = .COUNT + 1
%1625% ELSE
%1625% BEGIN
%1432% !(*** Get pointer to format statement. ***)
%1432% FORMAT = .CSTMNT[IOFORM];
%1432% ! Only an array used as a format has a format size word
%1432% IF .FORMAT[DATOPS1] EQL ARRAYNM1
%1432% THEN COUNT=.COUNT+2 ! address and size
%1432% ELSE COUNT=.COUNT+1; ! address only
%1432% END
%1625% END;
%[760]% IF .CSTMNT[IOEND] NEQ 0 THEN COUNT=.COUNT+1;
%[760]% IF .CSTMNT[IOERR] NEQ 0 THEN COUNT=.COUNT+1;
%[760]% IF .CSTMNT[IOIOSTAT] NEQ 0 THEN COUNT=.COUNT+1;
%[760]% IF .CSTMNT[IORECORD] NEQ 0 THEN COUNT=.COUNT+1;
%[760]%
%[760]% RETURN .COUNT;
END; ! of CNTKEYS
GLOBAL ROUTINE IOENDERR=
BEGIN
! Output the END=, ERR= and IOSTAT= words of an I/O arg block if
! nonzero. These words have the form:
! ---------------------------------------------------------
! ! 4 ! TYPE !I! X ! IOEND !
! ---------------------------------------------------------
! ! 5 ! TYPE !I! X ! IOERR !
! ---------------------------------------------------------
! ! 6 ! TYPE !I! X ! IOIOSTAT !
! ---------------------------------------------------------
! Output the END word if non zero
%[760]% IF .CSTMNT[IOEND] NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% PBOPWD=0;
%[760]% PBOPWD[OTSKEY]=OTSKEND;
%[760]% PBOPWD[OTSTYPE]=ADDRTYPE; !TYPE IS "ADDRESS"
%[760]% PBOPWD[OTSADDR]=.CSTMNT[IOEND];
%[760]% PSYMPTR=PBFLABREF;
%1401% OIFIW()
%[760]% END;
! Output the ERR= word if non zero
%[760]% IF .CSTMNT[IOERR] NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% PBOPWD=0;
%[760]% PBOPWD[OTSKEY]=OTSKERR;
%[760]% PBOPWD[OTSTYPE]=ADDRTYPE; !TYPE IS "ADDRESS"
%[760]% PBOPWD[OTSADDR]=.CSTMNT[IOERR];
%[760]% PSYMPTR=PBFLABREF;
%1401% OIFIW()
%[760]% END;
%[760]% ! Output the IOSTAT= word if non zero
%[760]% IF .CSTMNT[IOIOSTAT] NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% PBOPWD=0;
%[760]% PBOPWD[OTSKEY]=OTSKIOS;
%1123% IOPTR(.CSTMNT[IOIOSTAT])
%[760]% END
END; ! of IOENDERR
ROUTINE IOFORMAT=
! Routine to output the 1 or 2 FORMAT words of an I/O arg block. Format
! statements, integer vars, real vars, logical vars, and character vars
! used as a format have only a FORMAT ADDRESS word in an I/O argblock.
! Arrays used as formats have both a FORMAT ADDRESS word and a FORMAT
! SIZE word. These words have the form:
! !=========================================================================!
! !1!0! 2 ! TYPE !I! X ! Format address !
! !-------------------------------------------------------------------------!
! !1!0! 3 ! TYPE !I! X ! Format size !
! !=========================================================================!
BEGIN
REGISTER BASE FORMATP; ! Pointer to label or array
REGISTER BASE AUX; ! Pointer to stmnt or dim table entry
FORMATP=.CSTMNT[IOFORM]; ! I/O statement contains pointer to
! label table or variable
![760] Only output words if FORMAT exists
%[760]% IF .FORMATP EQL 0 THEN RETURN; ! Nothing to do
%1432% ! Set key field in FORMAT ADDRESS WORD to OTSKFMT.
%1432% PBOPWD = 0;
%1432% PBOPWD[OTSKEY]=OTSKFMT;
IF .FORMATP[OPRCLS] EQL LABOP
THEN
BEGIN
! If FORMAT is a stmnt - have a ptr to the label table
! entry for its label
AUX=.FORMATP[SNHDR];
! If the stmnt referenced is not a FORMAT stmnt, give
! an error message.
IF .AUX[SRCID] NEQ FORMID
THEN
BEGIN
FATLERR(.AUX[SRCISN],E91<0,0>);
RETURN
END;
! Output the FORMAT address word
PBOPWD[OTSADDR]=.AUX;
PBOPWD[OTSTYPE]=ADDRTYPE; ! Type field is address
! (Indicates that FORMAT
! is not an array)
PSYMPTR=PBFFORMAT;
%1401% OIFIW();
END
ELSE
IF .FORMATP[DATOPS1] EQL ARRAYNM1
THEN
BEGIN ! ARRAY
! Use IOPTR to output the FORMAT address word - if the
! array is a formal IOPTR will set the indirect bit
IOPTR(.FORMATP);
![2314] Output the FORMAT size word.
![760] Set up keyword value
%[760]% PBOPWD=0;
%[760]% PBOPWD[OTSKEY]=OTSKFSIZ;
! Get pointer to dimension table entry
AUX=.FORMATP[IDDIM];
%2314% IF .AUX[ADJDIMFLG] ! Adjustably dimensioned?
%2314% THEN IOPTR(.AUX[ARASIZ]) ! Yes, use .Q temp in ARASIZ
%2314% ELSE IOPTR(.AUX[ARACONSIZ]); ! No, use constant in ARACONSIZ
END ! ARRAY
%1516% ELSE
%1432% IF .FORMATP[VALTYPE] EQL CHARACTER
%1432% THEN !Format is a character expression
%1432% IOPTR(.FORMATP)
%1516% ELSE
%1432% IF .FORMATP[DATOPS1] EQL VARIABL1
%1432% THEN
%2003% BEGIN ! Format must be an integer, real, or logical var
%2003% IF .FORMATP[VALTYPE] EQL INTEGER
%2003% OR .FORMATP[VALTYPE] EQL REAL
%2003% OR .FORMATP[VALTYPE] EQL LOGICAL
%2003% THEN
%2003% BEGIN !Format is an integer, real, or logical var.
%1432% !Lie to FOROTS. Set indirect bit and type the
%1432% !format as an address (normal format stmt).
%1432% PBOPWD[OTSIND] = 1;
%1432% PBOPWD[OTSTYPE] = ADDRTYPE;
%2317% PBOPWD[OTSIFIW] = 1; ! Make this an IFIW
%2462% GENREF(.FORMATP,TRUE); ! Construct memory reference
! and buffer the argument word
%2003% END !Format is an integer, real, or logical var.
%1432% ELSE
%1516% CGERR() !Format is a variable, but not integer
%1432% END ! Format was an integer or character var
%1432% ELSE
%1516% CGERR() ! Format is none of label, array name, char expr, or int var
END; ! of IOFORMAT
GLOBAL ROUTINE IOPTR(EXPR)=
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! Generate an arg block entry for an expression node.
!
! FORMAL PARAMETERS:
!
! EXPR Points to expression node for argument.
!
! IMPLICIT INPUTS:
!
! EVALU Used to map PTR[VALTYPE] into argument type code.
!
! PBOPWD[OTSKEY] FOROTS argument keyword filled in by caller.
!
! IMPLICIT OUTPUTS:
!
! PBOPWD Destroyed.
!
! PBUFF Peephole buffer gets the finished arg block word.
!
! PSYMPTR Destroyed.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! Could flush the peephole buffer into the object and listing files.
!
!--
![1401] Reworked for extended addressing
! Output a word of the form:
!=========================================================================!
!1!0! FOROTS func ! Type !I! Index ! Address !
!=========================================================================!
! Note that the FOROTS function field (bits 2-8) are filled in by the caller
MAP BASE EXPR; ! Expression node to emit an arg for
%(***FILL IN TYPE-CODE FIELD OF WD TO BE OUTPUT***)%
![1002] Choose arg type based on /GFLOATING
%1002% PBOPWD[OTSTYPE] = .EVALU[.EXPR[VALTYPE]];
%2317% PBOPWD[OTSIFIW] = 1; ! Make this an IFIW
%2462% GENREF(.EXPR,TRUE); ! Generate the memory reference
! and buffer the argument word
END; ! of IOPTR
GLOBAL ROUTINE IOIMMED(EXPR)= ![1401] Reworked for extended addressing
%(***************************************************************************
Output an immediate mode FOROTS arg for the value of EXPR.
EXPR may be any integer expression.
Note that PBOPWD must be cleared and then PBOPWD[OTSKEY] must be
set by the caller
***************************************************************************)%
BEGIN
MAP PEXPRNODE EXPR;
![1471] This routine is called for somethings that can not be made into
![1471] immediate mode arguments for FOROTS. If this routine is called
![1471] with a EXPR that is not a constant, then it calls IOPTR to make
![1471] a normal non-immediate mode argument pointer. This edit moved
![1471] two consistency checks into the if statement that decides if the
![1471] EXPR is a constant. This allows UNIT=character to pass through.
! How the ptr is to be built depends on the operator of the expression
! If the expression is an integer constant
IF .EXPR[OPR1] EQL CONSTFL
THEN ! Put the constant directly in the arg list
BEGIN
%1471% ! If the arg is not type integer or if the arg already must
%1471% ! be referenced indirectly, then there is a compiler bug
%1471% IF .EXPR [VALTP1] NEQ INTEG1
%1471% THEN CGERR();
%1471% IF .EXPR[TARGIF] NEQ 0
%1471% THEN CGERR();
PBOPWD[OTSTYPE]_IMMEDTYPE; ! Immediate constant
PBOPWD[OTSADDR]_.EXPR[CONST2];
PSYMPTR_PBF2NOSYM;
OIFIW()
END
ELSE IOPTR(.EXPR)
END; ! of IOIMMED
ROUTINE CGOPARGS=
BEGIN
! Generate an OPEN type argument
LOCAL OPENLIST ARVALLST; ! List of args under this OPEN stmnt
LOCAL PEXPRNODE ARGVAL; ! Ptr to STE or constant table
! entry for the value to be passed
! to FOROTS for a given arg.
ARVALLST_.CSTMNT[OPLST];
! Walk thru the list of args, generating code for them
INCR I FROM 0 TO .CSTMNT[OPSIZ]-1 DO
BEGIN
PBOPWD_0;
PBOPWD[OPENGFIELD]_.ARVALLST[.I,OPENLCODE];
ARGVAL_.ARVALLST[.I,OPENLPTR]; ! EXPR node for val of this arg
IF .ARGVAL EQL 0 ! DIALOG can have a null value
THEN
BEGIN
PSYMPTR_PBFNOSYM;
PBOPWD[OTSADDR]_0;
%1401% OIFIW()
END
ELSE
BEGIN
! Set the indirect bit for an array reference as an associate variable
IF .PBOPWD[OPENGFIELD] EQL OPNCASSOCIATE
THEN IF .ARGVAL[OPRCLS] NEQ DATAOPR
AND .ARGVAL[OPRCLS] NEQ ARRAYREF
THEN PBOPWD[OTSIND]=1;
%1401% IOPTR(.ARGVAL)
END
END
END; ! of CGOPARGS
GLOBAL ROUTINE CGIOARGS=
BEGIN
! Code generation for argument blocks for I/O statements themselves. It
! is assumed that CSTMNT points to the statement. This implies that
! there is a driver routine that is following the linked list of I/O
! statements and calling this routine and then CGIOLARGS to generate the
! argument block for the I/O list.
MACRO
UTILLOW=BACKID$,
UTILHI=ENDFID$,
IOSRCIDBAS=READID$;
! To output a word for zeros. This word distinguishes binary WRITEs from
! list directed WRITEs (READs too).
! If this stmnt was removed from the program by P2SKEL, then IOARGLBL
! field will never have been filled in. Do not generate an arglist in
! this case.
! *****WARNING****
! Will have problems if IOARGLBL field is ever used for anything else
! and so is non-zero.
IF .CSTMNT[IOARGLBL] EQL 0 THEN RETURN;
IF .CSTMNT[SRCID] EQL OPENID OR
%2201% .CSTMNT[SRCID] EQL INQUID
THEN
BEGIN ! Special case OPEN and INQUIRE statements
%760% OPNFARGS(); ! Output the first args for OPEN/CLOSE
CGOPARGS(); ! Output the other arguments
RETURN ! Do not want to look at the IOLIST
END ! Special case OPEN and INQUIRE statements
ELSE
IF .CSTMNT[SRCID] GEQ UTILLOW AND .CSTMNT[SRCID] LEQ UTILHI
THEN
BEGIN ! MTOP.
%760% IO1ARG(CNTKEYS()+1); ! One extra for function code
IOENDERR();
! Output a word that contains a code indicating the function to be performed
PBOPWD_0;
![760] Set up keyword value
%[760]% PBOPWD[OTSKEY]_OTSKMTOP;
PBOPWD[OTSTYPE]_IMMEDTYPE;
PBOPWD[OTSADDR]_.MTOPFUN[.CSTMNT[SRCID]-UTILLOW];
PSYMPTR_PBF2NOSYM;
%1401% OIFIW();
END ! MTOP.
ELSE
BEGIN ! other I/O statements
CASE (.CSTMNT[SRCID]-IOSRCIDBAS) OF SET
%READID% REDORWRIT();
%WRITID% REDORWRIT();
%DECOID% CGDECARGS();
%ENCOID% CGDECARGS();
%REREDID% BEGIN
![760] Output first words of arg block
%[760]% IO1ARG(CNTKEYS());
IOENDERR();
IOFORMAT();
END;
%FINDID% BEGIN
![760] Output first words of arg block
![760] Set up keyword value
%[760]% IO1ARG(CNTKEYS());
%[760]% IOENDERR();
PBOPWD=0;
%[760]% PBOPWD[OTSKEY]_OTSKREC;
IOPTR(.CSTMNT[IORECORD])
END;
%CLOSID% BEGIN
![760] Output the first args for OPEN/CLOSE
%[760]% OPNFARGS();
CGOPARGS();
RETURN ! Do not want to look at the IOLIST
END;
%INPUID% BEGIN ! Not in release 1
END;
%OUTPID% BEGIN ! Not in release 1
END;
TES;
END; ! other I/O statements
IF .CSTMNT[IOLIST] NEQ 0 THEN
BEGIN
TREEPTR_.CSTMNT[IOLIST];
CGIOLARGS()
END
END; ! of CGIOARGS
GLOBAL ROUTINE REDORWRIT=
BEGIN
! Code generation for a READ or WRITE statement including all sizes,
! shapes, varieties and colors.
REGISTER BASE T1;
IF EXTSIGN(.CSTMNT[IOFORM]) EQL 0 THEN
BEGIN ! Binary I/O
![760] Output first words of arg block
%760% IO1ARG(CNTKEYS());
IOENDERR();
%(***BINARY WRITE WITH NO IOLIST IS ILLEGAL***)%
!IF .CSTMNT[IOLIST] EQL 0 AND .CSTMNT[SRCID] EQL WRITID
!THEN ERROUT(97);
END ELSE
IF EXTSIGN(.CSTMNT[IOFORM]) EQL -1 THEN
BEGIN ! List directed I/O
![760] Output first words of arg block
%760% IO1ARG(CNTKEYS());
IOENDERR();
![760] Set up keyword value
%760% PBOPWD=0;
%760% PBOPWD[OTSKEY]=OTSKFMT;
%760% PSYMPTR=PBF2NOSYM;
%1401% OIFIW();
END ELSE
BEGIN
T1=.CSTMNT[IONAME];
IF .T1[OPRCLS] EQL DATAOPR
%1516% AND .T1[OPERSP] NEQ CONSTANT
AND .T1[IDATTRIBUT(NAMNAM)]
THEN
BEGIN ! NAMELIST I/O
%1435% ! CNTKEYS knows FMT=NAMELIST generates only
%1435% ! one word in the FOROTS argblock
%1435% IO1ARG(CNTKEYS());
IOENDERR(); ! Handle END=, ERR= and IOSTAT=
! Make a label for the NAMELIST arg block and tuck it away in the
! IDCOMMON field of the symbol table. Make it only if there isn't
! already one there.
IF .T1[IDCOMMON] EQL 0 THEN
T1[IDCOMMON]=GENLAB();
PSYMPTR=PBFLABREF;
PBOPWD=.T1[IDCOMMON];
PBOPWD[OTSKEY]=OTSKNAME;
%1574% PBOPWD[OTSTYPE]=ADDRTYPE;
%1401% OIFIW()
END
ELSE
BEGIN ! Formatted READ
IO1ARG(CNTKEYS());
IOENDERR();
IOFORMAT()
END
END;
IF .CSTMNT[IORECORD] NEQ 0 THEN
BEGIN
! Since IORECORD is non-zero, there is either a REC=
! record specifier for random access external I/O or
! a character count for a multi-record internal file.
! See if the UNIT is character to determine which
! FOROTS key to generate.
%1471% PBOPWD = 0;
%1472% PBOPWD[OTSKEY] = OTSKREC; ! Assume external file
%1471% T1 = .CSTMNT[IOUNIT];
%1471% IF .T1[OPERATOR] EQL OPERC(CHARACTER,DATAOPR,ARRAYNAME)
%1471% OR .T1[OPERATOR] EQL OPERC(CHARACTER,DATAOPR,FORMLARRAY)
%1472% THEN PBOPWD[OTSKEY] = OTSKEDSIZ; ! Nope, internal file
%760% IOPTR(.CSTMNT[IORECORD])
END
END; ! of REDORWRIT
GLOBAL ROUTINE NAMGEN= ![1502] Reworked by AHM
BEGIN ! Generate NAMELIST blocks for FOROTS
OWN BASE
MRNAMPTR: ! Master NAMELIST pointer
NAMLENTRY; ! Pointer to each NAMELIST entry
REGISTER BASE
PTR: ! Points to various things
DMETRY; ! Pointer to dimension table entry
MRNAMPTR=.NAMLPTR<LEFT>; ! Get pointer to first NAMELIST block
WHILE .MRNAMPTR NEQ 0 ! Loop over all of them
DO ! in order to output them
BEGIN
! If this NAMELIST is never referenced in the program, then no label
! will have been associated with it. If so do not generate it. Note
! that the "IDCOMMON" field is used to hold the label of a NAMELIST.
PTR=.MRNAMPTR[NAMLID]; ! Point to the STE for the NAMLIST
IF .PTR[IDCOMMON] NEQ 0 ! Is there a label ?
THEN ! Yes
BEGIN
DEFLAB(.PTR[IDCOMMON]); ! Define the arg block label
! that was stored in the
! IDCOMMON field of the
! NAMELIST name by REDORWRIT
! NAMELIST block
! !=========================================================================!
! ! NAMELIST name in SIXBIT !
! !=========================================================================!
! ! First NAMELIST entry !
! !-------------------------------------------------------------------------!
! \ \
! \ More NAMELIST entries \
! \ \
! !=========================================================================!
! ! 4000,,0 (FOROTS FIN. word) !
! !=========================================================================!
PBOPWD=.PTR[IDSYMBOL]; ! Get the SIXBIT symbol name
PSYMPTR=PBF2NOSYM; ! Don't relocate it
OBUFFA(); ! Output it
INCR I FROM 0 TO .MRNAMPTR[NAMCNT]-1
DO ! Now each entry in the NAMELIST
BEGIN
! Point to a NAMELIST entry
NAMLENTRY=@(.MRNAMPTR[NAMLIST]+.I);
PBOPWD=.NAMLENTRY[IDSYMBOL]; ! Get var name
PSYMPTR=PBF2NOSYM; ! Don't relocate it
OBUFFA(); ! Output it
PBOPWD=0; ! Clear the output buffer word
IF .NAMLENTRY[OPERSP] EQL ARRAYNAME
THEN
BEGIN ! Output ARRAYNAME entry
! Array NAMELIST block entry
! !=========================================================================!
! !1!0! Dim count ! Type !I! X ! Array base !
! !-------------------------------------------------------------------------!
! ! Array size in items !
! !-------------------------------------------------------------------------!
! ! Offset in words !
! !=========================================================================!
! ! First array factor !
! !-------------------------------------------------------------------------!
! \ \
! \ More factors \
! \ \
! !=========================================================================!
DMETRY=.NAMLENTRY [IDDIM]; ! Point to dimension table
PBOPWD[OTSCNT]=.DMETRY[DIMNUM]; ! Set the number of dimensions
IOPTR (.NAMLENTRY); ! Output the array base word
! Get array size in items (ARASIZ field is in words or bytes). Note
! that adjustably dimensioned arrays are illegal in NAMELISTS.
%1502% IF .NAMLENTRY[VALTYPE] EQL CHARACTER
%1502% THEN IF .NAMLENTRY[IDCHLEN] EQL LENSTAR
%1502% THEN CGERR()
%1502% ELSE PBOPWD=.DMETRY[ARASIZ]/.NAMLENTRY[IDCHLEN]
%1502% ELSE PBOPWD=(IF .NAMLENTRY[DBLFLG]
THEN .DMETRY[ARASIZ]/2
ELSE .DMETRY[ARASIZ]);
%1502% PSYMPTR=PBF2NOSYM; ! Don't relocate this word
%1502% OBUFFA(); ! Output the word
PTR=.DMETRY[ARAOFFSET]; ! Point to the constant entry
! for the offset
! Compiler adds the offset - FOROTS subtracts it. Therefore we must
! pass FOROTS the negative of the offset used by the compiler
IF .PTR[OPR1] EQL CONSTFL
%1502% THEN PBOPWD=-.PTR[CONST2]
ELSE CGERR(); !(ADJUSTABLY DIM ARRAY ILLEGAL)
OBUFFA(); ! Output the word (also not relocated)
! Now for the factors
PSYMPTR=PBF2NOSYM; ! Factors aren't relocatable
INCR K FROM 1 TO .DMETRY[DIMNUM] ! Loop over all the factors
DO
BEGIN
PTR=.DMETRY[DFACTOR ((.K-1))]; ! Point to the constant table entry
IF .PTR [OPR1] EQL CONSTFL ! Consistancy check
THEN ! OK (must be constant)
BEGIN ! Get factor in items or bytes (not words)
%1502% IF .NAMLENTRY[VALTYPE] EQL CHARACTER
%1502% THEN IF .NAMLENTRY[IDCHLEN] EQL LENSTAR
%1502% THEN CGERR()
%1502% ELSE PBOPWD=.PTR[CONST2]
%1502% ELSE PBOPWD=(IF .NAMLENTRY[DBLFLG]
THEN .PTR[CONST2]/2
ELSE .PTR[CONST2]);
OBUFFA() ! Output the factor
END
ELSE CGERR() ! Factor must be a constant
END ! of factor output
END ! of array output
ELSE ! We have a scalar
IOPTR(.NAMLENTRY); ! Output the scalar
! Scalar NAMELIST block entry
! !=========================================================================!
! !1!0! 0 ! Type !I! X ! Address of scalar !
! !=========================================================================!
END; ! of INCR loop on entries in NAMELIST
PBOPWD=OTSFINWD; ! FIN. terminating word
PSYMPTR=PBF2NOSYM; ! Don't relocate it
OBUFFA(); ! Output the word
END; ! of the IF for nonzero label
MRNAMPTR=.MRNAMPTR[NAMLINK]; ! Go on to the next NAMELIST
END; ! of WHILE loop over NAMELISTs
END; ! of NAMGEN
END
ELUDOM