Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_V7wLink_Feb83
-
sta0.bli
There are 26 other files named sta0.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 1973, 1983
!AUTHOR: F.J. INFANTE/HPW/ D. B. TOLMAN/DCE/TFV/CKS/CDM/AHM/RVM
MODULE STA0(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND STA0V = 7^24 + 0^18 + #1715; ! Version Date: 12-Jan-83
%(
***** 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 Revision History *****
)%
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE META72.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;
!THE NUMBER IN COMMENT'S IS THE STATEMENTS LOCATION
!IN THE HASH TABLE .
FORWARD
MULTIASGN,
ASSIGNMENT, ! ASSIGNMENT
%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
CNVNODE,
E102,
E184,
E188,
E191,
E192, ! "Illegal in SAVE statement"
E200,
E201,
%1652% E209, ! "RETURN illegal in main routine"
%1652% FATLERR,
IODOXPN,
BASE LABLOFSTATEMENT,
LEXNAME,
LISTIO,
NAMLSTOK,
NAMSET,
NEWENTRY,
SAVSPACE,
STMNDESC;
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$;
%1455% BIND ISNOTSFN = 0; ! Flag for CHASGN. for this is not a
! statement function. Calls to CHASN.
! and CONCA. 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
! CALL CHASN. (LHS,RHS) ! for CH1 = CH2
! or
! CALL CONCA. (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
%1455% ! character assignments to calls to CHASN. or CONCA. It also
%1455% ! converts a character statement function into either a call
%1455% ! to CHSFN. (the subroutine form of CHASN.) or a call to
%1455% ! CHSFC. (the subroutine form of CONCA.). CHSFC. is used if
%1455% ! the character expression has concatenations at its top
%1455% ! level, CHSFN. is used for all 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
%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
! CHASN., CONCA., 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
%1455% THEN ENTRY = SIXBIT 'CONCA.'
%1455% ELSE ENTRY = SIXBIT 'CHASN.'
%1455% END; ! Character assignment
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;
R2[IDLIBFNFLG] = 1
END;
! If top node of RHS expression is concatenation, turn it into
! a CONCA. call, otherwise call CHASN.
IF .RHS[OPRCLS] EQL CONCATENATION
THEN
BEGIN ! Concatenation
MAP ARGUMENTLIST R2;
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;
! 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
LOCAL BASE ARGH;
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% ! If LHS is a substring of a scalar, call NAMSET to set STORD for it
%1661% VAR = .LHS[ARG4PTR];
%1661% IF .VAR[OPRCLS] EQL DATAOPR
%1661% THEN IF NAMSET(VARIABL1,.VAR) LSS 0
%1661% THEN RETURN .VREG;
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
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
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
IF .T2[VALTYPE] NEQ INTEGER THEN STK[1] _ CNVNODE(.T2,INTEGER,0);
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.
REGISTER T2=2;
%[745]% REGISTER BASE T1;
MAP BASE T2;
%[745]% LOCAL BASE R1:SYMTAB;
%1413% LOCAL ARGUMENTLIST ARGNODE; !Argument list node for subroutine
%1413% LOCAL CNT; !Count for increment loop.
EXTERNAL E121;
EXTERNAL STK,
SAVSPACE %(SIZE,LOC)%,
CORMAN %()%,
NEWENTRY %()%,
TBLSEARCH %()%,
NAMSET,NAMREF,NAMDEF;
MACRO
CARGPTR=0,0,RIGHT$,
CAFLGFLD=0,0,LEFT$,
ERR15(X) = RETURN FATLEX(X,SYMTAB[IDSYMBOL],E15<0,0>) $;
MACHOP BLT=#251;
LOCAL BASE CALLNODE;
!SEMANTIC ANALYSIS BEGINS
!------------------------------------------------------------------
! 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.
!------------------------------------------------------------------
R1_.STK[0];
SYMTAB_.R1[ELMNT]; !SYMTAB_LOC(SUBROUTINE NAME)
% DEFINE AND CHECK THE FUNCTION 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. Do also if /DEBUG:ARGUMENTS is
%1466% ! specified and the number of arguments is zero.
%[1217]% IF .TOTELMNTS NEQ 0
%1613% OR .FLGREG<DBGARGMNTS>
%1466% THEN
%[1217]% BEGIN ! Arg list is to be made
%[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]%
%[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
%1413% CNT _ 0;
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 !EXPRESSION
BEGIN
IF .T2[OPRCLS] EQL DATAOPR
%1413% THEN
BEGIN
ARGNODE[.CNT,AVALFLG] _ 1;
IF .T2[OPRSP1] EQL ARRAYNM1
OR .T2[OPRSP1] EQL VARIABL1
THEN NAMSET(VARYREF, .T2 )
END
ELSE
BEGIN
T2[PARENT] _ .CALLNODE;
IF .T2[OPRCLS] EQL ARRAYREF
THEN NAMSET( ARRAYNM1, .T2[ARG1PTR])
END;
END
ELSE !STATEMENT NUMBER
BEGIN
%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;
%1466% IF .TOTELMNTS NEQ 0 THEN
%[745]% !CLEAN UP ALL PTRS TO ARGLISTS
%[745]% SAVSPACE(.LISTPTR<LEFT>,.R1[ELMNT2]);
!**;[1217], CALLSTA, DCE, 28-May-81
%[1217]% END ! Arg list is to be made
%[745]% END ! Parethesis given on subroutine reference
%[745]% ELSE ! No parenthisis on subroutine reference
%1466% BEGIN
%1613% IF .FLGREG<DBGARGMNTS>
%1466% THEN ! /DEBUG:ARGUMENTS specified
%1466% BEGIN ! Create arg list for arg checking
%1466% NAME<LEFT> _ ARGLSTSIZE(0);
%1466% CALLNODE[CALLIST] _ ARGNODE _ CORMAN();
%1466% ARGNODE[ARGCOUNT] _ 0; !Arg count
%1466% 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
%1466% ARGNODE[ARGCHBLOCK] _ 1; !Want arg check block
%1466% END;
%1466% END; ! No parenthisis 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 (IF .T1[OPRCLS] NEQ DATAOPR THEN T1[PARENT] _ .R2;
IF .T1[VALTYPE] NEQ INTEGER THEN R2[RETEXPR] _ CNVNODE(.T1,INTEGER,0);
);
.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
! 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>;
MACRO ILLSPECIFIER (NAME) =
RETURN FATLEX (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
THEN QUNIT = MAKECNST(INTEGER,0,.DEFUNIT)
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
IF .QUNIT[OPRCLS] EQL DATAOPR 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);
IF .QUNIT[VALTYPE] NEQ INTEGER ! Convert to integer if
THEN QUNIT = CNVNODE(.QUNIT,INTEGER,0); ! necessary
END; ! UNIT = numeric
! Check FMT. Legal forms are *, character expression,
! character array name, statement label, numeric array name,
! or integer variable name.
IF .QFMT EQL 0
THEN OK ! FMT not specified
ELSE IF .QFMT^(-18) EQL ASTERISK
THEN OK ! FMT = *
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)]
THEN OK ! FMT = namelist name
ELSE IF .QFMT[OPRSP1] EQL FNNAME1
THEN ILLSPECIFIER(FMT) ! FMT = function name
ELSE IF .QFMT[VALTYPE] EQL INTEGER
THEN OK ! FMT = (assigned) integer variable
ELSE ILLSPECIFIER(FMT);
! Check REC. Convert it to integer if necessary. Also,
! cannot be used with FMT=*.
IF .QREC NEQ 0
THEN IF .QREC[VALTYPE] NEQ INTEGER
THEN QREC = CNVNODE(.QREC,INTEGER,0);
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.
! IOSTAT must be an integer variable name.
IF .QIOSTAT NEQ 0
THEN
BEGIN
IF .QIOSTAT[VALTYPE] NEQ INTEGER
THEN ILLSPECIFIER(IOSTAT);
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%
%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;
! Check for namelist directed IO with an IO list
IF .QFMT NEQ 0
THEN IF .QFMT[OPRCLS] EQL DATAOPR
THEN IF .QFMT[IDATTRIBUT(NAMNAM)]
THEN IF .IOL NEQ 0
THEN RETURN FATLEX(E102<0,0>);
%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>);
%1471% ! Make sure the format is not asterisk.
%1471% IF .QFMT^(-18) EQL ASTERISK
%1471% THEN RETURN FATLEX(UPLIT 'List directed I/O?0',E188<0,0>);
%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;
%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>;
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
!----------------------------------------------------------------------
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>;
MACRO ILLSPECIFIER (NAME) =
RETURN FATLEX (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);
IF .QUNIT[VALTYPE] NEQ INTEGER ! Convert to integer if
THEN QUNIT = CNVNODE(.QUNIT,INTEGER,0); ! necessary
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
THEN IF .QREC[VALTYPE] NEQ INTEGER
THEN QREC = CNVNODE(.QREC,INTEGER,0);
! 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;
! 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 READSTA=
%1546% IOBLD(READDATA,-5,TRUE);
GLOBAL ROUTINE WRITSTA=
%1546% IOBLD(WRITDATA,-3,TRUE);
GLOBAL ROUTINE TYPESTA=
%1546% IOBLD(WRITDATA,-1,FALSE);
GLOBAL ROUTINE PUNCSTA=
%1546% IOBLD(WRITDATA,-2,FALSE);
GLOBAL ROUTINE PRINSTA=
%1546% IOBLD(WRITDATA,-3,FALSE);
GLOBAL ROUTINE ACCESTA=
%1546% IOBLD(READDATA,-4,FALSE);
GLOBAL ROUTINE RERESTA=
%1546% IOBLD(READDATA,-6,FALSE);
GLOBAL ROUTINE ENCOSTA=
%1677% IOBLD(ENCODATA,0,TRUE);
GLOBAL ROUTINE DECOSTA=
%1677% IOBLD(DECODATA,0,TRUE);
END
ELUDOM