Trailing-Edge
-
PDP-10 Archives
-
fortv11
-
sta0.bli
There are 26 other files named sta0.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1973, 1987
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
!AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!AUTHOR: F.J. INFANTE/HPW/ D. B. TOLMAN/DCE/TFV/CKS/CDM/AHM/RVM/RJD/TJK/AlB/MEM
MODULE STA0(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND STA0V = #11^24 + 0^18 + #4553; ! Version Date: 15-Oct-86
%(
***** Begin Revision History *****
44 ----- ----- CATCH ILLEGAL LIST DIRECTED RANDOM ACCESS
45 ----- ----- MOVE DO INDEX MODIFICATION CHECK TO NAMSET SO THAT
IT WILL GET ALL CASES OF MODIFICATION
46 336 17259 CHECK FOR ILLEGAL I/O LIST WITH NAMELIST
***** Begin Version 5B *****
47 742 ----- STOP/PAUSE STATEMENTS NOW TAKE DIGIT STRINGS
INSTEAD OF OCTAL STRINGS
48 745 ----- ARGUMENT LIST COULD NOT BE .GTR. 124 - FIX IT, (DCE)
***** Begin Version 6 *****
49 760 TFV 1-Oct-79 ------
Rewrite RWBLD to accept either positional (old style) or keyword
(new style) control information lists
50 766 DCE 14-May-80 -----
Give error messages for the following:
1. GO TO A where A is dimensioned
2. GO TO A(I) where A is dimensioned
3. ASSIGN 10 TO A(I) where A is dimensioned
54 1076 TFV 8-Jun-81 ------
Allow list-directed I/O without an iolist.
55 1114 CKS 22-Jun-81 -----
Fix check in RWBLD for namelist IO without IO list. It was using
R2 as if it contained a format statement pointer; make it be true.
70 1150 DCE 7-Apr-82 20-17292
For an ASSIGN statement, flag the label as having been ASSIGNed.
This prevents the optimizer from getting illegal jumps into loops
when not warranted.
***** Begin Version 7 *****
51 1202 DCE 1-Jul-80 -----
Change calls to DATALIST to be calls to LISTIO so that we can do
expressions on output lists.
52 1203 DCE 24-Nov-80 -----
Modify 1202 to accomodate the new I/O list processing
53 1217 DCE 28-May-81 -----
Allow empty argument lists for CALL stmnts.
R2 as if it contained a format statement pointer; make it be true.
56 1233 CKS 25-Jun-81
%! Make "READ (1), X" work. The problem is complex. The BNF for
! IO statements contains [ [ COMMA ] +OUTPLIST ] where OUTPLIST is
! an output list. OUTPLIST is %NOTEOL% %GIOLIST% where NOTEOL checks
! for an end of line since GIOLIST can't be called on a null expression.
! When these productions are folded together you get
! ( COMMA %NOTEOL% ... | %NOTEOL% ... )
! which is not LL(1). That is, one-token lookahead cannot distinguish
! which alternative to use when the input starts with ",". Comma
! matches both alternatives. As it happens, SYNTAX always chooses the
! action routine alternative, which is wrong in this case. To get
! around this, replace [ COMMA ] with an action routine %OPTCOMMA%
! which acts like the optional syntax in the BNF, but doesn't require
! the parser to decide between two alternatives. One additional
! complication is present: the whole IO list, optional comma and all,
! is optional. Therefore, OPTCOMMA fails on end of line, so that
! SYNTAX will decide that the optional IO list is not present and
% proceed accordingly.
57 1247 CKS 6-Aug-81
Add SUBASSIGN semantic routine to parse substring assignment statements
58 1254 CKS 14-Aug-81
Modify MULTIASGN to generate a CALL node for character assignments.
Call CONCA. if the RHS of the assignment is a concatenation expression,
CHASN. otherwise.
59 1257 TFV 10-Sep-81 ------
Fix LITOR6DIGIT to convert character constant args to hollerith.
This fixes STOP/PAUSE 'foo'.
60 1260 CKS 14-Sep-81
Don't allow character variables in ASSIGN and GOTO statements
61 1263 TFV 22-Sep-81 ------
Fix edit 1260 to allow the degenerate case GOTO (100,200),'ccc'.
It's silly but legal in Version 6.
62 1277 CKS 20-Oct-81
Fix assigned GOTO to support the syntax GOTO I (10,20,30).
That is, allow the optional comma to be absent. This means that it is
no longer possible to use array elements in assigned GOTO. Remove the
V6 warning against using array elements.
63 1413 CDM/AHM 4-Nov-81
Edited CALLSTA to use structure ARGUMENTLIST for assigning argument
nodes. Made MULTIASGN know about larger arg block nodes for character
assignments. Also assign parent pointer to get at name of subroutine
being called for LINK hollerith/string argument coercion support.
64 1446 AHM 22-Dec-81
Made MULTIASGN return the address of the created statement node
so that calling routines that punt on negative return values
always get something positive when things went OK. This bug was
detected when character assignment statements in logical IFs
returned 1B0 in VREG causing LOGICALIF to not link the IF
statement into the statement list. Also, MULTIASGN was cleaned
up slightly.
65 1455 TFV 5-Jan-81 ------
Change MULTIASGN for character statement functions. The code to
convert character assignments to calls to CHASN. or CONCA. has
been made into the routine CHASGN. It will convert a character
statement function 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.
66 1465 CKS 22-Jan-82
Rewrite RWBLD to read the new tree shape produced by action routine
KEYSCAN. READ and WRITE statement keyword lists are now parsed by
that action routine instead of by SYNTAX.
67 1466 CDM 1-Feb-82
Create zero block argument lists in CALLSTA if /DEBUG:ARGUMENTS
is specified.
68 1471 RVM 5-Feb-82
Put checks into RWBLD to give error messages if illegal internal
file I/O is specified. If an internal file is an array, put its
total size in characters into the IORECORD field of the I/O
statement node. This causes no problems as random access I/O to
internal files is illegal.
69 1477 CKS 10-Feb-82
Fix RWBLD to check first for arrayname as unit specifier, then
convert it to integer. Converting first leaves you looking at
a type conversion node, which isn't an array name.
1505 AHM 13-Mar-82
Make CHASGN set the psect index of the symbol table entries it
creates for the various character assignment subroutines to
PSCODE so that routines references are relocated by .CODE.
1510 RVM 14-Mar-82
Put checks in RWBLD to make it illegal to use an assumed-size array
as either a unit or format in an I/O statement.
1517 CKS 24-Mar-82
Fix SUBASSIGN so that the RHS expression must be followed by LINEND.
1531 CDM 4-May-82
SAVE stmt changes after code review.
1546 CKS 31-May-82
Modify RWBLD to be IOBLD, which does TYPE/ACCEPT type statements as
well as READ and WRITE. Eliminate the FORMATID half of RWBLD, which
is not necessary since action routine KSPEC builds identical semantic
info for the two syntaxes. Move TYPESTA and its friends here so all
the relevant routines are in this module.
1551 AHM 4-Jun-82
Remove edit 1505 because external references no longer have
their psect index set.
1613 CDM 13-Aug-82
Change /DEBUG:PARAMETERS to /DEBUG:ARGUMENTS
1652 CDM 20-Oct-82
Give warning for RETURN in main program.
1661 CKS 2-Nov-82
Substring assignments aren't setting STORD for the variable being
assigned to. Call NAMSET to do this for scalar assignments. For
assignments to arrays, it seems that STORD is meaningless -- at
least, routine STATEFUNC does not worry about it for numeric array
assignments -- so don't worry for character assignments either.
1665 CKS 8-Nov-82
Allow computed GOTO as the last statement in a DO loop.
1677 CKS/CDM 20-Nov-82
Use action routine KEYSCAN to parse FIND, ENCODE, REWIND.
Check that an argument list really exists before lighting the
ARGCHBLOCK bit saying arg checking is necessary.
1715 RVM 12-Jan-83
The compiler did not realize that character variables were
stored into when they were used as internal files by WRITE
statements. To remedy this, set the STORD attribute when
doing the semantic checks on internal file specifiers used
in WRITE statements.
***** End V7 Development *****
1737 RJD 4-Mar-83
When the /DEBUG:ARGUMENTS switch is on but no arguments are
being passed, the loop which assigns arguments should not be
executed. Also, the CNT should be initialized to zero outside
of the loop.
1776 TFV 9-Sep-83
Namelist I/O is illegal for ENCODE and DECODE. Check for it in
IOBLD.
2003 TJK 27-Sep-83
Add check to IOBLD to allow a format specifier to be
a REAL or LOGICAL variable (instead of just INTEGER).
2063 TFV 29-Jun-84
Give an error for NAMELIST I/O with REREAD, ENCODE, and DECODE.
***** End Revision History *****
2245 CDM 15-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.
This deleted uneeded checkes of /DEBUG:ARGUMENTS in CALLSTA.
Also delete unused macros CARGPTR, CAFLGFLD, ERR15(X), and
machop BLT.
2247 AlB 22-Dec-83
Add compatibility flagging for old-type I/O statements
Routines:
ACCESTA, PUNCSTA, RERESTA, TYPESTA
2252 AlB 27-Dec-83
Added Compatibility flagging for:
1) ENCODE/DECODE
2) Non-integer used with REC=
3) Non-integer used with UNIT=
4) Non-integer used as index to RETURN
5) Non-integer used as index to computed GOTO
6) Assigned GOTO with label list
Routines:
BLDUTILITY, DECOSTA, ENCOSTA, GOTOSTA, IOBLD, RETUSTA
2261 AlB 5-Jan-84
More compatibility flagger checks:
PRINT (specifiers) iolist ! "(specifiers)" is neither ANSI nor VAX
WRITE f, iolist ! WRITE with default unit is
WRITE (FMT=f, ...) iolist ! neither ANSI nor VAX
Concantenation with length (*) ! ANSI extension
Routines:
CHASGN, PRINSTA, WRITSTA
2276 AlB 26-Jan-84
Compatibility flagging for intrinsic functions and Fortran-supplied
subroutines:
1) Added routine CFSRCLIB to search a list of functions/subroutines
which might cause incompatibilities.
2) Modified CALL statement to put out flagger warning if we detect
a) A reference to a subroutine supplied by us but not by
the VAX and/or Fortran-77.
b) A reference to a subroutine supplied by both VAX and us
which may produce a different result, or has different
arguments.
Routines:
CALLSTA CFSRCLIB
2277 AlB 26-Jan-84
Removed some entries from the Function Compatibility tables
(CFTABLEN and CFTABLEV). Those entries removed were the bit
manipulation functions and subroutines that the VAX has always
had, and which Randy Meyers is adding to Fortran-10/20.
Routine:
CFSRCLIB
2300 AlB 27-Jan-84
Corrected spelling of entries in CFTABLEN & CFTABLEV.
Routine:
CFSRCLIB
2302 TJK 2-Feb-84
Add new flag IDCLOBB to the IDFNATTRIB field of a symbol table
entry. This flag is set for certain library routines (called
as subroutines). It indicates that ACs are not preserved by
the call.
Have CHASGN generate calls to CASNM. instead of CHASN. for
single-source character assignments, and CNCAM. instead of
CONCA. for character concatenation assignments. Also have it
set IDCLOBB for these routines, which don't preserve ACs.
Replace a check for CONCA. with a check for CNCAM. in SKCALL.
Have ALCCALL mark registers 2-15 (octal) as being clobbered if
IDCLOBB is set.
2303 AlB 3-Feb-84
Remove the CFFSNAME variable, and instead reference the symbol table
to get name to stick into warning messages; WARNLEX will now print
the correct name (or at least the 'dotted' version of that name).
This edit touched some WARNLEX calls, and caused changed to routine
CFSRCLIB.
Made some cosmetic changes to better conform to programming
conventions.
2340 AlB 13-Apr-84
Remove flagger checking of Fortran-supplied subprograms. The fact
that these routines are not present (or differ) on VAX and/or ANSI
is checked at run-time, and need not be checked in the compiler.
2455 MEM 30-Aug-84
Replace all occurrences of VAX with VMS.
2473 CDM 26-Oct-84
Add IMPLICIT NONE for the Military Standard MIL-STD-1753.
2507 CDM 20-Dec-84
Add enhancement for IMPLICIT NONE (edit 2473) after code inpsection.
Check more cases, and add a symbol table walk at the back
end to catch unreferenced variables.
***** End V10 Development *****
2534 MEM 13-Jun-85
In SUBASSIGN set the STORD bit in the left hand expression of the
assignment and delete the call to NAMSET.
2557 JB 6-Nov-85
Check for the use of specific function names in argument lists
instead of in INTRINSIC statements. Call routine INTRCHK to
perform the check.
***** End Revision History *****
***** Begin Version 11 *****
4501 MEM 22-Jan-85
Modified IOBLD for indexed read.
4503 MEM 22-Jan-85
Created REWRSTA to flag ANSI compatibility and to perform keyword
processing for the REWRITE statement.
4514 MEM 13-Sep-85
Fillin in blank fields SRCID, OPRCLS, and SRCLBL in the node (character
assignment) under a character statement function node.
4516 CDM 2-Oct-85
Phase I.I for VMS long symbols. Pass Sixbit to all error message
routines, do not pass addresses of Sixbit anymore. In later edits
this will pass [length,,pointer to symbol] instead of a pointer to
this to the error message routines.
4526 MEM 27-Nov-85
Give error message on TOPS10 if RMS specifiers are given in a READ
statement and for all REWRITE statements.
4527 CDM 1-Jan-86
VMS Long symbols phase II. Convert all internal symbols from
one word of Sixbit to [length,,pointer]. The lengths will be one
(word) until a later edit, which will store and use long symbols.
4543 JB 9-Jul-86
Allow list-directed I/O with internal files, but flag it as
non-standard.
4553 JB 15-OCT-86
Remove edit 4543.
ENDV11
)%
SWITCHES NOLIST;
REQUIRE FTTENX.REQ; ![4526]
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE META72.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;
! Below is for RUNOFF in generating .PLM files
!++
!.LITERAL
!--
!THE NUMBER IN COMMENT'S IS THE STATEMENTS LOCATION
!IN THE HASH TABLE .
FORWARD
MULTIASGN,
ASSIGNMENT, ! ASSIGNMENT
%2276% CFSRCLIB(1), ! Search table of incompatible functions/subroutines
%1455% CHASGN, ! Character assignment
% 1% PUNCSTA, !PUNCH
% 38% CALLSTA, !CALL
% 49% GOTOSTA, !GOTO
% 53% PAUSSTA, !PAUSE
% 57% RETUSTA, !RETURN
% 73% ACCESTA, !ACCEPT
% 78% READSTA, !READ
% 90% WRITSTA, !WRITE
% 98% CONTSTA, !CONTINUE
%109% ASSISTA, !ASSIGN
%114% STOPSTA; !STOP
FORWARD
IOBLD;
EXTERNAL
%2252% CFLAGB, ! Put out certain flagger warnings
CNVNODE,
%2534% CREFIT,
E102,
E184,
E188,
E191,
E192, ! "Illegal in SAVE statement"
E200,
E201,
%1652% E209, ! "RETURN illegal in main routine"
%1776% E217, ! NAMELIST is not allowed in ENCODE and DECODE
%2261% E221, ! 'Extension to Fortran-77: Concantenation with length (*)'
%2252% E232, ! 'Extension to Fortran-77: ENCODE statement'
%2252% E233, ! 'Extension to Fortran-77: DECODE statement'
%2455% E250, ! 'VMS incompatibility: Label list with assigned GOTO'
%2252% E258, ! 'Extension to Fortran-77: Non-integer with computed GOTO'
%2252% E259, ! 'Extension to Fortran-77: Non-integer with (Keyword)
%2252% E261, ! 'Extension to Fortran-77: Non-integer RETURN index'
%2247% E267, ! 'Extension to Fortran-77: xxxx statement'
%2455% E268, ! 'Fortran-77 or VMS: xxxx statement'
%2455% E269, ! 'Fortran-77 or VMS: PRINT with specifiers'
%2455% E285, ! 'Fortran-77 or VMS: WRITE default unit'
%4501% E307, ! a key relation specifier must be specified with KEYID
%4501% E308, ! illegal specifier in indexed read
%4501% E309, ! indexed read is not ANSI compatible
%4501% E310, ! key relation specifiers can only be used in READ stmt
%4503% E311, ! format can not be asterisk or namelist in indexed read
%4503% E314, ! UNIT must be specified
%4526% E322, ! TOPS20 ONLY: xxx
%4553%
%1652% FATLERR,
%2557% INTRCHK,
IODOXPN,
%2261% IOSPEC, ! True if "(keywords)" used in I/O, false otherwise
BASE LABLOFSTATEMENT,
LEXNAME,
LISTIO,
%4527% ONEWPTR, ! Returns [1,,pointer] to Sixbit argument
NAMLSTOK,
NAMSET,
NEWENTRY,
SAVSPACE,
STMNDESC;
%2247% MACRO !To aid in compatibility flagging
%2247% ANSICHECK(STAT,ERR) =
%2247% IF FLAGANSI THEN WARNERR ((PLIT ASCIZ STAT)<0,0>,.ISN,ERR<0,0>)$,
%2247% FLAGCHECK(STAT,ERR) =
%2247% IF FLAGEITHER THEN CFLAGB ((PLIT ASCIZ STAT)<0,0>,ERR<0,0>)$;
GLOBAL ROUTINE MULTIASGN(LEFTSIDE)=
BEGIN
MAP BASE R1:R2;
%1455% REGISTER BASE LHS;
%1455% REGISTER BASE RHS;
EXTERNAL NEWENTRY %()%,SAVSPACE %(SIZE,LOC)%;
EXTERNAL STK,ASGNTYPER,LABLOFSTATEMENT;
EXTERNAL WARNLEX;
MACRO EXPRBASE=1,0,FULL$;
%2302% BIND ISNOTSFN = 0; ! Flag for CHASGN for this is not a
%2302% ! statement function. Calls to CASNM.
%2302% ! and CNCAM. are generated
%1254% MAP BASE LEFTSIDE;
%1254% IF .LEFTSIDE[VALTYPE] NEQ CHARACTER
%1254% THEN
BEGIN ! Numeric assignment
NAME_IDOFSTATEMENT_ASGNDATA;
NAME<RIGHT>_SORTAB;
R1_NEWENTRY();
R2_.STK[0];
R1[RHEXP]_.R2[ELMNT1] % EXPRESSION POINTER %;
R1[LHEXP]_R2_.LEFTSIDE;
ASGNTYPER(.R1); !CHECKING FOR ASSIGNMENT CONVERSION
R2 _ .R1[LHEXP]; !RESTORING EXP PTR INCASE OF TYPE CONVERSION NODE INSERTED
IF .R2[OPRCLS] EQL DATAOPR
THEN R1[A1VALFLG]_1
ELSE R2[PARENT] _ .R1;
R2 _ .R1[RHEXP]; !RESTORE RH EXP PTR
IF .R2[OPRCLS] EQL DATAOPR
THEN R1[A2VALFLG]_1
ELSE
BEGIN
R2[PARENT] _ .R1;
IF .R2[FNCALLSFLG]
THEN R1[FNCALLSFLG] _1
END;
END ! Numeric assignment
%1254% ELSE
BEGIN ! [1254] Character assignment
! Turn the node into a
%2302% ! CALL CASNM. (LHS,RHS) ! for CH1 = CH2
! or
%2302% ! CALL CNCAM. (LHS,RHS1,...,RHSn) ! for CH = CH1 // ... // CHn
LHS _ .LEFTSIDE; ! Get pointer to LHS expressnion
RHS _ @(.STK+1); ! Get pointer to RHS expression
%1455% R1 = CHASGN(.LHS, .RHS, ISNOTSFN);
END; ! [1254] Character assignment
SAVSPACE(.STK[0]<LEFT>,@STK[0]);
%1446% RETURN .R1; ! Finally, return the created statement
! so that our callers know we succeeded
END;
GLOBAL ROUTINE CHASGN(LHS, RHS, ISSFN)=
BEGIN
%1455% ! Moved out of MULTIASGN since it is also used by BLDSFN for
%1455% ! character statement functions. This routine converts
%2302% ! character assignments to calls to CASNM. or CNCAM. It also
%1455% ! converts a character statement function into either a call
%2302% ! to CHSFN. (the statement function form of CASNM.) or a
%2302% ! call to CHSFC. (the statement function form of CNCAM.).
%1455% ! CHSFC. is used if the character expression has
%1455% ! concatenations at its top level, CHSFN. is used for all
%1455% ! other character expressions.
%1455% MAP BASE LHS;
%1455% MAP BASE RHS;
%1455% MAP BASE R1;
%1455% MAP BASE R2;
EXTERNAL TBLSEARCH,CORMAN;
EXTERNAL E163;
IF .RHS[VALTYPE] NEQ CHARACTER ! If RHS is numeric
THEN FATLEX(E163<0,0>); ! "Illegal combination of
! character and numeric data"
NAME = IDOFSTATEMENT = CALLDATA; ! Make a CALL node
%1455% IF .ISSFN EQL 1
%1455% THEN
%1455% BEGIN ! Character statement function
R1 = CORMAN(); ! Get space for the node, don't
! link it into the source tree
%4514% R1[SRCID] = .IDOFSTATEMENT;
%4514% R1[OPRCLS] = STATEMENT;
%4514% IF (R1[SRCLBL] = .LABLOFSTATEMENT) NEQ 0 ! If any
%4514% THEN LABLOFSTATEMENT[SNHDR] = .R1;
%1455% END ! Character statement function
%1455% ELSE
%1455% BEGIN ! Character assignment
NAME<RIGHT> = SORTAB;
R1 = NEWENTRY(); ! Get space for the node, and
! link it into the source tree
%1455% END; ! Character assignment
NAME = IDTAB; ! Get symbol table pointer for
%2302% ! CASNM., CNCAM., CHSFN., or CHSFC.
%1455% IF .ISSFN EQL 1
%1455% THEN
%1455% BEGIN ! Character statement function
%1455% IF .RHS[OPRCLS] EQL CONCATENATION
%1455% THEN ENTRY = SIXBIT 'CHSFC.'
%1455% ELSE ENTRY = SIXBIT 'CHSFN.'
%1455% END ! Character statement function
%1455% ELSE
%1455% BEGIN ! Character assignment
%1455% IF .RHS[OPRCLS] EQL CONCATENATION
%2302% THEN ENTRY = SIXBIT 'CNCAM.'
%2302% ELSE ENTRY = SIXBIT 'CASNM.'
%1455% END; ! Character assignment
%4527% ENTRY = ONEWPTR(.ENTRY); ![1,,pointer]
R1[CALSYM] = R2 = TBLSEARCH();
IF NOT .FLAG ! If this was the first reference,
THEN ! set up the symbol table entry as a
BEGIN ! library function
R2[OPERSP] = FNNAME;
%2302% R2[IDLIBFNFLG] = 1; ! Set library function/subroutine flag
%2302% IF .ISSFN NEQ 1 ! Character assignment?
%2302% THEN R2[IDCLOBB] = 1; ! Yes, set flag saying ACs are smashed
END;
! If top node of RHS expression is concatenation, turn it into
%2302% ! a CNCAM. call, otherwise call CASNM.
IF .RHS[OPRCLS] EQL CONCATENATION
THEN
BEGIN ! Concatenation
MAP ARGUMENTLIST R2;
%2261% LOCAL BASE ARGH; ! Address of argument operand
R1[CALLIST] = R2 = .RHS[ARG2PTR];
! ARG2 of a CONCATENATION node
! is an arg list suitable for CALL
R2[1,ARGNPTR] = .LHS; ! Fill in first argument
IF .LHS[OPRCLS] EQL DATAOPR
THEN R2[1,AVALFLG] = 1
ELSE LHS[PARENT] = .R1;
! Check for character arguments with length of (*).
! The Fortran-77 specification does not allow them,
! but both Fortran-10/20 and VMS do.
%2261% IF FLAGANSI
%2261% THEN
%2261% INCR I FROM 2 TO .R2[ARGCOUNT]
%2261% DO BEGIN
%2261% ARGH=.R2[.I,ARGNPTR];
%2261% IF .ARGH[OPRCLS] EQL DATAOPR ! Is it data?
%2261% THEN IF SYMBOL(ARGH) ! Is it pointing to symbol?
%2261% THEN IF .ARGH[IDCHLEN] LSS 0
%2261% THEN EXITLOOP (WARNERR(.ISN,E221<0,0>))
%2261% END;
! Fix parent pointers of args 2-N. They currently
! point to the CONCATENATION node, change them to
! point to the CALL node.
INCR I FROM 2 TO .R2[ARGCOUNT]
DO
IF NOT .R2[.I,AVALFLG]
THEN
BEGIN
ARGH = .R2[.I,ARGNPTR];
ARGH[PARENT] = .R1;
END;
SAVSPACE(EXSIZ-1,.RHS); ! Toss the CONCATENATION node
END ! Concatenation
ELSE
BEGIN ! Non-concatenation
MAP ARGUMENTLIST R2;
%1413% NAME<LEFT> = ARGLSTSIZE(2); ! Allocate space for
! arg list with 2 args
R1[CALLIST] = R2 = CORMAN();
R2[ARGCOUNT] = 2; ! Set arg count to 2
R2[1,ARGNPTR] = .LHS; ! first arg is LHS
IF .LHS[OPRCLS] EQL DATAOPR
THEN R2[1,AVALFLG] = 1
ELSE LHS[PARENT] = .R1;
R2[2,ARGNPTR] = .RHS; ! second arg is RHS
IF .RHS[OPRCLS] EQL DATAOPR
THEN R2[2,AVALFLG] = 1
ELSE RHS[PARENT] = .R1;
END; ! Non-concatenation
BTTMSTFNFLG = 0; ! This isn't a bottommost function
! (ie, we destroy AC 16)
RETURN .R1;
END;
GLOBAL ROUTINE ASSIGNMENT=
BEGIN
EXTERNAL NAMSET,NAMDEF;
REGISTER BASE T1:T2;
EXTERNAL STK,SP,NEWENTRY %()%,SAVSPACE %(SIZE,LOC)%,MULTIASGN %()%,PROGNAME;
!------------------------------------------------------------------------------------------------------------------
! SYNTAX RETURNS A LIST POINTER (COUNT^18+LOC) IN STK[0]. THIS LIST CONTAINS:
!
! IDENTIFIER(20^18+LOC) - TO BE ASSIGNED
! POINTER TO LOGICAL EXPRESSION - (COUNT^18+LOC)
!
!------------------------------------------------------------------------------------------------------------------
T1_.STK[0]; !T1_LIST POINTER (COUNT^18+LOC)
T2_.T1[ELMNT]; !T2_LOC(IDENTIFIER)
% CHECK TO SEE IF ITS REALLY A VARIABLE %
IF NAMSET( VARIABL1, .T2 ) LSS 0 THEN RETURN .VREG;
% GENERATE THE ASSIGNMENT NODE %
MULTIASGN(.T2) ! GIVE IT THE LEFT HAND SIDE
END;
GLOBAL ROUTINE SUBASSIGN= ! [1247] New
! Substring assignment
BEGIN
EXTERNAL LEXEMEGEN,REFERENCE,EXPRESSION,COPYLIST;
REGISTER BASE LHS:RHS:VAR;
LEXL _ LEXEMEGEN();
IF (LHS _ REFERENCE()) LSS 0 THEN RETURN .VREG;
IF .LEXL<LEFT> NEQ EQUAL THEN RETURN ERR0L(.LEXNAM[EQUAL]);
IF (RHS _ EXPRESSION()) LSS 0 THEN RETURN .VREG;
%1517% IF .LEXL<LEFT> NEQ LINEND
%1517% THEN RETURN ERR0L(.LEXNAM[LINEND])
%1517% ELSE LSAVE _ 0;
%1661% VAR = .LHS[ARG4PTR];
%2534% VAR[IDATTRIBUT(STORD)] = 1;
%2534% IF .FLGREG<CROSSREF> THEN CREFIT( .VAR, SETT );
STK[0] _ .LHS;
STK[1] _ .RHS;
SP _ 1;
COPYLIST(-1);
RETURN MULTIASGN(.LHS);
END %SUBASSIGN%;
GLOBAL ROUTINE ASSISTA=
BEGIN
EXTERNAL SAVSPACE %(SIZE,LOC)%,BLDVAR %(VPNT)%,NEWENTRY %()%, ASIPTR,TBLSEARCH %()%,STK,TYPE,SETUSE,NAMSET;
EXTERNAL E147,E164;
MAP BASE ASIPTR;REGISTER BASE R1:R2;
!SEMANTIC ANALYSIS BEGINS
!--------------------------------------------------------------------------------
!THE CALL TO SYNTAX LEAVES A LIST POINTER ON THE STACK (STK[0]).
!THE POINTER POINTS TO THE LIST:
!
!LABEL (LABELEX^18+LOC) - THE LABEL TO BE ASSIGNED
!VARIABLESPEC - POINTER TO SCALAR OR ARRAY ELEMENT
!--------------------------------------------------------------------------------
R1_.STK[0]; !R1_LIST POINTER
% SET SETUSE FLAG FOR BLDVAR %
SETUSE _ SETT;
IF(STK[2]_R2_BLDVAR(.R1[ELMNT1])) LSS 0 THEN RETURN .VREG;
%1260% % DON'T ALLOW ASSIGN TO CHARACTER VARIABLE %
%1260% IF .R2[VALTYPE] EQL CHARACTER
%1260% THEN RETURN FATLEX(E164<0,0>);
% BLDVAR ALLOWS ARRAYS WITHOUT SUBSCRIPTS SO DON'T LET THEM THROUGH HERE %
IF .R2<LEFT> EQL IDENTIFIER
THEN IF .R2[OPRSP1] EQL ARRAYNM1
%4516% THEN RETURN FATLEX (.R2[IDSYMBOL], ARPLIT<0,0>, E4<0,0> );
%766% ! GIVE WARNING FOR ASSIGN INTO SUBSCRIPTED VARIABLE
%766% IF .R2<LEFT> EQL ARRAYREF
%766% THEN WARNLEX(E147<0,0>);
R2[IDATTRIBUT(INASSI)]_1;
NAME_IDOFSTATEMENT_ASSIDATA;NAME<RIGHT>_SORTAB;R2_NEWENTRY();
R2[ASILBL]_.R1[ELMNT];R2[ASISYM]_@STK[2];SAVSPACE(.R1<LEFT>,@R1);
![1150] Mark this label as having been ASSIGNed.
%[1150]% R1_.R2[ASILBL]; R1[SNASSIGNED]_1;
IF .ASIPTR<LEFT> EQL 0 THEN ASIPTR<LEFT>_ASIPTR<RIGHT>_@R2
ELSE
BEGIN
ASIPTR[ASILINK]_@R2;ASIPTR<RIGHT>_@R2
END;
.VREG
END;
GLOBAL ROUTINE GOTOSTA=
BEGIN
EXTERNAL SAVSPACE %(SIZE,LOC)%,TBLSEARCH %()%,NEWENTRY %()%,STK,NAMREF;
EXTERNAL EXPRTYPER,CNVNODE; !DOES TYPE CONVERSION IF NECESSARY
EXTERNAL E147,E164;
MACRO GETLAB =
INCR LLST FROM @STK[2] TO @STK[2]+.STK[2]<LEFT> DO
BEGIN
MAP BASE LLST;
LLST[ELMNT] _ .(@LLST[ELMNT])<RIGHT>
END
$;
LOCAL BASE T1; REGISTER BASE R1:T2:R2;
!SEMANTIC ANALYSIS BEGINS
!---------------------------------------------------------------------------------
!THE SYNTAX ROUTINE RETURNS A POINTER IN STK[0] TO THE LIST:
!
!CHOICE 1 - SIMPLE GOTO
! LABEL (LABELEX^18+LOC)
!CHOICE 2 - ASSIGNED OR COMPUTED GOTO
! CHOICE 1 - ASSIGNED GOTO
! COUNT^18+LOC - POINTER TO ASSIGNED VARIABLE AND LABEL LIST
! CHOICE 2 - COMPUTED GOTO
! COUNT^18+LOC - POINTER TO LABEL LIST AND CONTROL EXPRESSION
!
!SEE EXPANSION OF METASYMBOL GOTO FOR COMPLETE EXPANSION
!---------------------------------------------------------------------------------
R1_.STK[0]; !R1_LIST POINTER
IF .R1[ELMNT] EQL 1 THEN !CHOICE 1 - SIMPLE GOTO
BEGIN
%1665% ! Don't allow simple GOTO as last statement of a DO loop
%1665% IF .LABLOFSTATEMENT NEQ 0
%1665% THEN IF .LABLOFSTATEMENT[SNDOLVL] NEQ 0
%1665% THEN RETURN FATLEX(E67<0,0>); ! "Illegal DO object"
NAME_IDOFSTATEMENT_GOTODATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
T1[GOTOLBL]_.R1[ELMNT1];T1[GOTONUM]_T1[GOTOLIST]_0;
RETURN
END;
!------------------------------------------------------------------------------
!AT THIS POINT WE HAVE EITHER A COMPUTED OR ASSIGNED GOTO.
!R1[ELMNT1] TELLS US WHICH. CHOICE 1 = ASSIGNED GOTO,
!CHOICE 2 = COMPUTED GOTO.
!------------------------------------------------------------------------------
R2_.R1[ELMNT2]; !R2_LOC (ASSIGNED OR COMPUTED GOTO COMPONENTS)
IF .R1[ELMNT1] EQL 1 THEN !ASSIGNED GOTO
BEGIN
%1665% ! Don't allow assigned GOTO as last statement of a DO loop
%1665% IF .LABLOFSTATEMENT NEQ 0
%1665% THEN IF .LABLOFSTATEMENT[SNDOLVL] NEQ 0
%1665% THEN RETURN FATLEX(E67<0,0>); ! "Illegal DO object"
%1277% T1 _ .R2[ELMNT]; ! GET POINTER TO ID TABLE ENTRY
%1277% IF NAMREF(VARIABL1,.T1) LSS 0 THEN RETURN .VREG;
%1277% ! THIS STMT REFERENCES THE IDENTIFIER
%1277% STK[1] _ .T1;
%1260% % DON'T ALLOW GOTO CHARACTER VARIABLE %
%1260% IF .T1[VALTYPE] EQL CHARACTER
%1260% THEN RETURN FATLEX(E164<0,0>);
IF .R2[ELMNT1] NEQ 0 THEN !ASSIGNED GOTO WITH LABEL LIST
BEGIN
%2455% IF FLAGVMS THEN WARNERR(.ISN,E250<0,0>); !Comp Flagging
T1_.R2[ELMNT2];STK[2]_.T1[ELMNT1]; !SKIP OPTIONAL COMMA
GETLAB;
SAVSPACE(.R2[ELMNT2]<LEFT>,.R2[ELMNT2]);
STK[2]<LEFT> _ .STK[2]<LEFT>+1; !INCREMENT COUNT OF LABELS
END
ELSE STK[2]_0;NAME_IDOFSTATEMENT_AGODATA;
END
ELSE
BEGIN !COMPUTED GOTO
STK[2]_.R2[ELMNT];
GETLAB;
T2 _ STK[1] _.R2[ELMNT2]; !SKIP OPTIONAL COMMA
STK[2]<LEFT> _ .STK[2]<LEFT>+1; !INCREMENT COUNT OF LABELS
%1260% ! Don't allow GOTO character variable.
%1263% ! Allow character constant and make it hollerith.
%1263% IF .T2[OPERATOR] EQL CHARCONST
%1263% THEN T2[OPERATOR] _ HOLLCONST ! Make it hollerith
%1263% ELSE IF .T2[VALTYPE] EQL CHARACTER
%1260% THEN RETURN FATLEX(E164<0,0>); ! Character variable illegal
%2252% IF .T2[VALTYPE] NEQ INTEGER
%2252% THEN
%2252% BEGIN
%2252% IF FLAGANSI THEN WARNERR(.ISN,E258<0,0>); !Comp Flagging
%2252% STK[1] _ CNVNODE(.T2,INTEGER,0) ! Convert to integer
%2252% END;
NAME_IDOFSTATEMENT_CGODATA;
END;
SAVSPACE(.R1<LEFT>,@R1);
NAME<RIGHT>_SORTAB;T1_NEWENTRY();
!PTR TO LABEL NUM OF LABELS INLIST PTR TO LIST
T1[GOTOLBL]_.STK[1];T1[GOTONUM]_.STK[2]<LEFT>;T1[GOTOLIST]_.STK[2]<RIGHT>;
T2_.T1[GOTOLBL]; IF .T2[OPRCLS] NEQ DATAOPR THEN T2[PARENT] _ .T1;
.VREG
END;
GLOBAL ROUTINE CALLSTA=
BEGIN
!++
! Builds a CALL statement node. This routine expects to return a
! pointer in STK[0] to a subroutine name optionally followed by an
! argument list. See expansion of metasymbol call for details.
!--
REGISTER
BASE T2=2,
%[745]% BASE T1;
LOCAL
%1413% ARGUMENTLIST ARGNODE, ! Argument list node for subroutine
BASE CALLNODE, ! Call statement node.
%1413% CNT, ! Count for increment loop.
%[745]% BASE R1, ! Loaded from STK
%[745]% BASE SYMTAB; ! STE for subroutine name.
EXTERNAL E121;
EXTERNAL STK,
SAVSPACE %(SIZE,LOC)%,
CORMAN %()%,
NEWENTRY %()%,
TBLSEARCH %()%,
NAMSET,NAMREF,NAMDEF;
!SEMANTIC ANALYSIS BEGINS
R1_.STK[0];
SYMTAB_.R1[ELMNT]; !SYMTAB_LOC(SUBROUTINE NAME)
! Define and check the function name
%2507% SYMTAB[IDSUBROUTINE] = 1; ! This is a subroutine name
IF NAMREF( FNNAME1 , .SYMTAB ) LSS 0
THEN RETURN .VREG;
IF .SYMTAB[IDATTRIBUT(SFN)] THEN RETURN FATLERR(.ISN,E121<0,0>);
%1531% ! Subroutine names can't appear in SAVE statements.
%1531% IF .SYMTAB[IDSAVVARIABLE]
%1531% THEN FATLERR(.SYMTAB[IDSYMBOL],UPLIT(ASCIZ'Subroutine name'),
%1531% .ISN,E192<0,0>);
STK[1]_.SYMTAB;
!
!MAKE A CALL STATEMENT NODE
!
NAME_IDOFSTATEMENT_CALLDATA;
NAME<RIGHT>_SORTAB;
CALLNODE _ NEWENTRY();
IF .R1[ELMNT1] NEQ 0
THEN !ARGUMENT LIST
BEGIN
![745] REWRITE WHOLE ROUTINE TO HANDLE REAL LONG ARGUMENT LISTS
%[745]% LOCAL LISTPTR, TOTELMNTS;
%[745]% LISTPTR _ .R1[ELMNT2];
%[745]% TOTELMNTS _ 0;
%[745]% !CALCULATE TOTAL NUMBER OF PARAMETERS IN LIST
%[745]% INCR LISTNUM FROM 0 TO .LISTPTR<LEFT> DO
%[745]% TOTELMNTS_.TOTELMNTS+.(.LISTPTR<RIGHT>+.LISTNUM)<LEFT>+1;
%[745]% TOTELMNTS_.TOTELMNTS / 2; !GET REAL COUNT
%1466% ! Make an argument node.
%[745]% !Get free space for arg list
%[745]% NAME<LEFT> _ ARGLSTSIZE(.TOTELMNTS);
%1413% CALLNODE[CALLIST] _ ARGNODE _ CORMAN();
ARGNODE[ARGCOUNT] _ .TOTELMNTS; !Arg count
%1413% ARGNODE[ARGPARENT] _ .CALLNODE; !Pointer to call node
%1413% ! Arg checking is not possible for a dummy
%1413% ! routine name, LINK must know the name of the
%1413% ! subroutine at link-time.
%1677% IF NOT .SYMTAB[IDATTRIBUT(DUMMY)] THEN
%1413% ARGNODE[ARGCHBLOCK] _ 1; !Want arg check block
%[745]%
%1737% !Jump out of the routine here if number of arguments
%1737% !is zero.
%1737% !LISTPTR points to number of sets of arguments.
%1737% IF .TOTELMNTS NEQ 0
%1737% THEN
%1737% BEGIN ! Arguments exist.
%1737% ! Copy the arguments.
%1737%
%1737% CNT = 0;
%[745]% !Walk each of the potential lists of arguments
%[745]% INCR LISTNUM FROM 0 TO .LISTPTR<LEFT> DO
%[745]% BEGIN
%[745]% T1_@(.LISTPTR<RIGHT>+.LISTNUM);
%[745]%
%[745]% !LOOK AT EACH ELEMENT IN EACH LIST
INCR ARG FROM @T1 TO @T1+.T1<LEFT> BY 2 DO
BEGIN
MAP BASE ARG;
%1413% CNT _ .CNT+1; !One more argument
T2_.ARG[ELMNT1];
%1413% ARGNODE[.CNT,ARGNPTR] _ .T2;
%1413% ARGNODE[.CNT,AFLGFLD] _ 0;
IF .ARG[ELMNT] EQL 1
THEN
BEGIN ! Expression
IF .T2[OPRCLS] EQL DATAOPR
%1413% THEN
BEGIN
ARGNODE[.CNT,AVALFLG] _ 1;
IF .T2[OPRSP1] EQL ARRAYNM1
OR .T2[OPRSP1] EQL VARIABL1
%2557% THEN NAMSET(VARYREF, .T2 );
%2557% ! If the argument is a
%2557% ! function name, call
%2557% ! INTRCHK to check that
%2557% ! it has been declared
%2557% ! INTRINSIC and is a
%2557% ! specific function
%2557% ! name.
%2557% IF .T2[OPR1] EQL FNNAMFL
%2557% THEN INTRCHK(.T2);
END
ELSE
BEGIN
T2[PARENT] _ .CALLNODE;
IF .T2[OPRCLS] EQL ARRAYREF
THEN NAMSET( ARRAYNM1, .T2[ARG1PTR])
END;
END ! Expression
ELSE
BEGIN ! Statement number
%1413% ARGNODE[.CNT,AVALFLG] _ 1;
END;
![745] CLEAN UP AFTER ALL THE ARGUMENTS ARE DONE, AND RECLAIM FREE SPACE
%[745]% END;
%[745]% !FOR EACH PARTIAL ARGUMENT LIST
%[745]% SAVSPACE(.T1<LEFT>,.T1);
%[745]% !GO TO NEXT PARTIAL LIST
%[745]% T1_@(.R1[ELMNT2]+.LISTNUM);
%[745]% END;
%[745]% !CLEAN UP ALL PTRS TO ARGLISTS
%[745]% SAVSPACE(.LISTPTR<LEFT>,.R1[ELMNT2]);
%1737%
%1737% END; ! Arguments exist.
%[745]% END ! Parenthesis given on subroutine reference
%[745]% ELSE
%1466% BEGIN ! No parenthesis on subroutine reference
%1466%
%1466% NAME<LEFT> _ ARGLSTSIZE(0);
%1466% CALLNODE[CALLIST] _ ARGNODE _ CORMAN();
%1466% ARGNODE[ARGCOUNT] _ 0; !Arg count
%1466% ARGNODE[ARGPARENT] _ .CALLNODE; !Pointer to call node
%1466%
%1413% ! Arg checking is not possible for a dummy
%1413% ! routine name, LINK must know the name of the
%1413% ! subroutine at link-time.
%1677% IF NOT .SYMTAB[IDATTRIBUT(DUMMY)] THEN
%1466% ARGNODE[ARGCHBLOCK] _ 1; !Want arg check block
%1466%
%1466% END; ! No parenthesis on subroutine reference
%[745]% CALLNODE[CALSYM]_.STK[1];
FLGREG<BTTMSTFL>_0;
SAVSPACE(.R1<LEFT>,@R1);
END; ! of CALLSTA
GLOBAL ROUTINE RETUSTA=
BEGIN
! Semantics for RETURN statement
REGISTER BASE T1:R2;
EXTERNAL STK,EXPRTYPER,SAVSPACE %(size,loc)%,NEWENTRY %()%;
EXTERNAL LSAVE,LEXL,LEXNAME,EXPRESS,CNVNODE;
%1652% ! RETURN statements are meaningless in a main program, give a
%1652% ! warning.
%1652%
%1652% IF .FLGREG<PROGTYP> EQL MAPROG THEN FATLERR(.ISN,E209<0,0>);
LEXL _ LEXEMEGEN();
LSAVE _ -1;
IF .LEXL<LEFT> NEQ LINEND
THEN
BEGIN
IF ( STK[0] _ EXPRESS() ) LSS 0
THEN RETURN .VREG;
IF .LEXL<LEFT> NEQ EOSLEX
THEN RETURN NOEOSERRL
END
ELSE STK[0] _ 0;
!SEMANTIC ANALYSIS BEGINS
!---------------------------------------------------------------
! THIS ROUTINE EXPECTS IN STK[0], A POINTER TO AN OPTIONAL
! RETURN EXPRESSION OR 0.
!---------------------------------------------------------------
NAME _ IDOFSTATEMENT _ RETUDATA;
NAME<RIGHT> _ SORTAB;
R2 _ NEWENTRY();
R2[RETEXPR] _ T1 _ .STK[0];
IF .T1 NEQ 0
THEN
%2252% BEGIN !Optional RETURN expression
%2252% IF .T1[OPRCLS] NEQ DATAOPR THEN T1[PARENT] = .R2;
%2252% IF .T1[VALTYPE] NEQ INTEGER
%2252% THEN
%2252% BEGIN ! Non-integer expression
%2252% IF FLAGANSI THEN WARNERR(.ISN,E261<0,0>); !Comp Flagger
%2252% R2[RETEXPR] = CNVNODE(.T1,INTEGER,0) ! Convert to integer
%2252% END !Non-integer expression
%2252% END; !Optional RETURN expression
.VREG
END;
GLOBAL ROUTINE CONTSTA=
BEGIN
EXTERNAL NEWENTRY;
IF LEXEMEGEN() NEQ LINEND^18 THEN RETURN NOEOSERRV;
!SEMANTIC ANALYSIS BEGINS
NAME _ IDOFSTATEMENT _ CONTDATA; NAME<RIGHT>_SORTAB; NEWENTRY();
.VREG
END;
%[742]% GLOBAL ROUTINE LITOR6DIGIT=
BEGIN
!
!PARSES OPTIONAL [LITERAL OR 6-DIGIT STRING ] AFTER STOP OR PAUSE
!RETURNS LEXEME FOR EITHER
!
%1257% REGISTER BASE R2;
EXTERNAL GSTOPOBJ,STLEXEME,LEXICAL;
IF ( R2_LEXICAL( .GSTOPOBJ )) EQL 0
THEN
BEGIN % ITS NOT A DIGIT OR ' %
IF LEXICAL (.GSTLEXEME ) NEQ EOSLEX^18
THEN
BEGIN % AND ITS NOT ENDOF STATEMENT EITHER %
%[742]% RETURN FATLEX( PLIT'string or 6-digit integer?0',LEXPLITV,E0<0,0>)
END
% ELSE EOS IS OK %
END
ELSE
BEGIN % MAKE SURE THAT THERE WERE NO ERRORS IN THE OBJECT %
IF .R2 EQL EOSLEX^18
THEN RETURN -1; ! SOME SORT OF ERROR OCCURED
%OTHERWISE ITS AN INTEGER OR LITERAL
WHICH MUST BE FOLLOWED BY EOS %
IF LEXICAL(.GSTLEXEME) NEQ EOSLEX^18
THEN RETURN NOEOSERRV
END;
%1257% R2[OPERATOR] _ HOLLCONST; ! Change character constant arg into hollerith
RETURN .R2
END; % LITOR6DIGIT %
GLOBAL ROUTINE STOPSTA=
BEGIN
REGISTER BASE R1:R2;
%[742]% EXTERNAL STK,SAVSPACE %(SIZE,LOC)%,NEWENTRY %()%,LITOR6DIGIT;
%[742]% IF (R2 _ LITOR6DIGIT()) LSS 0 THEN RETURN -1;
NAME_IDOFSTATEMENT_STOPDATA;NAME<RIGHT>_SORTAB;R1_NEWENTRY();
R1[STOPIDENT]_@R2;
.VREG
END;
GLOBAL ROUTINE PAUSSTA=
BEGIN
REGISTER BASE R1:R2;
%[742]% EXTERNAL STK,SAVSPACE %(SIZE,LOC)%,NEWENTRY %()%,LITOR6DIGIT;
%[742]% IF (R2 _ LITOR6DIGIT()) LSS 0 THEN RETURN -1;
NAME_IDOFSTATEMENT_PAUSDATA;NAME<RIGHT>_SORTAB;R1_NEWENTRY();
R1[PAUSIDENT]_.R2;
.VREG
END;
GLOBAL ROUTINE IOBLD (NODEDATA,DEFUNIT,UNITFLAG)= ! [1465] New
!----------------------------------------------------------------------
!This routine expects a pointer in STK[0] to:
! pointer to:
! unit expression
! format expression
! encode/decode variable
! rec expression
! err label
! end label
! iostat variable
! key expression [4501]
! keyeq expression [4501]
! keyge expression [4501]
! keygt expression [4501]
! keyid expression [4501]
! option
! iolist
!----------------------------------------------------------------------
!
! For ENCODE and DECODE, the action routine that parses the keyword list
! guarantees that unit, format, and variable are all present.
BEGIN
REGISTER BASE T1;
REGISTER BASE R1:R2;
LOCAL IOL,
%1471% BASE DIMTBL;
! Offsets into semantic block built by KEYSCAN
STRUCTURE RBASE [I,J,K,L] =
CASE .I OF SET
%0% (\.RBASE +.J)<.K,.L>;
%1% (@\.RBASE +.J)<.K,.L>
TES;
BIND RBASE QUNIT = 0<FULL,R2>:
QFMT = 1<FULL,R2>:
QVAR = 2<FULL,R2>:
QREC = 3<FULL,R2>:
QEND = 4<FULL,R2>:
QERR = 5<FULL,R2>:
QIOSTAT = 6<FULL,R2>:
%4501% QKEYID = 7<FULL,R2>:
%4501% QKEYREL = 8<FULL,R2>:
%4501% QIOKEY = 9<FULL,R2>;
MACRO ILLSPECIFIER (NAME) =
%4527% RETURN FATLEX (ONEWPTR(SIXBIT 'NAME'), E184<0,0>)$;
%1510% MACRO ERR191(S) =
%1510% RETURN FATLEX (UPLIT ASCIZ 'S', E191<0,0>)$;
MACRO OK = .VREG$;
! Set statement type for LISTIO
TYPE = IF .NODEDATA EQL READDATA OR .NODEDATA EQL DECODATA
THEN READD
ELSE WRITEE;
R1 = .STK[0]; ! Get pointer to args
R2 = .R1[ELMNT];
! Fill in default UNIT if necessary. Check if UNIT was
! specified in a statement like TYPE or ACCEPT, where unit
! may not be specified.
IF .QUNIT EQL 0
%4503% THEN
%4503% BEGIN
%4503% IF .NODEDATA EQL REWRDATA
%4503% THEN FATLEX(E314<0,0>) ! UNIT must be specified for REWRITE
%4503% ELSE QUNIT = MAKECNST(INTEGER,0,.DEFUNIT)
%4503% END
ELSE IF NOT .UNITFLAG
THEN FATLEX(E201<0,0>); ! "UNIT may not be specified"
! Check UNIT. Legal forms are *, integer expression,
! character variable or array element or substring,
! or character array name.
IF .QUNIT^(-18) EQL ASTERISK
THEN
BEGIN ! UNIT=*
QUNIT = MAKECNST(INTEGER,0,.DEFUNIT);
END ! UNIT=*
ELSE IF .QUNIT[VALTYPE] EQL CHARACTER
THEN
BEGIN ! UNIT = character
%4503% IF .NODEDATA EQL REWRDATA THEN ILLSPECIFIER(UNIT)
%4503% ELSE IF .QUNIT[OPRCLS] EQL DATAOPR
%4503% THEN ! Don't allow bare
(IF .QUNIT[OPRSP1] EQL FNNAME1 ! function name
THEN ILLSPECIFIER(UNIT)
ELSE IF .QUNIT[OPERSP] EQL CONSTANT ! Don't allow
THEN ILLSPECIFIER(UNIT) ! char constant
%1510% ELSE IF .QUNIT[OPRSP1] EQL ARRAYNM1
%1510% THEN
%1510% BEGIN
%1510% DIMTBL = .QUNIT[IDDIM]; ! Get Dimesion Table
%1510% IF .DIMTBL[ASSUMESIZFLG] ! Don't allow assume
%1510% THEN ERR191(as unit specifiers); ! size array
%1510% END
ELSE OK)
ELSE IF .QUNIT[OPRCLS] EQL ARRAYREF THEN OK
ELSE IF .QUNIT[OPRCLS] EQL SUBSTRING THEN OK
ELSE ILLSPECIFIER(UNIT);
END ! UNIT = character
ELSE IF .QUNIT[OPRCLS] EQL RELATIONAL
! Don't allow any relational operator
THEN FATLEX(E200<0,0>) ! including # (was REC= delimiter, now
! gets parsed by EXPRESS as .NE.)
ELSE
BEGIN ! UNIT = numeric
IF .QUNIT[OPRCLS] EQL DATAOPR ! Don't allow bare array
THEN IF .QUNIT[PARENLSTFLG] ! name or function name
THEN ILLSPECIFIER(UNIT);
%2252% IF .QUNIT[VALTYPE] NEQ INTEGER
%2252% THEN !Non-integer UNIT
%2252% BEGIN
%2252% ANSICHECK('UNIT',E259); !Compatibility flagger
%2252% QUNIT = CNVNODE(.QUNIT,INTEGER,0) !Convert to integer
%2252% END;
END; ! UNIT = numeric
! Check FMT. Legal forms are *, character expression,
! character array name, statement label, numeric array name,
%2003% ! or integer, real, or logical variable name.
IF .QFMT EQL 0
THEN OK ! FMT not specified
ELSE IF .QFMT^(-18) EQL ASTERISK
%4503% THEN
%4503% BEGIN
%4503% IF .NODEDATA EQL REWRDATA
%4503% THEN FATLEX (UPLIT ASCIZ 'a rewrite statement',UPLIT ASCIZ 'an asterisk',E311<0,0>)
%4503% ELSE OK ! FMT = *
%4503% END
ELSE IF .QFMT[OPRCLS] EQL LABOP
THEN OK ! FMT = label
%1510% ELSE IF .QFMT[OPR2] EQL OPR2C(DATAOPR,ARRAYNAME)
%1510% THEN ! FMT = Array or Formal Array
%1510% BEGIN
%1510% DIMTBL = .QFMT[IDDIM]; ! Get Dimesion Table
%1510% IF .DIMTBL[ASSUMESIZFLG] ! Don't allow assumed-size
%1510% THEN ERR191(as format specifiers) ! array
%1510% ELSE OK
%1510% END
ELSE IF .QFMT[VALTYPE] EQL CHARACTER
THEN OK ! FMT = character expression
ELSE IF .QFMT[OPRCLS] NEQ DATAOPR
THEN ILLSPECIFIER(FMT) ! expression, but not type character
ELSE IF .QFMT[IDATTRIBUT(NAMNAM)]
%4503% THEN
%4503% BEGIN
%4503% IF .NODEDATA EQL REWRDATA
%4503% THEN FATLEX (UPLIT ASCIZ 'a rewrite statement',UPLIT ASCIZ 'a namelist',E311<0,0>)
%4503% ELSE OK ! FMT = namelist name
%4503% END
ELSE IF .QFMT[OPRSP1] EQL FNNAME1
THEN ILLSPECIFIER(FMT) ! FMT = function name
%2003% ELSE IF .QFMT[DATOPS1] NEQ VARIABL1
%2003% THEN ILLSPECIFIER(FMT) ! FMT not a variable
%2003%
%2003% ELSE IF .QFMT[VALTYPE] EQL INTEGER
%2003% THEN OK ! FMT = (assigned) integer variable
%2003%
%2003% ELSE IF .QFMT[VALTYPE] EQL REAL
%2003% THEN OK ! FMT = (assigned) real variable
%2003%
%2003% ELSE IF .QFMT[VALTYPE] EQL LOGICAL
%2003% THEN OK ! FMT = (assigned) logical variable
ELSE ILLSPECIFIER(FMT);
! Check REC. Convert it to integer if necessary. Also,
! cannot be used with FMT=*.
IF .QREC NEQ 0
%2252% THEN
%4503% BEGIN
%4503% IF .NODEDATA EQL REWRDATA THEN ILLSPECIFIER(REC);
%2252% IF .QREC[VALTYPE] NEQ INTEGER
%2252% THEN !Non-integer REC
%2252% BEGIN
%2252% ANSICHECK('REC',E259); !Compatibility flagger
%2252% QREC = CNVNODE(.QREC,INTEGER,0) !Convert to integer
%2252% END;
%4503% END;
IF .QFMT^(-18) EQL ASTERISK
THEN IF .QREC NEQ 0
THEN RETURN FATLEX (UPLIT 'random access?0', E101<0,0>);
! "List directed random access is illegal"
! ERR and END must be statement labels. No
! check necessary.
IF (.QEND NEQ 0) AND (.NODEDATA EQL REWRDATA) THEN ILLSPECIFIER(END);
! IOSTAT must be an integer variable name.
IF .QIOSTAT NEQ 0
THEN
BEGIN
IF .QIOSTAT[VALTYPE] NEQ INTEGER
THEN ILLSPECIFIER(IOSTAT);
END;
%4501% IF .NODEDATA EQL READDATA
%4501% THEN
%4501% BEGIN
%4501% ! indexed read is not ANSI compatible
%4501% IF (.QIOKEY NEQ 0) OR (.QKEYID NEQ 0)
%4501% THEN
%4526% BEGIN
%4526% IF NOT FTTENEX
%4526% THEN FATLEX (UPLIT ASCIZ 'key relation/key of reference specifiers',E322<0,0>);
%4501% IF FLAGANSI THEN WARNLEX(E309<0,0>);
%4526% END;
%4501%
%4501% ! if KEYID is specified then a key relation specifier must be specified
%4501%
%4501% IF (.QKEYID NEQ 0) AND (.QKEYREL EQL 0) AND (.QIOKEY EQL 0)
%4501% THEN FATLEX (E307<0,0>);
%4501% IF (.QIOKEY NEQ 0)
%4501% THEN
%4501% BEGIN
%4501% ! END= and REC= may not be specified in an indexed read
%4501% IF .QEND NEQ 0 THEN FATLEX (UPLIT ASCIZ 'END',E308<0,0>);
%4501% IF .QREC NEQ 0 THEN FATLEX (UPLIT ASCIZ 'REC',E308<0,0>);
%4501%
%4501% ! format can not be an asterisk or a namelist in a indexed read
%4501% IF .QFMT^(-18) EQL ASTERISK
%4501% THEN FATLEX (UPLIT ASCIZ 'in an indexed read',UPLIT ASCIZ 'an asterisk',E311<0,0>)
%4501% ELSE IF .QFMT[IDATTRIBUT(NAMNAM)]
%4501% THEN FATLEX (UPLIT ASCIZ 'in an indexed read',UPLIT ASCIZ 'a namelist',E311<0,0>);
%4501% END
%4501% END
%4501% ELSE
%4501% BEGIN
%4501% ! key relation specifiers may only be used in read statements
%4501% IF .QIOKEY NEQ 0 THEN FATLEX(E310<0,0>);
%4501% IF .QKEYID NEQ 0 THEN ILLSPECIFIER(KEYID);
%4501% END;
%1677% ! Check ENCODE/DECODE
%1677%
%1677% IF .QVAR NEQ 0
%1677% THEN
%1677% BEGIN ! ENCODE/DECODE
%1677% ! QUNIT is character count
%1677% IF .QUNIT[VALTYPE] NEQ INTEGER ! must be integer
%1677% THEN ILLSPECIFIER(UNIT);
%1677%
%1677% IF .QFMT^(-18) EQL ASTERISK ! FMT=* is illegal
%1677% THEN RETURN FATLEX (KEYWRD(@STMNDESC),E101<0,0>);
%1677% IF .QREC NEQ 0 ! REC= cannot be specified
%1677% THEN ILLSPECIFIER(REC);
%1677%
%1677% END; ! ENCODE/DECODE
! Do IO list
IF .R1[ELMNT1] EQL 0
THEN IOL = 0 ! No IO list
ELSE
BEGIN
T1 = .R1[ELMNT2]; ! Get pointer to tree
IOL = LISTIO(@@@.T1); ! Build IO list
IF .IOL LSS 0 THEN RETURN .IOL; ! If error, pass it on
SAVSPACE(0,@@.T1); ! Clean up
SAVSPACE(0,@.T1);
SAVSPACE(0,.T1);
END;
%2063% ! Check for illegal namelist directed I/O. It is not allowed in
%2063% ! REREAD, ENCODE, and DECODE statements. Also it can not be
%2063% ! used with an iolist.
IF .QFMT NEQ 0
THEN IF .QFMT[OPRCLS] EQL DATAOPR
THEN IF .QFMT[IDATTRIBUT(NAMNAM)]
THEN
%2063% BEGIN ! NAMELIST I/O
%2063% IF .QVAR NEQ 0 ! Prohibit it in ENCODE and DECODE
%2063% THEN RETURN FATLEX(UPLIT ASCIZ 'ENCODE and DECODE',E217);
%2063% IF .DEFUNIT EQL -6 ! Phohibit it in REREAD
%2063% THEN RETURN FATLEX(UPLIT ASCIZ 'REREAD',E217);
%2063% IF .IOL NEQ 0 ! Prohibit it with an iolist
%2063% THEN RETURN FATLEX(E102<0,0>);
%2063% END; ! NAMELIST I/O
%1715% ! Check for proper use of internal files, and note that the
%1715% ! CHARACTER variable has been stored into.
%1471% IF .QUNIT[VALTYPE] EQL CHARACTER
%1471% THEN
%1471% BEGIN ! Check Internal File
%1471% ! Make sure that there is a format.
%1471% IF .QFMT EQL 0
%1471% THEN RETURN FATLEX(UPLIT 'Unformatted I/O?0', E188<0,0>);
%1471% ! Make sure the format is not a NAMELIST.
%1471% IF .QFMT[OPRCLS] EQL DATAOPR
%1471% THEN IF .QFMT[IDATTRIBUT(NAMNAM)]
%1471% THEN RETURN FATLEX(UPLIT 'NAMELIST I/O?0', E188<0,0>);
%4553%
%1471% ! Make sure there is no REC= specifier
%1471% IF .QREC NEQ 0
%1471% THEN RETURN FATLEX (UPLIT 'Random access I/O?0', E188<0,0>);
%1715% IF .TYPE EQL WRITEE THEN QUNIT[IDATTRIBUT(STORD)] = 1;
%4501% ! Make sure NO indexed read key specifiers
%4501%
%4501% IF (.QIOKEY NEQ 0) OR (.QKEYID NEQ 0)
%4501% THEN FATLEX (UPLIT 'Indexed read key specifiers?0', E188<0,0>);
%1471% END; ! of Check Internal File
! Build statement node and fill it in
NAME = IDOFSTATEMENT = .NODEDATA;
NAME<RIGHT> = SORTAB;
T1 = NEWENTRY();
T1[IOUNIT] = .QUNIT;
T1[IORECORD] = .QREC;
T1[IOEND] = .QEND;
T1[IOERR] = .QERR;
T1[IOIOSTAT] = .QIOSTAT;
T1[IOLIST] = .IOL<LEFT>;
%4501% IF .QKEYID NEQ 0 THEN T1[IOKEYID] = .QKEYID;! KEYID field same as REC field
%4501% T1[IOKEYREL] = .QKEYREL;
%4501% T1[IOKEY] = .QIOKEY;
IF .QFMT^(-18) EQL ASTERISK
THEN T1[IOFORM] = -1
ELSE T1[IOFORM] = .QFMT;
%1677% IF .QVAR NEQ 0 ! ENCODE/DECODE?
%1677% THEN ! yes
%1677% BEGIN
%1677% T1[IOVAR] = .QVAR; ! set i/o variable
%1677% T1[IOCNT] = .QUNIT; ! set char count
%1677% END;
%1471% ! If the unit is a multi-record internal file, we will need
%1471% ! the total size of the array in characters. Store it in
%1471% ! the IORECORD field of the I/O statement. (IORECORD is
%1471% ! normally the random access I/O record number.)
%1471% IF .QUNIT[OPERATOR] EQL OPERC(CHARACTER,DATAOPR,ARRAYNAME)
%1471% OR .QUNIT[OPERATOR] EQL OPERC(CHARACTER,DATAOPR,FORMLARRAY)
%1471% THEN
%1471% BEGIN
%1471% DIMTBL = .QUNIT[IDDIM]; ! Pointer to dimension table
%1471% ! Get the size of the array in characters.
%1471% IF .DIMTBL[ADJDIMFLG]
%1471% THEN T1[IORECORD]=.DIMTBL[ARASIZ]
%1471% ELSE T1[IORECORD]=MAKECNST(INTEGER,0,.DIMTBL[ARASIZ]);
%1471% END;
! Set parent pointers of subexpression nodes
IF .QUNIT NEQ 0
THEN IF .QUNIT[OPRCLS] NEQ DATAOPR
THEN QUNIT[PARENT] = .T1;
IF .QFMT NEQ 0
%1546% THEN IF .QFMT^(-18) NEQ ASTERISK
THEN IF .QFMT[OPRCLS] NEQ DATAOPR
THEN IF .QFMT[OPRCLS] NEQ LABOP
THEN QFMT[PARENT] = .T1;
IF .QREC NEQ 0
THEN IF .QREC[OPRCLS] NEQ DATAOPR
THEN QREC[PARENT] = .T1;
! Process implicit DOs in the IO list
IODOXPN(.T1);
! Clean up
SAVSPACE(.R1<LEFT>,.R1);
SAVSPACE(.R2<LEFT>,.R2);
RETURN .T1;
END; ! IOBLD
GLOBAL ROUTINE BLDUTILITY (NODEDATA)= ! [1677] New
!----------------------------------------------------------------------
!This routine expects a pointer in STK[0] to:
! pointer to:
! unit expression
! format expression
! encode/decode variable
! rec expression
! err label
! end label
! iostat variable
! keyid
! key relational specifier
! iokey
!----------------------------------------------------------------------
BEGIN
REGISTER BASE T1;
REGISTER BASE R1:R2;
LOCAL IOL,
%1471% BASE DIMTBL;
! Offsets into semantic block built by KEYSCAN
STRUCTURE RBASE [I,J,K,L] =
CASE .I OF SET
%0% (\.RBASE +.J)<.K,.L>;
%1% (@\.RBASE +.J)<.K,.L>
TES;
BIND RBASE QUNIT = 0<FULL,R2>:
QFMT = 1<FULL,R2>:
QVAR = 2<FULL,R2>:
QREC = 3<FULL,R2>:
QEND = 4<FULL,R2>:
QERR = 5<FULL,R2>:
QIOSTAT = 6<FULL,R2>:
%4501% QKEYID = 7<FULL,R2>:
%4501% QKEYREL = 8<FULL,R2>:
%4501% QIOKEY = 9<FULL,R2>;
MACRO ILLSPECIFIER (NAME) =
%4527% RETURN FATLEX (ONEWPTR(SIXBIT 'NAME'), E184<0,0>)$;
MACRO OK = .VREG$;
R1 = .STK[0]; ! Get pointer to args
R2 = .R1[ELMNT];
! UNIT must be specified
IF .QUNIT EQL 0
THEN ILLSPECIFIER(UNIT);
! Check UNIT. Must be integer expression.
IF .QUNIT^(-18) EQL ASTERISK
THEN ILLSPECIFIER(UNIT)
ELSE IF .QUNIT[VALTYPE] EQL CHARACTER
THEN ILLSPECIFIER(UNIT)
ELSE IF .QUNIT[OPRCLS] EQL RELATIONAL
! Don't allow any relational operator
THEN FATLEX(E200<0,0>) ! including # (was REC= delimiter, now
! gets parsed by EXPRESS as .NE.)
ELSE
BEGIN ! UNIT = numeric
IF .QUNIT[OPRCLS] EQL DATAOPR ! Don't allow bare array
THEN IF .QUNIT[PARENLSTFLG] ! name or function name
THEN ILLSPECIFIER(UNIT);
%2252% IF .QUNIT[VALTYPE] NEQ INTEGER
%2252% THEN
%2252% BEGIN ! Non-integer UNIT
%2252% ANSICHECK('UNIT',E259); ! Compatibility flagging
%2252% QUNIT = CNVNODE(.QUNIT,INTEGER,0) !Convert to integer
%2252% END; ! Non-integer UNIT
END; ! UNIT = numeric
! FMT must be omitted
IF .QFMT NEQ 0
THEN ILLSPECIFIER(FMT);
! Check REC. Convert it to integer if necessary.
IF .QREC NEQ 0
%2252% THEN
%2252% IF .QREC[VALTYPE] NEQ INTEGER
%2252% THEN
%2252% BEGIN ! Non-integer REC
%2252% ANSICHECK('REC',E259); !Compatibility flagger
%2252% QREC = CNVNODE(.QREC,INTEGER,0) !Convert to integer
%2252% END; ! Non-integer REC
! ERR and END must be statement labels. No
! check necessary.
! IOSTAT must be an integer variable name.
IF .QIOSTAT NEQ 0
THEN
BEGIN
IF .QIOSTAT[VALTYPE] NEQ INTEGER
THEN ILLSPECIFIER(IOSTAT);
END;
%4501% IF .QKEYID NEQ 0 THEN ILLSPECIFIER(KEYID);
%4501% IF .QIOKEY NEQ 0 THEN FATLEX(E310<0,0>); ! keys can only be specified in read stm
! Build statement node and fill it in
NAME = IDOFSTATEMENT = .NODEDATA;
NAME<RIGHT> = SORTAB;
T1 = NEWENTRY();
T1[IOUNIT] = .QUNIT;
T1[IORECORD] = .QREC;
T1[IOEND] = .QEND;
T1[IOERR] = .QERR;
T1[IOIOSTAT] = .QIOSTAT;
! Set parent pointers of subexpression nodes
IF .QUNIT NEQ 0
THEN IF .QUNIT[OPRCLS] NEQ DATAOPR
THEN QUNIT[PARENT] = .T1;
IF .QREC NEQ 0
THEN IF .QREC[OPRCLS] NEQ DATAOPR
THEN QREC[PARENT] = .T1;
! Clean up
SAVSPACE(.R1<LEFT>,.R1);
SAVSPACE(.R2<LEFT>,.R2);
RETURN .T1;
END; ! BLDUTILITY
GLOBAL ROUTINE OPTCOMMA= ![1233] New
! Action routine to check for and skip over the optional comma in
! READ (1), X
!
! Also returns success if any token except EOL is seen (with or without comma),
! failure if EOL is seen, and failure plus an error message if a comma followed
! by EOL is seen.
BEGIN
IF .LSAVE EQL 0 THEN (LEXL_LEXEMEGEN(); LSAVE_-1); ! READ NEXT LEXEME
IF .LEXL<LEFT> EQL COMMA
THEN
BEGIN ! COMMA IS PRESENT
LEXL_LEXEMEGEN(); LSAVE_-1; ! READ COMMA
IF .LEXL<LEFT> NEQ LINEND ! COMMA FOLLOWED BY EOL?
THEN RETURN 0 ! NO, SUCCESS
ELSE RETURN FATLEX(.LEXNAME[IDENTIFIER],.LEXNAME[.LEXL<LEFT>],E0<0,0>); ! YES, ERROR
END;
IF .LEXL<LEFT> EQL LINEND THEN RETURN -1 ELSE RETURN 0
END;
GLOBAL ROUTINE CFSRCLIB (SYMTAB) = ! New in edit [2276]
!++
! FUNCTIONAL DESCRIPTION:
!
! Search a table of function and subroutine names for those subprograms
! which could cause an incompatibility with the VMS, or are an extension
! to the Fortran-77 standard.
!
! FORMAL PARAMETERS:
!
! SYMTAB is the pointer to the symbol table entry containing the name for
! which we search.
!
! IMPLICIT INPUTS:
!
! Symbol table entry
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! If the entry is found, the returned value is the CFTABLEV entry,
! which contains flags which describe the possible incompatibility.
! If the entry is not found, the returned value is zero.
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN
! The table of names of subroutines/functions which have some kind of conflict:
!
! This table must match CFTABLEV word for word.
! ****** BEWARE OF SKEWS *********
BIND CFTABLEN = UPLIT (
SIXBIT 'ACOSD',
SIXBIT 'ALG10.',
XALOG INDEXES SIXBIT 'ALOG',
SIXBIT 'ALOG.',
XALOG10 INDEXES SIXBIT 'ALOG10',
XAMAX1 INDEXES SIXBIT 'AMAX1',
SIXBIT 'AMAX1.',
XAMIN1 INDEXES SIXBIT 'AMIN1',
SIXBIT 'AMIN1.',
SIXBIT 'ASIND',
SIXBIT 'ASSIGN',
SIXBIT 'ATAN2D',
SIXBIT 'ATAND',
SIXBIT 'BITEST',
SIXBIT 'BJTEST',
SIXBIT 'CDABS',
SIXBIT 'CDCOS',
SIXBIT 'CDEXP',
SIXBIT 'CDLOG',
SIXBIT 'CDSIN',
SIXBIT 'CDSQRT',
SIXBIT 'CHKDIV',
SIXBIT 'CLOSE',
SIXBIT 'CLRFMT',
XCMPLX INDEXES SIXBIT 'CMPLX',
SIXBIT 'CMPLX.',
XCOSD INDEXES SIXBIT 'COSD',
SIXBIT 'COSD.',
XCOTAN INDEXES SIXBIT 'COTAN',
SIXBIT 'COTAN.',
SIXBIT 'DACOSD',
SIXBIT 'DASIND',
SIXBIT 'DATAN2', ! **** This is really DATAN2D *****
SIXBIT 'DATAND',
SIXBIT 'DATE',
SIXBIT 'DBLEQ',
SIXBIT 'DCMPLX',
SIXBIT 'DCONJG',
XDCOTAN INDEXES SIXBIT 'DCOTAN',
SIXBIT 'DCOTN.',
XDFLOAT INDEXES SIXBIT 'DFLOAT',
SIXBIT 'DFLOT.',
SIXBIT 'DIMAG',
SIXBIT 'DIVERT',
SIXBIT 'DREAL',
SIXBIT 'DTAND',
SIXBIT 'DTOGA',
SIXBIT 'DUMP',
SIXBIT 'ERRSET',
SIXBIT 'ERRSNS',
SIXBIT 'ERRTST',
SIXBIT 'EXIT',
SIXBIT 'FDBSET',
SIXBIT 'FFUNIT',
SIXBIT 'GCOTN.',
SIXBIT 'GFLOT.',
SIXBIT 'GTODA',
SIXBIT 'IDATE',
SIXBIT 'IIAND',
SIXBIT 'IIBCLR',
SIXBIT 'IIBITS',
%2300% SIXBIT 'IIBSET',
SIXBIT 'IIEOR',
SIXBIT 'IIOR',
SIXBIT 'IISHFT', !**** IISHFTC must be added later ****
SIXBIT 'ILL',
SIXBIT 'INOT',
SIXBIT 'IRAD50',
SIXBIT 'IZEXT',
SIXBIT 'JIAND',
SIXBIT 'JIBCLR',
SIXBIT 'JIBITS',
SIXBIT 'JIBSET',
SIXBIT 'JIEOR',
SIXBIT 'JIOR',
SIXBIT 'JISHFT', ! ***** JISHFTC must be added later *****
SIXBIT 'JNOT',
SIXBIT 'JZEXT',
SIXBIT 'LEGAL',
SIXBIT 'OVERFL',
SIXBIT 'PDUMP',
SIXBIT 'QACOS',
SIXBIT 'QACOSD',
SIXBIT 'QASIN',
SIXBIT 'QASIND',
SIXBIT 'QATAN',
SIXBIT 'QATAN2', ! ***** QATAN2D must be added later
SIXBIT 'QATAND',
SIXBIT 'QCOS',
SIXBIT 'QCOSD',
SIXBIT 'QCOSH',
SIXBIT 'QDIM',
SIXBIT 'QEXP',
SIXBIT 'QEXT',
SIXBIT 'QEXTD',
SIXBIT 'QLOG',
SIXBIT 'QLOG10',
SIXBIT 'QMAX1',
SIXBIT 'QMIN1',
SIXBIT 'QMOD',
SIXBIT 'QSIGN',
SIXBIT 'QSIN',
SIXBIT 'QSIND',
SIXBIT 'QSINH',
SIXBIT 'QSQRT',
SIXBIT 'QTAN',
SIXBIT 'QTAND',
SIXBIT 'QTANH',
SIXBIT 'R50ASC',
SIXBIT 'RAD50',
SIXBIT 'RANDU',
SIXBIT 'SAVFMT',
SIXBIT 'SAVRAN',
SIXBIT 'SECNDS',
SIXBIT 'SETRAN',
XSIND INDEXES SIXBIT 'SIND',
SIXBIT 'SIND.',
SIXBIT 'SNGLQ',
SIXBIT 'SORT',
SIXBIT 'TAND',
SIXBIT 'TIME',
SIXBIT 'TRACE',
SIXBIT 'USEREX',
TNBOT INDEXES SIXBIT 'ZEXT'
);
! Table of flag settings corresponding to the subroutines/functions.
! Entries for dotted names have the index to the true entry in left half, and
! zero in the right half.
! Entries for undotted names have zero in left half, and flags in right half.
!
! This table must match CFTABLEN word for word.
! ******* BEWARE OF SKEWS *********
BIND CFTABLEV = UPLIT (
%2455% CFFNVMS, !ACOSD
(XALOG10)^18, !ALG10.
%2455% CFNOTGNVMS, !ALOG
(XALOG)^18, !ALOG.
%2455% CFNOTGNVMS, !ALOG10
%2455% CFNOTGNVMS, !AMAX1
(XAMAX1)^18, !AMAX1.
%2455% CFNOTGNVMS, !AMIN1
(XAMIN1)^18, !AMIN1.
%2455% CFFNVMS, !ASIND
%2455% CFSBVMS, !ASSIGN
%2455% CFFNVMS, !ATAN2D
%2455% CFFNVMS, !ATAND
%2455% CFFNVMS, !BITEST
%2455% CFFNVMS, !BJTEST
CFNOTSBF77, !CDABS
CFNOTSBF77, !CDCOS
%2455% CFFNVMS+CFNOTSBF77, !CDEXP
%2455% CFFNVMS+CFNOTSBF77, !CDLOG
%2455% CFFNVMS+CFNOTSBF77, !CDSIN
%2455% CFFNVMS+CFNOTSBF77, !CDSQRT
%2455% CFNOTSBVMS+CFNOTSBF77, !CHKDIV
%2455% CFSBVMS, !CLOSE
CFNOTSBVMS+CFNOTSBF77, !CLRFMT
CFNOTFNF77, !CMPLX
(XCMPLX)^18, !CMPLX.
CFNOTFNF77+CFNOTGNUS, !COSD
(XCOSD)^18, !COSD.
%2455% CFNOTFNF77+CFNOTFNVMS, !COTAN
(XCOTAN)^18, !COTAN.
%2455% CFFNVMS, !DACOSD
%2455% CFFNVMS, !DASIND
%2455% CFFNVMS, !DATAN2D
%2455% CFFNVMS, !DATAND
CFSBDIFF+CFNOTSBF77, !DATE
%2455% CFFNVMS, !DBLEQ
%2455% CFFNVMS, !DCMPLX
%2455% CFFNVMS, !DCONJG
%2455% CFNOTFNF77+CFNOTFNVMS, !DCOTAN
(XDCOTAN)^18, !DCOTN.
CFNOTFNF77, !DFLOAT
(XDFLOAT)^18, !DFLOT.
%2455% CFFNVMS, !DIMAG
%2455% CFNOTSBVMS+CFNOTSBF77, !DIVERT
%2455% CFFNVMS, !DREAL
%2455% CFFNVMS, !DTAND
%2455% CFNOTSBVMS+CFNOTSBF77, !DTOGA
%2455% CFNOTSBVMS+CFNOTSBF77, !DUMP
CFSBDIFF+CFNOTSBF77, !ERRSET
CFSBDIFF+CFNOTSBF77, !ERRSNS
%2455% CFSBVMS, !ERRTST
CFSBDIFF+CFNOTSBF77, !EXIT
%2455% CFSBVMS, !FDBSET
%2455% CFNOTSBVMS, !FFUNIT
(XDCOTAN)^18, !GCOTN.
(XDFLOAT)^18, !GFLOT.
CFNOTSBVMS+CFNOTSBF77, !GTODA
%2455% CFSBVMS, !IDATE
%2455% CFFNVMS, !IIAND
%2455% CFFNVMS, !IIBCLR
%2455% CFFNVMS, !IIBITS
%2455% CFFNVMS, !IIBSET
%2455% CFFNVMS, !IIEOR
%2455% CFFNVMS, !IIOR
%2455% CFFNVMS, !IISHFT
%2455% CFNOTSBVMS+CFNOTSBF77, !ILL
%2455% CFFNVMS, !INOT
%2455% CFSBVMS, !IRAD50
%2455% CFFNVMS, !IZEXT
%2455% CFFNVMS, !JIAND
%2455% CFFNVMS, !JIBCLR
%2455% CFFNVMS, !JIBITS
%2455% CFFNVMS, !JIBSET
%2455% CFFNVMS, !JIEOR
%2455% CFFNVMS, !JIOR
%2455% CFFNVMS, !JISHFT
%2455% CFFNVMS, !JNOT
%2455% CFFNVMS, !JZEXT
%2455% CFNOTSBVMS+CFNOTSBF77, !LEGAL
%2455% CFNOTSBVMS+CFNOTSBF77, !OVERFL
%2455% CFNOTSBVMS+CFNOTSBF77, !PDUMP
%2455% CFFNVMS, !QACOS
%2455% CFFNVMS, !QACOSD
%2455% CFFNVMS, !QASIN
%2455% CFFNVMS, !QASIND
%2455% CFFNVMS, !QATAN
%2455% CFFNVMS, !QATAN2
%2455% CFFNVMS, !QATAND
%2455% CFFNVMS, !QCOS
%2455% CFFNVMS, !QCOSD
%2455% CFFNVMS, !QCOSH
%2455% CFFNVMS, !QDIM
%2455% CFFNVMS, !QEXP
%2455% CFFNVMS, !QEXT
%2455% CFFNVMS, !QEXTD
%2455% CFFNVMS, !QLOG
%2455% CFFNVMS, !QLOG10
%2455% CFFNVMS, !QMAX1
%2455% CFFNVMS, !QMIN1
%2455% CFFNVMS, !QMOD
%2455% CFFNVMS, !QSIGN
%2455% CFFNVMS, !QSIN
%2455% CFFNVMS, !QSIND
%2455% CFFNVMS, !QSINH
%2455% CFFNVMS, !QSQRT
%2455% CFFNVMS, !QTAN
%2455% CFFNVMS, !QTAND
%2455% CFFNVMS, !QTANH
%2455% CFSBVMS, !R50ASC
%2455% CFSBVMS, !RAD50
%2455% CFSBVMS, !RANDU
%2455% CFNOTSBVMS+CFNOTSBF77, !SAVFMT
%2455% CFNOTSBVMS+CFNOTSBF77, !SAVRAN
%2455% CFSBVMS, !SECNDS
%2455% CFNOTSBVMS+CFNOTSBF77, !SETRAN
CFNOTFNF77+CFNOTGNUS, !SIND
(XSIND)^18, !SIND.
%2455% CFFNVMS, !SNGLQ
%2455% CFNOTSBVMS+CFNOTSBF77, !SORT
%2455% CFFNVMS, !TAND
CFSBDIFF+CFNOTSBF77, !TIME
%2455% CFNOTSBVMS+CFNOTSBF77, !TRACE
%2455% CFSBVMS, !USEREX
%2455% CFFNVMS !ZEXT
);
MAP BASE SYMTAB; ! Symbol Table entry
LOCAL
TOP, ! Index to first viable entry
BOTTOM; ! Index to last viable entry
REGISTER
NAME, ! Name for which we search
CENTER; ! Index to current entry
%4527% ! Our names are only 6 characters (one word) long. Give up now if
%4527% ! the name if over that length.
%4527%
%4527% IF .SYMTAB[IDSYMLENGTH] GTR 1 THEN RETURN 0;
%4527% NAME = .SYMTAB[ID1ST6CHAR]; ! Name from symbol table entry
TOP = 0; ! Start looking at
BOTTOM = (TNBOT); ! the entire table
! Loop until:
! Entry found, in which case return the CFTABLEV entry,
! or all entries examined, in which case return zero
%2303% WHILE .BOTTOM GEQ .TOP
%2303% DO
%2303% BEGIN ! Look for entry
CENTER = (.TOP + .BOTTOM) / 2; ! Look here
IF .NAME EQL .CFTABLEN[.CENTER]
THEN
BEGIN ! Entry matches
IF (TOP = .CFTABLEV[.CENTER]<LEFT>) NEQ 0
%2303% THEN CENTER = .TOP; ! Index to undotted name
RETURN .CFTABLEV[.CENTER]
END; ! Entry matches
IF .NAME GTR .CFTABLEN[.CENTER]
THEN TOP = .CENTER + 1 ! Ignore old top thru center
ELSE BOTTOM = .CENTER -1; ! Ignore center thru old bottom
%2303% END; ! Look for entry
RETURN 0 ! No match
END; ! of CFSRCLIB
GLOBAL ROUTINE READSTA=
%1546% IOBLD(READDATA,-5,TRUE);
GLOBAL ROUTINE WRITSTA=
%2261% BEGIN
%2261% REGISTER BASE R;
%2261% STRUCTURE RBASE [I,J,K,L] =
%2261% CASE .I OF SET
%2261% (\.RBASE +.J)<.K,.L>; !0
%2261% (@\.RBASE +.J)<.K,.L> !1
%2261% TES;
%2261% BIND RBASE QUNIT = 0<FULL,R>;
%2261%
%2261% IF FLAGEITHER
%2261% THEN ! Check for default unit
%2261% BEGIN
%2261% R=.STK[0];
%2261% R=.R[ELMNT];
%2261% IF .QUNIT EQL 0 THEN CFLAGB(E285<0,0>)
%2261% END;
%1546% IOBLD(WRITDATA,-3,TRUE)
%2261% END; ! of WRITSTA
GLOBAL ROUTINE REWRSTA=
!++
! FUNCTIONAL DESCRIPTION:
!
! Perform keyword processing for the REWRITE statement
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! STK Points to the address of the block of specifiers built
! by KEYSCAN
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! Rewrite statement node
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN ![4503] New
%4526% IF NOT FTTENEX THEN FATLEX (UPLIT ASCIZ 'REWRITE statement',E322<0,0>);
ANSICHECK('REWRITE',E267);
IOBLD(REWRDATA,-3,TRUE);
END; ! of REWRSTA
GLOBAL ROUTINE TYPESTA=
%2247% BEGIN
%2247% ANSICHECK('TYPE',E267);
%1546% IOBLD(WRITDATA,-1,FALSE)
%2247% END; ! of TYPESTA
GLOBAL ROUTINE PUNCSTA=
%2247% BEGIN
%2247% FLAGCHECK('PUNCH',E268);
%1546% IOBLD(WRITDATA,-2,FALSE)
%2247% END; ! of PUNCSTA
GLOBAL ROUTINE PRINSTA=
%2261% BEGIN
%2261% IF FLAGEITHER
%2261% THEN IF .IOSPEC THEN CFLAGB(E269<0,0>);
%1546% IOBLD(WRITDATA,-3,FALSE)
%2261% END; ! of PRINSTA
GLOBAL ROUTINE ACCESTA=
%2247% BEGIN
%2247% ANSICHECK('ACCEPT',E267);
%1546% IOBLD(READDATA,-4,FALSE)
%2247% END; ! of ACCESTA
GLOBAL ROUTINE RERESTA=
%2247% BEGIN
%2247% FLAGCHECK('REREAD',E268);
%1546% IOBLD(READDATA,-6,FALSE);
%2247% END; ! of RERESTA
GLOBAL ROUTINE ENCOSTA=
%2252% BEGIN
%2252% IF FLAGANSI THEN WARNERR(.ISN,E233<0,0>); !Compatibility flagger
%1677% IOBLD(ENCODATA,0,TRUE);
%2252% END;
GLOBAL ROUTINE DECOSTA=
%2252% BEGIN
%2252% IF FLAGANSI THEN WARNERR(.ISN,E232<0,0>); !Compatibility flagger
%1677% IOBLD(DECODATA,0,TRUE);
%2252% END;
! Below is for RUNOFF in generating .PLM files
!++
!.END LITERAL
!--
END
ELUDOM