Trailing-Edge
-
PDP-10 Archives
-
BB-4157F-BM_1983
-
fortran/compiler/act0.bli
There are 12 other files named act0.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
! OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1983
!AUTHOR: F.J. INFANTE, D. B. TOLMAN/DCE/TFV/EGM/AHM/CKS
MODULE ACT0(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
GLOBAL BIND ACT0V = 7^24 + 0^18 + #1702; ! Version Date: 9-Dec-82
%(
***** Begin Revision History *****
47 ---- ----- ADD ROUTINE TO GENERATE TEMPORARIES FOR
STATEMENT FUNCTION DUMMIES
48 ----- ----- ADD THE CODE TO PNAMSET TO HANDLE THE *N
CONSTRUCT AFTER FUNCTION NAMES
49 ----- ----- FIX RECORDMARK TO SIMULATE VARIBLESPEC PRORERLY
ITS ALL IBMS FAULT!!!!!!
50 ----- ----- FIX ERROR RETURN IN EXPRLIST TO RETURN -1 AND
THUS SUPRESS AN EXTRANEOUS ERROR MESSAGE
51 ----- ----- SET ACTLDATYPE IN TYPEID FOR ASTER()
***** Begin Version 4B *****
52 325 17044 CHECK FOR STACK OVERFLOW IN LONG ARG LISTS.
***** Begin Version 5A *****
53 603 23442 ALLOW * AS NEW STATEMENT LABEL CONSTANT
BEGINNING CHARACTER, (DCE)
***** Begin Version 5B *****
54 716 26409 MARK LABELS WHICH CAN BE REACHED ON RETURN
FROM SUBROUTINES DIRECTLY, (DCE)
***** Begin Version 6 *****
55 760 TFV 1-Oct-79 ------
Recordmark is optional in FIND statement since REC= expression
is now legal
56 777 EGM 27-Jun-80 -----
In RECORDMARK, when parsing an array reference for a unit specification,
set LSAVE to indicate that we have used the right paren lexeme.
57 1061 DCE 9-Apr-81 -----
Give warning for # used in a random I/O statement
61 1132 AHM 22-Sep-81 Q10-06347
Reword message E150 defined by edit 1061 to refer to REC= as well as '
***** Begin Version 7 *****
58 1213 TFV 20-May-81 ------
Modify ASTERTYPE to handle CHARACTER*n. Clean up use of .VREG
Fix IMPLICIT handling; TYPTABle now has two word entries; second
word is character count for character data.
59 1217 DCE 28-May-81 -----
Allow CALL stmnt with null arg list, i. e., CALL FOO()
60 1232 TFV 16-Jul-81 ------
TYPEID sets CHDECL flag if a character declaration is seen. Used
in MRP3R and MRP3G to test if we have to scan the symbol table to
generate high seg character descriptors.
62 1410 CKS 28-Oct-81
Add action routine CMNCOMMA to analyze commas in COMMON statements.
A comma is a list terminator if followed by /, otherwise a separator.
63 1421 CKS 11-Nov-81
Add action routine NULLCHECK to check for null parameter lists in
statement function definitions. In a definition of the form F() = ...
we can't use +SUBLOCAL to read a list of parameters, since SUBLOCAL
will complain when it sees the right paren. NULLCHECK is called before
SUBLOCAL to detect the right paren and cause SYNTAX to take the other
alternative, which must match right paren.
64 1434 TFV 7-Dec-81 ------
Add a routine CHARGLIST to convert non-character function argument
blocks to character function argument blocks. They have an extra
argument. It is the first argument and is the descriptor for the
result. This fixes the cases where a function statement is followed
by a character or implicit character statement that changes the type
of the function.
65 1465 CKS 20-Jan-82
Add KEYSCAN routine to parse the keyword list in READ and WRITE
statements.
66 1470 CKS 2-Feb-81
Make KEYSCAN parse READ (unit ' record).
1505 AHM 9-Mar-82
Make SUBLOCAL set the psect index of statement function
formals to PSDATA for extended addressing support.
1527 CKS 29-Apr-82
Add new routines CONSTEXPR, EVAL, and MAKELIT to parse
constant expressions. Add ASTEREXPR to parse length specifications
in declarations of the form *const, *(expression), or *(*).
1535 CDM 17-May-82
Fixes to optimize CHAR(constant) and ICHAR(constant) into constants.
1546 CKS 31-May-82
Allow expressions in TYPE, ACCEPT, et al. Unify the handling of
"READ f, list" vs. "READ (cilist) list" forms.
1573 CKS 1-Jul-82
Add LABELANDWHILE action routine to help parse DO WHILE statement.
It parses an optional statement label, optional comma, and the
word WHILE.
1575 TFV 7-Jul-82
Fix type declarations to allow 'var *len (subs) * len'.
1656 CKS 25-Oct-82
Add routine PARMASSIGN, action routine to parse IDENTIFIER = CONSTEXPR
for parameter statements.
1670 CKS 10-Nov-82
Allow arbitrary expressions (not just constant expressions) as array
bounds. BLDDIM will check that such expressions are only used with
formal arrays.
1677 CKS 20-Nov-82
Use action routine KEYSCAN to parse FIND, ENCODE, REWIND.
1702 CKS 9-Dec-82
Improve error message when turkey incorrectly uses FMT= keyword
to specify format in ENCODE/DECODE.
***** End Revision History *****
)%
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE META72.BLI;
SWITCHES LIST;
REQUIRE ASHELP.BLI;
FORWARD
ASTERTYPE,
PNAMSET,
TMPGN,
SUBLOCAL,
NULLCHECK,
FUNCTIONSCAN,
LABELS,
NOLABELS,
TYPEID,
IMPLICITSPEC,
TOQUOTE,
KSPEC,
KUSPEC,
KEYSCAN,
UNITSCAN,
FMTSCAN,
EXPRLIST,
CHARGLIST(1), ! Generate a character function argument list. It
! has an extra argument. It is the first argument
! and is the descriptor for the result.
CONSTEXPR,
EVAL,
NTHARG,
CNVCONST,
ASTEREXPR,
CONSTP;
EXTERNAL
ACTLDATYPE,
BASE ASTATFUN,
BLDVAR,
ASTER,
C1H,
C1L,
C2H,
C2L,
CGERR,
%1213% CHDECL, ! Flag for character declaration seen
%1213% CHDLEN, ! Default character count for character data
%1213% CHLEN, ! Character count for character data
CNSTCM,
COPRIX,
COPYLIST,
CORMAN, ! Routine to get space from free memory
DATASTA,
E9,
%1061% E150,
E160,
E182,
E183,
E195,
E198,
E199,
E211,
ENTRSTA,
ENTRY,
EXPRESS,
FINDSTA,
FNTMP, ! Counter for .Fnnnn temporaries
GSTCSCAN,
GSTKSCAN,
GSTLEXEME,
GSTSSCAN,
GTYPCOD,
IDTYPE,
KARIIB,
KARIGB,
KBOOLBASE,
KSPECB,
KSPECG,
KTYPCB,
KTYPCG,
LEXEMEGEN,
LEXICAL,
LEXOPGEN,
LEXL,
LOOK4CHAR,
LOOK4LABEL,
LSAVE,
%1535% MAKLIT, ! Make empty literal table node
NAME, ! Global argument to CORMAN
NAMDEF,
NAMREF,
NAMSET,
NEWENTRY,
NONIOINIO,
PROGNAME,
SAVSPACE, ! Routine to free space
SETUSE,
SP,
STK,
STMNDESC,
SYNTAX,
TYPE,
TYPTAB,
WARNERR;
OWN
%1656% PARMCNV; ! Set iff parameter list enclosed in parens
GLOBAL ROUTINE ASTERTYPE=
BEGIN
!***************************************************************
! Action routine to parse *size modifiers in type declaractions.
! Invoked by ONEARRAY BNF. Calls ASTER to parse the size
! modifier and determine the datatype. Three words are put on
! STK:
! length for character data or 0
! flag = 1 if *size was specified
! datatype returned by ASTER
!***************************************************************
%1575% ! Rewritten by TFV on 7-Jul-82
%1213% REGISTER VAL; ! Use VAL instead of VREG
! Return if not type declaration
IF .ORDERCODE(@STMNDESC) NEQ GTYPCOD<0,0> THEN RETURN 0;
%1213% ! Call ASTER to process the *n, *(n), and *(*) constructs
! ASTER leaves two words on STK:
! length for character data or 0
! flag = 1 if *size was specified
%1213% IF (VAL = ASTER(.IDTYPE)) LSS 0
%1213% THEN RETURN .VAL
%1213% ELSE STK[SP = .SP + 1] = .VAL; ! Put datatype on stack
RETURN 0
END; ! of ASTERTYPE
GLOBAL ROUTINE PNAMSET=
BEGIN
! Set progname so it will come out on the heading
REGISTER BASE ID;
IF .STMNROUTINE(@STMNDESC) NEQ ENTRSTA<0,0>
THEN
BEGIN
ID = .STK[.SP]<RIGHT>;
PROGNAME = .ID[IDSYMBOL];
! Pick up any *n after function names if a type was specified
IF .ORDERCODE(@STMNDESC) EQL GTYPCOD<0,0>
THEN
BEGIN
%1575% ! ASTER leaves two words on STK:
%1575% ! length for character data or 0
%1575% ! flag = 1 if *size was specified
IF (IDTYPE = ASTER(.IDTYPE)) LSS 0
THEN RETURN .IDTYPE;
! Discard the flag word setup by ASTER
%1575% SP = .SP - 1;
END;
END;
RETURN 0
END; ! of PNAMSET
GLOBAL ROUTINE TMPGN=
BEGIN
! Generates a .Fnnnn temporary , returns its name but does not
! enter it in the symbol table.
REGISTER VAL;
VAL = SIXBIT'.F0000' +
(.FNTMP<9,3>)^18 +
(.FNTMP<6,3>)^12 +
(.FNTMP<3,3>)^6 +
(.FNTMP<0,3>);
FNTMP = .FNTMP + 1;
RETURN .VAL
END; ! of TMPGN
GLOBAL ROUTINE SUBLOCAL=
BEGIN
! This routine is called to generate a special non-confilcting
! variable for statement function formal arguments. A .Fnnnn
! variable is generated and inserted into the symbol table
! directly after the actual identifier. The names are then
! interchanged so that EXPRESS will get the .Fnnnn variable when
! looking up the formal argument. The semantic routine will
! reinterchange the names for the rest of the program. The .Fnnnn
! variable gets the type of the formal argument, the character
! length if it is a character variable,and have dummy and formlvar
! set in the IDATTRIBUT field.
REGISTER BASE ID:SAV:TMP;
! ID - formal argument
! SAV - used to switch names
! TMP - .Fnnnn variable
! Get a variable
STK[SP = .SP + 1] = LEXL = LEXICAL(.GSTLEXEME);
IF .LEXL<LEFT> NEQ IDENTIFIER
THEN IF .LEXL<LEFT> EQL CONSTLEX
THEN RETURN FATLEX(PLIT'dimensioned',ASTATFUN[IDSYMBOL],E15<0,0>)
ELSE RETURN ERR0L(IDENPLIT);
ID = .LEXL<RIGHT>;
! Generate a new .Fnnnn symbol, insert it in the symbol table after
! the formal argument and swap the names
SAV = .ID[CLINK];
NAME = IDTAB;
TMP = ID[CLINK] = NEWENTRY();
TMP[CLINK] = .SAV;
TMP[IDSYMBOL] = .ID[IDSYMBOL]; ! Name of the formal argument
ID[IDSYMBOL] = TMPGN(); ! .Fnnnn variable name
TMP[IDATTRIBUT(DUMMY)] = -1; ! Mark it as a dummy argument
TMP[OPERSP] = FORMLVAR; ! It's a formal variable
TMP[VALTYPE] = .ID[VALTYPE]; ! The valtype is the same as the formal
! argument.
%1434% TMP[IDCHLEN] = .ID[IDCHLEN]; ! The character length is the same also
%1505% TMP[IDPSECT] = PSDATA; ! The variable is in the .DATA. psect
RETURN 0 ! Return success
END; ! of SUBLOCAL
GLOBAL ROUTINE NULLCHECK= ![1421] New
BEGIN
! Action routine called to detect null parameter list in statement
! function definition. This routine succeeds if the upcoming
! lexeme is not ')'. Otherwise, it fails without typing an error
! message. SYNTAX will then try the other alternative, which must
! match ')'. This routine never reads any lexemes. It just
! serves to choose between two alternatives, one of which starts
! with ')'.
LOOK4CHAR = ")";
IF LEXICAL(.GSTCSCAN) NEQ 0
THEN ! Right paren coming up, fail
BEGIN
LSAVE = -1; ! Reread the right paren
LEXL = RPAREN^18;
RETURN -1; ! Fail to make syntax try another
! alternative
END;
RETURN 0; ! Else succeed
END; ! of NULLCHECK
GLOBAL ROUTINE FUNCTIONSCAN =
BEGIN
! Scan for the string "FUNCTION". If it is found then call this a
! function. We will invoke the rule that identifiers must be less
! than or equal to 6 characters in making this decision.
LOOK4CHAR = FNPLIT<29,7>; ! Skip the blank
IF LEXICAL(.GSTSSCAN) EQL 0
THEN RETURN -1 ! Not function
ELSE RETURN 0 ! Got one
END; ! of FUNCTIONSCAN
GLOBAL ROUTINE LABELS=
BEGIN
! This routine sets a flag that indicates to the lexical analyzer
! that what one really wants here is a label and not a constant.
LOOK4LABEL = 1;
RETURN 0
END; ! of LABELS
GLOBAL ROUTINE NOLABELS=
BEGIN
! This routine sets a flag that indicates to the lexical analyzer
! that what one really wants here is a constant and not a label.
LOOK4LABEL = 0;
RETURN 0
END; ! of NOLABELS
GLOBAL ROUTINE TYPEID =
BEGIN
!*****************************************************************
! This routine will pick up the data type words in IMPLICIT
! statements. It then calls ASTER to pick up the *size construct
! if any and then sets the type for use in the routine
! IMPLICITSPEC and returns.
!*****************************************************************
REGISTER R1,R2;
LOOK4CHAR _ "?L"; ! Any letter
SELECT LEXICAL(.GSTCSCAN) OF NSET
"I": EXITSELECT (R1 = INTEGER; R2 = INTGPLIT<22,7>);
"R": EXITSELECT (R1 = REAL; R2 = REALPLIT<22,7>);
"D": EXITSELECT (R1 = DOUBLPREC; R2 = DOUBPLIT<22,7>);
"C": EXITSELECT (R1 = COMPLEX; R2 = COMPLIT<22,7>);
"L": EXITSELECT (R1 = LOGICAL; R2 = LOGIPLIT<22,7>);
OTHERWISE: RETURN FATLEX(E17<0,0>)
TESN;
LOOK4CHAR = .R2;
%1213% IF LEXICAL(.GSTSSCAN) EQL 0
%1213% THEN
%1213% BEGIN ! May be CHARACTER instead of COMPLEX
%1213% IF .R1 EQL COMPLEX
%1213% THEN
%1213% BEGIN ! Try CHARACTER
%1213% R1 = CHARACTER;
%1213% LOOK4CHAR = R2 = CHARPLIT<22,7>;
%1213% IF LEXICAL(.GSTSSCAN) EQL 0 THEN RETURN FATLEX(E17<0,0>);
%1213% CHDLEN = 1; ! Default character count is 1
%1232% ! Set flag for character declaration seen used in
%1232% ! MRP3R and MRP3G to test if we have to scan the
%1232% ! symbol table to generate high seg character
%1232% ! descriptors.
%1232% CHDECL = -1;
%1213% END
%1213% ELSE
%1213% RETURN FATLEX(E17<0,0>);
%1213% END;
ACTLDATYPE = .R1;
%1213% TYPE = ASTER(.R1);
! ASTER leaves two words on STK:
! length for character data or 0
! flag = 1 if *size was specified
%1213% IF .TYPE EQL CHARACTER
%1575% THEN CHLEN = .STK[.SP - 1] ! Fetch character length from stack
%1575% ELSE CHLEN = 0; ! No character length
%1575% SP = .SP - 2; ! Discard the two words ASTER put on STK
%1213% RETURN .TYPE
END; ! of TYPEID
GLOBAL ROUTINE IMPLICITSPEC=
BEGIN
! This routine will pick up the letter and letter-letter
! constructs in implicit statements. It will then adjust the
! basic type table appropriately.
LOCAL L1,L2;
LOOK4CHAR = "?L"; ! Any letter
IF (L1 = LEXICAL(.GSTCSCAN)) EQL 0 THEN RETURN FATLEX(E18<0,0>);
L1 = .L1 - "A";
! We have a letter in L1. Lets look for the "-"
LOOK4CHAR = "-";
IF LEXICAL(.GSTCSCAN) EQL 0
THEN
BEGIN ! Just single letter
%1213% ! Give warning if already specifiedd in IMPLICIT statement
%1213% IF .TYPTAB[2 * .L1]<LEFT> EQL #777777
%1213% THEN WARNLEX(E88<0,0>)
%1213% ELSE TYPTAB[2 * .L1]<LEFT> = #777777;
%1213% ! Set implicit type for identifiers
%1213% TYPTAB[2 * .L1]<RIGHT> = .TYPE;
%1213% ! Set character count for character data
%1213% IF .TYPE EQL CHARACTER THEN TYPTAB[2 * .L1 + 1] = .CHLEN;
RETURN 0
END
ELSE
BEGIN ! Look for the second letter
LOOK4CHAR = "?L";
IF (L2 = LEXICAL(.GSTCSCAN)) EQL 0
THEN RETURN FATLEX(E18<0,0>);
! Got one so check to see if they are in ascending order
L2 = .L2 - "A";
IF .L1 LEQ .L2
THEN
BEGIN ! OK - Set implicit type for range of letters
DO
%1213% BEGIN
%1213% ! Give warning if already specified in
%1213% ! IMPLICIT statement
%1213% IF .TYPTAB[2 * .L1]<LEFT> EQL #777777
%1213% THEN WARNLEX(E88<0,0>)
%1213% ELSE TYPTAB[2 * .L1]<LEFT> = #777777;
%1213% ! Set implicit type for identifiers
%1213% TYPTAB[2 * .L1]<RIGHT> = .TYPE;
%1213% ! Set character count for character data
%1213% IF .TYPE EQL CHARACTER
%1213% THEN TYPTAB[2 * .L1 + 1] = .CHLEN;
%1213% END
%1213% WHILE (L1 = .L1 + 1) LEQ .L2;
RETURN 0
END
ELSE RETURN FATLEX(E18<0,0>);
END;
END; ! of IMPLICITSPEC
GLOBAL ROUTINE TOQUOTE=
BEGIN
! Picks up the "TO" for assign statements
LOOK4CHAR = (UPLIT ASCIZ 'TO')<36,7>;
IF LEXICAL(.GSTSSCAN) EQL 0
THEN RETURN FATLEX(E10<0,0>)
ELSE RETURN 0
END; ! of TOQUOTE
GLOBAL ROUTINE LABELANDWHILE= ! [1573] New
! Parses the optional label and WHILE part of a DO WHILE statement.
! The equivalent BNF is
!
! [ LABELEX [ COMMA ] ] %WHILEQUOTE%
!
! where WHILEQUOTE reads "WHILE" with GSTSSCAN. This BNF isn't usable
! because when SYNTAX checks for the an optional LABELEX and it isn't
! found, it sees "WHILE" as an identifier and there's no way to back up.
!
! This routine does not attempt to mimic the tree shape that SYNTAX
! would produce with the above BNF. It returns a LABELEX or 0 on STK,
! and returns success (0) or failure (-1) as its value.
BEGIN
BIND WHILEPLIT = (UPLIT ASCIZ 'WHILE')<36,7>;
! Check for WHILE
LOOK4CHAR = WHILEPLIT;
IF LEXICAL(.GSTSSCAN) NEQ 0
THEN
BEGIN ! WHILE
STK[SP=.SP+1] = 0; ! no label
RETURN 0; ! succeed
END; ! WHILE
! Not WHILE, must be label
LABELS(); ! integers here are labels
LEXL = LEXEMEGEN(); ! read lexeme
NOLABELS(); ! back to integers as integers
IF .LEXL<LEFT> EQL LABELEX ! must have label
THEN STK[SP=.SP+1] = .LEXL ! we do, return it on STK
ELSE RETURN ERR0L(LABLPLIT); ! "found ... when expecting label"
! Check for and skip optional comma
LOOK4CHAR = ","; ! comma
LEXICAL(.GSTCSCAN); ! read it if it's there
! Now we must see WHILE
LOOK4CHAR = WHILEPLIT; ! while
IF LEXICAL(.GSTSSCAN) NEQ 0 ! read it if it's there
THEN RETURN 0 ! it was, succeed
ELSE RETURN FATLEX(E10<0,0>); ! "Statement not recognized"
END; ! LABELANDWHILE
GLOBAL ROUTINE KEY1SPEC = KSPEC(1,2); ! [1546] New
GLOBAL ROUTINE KEY4SPEC = KSPEC(4,4); ! [1546] New
GLOBAL ROUTINE ENCDECSPEC = KEYSCAN(1,3); ! [1677] New
GLOBAL ROUTINE REWSPEC = KUSPEC(1,2); ! [1677] New
GLOBAL ROUTINE FINDSPEC = KEYSCAN(1,2); ! [1677] New
ROUTINE KSPEC (STARTPOS,MAXPOS)= ! [1546] New
! Routine to parse the keyword list or format specifier in READ, WRITE,
! TYPE, ACCEPT, PRINT, PUNCH, and REREAD statements. The specification
! can be either a parenthesized keyword list (as described below in routine
! KEYSCAN) or a format specifier followed by comma.
!
! This routine returns a pointer on STK to a 7-word block. The block
! contains pointers to the UNIT, FMT, variable, REC, END, ERR, IOSTAT
! specifiers, in that order.
BEGIN
REGISTER QFMT,LSP;
! Check for parenthesized keyword list
LOOK4CHAR = "(";
IF LEXICAL(.GSTCSCAN) NEQ 0 ! check for left paren
THEN ! found left paren
BEGIN ! keyword list
! Parse keyword list
KEYSCAN(.STARTPOS,.MAXPOS);
! Read closing right paren
IF .LSAVE NEQ 0 THEN LSAVE = 0 ELSE LEXL = LEXEMEGEN();
IF .LEXL<LEFT> NEQ RPAREN
THEN RETURN ERR0L(RPARPLIT); ! "found ... when expecting ')'"
END ! keyword list
ELSE
BEGIN ! plain format specifier
QFMT = FMTSCAN(); ! read format specifier
IF .QFMT LSS 0 THEN RETURN .QFMT; ! if error, pass it on
! The format specifier must be followed by comma or EOL.
! This routine does not read the comma or EOL, just checks
! that it's there.
IF .LSAVE EQL 0 THEN (LEXL = LEXEMEGEN(); LSAVE = -1);
! peek at next lexeme
IF .LEXL<LEFT> NEQ LINEND ! LINEND is OK
THEN IF .LEXL<LEFT> NEQ COMMA ! COMMA is OK
THEN RETURN ERR0L(.LEXNAM[COMMA]); ! anything else, not OK
LSP = .SP; ! make semantic node
SP = .SP + 7; ! 7 words long
STK[.LSP+1] = 0; ! unit
STK[.LSP+2] = .QFMT; ! fmt
STK[.LSP+3] = 0; ! var
STK[.LSP+4] = 0; ! rec
STK[.LSP+5] = 0; ! end
STK[.LSP+6] = 0; ! err
STK[.LSP+7] = 0; ! iostat
COPYLIST(.LSP); ! copy into 7-word block, leave pointer
! on top of STK
END;
END; ! KSPEC
ROUTINE KUSPEC (STARTPOS,MAXPOS)= ! [1677] New
! Routine to parse the keyword list in REWIND and friends. The specification
! can be either a parenthesized keyword list (as described below in routine
! KEYSCAN) or a unit specifier.
!
! This routine returns a pointer on STK to a 7-word block. The block
! contains pointers to the UNIT, FMT, variable, REC, END, ERR, IOSTAT
! specifiers, in that order.
BEGIN
REGISTER QUNIT,LSP;
! Check for parenthesized keyword list
LOOK4CHAR = "(";
IF LEXICAL(.GSTCSCAN) NEQ 0 ! check for left paren
THEN ! found left paren
BEGIN ! keyword list
! Parse keyword list
KEYSCAN(.STARTPOS,.MAXPOS);
! Read closing right paren
IF .LSAVE NEQ 0 THEN LSAVE = 0 ELSE LEXL = LEXEMEGEN();
IF .LEXL<LEFT> NEQ RPAREN
THEN RETURN ERR0L(RPARPLIT); ! "found ... when expecting ')'"
END ! keyword list
ELSE
BEGIN ! plain unit specifier
QUNIT = UNITSCAN(); ! read unit specifier
IF .QUNIT LSS 0 THEN RETURN .QUNIT; ! if error, pass it on
! The unit specifier must be followed by EOL.
! This routine does not read the EOL, just checks
! that it's there.
IF .LSAVE EQL 0 THEN (LEXL = LEXEMEGEN(); LSAVE = -1);
! peek at next lexeme
IF .LEXL<LEFT> NEQ LINEND ! LINEND is OK
THEN RETURN ERR0L(.LEXNAM[LINEND]); ! anything else, not OK
LSP = .SP; ! make semantic node
SP = .SP + 7; ! 7 words long
STK[.LSP+1] = .QUNIT; ! unit
STK[.LSP+2] = 0; ! fmt
STK[.LSP+3] = 0; ! var
STK[.LSP+4] = 0; ! rec
STK[.LSP+5] = 0; ! end
STK[.LSP+6] = 0; ! err
STK[.LSP+7] = 0; ! iostat
COPYLIST(.LSP); ! copy into 7-word block, leave pointer
! on top of STK
END;
END; ! KUSPEC
ROUTINE KEYSCAN (STARTPOS,MAXPOS)= ! [1465] New
! Routine to look at the control information list (cilist) in READ and WRITE
! and friends. The list can have the following forms:
!
! (u,f,keys) (u'r,f,keys)
! (u,keys) (u'r,keys)
! (keys)
! (u,f) (u'r,f)
! (u) (u'r)
! (u,f,v)
! (u,f,v,keys)
!
! where keys is one or more of
!
! UNIT=u u = integer expression, char variable, char array, *
! FMT=f f = integer variable, numeric array, char expression,
! label, *
! REC=r r = integer expression
! END=s s = label
! ERR=s s = label
! IOSTAT=v v = integer variable
!
! The argument STARTPOS is 1 to read a list that may start with unit, or 4
! to read a list that must be all keywords.
! The argument MAXPOS is 2 to allow positional specification of UNIT and FMT,
! or 3 to allow UNIT, FMT, and an encode/decode variable.
!
! [1702] Crock: if MAXPOS is 3, specifying that a 3-element positional arg list
! is legal (for ENCODE and DECODE), do not allow FMT= keyword.
BEGIN
REGISTER POS; ! Position we're currently at in
! positional arg list.
! position 1: unit expression
! position 2: format expression
! position 3: encode/decode variable
! position 4: keyword list
LOCAL K, ! keyword in sixbit
QUNIT,QFMT,QREC, ! keyword values
QERR,QEND,QIOSTAT,
QVAR,
LSP; ! local SP
QUNIT = QFMT = QREC = QERR = QEND = QIOSTAT = QVAR = 0;
POS = .STARTPOS; ! Start at unit (1) or keywords (4)
DO ! Loop through cilist
BEGIN
K = LEXICAL(.GSTKSCAN); ! Look for "KEYWORD="
IF .K EQL 0 ! If keyword not found, we have a
THEN ! positional argument
BEGIN ! positional arg
CASE .POS OF SET
CGERR(); ! 0
BEGIN ! 1 - u or u'r
POS = 2;
QUNIT = UNITSCAN(); ! read unit expression
IF .QUNIT LSS 0 THEN RETURN .QUNIT;
IF .LSAVE EQL 0 ! peek at following lexeme
THEN (LSAVE = -1; LEXL = LEXOPGEN());
IF .LEXL<LEFT> EQL TICLEX ! If unit was
THEN ! delimited by '
BEGIN ! u'r
LSAVE = 0; ! Read the '
FLGREG<FELFLG> = 0;
! bare array names illegal
IF EXPRESS() LSS 0 THEN RETURN .VREG;
! read rec expression
QREC = .STK[.SP];
SP = .SP - 1;
END; ! u'r
END; ! 1 - u or u'r
BEGIN ! 2 - f
POS = 3;
IF .POS GTR .MAXPOS THEN POS = 4;
QFMT = FMTSCAN(); ! read format expression
IF .QFMT LSS 0 THEN RETURN .QFMT;
END; ! 2 - f
BEGIN ! 3 - variable
POS = 4;
LSP = .SP; ! Save SP for COPYLIST
IF SYNTAX(VARIABLESPEC) LSS 0 ! Parse variable
THEN RETURN .VREG; ! if error, pass it on
COPYLIST(.LSP); ! Copy variable spec off STK
QVAR = .STK[.SP]; ! Get pointer to variable
SP = .LSP; ! Restore SP
SETUSE = IF NOT .IOINPT(@STMNDESC)
THEN SETT ELSE USE;
! ENCODE, the output statement
! of the pair, modifies the
! variable in the cilist
QVAR = BLDVAR(@.QVAR);
! Build DATAOPR or ARRAYREF
IF .QVAR LSS 0 THEN RETURN .QVAR;
END; ! 3 - variable
BEGIN ! 4 - keys
! After unit & format, the only legal thing is
! a list of keywords. If we see more positional
! args, it's an error.
IF .LSAVE EQL 0
THEN (LEXL = LEXEMEGEN(); LSAVE = -1);
! read a lexeme for the error message
! to use
RETURN ERR0L (UPLIT ASCIZ 'keyword');
END ! 4 - keys
TES
END ! positional arg
ELSE
BEGIN ! keyword arg
POS = 4; ! Only keywords legal from now on
IF .K EQL SIXBIT 'UNIT'
THEN
BEGIN ! UNIT=
IF .QUNIT NEQ 0 THEN FATLEX(.K,E182<0,0>);
! "UNIT= may only be specified once"
QUNIT = UNITSCAN();
IF .QUNIT LSS 0 THEN RETURN .QUNIT;
END ! UNIT=
ELSE IF .K EQL SIXBIT 'FMT'
THEN
BEGIN ! FMT=
IF .QFMT NEQ 0 THEN FATLEX(.K,E182<0,0>);
! "FMT= may only be specified once"
QFMT = FMTSCAN();
IF .QFMT LSS 0 THEN RETURN .QFMT;
%1702% IF .MAXPOS EQL 3 ! If in ENCODE/DECODE,
%1702% ! don't allow FMT to be
%1702% ! specified this way
%1702% THEN RETURN FATLEX(E211<0,0>);
END ! FMT=
ELSE IF .K EQL SIXBIT 'REC'
THEN
BEGIN ! REC=
IF .QREC NEQ 0 THEN FATLEX(.K,E182<0,0>);
! "REC= may only be specified once"
FLGREG<FELFLG> = 0;
IF EXPRESS() LSS 0 THEN RETURN .VREG;
QREC = .STK[.SP];
SP = .SP - 1;
END ! REC=
ELSE IF .K EQL SIXBIT 'END'
THEN
BEGIN ! END=
IF .QEND NEQ 0 THEN FATLEX(.K,E182<0,0>);
! "END= may only be specified once"
LABELS(); ! Read number as statement label
NONIOINIO = 1; ! Label must be executable,
! not format
QEND = LEXL = LEXEMEGEN(); ! Read label
NOLABELS(); ! Reset numbers to be integer
! constants
NONIOINIO = 0; ! Reset flag (LABREF does, but
! if we didn't get a label, we
! didn't go through LABREF)
IF .QEND<LEFT> NEQ LABELEX ! Must be a
THEN ERR0L(.LEXNAM[LABELEX]); ! statement label
END ! END=
ELSE IF .K EQL SIXBIT 'ERR'
THEN
BEGIN ! ERR=
IF .QERR NEQ 0 THEN FATLEX(.K,E182<0,0>);
! "ERR= may only be specified once"
LABELS(); ! Read number as statement label
NONIOINIO = 1; ! Executable, not format
QERR = LEXL = LEXEMEGEN(); ! Read label
NOLABELS(); ! Reset numbers to be integers
NONIOINIO = 0; ! Reset flag (LABREF does, but
! if we didn't get a label, we
! didn't go through LABREF)
IF .QERR<LEFT> NEQ LABELEX ! Must be a
THEN ERR0L(.LEXNAM[LABELEX]); ! statement label
END ! ERR=
ELSE IF .K EQL SIXBIT 'IOSTAT'
THEN
BEGIN ! IOSTAT=
IF .QIOSTAT NEQ 0 THEN FATLEX(.K,E182<0,0>);
! "IOSTAT= may only be specified once"
LSP = .SP; ! Save SP for COPYLIST
IF SYNTAX(VARIABLESPEC) LSS 0 ! Parse variable
THEN RETURN .VREG; ! If error, pass it on
COPYLIST(.LSP); ! Copy semantic info
QIOSTAT = .STK[.SP]; ! Get pointer to info
SP = .LSP; ! Restore SP
SETUSE = SETT; ! Variable is modified
IF (QIOSTAT=BLDVAR(@.QIOSTAT)) LSS 0
! Build DATAOPR or
! ARRAYREF node
THEN RETURN .VREG; ! If error, pass it on
END ! IOSTAT=
ELSE RETURN FATLEX(.K,E183<0,0>);
! "unrecognized keyword K"
END;
! Read next lexeme. If it is comma, go do next argument.
! If it is right paren, we have found the end of the list;
! return without reading past the right paren. Otherwise
! it's an error.
IF .LSAVE EQL 0 THEN (LEXL = LEXEMEGEN(); LSAVE = -1);
IF .LEXL<LEFT> EQL COMMA
THEN LSAVE = 0;
END
WHILE .LEXL<LEFT> EQL COMMA;
IF .LEXL<LEFT> EQL RPAREN
THEN LSAVE = -1
ELSE RETURN ERR0L (UPLIT ASCIZ '"," or ")"');
! Put args into a block of information on the semantic stack
LSP = .SP;
SP = .SP + 7;
STK[.LSP+1] = .QUNIT;
STK[.LSP+2] = .QFMT;
STK[.LSP+3] = .QVAR;
STK[.LSP+4] = .QREC;
STK[.LSP+5] = .QEND;
STK[.LSP+6] = .QERR;
STK[.LSP+7] = .QIOSTAT;
COPYLIST(.LSP);
END; ! KEYSCAN
ROUTINE UNITSCAN= ! [1465] New
! Parses unit specifier. Legal syntaxes are *, array name, expression.
! Semantic checks will impose further restrictions.
BEGIN
REGISTER U;
LOOK4CHAR = "*"; ! Check for UNIT=*
IF LEXICAL(.GSTCSCAN) NEQ 0
THEN U = ASTERISK^18 ! Store asterisk lexeme for UNIT=*
ELSE
BEGIN
FLGREG<FELFLG> = 1; ! Allow bare array names
IF EXPRESS() LSS 0 THEN RETURN .VREG; ! Read an expression
U = .STK[.SP];
SP = .SP - 1; ! Remove it from the semantic stack
END;
RETURN .U;
END; ! UNITSCAN
ROUTINE FMTSCAN= ! [1465] New
! Parses format specifier. Legal syntaxes are *, label, array name,
! namelist name, expression. Semantic checks will impose further
! restrictions.
BEGIN
REGISTER BASE F;
REGISTER BASE ID:NAMCOM;
LOCAL NAMROUT;
MAP BASE LEXL;
LOOK4CHAR = "*"; ! Check for FMT=*
IF LEXICAL(.GSTCSCAN) NEQ 0
THEN F = ASTERISK^18 ! Store asterisk lexeme for FMT=*
ELSE
BEGIN
! Check for FMT=label
LABELS(); ! Read numbers as statement labels
LEXL = LEXEMEGEN(); ! Get a lexeme
NOLABELS(); ! Read numbers as integer constants
IF .LEXL<LEFT> EQL LABELEX ! If we got a statement label,
THEN F = .LEXL ! it is the format specifier
ELSE
BEGIN
IF .LEXL<LEFT> EQL IDENTIFIER ! If we got a namelist
AND .LEXL[IDATTRIBUT(NAMNAM)] ! name,
THEN
BEGIN ! namelist
F = .LEXL; ! set format specifier to
! namelist name
IF NAMREF(NMLSTREF,.F) LSS 0 THEN RETURN .VREG;
! Call NAMREF or NAMSET for the variables
! in the namelist
NAMROUT = IF .TYPE EQL READD
THEN NAMSET ELSE NAMREF;
NAMCOM = .F[IDCOLINK];
INCR NMLST FROM .NAMCOM[NAMLIST]
TO .NAMCOM[NAMLIST]
+.NAMCOM[NAMCNT] - 1
DO
BEGIN
ID = @.NMLST;
(.NAMROUT)(.ID[OPRSP1],.ID);
END;
END ! namelist
ELSE
BEGIN ! not label, not namelist
LSAVE = -1; ! Otherwise back up over the
! lexeme we just read
FLGREG<FELFLG> = 1; ! Allow bare array names
IF EXPRESS() LSS 0 THEN RETURN .VREG;
! Read FMT expression
F = .STK[.SP];
SP = .SP - 1; ! Remove it from the stack
END ! not label, not namelist
END
END;
RETURN .F;
END; ! FMTSCAN
GLOBAL ROUTINE EXPRLIST=
BEGIN
! PROCESS THE ARGUMENT LIST OF A CALL STATEMENT
LOCAL LSP;
MACRO STKSIZE=250$; ! For checking stack overflow
REGISTER BASE T1,VAL;
T1 = .STK[.SP - 1]; ! T1 is loc(identifier)
IF (VAL = NAMREF(FNNAME1, .T1)) LSS 0
THEN RETURN .VAL; ! Name conflict
T1[OPERSP] = IF .T1[IDATTRIBUT(DUMMY)] THEN FORMLFN ELSE FNNAME;
! Now scan the list of expressions (zero or more separated by commas)
! which must follow.
LSP = .SP;
LSAVE = -1;
%1217% LEXL = LEXEMEGEN();
%1217% IF .LEXL<LEFT> EQL RPAREN ! As in CALL FOO() - empty list
%1217% THEN STK[SP = .SP + 1] = 0 ! Empty list set up
%1217% ELSE
WHILE 1 DO
BEGIN
FLGREG<FELFLG> = 1;
! Allow * as initial character for label too.
IF (.LEXL<LEFT> NEQ DOLLAR)
AND (.LEXL<LEFT> NEQ ANDSGN)
AND (.LEXL<LEFT> NEQ ASTERISK)
THEN
BEGIN
STK[SP = .SP + 1] = 1; ! Expression
IF (VAL = EXPRESS()) LSS 0 THEN RETURN .VAL;
! Express puts its result on STK[SP = .SP + 1] and
! returns next lexeme in lexl
END
ELSE
BEGIN
STK[SP = .SP + 1] = 2; ! Label arg
LOOK4LABEL = 1;
STK[SP = .SP + 1] = LEXL = LEXEMEGEN();
IF .LEXL<LEFT> NEQ LABELEX
THEN RETURN FATLEX(LABLPLIT,LEXPLITV,E0<0,0>);
%716% T1 = .LEXL<RIGHT>; ! Get label address
%716% T1[SNRFS] = 1; ! Mark label as being jumped to
%716% ! by a return from a subroutine
%716% ! call
LEXL = LEXEMEGEN();
END;
IF .LEXL<LEFT> NEQ COMMA
THEN EXITLOOP
%1217% ELSE LEXL = LEXEMEGEN();
! Make sure that a super long list of arguments will not
! overflow stk
IF .SP GTR STKSIZE - 3
THEN
BEGIN
COPYLIST(.LSP);
LSP = .SP;
END;
END;
LSAVE _ -1;
COPYLIST(.LSP);
RETURN 0
END; ! of EXPRLIST
GLOBAL ROUTINE CMNCOMMA= ! [1410] New
BEGIN
! This routine is responsible for parsing the optional comma in
!
! COMMON A,/B/C
!
! This is problematical because the thing preceding the comma is a
! list of ONEARRAYs separated by commas. The comma gets read as a
! list separator, not as an optional comma terminating the list.
! The solution is to check for ",/" before allowing the comma to
! be seen as a list separator.
!
! This routine always succeeds. It leaves things alone if called
! before a comma which is a list separator. It reads and discards
! a comma which is followed by / or //. The / or // is not read
! by this routine.
IF .LSAVE NEQ 0
THEN
BEGIN ! If a lexeme is already saved then that lexeme is the
! first char of the string we're looking for.
IF .LEXL<LEFT> NEQ COMMA THEN RETURN 0; ! Not comma, no match
LOOK4CHAR = (UPLIT '//')<36,7>; ! Comma followed by //?
IF LEXICAL(.GSTSSCAN) NEQ 0
THEN
BEGIN
LEXL<LEFT> = CONCAT; ! Yes, delete comma, return //
RETURN 0;
END;
LOOK4CHAR = (UPLIT '/')<36,7>; ! Comma followed by /?
IF LEXICAL(.GSTSSCAN) NEQ 0
THEN
BEGIN
LEXL<LEFT> = SLASH; ! Yes, delete comma, return /
RETURN 0;
END;
RETURN 0; ! Comma followed by other stuff,
! return the other stuff
END;
! Else no saved lexeme
LOOK4CHAR = (UPLIT ',//')<36,7>; ! Comma followed by //?
IF LEXICAL(.GSTSSCAN) NEQ 0
THEN
BEGIN
LSAVE = -1; ! Ignore the comma, return the //
LEXL<LEFT> = CONCAT;
RETURN 0;
END;
LOOK4CHAR = (UPLIT ',/')<36,7>; ! Comma followed by ?
IF LEXICAL(.GSTSSCAN) NEQ 0
THEN
BEGIN
LSAVE = -1; ! Ignore the comma, return the /
LEXL<LEFT> = SLASH;
RETURN 0;
END;
RETURN 0; ! Otherwise comma, if present, is a list
! separator
END; ! of CMNCOMMA
GLOBAL ROUTINE CHARGLIST(OLDARGLIST)=
BEGIN
%1434% ! Written by TFV on 7-Dec-81
! Generate the argument list for a character function. It has an
! extra argument. It is the first argument and is the descriptor
! for the result. The space for the old argument list is freed;
! the new argument list is returned.
MAP ARGUMENTLIST OLDARGLIST;
REGISTER
ARGUMENTLIST ARGLIST,
NUMARGS;
IF .OLDARGLIST EQL 0
THEN NUMARGS = 1 ! New argument list has one element
ELSE NUMARGS = .OLDARGLIST[ARGCOUNT] + 1; ! New argument list is
! 1 larger
NAME<LEFT> = ARGLSTSIZE(.NUMARGS); ! Compute size of block needed
ARGLIST = CORMAN(); ! Get the space
IF .OLDARGLIST NEQ 0
THEN
BEGIN ! An old argument list exists
! Copy the header words to the new argument list
DECR I FROM ARGHDRSIZ - 1 TO 0
DO (.ARGLIST)[.I] = .(.OLDARGLIST)[.I];
! Copy the argument pointers
DECR I FROM .NUMARGS - 1 TO 1
DO ARGLIST[.I + 1, ARGFULL] = .OLDARGLIST[.I, ARGFULL];
! Return the space for the old argument list
SAVSPACE(ARGLSTSIZE(.OLDARGLIST[ARGCOUNT]) - 1, .OLDARGLIST);
END; ! An old argument list exists
ARGLIST[ARGCOUNT] = .NUMARGS; ! Setup number of arguments
RETURN .ARGLIST; ! Return the new argument list
END; ! of CHARGLIST
GLOBAL ROUTINE PARMASSIGN = ! [1656] New
! Action routine to do parameter definition
! Parses
! IDENTIFIER = %CONSTEXPR%
! and assigns the value of the constant expression to the identifier,
! type-converting it if appropriate. A warning is given if:
! - /F77
! - the parens around the parameter list are omitted
! - the parameter variable and the expression differ in type
BEGIN
REGISTER BASE ID:EXPR;
! Read identifier lexeme
IF .LSAVE NEQ 0 THEN LSAVE = 0 ELSE LEXL = LEXEMEGEN();
IF .LEXL<LEFT> NEQ IDENTIFIER THEN RETURN ERR0L(IDENPLIT);
ID = .LEXL;
! Read EQUAL
IF LEXEMEGEN() NEQ EQUAL^18 THEN RETURN ERR0V(.LEXNAM[EQUAL]);
! Read CONSTEXPR
IF CONSTEXPR() LSS 0 THEN RETURN .VREG;
EXPR = .STK[.SP]; SP = .SP - 1;
! Define the identifier with the value of the expression.
! Convert the expression to match the type of the parameter if
! the parameter list was enclosed in parentheses. If no parens,
! we have a /F66 style parameter statement. Do not convert, but
! give a warning if a conversion would have occurred.
IF NAMDEF (PARADEF, .ID) LSS 0 THEN RETURN .VREG;
ID[IDATTRIBUT(PARAMT)] = 1;
ID[IDPARAVAL] = .EXPR;
IF .ID[VALTYPE] NEQ .EXPR[VALTYPE] OR .ID[VALTYPE] EQL CHARACTER
THEN IF .PARMCNV NEQ 0
THEN ID[IDPARAVAL]=CNVCONST(.EXPR,.ID,.EXPR[VALTYPE],.ID[VALTYPE])
ELSE IF F77 THEN WARNLEX(.ID[IDSYMBOL],E198<0,0>);
! "Parameter X will not be type converted"
! Suppress warning if /F66
END; ! PARMASSIGN
GLOBAL ROUTINE PARMLPAREN = ! [1656] New
! Action routine to read optional left paren for parameter statement.
! Sets PARMCNV if left paren seen, clears it otherwise.
BEGIN
LEXL = LEXEMEGEN();
IF .LEXL<LEFT> EQL LPAREN
THEN PARMCNV = -1
ELSE (PARMCNV = 0; LSAVE = -1);
END; ! PARMLPAREN
GLOBAL ROUTINE PARMRPAREN = ! [1656] New
! Checks for and reads right paren in PARAMETER statement
BEGIN
LOCAL RFLAG;
IF .LSAVE NEQ 0 THEN LSAVE = 0 ELSE LEXL = LEXEMEGEN();
IF .LEXL<LEFT> EQL RPAREN
THEN RFLAG = -1
ELSE (RFLAG = 0; LSAVE = -1);
IF .RFLAG NEQ .PARMCNV THEN RETURN FATLEX (E9<0,0>);
! "Unmatched parentheses"
END; ! PARMRPAREN
GLOBAL ROUTINE CONSTEXPR= ! [1527] New
! Action routine to parse and evaluate a constant expression.
! Returns -1 if an error is encountered, or 0 if no error.
! If no error is encountered, also returns a constant lexeme on STK.
BEGIN
REGISTER BASE CONST;
IF EXPRESS() LSS 0 THEN RETURN .VREG; ! Read an expression.
! If error, pass it on
CONST = EVAL(.STK[.SP]); ! Evaluate expression
IF .CONST LSS 0 ! Check if error
THEN
BEGIN
SP = .SP - 1; ! If error, clean up STK
RETURN .CONST; ! Pass the error on
END
ELSE
BEGIN
STK[.SP] = .CONST; ! No error, put the constant on STK
STK[.SP]<LEFT> = IF .CONST[VALTYPE] EQL CHARACTER
THEN LITSTRING ELSE CONSTLEX;
! Put lexeme name on STK
RETURN 0; ! Return success
END;
END; ! CONSTEXPR
ROUTINE EVAL (EXPR) = ! [1527] New
! Routine to evaluate a constant expression.
! (At present, works on expressions produced by EXPRESS. Certain nodes,
! viz. SPECOP, INLINFN, and CMNSUB, which cannot occur this early, are not
! handled.)
!
! Returns constant lexeme on success, -1 on error.
! SAVSPACEs the expression tree.
BEGIN
MAP BASE EXPR;
REGISTER BASE ARG1:ARG2;
LOCAL BASE ARGPTR:RESULTPTR:RESULT:ARG;
LOCAL ARGUMENTLIST ARGL;
LOCAL LEN;
CASE .EXPR[OPRCLS] OF SET
BEGIN ! BOOLEAN
! Evaluate args
IF (ARG1 = EVAL(.EXPR[ARG1PTR])) LSS 0 THEN RETURN .VREG;
IF (ARG2 = EVAL(.EXPR[ARG2PTR])) LSS 0 THEN RETURN .VREG;
! Set opcode and operands for CNSTCM
COPRIX = KBOOLOPIX(EXPR);
C1L = IF .ARG1[VALTP1] EQL INTEG1
THEN .ARG1[CONST2]
ELSE .ARG1[CONST1];
C2L = IF .ARG2[VALTP1] EQL INTEG1
THEN .ARG2[CONST2]
ELSE .ARG2[CONST1];
! Do the operation and return
CNSTCM();
SAVSPACE(EXSIZ-1,.EXPR);
RETURN MAKECNST(LOGICAL,0,.C2L);
END; ! BOOLEAN
BEGIN ! DATAOPR
! Leaf: check that it's a constant
IF .EXPR[OPERSP] EQL CONSTANT
THEN RETURN .EXPR
ELSE RETURN FATLEX(E195<0,0>); ! "Constant required"
END; ! DATAOPR
BEGIN ! RELATIONAL
BIND VECTOR TRAN = UPLIT (0,1,2,3,0,6,5,4);
REGISTER COND;
! Evaluate args
COND = 0;
IF (ARG1 = EVAL(.EXPR[ARG1PTR])) LSS 0 THEN RETURN .VREG;
IF (ARG2 = EVAL(.EXPR[ARG2PTR])) LSS 0 THEN RETURN .VREG;
! Set COND to .LT. (1), .EQ. (2), or .GT. (4)
IF .ARG1[CONST1] LSS .ARG2[CONST1]
THEN COND = .COND OR 1;
IF .ARG1[CONST1] EQL .ARG2[CONST1]
THEN
BEGIN
IF .ARG1[CONST2] LSS .ARG2[CONST2]
THEN COND = .COND OR 1;
IF .ARG1[CONST2] EQL .ARG2[CONST2]
THEN COND = .COND OR 2;
IF .ARG1[CONST2] GTR .ARG2[CONST2]
THEN COND = .COND OR 4;
END;
IF .ARG1[CONST1] GTR .ARG2[CONST1]
THEN COND = .COND OR 4;
! Now COND encodes whether ARG1 is greater than, equal to,
! or less than ARG2. The TRAN table tells for each relational
! operator which COND values satisfy the operator.
! Compute whether the relation is satisfied or not.
COND = .COND AND .TRAN[.EXPR[OPERSP]];
SAVSPACE(EXSIZ-1,.EXPR);
! Return an appropriate logical constant
IF .COND NEQ 0
THEN RETURN MAKECNST(LOGICAL,0,TRUE)
ELSE RETURN MAKECNST(LOGICAL,0,FALSE);
END; ! RELATIONAL
BEGIN ! FNCALL
! Check first arg; must be CHAR or ICHAR
ARG1 = .EXPR[ARG1PTR];
IF .ARG1[IDSYMBOL] EQL SIXBIT 'CHAR.'
THEN
BEGIN ! CHAR.
IF (ARG2 = EVAL(NTHARG(2,.EXPR))) LSS 0
THEN RETURN .VREG;
ARG1 = MAKLIT(1);
ARG1[LIT1] = .ARG2[CONST2]^29 + " "^1;
SAVSPACE(EXSIZ-1,.EXPR);
RETURN .ARG1;
END ! CHAR.
ELSE IF .ARG1[IDSYMBOL] EQL SIXBIT 'ICHAR.'
THEN
BEGIN ! ICHAR.
IF (ARG2 = EVAL(NTHARG(1,.EXPR))) LSS 0
THEN RETURN .VREG;
SAVSPACE(EXSIZ-1,.EXPR);
RETURN MAKECNST (INTEGER,0, .ARG2[LITC2]);
END ! ICHAR.
ELSE RETURN FATLEX(E195<0,0>); ! "Constant required"
END; ! FNCALL
BEGIN ! ARITHMETIC
! Evaluate args
IF (ARG1 = EVAL(.EXPR[ARG1PTR])) LSS 0 THEN RETURN .VREG;
IF (ARG2 = EVAL(.EXPR[ARG2PTR])) LSS 0 THEN RETURN .VREG;
! Check for exponentiation
IF .EXPR[OPERSP] EQL EXPONOP
THEN
BEGIN ! exponentiation
! Make sure exponent is integer
IF .ARG2[VALTYPE] NEQ INTEGER
THEN FATLEX(E199<0,0>);
COPRIX = KEXPIX(.ARG1[VALTP1]);
END ! exponentiation
ELSE
BEGIN ! mundane
COPRIX = KARITHOPIX(EXPR);
END; ! mundane
C1H = .ARG1[CONST1]; C1L = .ARG1[CONST2];
C2H = .ARG2[CONST1]; C2L = .ARG2[CONST2];
! Do the operation and return
CNSTCM();
SAVSPACE(EXSIZ-1,.EXPR);
RETURN MAKECNST(.EXPR[VALTYPE], .C2H, .C2L);
END; ! ARITHMETIC
BEGIN ! TYPECNV
! Evaluate the operand
IF (ARG2 = EVAL(.EXPR[ARG2PTR])) LSS 0 THEN RETURN .VREG;
! Call CNSTCM to do the conversion
C1H = .ARG2[CONST1];
C1L = .ARG2[CONST2];
COPRIX = KTPCNVIX(EXPR);
CNSTCM();
SAVSPACE(EXSIZ-1,.EXPR);
RETURN MAKECNST(.EXPR[VALTYPE],.C2H,.C2L);
END; ! TYPECNV
BEGIN ! ARRAYREF
RETURN FATLEX(E195<0,0>); ! "not constant"
END; ! ARRAYREF
BEGIN ! CMNSUB
CGERR();
END; ! CMNSUB
BEGIN ! NEGNOT
IF (ARG2 = EVAL(.EXPR[ARG2PTR])) LSS 0 THEN RETURN .VREG;
IF .EXPR[OPERSP] EQL NEGOP
THEN RETURN NEGCNST(.ARG2)
ELSE RETURN NOTCNST(.ARG2);
END; ! NEGNOT
BEGIN ! SPECOP
CGERR();
END; ! SPECOP
BEGIN ! FIELDREF
CGERR();
END; ! FIELDREF
BEGIN ! STORECLS
CGERR();
END; ! STORECLS
BEGIN ! REGCONTENTS
CGERR();
END; ! REGCONTENTS
BEGIN ! LABOP
CGERR();
END; ! LABOP
BEGIN ! STATEMENT
CGERR();
END; ! STATEMENT
BEGIN ! IOLSCLS
CGERR();
END; ! IOLSCLS
BEGIN ! INLINFN
CGERR();
END; ! INLINFN
BEGIN ! SUBSTRING
RETURN FATLEX(E195<0,0>); ! "not constant"
END; ! SUBSTRING
BEGIN ! CONCATENATION
ARGL = .EXPR[ARG2PTR];
! Look through argument list EVALing the args and accumulating
! the result string length.
LEN = 0;
INCR N FROM 2 TO .ARGL[ARGCOUNT] DO
BEGIN
IF (ARGL[.N,ARGNPTR] = ARGPTR = EVAL(.ARGL[.N,ARGNPTR])) LSS 0
THEN RETURN .VREG; ! If error, pass it on
LEN = .LEN + .ARGPTR[LITLEN];
END;
! Allocate literal table node for result string
RESULT = MAKLIT(.LEN);
! Copy strings into result
RESULTPTR = RESULT[LITC1];
INCR N FROM 2 TO .ARGL[ARGCOUNT] DO
BEGIN
ARG = .ARGL[.N,ARGNPTR];
ARGPTR = ARG[LITC1];
DECR I FROM .ARG[LITLEN] TO 1 DO
COPYII(ARGPTR,RESULTPTR);
END;
! Insert trailing spaces to bring string up to
! word boundary
WHILE .RESULTPTR<31,5> NEQ 0
DO REPLACEI(RESULTPTR," ");
! Clean up
!SAVSPACE(ARG LIST);
!SAVSPACE(CONCAT NODE);
RETURN .RESULT;
END ! CONCATENATION
TES;
END; ! EVAL
ROUTINE NTHARG (N,CNODE) =
! Returns Nth argument of function call node CNODE.
! The argument list has already been validated by MAKLIBFUN.
BEGIN
MAP BASE CNODE;
REGISTER ARGUMENTLIST ARGL;
ARGL = .CNODE[ARG2PTR]; ! Get pointer to arg list
RETURN .ARGL[.N,ARGNPTR]; ! Return Nth arg
END; ! NTHARG
GLOBAL ROUTINE CNVCONST (CNODE, TONODE, FROMTYPE, TOTYPE) = ! [1527] New
! Routine to convert constant to desired type. Used to convert F77 parameters
! to match the type declared for the parameter. Under /F66, parameters have
! the type of the expression, not the parameter name.
!
! Args: CNODE = constant node to be converted
! TONODE = identifier node (gives character length to convert to)
! FROMTYPE = valtype of constant
! TOTYPE = desired valtype
BEGIN
MAP BASE TONODE:CNODE;
REGISTER BASE FROMPTR:TOPTR:RESULT;
IF .FROMTYPE EQL .TOTYPE
THEN
BEGIN ! types match
IF .TOTYPE NEQ CHARACTER ! converting numeric to numeric?
THEN RETURN .CNODE; ! yes, done
IF .TONODE[IDCHLEN] EQL LENSTAR ! converting to length *?
THEN RETURN .CNODE; ! yes, result length is length of RHS
IF .CNODE[LITLEN] EQL .TONODE[IDCHLEN] ! lengths match?
THEN RETURN .CNODE; ! yes, return RHS
! copy string to literal node of correct length
RESULT = MAKLIT(.TONODE[IDCHLEN]);
FROMPTR = CNODE[LITC1];
TOPTR = RESULT[LITC1];
DECR I FROM .TONODE[IDCHLEN] TO 1 DO
COPYII(FROMPTR,TOPTR);
WHILE .TOPTR<31,5> NEQ 0 ! put 0-4 trailing spaces at end
DO REPLACEI(TOPTR," ");
RETURN .RESULT + LITSTRING^18;
! return copied string as string lexeme
END; ! types match
IF .TOTYPE EQL CHARACTER ! converting numeric to character?
THEN RETURN FATLEX(E160<0,0>); ! yes, error, can't be done
! Numeric to numeric conversion, call CNSTCM to do the work
C1H = .CNODE[CONST1];
C1L = .CNODE[CONST2];
COPRIX = (VTP2(.FROMTYPE))^3 + VTP2(.TOTYPE)
+ (IF .GFLOAT THEN KTYPCG ELSE KTYPCB);
CNSTCM();
RETURN MAKECNST (.TOTYPE, .C2H, .C2L) + CONSTLEX^18;
END; ! CNVCONST
GLOBAL ROUTINE ASTEREXPR = ! [1527] New
! Action routine to read array declarator bounds. Allows asterisk, expression,
! or constant expression. Returns (on STK) a constant, expression, or asterisk.
! Returns -1 on error, 0 on success.
BEGIN
LOCAL BASE CONST;
IF .LSAVE NEQ 0 THEN LSAVE = 0 ELSE LEXL = LEXEMEGEN();
IF .LEXL<LEFT> EQL ASTERISK THEN STK[SP=.SP+1] = .LEXL
ELSE
BEGIN ! Constant or expression
LSAVE = -1;
%1670% IF EXPRESS() LSS 0 THEN RETURN .VREG;
%1670% ! Read an expression
%1670% IF CONSTP(.STK[.SP]) ! Check if expression is constant
%1670% THEN
%1670% BEGIN
%1670% CONST = STK[.SP] = EVAL(.STK[.SP]);
%1670% ! Evaluate constant expression
%1670% IF .CONST LSS 0 THEN RETURN .CONST;
%1670% STK[.SP]<LEFT> = IF .CONST[VALTYPE] EQL CHARACTER
%1670% THEN LITSTRING ELSE CONSTLEX;
%1670% RETURN 0;
%1670% END;
END; ! Constant or expression
RETURN 0; ! succeed
END; ! ASTEREXPR
ROUTINE CONSTP (EXPR) = ! [1670] New
! Return true iff EXPR is a constant expression
BEGIN
MAP BASE EXPR;
SELECT .EXPR[OPRCLS] OF NSET
DATAOPR:
RETURN .EXPR[OPERSP] EQL CONSTANT;
FNCALL: RETURN 0;
ARRAYREF: RETURN 0;
SUBSTRING: RETURN 0;
CONCATENATION: RETURN 0;
TYPECNV: RETURN CONSTP(.EXPR[ARG2PTR]);
NEGNOT: RETURN CONSTP(.EXPR[ARG2PTR]);
OTHERWISE: ! binary
RETURN
IF CONSTP(.EXPR[ARG1PTR]) THEN CONSTP(.EXPR[ARG2PTR]) ELSE 0;
TESN;
END; ! CONSTP
END
ELUDOM