Trailing-Edge
-
PDP-10 Archives
-
BB-4157F-BM_1983
-
fortran/compiler/cgdo.bli
There are 12 other files named cgdo.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
! OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1983
!AUTHOR NORMA ABEL/HPW/MD/DCE/SJW/RDH/TFV/CKS/AHM/CDM/RVM
MODULE CGDO(RESERVE(0,1,2,3),SREG=#17,VREG=#15,FREG=#16,DREGS=4)=
BEGIN
GLOBAL BIND CGDOV = 7^24 + 0^18 + #1562; ! Version Date: 18-Jun-82
%(
***** 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.
***** End Revision History *****
)%
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
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;
EXTERNAL
A1LABEL,
A2LABEL,
ARGLINKPT, ! Points to linked list of arg blocks
CGASMNT,
%1533% CGCHMRK, ! Generate code for a CHMRK. call
%1533% CGCHUNW, ! Generate code for a CHUNW. call
CGCMNSUB, ! Generate code for common subs
CGERR,
CGOPGEN, ! Code generation routine
CLOBBREGS,
CSTMNT,
DEFLAB, ! Defines a label
%674% DOSTAK,
E131,
%674% E144, ! Error message declarations
GENLAB,
FATLERR,
LASTONE,
%1533% OBUFF,
OBUFFA, ! Outputs a word
%1401% OIFIW, ! Makes the word in PBOPWD into an IFIW
! and writes it out with OBUFFA
OPDSPIX,
PBOPWD, ! Holds data word to output
PROGNAME,
PSYMPTR; ! Holds relocation info for OBUFFA
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], CGDOEND, DCE, 21-Oct-81
%1276% IF F77 THEN ! Need to get final value to variable
%1206% IF NOT .CURDO[MAYBEZTRIP]
%1206% AND (.CURDO[NEDSMATRLZ] OR .CURDO[MATRLZIXONLY])
%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))$;
MACRO MOV1GEN(SRCE)=
BEGIN
! Generate a MOVE 1,SRCE
EXTERNAL C1H;
OPDSPIX = MOVRET;
C1H = SRCE;
CGOPGEN();
END$;
GLOBAL ROUTINE CGPROEPI =
BEGIN
! Generate subroutine prologue and epilogue, using temps
! .A0002 to .A0017
OWN PEXPRNODE ENTNAME;
LOCAL ARGLSTPT,NEDTOSAV;
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];
PBOPWD = .ENTNAME[IDSYMBOL];
PSYMPTR = PBF2NOSYM;
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;
ENTRY = 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;
ENTRY = 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;
ENTRY = 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]
THEN
BEGIN
! Save current indirect flag of formal,
! turn off indirect flag then generate
! store code and restore indirect flag
NEDTOSAV = .A1NODE[IDTARGET] AND INDBIT;
A1NODE[IDTARGET] = .A1NODE[IDTARGET] AND (NOT INDBIT);
CGOPGEN ();
A1NODE[IDTARGET] = .A1NODE[IDTARGET] OR .NEDTOSAV;
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;
ENTRY = 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;
ENTRY = 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
ENTRY = 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)=
BEGIN
! Return statement - expr points to the return expression
! Generate setz 1 for plain return when there are labels as parameters
MACRO SET1ZGEN =
BEGIN
REGFORCOMP = 1^23;
OPDSPIX = OPGSET+1;
CGOPGEN();
END$;
EXTERNAL E130;
EXTERNAL MOVRET,CGETVAL;
EXTERNAL PBOPWD,PSYMPTR,OBUFF,OPGSET,REGFORCOMP;
%761% EXTERNAL TREEPTR,A1NODE,CSTMNT,OPGETI,PROGNAME,CGEND;
REGISTER BASE NXTSTMNT; !PTR TO NEXT STMNT
MAP PEXPRNODE TREEPTR:A1NODE:CSTMNT;
MAP BASE EPILAB;
MAP PEXPRNODE EXPR;
! If this is a multiple return and there were no label args,
! give an error message
IF .EXPR NEQ 0 AND NOT .FLGREG<LABLDUM> THEN FATLERR(.ISN,E130<0,0>);
IF (NXTSTMNT = .CSTMNT[CLINK]) NEQ 0 ! Stmnt following the return
THEN
BEGIN ! If the return was not the branch of a log if skip the
! CONTINUE inserted by the optimizer
! Make sure it is a dummy continue statement by
! checking for zero source statement number
IF .NXTSTMNT[SRCID] EQL CONTID THEN
IF .NXTSTMNT[SRCISN] EQL 0
THEN NXTSTMNT = .NXTSTMNT[CLINK];
! If there are not label arguments and the next statement is
! the end statement then do not generate the return.
! It will be part of the end code.
IF NOT .FLGREG<LABLDUM> THEN
IF .NXTSTMNT[SRCID] EQL ENDID
THEN RETURN;
END;
! A return that appears in a main program should be treated like
! a CALL EXIT. This is accomplished by calling CGEND
IF .FLGREG<PROGTYP> EQL MAPROG
THEN
BEGIN
CGEND();
RETURN
END;
IF NOT .FLGREG<MULTENT> THEN
BEGIN ! Single entry
IF NOT .FLGREG<LABLDUM>
THEN JRSTGEN(.EPILAB)
ELSE
BEGIN ! Labels are args
IF .EXPR EQL 0
THEN SET1ZGEN ! Plain vanilla return
ELSE
BEGIN ! Return thru a label
TREEPTR = .EXPR;
IF .TREEPTR[OPRCLS] EQL DATAOPR
THEN
BEGIN ! Expression is dataopr
REGFORCOMP = 1^23;
A1NODE = .TREEPTR;
%761% OPDSPIX = .A1NODE[VALTP1] + OPGETI;
CGOPGEN();
END
ELSE
BEGIN
CGETVAL();
! If the register allocator didnt put
! it in 1 (which it never will do???).
! Then move it to 1
IF .EXPR[TARGTAC] NEQ 1
THEN MOV1GEN(.EXPR[TARGTAC]);
END;
END;
JRSTGEN(.EPILAB);
END; ! Labels are args
END ! Single entry
ELSE
BEGIN ! Multiple entries
IF NOT .FLGREG<LABLDUM>
THEN JRSTIVAR(.EPILAB)
ELSE
BEGIN ! Labels as args with multiple entries
IF .EXPR EQL 0
THEN SET1ZGEN ! Plain vanilla return
ELSE
BEGIN ! Return thru a label
TREEPTR = .EXPR;
IF .TREEPTR[OPRCLS] EQL DATAOPR
THEN
BEGIN ! Expression is dataopr
REGFORCOMP = 1^23;
A1NODE = .TREEPTR;
%761% OPDSPIX = .A1NODE[VALTP1] + OPGETI;
CGOPGEN();
END
ELSE
BEGIN
CGETVAL();
! If it si not already in ac1 move it there
IF .EXPR[TARGTAC] NEQ 1
THEN MOV1GEN(.EXPR[TARGTAC]);
END;
END;
JRSTIVAR(.EPILAB);
END; ! Labels as args with multiple entries
END; ! Multiple entries
END; ! 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 calls, function references
! and statement function references and library function references
EXTERNAL TREEPTR,CGETVAL,OPGSFN,ZERBLK;
EXTERNAL NEDZER; ! Flag to indicate if zero-arg-block needed
%761% EXTERNAL A1NODE,CALLER,TBLSEARCH,REGFORCOMP,OPGSTI;
MAP BASE NAMEP;
MAP ARGUMENTLIST ARLISTT;
%1466% LOCAL ARGFLG; ! Flag - Need an arg block
%1533% LOCAL HASMULTRETS; ! Flag for has multiple returns
REGISTER BASE ARGNODE;
%1533% REGISTER MARK; ! The ARGMARK field
%1533% REGISTER CURLBL; ! The label for the current location
%1533% LOCAL JRSTPAST; ! The label for the instruction after the error
%1533% ! handling code
! ARLISTT is a pointer to the argument list. NAMEP is a pointer
! to the symbol table entry for the routine name. IF
! /DEBUG:ARGUMENTS is given, output a size zero arglist for
! argument checking.
%1466% ARGFLG _ 0;
%1533% HASMULTRETS = FALSE;
IF .ARLISTT NEQ 0
THEN
%1562% BEGIN ! Argument list present
%1613% IF .ARLISTT[ARGCOUNT] NEQ 0 OR .FLGREG<DBGARGMNTS>
%1466% THEN ARGFLG _ 1;
%1533% ! If there are dynamic concatenations as arguments,
%1533% ! generate the CHMRK. call
%1533% MARK = .ARLISTT[ARGMARK];
%1562% END ! Argument list present
%1562% ELSE MARK = 0; ! No argument list
%1533% IF .MARK NEQ 0 THEN CGCHMRK(.MARK);
%1466% IF .ARGFLG
THEN
BEGIN ! arguments present
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
TREEPTR = .ARGNODE;
CGETVAL();
END
ELSE
BEGIN
! 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;
END; ! Generate code to evaluate arguments
! Should test for this being a library function to generate a
! different name. Not in release 1.
A1LABEL = ARLISTT[ARGLABEL] = GENLAB();
END ! arguments present
ELSE
BEGIN ! No args reference a 2 word, zero arg block, defined once
NEDZER = 1;
A1LABEL = .ZERBLK; ! Flag zero-arg-block needed
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)=
BEGIN
![1401] Rewritten to support extended addressing
! Generate an arg block entry for the expression pointed to by PTR.
! Takes a pointer to an expression node and generates the appropriate
! entry by placing the data in the global PBOPWD and some relocation
! information (often a pointer to an STE) into the global PSYMPTR.
! Unlike FOROTS arg block generation, this routine fills in all of the
! fields in PBOPWD itself.
!=========================================================================!
!1!0! ! Type !I! Index ! Address !
!=========================================================================!
! Uses EXTERNAL ROUTINE OIFIW ! NOVALUE
MAP PEXPRNODE PTR; ! Points to the expression
EXTERNAL BASE PSYMPTR; ! Holds relocation info
EXTERNAL OBJECTCODE PBOPWD; ! Holds data word to output
%1002% EXTERNAL EVALTAB EVALU; ! Maps internal type codes to external
SELECT .PTR[OPRCLS] OF
NSET
DATAOPR: BEGIN
PSYMPTR=.PTR;
PBOPWD=.PTR[TARGTMEM];
%1524% ! If PTR is not character then we want to set the
! indirect bit if it is a formal function name or
! a formal array.
! [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.
%1524% IF .PTR[VALTYPE] NEQ CHARACTER
THEN IF (.PTR[FORMLFLG] AND .PTR[IDATTRIBUT(INEXTERN)])
OR .PTR[OPR1] EQL OPR1C(DATAOPR,FORMLARRAY)
THEN PBOPWD[OTSIND]=1
END;
LABOP: BEGIN
PBOPWD=.PTR;
PSYMPTR=PBFLABREF
END;
ARRAYREF: IF .PTR[VALTYPE] NEQ CHARACTER
%1253% THEN
BEGIN ! Non-CHARACTER ARRAYREF
! For an ARRAYREF, the target field of the
! expression node contains the relative address.
! ARG1PTR points to the symbol table entry.
%1002% PBOPWD=.PTR[TARGADDR];
PSYMPTR=.PTR[ARG1PTR];
! An ARRAYREF node is found as an argument only if
! the address calculation is constant. If there is
! a variable part, there will be a STORECLS node at
! the top to store a pointer to the element into a
! temporary.
IF .PTR[ARG2PTR] NEQ 0
THEN CGERR()
END ! Non-CHARACTER ARRAYREF
%1253% ELSE
%1253% BEGIN ! CHARACTER ARRAYREF
! TARGADDR points to the STE of the .Q temp which
! has the descriptor
PSYMPTR = .PTR[TARGADDR];
PBOPWD = .PSYMPTR[IDADDR] ! Use addr of .Q temp
END; ! [1253] CHARACTER ARRAYREF
OTHERWISE: BEGIN
! Pick up the temp in which the result value will
! will be stored. This is the *REAL* arg.
PSYMPTR=.PTR[TARGADDR]; ! Get hold of the STE
PBOPWD=.PSYMPTR[IDADDR]; ! Store .Q temp addr
PBOPWD[OTSIND]=.PTR[TARGIF] ! Move the indirect bit
END;
TESN;
IF .PTR[OPRCLS] EQL LABOP
THEN PBOPWD[OTSTYPE]=ADDRTYPE
%1002% ELSE PBOPWD[OTSTYPE]=.EVALU[.PTR[VALTYPE]];
OIFIW() ! Finally output the word
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 ! For all arg lists . . .
DO
BEGIN
! Watch out for statements that may have been deleted by
! folding. ARGLABEL is 0 for these statements.
IF .ARGLSTPT[ARGLABEL] NEQ 0
THEN
BEGIN
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:"
%1466% IF .ARGCT NEQ 0 !No args?
%1466% THEN INCR I FROM 1 TO .ARGCT ! Write out each arg
DO ARGGEN(.ARGLSTPT[.I,ARGNPTR])
%1466% ELSE
%1466% BEGIN ! Put out a word of 0 so that the label will
%1466% ! have something to refernce.
%1466% PBOPWD = 0;
%1466% PSYMPTR = PBF2NOSYM;
%1466% OBUFFA();
%1466% END;
END;
%1437% ARGLSTPT = .ARGLSTPT[ARGLINK] ! Move to next arg list
END
END; ! of CGARGS
END
ELUDOM