Trailing-Edge
-
PDP-10 Archives
-
bb-4157h-bm_fortran20_v10_16mt9
-
fortran-compiler/expres.bli
There are 12 other files named expres.bli in the archive. Click here to see a list.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1973, 1985
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
!AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!AUTHOR: F.J. INFANTE, D. B. TOLMAN/DCE/JNG/TFV/EGM/CKS/CDM/AHM/SRM/RVM/AlB
MODULE EXPRES(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND EXPREV = #10^24 + 0^18 + #2517; ! Version Date: 1-Feb-85
%(
***** Begin Revision History *****
24 ----- ----- CODE TO WORRY ABOUT STATEMENT FUNCTION DUMMIES
HAS BEEN REMOVED SINCE THEY ARE NOW
SPECIAL GENERATED SUBLOCAL VARIABLES
CODE TO WORRY ABOUT VARIABLES THE SAME AS FUNCTION
NAMES HAS BEEN REMOVED SINCE THE NAME OF THE FUNCTION
CURRENTLY BEING COMPILED NO LONGER HAS FNNAME SET
ON IT
25 ----- ----- DON'T LET DUMMY ARGUMENTS WHICH HAPPEN TO BE LIBRARY
FUNCTION NAMES TURN INTO LIBRARY FUNCTION CALLS
26 ----- ----- PICK UP THE .ED NAMES FOR ACTUAL PARAMETER
LIBRARY FUNCITONS
THE ROUTINE LIBSRCH HAS BEEN CHANGED TO SRCHLIB
WITH A SYMBOL TABLE POINTER AS PARAMETER
27 ----- ----- CLEAR THE ARG1PTR FOR NEGNOT NODES IN MACRO
BLDTREE
28 ----- ----- IMMEDIATELY NEGATE ALL CONSTANTS PRECEEDED BY
UNARY MINUS. ROUTINE PRIMITIVE
29 ----- ----- DETECT A .NOT. B IN MACRO BLDTREE
30 ----- ----- REMOVE THE CONVERSION NODE INSERT CODE
FOR UNARY NEGATION OF DOUBLE OCTAL AND LET
NEGCNST DO IT NOW THAT CONSTANTS ARE IMMEDIATELY NEGATED
ROUTINE PRIMITIVE
31 ----- ----- FIX PRIMITIVE SO THAT IT WILL NOT MAKE NAMSET
CALLS FOR LIBRARY ROUTINE ACTUAL PARAMETERS
32 542 22147 MAKE NOT NODES BE OF TYPE LOGICAL, (DCE)
33 626 23169 DON'T ALLOW FUNCTION OR ARRAY NAMES WITHOUT
PARENTHESIZED LISTS TO APPEAR IN EXPRESSIONS
IN ARGUMENT LISTS, E.G. CATCH FN(A+3), WHERE
FN IS A FUNCTION AND A IS AN ARRAY., (JNG)
***** Begin Version 6 *****
34 761 TFV 1-Mar-80 -----
Choose either KLDP or GFLOATING dotted name for generic functions.
Convert DP to SP based on /GFLOATING
35 1004 TFV 1-Jul-80 ------
Fix dottednames to lookup /GFLOATING routines only for doubleprecision.
Replace VREG with temp.
36 1043 EGM 19-Jan-81 20-15466
***NOT INCLUDED IN VERSION 7***
Generate warning for consecutive arithmetic operands.
37 1056 DCE 3-Mar-81 -----
Put type conversion node beneath .NOT. node if necessary (for register
allocation especially).
38 1072 CKS 22-May-81 Q20-1524
***NOT INCLUDED IN VERSION 7***
Remove consecutive arithmetic operators illegal message until it can be
put under flagger switch
***** Begin Version 7 *****
39 1202 DCE 1-Jul-80 -----
Add routine NOLPAR to assist with implementation of expressions
in output lists.
40 1203 DCE 21-Nov-80 -----
Change the world to do I/O list parsing here. Add NOTEOL and
BEXPRLIST; remove old NOLPAR. Remove all the parsing from the BNF.
Now I/O lists and expressions will share a good deal of common code!
41 1235 CKS 1-Jul-81 -----
Add ERREOL to type an error message for "TYPE *,". Without this crock,
that statement does not parse, does not generate code, but does not get
an error message either.
42 1243 CKS 30-Jul-81
Add PRCDNCE23, precedence for lexeme 23, CONCAT, the // concatenation
operator.
43 1244 CKS 2-Aug-81
Make REFERENCE understand substring references. Make PRIMITIVE
understand concatenation.
44 1255 TFV 14-Aug-81 ------
Fix LOGEXPRESSION to handle character relational expressions.
Turn them into calls to CH.xx. (EQ, NE, LT, LE, GT, GE). (The
names changed to Lxx. in edit 1422.)
45 1262 CKS 21-Sep-81
Add action routines COLNEXP and RPAREXP to parse the
optional expressions that occur in substring bounds
46 1264 CDM 25-Sept-81
Change name of MAKLIBFUN to MAKLIBFN, the name as declared in
GNRCFN.BLI.
47 1270 CDM 6-Oct-81
Add additional parameter to MAKLIBFN call.
48 1400 CKS 20-Oct-81
Modify REFERENCE to allow null argument list in function calls
49 1413 CDM/AHM 4-Nov-81
Modify REFERENCE to use ARGUMENTLIST structure in storing argument
nodes. Also, make PRIMITIVE and MAKECALL allow for the extra parent
word when they are creating an argument list for concetenation and
character relational library subroutine calls.
50 1422 TFV 12-Nov-81 ------
Change name of MAKCALL to MAKECALL. Change the names in
MAKECALL from CH.xx. to Lxx. (These are character relationals
which become function calls). Change REFERENCE to generate an
extra argument for character functions; it is the .Dnnnn
variable for the result.
51 1425 CDM 1-Dec-81
Creation of MAKEFN to simplifly REFERENCE which is getting humongous.
REFERENCE is recursive and was using too much stack space from too
many LOCAL variables.
52 1427 CKS 2-Dec-81
MAKESUBSTR was not defaulting the upper bound of A(I)(:) correctly. It
was setting the upper bound from IDCHLEN of the ARRAYREF node. Follow
down to the base of an array ref and set from IDCHLEN from that.
53 1434 TFV 14-Dec-81 ------
MAKEFN has to process character functions after checking for
library functions. It will call CHARGLIST to build a character
function argulment list form a non-character function argument
list.
54 1431 CKS 15-Dec-81
Get VALFLGs right in substring nodes
55 1436 SRM 16-Dec-81
Set CHARUSED if see // or ( : )
56 1456 CKS 11-Jan-82
Call NAMSET (as opposed to NAMREF) for variables which appear in
input lists. Use a new bit in the statement descriptor block to
recognize input statements. Can't use TYPE since EXPRESS is an
action routine called during the parse, before the semantic routine
has a chance to set TYPE correctly.
57 1466 CDM 1-Feb-82
Perform compile time arg checking for statement functions in
new routine ARGSFCHECK.
58 1470 CKS 2-Feb-82
Add LEXOPGEN, routine to read an operator lexeme. It is the same as
LEXEMEGEN except that if it sees tic (') it returns it as TICLEX
instead of reading a character constant.
59 1476 RVM 8-Feb-82
Change the name of INEXTSGN to USERFUNCTION.
60 1501 RVM 16-Feb-82
Due to a change in the meaning of the INEXTERN and USERFUNCTION
attributes, only INEXTERN should be tested to see if the name of
a routine may be used as an argument.
1505 AHM 12-Mar-82
Have MAKECALL set the psect index of the symbol table entry
for "Lxy." to PSCODE to relocate those references by .CODE.
1513 RVM 22-Mar-82
Have REFERENCE use the routine MAKDOTTEDNAME to make a dotted
name of a library function used as an argument to a subroutine.
1523 RVM 29-Mar-82
Implement an extension which makes the EXTERNAL statement
optional for a user function name when the program unit that
tries to pass that user function name as an argument also calls
the function directly. This edit provides some degree of
compatibility with other DEC compilers and the compilers of
other vendors. Making EXTERNAL optional is accomplished by
setting the INEXTERN and USERFUNCTION bits in the STE of any
user function when the function is passed as an argument. Note
that this edit does not make the INTRINSIC statement optional.
We have always allowed a program unit to have a variable as the
same name as a library function called in that program unit.
Making INTRINSIC optional would break this.
1530 TFV 4-May-82
Fix PRIMITIVE for concatenations. Use ARGHDRSIZ to build the
header words for the concatneation argument list on STK.
1531 CDM 4-May-82
Changes for SAVE statement processing after code review.
1551 AHM 4-Jun-82
Remove edit 1505 because external references no longer have
their psect index set.
1554 CKS 3-Jun-82
Add call to PROSUB to do substring bounds checking if /DEBUG:BOUNDS
1604 CKS 21-Jul-82
Handle long IO lists by calling MOVSTK and COPYXLIST if necessary.
1613 CDM 10-Aug-82
Correct table indicating errors for statement function arg checking.
Change /DEBUG:PARAMETERS to /DEBUG:ARGUMENTS
1620 CKS 24-Aug-82
Improve err message when you use numeric operands to concatenation
operator. It is not easy to say "Illegal operator for numeric data"
since // is an n-ary operator and you tend to say it many times.
The message is "numeric operand to concatenation operator".
1651 CKS 18-Oct-82
Fix omitted substring upper bound (C(I:)) to handle length * variables.
Build a substring node for C(I:LEN(C)) for this case.
***** End V7 Development *****
1752 CDM 18-May-83
Don't assume that a function reference may be an intrinsic
function it it has been previously declared as a statement
function.
2077 RJD 11-Feb-85 SPR:10-35087
Check the structure of passed arguments.
***** Begin Version 10 *********
2253 AlB 28-Dec-83
Compatibility flagging for non-integer substring bounds.
Routine:
MAKESUBSTR
2255 AlB 29-Dec-83
Compatibility flagging of .NOT. used with non-logical operands.
Routine:
LOGEXPRESSION
2517 CDM 1-Feb-85
Enhancements to argument checking, upgrading for statement
functions to be up with external routines, and a few bug fixes in
statement functions. Added checks for structure in arguments;
singleton (scalar), array, routine. Added character length
checking in statement functions.
***** End V10 Development *****
***** End Revision History *****
)%
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE ASHELP.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
BIND PRECEDENCE = !THE PRECEDENCE OF THE EXPRESSION OPERATORS
PLIT( %PRECEDENCE,,OPERATOR FLAG COMBINED IF NEGATIVE%
PRCDNCE0, !NULL FOR INDEXING
PRCDNCE1,
PRCDNCE2,
PRCDNCE3,
PRCDNCE4,
PRCDNCE5,
PRCDNCE6,
PRCDNCE7,
PRCDNCE8,
PRCDNCE9,
PRCDNCE10,
PRCDNCE11,
PRCDNCE12,
PRCDNCE13,
PRCDNCE14,
PRCDNCE15,
PRCDNCE16,
PRCDNCE17,
PRCDNCE18,
PRCDNCE19,
PRCDNCE20,
PRCDNCE21,
PRCDNCE22,
%1243% PRCDNCE23,
%1470% PRCDNCE24
);
MACRO OPER(X)= (.PRECEDENCE[X] LSS 0)$;
MACRO ERR0(X)= RETURN FATLEX( X, .LEXNAME[.LEXL<LEFT>], E0<0,0> ) $;
EXTERNAL % Routines %
ARRXPN,
CNVNODE,
CCONST, ! Create complex constant
%2255% CFLAGB, ! Put out flagger warning
%1434% CHARGLIST, ! Create the argument list node for a character
! function. The first argument is the descriptor
! for the result.
%2517% CHEXLEN, ! Returns length of character expression
COPYLIST, ! Create ptr to list (on STK)
%1604% COPYXLIST, ! Same as COPYLIST but for saved STK created by MOVSTK
CORMAN,
EXPRTYPER, ! Get type right (insert type conv node)
FATLERR, ! Error routine
FATLEX, ! Fatal error handler
LEXEMEGEN, ! Get next lexeme
LEXICAL, ! The lexical scanner
MAKLIBFN, ! Makes a node for library functions
%1604% MOVSTK, ! Save STK in free core to handle long lists
NAMREF,
NAMSET,
%1422% NEWDVAR, ! Routine to generate a .Dnnnn compile-time-constant
%1422% ! character descriptor
NEWENTRY, ! Create new entry
PROGNAME,
%1554% PROSUB,
SRCHLIB,
SAVSPACE,
TBLSEARCH; ! Enter new variable name
EXTERNAL % GLOBALS %
%1436% CHARUSED, ! Character data used. Set if see // or [ : ]
ASTATFUN,
E47,
%1434% E180, ! Error for character function references with length *
%1466% E185, ! Wrong number of arg's for a statement function
E186,
%1531% E192, ! "illegal for SAVE statement"
E206,
E207,
%2253% E257, ! "Extension to Fortran-77: Non-integer substring bounds"
%2255% E290, ! "Numeric in logical context"
%2517% E318, ! Length mismatch for statement function
%2077% E319, ! Illegal argument for statement function
ENTRY, ! arg to TBLSEARCH - data for new entry
EVALTAB EVALU, ! Table to access LINK type codes
GSTCSCAN,
GSTLEXEME,
ISN, ! Number of the statement being processed
%1651% LENATTRIB, ! Library function attributes for LEN.
LEXL, ! Current lexeme
LEXNAME, ! Table of lexeme names (ASCII)
%1004% LIBATTSTR LIBATTRIBUTES, !Table of library function attributes
%1004% LIBFUNTAB, ! Table of library function names
LOOK4CHAR,
LSAVE, ! Is LEXL valid (-1 is yes, 0 is no)
NAME, ! arg to TBLSEARCH - table to search
MAKEPR, ! Make expr node
STK, ! Parsing stack
SP; ! Stack ptr for STK
FORWARD % Routines contained in this module %
ARGSFCHECK, ! Routine to perform compile time argument checking for
! statement functions.
NOTEOL, ! Action routine to test end-of-line condition
GIOLIST, ! Action routine to handle top level I/O lists
EXPRESSION, ! Action routine to handle all expressions (NOT lists)
BOTHCHAR, ! Routine to test relationals for both args of type character
%1422% MAKECALL, ! Routine to turn character relationals into calls to
! Lxx.
%1425% MAKEFN, ! Builds function call node.
LOGEXPRESSION, ! Operator precedence top level expression parser
MAKESUBSTR, ! Create substring node
REFERENCE, ! Variables and Function references
PRIMITIVE, ! Parentheses - complex constants, lists, etc.
LEXOPGEN, ! LEXEMEGEN for operators - checks for ' coming up
BEXPRLIST; ! Process list, implied DO loop parameters
OWN LISTOK; ! IF -1, the current context allows a list of elements (I/O list)
GLOBAL ROUTINE NOTEOL=
! Routine is an "action" routine called by the syntax analyser to
! ensure that an expression list is forthcoming. Checks for the next
! lexeme being an end of line, and if so, it fails, otherwise succeeds.
! This routine is always called immediately prior to GIOLIST.
! This routine is all new in edit 1203.
BEGIN
IF .LSAVE EQL 0 THEN (LEXL = LEXEMEGEN(); LSAVE = -1);
IF .LEXL<LEFT> EQL LINEND THEN RETURN -1 ELSE RETURN 0
END %NOTEOL%;
GLOBAL ROUTINE ERREOL =
! As above, but type an error message if EOL is encountered
BEGIN
IF .LSAVE EQL 0 THEN (LEXL = LEXEMEGEN(); LSAVE = -1);
IF .LEXL<LEFT> EQL LINEND THEN RETURN ERR0L(.LEXNAM[IDENTIFIER]);
END %ERREOL%;
GLOBAL ROUTINE COLNEXP= ! [1262] New
! COLNEXP is an action routine used in parsing the optional expression in
! character substring bounds. COLNEXP stands for colon or expression. It
! looks at the upcoming lexeme; if it's a colon COLNEXP returns 0, leaving
! the colon unread, otherwise the lexeme must be the first lexeme of an
! expression, and COLNEXP reads the expression and returns a pointer to it.
BEGIN
IF .LSAVE EQL 0 THEN (LEXL = LEXEMEGEN(); LSAVE = -1);
IF .LEXL<LEFT> EQL COLON THEN RETURN (STK[SP = .SP+1] = 0)
ELSE RETURN EXPRESSION();
END;
GLOBAL ROUTINE RPAREXP= ! [1262] New
! RPAREXP is like COLNEXP but reads right paren or an expression.
BEGIN
IF .LSAVE EQL 0 THEN (LEXL = LEXEMEGEN(); LSAVE = -1);
IF .LEXL<LEFT> EQL RPAREN THEN RETURN (STK[SP = .SP+1] = 0)
ELSE RETURN EXPRESSION();
END;
GLOBAL ROUTINE GIOLIST=
BEGIN
! Routine is an "action" routine called by the syntax analyser to
! parse a general I/O list of elements. It is intertwined very heavily
! with the general expression parsing routines, and leaves a representation
! of the I/O list on STK. In general, when a completed sublist is found,
! STK will be updated and a zero value returned to indicate this.
! If we merely have an expression, however, a pointer to it will get
! passed back until the complete expression is available (until the
! comma which terminates the list element is found).
! This routine is always called immediately after NOTEOL.
! This routine is all new in edit 1203.
LOCAL IOELEMENT; ! ptr to an I/O list expression/sublist
LOCAL LSP, ! save the STK pointer for COPYLIST
%1604% STKSV, ! saved STK for COPYXLIST
%1604% COUNT; ! count of saved STK elements
LSP = .SP; ! save SP for COPYLIST
%1604% STKSV = 0; ! no overflow from STK yet
DO
BEGIN ! process each list item
LISTOK = -1; ! Sublists are allowed
FLGREG<FELFLG> = 1; ! Bare array references are allowed too
IF (IOELEMENT = LOGEXPRESSION()) LSS 0 THEN RETURN .VREG;
IF .IOELEMENT NEQ 0 THEN (STK[SP = .SP+1] = 1; STK[SP = .SP+1] = .IOELEMENT);
%1604% ! Check for stack overflow
%1604% IF .SP GEQ STKSIZ-20 ! if STK is getting full
%1604% THEN MOVSTK(LSP,STKSV,COUNT); ! move this portion of the list
END
UNTIL (IF .LEXL<LEFT> NEQ COMMA THEN TRUE
ELSE (LEXL = LEXEMEGEN(); FALSE));
! Done with the list - better have an end-of-line!
IF .LEXL<LEFT> NEQ LINEND THEN ERR0(PLIT'comma or end of statement?0');
%1604% IF .STKSV EQL 0
THEN COPYLIST(.LSP)
%1604% ELSE COPYXLIST(.LSP,.STKSV,.COUNT);
RETURN 0;
END;
GLOBAL ROUTINE EXPRESSION=
BEGIN
! Routine is an "action" routine called by the syntax analyser to
! parse a general FORTRAN expression. It returns a pointer to the
! final resulting expression node in STK[SP = .SP+1].
! This routine is NOT recursive, although LOGEXPRESSION (which is
! called to do the work) is recursive.
LOCAL LSP; ! Local STK ptr
LSP = .SP;
LISTOK = 0; ! No lists allowed
IF .LSAVE EQL 0 THEN (LSAVE _ -1;LEXL _ LEXEMEGEN());
IF .LEXL<LEFT> EQL LINEND THEN ERR0(.LEXNAM[IDENTIFIER]); ! No expression found
RETURN STK[SP = .LSP+1] = LOGEXPRESSION();
END;
ROUTINE REFSET(A,B) = ! [1456] New
! Call NAMSET or NAMREF. Calls NAMSET if in READ statement (or READ-like
! statement), otherwise calls NAMREF.
! In a READ statement, we wish to call NAMSET for the variables that appear at
! the top level of the list. For instance, in the list A,B(I),C(D(I)) we wish
! to call NAMSET for A, B, and C, but not D or I. In fact, we wish to call
! NAMSET for any variable that appears in a context where an IO list is legal.
! The variable LISTOK is set if an IO list is legal.
BEGIN
EXTERNAL STMNDESC;
IF .LISTOK NEQ 0 ! If reading an IO list
THEN IF .IOINPT(@STMNDESC) ! and in an input statement
THEN NAMSET(.A,.B) ! the variable will be stored into
ELSE NAMREF(.A,.B) ! else it will just be referenced
ELSE NAMREF(.A,.B);
END;
ROUTINE BOTHCHAR(ARG1,ARG2)=
BEGIN
%1255% ! Written 13-Aug-81 by TFV
! Tests relational for both args of type character
! Return TRUE for both character, otherwise FALSE
MAP BASE ARG1:ARG2;
IF .ARG1[VALTYPE] EQL CHARACTER AND .ARG2[VALTYPE] EQL CHARACTER
THEN RETURN TRUE
ELSE RETURN FALSE;
END; ! BOTHCHAR
ROUTINE MAKECALL(EXPR)=
BEGIN
%1255% ! Written 13-Aug-81 by TFV
! EXPR is a relational expression node with character args
%1422% ! Turn it into a call to Lxx. (EQ, NE, GT, GE, LT, LE)
REGISTER BASE ARG1:ARG2:FNID;
%1422% REGISTER ARGUMENTLIST ARGBLOCK;
MAP BASE EXPR;
EXTERNAL TBLSEARCH, CORMAN, CGERR;
ARG1 = .EXPR[ARG1PTR]; ! Pick up first arg
ARG2 = .EXPR[ARG2PTR]; ! Pick up second arg
EXPR[VALTYPE] = LOGICAL; ! Result is logical
EXPR[OPRCLS] = FNCALL; ! Convert relational expression node
! into function call
CASE .EXPR[OPERSP] OF SET ! Get name based on relational operator
CGERR(); ! Internal compiler error
%1422% ENTRY = SIXBIT 'LLT.'; ! LT
%1422% ENTRY = SIXBIT 'LEQ.'; ! EQ
%1422% ENTRY = SIXBIT 'LLE.'; ! LE
CGERR(); ! Internal compiler error
%1422% ENTRY = SIXBIT 'LGE.'; ! GE
%1422% ENTRY = SIXBIT 'LNE.'; ! NE
%1422% ENTRY = SIXBIT 'LGT.' ! GT
TES;
EXPR[OPERSP] = LIBARY; ! It's a library function
%1422% NAME = IDTAB; ! Get Lxx. symbol table entry
EXPR[ARG1PTR] = FNID = TBLSEARCH(); ! Get or create STE
FNID[VALTYPE] = LOGICAL; ! Type is logical
FNID[OPRCLS] = DATAOPR;
FNID[OPERSP] = FNNAME; ! It's a function name
FNID[IDLIBFNFLG] = 1; ! It's a library function too,
! so never allocate it
BTTMSTFNFLG = 0; ! Not bottommost (destroy's AC16)
%1413% NAME<LEFT> = ARGLSTSIZE(2); ! Make a four word argblock entry
EXPR[ARG2PTR] = ARGBLOCK = CORMAN();
ARGBLOCK[ARGCOUNT] = 2; ! Two arg function
ARGBLOCK[1, ARGNPTR] = .ARG1; ! Copy pointer to first arg
IF .ARG1[OPRCLS] EQL DATAOPR
THEN ARGBLOCK[1, AVALFLG] = 1 ! DATAOPR flag
ELSE ARG1[PARENT] = .EXPR; ! Up pointer
ARGBLOCK[2, ARGNPTR] = .ARG2; ! Copy pointer to second arg
IF .ARG2[OPRCLS] EQL DATAOPR
THEN ARGBLOCK[2, AVALFLG] = 1 ! DATAOPR flag
ELSE ARG2[PARENT] = .EXPR; ! Up pointer
END; ! MAKECALL
GLOBAL ROUTINE LOGEXPRESSION=
BEGIN
! Routine is called by the action routines EXPRESSION and GIOLIST to
! parse arbitrary FORTRAN expressions and I/O lists, respectively.
! The value of LISTOK determines what kinds of elements are to be
! parsed (-1 for an I/O list and 0 for an expression). This routine
! is basically an operator precedence machine; the precedence of the
! operators is given in the table in this file. This routine is
! recursive, and may be called from PRIMITIVE, REFERENCE, and/or
! BEXPRLIST.
MACRO BLDTREE(OPRATOR)=
BEGIN
LABEL BLDTR;
BLDTR: BEGIN
LOCAL OPR;
REGISTER BASE R2:T1:T2;
EXTERNAL CGERR;
OPR = .OPRATOR;
NAME = EXPTAB; !GENERATE AN EXPRESSION NODE
T1 = NEWENTRY();
T1[ARG2PTR] = R2 = .STAK[.STP]; STP = .STP-1;
IF .OPR<LEFT> EQL LOGICALNOT
THEN
BEGIN ! Logical .NOT.
EXTERNAL FATLEX,E132,E163,TPCDMY;
%MAKE SURE THIS ISN'T A BINARY .NOT.%
IF .STP NEQ 0
THEN
IF .STAK[.STP-1]<LEFT> LEQ LASTLEX
THEN
IF NOT OPER( .STAK[.STP-1]<LEFT>)
THEN RETURN FATLEX(E132<0,0>);
%1255% ! .NOT. character constant becomes .NOT. hollerith constant
%1255% ! .NOT. character var or expression gives fatal error (ICN)
%1255% ! "Illegal combination of character and numeric"
%2255% ! .NOT. numeric operand may give flagger warning (NLC)
%2255% ! "Numeric operand in logical context"
%1255% IF .R2[VALTYPE] EQL CHARACTER
%1255% THEN IF .R2[OPERATOR] EQL CHARCONST
%2255% THEN
%2255% BEGIN
%2255% IF FLAGEITHER THEN CFLAGB(E290<0,0>); ! Warning (NLC)
%2255% R2[OPERATOR] = HOLLCONST ! Make it HOLLERITH
%2255% END
%2255% ELSE RETURN FATLEX(E163<0,0>) ! Fatal error (ICN)
%2255% ELSE
%2255% IF FLAGEITHER
%2255% THEN IF .R2[VALTYPE] GEQ INTEGER
%2255% THEN CFLAGB(E290<0,0>); ! Warning (NLC)
T1[OPRCLS] = NEGNOT; T1[OPERSP] = NOTOP;
IF .R2[OPRCLS] EQL DATAOPR
THEN T1[A2VALFLG] = 1
ELSE
BEGIN
R2[PARENT] = .T1;
IF .R2[FNCALLSFLG] THEN T1[FNCALLSFLG] = 1;
END;
!NOT NODES SHOULD ALWAYS BE OF TYPE LOGICAL
T1[VALTYPE] = LOGICAL;
T1[ARG1PTR] = 0;
![1056] If a node of double size sits below a .NOT. node (shudder),
![1056] we need to insert an intervening type conversion node so that
![1056] register allocation does not use odd registers for dp and
![1056] complex numbers.
%[1056]% IF .R2[DBLFLG] THEN T1[ARG2PTR] = TPCDMY(.T1,.R2);
%1255% LEAVE BLDTR WITH .T1 ! Don't call exprtyper for character relationals
END; ! Logical .NOT.
T1[ARG1PTR] = .STAK[STP = .STP-1];
CASE .OPR<LEFT>-6 OF SET
BEGIN ! Relational
%1255% T1[OPRCLS] = RELATIONAL;
%1255% T1[OPERSP] = .OPR<RIGHT>;
%1255% IF BOTHCHAR(.T1[ARG1PTR],.T1[ARG2PTR])
%1255% THEN
%1255% BEGIN ! Character relational make it a call to Lxx.
%1255% MAKECALL(.T1);
%1255% LEAVE BLDTR WITH .T1
%1255% END; ! Character relational make it a call to Lxx.
%1255% END; ! Relational
%NOT% (T1[OPRCLS] = NEGNOT;T1[OPERSP] = NOTOP);
%AND% (T1[OPRCLS] = BOOLEAN;T1[OPERSP] = ANDOP);
%OR% (T1[OPRCLS] = BOOLEAN;T1[OPERSP] = OROP);
%MATCH% (T1[OPRCLS] = BOOLEAN;T1[OPERSP] = IF .OPR<RIGHT> EQL 1 THEN EQVOP ELSE XOROP);
%POWER% (T1[OPRCLS] = ARITHMETIC;T1[OPERSP] = EXPONOP);
CGERR();
CGERR();
CGERR();
CGERR();
CGERR();
CGERR();
%MINUS% (T1[OPRCLS] = ARITHMETIC;T1[OPERSP] = SUBOP);
%DIVIDE% (T1[OPRCLS] = ARITHMETIC;T1[OPERSP] = DIVOP);
%PLUS% (T1[OPRCLS] = ARITHMETIC;T1[OPERSP] = ADDOP);
%TIMES% (T1[OPRCLS] = ARITHMETIC;T1[OPERSP] = MULOP)
TES;
R2 = .T1; EXPRTYPER(.T1); !SAVING EXPRESSION PTR
!EXPRTYPER BUILDS A TYPE CONVERSION NODE IF NECESSARY
T1 = .R2; !RESTORING PTR
R2 = .T1[ARG2PTR]; T2 = .T1[ARG1PTR]; !RESTORING PTRS
IF .R2[OPRCLS] EQL DATAOPR THEN T1[A2VALFLG] = 1
ELSE (R2[PARENT] = .T1;IF .R2[FNCALLSFLG] THEN T1[FNCALLSFLG] = 1;);
IF .T2[OPRCLS] EQL DATAOPR THEN T1[A1VALFLG] = 1
ELSE (T2[PARENT] = .T1; IF .T2[FNCALLSFLG] THEN T1[FNCALLSFLG] = 1;);
.T1
END
END$; !OF BLDTREE
LOCAL STAK[14], STP; !STACK AND STACK PTR
LOCAL SLISTOK;
REGISTER BASE R1;
EXTERNAL POOL;
LABEL EXPR1,EXPR2;
!
!CHECK FOR STACK OVERFLOW
!
IF .SREG<RIGHT> GEQ (POOL<0,0>-50)<0,0> THEN RETURN FATLEX(E90<0,0>);
!
STP = -1; !INITIALIZE THE STACK PTR
SLISTOK = .LISTOK; ! Save incoming value of LISTOK
WHILE 1 DO
BEGIN
EXPR1:
IF .LEXL<LEFT> EQL LOGICALNOT
THEN LISTOK = 0
ELSE
BEGIN
R1 = PRIMITIVE(); ! Get an operand (or I/O list)
IF .R1 LEQ 0 THEN RETURN .R1 ! Can't have an operator after a list...
ELSE STAK[STP = .STP + 1] = .R1;
LISTOK = 0; ! Cannot have a list after a primitive seen (until comma)
EXPR2: WHILE 1 DO
BEGIN
IF NOT OPER(.LEXL<LEFT>)
THEN (IF .STP LEQ 0 THEN (LISTOK = .SLISTOK; RETURN .STAK[.STP]) )
ELSE (
IF .STP LEQ 0 THEN LEAVE EXPR2;
IF .PRECEDENCE[.LEXL<LEFT>] GTR .PRECEDENCE[.STAK[.STP-1]<LEFT>]
THEN LEAVE EXPR2; !LEAVE TO STACK THE OPERATOR
);
!HERE IF NOT OPERATOR AND STACK PTR GTR 0
!OR
!IF OPERATOR PRECEDENCE LEQ PREVIOUS OPERATOR'S
STAK[.STP] = BLDTREE(STAK[.STP-1]); !BUILD A TREE NODE
END; !OF WHILE 1 DO
END; !OF IF LEXL NEQ NOTOP
!
!HERE IF STACKING HIGER PRECEDENCE OPERATOR OR
!NOT OP SEEN OR FIRST OPERATOR SEEN
!
STAK[STP = .STP+1] = .LEXL;
LEXL = LEXEMEGEN();
%[626]% FLGREG<FELFLG> = 0; !ARRAYREFS OR FNS W/O ARG LISTS NO LONGER LEGAL
END; !OF WHILE 1 DO
!EXIT FROM THIS LOOP IS BY RETURN FROM INSIDE THE LOOP
END; !OF LOGEXPRESSION
ROUTINE MAKESUBSTR(IDPTR)= ! [1244] New
! Makes a substring node
! Args: IDPTR = variable or ARRAYREF node
! STK[SP+1] = lower bound expression
! STK[SP+2] = upper bound expression
!
! Returns -1 if error:
! IDPTR doesn't point to something of type CHARACTER
! Returns pointer to a substring node if no error
BEGIN ! MAKESUBSTR
MAP BASE IDPTR;
REGISTER BASE T1; ! TEMP
REGISTER BASE SSNODE; ! SUBSTRING NODE
LOCAL BASE LBOUND:UBOUND; ! LOWER AND UPPER BOUND EXPRESSIONS
EXTERNAL CNVNODE,NEWENTRY,CORMAN,MAKPR1,ONEPLIT;
EXTERNAL E162;
! CHECK THAT EXPRESSION WE'RE SUBSTRINGING IS TYPE CHARACTER
IF .IDPTR[VALTYPE] NEQ CHARACTER
THEN RETURN FATLEX (E162<0,0>); !"Substring of non-CHARACTER variable"
%1436% CHARUSED = TRUE; ! Global flag for character
! data used
NAME = EXPTAB; ! MAKE A BLANK EXPRESSION NODE
NAME<LEFT> = SUBNODESIZ; ! 5 WORDS LONG INSTEAD OF 4
SSNODE = NEWENTRY(); ! FILL IT IN...
SSNODE[VALTYPE] = CHARACTER; ! VALTYPE: CHARACTER
SSNODE[OPRCLS] = SUBSTRING; ! OPRCLS: SUBSTRING
SSNODE[ARG4PTR] = .IDPTR; ! ARG4PTR: CHAR VARIABLE OR ARRAYREF
LBOUND = .STK[.SP+1]; ! CONVERT LOWER BOUND TO INTEGER
IF .LBOUND EQL 0
THEN LBOUND = .ONEPLIT
%2253% ELSE
%2253% IF .LBOUND[VALTP1] NEQ INTEG1
%2253% THEN ! Force lower bound to be integer
%2253% BEGIN
%2253% IF FLAGANSI THEN WARNERR(.ISN,E257<0,0>); ! Comp flagger
%2253% LBOUND = CNVNODE(.LBOUND,INTEGER,0) ! Convert to integer
%2253% END;
UBOUND = .STK[.SP+2]; ! GET UPPER BOUND EXPR, OR 0 IF OMITTED
IF .IDPTR[OPRCLS] NEQ ARRAYREF ! GET LENGTH OF CHAR VARIABLE
THEN T1 = .IDPTR[IDCHLEN] ! IF NON-ARRAYREF, GET FROM DATAOPR
ELSE (T1 = .IDPTR[ARG1PTR]; T1 = .T1[IDCHLEN]);
! IF ARRAYREF, FOLLOW TO BASE DATAOPR
%2253% IF .UBOUND NEQ 0
%2253% THEN
%2253% BEGIN ! Upper bound specified
%2253% IF .UBOUND[VALTP1] NEQ INTEG1
%2253% THEN !Force upper bound to be integer
%2253% BEGIN
%2253% IF FLAGANSI THEN WARNERR(.ISN,E257<0,0>); ! Comp flagger
%2253% UBOUND = CNVNODE(.UBOUND,INTEGER,0) ! Convert
%2253% END
%2253% END ! Upper bound specified
ELSE IF .T1 NEQ LENSTAR ! ELSE FILL IN DEFAULT
THEN UBOUND = MAKECNST(INTEGER,0,.T1)
%1651% ELSE
%1651% BEGIN ! For length *, put in explicit call
%1651% ! to LEN
%1651% LOCAL BASE LENSYM;
%1651% LOCAL ARGUMENTLIST ARGLST;
%1651%
%1651% BTTMSTFNFLG = FALSE; ! set destroy-ac-16 flag
%1651%
%1651% ! Make arg list and FNCALL node
%1651%
%1651% NAME<LEFT> = ARGLSTSIZE(1); ! get block for 1 arg
%1651% ARGLST = CORMAN();
%1651%
%1651% NAME = IDTAB;
%1651% ENTRY = SIXBIT 'LEN.';
%1651% LENSYM = TBLSEARCH();
%1651% IF NOT .FLAG ! if LEN. is a new entry, fill it in
%1651% THEN BEGIN
%1651% LENSYM[VALTYPE] = INTEGER;
%1651% LENSYM[OPERSP] = FNNAME;
%1651% LENSYM[IDFNATTRIB] = .LENATTRIB;
%1651% LENSYM[IDPSECT] = PSCODE;
%1651% END;
%1651%
%1651% UBOUND = MAKEPR(FNCALL,LIBARY,INTEGER,.LENSYM,.ARGLST);
%1651%
%1651% ! Fill in arg block
%1651%
%1651% ARGLST[ARGCOUNT] = 1;
%1651% ARGLST[1,ARGNPTR] = .IDPTR;
%1651% ARGLST[1,AVALFLG] = 1;
%1651%
%1651% END;
%1431% IF .UBOUND[OPRCLS] EQL DATAOPR ! SET VALFLG OR PARENT POINTER
%1431% THEN SSNODE[A1VALFLG] = 1 ! FOR UPPER BOUND NODE
%1431% ELSE UBOUND[PARENT] = .SSNODE;
! MAKE EXPRESSION NODE FOR LOWER BOUND - 1
LBOUND = MAKPR1(.SSNODE,ARITHMETIC,SUBOP,INTEGER,.LBOUND,.ONEPLIT);
SSNODE[ARG1PTR] = .UBOUND; ! ARG1PTR: UPPER BOUND
SSNODE[ARG2PTR] = .LBOUND; ! ARG2PTR: LOWER BOUND MINUS 1
IF .IDPTR[OPRCLS] NEQ DATAOPR ! IF SUBSTRINGEE IS NOT A SIMPLE VARIABLE
THEN IDPTR[PARENT] = .SSNODE; ! SET ITS PARENT POINTER
%1554% RETURN PROSUB(.SSNODE);
END; ! MAKESUBSTR
GLOBAL ROUTINE REFERENCE=
BEGIN
! Routine to parse a variable or function reference. Incoming
! lexeme is already available in LEXL and must be an identifier.
! REFERENCE then proceeds to check for array or function reference
! and if a left paren is seen then the list of subscripts or
! arguments is scanned. Return a pointer to a variable or
! function reference node.
LOCAL BASE IDPTR;
REGISTER BASE T1:T2;
MACRO ERR65(X)= RETURN FATLEX ( X, E65<0,0> ) $;
IF .LEXL<LEFT> NEQ IDENTIFIER THEN ERR0(.LEXNAM[IDENTIFIER]);
IDPTR = .LEXL<RIGHT>; !PTR TO IDENTIFIER
%1470% LEXL = LEXOPGEN(); !NEXT LEXEME TO LOOK FOR "("
IF .LEXL<LEFT> EQL LPAREN
THEN
BEGIN !ARRAY REFERENCE OR FUNCTION REFERENCE
LOCAL SLISTOK;
LOCAL LSP; LSP =.SP; !SAV THE STK PTR FO SYNTAX
%1400% ! Check for function call with null argument list
%1400% LOOK4CHAR = ")"; ! CHECK FOR RIGHT PAREN
%1400% IF LEXICAL(.GSTCSCAN) EQL 0 ! IF "NAME()"
%1400% THEN ! THEN WE HAVE FUNCTION WITH NULL ARG LIST
%1400% BEGIN ! ELSE NORMAL CASE, NOT "NAME()"
SLISTOK = .LISTOK;
LISTOK = 0;
DO BEGIN !WHILE REFERENCE FOLLOWED BY ","
LEXL = LEXEMEGEN();
IF .IDPTR[OPRSP1] NEQ ARRAYNM1 !IF NOT ARRAY THEN FUNCTION CALL
THEN FLGREG<FELFLG> = 1; !SET FLG FOR CHECKING ARGS IN ARGLIST OF FUNCTION
IF (.LEXL<LEFT> EQL DOLLAR) OR (.LEXL<LEFT> EQL ANDSGN)
THEN RETURN FATLEX(E83<0,0>); !LABEL ARGS ARE ILLEGAL IN FUNCTION OR ARRAY REF'S
%[1244]% IF .LEXL<LEFT> EQL COLON
%[1244]% THEN STK[SP = .SP+1] = 0
ELSE IF (STK[SP = .SP+1] = LOGEXPRESSION()) LSS 0 THEN RETURN .VREG;
END WHILE .LEXL<LEFT> EQL COMMA;
![1244] Have seen IDENTIFIER ( LOGEXPRESSION , LOGEXPRESSION , ...
!followed by something that is not a comma.
!If it is a right paren, we have seen an array ref or fn call.
!If it is a colon and there was exactly one LOGEXPRESSION, we have
!a substring reference.
IF .LEXL<LEFT> EQL COLON
THEN
IF .SP EQL .LSP+1 ! IF 1 EXPRESSION BEFORE COLON
THEN ! THEN WE HAVE A SUBSTRING REFERENCE
BEGIN ! [1244] SUBSTRING
! UNTIL NOW WE'VE BEEN PARSING WHAT COULD BE A FUNCTION CALL,
! SO ALLOWED BARE ARRAY NAMES. NOW THAT WE KNOW IT'S A
! SUBSTRING REFERENCE, WE MUST DISALLOW ARRAY NAMES AS THE
! LOWER BOUND EXPRESSION.
T1 = .STK[.SP]; ! CHECK LOWER BOUND EXPRESSION
IF .T1 NEQ 0 ! IF EXPRESSION PRESENT,
THEN IF .T1[OPRCLS] EQL DATAOPR ! IF SIMPLE IDENTIFIER
THEN IF .T1[PARENLSTFLG] ! WHICH NEEDED TO BE FOLLOWED
! BY ARGS OR SUBSCRIPTS
THEN RETURN NAMREF(VARIABL1,.T1); ! CALL NAMREF TO TYPE ERROR
FLGREG<FELFLG> = 0; ! BARE ARRAY NAMES ARE NOW ILLEGAL
LEXL = LEXEMEGEN(); ! READ THE COLON
IF .LEXL<LEFT> EQL RPAREN
THEN STK[SP = .SP+1] = 0 ! IF NULL EXPRESSION, PUSH 0
ELSE IF (STK[SP = .SP+1] = LOGEXPRESSION()) LSS 0 THEN RETURN .VREG;
! READ THE UPPER BOUND EXPRESSION
IF .LEXL<LEFT> NEQ RPAREN THEN ERR0L(.LEXNAM[RPAREN]);
LEXL = LEXEMEGEN(); ! READ THE RIGHT PAREN
SP = .LSP; ! RESTORE STK POINTER
%1456% REFSET(VARIABL1,.IDPTR); ! RECORD (AND CHECK) SCALAR REFERENCE
RETURN MAKESUBSTR(.IDPTR); ! BUILD SUBSTRING NODE AND RETURN
END; ! [1244] SUBSTRING
LISTOK = .SLISTOK;
IF .LEXL<LEFT> NEQ RPAREN THEN ERR0(.LEXNAM[RPAREN]);
%1400% END; ! NORMAL CASE, NOT "NAME()"
FLGREG<FELFLG> = 0; !TURN OFF FELFLG FOR NEXT FUNCTION CALL
%1400% IF .SP EQL .LSP
%1400% THEN STK[SP = .SP+1] = -1 ! NULL ARG LIST
%1400% ELSE
%1400% BEGIN ! NON-NULL ARG LIST
COPYLIST(.LSP); !COPY LIST FROM STK TO FREE CORE
INCR ARG FROM .STK[.SP] TO .STK[.SP]+.STK[.SP]<LEFT> DO
BEGIN MAP BASE ARG;
MACRO ARGPTR=0,0,FULL$, ARGFLG=0,0,LEFT$;
LOCAL BASE R2;
R2 = .ARG[ARGPTR];
IF .R2[OPRCLS] EQL DATAOPR
THEN ARG[P1AVALFLG] = 1
ELSE ARG[P1AVALFLG] = 0;
END; !OF INCR ARG
%1400% END; ! NON-NULL ARG LIST
!
!NOW SEE IF FUNCTION CALL OR ARRAY REF TO MAKE PROPER NODE TYPE
!
%1470% LEXL = LEXOPGEN(); !FOR POSSIBLE RETURN TO CALLING ROUTINE
IF .IDPTR[OPRSP1] NEQ ARRAYNM1
THEN !Identifier is function name
BEGIN !Is function
%1425% IDPTR = MAKEFN(.IDPTR); !Make function node
%1400% IF .STK[.SP] NEQ -1 THEN
SAVSPACE(.STK[.SP]<LEFT>,.STK[.SP]); !Save the arglist space
! IDPTR = .FNEXPR;
END !Is function
ELSE
BEGIN
% ARRAY NAME%
%1456% REFSET(ARRAYNM1, .IDPTR); !RECORD THE REFERENCE
IDPTR = ARRXPN(.IDPTR,.STK[.SP]);
! [1244] Have seen IDENTIFIER ( SUBSCRIPTS )
! Check for IDENTIFIER ( SUBSCRIPTS ) ( LOWER : UPPER )
IF .LEXL<LEFT> EQL LPAREN
THEN
BEGIN ! [1244] SUBSTRING OF ARRAYREF
SP = .LSP; ! RESET SP TO REUSE SPACE
LEXL = LEXEMEGEN(); ! READ LEFT PAREN
IF .LEXL<LEFT> EQL COLON
THEN STK[SP = .SP+1] = 0 ! NULL EXPRESSION
ELSE IF (STK[SP = .SP+1] = LOGEXPRESSION()) LSS 0
THEN RETURN .VREG; ! READ LOWER BOUND EXPRESSION
IF .LEXL<LEFT> NEQ COLON THEN ERR0L(.LEXNAM[COLON]);
LEXL = LEXEMEGEN(); ! READ COLON
IF .LEXL<LEFT> EQL RPAREN
THEN STK[SP = .SP+1] = 0 ! NULL EXPRESSION
ELSE IF (STK[SP = .SP+1] = LOGEXPRESSION()) LSS 0
THEN RETURN .VREG; ! READ UPPER BOUND EXPRESSION
IF .LEXL<LEFT> NEQ RPAREN THEN ERR0L(.LEXNAM[RPAREN]);
%1470% LEXL = LEXOPGEN(); ! READ RIGHT PAREN
SP = .LSP; ! RESET SP FOR MAKESUBSTR
RETURN MAKESUBSTR(.IDPTR); ! BUILD SUBSTRING NODE
END; ! [1244] SUBSTRING OF ARRAYREF
END;
SP = .LSP; !RESTORING STK PTR TO ORIGINAL TO AVOID RECURSION PROBLEMS
END
ELSE
!CHECK USE OF NAME WITHOUT SUBSCRIPTS OR ARGS
IF .IDPTR[PARENLSTFLG]
THEN
BEGIN !ARRAYNAME OR FUNCTION NAME W/O ARGS OR SUBSCRIPTS
IF NOT .FLGREG<FELFLG>
%[626]% OR OPER(.LEXL<LEFT>) !CAN'T BE EMBEDDED IN AN EXPRESSION
THEN !ERRONEOUS USE OF IDENTIFIER
BEGIN
RETURN NAMREF(VARIABL1, .IDPTR) ! THIS WILL PRODUCE ERROR MESSAGE
END
ELSE IF .IDPTR[OPRSP1] EQL FNNAME1
THEN
BEGIN
! Get dotted name if this is a library function
%1476% IF NOT .IDPTR[IDATTRIBUT(USERFUNCTION)]
THEN
%1004% IF ( T1 = SRCHLIB( .IDPTR) ) NEQ -1
THEN
BEGIN
%1513% EXTERNAL LIBFUNTAB, MAKDOTTEDNAME;
! Get offset into table
%1004% T1 = .T1 - LIBFUNTAB<0,0>;
%1513% ! Get dotted name of function
%1513% IDPTR = MAKDOTTEDNAME(.T1,.IDPTR)
END
%1523% ELSE
%1523% BEGIN
%1523% ! At this point we have the name
%1523% ! of a user routine that is being
%1523% ! passed as an argument. Set the
%1523% ! bits needed to make the EXTERNAL
%1523% ! statement optional.
%1523% IDPTR[IDATTRIBUT(INEXTERN)] = 1;
%1523% IDPTR[IDATTRIBUT(USERFUNCTION)]=1;
%1523% END;
NAMREF(FNNAME1, .IDPTR)
END
%1456% ELSE REFSET(ARRAYNM1, .IDPTR)
END
%1456% ELSE REFSET( VARIABL1, .IDPTR ); !RECORD REFERENCE
RETURN .IDPTR !RETURN HERE ONLY
END; !OF REFERENCE
ROUTINE MAKEFN(IDPTR)=
BEGIN
! Created [1425] - Code was previously in REFERENCE.
! This routine was created to simplify REFERENCE.
! Builds a node for function reference.
! This function returns address of the function node created.
MACRO ERR47(X)= RETURN FATLEX( X, E47<0,0> ) $;
%1422% BIND GENLEN = 1; ! Generate both byte pointer and length for
! a .Dnnnn compile-time-constant character
! descriptor
LOCAL
ARGUMENTLIST ARGLIST, !Argument list
BASE ARGPT, ! Node from argument pointer
BASE FNEXPR,
%1422% NUMARGS, ! Actual number of arguments for a function
%1422% BASE DVAR; ! Pointer to a .Dnnnn compile-time-constant
%1422% ! character descriptor for the result of the
%1422% ! character function
MAP BASE IDPTR;
LABEL LIBCHK;
REGISTER R2; ! For ptr to function arg list
%1531% ! A function name can't be SAVE-d.
%1531% IF .IDPTR[IDSAVVARIABLE]
%1531% THEN FATLERR(.IDPTR[IDSYMBOL],UPLIT ASCIZ'Function name',
%1531% .ISN,E192<0,0>);
FLGREG<BTTMSTFL> = 0; ! Turn off bottomost routine flag
! Check for recursive statement function
IF .IDPTR EQL .ASTATFUN THEN ERR47(IDPTR[IDSYMBOL]);
%1400% IF .STK[.SP] EQL -1 ! Number of argments
%1422% THEN NUMARGS = 0 ! No arguments
%1422% ELSE NUMARGS = .STK[.SP]<LEFT>+1; ! Get number from stack
%1422% NAME<LEFT> = ARGLSTSIZE(.NUMARGS);
%1422% ARGLIST = R2 = CORMAN(); ! Core for function argument list
%1422% ! Now move the argument list from STK to ARGLIST
NAME = EXPTAB;
ENTRY[0] = .IDPTR;
ENTRY[1] = .R2;
FNEXPR = NEWENTRY(); !Make an expression node for FNCALL
FNEXPR[VALTYPE] = .IDPTR[VALTYPE];
FNEXPR[OPRCLS] = FNCALL;
%1413% ARGLIST[ARGPARENT] = .FNEXPR; !Pointer to parent node
%1422% ARGLIST[ARGCOUNT] = .NUMARGS; !Number of arguments
%1422% IF .NUMARGS NEQ 0
%1400% THEN
%1400% BEGIN ! Move argument list from STK to ARGLIST
! Note that this might not be the final arg list. If this
! is a character function it will have it's return value
! inserted into the first argument by CHARLIST, called
! below.
DECR I FROM .STK[.SP]<LEFT> TO 0 DO
BEGIN ! Copy arguments from STK
%1422% ARGLIST[.I + 1, ARGFULL] = ARGPT = @(.STK[.SP])[.I];
! If AVALFLG is not set, init parent pointer
IF NOT .ARGLIST[.I + 1, AVALFLG]
THEN ARGPT[PARENT] = .FNEXPR;
END; ! Copy arguments from STK
%1400% END; ! Move arg list
%1413% ! Flag to indicate we need type checking blocks
%1413% ! We don't want arg checking if the function is a dummy
%1413% ! argument. LINK must know the name of the function at
%1413% ! LINK-time to do any fixup or error checking.
%1413% IF NOT .IDPTR[IDATTRIBUT(DUMMY)]
%1413% THEN ARGLIST[ARGCHBLOCK] = 1;
! Now if function call is to library routine, call special processing
! routine in module GNRCFN.
!
LIBCHK:BEGIN
! If not declared external, or dummy argument, or
! statement function name, then check to see if it is an
! intrinsic function.
%1476% IF NOT .IDPTR[IDATTRIBUT(USERFUNCTION)]
AND NOT .IDPTR[IDATTRIBUT(DUMMY)]
%1752% AND NOT .IDPTR[IDATTRIBUT(SFN)]
THEN
BEGIN
LOCAL LIBPTR;
IF (LIBPTR = SRCHLIB(.IDPTR)) NEQ -1
THEN
BEGIN ! Found it - make the lib call node.
%1270% MAKLIBFN(.LIBPTR,.FNEXPR,.IDPTR);
%1413% ! Undo flag - don't want arg checking
%1413% ! for library calls.
%1413% ARGLIST[ARGCHBLOCK] = 0;
LEAVE LIBCHK;
END;
END;
FNEXPR[OPERSP] = NONLIBARY;
! Note possible "set" for non-library functions
%1400% IF .STK[.SP] NEQ -1 THEN
DECR I FROM .NUMARGS TO 1 DO
BEGIN
%1422% ARGPT = .ARGLIST[ .I, ARGFULL];
IF .ARGPT[OPRCLS] EQL DATAOPR
THEN
BEGIN
IF .ARGPT[OPRSP1] EQL ARRAYNM1
OR .ARGPT[OPRSP1] EQL VARIABL1
THEN NAMSET(VARYREF, .ARGPT)
END
ELSE IF .ARGPT[OPRCLS] EQL ARRAYREF
THEN NAMSET( ARRAYNM1, .ARGPT[ARG1PTR]);
END;
END; %LIBCHK%
%1434% IDPTR = .FNEXPR[ARG1PTR]; ! Fetch the symbol table entry for the
%1434% ! function call - it may have changed
%1422% IF .IDPTR[VALTYPE] EQL CHARACTER
%1422% THEN
%1422% BEGIN ! Character function
%1422% ! Increment the number of arguments since character
%1422% ! functions have an extra argument. The first
%1422% ! argument is the descriptor for the result. Make a
%1422% ! .Dnnnn variable entry for the compile-time-constant
%1422% ! character descriptor. Fill in the length field of
%1422% ! the result from the function definition.
%1434% ! Give and error if the function reference has a result
%1434% ! length of *.
%1434% IF .IDPTR[IDCHLEN] EQL LENSTAR THEN RETURN FATLEX(.IDPTR[IDSYMBOL], E180<0,0>);
%1434% ! First make the new argument list
%1434% FNEXPR[ARG2PTR] = ARGLIST = CHARGLIST(.ARGLIST);
%1422% ! Fill in the first argument. It is the .Dnnnn compile-time-
%1422% ! constant character descriptor used for the result of the
%1422% ! function.
%1422% DVAR = NEWDVAR(GENLEN); ! Generate the .Dnnnn variable
%1422% DVAR[IDCHLEN] = .IDPTR[IDCHLEN]; ! Fill in the length
%1422% ARGLIST[1,ARGFULL] = .DVAR; ! Fill in the first argument
%1422% ARGLIST[1,AVALFLG] = 1; ! Dataopr flag
%1422% END; ! Character function
%1466% ! We now have the arguments in the arg list. If we have a
%1466% ! statement function, then do it now.
%1466% IF .IDPTR[IDATTRIBUT(SFN)]
%1466% THEN
%1466% BEGIN
%1466% ARGSFCHECK(.ARGLIST); ! Do arg checking now.
%1466% ARGLIST[ARGCHBLOCK] = 0; ! Un-mark for LINK arg checking
%1466% END;
NAMREF(FNNAME1, .FNEXPR[ARG1PTR]) ; !Record the reference
%1425% RETURN .FNEXPR; !Address of function node
END; !of MAKEFN
GLOBAL ROUTINE PRIMITIVE=
BEGIN
! This routine parses a primitive of an expression (if LISTOK is 0)
! or possibly an expression list (if LISTOK is -1). The primitives
! are:
! [$ OR * OR &] label
! [+,-] constant or literal
![1244] [+,-] REFERENCE - (ARRAY or FUNCTION or SUBSTRING)
! A**B
![1244] A // B // ... // Z
! (constant,constant) - a complex constant
! (LOGEXPRESSION) - a parenthesized expression
!
! and leaves the next lexeme available when finished.
! If this routine is entered with LISTOK set to -1, then this
! routine is also willing to handle an expression list (I/O list)
! including the parentheses. Observe that the routine is fully recursive.
! In the event that an expression is parsed, the value returned is a
! pointer to the expression. If an I/O list is found, a pointer to
! the list is put on STK, and zero is returned to indicate this fact.
! As usual, a -1 is returned on a wide variety of error conditions.
LOCAL BASE NEGATNODE,UNARYSIGN;
LOCAL BASE REALPART:IMAGPART;
LOCAL BASE SLISTOK;
LABEL PRIM1;
NEGATNODE = UNARYSIGN = 0;
SLISTOK = .LISTOK; ! Save incoming value for later
WHILE 1 DO
BEGIN ! Scan until no leading '+' or '-'
IF .LEXL<LEFT> NEQ PLUS THEN
IF .LEXL<LEFT> NEQ MINUS THEN EXITLOOP
ELSE NEGATNODE = NOT .NEGATNODE;
! We saw either a '+' or a '-'
%1244% UNARYSIGN = -1; ! Remember we saw a sign
LEXL = LEXEMEGEN(); ! Get next lexeme
FLGREG<FELFLG> = 0; ! CALL FOO(+ARRAY) is illegal
LISTOK = 0; ! +(list) is illegal too
END; ! of +/- loop
PRIM1:
IF .LEXL<LEFT> EQL LPAREN THEN
! We have either:
! 1. Parenthesized expression
! 2. Complex constant
! 3. Possible expression list (if LISTOK set)
BEGIN
LOCAL LSP;
LSP = .SP;
LEXL = LEXEMEGEN();
IF .LISTOK THEN FLGREG<FELFLG> = 1; ! Bare array reference OK
IF(REALPART = LOGEXPRESSION()) LSS 0 THEN RETURN -1; ! Pass failure through
IF .LEXL<LEFT> EQL RPAREN THEN
! We have " ( LOGEXPRESSION ) " - may be either:
! 1. Parenthesized expression
! 2. List of 1 element (if (A) with A an array...)
BEGIN
%1470% LEXL = LEXOPGEN(); ! Get another lexeme in any case
IF .REALPART[OPRCLS] EQL DATAOPR AND
(.REALPART[OPERSP] EQL ARRAYNAME OR
.REALPART[OPERSP] EQL FORMLARRAY)
THEN ! We have got an array with no subscripts
BEGIN
STK[SP = .SP+1] = 1; ! ARRAY NAME ELEMENT
STK[SP = .SP+1] = .REALPART; ! ARRAY PTR
COPYLIST(.LSP);
STK[SP = .SP+1] = 0; ! NO LOOP VARIABLE
COPYLIST(.LSP);
STK[.SP+1] = .STK[.SP]; ! PTR TO "LIST"
STK[.SP] = 2; ! A LIST
SP = .SP+1;
RETURN 0
END
ELSE
BEGIN ! Must be a parenthesized expression
IF .REALPART[OPRCLS] NEQ DATAOPR
THEN REALPART[PARENFLG] = 1;
LEAVE PRIM1;
END
END; ! of RPAREN processing
IF .LEXL<LEFT> NEQ COMMA THEN ERR0(PLIT 'comma or right parenthesis?0');
! We now have " ( LOGEXPRESSION , " -- Try for another expression...
IF .LISTOK THEN FLGREG<FELFLG> = 1; ! Bare array reference OK
LEXL = LEXEMEGEN();
IF(IMAGPART = LOGEXPRESSION()) LSS 0 THEN RETURN -1; ! Pass error through
! We now have " ( LOGEXPRESSION , LOGEXPRESSION " -- Try for complex constant...
IF .LEXL<LEFT> EQL RPAREN THEN
BEGIN
LOCAL CC;
IF (CC = CCONST(.REALPART,.IMAGPART)) NEQ 0
THEN ! It was a complex constant
BEGIN
REALPART = .CC;
%1470% LEXL = LEXOPGEN();
LEAVE PRIM1
END
END; ! of RPAREN processing
! If we get here, it is either a list or illegal
IF NOT .LISTOK OR .NEGATNODE NEQ 0
THEN RETURN FATLEX(PLIT 'expression?0',PLIT 'list?0',E0<0,0>);
! A list is legal in this context, and we have one!
RETURN BEXPRLIST(.REALPART,.IMAGPART); ! Process rest of I/O list
END ! of LPAREN processing
ELSE ! Not a parenthesized expression
BEGIN
IF .LEXL<LEFT> EQL CONSTLEX OR .LEXL<LEFT> EQL LITSTRING
%1470% THEN (REALPART = .LEXL<RIGHT>; LEXL = LEXOPGEN())
ELSE
IF ( REALPART = REFERENCE()) LSS 0 THEN RETURN .VREG; ! Variable or function reference
! REFERENCE returns with next lexeme in LEXL
END; !OF PRIM1:
!
! Here now to check for ** operator (exponentiation).
! REALPART should contain either:
! 1. Pointer to constant node
! 2. Pointer to expression node
! 3. Pointer to variable or function reference
!
IF .LEXL<LEFT> EQL POWER
THEN
BEGIN ! Make an exponent node
LOCAL BASE EXPON;REGISTER BASE T1;
%[626]% FLGREG<FELFLG> = 0; ! CALL FOO(3**ARRAY) illegal
LISTOK = 0; ! list is now illegal too
NAME = EXPTAB; EXPON = NEWENTRY();
EXPON[OPRCLS] = ARITHMETIC; EXPON[OPERSP] = EXPONOP;
EXPON[ARG1PTR] = .REALPART; !BASE
!NOW CHECK FOR SONS BEING DATAOPR OR NOT AND SET PARENT POINTERS APPROPRIATELY
LEXL = LEXEMEGEN();
IF (REALPART = PRIMITIVE()) LSS 0 THEN RETURN -1; !RECURSE TO GET A**B**C = A**(B**C)
EXPON[ARG2PTR] = .REALPART;
EXPRTYPER(.EXPON); !CHECK FOR TYPE CONVERSIONS
REALPART = .EXPON[ARG1PTR]; !CHECK SONS NOW
IF .REALPART[OPRCLS] EQL DATAOPR
THEN EXPON[A1VALFLG] = 1
ELSE ( REALPART[PARENT] = .EXPON;
IF .REALPART[FNCALLSFLG] THEN EXPON[FNCALLSFLG] = 1;
);
REALPART = .EXPON[ARG2PTR]; !CHECK SON AGAIN
IF .REALPART[OPRCLS] EQL DATAOPR
THEN EXPON[A2VALFLG] = 1
ELSE ( REALPART[PARENT] = .EXPON;
IF .REALPART[FNCALLSFLG] THEN EXPON[FNCALLSFLG] = 1;
);
REALPART = .EXPON;
END;
![1244] Check for X // Y // ... // Z
IF .LEXL<LEFT> EQL CONCAT
THEN
BEGIN ! [1244] CONCATENATION
! Here with REALPART = a REFERENCE (DATAOPR or ARRAYREF or SUBSTRING or FNCALL)
! or a complex constant
! or a parenthesized expression
! or anything above preceded by + or -
! Check if it's followed by //, the concatenation operator. If so,
! read a sequence of character primaries followed by //. A character
! primary is a REFERENCE or a parenthesized expression. Quit when
! a primary is followed by anything but //.
LOCAL LSP;
REGISTER BASE CONCNODE;
EXTERNAL E90,E163;
structure pbase [i,j,k,l] =
(.pbase + .j)<.k,.l>;
%1436% CHARUSED = TRUE; ! Flag for character operator used
! in program
! CONCATENATION EXPRESSIONS CAN'T HAVE UNARY SIGN OPERATORS
IF .UNARYSIGN THEN RETURN FATLEX(E206<0,0>);
! "Illegal operator for char data"
FLGREG<FELFLG> = 0; LISTOK = 0; ! BARE ARRAY NAME NOW ILLEGAL
NAME = EXPTAB; CONCNODE = NEWENTRY(); ! MAKE EXPR NODE
CONCNODE[VALTYPE] = CHARACTER;
CONCNODE[OPRCLS] = CONCATENATION;
CONCNODE[OPERSP] = CONCTV;
LSP = .SP; ! SAVE SP FOR RECURSIVE CALLS
! CHECK FIRST OPERAND TYPE, MUST BE CHARACTER
%1620% IF .REALPART[VALTYPE] NEQ CHARACTER THEN FATLEX(E207<0,0>);
! "Numeric operand of concatenation"
! SET PARENT POINTER OF EXPRESSION, SET VALFLG IF NOT EXPRESSION
IF .REALPART[OPRCLS] EQL DATAOPR
THEN (MAP PBASE REALPART; REALPART[P1AVALFLG] = 1)
ELSE REALPART[PARENT] = .CONCNODE;
! A concatenation node looks like a FNCALL node. Make
! an argument list to hang off the concatenation node.
! Leave an extral zero word in place of the first
! argument; it will be used for the concatenation
! result. Zero the header words using ARGHDRSIZ.
%1530% DECR I FROM ARGHDRSIZ TO 1 DO STK[SP = .SP+1] = 0;
! First argument is the result - filled in later
STK[SP = .SP+1] = 0;
! Second argument is the first operand to concat
STK[SP = .SP+1] = .REALPART;
DO
BEGIN ! WHILE //
IF .SP GEQ STKSIZ-1 THEN RETURN FATLEX(E90<0,0>);
! "Expression too complex to compile"
LEXL = LEXEMEGEN(); ! READ THE //
! Read character primary:
! a character constant
! a character variable, array element, substring
! a parenthesized character expression
! We want to parse all the // operands in this loop,
! so can't just call PRIMITIVE to pick up whatever
! follows, as PRIMITIVE would pick up a whole //
! expression. So call PRIMITIVE only for parenthesized
! expressions, otherwise just call reference
IF .LEXL<LEFT> EQL LPAREN
THEN REALPART = PRIMITIVE()
ELSE IF .LEXL<LEFT> EQL LITSTRING
%1470% THEN (REALPART = .LEXL<RIGHT>; LEXL = LEXOPGEN())
ELSE REALPART = REFERENCE();
IF .REALPART LSS 0 THEN RETURN .VREG; ! IF ERROR, PASS IT ON
! MUST BE TYPE CHARACTER
IF .REALPART[VALTYPE] NEQ CHARACTER
%1620% THEN FATLEX(E207<0,0>);
! "Numeric operand of concatenation"
! SET PARENT POINTER OF EXPRESSION, SET VALFLG IF NOT EXPRESSION
IF .REALPART[OPRCLS] EQL DATAOPR ! SET VALFLG OR PARENT POINTER
THEN (MAP PBASE REALPART; REALPART[P1AVALFLG] = 1)
ELSE REALPART[PARENT] = .CONCNODE;
STK[SP = .SP+1] = .REALPART; ! SAVE ARG ON STK
END ! WHILE //
UNTIL .LEXL<LEFT> NEQ CONCAT;
%1413% STK[.LSP+2] = .SP - .LSP - ARGHDRSIZ; ! Set argument count
COPYLIST(.LSP); ! COPY ARG LIST INTO LOCAL STORAGE
CONCNODE[ARG2PTR] = .STK[.SP]; ! SET POINTER TO ARG LIST
SP = .LSP; ! RESTORE STK POINTER
REALPART = .CONCNODE; ! DONE
END; ! [1244] CONCATENATION
LISTOK = .SLISTOK; ! Safe to restore original value of LISTOK now
! One final case - did we have a "-" originally?
IF .NEGATNODE EQL 0 THEN RETURN .REALPART; ! Done
IF .REALPART[OPRCLS]EQL DATAOPR AND .REALPART[OPERSP] EQL CONSTANT
THEN RETURN NEGCNST(REALPART); ! No need to create NEGNOT node.
! The hard case - we absolutely need to create a NEGNOT node...
NAME = EXPTAB;
NEGATNODE = NEWENTRY();
NEGATNODE[OPRCLS] = NEGNOT;
NEGATNODE[OPERSP] = NEGOP;
NEGATNODE[ARG2PTR] = .REALPART;
NEGATNODE[ARG1PTR] = 0;
IF .REALPART[OPRCLS] EQL DATAOPR THEN NEGATNODE[A2VALFLG] = 1
ELSE (REALPART[PARENT] = .NEGATNODE;
IF .REALPART[FNCALLSFLG] THEN NEGATNODE[FNCALLSFLG] = 1
);
NEGATNODE[VALTYPE] = (IF .REALPART[VALTYPE] EQL CONTROL THEN LOGICAL ELSE .REALPART[VALTYPE]);
RETURN .NEGATNODE
END; !0F ROUTINE PRIMITIVE
GLOBAL ROUTINE LEXOPGEN= ! [1470] New
! This routine is used instead of LEXEMEGEN for reading an operator lexeme.
! It is the same as LEXEMEGEN except that it will return TICLEX if it sees a
! tic (') coming up. This is so that EXPRESSION can read the unit specifier
! in IO statements, which can be delimited by tic. LEXOPGEN returns TICLEX if
! the next lexeme starts with ', otherwise it returns the next lexeme. This is
! the only time that TICLEX will be seen.
BEGIN
LOOK4CHAR = "'"; ! Look for tic
IF LEXICAL(.GSTCSCAN) NEQ 0 ! See if tic coming up
THEN RETURN TICLEX^18 ! If so, return TIC lexeme
ELSE RETURN LEXICAL(.GSTLEXEME); ! Else return normal lexeme
END; ! LEXOPGEN
GLOBAL ROUTINE BEXPRLIST(PTR1,PTR2)=
BEGIN
! Called only from PRIMITIVE when we have parsed:
!
! ( LOGEXPRESSION, LOGEXPRESSION
!
! and for some reason we did not have a complex constant.
! PTR1 and PTR2 are pointers to the two LOGEXPRESSIONs already seen;
! if zero, a sublist was seen (for which a ptr is on the STK).
! This routine picks up the rest of the list (if any), and also
! handles any DO loop parameters which might be present.
! If successful, a list pointer is put onto the stack, and zero
! is returned to indicate this fact.
! This routine is all new for edit 1203.
MAP BASE PTR1:PTR2;
LOCAL LSP;
! Adjust the STK so that both of the LOGEXPRESSIONs are present.
! Observe that PTR1 and/or PTR2 may be zero in which case STK already
! contains pointers to sublists (which may need to be moved).
IF .PTR1 EQL 0 THEN SP = .SP-2;
IF .PTR2 EQL 0 THEN SP = .SP-2;
LSP = .SP;
IF .PTR2 EQL 0 AND .PTR1 NEQ 0
THEN
BEGIN
STK[.SP+3] = .STK[.SP+1];
STK[.SP+4] = .STK[.SP+2]
END;
IF .PTR1 NEQ 0 THEN (STK[.SP+1] = 1; STK[.SP+2] = .PTR1);
IF .PTR2 NEQ 0 THEN (STK[.SP+3] = 1; STK[.SP+4] = .PTR2);
SP = .SP+4;
! We are done with fixing up STK to contain PTR1 and PTR2.
! Now process the rest of the list elements (if any), adjusting
! STK accordingly.
WHILE .LEXL<LEFT> EQL COMMA DO
BEGIN
FLGREG<FELFLG> = 1; ! Bare array references are allowed
LEXL = LEXEMEGEN();
IF(PTR1 = LOGEXPRESSION()) LSS 0 THEN RETURN -1;
IF .PTR1 NEQ 0 THEN (STK[SP = .SP+1] = 1; STK[SP = .SP+1] = .PTR1)
END;
! The list of I/O elements/sublists is done
COPYLIST(.LSP); ! Get ptr to list of elements (and loop index)
! Try for either a right parenthesis or possibly loop parameters.
IF .LEXL<LEFT> EQL RPAREN THEN
STK[SP = .SP+1] = 0 ! No loop variable, just a list
ELSE IF .LEXL<LEFT> EQL EQUAL THEN ! We have a loop
BEGIN
STK[SP = .SP+1] = 1;
LEXL = LEXEMEGEN();
LISTOK = 0; ! No loops allowed in here
FLGREG<FELFLG> = 0; ! Bare array references are not allowed
! Get the loop parameters - first the lower bound
IF (STK[SP = .SP+1] = LOGEXPRESSION()) LSS 0
THEN RETURN -1;
IF .LEXL<LEFT> NEQ COMMA THEN ERR0(.LEXNAM[COMMA]);
LEXL = LEXEMEGEN();
! Next the upper bound
IF (STK[SP = .SP+1] = LOGEXPRESSION()) LSS 0
THEN RETURN -1;
IF .LEXL<LEFT> EQL COMMA THEN ! We have an increment too
BEGIN
LEXL = LEXEMEGEN();
IF (STK[SP = .SP+1] = LOGEXPRESSION()) LSS 0
THEN RETURN -1;
END
ELSE STK[SP = .SP+1] = 0; ! No increment
IF .LEXL<LEFT> NEQ RPAREN
THEN ERR0(.LEXNAM[RPAREN]);
! We have all the DO loop parameters now, so it is time
! to put all the pieces together from the pointers on STK
COPYLIST(.LSP+2); ! Do loop elements
LISTOK = -1; ! Restore list legality
END ! Of .LEXL<LEXL> EQL EQUAL
ELSE ERR0(.LEXNAM[RPAREN]);
! Finish up with the STK elements
COPYLIST(.LSP);
STK[.SP+1] = .STK[.SP]; ! Ptr to "list"
STK[.SP] = 2; ! A list
SP = .SP+1;
LEXL = LEXEMEGEN(); ! Always get the next lexeme
RETURN 0
END; !OF ROUTINE BEXPRLIST
GLOBAL ROUTINE ARGSFCHECK(CALLLIST)= ![1466] New
BEGIN
! Performs argument checking for statement functions for the arg
! list passed to it.
MAP ARGUMENTLIST CALLLIST; ! Passed: caller's arg list
LOCAL
%2517% CALLSTRUCTURE, ! Caller's argument's structure
%2517% CHARFNOFFSET, ! Offset (or 0) for where character
%2517% ! fn's arguments start
BASE CNODE, ! Scratch expression node
%2517% LENCALL, ! Length of caller's argument
%2517% LENSF, ! Length of sf's argument
MAXNUM, ! Max number of args to check
ARGUMENTLIST SFLIST, ! SF's arg list
BASE SFNODE; ! SF statement node
REGISTER
BASE CALLARG, ! Callers's arg node
BASE SFARG, ! SF's arg node
BASE SYMTAB; ! Symbol table entry for SF name
! Table accessed by LINK's type codes (table EVALU) to give the
! action based on actual and formal argument values 1=complain
! 0=legal.
STRUCTURE ACTSTR[ACTUAL,FORMAL]=
(.ACTSTR[.ACTUAL])<.FORMAL,1>;
MACRO ACT(L1,I2,R4,O6,L7,D10,D12,G13,C14,C15,H17)=
L1^1 OR I2^2 OR R4^4 OR O6^6 OR L7^7 OR D10^8
OR D12^10 OR G13^11 OR C14^12 OR C15^13 OR H17^15$;
BIND ACTSTR WARN =
UPLIT(
! **FORMALS**
! L I R O L D D G C C H **ACTUALS**
! o n l c a b O f m h o
! g t t b l c l p a l
0,
%1613% ACT( 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), ! Logical
%1613% ACT( 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1), ! Integer
0,
%1613% ACT( 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1), ! Real
0,
%1613% ACT( 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1), ! Octal
%1613% ACT( 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1), ! Label
%1613% ACT( 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1), ! Dble Prec
0,
%1613% ACT( 1, 1, 1, 1, 1, 0, 1, 0, 0, 1, 1), ! Dble Octal
%1613% ACT( 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1), ! G-floating
%1613% ACT( 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1), ! Complex
%1613% ACT( 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1), ! Character
0,
%1613% ACT( 0, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1), ! Hollerith
0
! L I R O L D D G C C H
! o n l c a b O f m h o
! g t t b l c l p a l
);
CNODE = .CALLLIST[ARGPARENT]; ! Calling node for SF
SYMTAB = .CNODE[ARG1PTR]; ! Symbol table entry
SFNODE = .SYMTAB[IDSFNODE]; ! Statement node for SF
SFLIST = .SFNODE[SFNLIST]; ! Arg list for SF
! Inform user if calling statement function with the wrong number
! of arguments.
%1613% IF .FLGREG<DBGARGMNTS> ! /DEBUG:ARGUMENTS specified
THEN
BEGIN
IF .CALLLIST[ARGCOUNT] NEQ .SFLIST[ARGCOUNT]
THEN FATLERR(.SYMTAB[IDSYMBOL],.ISN,
E185<0,0>);
END;
! Loop through the arguments to compare them. In case the number
! of arguments isn't the same, take the smaller of the two for the
! upper bound.
MAXNUM = .CALLLIST[ARGCOUNT];
IF .CALLLIST[ARGCOUNT] GTR .SFLIST[ARGCOUNT]
THEN MAXNUM = .SFLIST[ARGCOUNT];
%2517% ! Set if there is an offset for character functions. We start at
%2517% ! argument 2 if so, because argument one is the function's return
%2517% ! value. No need to check that...
%2517%
%2517% IF .SYMTAB[VALTYPE] EQL CHARACTER ! Character function?
%2517% THEN CHARFNOFFSET = 1
%2517% ELSE CHARFNOFFSET = 0;
! Perform arg checking for each argument.
%2517% INCR CNT FROM (1 + .CHARFNOFFSET) TO .MAXNUM
DO
BEGIN ! Each argument
CALLARG = .CALLLIST[.CNT,ARGNPTR];
SFARG = .SFLIST[.CNT,ARGNPTR];
! Check if character constant argument is being passed to
! numeric. If so then do a fixup to make this constant a
! hollerith.
IF .CALLARG[OPERATOR] EQL CHARCONST THEN
IF .SFARG[VALTYPE] NEQ CHARACTER
THEN CALLARG[VALTYPE] = HOLLERITH;
! Do more checking if /DEBUG:ARGUMENTS is specified.
%1613% IF .FLGREG<DBGARGMNTS>
THEN
BEGIN ! /DEBUG:ARGUMENTS specified
! Inform user of any improper passing of actuals to
! dummy aguments
IF (.WARN[ .EVALU[.CALLARG[VALTYPE]],
.EVALU[.SFARG[VALTYPE]] ])
THEN FATLERR (.SYMTAB[IDSYMBOL],.CNT,
%2517% .ISN - .CHARFNOFFSET,E186<0,0>)
%2517% ELSE
%2517% BEGIN ! No type mismatch
%2517%
%2517% ! If character arguments (both are the same
%2517% ! if we're here), then check the length of
%2517% ! of the arguments. It's illegal for a
%2517% ! dummy variable of the sf to be longer
%2517% ! than the argument that is passed to it,
%2517% ! it could reference something that isn't
%2517% ! allocated or isn't character.
%2517%
%2517% IF .CALLARG[VALTYPE] EQL CHARACTER
%2517% THEN
%2517% BEGIN ! Both arguments are character
%2517%
%2517% ! Get length of the arugments. If
%2517% ! they aren't known at compile time
%2517% ! (length *), 0 is returned.
%2517%
%2517% LENCALL = CHEXLEN(.CALLARG);
%2517% LENSF = CHEXLEN(.SFARG);
%2517%
%2517% ! Check if len(caller) < len(sf).
%2517% ! Don't if either is unknown
%2517% ! (length *).
%2517%
%2517% IF (.LENCALL NEQ LENSTAR) AND
%2517% (.LENSF NEQ LENSTAR)
%2517% THEN IF .LENCALL LSS .LENSF
%2517% THEN FATLERR (.SYMTAB[IDSYMBOL],
%2517% .CNT - .CHARFNOFFSET, .ISN,
%2517% E318<0,0>); ! Warning!
%2517%
%2517% END; ! Both arguments are character
%2517%
%2517% END; ! No type mismatch
%2517% ! Check structure of passed arguments.
%2517% !
%2517% ! The basic structures are:
%2517% !
%2517% ! o Singleton (one unit of data)
%2517% ! o Bare array name (multiple units of data)
%2517% ! o Function name.
%2517% !
%2517% ! We'll call these VARIABL1, ARRAYNM1, and FNNAME1
%2517% ! respectively (names are from the DATOPS1 field in
%2517% ! DATAOPR's).
%2517% !
%2517% ! Set CALLSTRUCTURE to the structure types for each
%2517% ! argument. DATAOPR's have this info build in to
%2517% ! the node, expressions don't. If the caller's
%2517% ! argument is a DATAOPR (all the sf's arguments
%2517% ! are), then make "0" and ARRAYNM1 into VARIABL1
%2517% ! (its ok to pass an array to a singleton), and
%2517% ! copy FNNAME1 as is. If the caller's arguments
%2517% ! aren't DATAOPR's then they are VARIABL1
%2517% ! (singletons).
%2517% !
%2517% ! Compare to see if the calculated structures are
%2517% ! equal. If not, complain.
%2517%
%2517% ! Calculate/copy the caller's structure.
%2517%
%2517% CALLSTRUCTURE = VARIABL1; ! Default; singleton
%2517% IF .CALLARG[OPRCLS] EQL DATAOPR ! DATOPS1 valid?
%2517% THEN IF .CALLARG[DATOPS1] GTR ARRAYNM1 ! Already set?
%2517% THEN CALLSTRUCTURE = FNNAME1; ! Function
%2517%
%2517% ! If the structures aren't the same, then complain!
%2517% ! The statement function's dummy arguments must be
%2517% ! DATAOPR's, so DATOPS1 is valid. VARIABL1 and
%2517% ! FNNAME1 are the only values set for the sf
%2517% ! dummies (no array names are possible).
%2517%
%2517% IF .CALLSTRUCTURE NEQ .SFARG[DATOPS1]
%2517% THEN FATLERR (.SYMTAB[IDSYMBOL], .CNT - .CHARFNOFFSET,
%2517% .ISN, E319<0,0>);
END ! /DEBUG:ARGUMENTS specified
%2517% ELSE
%2517% BEGIN ! /DEBUG:ARGUMENTS not specified
%2517%
%2077% ! Check structure of passed arguments. Its is verboten
%2077% ! to pass a constant when a routine is expected.
%2077%
%2077% IF (.CALLARG[OPR1] EQL CONSTFL) AND
%2077% (.SFARG[DATOPS1] EQL FNNAME1)
%2517% THEN FATLERR (.SYMTAB[IDSYMBOL], .CNT - .CHARFNOFFSET,
%2077% .ISN, E319<0,0>);
%2517%
%2517% END; ! /DEBUG:ARGUMENTS not specified
END; ! Each argument
END; ! of ARGSFCHECK
END
ELUDOM