Trailing-Edge
-
PDP-10 Archives
-
bb-4157j-bm_fortran20_v11_16mt9
-
fortran-compiler/act0.bli
There are 12 other files named act0.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1987
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
!AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!AUTHOR: F.J. INFANTE, D. B. TOLMAN/DCE/TFV/EGM/AHM/CKS/CDM/TGS/TJK/AlB/MEM
MODULE ACT0(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
GLOBAL BIND ACT0V = #11^24 + 0^18 + #4530; ! Version Date: 17-Feb-86
%(
***** 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 V7 Development *****
1732 CDM 10-Mar-83
Add code to check for the length of a character constant in a
PARAMETER statement. If the word length of the identifier is
longer than the constant, build a new constant and pad with
blanks.
1740 CDM 7-Apr-83
Make constant expressions work for EQUIVALENCE statements.
EVAL must be a global routine.
1765 TGS 29-Jun-83
Fix KEYSCAN to check for ENCODE/DECODE without a third
positional argument. Improve error messages for mis-positioned
optional keyword arguments.
1777 TJK 13-Sep-83
Make KSPEC and KUSPEC pass errors from KEYSCAN.
Also add explicit zero return for no error.
2055 CDM 30-May-84
Edit 1732 did not check for a PARAMETER constant not being of
type character so that a illegal constant could make the
compiler get a non informative compiler error (illegal
instrucion) before the problem can be properly reported to the
user.
***** End Revision History *****
***** Begin Version 10 *********
2253 AlB 28-Dec-83
Added code for compatibility flagger.
Routines:
EXPRLIST, FMTSCAN, KEYSCAN, PARMLPAREN
2261 AlB 5-Jan-84
Set global variable IOSPEC to true if I/O specifiers were found
inside parentheses, and false otherwise. This helps the compatibility
flagger detect "PRINT (FMT=f) iolist" which is extension to Fortran-77
and incompatible with VAX.
Routine:
KSPEC
2270 AlB 16-Jan-84
FMTSCAN, upon encountering 'FMT=namelist', will go through that
list in order to do NAMSET or NAMREF calls for each of the items in
the list. This process caused a redundant, and to some extent confusing,
VAX compatibility warning; VAX compatibility flagging is now turned
off during those calls.
It should be noted that the incompatibilities are flagged when the
NAMELIST statement itself is parsed, so nothing falls through a crack.
2341 AlB 17-Apr-84
Added NML to list of acceptable keywords in KEYSCAN. NML= is
equivalent to FMT= except that its argument may only be a NAMELIST
name.
Added the NMLSCAN routine to handle the NML= keyword.
Since FMTSCAN and NMLSCAN do identical processing for a namelist
key value, the NMLIOREF routine was added to be called by both
FMTSCAN and NMLSCAN.
If VAX compatibility flagging is being done, then a warning will
be issued if 'FMT=namelist' is used (VAX wants 'NML=namelist').
2370 MEM 14-Jun-84
Calls to FATLEX with E182 or E183 were changed to pass the address
of the specifier to be printed in the error message instead of
passing the specifier itself.
2424 MEM 13-Jul-84
Check for IOSTAT in read/write statements instead of only
checking the first five characters and ignoring the rest.
2436 MEM 31-Jul-84
Replace K, in calls to FATLEX in KEYSCAN, with KEYBUFFER
2455 MEM 30-Aug-84
Replace all references to VAX with VMS.
2461 CDM 28-Sept-84
Add octal and hexadecimal constants for the Military Standard
MIL-STD-1753 to DATA statements.
Add routines OCTHEX and GETDIGIT.
Fix error message in CNVCONST. It was not giving a variable
name to an error message that expects it.
2473 CDM 29-Oct-84
Add IMPLICIT NONE for the Military Standard MIL-STD-1753.
2507 CDM 20-Dec-84
Add enhancement for IMPLICIT NONE (edit 2473) after code inpsection.
Check more cases, and add a symbol table walk at the back
end to catch unreferenced variables.
2510 CDM 4-Jan-85
Enhancements to edit 2461 for octal and hexadecimal constants in
DATA statements. Better error messages and significant leading
zeroes to match the already existing octal constants.
***** End V10 Development *****
2537 CDM 16-JUL-85
When no FMT= or NML= is given in a format expression,
FMT= is default. FMTSCAN is called, but doesn't
know if it is FMT= has really been given or not.
Add argument to indicate this.
***** End Revision History *****
***** Begin Version 11 *****
4501 MEM 22-Jan-85
Modified KEYSCAN to scan for the new indexed read specifiers.
4516 CDM 2-Oct-85
Phase I.I for VMS long symbols. Pass Sixbit to all error message
routines, do not pass addresses of Sixbit anymore. In later edits
this will pass [length,,pointer to symbol] instead of a pointer to
this to the error message routines.
4527 CDM 1-Jan-86
VMS Long symbols phase II. Convert all internal symbols from
one word of Sixbit to [length,,pointer].
4530 MEM 17-Feb-86
Add support for long symbols. Handle conflict of INTEGER FUNCTION x
which can be either function declaration of X or declaration of
identifier FUNCTIONX.
4534 CDM 12-May-86
Correct error message. KEYBUFFER was being overwritten before
error message was displayed.
ENDV11
)%
!++
! These are the action routines for the BNF.
!
! To return a value to the BNF, return:
!
! -1 Didn't find what I wanted.
!
! 0 Success, I found what I wanted.
!--
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, ! Parse for data type or NONE on IMPLICIT
%2473% IMPCHK, ! Check if IMPLICIT NONE was parsed by TYPEID
IMPLICITSPEC,
TOQUOTE,
KSPEC,
KUSPEC,
KEYSCAN,
UNITSCAN,
FMTSCAN,
%2341% NMLSCAN, ! Handle NML= keyword
%2341% NMLIOREF(1), ! Handle namelist for both FMTSCAN and NMLSCAN
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,
%2461% OCTHEX, ! Action routine to read an octal/hex constant
%2461% GETDIGIT; ! Gets a digit, called by OCTHEX.
EXTERNAL
ACTLDATYPE,
%2473% ANSIPLIT, ! 'Extension to Fortran 77:'
BASE ASTATFUN,
BLDVAR,
ASTER,
C1H, ! Arguments to CNSTM
C1L, ! Arguments to CNSTM
C2H, ! Arguments to CNSTM
C2L, ! Arguments to CNSTM
%2253% CFLEXB, ! Put out compatibility warning
CGERR,
%1213% CHDECL, ! Flag for character declaration seen
%1213% CHDLEN, ! Default character count for character data
%1213% CHLEN, ! Character count for character data
CNSTCM, ! Constant combine routine
COPRIX, ! Arguments to CNSTM
COPYLIST,
CORMAN, ! Routine to get space from free memory
%4527% CPYSYM, ! Copies [length,,pointer] to unique memory
E9,
%2461% E64, ! Constant underflow or overflow
%1061% E150,
E160,
%2461% E163, ! Illegal combination of character and numeric data
E182,
E183,
E195,
E198,
E199,
E211,
%2253% E218, ! Extension to Fortran-77: Apostrophe in I/O keyword
%2253% E237, ! Extension to Fortran-77: Format in numeric array
%2455% E240, ! VMS incompatibility: FMT= used instead of NML=
%2341% E262, ! Extension to Fortran-77: Use of NAMELIST
%2253% E264, ! Extension to Fortran-77: Missing parens around PARAMETER
%2253% E270, ! Extension to Fortran-77: & used as return label
%2253% E271, ! Fortran-77 or VMS: $ used as return label
%2341% E298, ! NML= must have only namelist name
%2461% E302, ! Octal & hex constants are extensions
%2473% E303, ! IMPLICIT NONE
%4501% E306, ! only 1 of KEY,KEYEQ,KEYGE,KEYGT can be specified
%4501% E312, ! Illegal valtype of expression
ENTRSTA,
ENTRY,
EXPRESS,
FINDSTA,
FNTMP, ! Counter for .Fnnnn temporaries
GSTCSCAN,
GSTKSCAN,
GSTLEXEME,
GSTSSCAN,
GTYPCOD,
IDTYPE,
%2473% IMPNONE, ! Flag for IMPLICIT NONE
KARIIB,
KARIGB,
KBOOLBASE,
%2461% KDNEGB, ! Negate double word
%2424% KEYBUFFER, ! 4 word buffer containing keyword found in LEXICA
KSPECB,
KSPECG,
KTYPCB,
KTYPCG,
LEXEMEGEN,
LEXICAL,
%2473% LEXLINE, ! Line number that we're parsing
LEXOPGEN,
LEXL,
%1732% LITPOINTER, ! Pointer to first,,last linked literals
LOOK4CHAR,
LOOK4LABEL,
LSAVE,
%1535% MAKLIT, ! Make empty literal table node
NAME, ! Global argument to CORMAN
NAMDEF,
NAMREF,
NAMSET,
NEWENTRY,
NONIOINIO,
%4527% ONEWPTR, ! Returns [1,,pointer] to Sixbit argument passed
%1732% PRVLIT, ! Previous literal in the linked list
PROGNAME,
SAVSPACE, ! Routine to free space
SETUSE,
SP,
STK,
STMNDESC,
SYNTAX,
TYPE,
%2473% TYPIMP, ! Flag for whether variables are typed IMPLICITly
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
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;
%4527% RETURN CPYSYM( ONEWPTR(.VAL) ); ![length,,pointer]
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, ! formal argument
BASE SAV, ! used to switch names
BASE TMP; ! .Fnnnn variable
! Get a variable
STK[SP = .SP + 1] = LEXL = LEXICAL(.GSTLEXEME);
IF .LEXL<LEFT> NEQ IDENTIFIER
THEN IF .LEXL<LEFT> EQL CONSTLEX
%4516% THEN RETURN FATLEX(PLIT'dimensioned',.ASTATFUN[IDSYMBOL],E15<0,0>)
ELSE RETURN ERR0L(IDENPLIT);
ID = .LEXL<RIGHT>;
! Generate a new formal variable, insert it in the symbol table
! after the existing argument and swap the names so that the
! previously existing argument becomes a .Fnnnn variable.
SAV = .ID[CLINK];
NAME = IDTAB;
TMP = ID[CLINK] = NEWENTRY(); ! New variable
TMP[CLINK] = .SAV;
TMP[IDSYMBOL] = .ID[IDSYMBOL]; ! Name of the formal argument
ID[IDSYMBOL] = TMPGN(); ! .Fnnnn variable name
! Copy/create the info needed for this new variable
TMP[IDATTRIBUT(DUMMY)] = -1; ! Mark it as a dummy argument
%2473% TMP[IDATTRIBUT(INTYPE)] = .ID[IDATTRIBUT(INTYPE)]; ! Declared?
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
%4530% !PROGNAME = MAIN. by default if no program/function/subroutine name was specified
%4530% !If a program/function/subroutine name was specified then
%4530% ! ddd FUNCTION nnn
%4530% !is declaration of identifier FUNCTIONnnn of data type ddd
%4530% !since it is not a function declaration so exit this routine
%4530%
%4530% !where ddd is a datatype (INTEGER,REAL,CHARACTER...) and
%4530% ! nnn is an symbol/number
%4530%
%4530% IF @(.PROGNAME<SYMPOINTER>) NEQ SIXBIT 'MAIN.'
%4530% THEN RETURN -1;
! Scan for the string "FUNCTION". If it is found then call this a
! function.
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 =
!++
! FUNCTIONAL DESCRIPTION:
!
! This action routine parses the valid characters following
! "IMPLICIT". They are either a data type or "NONE". If a data
! type, 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.
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! ANSIPLIT Characters for error message about ansi-F77 standard
!
! E17, E303 Error messages for IMPLICIT
!
! LEXLINE line number of statement being processed
!
! IMPLICIT OUTPUTS:
!
! CHLEN Character length passed to <>
!
! GSTSSCAN "Scan for character string" passed to LEXICA
!
! IMPNONE Flag for IMPLICIT NONE was seen
!
! LOOK4CHAR Pointer to character string to look for
!
! SP Pointer into STK
!
! STK Results of the parsed BNF stack
!
! TYPIMP Flag indicating that IMPLICIT statements have
! been scanned (other than IMPLICIT NONE).
!
! ROUTINE VALUE:
!
! .LT. 0 if parsing a data type or NONE fails.
!
! .EQ. 0 if parsing NONE succeeds.
!
! .GT. 0 if a data type is found (the data type itself is returned).
!
! SIDE EFFECTS:
!
! Parsing is done on the input source file.
!
!--
![2473] Rewritten
BEGIN
REGISTER R1; ! VALTYPE of the data type read in
! This is a table of the valid data types/"NONE" characters to
! follow IMPLICIT. This table mus be kept in order with TYPENUM.
! For the global externals, start at the second character, the
! first character is " ".
BIND TYPECHAR = PLIT(
INTGPLIT<29,7>,
REALPLIT<29,7>,
DOUBPLIT<29,7>,
COMPLIT<29,7>,
LOGIPLIT<29,7>,
CHARPLIT<29,7>,
UPLIT(ASCIZ 'NONE')<36,7>);
BIND TYPNONE = -1; ! Invalid VALTYPE, for IMPLICIT NONE
! This is the table of VALTYPEs corresponding to the characters
! parsed in TYPECHAR. It must be kept in order with TYPECHAR.
BIND TYPENUM = PLIT(
INTEGER,
REAL,
DOUBLPREC,
COMPLEX,
LOGICAL,
CHARACTER,
TYPNONE);
LABEL LOOP;
LOCAL FNDONE; ! "Found one!" (a dataype or a NONE)
MACRO ERR303 = (FATLEX(UPLIT(ASCIZ'Other IMPLICIT specifications are illegal with'),
E303<0,0>))$;
! Try each valid string of characters following IMPLICIT, one by
! one.
FNDONE = FALSE; ! Haven't found any yet!
INCR CNT FROM 0 TO .(TYPECHAR - 1) -1
DO
LOOP: BEGIN ! Scan for each datatype
LOOK4CHAR = .TYPECHAR[.CNT]; ! Characters to look for
IF LEXICAL(.GSTSSCAN) NEQ 0 ! Look for them
THEN
BEGIN ! Found a data type
FNDONE = TRUE; ! We FOUND it!
R1 = .TYPENUM[.CNT]; ! VALTYPE of this type
LEAVE LOOP; ! Don't look any further
END; ! Found a data type
END; ! Scan for each datatype
! Didn't find a data type? We tried all the valid possiblities, so
! if we didn't find one complain!
IF NOT .FNDONE
THEN RETURN FATLEX(E17<0,0>); ! Invalid data type
IF .R1 EQL TYPNONE
THEN
BEGIN ! IMPLICIT NONE
STK[SP = .SP+1] = 'NONE'; ! Tell IMPCHK we have one
! If we have already seen an IMPLICIT NONE, then tell the
! user they're verbose. This is the catch the "IMPLICIT
! NONE, NONE" case which the BNF allows
%2506% IF .IMPNONE
%2506% THEN FATLEX(UPLIT(ASCIZ'Muliple'), E303<0,0>) ! Warning
%2506% ELSE IMPNONE = TRUE; ! IMPLICIT NONE
! IMPLICIT NONE is not ANSI standard, give a warning
IF FLAGANSI THEN FATLERR(ANSIPLIT, .LEXLINE, E303<0,0>);
! Other IMPLICIT statements are not allowed with
! IMPLICIT NONE.
IF .TYPIMP THEN ERR303;
RETURN 0; ! "Found something valid after IMPLICIT"
END; ! IMPLICIT NONE
! Not IMPLICIT NONE.
! Has IMPLICIT NONE been seen already? No other IMPLICIT
! statements are allowed wit it.
IF .IMPNONE THEN ERR303;
TYPIMP = TRUE; ! IMPLICIT used for typeing variables
IF .R1 EQL CHARACTER
THEN
BEGIN ! Type is character
%1213% CHDLEN = 1; ! Default character count is 1
%1232% ! Set flag for character declaration seen used in MRP3R
%1232% ! and MRP3G to test if we have to scan the symbol table
%1232% ! to generate high seg character descriptors.
%1232% CHDECL = -1;
END; ! Type is character
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 IMPCHK= ![2473] New
!++
! FUNCTIONAL DESCRIPTION:
!
! Action routine to check for IMPLICIT NONE. If TYPEID (another
! action routine) puts 'NONE' on STK, then we've seen it. This is
! to decide if the part of the BNF, "(" <implicitspec> ")" is
! optional or not. It's not allowed with NONE, and is required without NONE.
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! SP Current position in STK.
!
! STK Parse stack for BNF.
!
! IMPLICIT OUTPUTS:
!
! SP Current position in STK.
!
! ROUTINE VALUE:
!
! -1 If IMPLICIT NONE was parsed by TYPEID (routine "fails")
!
! 0 Otherwise (routine "succeeds")
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN
! Have we seen IMPLICIT NONE in TYPEID? If so, 'NONE' was
! pushed on the top of the stack.
IF .STK[.SP] EQL 'NONE'
THEN
BEGIN ! IMPLICIT NONE
SP = .SP - 1; ! Set pointer to not look at 'NONE'
RETURN -1; ! Don't parse optional (<implicitspec>)
END ! IMPLICIT NONE
ELSE RETURN 0; ! Must continue parsing (<implicitspec>)
END; ! of IMPCHK
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 10-word block. The block
! contains pointers to the UNIT, FMT, variable, REC, END, ERR, IOSTAT
! specifiers, in that order, plus 3 words for RMS key specifiers.
BEGIN
REGISTER QFMT,LSP;
%1777% LOCAL SCANERR;
%2261% GLOBAL IOSPEC;
! 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
%2261% IOSPEC=TRUE; ! So PRINT can be flagged
%1777% SCANERR = 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 ')'"
%1777% IF .SCANERR LSS 0 ! KEYSCAN error
%1777% THEN RETURN .SCANERR;
END ! keyword list
ELSE
BEGIN ! plain format specifier
%2261% IOSPEC=FALSE; ! So WRITE can be flagged
%2537% QFMT = FMTSCAN(TRUE); ! 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
%4501% SP = .SP + 10; ! 10 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
%4501% STK[.LSP+8] = 0; ! keyid
%4501% STK[.LSP+9] = 0; ! keyrel
%4501% STK[.LSP+10] = 0; ! key
COPYLIST(.LSP); ! copy into 10-word block, leave pointer
! on top of STK
END;
%1777% RETURN 0; ! no error
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 10-word block. The block
! contains pointers to the UNIT, FMT, variable, REC, END, ERR, IOSTAT
! specifiers, in that order, plus 3 words for RMS key specifiers.
BEGIN
REGISTER QUNIT,LSP;
%1777% LOCAL SCANERR;
! 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
%1777% SCANERR = 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 ')'"
%1777% IF .SCANERR LSS 0 ! KEYSCAN error
%1777% THEN RETURN .SCANERR;
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
%4501% SP = .SP + 10; ! 10 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
%4501% STK[.LSP+8] = 0; ! keyid
%4501% STK[.LSP+9] = 0; ! keyrel
%4501% STK[.LSP+10] = 0; ! key
COPYLIST(.LSP); ! copy into 10-word block, leave pointer
! on top of STK
END;
%1777% RETURN 0; ! no error
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
![4501] KEY=k k = integer expression or char expression
![4501] KEYEQ=k k = integer expression or char expression
![4501] KEYGE=k k = integer expression or char expression
![4501] KEYGT=k k = integer expression or char expression
![4501] KEYID=r r = integer expression
!
! 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
%4501% BIND
%4501% CIEXP = UPLIT ASCIZ 'a character or integer expression',
%4501% IEXP = UPLIT ASCIZ 'an integer expression';
%2370% LOCAL K, ! pointer to keyword in asciz
QUNIT,QFMT,QREC, ! keyword values
QERR,QEND,QIOSTAT,QVAR,
LSP; ! local SP
%4501% LOCAL BASE QKEYREL: QIOKEY: QKEYID;! more keyword values
%4501% LOCAL MULTIFLG; ! we have seen multiple key relation specifiers
%1765% ! Return a fatal error if parsing ENCODE/DECODE
%1765% ! and no variable has yet been parsed
%1765% MACRO CHKENCDEC =
%1765% BEGIN
%1765% IF .MAXPOS EQL 3
%1765% THEN IF .QVAR EQL 0
%1765% THEN RETURN FATLEX(.LEXNAM[IDENTIFIER],PLIT 'keyword',E0<0,0>);
%1765% END$;
QUNIT = QFMT = QREC = QERR = QEND = QIOSTAT = QVAR = 0;
%4501% QKEYID = QKEYREL = QIOKEY = 0;
%4501% MULTIFLG = FALSE; ! we have not seen multiple key relation specifiers
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
%2253% IF FLAGANSI !Compatibility flagger
%2253% THEN WARNLEX(E218<0,0>);
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;
%2537% QFMT = FMTSCAN(FALSE); ! 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
%2424% IF .KEYBUFFER EQL 'UNIT'
THEN
BEGIN ! UNIT=
%2436% IF .QUNIT NEQ 0 THEN FATLEX(KEYBUFFER,E182<0,0>);
! "UNIT= may only be specified once"
QUNIT = UNITSCAN();
IF .QUNIT LSS 0 THEN RETURN .QUNIT;
END ! UNIT=
%2424% ELSE IF .KEYBUFFER EQL 'FMT'
THEN
BEGIN ! FMT=
%2436% IF .QFMT NEQ 0 THEN FATLEX(KEYBUFFER,E182<0,0>);
! "FMT= may only be specified once"
%2537% QFMT = FMTSCAN(TRUE);
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=
%2424% ELSE IF .KEYBUFFER EQL 'NML'
%2341% THEN
%2341% BEGIN ! NML=
%2436% IF .QFMT NEQ 0 THEN FATLEX(KEYBUFFER,E182<0,0>);
%2341% ! "FMT= may only be specified once"
%2341% QFMT = NMLSCAN();
%2341% IF .QFMT LSS 0 THEN RETURN .QFMT;
%2341% IF .MAXPOS EQL 3 ! If in ENCODE/DECODE,
%2341% ! don't allow NML to be
%2341% ! specified this way
%2341% THEN RETURN FATLEX(E211<0,0>);
%2341% END ! NML=
%2424% ELSE IF .KEYBUFFER EQL 'REC'
THEN
BEGIN ! REC=
%2436% IF .QREC NEQ 0 THEN FATLEX(KEYBUFFER,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=
%2424% ELSE IF .KEYBUFFER EQL 'END'
THEN
BEGIN ! END=
%2436% IF .QEND NEQ 0 THEN FATLEX(KEYBUFFER,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=
%2424% ELSE IF .KEYBUFFER EQL 'ERR'
THEN
BEGIN ! ERR=
%2436% IF .QERR NEQ 0 THEN FATLEX(KEYBUFFER,E182<0,0>);
! "ERR= may only be specified once"
%1765% CHKENCDEC; ! Check for ENC/DEC misordering
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=
%2424% ELSE IF (.KEYBUFFER EQL 'IOSTA') AND
%2424% (.(KEYBUFFER+1) EQL 'T')
THEN
BEGIN ! IOSTAT=
%2436% IF .QIOSTAT NEQ 0 THEN FATLEX(KEYBUFFER,E182<0,0>);
! "IOSTAT= may only be specified once"
%1765% CHKENCDEC; ! Check ENC/DEC
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=
%4501% ELSE IF .KEYBUFFER EQL 'KEY'
%4501% THEN
%4501% BEGIN ! KEY=
%4501% ! we have already seen a key relational specifier
%4501% IF .QIOKEY NEQ 0 THEN MULTIFLG = TRUE;
%4501%
%4501% QKEYREL = KEYREL0;
%4501%
%4501% IF EXPRESS() LSS 0 THEN RETURN .VREG;
%4501% QIOKEY = .STK[.SP];
%4501% SP = .SP - 1;
%4501% IF (.QIOKEY[VALTYPE] NEQ INTEGER) AND
%4501% (.QIOKEY[VALTYPE] NEQ CHARACTER)
%4501% THEN FATLEX (CIEXP,UPLIT ASCIZ 'KEY=',E312<0,0>);
%4501% END
%4501% ELSE IF .KEYBUFFER EQL 'KEYEQ'
%4501% THEN
%4501% BEGIN ! KEYEQ=
%4501% ! we have already seen a key relational specifier
%4501% IF .QIOKEY NEQ 0 THEN MULTIFLG = TRUE;
%4501%
%4501% QKEYREL = KEYRELEQ;
%4501%
%4501% IF EXPRESS() LSS 0 THEN RETURN .VREG;
%4501% QIOKEY = .STK[.SP];
%4501% SP = .SP - 1;
%4501% IF (.QIOKEY[VALTYPE] NEQ INTEGER) AND
%4501% (.QIOKEY[VALTYPE] NEQ CHARACTER)
%4501% THEN FATLEX (CIEXP,UPLIT ASCIZ 'KEYEQ=',E312<0,0>);
%4501% END
%4501% ELSE IF .KEYBUFFER EQL 'KEYGE'
%4501% THEN
%4501% BEGIN ! KEYGE=
%4501% ! we have already seen a key relational specifier
%4501% IF .QIOKEY NEQ 0 THEN MULTIFLG = TRUE;
%4501%
%4501% QKEYREL = KEYRELGE;
%4501% IF EXPRESS() LSS 0 THEN RETURN .VREG;
%4501% QIOKEY = .STK[.SP];
%4501% SP = .SP - 1;
%4501% IF (.QIOKEY[VALTYPE] NEQ INTEGER) AND
%4501% (.QIOKEY[VALTYPE] NEQ CHARACTER)
%4501% THEN FATLEX (CIEXP,UPLIT ASCIZ 'KEYGE=',E312<0,0>);
%4501% END
%4501% ELSE IF .KEYBUFFER EQL 'KEYGT'
%4501% THEN
%4501% BEGIN ! KEYGT=
%4501% ! we have already seen a key relational specifier
%4501% IF .QIOKEY NEQ 0 THEN MULTIFLG = TRUE;
%4501%
%4501% QKEYREL = KEYRELGT;
%4501%
%4501% IF EXPRESS() LSS 0 THEN RETURN .VREG;
%4501% QIOKEY = .STK[.SP];
%4501% SP = .SP - 1;
%4501% IF (.QIOKEY[VALTYPE] NEQ INTEGER) AND
%4501% (.QIOKEY[VALTYPE] NEQ CHARACTER)
%4501% THEN FATLEX (CIEXP,UPLIT ASCIZ 'KEYGT=',E312<0,0>);
%4501% END
%4501% ELSE IF .KEYBUFFER EQL 'KEYID'
%4501% THEN
%4501% BEGIN ! KEYID=
%4501% IF .QKEYID NEQ 0 THEN FATLEX(KEYBUFFER,E182<0,0>);
%4501% ! "KEYID= may only be specified once"
%4501%
%4501% IF EXPRESS() LSS 0 THEN RETURN .VREG;
%4501% QKEYID = .STK[.SP];
%4501% SP = .SP - 1;
%4501% IF (.QKEYID[VALTYPE] NEQ INTEGER)
%4501% THEN FATLEX (IEXP,UPLIT ASCIZ 'KEYID=',E312<0,0>);
%4501% END
%2436% ELSE
%2436% BEGIN ! "unrecognized keyword K"
%4534% OWN SAVEKEY[MAXSYMWORDS]; ! Where to save
%4534%
%4534% ! Bad keyword. Must save it away, since
%4534% ! someone may overwrite KEYBUFFER before
%4534% ! the error message is output.
%4534%
%4534% INCR CNT FROM 0 TO MAXSYMWORDS
%4534% DO SAVEKEY[.CNT] = .KEYBUFFER[.CNT];
%4534% RETURN FATLEX(SAVEKEY<0,0>,E183<0,0>);
%2436% END; ! "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 ")"');
%1765% IF .MAXPOS EQL 3 ! ENC/DEC without
%1765% THEN IF .QVAR EQL 0 ! a variable
%1765% THEN RETURN ERR0L (UPLIT ASCIZ '","'); ! is an error
%4501% ! if we have seen multiple key relational specifiers, say so
%4501% IF .MULTIFLG EQL TRUE THEN WARNLEX(E306<0,0>);
! Put args into a block of information on the semantic stack
LSP = .SP;
%4501% SP = .SP + 10;
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;
%4501% STK[.LSP+8] = .QKEYID;
%4501% STK[.LSP+9] = .QKEYREL;
%4501% STK[.LSP+10] = .QIOKEY;
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(FMTGIVEN)= ! [2537] argument added
! Parses format specifier. Legal syntaxes are *, label, array name,
! namelist name, expression. Semantic checks will impose further
! restrictions.
! FMTGIVEN TRUE or FALSE depending on whether "FMT=" was really
! seen in the user's program.
BEGIN
REGISTER BASE F;
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
%2341% IF NMLIOREF(.F) LSS 0 THEN RETURN .VREG;
%2341%
%2455% ! Should use NML if flagging for VMS
%2537% IF .FMTGIVEN EQL TRUE THEN
%2455% IF FLAGVMS THEN WARNLEX(E240<0,0>)
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
%2253% ! If numeric array, flag the extension to ANSI
%2253% IF FLAGANSI
%2253% THEN
%2253% IF .F[OPRCLS] EQL DATAOPR AND
%2253% .F[VALTYPE] NEQ CHARACTER
%2253% THEN
%2253% IF .F[OPERSP] EQL ARRAYNAME OR
%2253% .F[OPERSP] EQL FORMLARRAY
%2253% THEN WARNLEX(E237<0,0>)
END ! not label, not namelist
END
END;
RETURN .F;
END; ! FMTSCAN
ROUTINE NMLSCAN=
!++
! FUNCTIONAL DESCRIPTION: [Added in edit 2341]
!
! Parses NML specifier.
!
! The only legal syntax is namelist name.
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! LEXL contains the next lexeme.
!
! ROUTINE VALUE:
!
! If the next lexeme is a namelist name, that lexeme is returned.
! Otherwise, a negative number is returned.
!
! SIDE EFFECTS:
!
! Fatal error message if lexeme is not a NAMELIST name.
!
!--
BEGIN
MAP BASE LEXL;
LEXL=LEXEMEGEN(); ! Get the lexeme for the keyword value
IF .LEXL<LEFT> EQL IDENTIFIER AND .LEXL[IDATTRIBUTE(NAMNAM)]
THEN
IF NMLIOREF(.LEXL) LSS 0 ! Set references to NAMELIST items
THEN RETURN .VREG ! Trouble
ELSE RETURN .LEXL ! All is well
ELSE RETURN FATLEX(E298<0,0>) ! Must be namelist name
END; ! of NMLSCAN
ROUTINE NMLIOREF(LEX)=
!++
! FUNCTIONAL DESCRIPTION: [Added in edit 2341]
!
! Handles the namelist keyword value for FMT= and NML=.
!
! The reference to the namelist name is noted via NAMREF.
! The references to the namelist elements are noted via
! NAMREF (for output) or via NAMSET (for input).
!
! FORMAL PARAMETERS:
!
! LEX is the lexeme for the namelist name.
!
! IMPLICIT INPUTS:
!
! TYPE contains READD if this is for an input statement,
! otherwise the statement is assumed to be output.
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! If NAMREF likes the namelist name, return a 0.
! Otherwise, return a negative error number.
!
! SIDE EFFECTS:
!
! Fatal error message if .LEX cannot be a NAMELIST name.
! Flagger warning if ANSI flagging is being done.
!
!--
BEGIN
REGISTER BASE
ID: ! Index into Symbol Table
NAMCOM; ! Link to the entry in Namelist table
MAP BASE LEX; ! The lexeme
%2455% LOCAL SAVEFLAG; ! To save setting of CFLGVMS
IF NAMREF(NMLSTREF,.LEX) LSS 0 THEN RETURN .VREG;
! Call NAMREF or NAMSET for the variables in the namelist
%2455% SAVEFLAG=.F2<CFLGVMS>; ! Remember the VMS setting
%2455% F2<CFLGVMS>=0; ! Turn off flagging temporarily
NAMCOM = .LEX[IDCOLINK];
INCR NMLST FROM .NAMCOM[NAMLIST]
TO .NAMCOM[NAMLIST]+.NAMCOM[NAMCNT] - 1
DO
BEGIN
ID = @.NMLST;
IF .TYPE EQL READD
THEN NAMSET (.ID[OPRSP1],.ID)
ELSE NAMREF (.ID[OPRSP1],.ID)
END;
%2455% F2<CFLGVMS>=.SAVEFLAG; ! Restore any VMS flagging
IF FLAGANSI THEN WARNLEX(E262<0,0>); !NAMELIST is ANSI extension
RETURN 0
END; ! of NMLIOREF
GLOBAL ROUTINE EXPRLIST=
BEGIN
!++
! Process the argument list of a CALL statement.
!--
LOCAL LSP;
REGISTER BASE T1,VAL;
T1 = .STK[.SP - 1]; ! T1 is loc(identifier)
%2507% T1[IDSUBROUTINE] = 1; ! Mark as a subroutine name
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
%2253% BEGIN ! Return label
%2253% IF FLAGEITHER AND (T1 = .LEXL<LEFT>) NEQ ASTERISK
%2253% THEN
%2253% BEGIN ! Compatibility checks
%2253% IF .T1 EQL DOLLAR
%2253% THEN
%2253% CFLEXB(E271<0,0>) ! Flag the $
%2253% ELSE
%2253% IF FLAGANSI
%2253% THEN WARNLEX(E270<0,0>) ! Flag the &
%2253% END; ! Compatibility checks
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();
%2253% END; ! Return label
IF .LEXL<LEFT> NEQ COMMA
THEN EXITLOOP
%1217% ELSE LEXL = LEXEMEGEN();
! Make sure that a super long list of arguments will not
! overflow stk
%2507% IF .SP GTR STKSIZ - 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;
%1732% LOCAL
%1732% BASE EXPLEN, ! Length of constant expression in words
%1732% BASE IDLEN, ! Length of ID in words
%1732% BASE NEWLIT, ! Make a new constant
%1732% BASE SAVPRVLIT; ! Saved value of PRVLIT
! 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;
%1732% ! Check if the length of the constant is long enough. If the
%1732% ! word length of the identifier is longer than the constant,
%1732% ! then me must make a new constant that is long enough (padded
%1732% ! with blanks).
%1732%
%1732% IF .ID[VALTYPE] EQL CHARACTER ! symbol character?
%2055% THEN IF .EXPR[VALTYPE] EQL CHARACTER ! constant character?
%1732% THEN
%1732% BEGIN ! Character parameter
%1732%
%1732% IDLEN = CHWORDLEN( .ID[IDCHLEN] ); ! Len of identifier
%1732% EXPLEN = CHWORDLEN( .EXPR[LITLEN] ); ! Len of constant
%1732%
%1732% IF .IDLEN GTR .EXPLEN
%1732% THEN
%1732% BEGIN ! Make a new longer character constant
%1732%
%1732% ! Save the node that points to the lit to
%1732% ! replace. After the MAKLIT call, PRVLIT is no
%1732% ! longer that node.
%1732% SAVPRVLIT = .PRVLIT;
%1732%
%1732% NEWLIT = MAKLIT(.ID[IDCHLEN]);
%1732%
%1732% ! Copy over each word of the old to the new
%1732% ! consant.
%1732% INCR CNT FROM 1 TO .EXPLEN
%1732% DO NEWLIT[LITWD(.CNT)] = .EXPR[LITWD(.CNT)];
%1732%
%1732% ! Pad with blanks from the end of the old
%1732% ! constant to the end of the new one.
%1732% INCR CNT FROM ( .EXPLEN + 1 ) TO .IDLEN
%1732% DO NEWLIT[LITWD(.CNT)] = ' ';
%1732%
%1732% ! Delete the old literal, we don't need it
%1732% SAVSPACE(.EXPLEN-1 + LTLSIZ - 1, .EXPR<RIGHT>);
%1732%
%1732% ! Remove it from the linked list too.
%1732% IF .LITPOINTER<LEFT> EQL .EXPR<RIGHT> ! 1st literal?
%1732% THEN LITPOINTER<LEFT> = .NEWLIT ! Yes
%1732% ELSE SAVPRVLIT[LITLINK] = .NEWLIT;
%1732%
%1732% ! Assign a new constant expression of the
%1732% ! correct size. Assign only to the right hand
%1732% ! side, since the left must contain the
%1732% ! lexeme.
%1732% EXPR<RIGHT> = .NEWLIT;
%1732%
%1732% END; ! Make a new longer character constant
%1732%
%1732% END; ! Character parameter
ID[IDPARAVAL] = .EXPR; ! Parameter value
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
%2253% ELSE
%2253% BEGIN
%2253% IF FLAGANSI THEN WARNLEX(E264<0,0>); !Compatibility flagger
%2253% PARMCNV = 0; LSAVE = -1
%2253% END;
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
GLOBAL ROUTINE EVAL (EXPR) = ! [1527] New [1740] Make global
! Evaluates a constant expression, trying to simplify it into a single
! constant.
! (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];
%4527% IF .ARG1[ID1ST6CHAR] 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.
%4527% ELSE IF .ARG1[ID1ST6CHAR] 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
! Converting numeric to character is illegal.
IF .TOTYPE EQL CHARACTER
%2461% THEN RETURN FATLEX(E163<0,0>);
! 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
GLOBAL ROUTINE OCTHEX= ![2461] New
!++
! FUNCTIONAL DESCRIPTION:
!
! Action routine to process octal/hexadecimal constants in DATA
! statements. Parse to see if one is present, and if so, put the
! necessary information pointing to an octal constant on STK for
! later processing.
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! GSTCSCAN Want LEXICA to scan a character
!
! GSTSSCAN Want LEXICA to scan a string
!
! SP Top location in STK
!
! IMPLICIT OUTPUTS:
!
! LOOK4CHAR Trashed, argument to LEXICA
!
! SP Top location in STK
!
! STK Syntax parsing stack
!
! ROUTINE VALUE:
!
! Returns:
!
! 0 If we found a valid octal or hexidecimal constant
!
! -1 If we failed
!
! SIDE EFFECTS:
!
! The input file will be parsed and characters may be "eaten".
!
!--
BEGIN
REGISTER
DIG, ! Octal/hex digit
LOWWORD, ! Low order word of constant
HIWORD; ! Hi order word of constant
LOCAL
%2510% ISDOUBLE, ! TRUE = Double precision constant
%2510% ! FALSE = Single precision constant
ISNEG, ! TRUE = negate the constant
! FALSE = keep constant as read in
ISOCTAL, ! TRUE = octal constant
! FALSE = hex constant
NUMDIGITS; ! Number of digits read so far
! Look for "O'<octal constant>'" or "Z'<hex constant>'"
! Look for >O'< (Note we're reading in TWO CHARACTERS!)
LOOK4CHAR = UPLIT(ASCIZ 'O''')<36,7>;
IF LEXICAL(.GSTSSCAN) NEQ 0
%2510% THEN ISOCTAL = TRUE ! Parsing octal constant
ELSE
BEGIN ! Not O'
! Look for >Z'< (Note we're reading in TWO CHARACTERS!)
LOOK4CHAR = UPLIT(ASCIZ 'Z''')<36,7>;
IF LEXICAL(.GSTSSCAN) EQL 0
THEN RETURN -1 ! Found no octal/hexadecimal constant
ELSE ISOCTAL = FALSE; ! Parsing hex constant, Z'
END; ! Not O'
! Found "O'" or "Z'". Look for the digits or +/- following.
! Look for +/-. Plus is simply read over, minus must be remembered
! so that the constant can be negated after we've read it in. This
! is not in the Mil Standard, merely an extension, since "-123 is
! allowed.
%2510% LOOK4CHAR = "-"; ! Minus sign
%2510% IF LEXICAL(.GSTCSCAN) NEQ 0
%2510% THEN ISNEG = TRUE ! "-" found, must negate later
%2510% ELSE
BEGIN ! - not found
%2510% ISNEG = FALSE; ! Positive number
%2510% LOOK4CHAR = "+"; ! Look for "+"
%2510% LEXICAL(.GSTCSCAN); ! Skip over + if present
END; ! - not found
! Read in all the digits and process them to make a constant.
! We loop as long as we see digits. When we see no more we
! expect a "'" to close the constant, otherwise we have an
! invalid character in the constant.
%2510% LOWWORD = HIWORD = NUMDIGITS = DIG = 0; ! Initialize
WHILE .DIG NEQ -1
DO
BEGIN ! Process all the digits
DIG = GETDIGIT(.ISOCTAL); ! Next digit
! -1 non-digit/letter found
! -2 bad digit/letter found
%2510% IF .DIG EQL -2 THEN RETURN -1; ! Bad digit, return now.
! (error message already given)
%2510% IF .DIG GEQ 0
%2510% THEN
%2510% BEGIN ! Valid digit
NUMDIGITS = .NUMDIGITS + 1; ! One more digit
! Got a digit. Shift any previous digits over. If
! the low word is full, then we must carry from the
! low into the high word. Too many digits, and we
! truncate off the left and keep the rightmost.
IF .ISOCTAL
THEN
BEGIN ! Octal constant
! 3 bits per digit, slide 'em on over!
IF .NUMDIGITS GTR 12 ! Shift into 2nd word?
THEN HIWORD = (.HIWORD ^ 3) + .LOWWORD<33,3>;
LOWWORD = (.LOWWORD ^ 3) + .DIG; ! first word
END !Octal
ELSE
BEGIN ! Hexadecimal
! 4 bits per digit, slide 'em on over!
IF (.NUMDIGITS GTR 9) ! Shift into 2nd word?
THEN HIWORD = (.HIWORD ^ 4) + .LOWWORD<32,4>;
LOWWORD = (.LOWWORD ^ 4) + .DIG; ! 1st word
END; ! Hexadecimal
%2510% END; ! Valid digit
END; ! Process all the digits
%2510% ! Decide if we have single or double precision
%2510% IF (NOT .ISOCTAL AND .NUMDIGITS GTR 9) ! Hex
%2510% OR (.NUMDIGITS GTR 12) ! Oct
%2510% THEN ISDOUBLE = TRUE ! Double precision
%2510% ELSE ISDOUBLE = FALSE; ! Single precision
! Check if we read too many digits and truncated.
IF (.NUMDIGITS GTR 24) ! Too many octal or hex
OR ((NOT .ISOCTAL) AND (.NUMDIGITS GTR 18)) ! Too many hex
THEN FATLEX(E64); ! "Constant underflow or overflow"
! Make sure that the closing quote for the constant is present.
! If not, then we haven't found a proper constant!
%2510% IF .LSAVE EQL 0 THEN LEXL = LEXOPGEN(); ! Get lexeme
%2510%
%2510% IF .LEXL<LEFT> NEQ TICLEX ! found ... when expecting "'" or ... digit
%2510% THEN RETURN ERR0L(IF .ISOCTAL ! Different message depending on type
%2510% THEN UPLIT ASCIZ'"''" or octal digit'
%2510% ELSE UPLIT ASCIZ'"''" or hexidecimal digit');
%2510% ! No digits given? (O'' or Z'') This is an error for a regular
%2510% ! octal constant. Give a message, default is 0.
%2510%
%2510% IF .NUMDIGITS EQL 0
%2510% THEN FATLEX(IF .ISOCTAL ! Different message depending on type
%2510% THEN UPLIT ASCIZ'octal digit'
%2510% ELSE UPLIT ASCIZ'hexidecimal digit',
%2510% .LEXNAM[TICLEX], E0<0,0>);
! FOUND VALID OCTAL OR HEX CONSTANT!
! If neccessary, negate the constant.
IF .ISNEG
THEN
BEGIN ! Read in minus sign
! We use the constant combine routine to handle overflow
! from negation and bit carry from low to high word.
C1H = .HIWORD; ! Constant to negate
C1L = .LOWWORD;
COPRIX = KDNEGB; ! "Do a double word negation"
CNSTCM(); ! Do the negation
HIWORD = .C2H; ! Restore the values
LOWWORD = .C2L;
%2510% ! Negative double precisions must have the sign lit in
%2510% ! their low order words. For some reason, DMOVN does not
%2510% ! do this. Later the compiler in its infinite wisdom may
%2510% ! use the low order word, so the low must appear negative
%2510% ! if the high is negative!
%2510%
%2510% IF (.HIWORD LSS 0) AND (.LOWWORD NEQ 0)
%2510% THEN LOWWORD = #400000000000 OR .LOWWORD; ! Add bit
END; ! Read in minus sign
! Warn users that neither the 77-standard nor VMS Fortran
! supports this type of constant.
IF FLAGEITHER THEN CFLEXB(E302);
! Put the constant that we've got onto STK. We're not making
! this look like the BNF parsed it at all, we're just putting on
! the info needed. The below is found by the DATA statement
! processing routine.
! 2,, ptr to constant
! 1 "I'm an octal/hex constant!"
! (The grammar puts this here)
! Pointers to other constant table entries are 2,,ptr (2 is the
! constant lexeme). This also puts something in the left half
! so it looks different from what the other BNF-parsed entries
! look like (they don't have anything in their left half of the
! first word; <option>/<cnt-1>,,<ptr>).
STK[SP = .SP+1]<LEFT> = CONSTLEX; ! Constant lexeme
%2510% STK[.SP]<RIGHT> = MAKECNST(IF .ISDOUBLE
THEN DOUBLOCT ! Dble prec
ELSE OCTAL, ! Single prec
.HIWORD, .LOWWORD); ! Constant values
! When we return 0, a "1" is put on STK[SP = .SP+1] to indicate
! to DATASTA that an octal or hex constant was found.
RETURN 0; ! Found either an octal or hexadecimal constant
END; ! of OCTHEX
ROUTINE GETDIGIT(ISOCTAL)= ![2461] New
!++
! FUNCTIONAL DESCRIPTION:
!
! Gets an octal or hexadecimal digit from source file.
!
! Appropriate error messages are given if the digit or letter is
! out of bounds for the constant.
!
! FORMAL PARAMETERS:
!
! ISOCTAL If TRUE, then we're looking for an octal constant,
! if FALSE, then a hexadecimal one.
!
! IMPLICIT INPUTS:
!
! GSTCSCAN Look for a character via LEXICA
!
! IMPLICIT OUTPUTS:
!
! LOOK4CHAR Trashed, argument to LEXICA
!
! ROUTINE VALUE:
!
! Returns:
!
! 0-15 Value of the ASCII octal/hex digit that was
! found.
!
! -1 Failed to find a digit (or letter if hex)
! (Invalid character)
! -2 Found an invalid digit (or letter if hex)
!
! SIDE EFFECTS:
!
! Parses the source file to find digits.
!
!--
BEGIN
REGISTER DIG; ! The digit/character read in
! Read in a digit or letter. Try for digit first. If this
! fails, and we have a hex constant, then try for a letter.
LOOK4CHAR = "?D"; ! Any digit
IF (DIG = LEXICAL(.GSTCSCAN)) EQL 0
THEN
BEGIN ! Not a digit
IF .ISOCTAL
%2510% THEN RETURN -1 ! Invalid character for octal constant
%2510% ELSE
BEGIN ! Hexadecimal
LOOK4CHAR = "?L"; ! Any letter
! (A-F is valid)
IF (DIG = LEXICAL(.GSTCSCAN)) EQL 0
THEN RETURN -1; ! Didn't find a letter
END; ! Hexadecimal
END; ! Not a digit
! Found digit or letter. Check if its valid (in range), and if
! so convert it from ASCII to decimal.
IF .ISOCTAL
THEN
BEGIN ! Octal constant
! Only 0-7 are valid octal characters, letters are > digits.
%2510% IF (.DIG GTR "7")
THEN
%2510% BEGIN ! Invalid digit
FATLEX(UPLIT ASCIZ 'octal digit', .DIG, E0<0,0>);
%2510% RETURN -2;
%2510% END;
DIG = .DIG - "0"; ! Convert from ASCII to numeric
END ! Octal constant
ELSE
BEGIN ! Hex constant
! Check for range.
! Only 0-9 and A-F (0-15) are valid hex characters. 0-9 is
! all digits, there are no letters below A, so try for
! above F.
%2510% IF .DIG GTR "F"
THEN
%2510% BEGIN ! Invalid hex digit
FATLEX(UPLIT ASCIZ 'hexadecimal digit', .DIG,
E0<0,0>);
%2510% RETURN -2;
%2510% END;
! Convert from ASCII to numeric.
IF .DIG GTR "9"
THEN DIG = (.DIG - "A") + 10 ! Digit A-F
ELSE DIG = .DIG - "0"; ! Digit 0-9
END; ! Hex constant
RETURN .DIG; ! Return the digit found
END; ! of GETDIGIT
END
ELUDOM