Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_Alpha_31-jul-86
-
cgdo.bli
There are 12 other files named cgdo.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1986
!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 NORMA ABEL/HPW/MD/DCE/SJW/RDH/TFV/CKS/AHM/CDM/RVM/TJK/MEM
MODULE CGDO(RESERVE(0,1,2,3),SREG=#17,VREG=#15,FREG=#16,DREGS=4)=
BEGIN
GLOBAL BIND CGDOV = #11^24 + 0^18 + #4532; ! Version Date: 19-Feb-86
%(
***** Begin Revision History *****
119 ----- ----- MAKE ARGGEN A GLOBAL ROUTINE
120 ----- ----- IN "CGRETURN", WHEN LOOK FOR NEXT STMNT AFTER
THE RETURN EQUAL TO END, SKIP OVER AN INTERVENING CONTINUE
121 ----- ----- IN "CGRETURN", WHEN CHECKING THE SRCID OF NXTSTMNT,
MUST FIRST CHECK THE NXTSTMNT NEQ 0
122 ----- ----- IN "CGRETURN", GENERATE A RETURN WHEN THERE
ARE LABEL ARGUMENTS IN ALL CASES
123 ----- ----- FIX ARGGEN TO PERMIT MULTIPLE LEVEL PASSING
OF SUBPROGRAM NAMES
124 ----- ----- FIX 123 (I HOPE)
125 ----- ----- CHANGE REFERENCES TO PROEPITYP
126 ----- ----- PUT OUT TYPE CODE WITH LABEL ARGUMENTS
127 ----- ----- GIVE ERROR MESSAGES FOR MULTIPLE RETURN
WHEN THERE WERE NO LABEL PARAMS; AND
FOR VALUE OF A FN NEVER DEFINED
128 ----- ----- MESSAGE FOR VAL OF FN UNDEFINED SHOULD NOT
BE GIVEN FOR A STMNT FN
129 ----- ----- MACRO SET1ZGEN MISSPELLED IN CGRETURN
130 ----- ----- FIX CALLS TO FATLERR TO INCLUDE .ISN
131 ----- ----- WHEN /DEB:TRACE WAS SPECIFIED, FOR STMNT FNS
AND ENTRIES THE XCT FDDT. MUST BE GENERATED AFTER
THE ENTRY NAME IS DEFINED.
132 ----- ----- IN "CGPROEPI", SHOULD CLEAR PBFISN FIELD
BEFORE OUTPUT SIXBIT FOR ENTRY NAME; SET
IT TO THE STMNT ISN BEFORE THE 1ST INSTRUCTION
133 ----- ----- GENERATE COMMON SUBS ON DO STMNTS
134 256 15493 DO NOT LOOK FOR LABEL DUMMIES IN STATEMENT FUNCTIONS,
(JNT)
135 323 16729 USE .A00NN FOR NAME OF TEMPORARY USED TO SAVE
REGISTERS IN PROLOGUE OF A FUNCTION, (MD)
136 360 18243 FIX RETURN BEFORE CONTINUE, END STMNTS, (DCE)
***** Begin Version 5A *****
137 607 22685 SET GLOBAL FLAG NEDZER IN CGSBPRGM TO INDICATE
ZERO-ARG-BLOCK NEEDED
140 613 QA2114 IGNORE INDIRECT BIT IN FORMAL FUNCTION TARGET
ON ENTRY PROLOGUE, (SJW)
***** Begin Version 5B *****
141 674 11803 TEST FOR DOSTAK OVERFLOW AND GIVE ERROR MSG, (DCE)
142 677 25573 GENERATE CODE TO CHECK FOR CORRECT
NUMBER OF PARAMETERS IF DEBUG:PARAM SET, (DCE)
***** Begin Version 6 *****
143 750 TFV 1-Jan-80 ------
remove Debug:parameters (edit 677)
144 761 TFV 1-Mar-80 -----
Remove KA10FLG and add in /GFLOATING
145 1002 TFV 1-Jul-80 ------
MAP EVALU onto EVALTAB to get the argtype for argblock entries
***** Begin Version 7 *****
146 1206 DCE 20-Mar-81 -----
For real DO loops, put out potential jump around (zero trip F77)
together with a label for it, and be sure to make "final" loop value
available at end of loop.
147 1227 CKS 22-Jun-81
Use CONST2L instead of CW4L to access LH of constant AOBJN pointer.
148 1253 CKS 11-Aug-81
When ARGGEN is doing a character arrayref node, point symbol table
pointer at the .Q temp (from TARGADDR) not the array name
(from ARG1PTR).
149 1266 TFV 5-Oct-81 ------
Add code to copy 1 or 2 words of descriptor for character formal
at subroutine entrance. Don't copy it back on subroutine exit.
Fix up lots of code and comments to look nice.
150 1276 DCE 21-Oct-81 -----
Only materialize loop variable at normal exit if /F77 given.
151 1400 CKS 21-Oct-81
In CGSBPRGM, check for function call with zero arguments and use ZERBLK
152 1401 AHM 2-Oct-81
Make ARGGEN emit arg block entries that are IFIWs. Do the same
in CGPROEPI for the vector of addresses that point into a
subroutine's arg block used for multiple returns. Delete a
macro that fudged over misspellings of ENTLIST in CGPROEPI.
Rework and pretty up ARGGEN and CGARGS. Put form feeds between
all routines in this module.
153 1422 TFV 12-Nov-81 ------
Fix CGEPILOGUE to handle character functions. The result of
character functions is not returned in AC0, AC1. Instead the
first argument has the descriptor for the result.
154 1437 CDM 16-Dec-81 ------
Save address call in CGARGS to a subprogram for argument checking
processing.
155 1455 TFV 5-Jan-82 ------
Modify CGSFN for character statement function. A statement
function is turned into either a call to CHSFN. (the subroutine
form of CHASN.) or a call to CHSFC. (the subroutine form of
CONCA.). CHSFC. is used if the character expression has
concatenations at its top level, CHSFN. is used for all other
character expressions. Modify CGSBPRGM so it doesn't set the
indirect bit for character statement function names.
156 1466 CDM 2-Feb-82
Modified CGARGS to allow zero argument blocks to be allocated if
/DEBUG:ARGUMENTS is specified.
1505 AHM 9-Mar-82
Set the IDPSECT field in symbol table enties for .A00nn temps
to .DATA. Also optimize macro TNAME by removing a LSH and two
adds.
1524 RVM 31-Mar-82
Don't turn on the indirect bit of an argument block entry for
an argument of type dummy character function.
1526 AHM 27-Apr-82
Don't subtract HIORIGIN from the address of subroutine calls
when saving them for argument checking in CGARGS, since we now
never add it in in the first place.
1533 TFV 17-May-82
Modify CGSBPRGM for dynamic concatenations. Call CHMRK. before
the subprogram call and call CHUNW. after. If there are
multiple returns, generate error handling code to do the CHUNW.
call and then JRST to the user label.
1562 TFV 18-Jun-82
Fix CGSBPRGM to only check ARGMARK if there is an argument list.
1613 CDM 13-Aug-82
Change /DEBUG:PARAMETERS to /DEBUG:ARGUMENTS.
***** Begin Version 10 *****
2245 CDM 18-Dec-83
Improve argument checking. Subroutine calls with no arguments
would not output argument checking (1120) rel blocks for Link
unless /DEBUG:ARGUMENTS was given. Now always output the the
rel block, and change the call to the subroutine not to have its
own unique argument block of 0, but instead use the shared
ZERBLK which everyone else with no arguments shares. This
simplifies code in several places.
Delete unneeded local variable ARGFLG in CGSBPRGM. Code becomes
much simpler without it.
2313 TJK 21-Feb-84
Rewrite CGRETURN. This routine had a number of problems
including inefficiency within the routine itself, incorrect
code produced for alternate returns using array references,
and pessimal code produced for some cases. Added a routine
header. Removed macro MOV1GEN. Commented out code pattern
MOVRET. Added entry point for code pattern OPGZER.
2317 AHM 4-Mar-84
Make ARGGEN use GENREF to construct memory references instead
of doing it itself. Remove code in CGPROEPI which believed
that formal array STEs had an indirect bit set in IDADDR.
2462 AHM 2-Oct-84
Use execrable TRUE/FALSE/TRUTH/FALSITY miasma for boolean in
call to GENREF to satisfy programming conventions.
***** End V10 Development *****
2541 MEM 1-Aug-85
When the loop count can stay in a register, but the induction
variable must be materialized (MATRLZIXONLY bit is set), make
sure induction variable is updated after exiting the loop.
2563 MEM 17-Dec-85
When a subprogram has a subprogram name as a formal parameter, the
the indirect bit is set in the STE for the subprogram name after the
address of the subprogram has been moved into the dummy argument.
However, if this subprogram has an entry statement (also passing the
subprogram name as a parameter) the indirect bit in the STE must be
ignored when moving the address of the subprogram into the dummy
argument.
***** End Revision History *****
***** Begin Version 11 *****
4515 CDM 20-Sep-85
Phase I for VMS long symbols. Create routine ONEWPTR for Sixbit
symbols. For now, return what is passed it. For phase II, return
[1,,pointer to symbol].
4527 CDM 1-Jan-86
VMS Long symbols phase II. Convert all internal symbols from
one word of Sixbit to [length,,pointer].
4532 MEM 19-Feb-86
Add long symbol support: Preceding each function/subroutine we want
a pointer to a sixbitz name instead of the name. When outputting arg
blocks, check if we have an arg block for a call to PROSB. If we do
then change the fifth argument to an address where the long name is.
This fifth argument is currently a constant table entry containing
the cnt,,ptr to name.
ENDV11
)%
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE REQREL.BLI; ;[4532]
SWITCHES LIST;
! Below is for RUNOFF in generating .PLM files
!++
!.LITERAL
!--
OWN
JUMPABOUT,
JMPVECT,
LABARGCT,
JMPSFN,
%1505% BASE EPILAB; ! Holds pointer to labels of epilogue code and
! STE of temp that holds the address of the
! proper epilogue at runtime
FORWARD
CGDOLOOP,
CGDOEND(1),
CGPROEPI ,
CGEPILOGUE(1),
CGRETURN(1),
CGSFN,
CGSBPRGM(2), ! Generate code for a subroutine call
ARGGEN(1),
CGARGS,
%4532% PROSBARGLIST; !Generate arg list for PROSB.
EXTERNAL
A1LABEL,
%2313% BASE A1NODE, ! Points to first argument of expression
A2LABEL,
ARGLINKPT, ! Points to linked list of arg blocks
%761% CALLER,
CGASMNT,
%1533% CGCHMRK, ! Generate code for a CHMRK. call
%1533% CGCHUNW, ! Generate code for a CHUNW. call
CGCMNSUB, ! Generate code for common subs
%2313% CGEND, ! Generate code for END statement
CGERR,
CGETVAL,
CGOPGEN, ! Code generation routine
CLOBBREGS,
%2313% BASE CSTMNT, ! Points to current statement
DEFLAB, ! Defines a label
%674% DOSTAK,
%2313% E130, ! Error for alternate RETURN with no dummy labels
E131,
%674% E144, ! Error message declarations
%1002% EVALTAB EVALU, ! Maps internal type codes to external
FATLERR,
GENLAB,
%2317% GENREF, ! Constructs memory references
LASTONE,
NEDZER, ! Flag to indicate if zero-arg-block needed
%1533% OBUFF,
OBUFFA, ! Outputs a word
%1401% OIFIW, ! Makes the word in PBOPWD into an IFIW
! and writes it out with OBUFFA
%4515% ONEWPTR, ! Returns [1,,pointer] from sixbit argument
OPDSPIX,
%2313% OPGETI, ! OPGEN table entry for "get in register"
OPGSFN,
%761% OPGSTI,
%2313% OPGZER, ! OPGEN table entry for setting an AC to zero
%2317% OBJECTCODE PBOPWD, ! Holds data word to output
PROGNAME,
PSYMPTR, ! Holds relocation info for OBUFFA
%761% REGFORCOMP,
%761% TBLSEARCH,
%2313% BASE TREEPTR, ! Points to current expression
ZERBLK;
GLOBAL ROUTINE CGDOLOOP=
BEGIN
! Code generator drivers for DO loops
%1206% EXTERNAL DOZJMP,A1LABEL;
EXTERNAL TREEPTR,A1NODE,A2NODE,REGFORCOMP,CSTMNT;
EXTERNAL DOSTI;
%761% EXTERNAL CGETVAL,OPGETI,DOSP,OPGSTI,DOSTC;
MAP BASE DOSP:A1NODE:CSTMNT:TREEPTR;
OWN PEXPRNODE DOCEXPR; ! Ptr to expression for control wd
LOCAL CTLREG, ! Control word register
IVALREG; ! Initial value register
IF .CSTMNT[SRCCOMNSUB] NEQ 0 ! Gen code for any common subs
THEN CGCMNSUB();
CTLREG = .CSTMNT[DOCREG]^23; ! Set up local values
IVALREG = .CSTMNT[DOIREG]^23;
! Get the val of the control expression into the loop ctl reg
DOCEXPR = .CSTMNT[DOLPCTL];
A1NODE = .DOCEXPR;
! If the ctl expr needs to be evaluated at run time, generate code to evaluate it
IF .DOCEXPR[OPRCLS] NEQ DATAOPR
THEN
BEGIN
TREEPTR = .DOCEXPR;
CGETVAL();
END;
! Get the value of the ctl expression into the loop ctl reg
IF NOT .CSTMNT[CTLSAMEFLG]
THEN
BEGIN
REGFORCOMP = .CTLREG;
A1NODE = .DOCEXPR;
IF .CSTMNT[FLCWD] ! If the ctl is in an AOBJN wd
%761% THEN OPDSPIX = OPGETI
ELSE OPDSPIX = DOGETAOPIX(.CSTMNT[CTLIMMED], .A1NODE[VALTP1],.CSTMNT[CTLNEG]);
CGOPGEN();
END;
! Control word is now in a register
! Get the initial value in one if necessary
IF NOT .CSTMNT[FLCWD] THEN
BEGIN
REGFORCOMP = .IVALREG;
A1NODE = .CSTMNT[DOM1]; ! Initial value
! If the initial val is not in the reg for the DO index, put it there
IF .A1NODE[OPRCLS] EQL REGCONTENTS
AND .A1NODE[TARGTAC] EQL .CSTMNT[DOIREG]
THEN
BEGIN END
ELSE
BEGIN
IF .CSTMNT[INITLIMMED]
THEN OPDSPIX = DOGETAOPIX(1,.A1NODE[VALTP1],.CSTMNT[INITLNEG])
ELSE OPDSPIX = DOGETAOPIX(0,.A1NODE[VALTP1],.CSTMNT[INITLNEG]);
CGOPGEN();
END
END;
! If this loop must have its count-ctl var materialized, generate code
! to store the count
IF .CSTMNT[NEDSMATRLZ] OR .CSTMNT[MATRLZCTLONLY]
THEN
BEGIN
! Generate code to store the count
A1NODE = .CSTMNT[DOCTLVAR];
REGFORCOMP = .CTLREG;
OPDSPIX = DOSTC + .CSTMNT[FLCWD];
CGOPGEN();
END;
%1206% ! If this is a potential zero trip loop, we need a label to
%1206% ! jump to at the end of the loop...
%1206% ! Also code to jump around the loop if appropriate.
%1206% IF F77 THEN
%1206% IF .CSTMNT[MAYBEZTRIP] NEQ 0 THEN
%1206% BEGIN
%1206% EXTERNAL PBOPWD,PSYMPTR,OBUFF;
%1206% CSTMNT[DOZTRLABEL] = A1LABEL = GENLAB();
%1206% REGFORCOMP = .CTLREG;
%1206% IF .CSTMNT[FLCWD] AND NOT .CSTMNT[NEDSMATRLZ] ! Trip count constant
%1227% AND .DOCEXPR[CONST2L] EQL 0 ! Trip count zero
%1206% THEN JRSTGEN(.A1LABEL) ! Too late to delete the loop,
%1206% ! but we can still jump around it!
%1206% ELSE
%1206% BEGIN ! Put out a JUMPGE on negative count
%1206% OPDSPIX = DOZJMP;
%1206% CGOPGEN()
%1206% END
%1206% END;
! If this loop must have its index materialized, generate code to store the index
IF .CSTMNT[NEDSMATRLZ] OR .CSTMNT[MATRLZIXONLY]
THEN
BEGIN
! Generate the materialization label
DOSP[LEFTP] = GENLAB();
DEFLAB(.DOSP[LEFTP]);
! Now store initial value using opgnta tables to get
! double precision unless its an HRRM
IF .CSTMNT[FLCWD] THEN
BEGIN
A1NODE = .CSTMNT[DOSYM]; ! Induction variable
REGFORCOMP = .CTLREG;
OPDSPIX = DOSTI;
CGOPGEN();
END
ELSE
BEGIN
REGFORCOMP = .IVALREG;
TREEPTR = .CSTMNT[DOSYM];
OPDSPIX = STOROPIX(TREEPTR);
CGOPGEN();
END;
END;
! Now generate non-materialization labels
DOSP[RIGHTP] = GENLAB();
DEFLAB(.DOSP[RIGHTP]);
DOSP = .DOSP+1;
%674% ! Test for stack overflow, and issue message if necessary
%674% IF (.DOSP-DOSTAK) GTR TDOSTSIZ THEN FATLERR(.ISN,E144<0,0>);
END; ! CGDOLOOP
GLOBAL ROUTINE CGDOEND(TLAB)=
BEGIN
![761] OPGARG for /GFLOATING code generation
EXTERNAL REGFORCOMP,TREEPTR,
%761% A1NODE,A2NODE,DOSP,DOEND,OPGARG,OPGARI,OPGDOE;
%1206% EXTERNAL OPGETI,OPGDOS,OPGSTI,DOSTI;
MAP BASE TLAB;
MAP BASE A1NODE:DOSP:A2NODE:TREEPTR;
! TLAB points to label table entry for label terminating the scope of
! one or more do statements.
! SNDOLNK points to a linked list of the DO statements terminating here
LOCAL CURDO, ! the current DO loop
NXTWD, ! word containing link and do pointer
NXTLNK, ! word containing link to next word
TMP1;
MAP BASE CURDO:TMP1:NXTWD:NXTLNK;
IF .TLAB[SNDOLVL] EQL 0 THEN RETURN; ! No DO's end here
NXTWD = .TLAB[SNDOLNK]; ! Point at first of list
WHILE .NXTWD NEQ 0 DO
BEGIN
CURDO = .NXTWD[LEFTP];
! If the loop is still there
%1206% IF .CURDO NEQ 0 THEN
IF NOT .CURDO[DOREMOVED] THEN
BEGIN
DOSP = .DOSP-1;
! Look at the correct stack entry determine which
! label to transfer to at loop ending if the
! index is materialized, transfer to materialize label
IF .CURDO[NEDSMATRLZ] OR .CURDO[MATRLZIXONLY]
THEN A1LABEL = .DOSP[LEFTP]
ELSE A1LABEL = .DOSP[RIGHTP];
IF .A1LABEL EQL 0 THEN CGERR();
! For the AOBJN case - the control wd and the loop
! index are incremented together
IF .CURDO[FLCWD] AND NOT .CURDO[NEDSMATRLZ]
THEN
BEGIN ! Generate AOBJN CREG,A1LABEL
A1NODE = .CURDO[DOCTLVAR]; ! Temp for contol word
REGFORCOMP = .CURDO[DOCREG]^23;
OPDSPIX = OPGDOE;
END
ELSE
BEGIN
! For cases other than AOBJN - must generate
! code to increment the loop index and code to
! increment and test the control-word
REGFORCOMP = .CURDO[DOIREG]^23;
IF NOT .CURDO[NEDSMATRLZ] AND NOT .CURDO[MATRLZIXONLY]
THEN
BEGIN
! If the loop index is not materialized
! simply generate an add of the incr to
! the reg holding the index
A2NODE = .CURDO[DOSSIZE]; ! ptr to incr
IF (.CURDO[SSIZONE] OR .CURDO[SSIZIMMED])
AND .A2NODE[VALTYPE] NEQ DOUBLPREC
THEN OPDSPIX = DOARITHOPIX(.A2NODE[VALTP1],0,1,.CURDO[SSIZNEGFLG])
ELSE OPDSPIX = DOARITHOPIX(.A2NODE[VALTP1],0,0,.CURDO[SSIZNEGFLG]);
CGOPGEN();
END
ELSE
IF (.CURDO[SSIZONE] AND NOT .CURDO[REALARITH])
OR .CURDO[FLCWD]
THEN
BEGIN
! If the loop index is materialized and
! the increment is 1, generate AOS
A1LABEL = .DOSP[RIGHTP];
OPDSPIX = OPGDOS; ! Non-matrlize label
A1NODE = .CURDO[DOSYM];
CGOPGEN();
END
ELSE
BEGIN
! If the loop index needs to be materialized
! pick up the increment and them add it
! to memory if valtype is not double-prec
A1NODE = .CURDO[DOSSIZE];
IF (.CURDO[SSIZONE] OR .CURDO[SSIZIMMED])
AND .A1NODE[VALTYPE] NEQ DOUBLPREC
THEN OPDSPIX = DOGETAOPIX(1,.A1NODE[VALTP1],.CURDO[SSIZNEGFLG])
ELSE OPDSPIX = DOGETAOPIX(0,.A1NODE[VALTP1],.CURDO[SSIZNEGFLG]);
CGOPGEN();
! Unless the index is double-prec will
! add the increment to it in both the
! reg used and memory, and transfer at
! loop end will be to the code after
! the materialization code
A2NODE = .CURDO[DOSYM];
IF .A2NODE[DBLFLG]
%1206% THEN OPDSPIX = DOARITHOPIX(.A2NODE[VALTP1],1,1,0)
ELSE
BEGIN
! Index to generate ADD to both
! for REAL or INTEGER
A1LABEL = .DOSP[RIGHTP];
OPDSPIX = DOARBOTHOPIX(.A2NODE[VALTP1]);
END;
CGOPGEN();
END;
! generate code to increment and test the control word
! AOJL
! OR
! AOSGE
! JRST
! The control register is used
REGFORCOMP = .CURDO[DOCREG]^23;
! Code to be generated depends on whether the
! ctl-count word is materialized
OPDSPIX = OPGDOE+2+(.CURDO[NEDSMATRLZ] OR .CURDO[MATRLZCTLONLY]);
A1NODE = .CURDO[DOCTLVAR];
END;
CGOPGEN();
%1206% ! If a zero trip label is required, put one out.
%1206% ! Also make sure that the final loop value gets
%1206% ! generated - handle all the various cases.
%1206% IF .CURDO[DOZTRLABEL] NEQ 0
%1206% THEN DEFLAB(.CURDO[DOZTRLABEL]);
%1276% IF F77 THEN ! Need to get final value to variable
%2541% IF NOT .CURDO[MAYBEZTRIP] AND .CURDO[NEDSMATRLZ]
%1206% THEN BEGIN END ! Already got the index materialized
%1206% ELSE IF .CURDO[FLCWD] ! Need to get the final value for loop variable
%1206% THEN
%1206% BEGIN
%1206% A1NODE = .CURDO[DOSYM];
%1206% REGFORCOMP = .CURDO[DOCREG]^23;
%1206% OPDSPIX = DOSTI;
%1206% CGOPGEN();
%1206% END
%1206% ELSE
%1206% BEGIN
%1206% REGFORCOMP = .CURDO[DOIREG]^23;
%1206% TREEPTR = .CURDO[DOSYM];
%1206% OPDSPIX = STOROPIX(TREEPTR);
%1206% CGOPGEN();
%1206% END;
END; ! Do loop really there test
NXTLNK = .NXTWD[RIGHTP];
NXTWD = .NXTLNK;
END; ! WHILE .NXTWD NEQ 0 DO
END; ! CGDOEND;
MACRO TNAME(INDX)=
! Defines .A00nn temp names to save the registers used in the
! function. .A0002 to .A0016 are for register saves, .A0017
! holds the epilogue address if there are multiple entries.
%1505% (SIXBIT '.A0000'+(((INDX) AND #70)^3)+((INDX) AND #7))$;
GLOBAL ROUTINE CGPROEPI =
BEGIN
! Generate subroutine prologue and epilogue, using temps
! .A0002 to .A0017
%4527% OWN BASE ENTNAME;
%4532% LOCAL SAVLAB; !Label at start of sixbit entry name
LOCAL ARGLSTPT;
EXTERNAL OPGADJ,A2LABEL;
EXTERNAL OPGMVL;
%761% EXTERNAL OPGPHR,OPGPPR,DVALU,OPINSI,CLOBBREGS;
EXTERNAL OUTMOD,PBFPTR,PBUFF,PBOPWD,OBUFF,OBUFFA,PSYMPTR,C1H;
EXTERNAL CSTMNT,NAME,TBLSEARCH,ENTRY,POPRET,CRETN,PROGNAME;
%761% EXTERNAL REGFORCOMP,A1NODE,OPINDI,OPGETI;
%1505% EXTERNAL BASE TREEPTR;
%1266% EXTERNAL OPIND2,OPGST2,OPGSTI;
EXTERNAL XCTFDDT;
MAP PPEEPFRAME PBFPTR;
EXTERNAL ARGLINKPT;
MAP PEXPRNODE CSTMNT:A1NODE;
MAP ARGUMENTLIST ARGLSTPT;
MAP PEEPFRAME PBUFF;
EXTERNAL OUTMDA,OPGIIN;
PBFPTR[PBFISN] = NOISN; ! Remove the seq number from the next instr
! (instead it will go on the 1st instr after
! the entry pt)
JUMPABOUT = 0; ! If an entry then JRST around prologue and epilogue
IF .CSTMNT[SRCID] EQL SFNID THEN
BEGIN
JMPSFN = GENLAB();
JRSTGEN(.JMPSFN);
! Use A1NODE as a temp to make and save the label for the sfn
! that will be used in the PUSHJ at reference time
A1NODE = .CSTMNT[SFNNAME];
A1NODE[IDSFNLAB] = GENLAB();
END;
IF .CSTMNT[ENTNUM] NEQ 0 AND .CSTMNT[SRCID] NEQ SFNID
THEN
BEGIN
JUMPABOUT = GENLAB();
JRSTGEN(.JUMPABOUT);
END;
! Output any instrs remaining in the peephole buffer (and initialize
! the ptr to next available wd in buffer to the 1st wd of buffer
IF .PBFPTR NEQ PBUFF
THEN
BEGIN
OUTMOD(PBUFF,(.PBFPTR-PBUFF)/PBFENTSIZE);
PBUFF[PBFLABEL] = NOLABEL; ! Init label field of 1st instr
PBFPTR = PBUFF;
END;
! Clear ISN field in peephole buffer - want the isn on the 1st instr,
! not on the sixbit
PBFPTR[PBFISN] = NOISN;
! Output sixbit for the entry name. use the output routine OBUFFA to
! bypass the peephole optimizer
ENTNAME = .CSTMNT[ENTSYM];
%4532% DEFLAB(SAVLAB = GENLAB()); !Generate and put out label at
%4532% !beginning of entry name
%4532% !Store name in SAVLAB
PSYMPTR = PBF2NOSYM; !Don't relocate this word
%4532%
%4532% INCR I FROM 0 TO .ENTNAME[IDSYMLENGTH]-1 ! Output name
%4532% DO !Loop to output name
%4532% BEGIN
%4532% PBOPWD = @(.ENTNAME[IDSYMPOINTER] + .I);
%4532% OBUFFA();
%4532% END;
%4532% PBOPWD = 0; !Follow name by a zero word
%4532% OBUFFA();
%4532%
%4532% PBOPWD = .SAVLAB; !Label at start of entry name
%4532% IF EXTENDED
%4532% THEN PBOPWD = .PBOPWD OR PXCODE^18;
%4532% PSYMPTR = PBFLABREF; !PBOPWD contains label table entry
OBUFFA();
! Must now clear the peephole buffer again before start peepholing
IF .PBFPTR NEQ PBUFF
THEN
BEGIN
OUTMDA(PBUFF,(.PBFPTR - PBUFF) / PBFENTSIZE);
PBFPTR = PBUFF;
PBUFF[PBFLABEL] = NOLABEL;
END;
! There should be only one subroutine or function per compilation unit.
! Save the epilogue address if necessary, make the entry name a global
! for LINK
IF .CSTMNT[SRCID] NEQ SFNID
THEN
BEGIN
PBOPWD = .CSTMNT[ENTSYM];
PSYMPTR = PBFENTRY;
OBUFF();
END
ELSE
BEGIN
A1NODE = .CSTMNT[SFNNAME];
DEFLAB(.A1NODE[IDSFNLAB]);
END;
PBFPTR[PBFISN] = .CSTMNT[SRCISN]; ! Internal seq number of the entry
! stmnt goes on the 1st instruction
! of the entry sequence
! If the user specified /DEB:TRACE, generate "XCT FDDT."
IF .FLGREG<DBGTRAC> THEN XCTFDDT();
! Define the epilogue label
EPILAB = GENLAB();
IF .FLGREG<MULTENT>
THEN
BEGIN ! If multiple entries
REGFORCOMP = 1^23; ! Hope to generate MOVEM 1, A0017
A1LABEL = .EPILAB;
OPDSPIX = OPGMVL;
NAME = IDTAB;
%4515% ENTRY[0] = ONEWPTR(TNAME(#17));
A1NODE = TBLSEARCH();
%1505% A1NODE[IDPSECT] = PSDATA; ! .A0017 goes in .DATA.
CGOPGEN();
END;
! Save register 16 except if its a statement function or a function
! that does not call FOROTS or any other functions use PUSH for sfn
! MOVEM otherwise
IF .CSTMNT[SRCID] EQL SFNID
THEN OPDSPIX = OPGPHR ! Store the other regs using PUSH
ELSE IF NOT (.BTTMSTFNFLG AND .IOFIRST EQL 0 AND NOT .LIBARITHFLG)
THEN
BEGIN
%761% OPDSPIX = OPGSTI;
NAME = IDTAB;
%4515% ENTRY[0] = ONEWPTR(TNAME(#16));
TREEPTR = TBLSEARCH();
%1505% TREEPTR[IDPSECT] = PSDATA; ! .A0016 goes in .DATA.
REGFORCOMP = #16^23;
CGOPGEN();
END
%761% ELSE OPDSPIX = OPGSTI; ! Will store any other regs using MOVEM
! Now if it is a function
IF .FLGREG<PROGTYP> EQL FNPROG
THEN DECR I FROM LASTONE(.CLOBBREGS) TO 2 DO
BEGIN
IF .CSTMNT[SRCID] EQL ENTRID THEN
BEGIN
NAME = IDTAB;
%4515% ENTRY[0] = ONEWPTR(TNAME(.I));
TREEPTR = TBLSEARCH();
%1505% TREEPTR[IDPSECT] = PSDATA; ! In .DATA.
END;
REGFORCOMP = .I^23;
CGOPGEN();
END;
! Move args to temps - address of temp is in symbol table for argument
REGFORCOMP = 0;
%1401% IF .CSTMNT[ENTLIST] NEQ 0 THEN
BEGIN
%1401% ARGLSTPT = .CSTMNT[ENTLIST];
INCR I FROM 1 TO .ARGLSTPT[ARGCOUNT] DO
BEGIN ! Walk down args
TREEPTR = A1NODE = .ARGLSTPT[.I,ARGNPTR];
IF .A1NODE NEQ 0 THEN ! Zero means label
IF NOT .ARGLSTPT[.I,ENTNOCOPYFLG]
THEN
BEGIN ! Local copy is to be made of this param
%1266% ! For character formals copy the descriptor
%1266% ! Always copy the byte pointer, copy the length
%1266% ! if the formal is length *
%1266% IF .A1NODE[VALTYPE] EQL CHARACTER
%1266% THEN
%1266% BEGIN
%1266% IF .A1NODE[IDCHLEN] EQL LENSTAR
%1266% THEN OPDSPIX = OPIND2 ! Copy BP and length
%1266% ELSE OPDSPIX = OPINDI; ! Copy BP only
%1266% C1H = INDBIT OR (.I - 1); ! Set indirect bit and Y field
%1266% END
%1266% ELSE
%1266% BEGIN ! Not character
IF .A1NODE[OPR1] EQL OPR1C(DATAOPR,FORMLVAR)
THEN
BEGIN ! Move value of scalar to register
%761% OPDSPIX = .A1NODE[VALTP1] + OPINDI;
%761% C1H = INDBIT OR (.I-1);
END
ELSE
BEGIN
OPDSPIX = OPGIIN;
C1H = INDBIT OR (.I-1);
END
%1266% END; ! Not character
! Pick up register from entac field
REGFORCOMP = .ARGLSTPT[.I,ENTAC]^23;
CGOPGEN(); ! Value now in a register
! Now store value or pointer in temp
%1266% IF .A1NODE[VALTYPE] EQL CHARACTER
%1266% THEN IF .A1NODE[IDCHLEN] EQL LENSTAR
%1266% THEN OPDSPIX = OPGST2 ! Copy BP and length
%1266% ELSE OPDSPIX = OPGSTI ! Copy BP only
%1266% ELSE IF .A1NODE[OPR1] EQL OPR1C(DATAOPR,FORMLVAR)
%761% THEN OPDSPIX = .A1NODE[DBLFLG]+OPGSTI
%761%
ELSE OPDSPIX = OPGSTI;
! Only do store if not globally allocated
IF NOT .ARGLSTPT [.I, ENTGALLOCFLG]
%2563% THEN
%2563% BEGIN
%2563% LOCAL IBIT;
%2563% IBIT = .A1NODE[TARGIF];
%2563% A1NODE[TARGIF] = 0;
%2563% CGOPGEN ();
%2563% A1NODE[TARGIF] = .IBIT;
%2563% END;
END; ! Local copy is to be made of this param
END; ! Walk down args
END;
! Now generate JRST to first executable statement
!**********************************************************************
!**********************************************************************
! This JRST is special. If we are going to create a jump
! vector for multiple returns, we must output the peephole
! buffer before generating the JRST. Else, it would be a
! labeled JRST and receive cross-jumping optimization. Since
! the peephole optimizer always looks at the third from last
! instruction, making it the first instruction will inhibit
! the peephole.
!**********************************************************************
!**********************************************************************
IF .JUMPABOUT EQL 0 THEN JUMPABOUT = GENLAB(); ! Already have label if
! jumpabout is set
! If there were label dummy args
IF .FLGREG<LABLDUM>
THEN
BEGIN ! Make this JRST the base of the jump vector so we dont waste a space
!*****************************************
! Here is the special output of the buffer
!*****************************************
OUTMOD(PBUFF,(.PBFPTR-PBUFF)/PBFENTSIZE);
PBFPTR = PBUFF;
PBUFF[PBFLABEL] = NOLABEL;
JMPVECT = GENLAB();
DEFLAB(.JMPVECT);
END;
! Now JRST to first executable if there are label args (and hence a
! jump vector) or multiple entries. This entry follows the prologue
IF .FLGREG<LABLDUM> OR .FLGREG<MULTENT> THEN JRSTGEN(.JUMPABOUT);
! Now the rest of the jump vector if needed
IF .CSTMNT[SRCID] NEQ SFNID ! Don't need it if it's an arithmetic statement function
THEN
BEGIN
LABARGCT = 0;
IF .FLGREG<LABLDUM>
THEN
BEGIN
! First output the JRST, it must go thru OUTMOD.
OUTMOD(PBUFF,1);
PBFPTR = PBUFF;
PBUFF[PBFLABEL] = NOLABEL;
%1401% IF .CSTMNT[ENTLIST] NEQ 0 THEN
BEGIN
%1401% ARGLSTPT = .CSTMNT[ENTLIST];
INCR I FROM 1 TO .ARGLSTPT[ARGCOUNT] DO
BEGIN
IF .ARGLSTPT[.I,ARGNPTR] EQL 0
THEN ! It is a label
BEGIN
! Generate @N-1(16) (which is
! added to the value of the
! are list base by a RETURN N)
LABARGCT = .LABARGCT+1;
%1401% PSYMPTR = PBF2NOSYM;
%1401% PBOPWD=(#36^18) OR (.I-1);
%1401% OIFIW()
END;
END;
END;
! Now output the jump vector through outmda
OUTMDA(PBUFF,.LABARGCT);
PBFPTR = PBUFF;
END;
END; ! End of if statement function
! For multiple entry subroutines, generate the epilogue right after
! the prologue for each entry
IF .FLGREG<MULTENT> THEN CGEPILOGUE(.CSTMNT);
! Define label of first executable statement
DEFLAB(.JUMPABOUT);
! If there are multiple entries (the return will be an indirect JRST)
! then make EPILAB point to the temp in which the epilogue address is
! stored.
IF .FLGREG<MULTENT> THEN
BEGIN
NAME = IDTAB;
%4515% ENTRY[0] = ONEWPTR(TNAME(#17));
EPILAB = TBLSEARCH();
END;
END; ! CGPROEPI
GLOBAL ROUTINE CGEPILOGUE(ENTSTMN)=
BEGIN
! Routine to generate code for function/subroutine epilogue. ENTSTMN
! points to the entry statement to which this epilogue corresponds
EXTERNAL A1NODE,C1H,REGFORCOMP;
EXTERNAL PROGNAME;
MAP PEXPRNODE A1NODE;
%761% EXTERNAL OPGETI,POPRET,CRETN,OPINSI,OPGPPR;
EXTERNAL CLOBBREGS,TBLSEARCH;
EXTERNAL NAME;
MAP BASE ENTSTMN;
REGISTER ARGUMENTLIST ARGLSTPT;
DEFLAB(.EPILAB); ! Define the epilogue label
! Restore register 16. Statement functions and bottommost functions
! won't restore 16
IF .ENTSTMN[SRCID] NEQ SFNID
AND (NOT .BTTMSTFNFLG OR .IOFIRST NEQ 0 OR .LIBARITHFLG)
THEN
BEGIN
NAME = IDTAB;
%4515% ENTRY[0] = ONEWPTR(TNAME(#16));
A1NODE = TBLSEARCH();
%761% OPDSPIX = OPGETI;
REGFORCOMP = #16^23;
CGOPGEN();
END;
! For labels as parameters generate the complex return
IF .FLGREG<LABLDUM>
THEN
BEGIN
A2LABEL = .JMPVECT;
A1LABEL = GENLAB(); ! Label for out of bounds
C1H = .LABARGCT;
OPDSPIX = CRETN;
CGOPGEN();
DEFLAB(.A1LABEL);
END;
! Now move scalars back. Not necessary for statement functions
%1401% IF .ENTSTMN[ENTLIST] NEQ 0 AND .ENTSTMN[SRCID] NEQ SFNID
THEN
BEGIN
REGFORCOMP = 0;
%1401% ARGLSTPT = .ENTSTMN[ENTLIST];
INCR I FROM 1 TO .ARGLSTPT[ARGCOUNT] DO
BEGIN ! Walk down args
A1NODE = .ARGLSTPT[.I,ARGNPTR];
IF .A1NODE NEQ 0 THEN
IF NOT .ARGLSTPT[.I,ENTNOCOPYFLG]
THEN
BEGIN ! Local copy was made of this param
! Only move them back if they were stored into,
! else we are in trouble with generating hiseg
! stores. Never copy back character descriptors
IF .A1NODE[IDATTRIBUT(STORD)] THEN
%1266% IF .A1NODE[VALTYPE] NEQ CHARACTER THEN
IF .A1NODE[OPR1] EQL OPR1C(DATAOPR,FORMLVAR) THEN
IF NOT .ARGLSTPT[.I,ENTGALLOCFLG] THEN
BEGIN
! Local case - set regforcomp.
! Things are different if global
! allocation of an argument has
! occurred
REGFORCOMP = (IF .ENTSTMN[VALINR0] THEN
1^23 ELSE 0);
C1H = INDBIT OR (.I-1);
%761% OPDSPIX = .A1NODE[VALTP1]+OPGETI;
CGOPGEN();
%761% OPDSPIX = .A1NODE[DBLFLG]+OPINSI;
CGOPGEN();
END
ELSE
BEGIN ! Globally allocated
REGFORCOMP = .ARGLSTPT[.I,ENTAC]^23;
C1H = INDBIT OR (.I-1);
%761% OPDSPIX = .A1NODE[DBLFLG]+OPINSI;
CGOPGEN();
END;
END; ! Local copy was made of this param
END; ! Walk down args
END;
IF .ENTSTMN[SRCID] EQL SFNID ! Restore registers if need be
THEN OPDSPIX = OPGPPR
%761% ELSE OPDSPIX = OPGETI;
NAME = IDTAB;
IF .FLGREG<PROGTYP> EQL FNPROG
THEN
BEGIN
!******************************************************
! Since statement functions PUSH and POP for register
! save and restore, these must be symetrically reversed
! to the save code in the prologue
!******************************************************
INCR I FROM 2 TO LASTONE(.CLOBBREGS) DO
BEGIN
IF .ENTSTMN[SRCID] EQL ENTRID THEN
BEGIN
%4515% ENTRY[0] = ONEWPTR(TNAME(.I));
A1NODE = TBLSEARCH();
END;
REGFORCOMP = .I^23;
CGOPGEN();
END;
A1NODE = .ENTSTMN[ENTSYM]; ! Name of fn
IF NOT .A1NODE[IDATTRIBUT(STORD)]
AND NOT .ENTSTMN[SRCID] EQL SFNID
THEN FATLERR(.ISN,E131<0,0>); ! If the value is never stored
%1422% ! Pick up return function value for if not already put there
%1422% ! by global allocator. Don't do it for character functions.
%1422% ! Character functions have the descriptor for the result as
%1422% ! their first argument.
%1422% IF NOT .ENTSTMN[VALINR0] THEN
%1422% IF .A1NODE[VALTYPE] NEQ CHARACTER
THEN
BEGIN
REGFORCOMP = 0;
%761% OPDSPIX = .A1NODE[VALTP1]+ OPGETI;
CGOPGEN();
END;
END; ! FNPROG
OPDSPIX = POPRET;
CGOPGEN();
END; ! CGEPILOGUE
MACRO JRSTIVAR(ADDR)=
BEGIN
! Macro to generate an indirect JRST through a variable.
! Differs from JRSTIGEN in the setting of PSYMPTR
PBOPWD = JRSTOC OR INDBIT OR ADDR[IDADDR];
PSYMPTR = ADDR;
OBUFF();
END$;
GLOBAL ROUTINE CGRETURN(EXPR) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine generates code for RETURN statements. If the
! RETURN is a plain RETURN right before the END statement, no
! code is generated since the code generated for the END
! statement will perform the RETURN.
!
! If the RETURN is in a main program, CGEND is called to
! generate code for CALL EXIT. (which is how a main program
! ends).
!
! If the RETURN is in a routine without dummy label parameters,
! it generates a JRST to the epilogue label (indirectly through
! .A0017 if it has multiple ENTRY points).
!
! If the RETURN is in a routine which has dummy label
! parameters, it moves the alternate RETURN index (defaults to
! zero for a plain RETURN) to AC 1, then generates a JRST to the
! epilogue label as above.
!
! FORMAL PARAMETERS:
!
! EXPR Points to the return expression (0 if none)
!
! IMPLICIT INPUTS:
!
! CSTMNT Points to the current statement
!
! EPILAB Points to the epilogue label of the current program
! unit
!
! FLGREG Flag register; contains information about current
! program unit
!
! IMPLICIT OUTPUTS:
!
! A1NODE Points to first argument of expression
!
! OPDSPIX Pointer into the OPGENTABLE dispatch table
!
! REGFORCOMP Bits 9-12 indicate the register to be used in
! the computation for which code is being generated
!
! TREEPTR Points to expression to be evaluated
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
!--
![2313] Rewritten
BEGIN
MAP BASE EXPR; ! EXPR is 0 or points to an expression
REGISTER BASE NXTSTMNT; ! Used for pointer to next statement
IF NOT .FLGREG<LABLDUM> ! Are dummy labels absent?
THEN IF .EXPR NEQ 0 ! Yes, do we have an expression?
THEN FATLERR(.ISN, E130<0,0>); ! Yes, give an error message
! Check to see if we have a plain RETURN right before the END
! statement. If so, we won't bother to generate any code for
! the RETURN.
IF .EXPR EQL 0 ! Plain RETURN?
THEN IF (NXTSTMNT = .CSTMNT[SRCLINK]) NEQ 0 ! Yes, check next stmnt
THEN
BEGIN ! Plain RETURN with non-zero SRCLINK
! We have a plain RETURN which is not the branch of a
! logical IF and we're not being called by CGEND. See
! if we're at the last statement in the program unit
! before the END statement.
! Skip the CONTINUE statement inserted by the
! optimizer (if any). Make sure it's a dummy CONTINUE
! by checking for a zero source statement number.
IF .NXTSTMNT[SRCID] EQL CONTID ! Is next a CONTINUE?
THEN IF .NXTSTMNT[SRCISN] EQL 0 ! Yes, is ISN zero?
THEN NXTSTMNT = .NXTSTMNT[SRCLINK]; ! Yes, skip it
! If next statement is the END statement then don't
! generate the RETURN. It will be part of the END
! code.
IF .NXTSTMNT[SRCID] EQL ENDID ! Is the next stmnt the END?
THEN RETURN; ! Yes, don't bother
END; ! Plain RETURN with non-zero SRCLINK
! A RETURN that appears in a main program will be treated like
! a CALL EXIT. by CGEND.
IF .FLGREG<PROGTYP> EQL MAPROG
THEN
BEGIN ! Main program
CGEND(); ! Generate the call to EXIT.
RETURN; ! Done
END; ! Main program
IF .FLGREG<LABLDUM> ! Do dummy labels exist?
THEN
BEGIN ! Dummy labels exist
IF .EXPR EQL 0 ! Plain RETURN?
THEN OPDSPIX = OPGZER ! Yes, treat as RETURN 0
ELSE
BEGIN ! We have an expression
IF .EXPR[OPRCLS] NEQ DATAOPR
THEN
BEGIN ! Must evaluate
TREEPTR = .EXPR; ! Evaluate EXPR
CGETVAL(); ! Do it
END; ! Must evaluate
A1NODE = .EXPR; ! Source is EXPR
OPDSPIX = OPGETI; ! Get in register (one word,
! no flags)
END; ! We have an expression
REGFORCOMP = 1^23; ! Destination is AC 1
CGOPGEN(); ! Move alternate RETURN index
END; ! Dummy labels exist
IF .FLGREG<MULTENT> ! Do multiple entries exist?
THEN JRSTIVAR(.EPILAB) ! Yes, generate indirect jump
ELSE JRSTGEN(.EPILAB); ! No, generate direct jump
END; ! of CGRETURN
GLOBAL ROUTINE CGSFN=
BEGIN
%1455% ! Rewritten by TFV on 5-Jan-82
! Code generation for statement function
OWN
OCSTMNT,
OCLOBB,
OPRGM,
OPE,
SFNSYM,
OEPILB;
MAP
BASE CSTMNT,
BASE SFNSYM;
! Save away pertinent globals
OCLOBB = .CLOBBREGS; ! Current set of clobbered registers
OPRGM = .PROGNAME; ! Program name for this unit
OPE = .FLGREG<0,36>; ! Current flag register
OCSTMNT = .CSTMNT; ! Current statement pointer
OEPILB = .EPILAB; ! Current epilog label
! Adjust flgreg
FLGREG<PROGTYP> = FNPROG; ! This is a function subprogram
FLGREG<MULTENT> = 0; ! Statement functions have one entry
FLGREG<LABLDUM> = 0; ! No dummy labels
! Setup clobbregs with registers clobbered by the statement
! function
CLOBBREGS<LEFT> = .CSTMNT[SFNCLBREG];
! Get the statement function name - it is put out in SIXBIT to
! the .REL file for traceback
SFNSYM = .CSTMNT[SFNNAME];
PROGNAME = .SFNSYM[IDSYMBOL];
CGPROEPI(); ! Generate prologue & epilogue
CSTMNT = .CSTMNT[SFNEXPR]; ! Get the assignment or call node
IF .SFNSYM[VALTYPE] EQL CHARACTER
THEN
BEGIN ! Generate code for a call
! Generate code for any common subs
IF .CSTMNT[SRCCOMNSUB] NEQ 0 THEN CGCMNSUB();
! Generate code for the call to CHSFN. or CHSFC.
CGSBPRGM(.CSTMNT[CALLIST],.CSTMNT[CALSYM]);
END ! Generate code for a call
ELSE CGASMNT(); ! Generate code for an assignment
CGEPILOGUE(.OCSTMNT); ! Generate the epilogue code
! Restore the saved globals
CLOBBREGS = .OCLOBB; ! Clobbered registers
PROGNAME = .OPRGM; ! Program name
FLGREG<0,36> = .OPE; ! Flag register
CSTMNT = .OCSTMNT; ! Current statement
EPILAB = .OEPILB; ! Epilog label
DEFLAB(.JMPSFN); ! Define the label for the start of the
! statment function
END; ! CGSFN
GLOBAL ROUTINE CGSBPRGM(ARLISTT,NAMEP)=
BEGIN
!++
! Perform vital code generation for argument lists of
! o subroutine calls,
! o function references,
! o library function references,
! o statement function references.
!
! ARLISTT is a pointer to the argument list.
! NAMEP is a pointer to the symbol table entry for the routine name.
!--
MAP BASE NAMEP,
ARGUMENTLIST ARLISTT;
LOCAL
%1533% HASMULTRETS, ! Flag for has multiple returns
%1533% JRSTPAST; ! The label for the instruction after the error
%1533% ! handling code
REGISTER
BASE ARGNODE, ! Argument node in the arg list
%1533% MARK, ! The ARGMARK field
%1533% CURLBL; ! The label for the current location
%1533% HASMULTRETS = FALSE;
%2245% IF .ARLISTT NEQ 0
THEN
BEGIN ! arguments present
%1533% ! If there are dynamic concatenations as arguments,
%1533% ! generate the CHMRK. call
%1533% MARK = .ARLISTT[ARGMARK];
%1533% IF .MARK NEQ 0 THEN CGCHMRK(.MARK);
ARLISTT[ARGLINK] = .ARGLINKPT;
ARGLINKPT = .ARLISTT;
INCR I FROM 1 TO .ARLISTT[ARGCOUNT] DO
BEGIN ! Generate code to evaluate arguments
ARGNODE = .ARLISTT[.I,ARGNPTR]; ! Pick up arg ptr
%1533% ! Set the flag if an argument is a label
%1533% IF .ARGNODE[OPRCLS] EQL LABOP
%1533% THEN HASMULTRETS = TRUE;
IF NOT .ARLISTT[.I,AVALFLG]
THEN
BEGIN ! Not DATAOPR
TREEPTR = .ARGNODE;
CGETVAL();
END
ELSE
BEGIN ! DATAOPR
! If its a register and a library function
! stash it away in memory. If it's a
! register and not a library function then
! you lose
IF .ARGNODE[OPRCLS] EQL REGCONTENTS THEN
BEGIN
MAP PEXPRNODE TREEPTR;
TREEPTR = .ARGNODE[ARG2PTR];
REGFORCOMP = .ARGNODE[TARGTAC]^23;
OPDSPIX = STOROPIX(TREEPTR);
CGOPGEN();
! Take the regcontents node out
! so the arg list will be right
ARLISTT[.I,ARGNPTR] = .ARGNODE[ARG2PTR];
END;
END; ! DATAOPR
END; ! Generate code to evaluate arguments
! If there are arguments, then generate a label for the
! argument list. If not, then use the shared zero arg
! block.
%2245% IF .ARLISTT[ARGCOUNT] NEQ 0 THEN
A1LABEL = ARLISTT[ARGLABEL] = GENLAB() ! Gen label
%2245% ELSE
%2245% BEGIN ! No arguments
%2245% NEDZER = 1; ! Flag zero-arg-block needed
%2245% A1LABEL = ARLISTT[ARGLABEL] = .ZERBLK;
%2245% END;
END ! arguments present
ELSE
BEGIN ! No arguments
%1533% MARK = 0; ! No argument list
! Reference a common 2 word zero arg block, defined once
! per program unit.
NEDZER = 1; ! Flag zero-arg-block needed
A1LABEL = .ZERBLK;
END;
! For a formal function set the indirect bit in the symbol table
%1455% ! Do not set the indirect bit for character statement functions
%1455% IF (.NAMEP[IDATTRIBUT(DUMMY)] AND NOT .NAMEP[IDATTRIBUT(SFN)])
THEN NAMEP[TARGET] = .NAMEP[TARGET] OR INDBIT;
IF .NAMEP[IDATTRIBUT(SFN)]
THEN
BEGIN
A2LABEL = .NAMEP[IDSFNLAB];
OPDSPIX = OPGSFN;
END
ELSE
BEGIN
A1NODE = .NAMEP;
OPDSPIX = CALLER;
END;
CGOPGEN(); ! Generate the subprogram call
%1533% ! If there are dynamic concatenations as arguments, generate the
%1533% ! CHUNW. call
%1533% IF .MARK NEQ 0 THEN CGCHUNW(.MARK);
%1533% ! If there are multiple returns, generate special error handling
%1533% ! code
%1533% IF .HASMULTRETS
%1533% THEN IF .MARK NEQ 0
%1533% THEN
%1533% BEGIN ! Multiple returns
%1533% ! Generate a label for the location after the error
%1533% ! handling code
%1533% JRSTPAST = GENLAB();
%1533% JRSTGEN(.JRSTPAST); ! Generate JRST JRSTPAST
%1533% INCR I FROM 1 TO .ARLISTT[ARGCOUNT]
%1533% DO
%1533% BEGIN ! Walk down arguments to generate error handling code
%1533% ARGNODE = .ARLISTT[.I,ARGNPTR]; ! Pointer to argument
%1533% IF .ARGNODE[OPRCLS] EQL LABOP
%1533% THEN
%1533% BEGIN ! Argument is a multiple return
%1533% ! Generate a label for the current address
%1533% CURLBL = GENLAB();
%1533% DEFLAB(.CURLBL);
%1533% ! Replace the user specified label with the
%1533% ! compiler generated one
%1533% ARLISTT[.I,ARGNPTR] = .CURLBL;
%1533% ! Generate the CHUNW. call
%1533% CGCHUNW(.MARK);
%1533% ! Generate JRST user_label
%1533% JRSTGEN(.ARGNODE);
%1533% END; ! Argument is a multiple return
%1533% END; ! Walk down arguments to generate error handling code
%1533% DEFLAB(.JRSTPAST); ! Define the label for the instruction
%1533% ! after the error handling code.
%1533% END;
END; ! CGSBPRGM
GLOBAL ROUTINE ARGGEN(PTR)=
!++
! FUNCTIONAL DESCRIPTION:
!
! Generate an arg block entry for an expression node. Unlike
! FOROTS arg block generation (IOPTR), this routine does not
! allow its caller to fill in any of the fields in PBOPWD.
!
! FORMAL PARAMETERS:
!
! PTR Points to expression node for argument.
!
! IMPLICIT INPUTS:
!
! EVALU Used to map PTR[VALTYPE] into argument type code.
!
! 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] Rewritten to support extended addressing
BEGIN
!=========================================================================!
!1!0! 0 ! Type !I! Index ! Address !
!=========================================================================!
MAP PEXPRNODE PTR; ! Points to the expression
PBOPWD = 0; ! Start out with an empty word
![1524] If PTR is not character then we want to set the
![1524] indirect bit if it is a formal function name.
! [Remark by RVM: I don't understand this comment.]
! The indirect bit may already have been set if it was
! previously referenced as a formal function. Thus we set the
! bit explicitly.
%2317% IF .PTR[OPRCLS] EQL DATAOPR
%1524% THEN IF .PTR[VALTYPE] NEQ CHARACTER
THEN IF (.PTR[FORMLFLG] AND .PTR[IDATTRIBUT(INEXTERN)])
THEN PBOPWD[OTSIND] = 1;
IF .PTR[OPRCLS] EQL LABOP
THEN PBOPWD[OTSTYPE]=ADDRTYPE
%1002% ELSE PBOPWD[OTSTYPE]=.EVALU[.PTR[VALTYPE]];
%2317% PBOPWD[OTSIFIW] = 1; ! Make the word an IFIW
%2462% GENREF(.PTR,TRUE); ! Construct memory reference for
! argument word and buffer it
END; ! ARGGEN
GLOBAL ROUTINE CGARGS=
BEGIN
![1401] Rewritten to support extended addressing
!++
! At the end of a block, generate any argument lists that have not
! already been generated. They are on a linked list pointed to by
! ARGLINKPT. The object code for an arg list is a labeled vector of n
! IFIWs to arguments, preceeded by "-n,,0". The routine ARGGEN is
! called to output words that point to the arguments.
!--
REGISTER ARGCT; ! Will hold number of args
%1437% REGISTER BASE LABTAB; ! Label table entry
%1437% REGISTER ARGUMENTLIST ARGLSTPT; ! Arg blocks pointed to by ARGLINKPT
%1437% ARGLSTPT = .ARGLINKPT; !The global pointer to all arguments
%1437% WHILE .ARGLSTPT NEQ 0
DO
BEGIN ! For all arg lists . . .
! Watch out for statements that may have been deleted by
! folding. ARGLABEL is 0 for these statements.
%2245% ! Also do not generate an argument block if there are no
%2245% ! arguments. This could exist for argument checking
%2245% ! purposes.
IF .ARGLSTPT[ARGLABEL] NEQ 0
%2245% AND .ARGLSTPT[ARGCOUNT] NEQ 0 ! Any arguments?
THEN
BEGIN ! Generate argument block
ARGCT=.ARGLSTPT[ARGCOUNT];
PBOPWD=(-.ARGCT)^18; ! -n,,0
PSYMPTR=PBF2NOSYM;
OBUFFA(); ! Write out count word
! Save away the location of the call using the
! label, which is the last reference. Make sure the
! label's been referenced, but not resolved.
%1437% IF .FLGREG<OBJECT>
%1437% THEN !.REL file
%1437% BEGIN
%1437% LABTAB = .ARGLSTPT[ARGLABEL];
%1437% IF .LABTAB[SNDEFINED] AND !Referenced
%1437% (.LABTAB[SNSTATUS] EQL UNRESOLVED)!Not resolved
%1526% THEN ARGLSTPT[ARGCALL] = .LABTAB[SNADDR]
%1437% ELSE CGERR();
%1437% END;
%1437% !** Here the label is defined***
DEFLAB(.ARGLSTPT[ARGLABEL]); ! "nnnnnM:"
%4532% IF NOT PROSBARGLIST(.ARGLSTPT)
%4532% THEN
%1466% INCR I FROM 1 TO .ARGCT ! Write out each arg
DO ARGGEN(.ARGLSTPT[.I,ARGNPTR]);
END; ! Generate argument block
%1437% ARGLSTPT = .ARGLSTPT[ARGLINK] ! Move to next arg list
END ! For all arg lists . . .
END; ! of CGARGS
ROUTINE PROSBARGLIST (ARGLST) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Checks if ARGLST is the argument list for a call to PROSB.
! If it is then the fifth and last argument in the argument list is a
! constant table entry containing a count and pointer to a symbol.
! This fifth argument must be changed to a address of the sixbitz symbol.
!
! FORMAL PARAMETERS:
!
! ARGLST an argument list
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! True if ARGLST is the argument list for a PROSB. call
! False otherwise
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN !New [4532]
MAP ARGUMENTLIST ARGLST; ! argument block being generated by CGARGS
LOCAL BASE TEMP;
TEMP = .ARGLST[ARGPARENT]; !Parent of arg list
IF .TEMP[OPRCLS] NEQ FNCALL OR .TEMP[OPERSP] NEQ LIBARY
THEN RETURN 0;
TEMP = .TEMP[ARG1PTR]; !Name of library function
IF .TEMP[ID1ST6CHAR] NEQ SIXBIT 'PROSB.' !Not PROSB.
THEN RETURN 0;
INCR I FROM 1 TO 4 ! Write out each arg
DO ARGGEN(.ARGLST[.I,ARGNPTR]);
PBOPWD = TEMP = GENLAB(); !Label where symbol starts
PBOPWD[OTSTYPE] = SIXBITZTYPE; ! Type is pointer to sixbitz string
PBOPWD[OTSIFIW] = 1; ! Make the word an IFIW
PSYMPTR = PBFLABREF; !PBOPWD contains label table entry
GENREF(.TEMP,TRUE); !Generate the reference
DEFLAB(.TEMP); ! Define label
TEMP = .ARGLST[5,ARGNPTR]; ! Constant entry
TEMP = .TEMP[CONST2]; ! CNT,,PTR TO SYMBOL
PSYMPTR = PBF2NOSYM; !Don't relocate this word
INCR I FROM 0 TO .TEMP<SYMLENGTH> - 1
DO !Dump out symbol
BEGIN
PBOPWD = @(.TEMP<SYMPOINTER> + .I);
OBUFFA();
END;
PBOPWD = 0;
OBUFFA();
RETURN 1; !We already generated the arglist for ARGLST
END; !PROSBARGLIST
! Below is for RUNOFF in generating .PLM files
!++
!.END LITERAL
!--
END
ELUDOM