Google
 

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