Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-BB_1985_short
-
sta2.bli
There are 26 other files named sta2.bli in the archive. Click here to see a list.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
!AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!AUTHOR: F.J. INFANTE, D. B. TOLMAN/DCE/SJW/EGM/CKS/AHM/TFV/AlB/RVM/PLB/MEM
MODULE STA2(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND STA2V = #10^24 + 0^18 + #2507; ! Version Date: 20-Dec-84
%(
***** Begin Revision History *****
36 ----- ----- ADD THE INCLUDE STATEMENT SEMANTICS ROUTINE
37 ----- ----- ALLOW LITSTRINGS IN THE PARAMETER STATEMENT
38 ----- ----- FIX REAL*8 X*4 SO IT WORKS
ALLOW SIGNED CONSTANTS IN THE PARAMETER STATEMENT
39 ----- ----- THE "CLEVER" WAY OF DEALING WITH THE LOOKUP
SKIP RETURN WAS OPTIMIZED AWAY BY 5(122)
SO WE MUST NOT BE SO CLEVER THIS TIME
40 ----- ----- FIX UP INCLUDE A LITTLE
41 320 16787 CATCH COMMON STATEMENTS LIKE /X/A(5)B(5) AS ERRORS, (JNT)
42 402 18917 RESTORE FLAGS CORRECTLY AFTER INCLUDE FILE, (DCE)
43 467 VER5 REQUIRE FTTENX.REQ ,(SJW)
44 533 21796 FIX OUTPUT BUFFER PTR FOR INCLUDE FILE TO BE 0., (DCE)
45 540 22096 ICE CAUSED BY BAD COMMON DECLARATION, (DCE)
***** Begin Version 5B *****
46 722 28072 ADD /NOCREF TO INCLUDE FILE PROCESSING, (DCE)
47 755 13884 Allow lower case for INCLUDE/NOLIST/NOCREF under TENEX,
(EGM)
***** Begin version 6 *****
48 1000 EGM 27-Jun-80 10-29620
Flag error if no name is given on PROGRAM statement
***** Begin Version 7 *****
49 1213 TFV 6-May-81 ------
Modify ASTER to handle CHARACTER*(*), CHARACTER*n, and CHARACTER*(n).
The length for character data gets put on the stack. Fix TYPDECLARE
to handle CHARACTER decl's. Add CHARSTA the CHARACTER decl semantic
routine. Move ACTLDATYPE and CHDLEN to GLOBAL.BLI. Add a second
argument to FUNCGEN to distinguish 'datatype FUNCTION ...' from
'FUNCTION ...'. The first case puts CHLEN on the stack.
50 1214 CKS 1-Jun-81
Prohibit ENTRY statement in range of block IF as well as DO
51 1224 CKS 12-Jun-81
Use "LTLSIZ-1" instead of "2" to free up literal node
52 1232 TFV 24-Jun-81 ------
CHARSTA 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.
53 1256 CKS 8-Sep-81
Modify COMMSTA to read the modified output of SYNTAX for the modified
common statement. The difference is that COMMON // X is returned with
a concatenation lexeme instead of two slashes.
54 1267 AHM 6-Oct-81 ------
Define a stub routine SAVESTA for the SAVE statement so we don't
get undefined symbols when linking.
55 1434 TFV 14-Dec-81 ------
Modify ENTRSTA to handle multi-entry function subprograms.
Character and numeric entry points cannot occur in the same
subprogram. All character entry points must be the same length;
they share the descriptor for the function result. All numeric entry
points are equivalenced using the EQUIVALENCE statement semantic
routine.
56 1466 CDM 1-Feb-82
Added warning for using SAVE statement. Not yet implemented.
1511 CDM 18-March-82
Added code for SAVE statement in SAVESTA.
Added routine LKSVCOMMON for linking common blocks together for
SAVE statement processing.
1527 CKS 9-Apr-82
Rewrite ASTER to allow expressions as length specifiers. Modify
PARASTA to allow expressions in parameter statements.
1531 CDM 4-May-82
Changes for code review of SAVE.
1566 CDM 24-Jun-82
Remove warning for SAVE processing with overlays.
1575 TFV 7-Jul-82
Modify TYPEDECLARE and ASTER to accept 'var * len (subs) * len'.
1646 TFV 18-Oct-82
Fix ASTER to give an error for character lengths less than or
equal to 0.
1656 CKS 25-Oct-82
Modify parameter statement semantic routine PARASTA to do nothing.
It's all handled in action routine PARMASSIGN.
1667 TFV 9-Nov-82
Fix ASTER to give a better found when expecting error for type
declarations.
1704 TFV 21-Dec-82
Fix type declarations to allow optional comma after the optional
*size specifier. The comma is only allowed if the *size is
specified.
***** Begin Version 10 *********
2250 AlB 22-Dec-83
Added Compatibility flagging for Type Declarations.
Added code to allow LOGICAL*2 with warning.
Routine:
ASTER
2252 AlB 27-Dec-83
Change edit 2250 to use ISN instead of LEXLINE for error line number.
Routine:
ASTER
2256 AlB 29-Dec-83
Change the INCLUDE statement so as to recognize /LIST and /CREF
switches as valid options. This is in order to make Fortran-20
more compatible with VAX-11 Fortran.
Routine:
INCLSTA
2261 AlB 5-Jan-84
Added compatibility check to INCLUDE statement, which is extension
to Fortran-77.
Routine:
INCLSTA
2270 AlB 10-Jan-84
Turn off compatibility flagging for VAX when equating ENTRY variable
with FUNCTION variable, so as to avoid redundant (and confusing) warning.
Routine:
ENTRSTA
2312 AlB 20-Feb-84
Fix the INCLUDE switches used by Fortran-10. This code was
originally entered with edit 2256, but was never tested in the
Tops-10 version.
2343 RVM 18-Apr-84
Have COMMSTA put the COMMON block variables in the proper PSECT
as it links up the COMMON block chain.
2412 TFV 2-Jul-84
Split LEXICA into two modules. The classifier is in the new
module LEXCLA. The lexeme scanner is in LEXICA. LEXCLA is
called to initialize each program unit, to classify each
statement, to classify the consequent statement of a logical IF,
and to do the standard end of program and missing end of program
actions.
2430 CDM 18-Jul-84
Have the compiler complain /FLAG for a variable mentioned more
than once in SAVE statements (SAVE A,B,A - A is mentioned
twice).
2447 PLB 10-Aug-84
Changes for nested INCLUDE. Also added code for .SFD's in
INCLUDE files, and outlawed non-octal digits in PPNs.
2455 MEM 30-Aug-84
Replace all occurrences of VAX with VMS.
2460 AlB 26-Sep-84
Force REAL*16 to be treated as REAL*8 instead of REAL*4.
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.
***** End V10 Development *****
***** End Revision History *****
)%
REQUIRE FTTENX.REQ;
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE META72.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;
!THE NUMBER IN COMMENT'S IS THE STATEMENTS LOCATION
!IN THE HASH TABLE .
FORWARD
% 16% SUBRSTA, !SUBROUTINE
% 19% INTESTA, !INTEGER
% 29% LOGISTA, !LOGICAL - P.30
% 51% DIMESTA, !DIMENSION
% 56% DOUBSTA, !DOUBLEPRECISION - P.31
% 64% ENTRSTA, !ENTRY
% 75% BLOCSTA, !BLOCKDATA - P.38
% 81% FUNCSTA, !FUNCTION
% 86% REALSTA, !REAL - P.29
% 93% COMMSTA, !COMMON
% 96% COMPSTA, !COMPLEX - P.32
%121% PROGSTA, !PROGRAM
PARASTA, !PARAMETER STATEMENT
% 13% SAVESTA, ![1267] SAVE STATEMENT
%1511% LKSVCOMMON; ! Links together Common blocks for SAVE processing
FORWARD
%2447% FIXLINENO, !BLAST LINENO[1] FOR INCLSTA/POSTINCL
%1511% LKSVCOMMON, ! Links together Common blocks for SAVE processing
POSTINCL; !CLEAN UP AFTER INCLUDE
EXTERNAL
%2430% CFLAGB, ! Error message output routine for /FLAG:ALL
%1232% CHDECL, ! Flag for character declaration seen
%1527% CNVCONST, ! Convert constant to desired type
CORMAN, ! Routine to get space from free memory
DOIFSTK,
E122, ! Error - Double <frob> name illegal
E124, ! Error - INCLUDEd files must reside on disk
E178, ! Error - character and numeric entry points cannot
! be mixed.
E179, ! Error - character entry points must have the same
! length.
%1531% E192, ! "Illegal in SAVE statement"
%2455% E244, ! "VMS incompatibility: /NOCREF"
%2455% E245, ! "VMS incompatibility: /CREF"
%2455% E246, ! "VMS incompatibility: Default for VMS is /NOLIST"
%2256% E291, ! "Conflicting INCLUDE switches"
%2261% E292, ! "Extension to Fortran-77: INCLUDE statement"
%2430% E301, ! "Variable xxx already declared in SAVE statement"
ENTRY, ! Parameter for TBLSEARCH
EQUISTA, ! Routine to do semantic processing for EQUIVALENCE
%1511% FATLERR, ! Error routine
FUNCGEN, ! Routine to processes the argument list for an
! ENTRY, FUNCTION or SUBROUTINE statement
%2447% ICLEVEL, ! Current INCLUDE level
%2412% LEXCLA, ! Classifier entry point
%2412% LEXICAL, ! Lexeme entry point
LINENO,
NAMDEF,
NAME, ! Parameter for TBLSEARCH
%1511% NUMSAVCOMMON, ! Number of commons to SAVE.
%1531% PTRSAVCOMMON, ! Linked list of commons to SAVE.
SAVSPACE, ! Routine to return space to free memory
%1511% SAVALL, ! SAVE with no arguments specified
%1511% SAVBLC, ! SAVE blank common
%2447% SAVFLG[INCLMAX],! Array of saved flags (during INCLUDE)
%1511% SAVLOC, ! SAVE local variables
%1511% SAVNED, ! SAVE rel block is needed
STK,
TBLSEARCH, ! Routine to lookup a symbol table entry
TYPE,
WARNLEX;
%2447% BIND WRDS2SAVE = 8; !NUMBER OF WORDS PER LEVEL
%2447% STRUCTURE SAVTBL[I,J]=[I*J](.SAVTBL+.I*J+.J);
%2447% OWN SAVTBL SVINCL[WRDS2SAVE,INCLMAX]; !TABLE OF SAVED VALUES
%2447% MACRO ICLCHAN = (ICL + .ICLEVEL)$; !INCLUDE CHANNEL
GLOBAL ROUTINE INCLSTA=
BEGIN % INCLUDE STATEMENT%
%2447% OWN PTHBLK[10]; !BLOCK FOR FULL INCLUDE PATH
OWN TMP;
%2256% GLOBAL ICLPTR;
%2447% GLOBAL SVFLG2[INCLMAX]; !AREA TO SAVE FLAG2 DURING INCLUDE
EXTERNAL EOPSVPOOL,POOL,EOPRESTORE;
EXTERNAL LEXICAL,GSTCSCAN,GSTSSCAN,LOOK4CHAR,LEXEMEGEN,GSTEOP;
BIND EOF = #200;
%2447% MACHOP CALLI = #047; !IMMEDIATE CALL (TOPS-10)
%2447% MACRO FILOP&(X) = CALLI(X,#155)$; !GENERAL FILE OPERATOR
%2447% BIND &FORED = #1; !FILOP. LOOKUP FUNCTION
%2447% MACHOP JSYS = #104; !JUMP TO SYSTEM (TOPS-20)
%2447% MACRO CLOSF = JSYS(0,#22)$; !CLOSE JFN IN AC1
MACRO DEFAULT = TMP<LEFT>$,
%2256% NOLST = TMP<0,2>$, ! 1 if /NOLIST, 2 if /LIST, 0 otherwise
%2256% NOCRF = TMP<2,2>$; ! 1 if /NOCREF, 2 if /CREF, 0 otherwise
MACRO ERRORR(X) = RETURN FATLEX(X<0,0>)$;
FORWARD
%2447% PATH,PPNUM,SCANFIL,FILSP,SWIT10,SWIT20(2);
ROUTINE FILSP =
BEGIN !FILSP
IF NOT FTTENEX
THEN
BEGIN !TOPS-10
REGISTER R;
%GET DEVICE OR FILE NAME%
WHILE 1 DO
BEGIN %LOOP%
IF (R_SCANFIL()) EQL 0 THEN RETURN 0;
LOOK4CHAR _ ":";
IF LEXICAL(.GSTCSCAN) EQL 0
THEN EXITLOOP
ELSE
BEGIN %DEVICE NAME%
%2447% IF @DEVICE(ICLCHAN+1) NEQ 0
THEN RETURN FATLEX( SIXBIT'DEVICE', E122<0,0>);
%2447% DEVICE(ICLCHAN+1) _ .R
END %DEVICE NAME%
END; %LOOP%
%STORE FILE NAME%
%2447% IF @FILENAME(ICLCHAN+1) NEQ 0
THEN RETURN FATLEX( SIXBIT'FILE', E122<0,0>);
%2447% FILENAME(ICLCHAN+1) _ .R;
LOOK4CHAR _ ".";
IF LEXICAL(.GSTCSCAN) EQL 0
THEN
BEGIN
%DEFAULT%
DEFAULT _ 1;
%2447% (FILENAME(ICLCHAN+1)+1) _ SIXBIT'FOR';
END
ELSE
BEGIN
DEFAULT _ 0;
%2447% (FILENAME(ICLCHAN+1)+1) _ SCANFIL()
END;
RETURN 1
END !TOPS-10
END; !FILSP
ROUTINE PATH = !PICK UP A FULL PATH
!++
! Created from old routine PPN [2447] /PLB
! FUNCTIONAL DESCRIPTION:
!
! Parse a full file path for INCLUDE
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! ICLCHAN
!
! IMPLICIT OUTPUTS:
!
! Sets up current INCLUDE level directory pointer.
! Sets up full path in PTHBLK[]
!
! ROUTINE VALUE:
!
! -1 Error parsing path
! 0 No path found
! 1 Success
!
! SIDE EFFECTS:
!
! Reads tokens.
!
!--
BEGIN !PATH
IF NOT FTTENEX
THEN
BEGIN !TOPS-10
REGISTER PTR; !POINTER (INDEX) INTO PATH BLOCK
LABEL SFDLOP;
LOOK4CHAR = "[";
IF LEXICAL(.GSTCSCAN) EQL 0
THEN
BEGIN !NO [ FOUND
DIRECTORY(ICLCHAN+1) = 0;
RETURN 0 !NONE
END; !NO [ FOUND
IF (PTHBLK[2]<LEFT> = PPNUM()) EQL 0 !GET PROJECT
THEN RETURN -1; !ERROR
LOOK4CHAR = ","; !LOOK FOR A COMMA
IF LEXICAL(.GSTCSCAN) EQL 0
THEN RETURN -1; !ERROR
IF (PTHBLK[2]<RIGHT> = PPNUM()) EQL 0 !GET PROGRAMMER
THEN RETURN -1; !ERROR
PTR = 3; !INDEX TO FIRST SFD WORD
PTHBLK[9] = 0; !ENSURE LAST WORD OF PATH IS ZERO
SFDLOP: DO
BEGIN !SFDLOP
PTHBLK[.PTR] = 0; !ZERO NEXT SFD WORD
LOOK4CHAR = ","; !LOOK FOR A COMMA
IF LEXICAL(.GSTCSCAN) EQL 0
THEN LEAVE SFDLOP; !NO COMMA, DONE!!
IF (PTHBLK[.PTR] = SCANFIL()) EQL 0 !PICK UP SIXBIT
THEN RETURN -1; !FATAL ERROR IF BLANK
PTR = .PTR + 1 !ADVANCE POINTER
END !SFDLOP
WHILE .PTR LSS 9;
LOOK4CHAR = "]"; !LOOK FOR CLOSING BRACKET
IF LEXICAL(.GSTCSCAN) EQL 0
THEN RETURN -1; !ERROR?!!
DIRECTORY(ICLCHAN+1) = PTHBLK<0,0>; !POINT DIRECTORY TO PATH BLOCK
RETURN 1 !GOT ONE
END !TOPS-10
END; !PATH
ROUTINE PPNUM = !PARSE OFF AN OCTAL NUMBER FOR PJ/PN
BEGIN !PPNUM
IF NOT FTTENEX
THEN
BEGIN !TOPS-10
REGISTER NUM,C;
NUM _ 0;
LOOK4CHAR _ "?D"; !LOOK FOR ANY DIGIT
UNTIL ( C _ LEXICAL(.GSTCSCAN) ) EQL 0
%2447% DO IF .C LEQ "7" !LEGAL "OIT"??
%2447% THEN NUM _ .NUM*8 + .C -"0" !YES, ADD IN
%2447% ELSE RETURN 0; !NO, NOT AN OIT!!, RETURN ERROR
RETURN .NUM
END !TOPS-10
END; !PPNUM
ROUTINE SCANFIL =
BEGIN !SCANFIL
IF NOT FTTENEX
THEN
BEGIN !TOPS-10
%GET FILE NAME%
REGISTER SIX,C;
DECR SHIFT FROM 30 TO 0 BY 6
DO
BEGIN
MACHOP ADDI=#271;
SIX _ .SIX^6;
LOOK4CHAR _ "?L";
IF ( C _ LEXICAL(.GSTCSCAN) ) EQL 0
THEN
BEGIN
LOOK4CHAR _ "?D";
IF ( C_ LEXICAL(.GSTCSCAN)) EQL 0
THEN RETURN SIX_.SIX^.SHIFT;
END;
ADDI(SIX,-" ",C)
END;
WHILE 1 DO
BEGIN %SKIP ANY MORE CHARACTERS%
LOOK4CHAR _ "?L";
IF LEXICAL(.GSTCSCAN) EQL 0
THEN
BEGIN
LOOK4CHAR _ "?D";
IF LEXICAL(.GSTCSCAN) EQL 0
THEN RETURN .SIX
END
END
END !TOPS-10
END; !SCANFIL
ROUTINE SWIT10 = ![2256]
%2256% ! Allow /LIST, /CREF, /NOLIST and /NOCREF
BEGIN IF NOT FTTENEX THEN BEGIN
%[722]% LOOK4CHAR_"/";
%[722]%
%[722]% IF LEXICAL(.GSTCSCAN) EQL 0 THEN RETURN 0;
%[722]% DO
%[722]% BEGIN
%[722]%
%2312% LOOK4CHAR=(UPLIT ASCIZ 'NOLIST')<36,7>;
%[722]% IF LEXICAL(.GSTSSCAN) NEQ 0
%2256% THEN ! Got /NOLIST
%2256% IF .NOLST EQL 2 ! Check conflict with /LIST
%2256% THEN WARNLEX(E291<0,0>)
%2256% ELSE NOLST=1
%[722]% ELSE !TRY NOCREF
%[722]% BEGIN
%2312% LOOK4CHAR=(UPLIT ASCIZ 'NOCREF')<36,7>;
%[722]% IF LEXICAL(.GSTSSCAN) NEQ 0
%2256% THEN ! Got /NOCREF
%2256% BEGIN
%2455% IF FLAGVMS THEN WARNLEX(E244<0,0>); ! VMA doesn't have /NOCREF
%2256% IF .NOCRF EQL 2 ! Check conflict with /CREF
%2256% THEN WARNLEX(E291<0,0>)
%2256% ELSE NOCRF=1
%2256% END
%2256% ELSE
%2256% BEGIN
%2312% LOOK4CHAR=(UPLIT ASCIZ 'LIST')<36,7>;
%2256% IF LEXICAL(.GSTSSCAN) NEQ 0
%2256% THEN ! Got /LIST
%2256% IF .NOLST EQL 1 ! Check conflict with /NOLIST
%2256% THEN WARNLEX(E291<0,0>)
%2256% ELSE NOLST=2
%2256% ELSE
%2256% BEGIN
%2312% LOOK4CHAR=(UPLIT ASCIZ 'CREF')<36,7>;
%2256% IF LEXICAL(.GSTSSCAN) NEQ 0
%2256% THEN ! Got /CREF
%2256% BEGIN
%2455% IF FLAGVMS THEN WARNLEX(E245<0,0>); ! VMS doesn't have /CREF
%2256% IF .NOCRF EQL 1 ! Check conflict with /NOCREF
%2256% THEN WARNLEX(E291<0,0>)
%2256% ELSE NOCRF=2
%2256% END
%2256% ELSE RETURN -1 ! Error
%2256% END
%2256% END
%[722]% END;
%[722]% LOOK4CHAR_"/"
%[722]% END UNTIL LEXICAL(.GSTCSCAN) EQL 0;
%[722]%
%[722]% RETURN 1;
END END;
ROUTINE SWIT20 (SWTEST,ORGICL) = ![2256]
! Try to match a switch (Fortran-20 version)
! SWTEST points to desired value of switch
! ORGICL points to switch in the INCLUDE text
BEGIN
IF FTTENEX
THEN BEGIN
REGISTER CHAR1,CHAR2; ! Current characters to match
LOCAL PNT; ! Pointer to literal to be matched
ICLPTR=.ORGICL; ! Start here in INCLUDE text
PNT=.SWTEST; ! Match this literal
UNTIL (CHAR1 = SCANI(PNT)) EQL 0
DO BEGIN
CHAR2=SCANI(ICLPTR);
IF .CHAR2 GEQ "a" AND .CHAR2 LEQ "z"
THEN CHAR2=.CHAR2-#40; ! Convert lower- to upper-case
IF .CHAR1 NEQ .CHAR2
THEN ! No match
BEGIN
ICLPTR=.ORGICL; ! Reset the pointer
RETURN FALSE
END
END;
SCANI(ICLPTR); ! Bump to next '/' or end
RETURN TRUE ! Match
END; ! If FTTENEX
END; ! of SWIT20
%LETS DO IT%
%2447% IF .FLGREG<ININCLUD> !IN INCLUDE NOW?
%2447% THEN
%2447% BEGIN !NOW IN INCLUDE
%2447% IF .ICLEVEL EQL INCLMAX-1 !NOW AT BOTTOM? (ZERO BASED)
%2447% THEN ERRORR(E120); !YES, NESTED TO DEEPLY
%2447% END !NOW IN INCLUDE
%2447% ELSE ICLEVEL = -1; !FIRST INCLUDE FILE
%2447% !(KEPT PRE-INCREMENTED
%2447% !UNTIL OPEN)
%2261% IF FLAGANSI THEN WARNLEX(E292<0,0>); ! INCLUDE is extension to ANSI
NOLST=NOCRF=0; ! Preset the defaults
IF NOT FTTENEX THEN
BEGIN !TOPS-10
%2447% FILENAME(ICLCHAN+1) _ 0;
TMP _ 0;
%2447% DIRECTORY(ICLCHAN+1) _ 0;
%2447% DEVICE(ICLCHAN+1) _ 0;
%GET THE INITIAL ' %
LOOK4CHAR _ "'";
IF LEXICAL(.GSTCSCAN) EQL 0
THEN
BEGIN
EXTERNAL LEXNAME;
LEXEMEGEN();
RETURN FATLEX(PLIT'''',.LEXNAME[.VREG<LEFT>],E0<0,0>);
END;
BEGIN
LABEL SPEC,LOOP,LOK,CHK;
SPEC:BEGIN
WHILE 1 DO
BEGIN %GET THE SPEC%
LOOP:BEGIN
%2447% IF @FILENAME(ICLCHAN+1) EQL 0
%2447% OR @DEVICE(ICLCHAN+1) EQL 0
THEN IF FILSP() EQL 1
THEN LEAVE LOOP !FOUND ONE
ELSE IF .VREG LSS 0
THEN RETURN .VREG;
%2447% IF @DIRECTORY(ICLCHAN+1) EQL 0
%2447% THEN IF PATH() EQL 1
THEN LEAVE LOOP
ELSE IF .VREG LSS 0
THEN ERRORR(E117);
IF SWIT10() LSS 0
THEN ERRORR(E116)
ELSE IF .VREG EQL 1
THEN LEAVE LOOP;
LEAVE SPEC !NOTHING ELSE RECOGNIZABLE
END %LOOP%
END %WHILE 1%
END ; %SPEC%
%GET THE FINAL ' %
LOOK4CHAR _ "'";
IF LEXICAL(.GSTCSCAN) EQL 0
THEN
BEGIN
EXTERNAL LEXNAME;
LEXEMEGEN();
RETURN FATLEX(PLIT'''',.LEXNAME[.VREG<LEFT>],E0<0,0>);
END;
IF LEXEMEGEN() NEQ EOSLEX^18
THEN RETURN NOEOSERRV;
%NOW LETS TRY AND OPEN THE FILE%
%2447% IF @DEVICE(ICLCHAN+1) EQL 0
%2447% THEN DEVICE(ICLCHAN+1) _ SIXBIT'DSK';
BEGIN %MAKE SURE THAT THE DEVICE IS A DISK%
%2447% MACHOP CALLI = #047;
%2447% MACRO DEVCHR(X) = CALLI(X,#4) $,
%2447% DV&DSK = 34,1 $;
%2447% VREG _ @DEVICE(ICLCHAN+1);
%2447% DEVCHR(VREG);
%2447% IF NOT .VREG<DV&DSK> !NOT A DISK?
THEN RETURN FATLERR(.ISN,E124<0,0>)
END;
%2447% IF @FILENAME(ICLCHAN+1) EQL 0
THEN ERRORR(E118); !NO FILE NAME
%2447% STATUS(ICLCHAN+1) _ 0; !ASCII
%2447% BUFFERS(ICLCHAN+1) _ BUFHDR(ICLCHAN+1)<0,0>;
LOK:BEGIN
WHILE 1 DO
BEGIN
%2447% REGISTER T1; !REGISTER FOR FILOP.
%2447% LOCAL ARGBLK[6]; !FILOP. BLOCK
%2447% ARGBLK[0] = (ICLCHAN+1)^18 + &FORED; !CHN,,FNC
%2447% ARGBLK[1] = @STATUS(ICLCHAN+1); !COPY I/O MODE
%2447% ARGBLK[2] = @DEVICE(ICLCHAN+1); !DEVICE
%2447% ARGBLK[3] = @BUFFERS(ICLCHAN+1); !0,,IHDR
%2447% ARGBLK[4] = 3; !0,,IBUFCNT
%2447% ARGBLK[5] = FILENAME(ICLCHAN+1)<0,0>; !0,,LKPBLK
%2447%
%2447% T1 = 6^18 + ARGBLK<0,0>; !LEN,,ADDR
%2447% IFSKIP FILOP&(T1) !PERFORM OPEN
%2447% THEN LEAVE LOK; !OK!!
%TRY WITHOUT .FOR %
IF .DEFAULT NEQ 0
THEN
BEGIN
EXTENSION(ICLCHAN+1) _ 0;
DEFAULT _ 0
END
ELSE ERRORR(E119)
END %WHILE 1%
END %LOK%
END;
END !TOPS-10
ELSE
BEGIN %FTTENEX%
EXTERNAL OPNICL,E138;
LOCAL BASE LIT;
EXTERNAL LITPOINTER;
LOCAL LITPNTSAV,VAL;
LITPNTSAV _ .LITPOINTER; !SAVE SO LITERAL CAN BE DELETED
%PICK UP THE LITSTRING SPEC%
LIT _ LEXICAL(.GSTLEXEME);
IF .LIT<LEFT> NEQ LITSTRING
THEN FATLEX(.LEXNAM[LITSTRING],.LEXNAM[.LIT<LEFT>],E0<0,0>);
%CHECK FOR EOS%
IF LEXICAL(.GSTLEXEME ) NEQ EOSLEX^18
THEN RETURN NOEOSERRV;
ICLPTR _ ( LIT[LIT1] )<36,7>; !SPEC POINTER
%2447% VAL = OPNICL(); !OPEN THE FILE, RETURNS JFN OR
%2447% !BP TO ERROR STRING
%2447% IF .VAL<LEFT> EQL 0 !WAS THERE AN ERROR?
%2447% THEN XDEVJFN(ICLCHAN+1) = .VAL !NO WAS A JFN
%2447% ELSE RETURN FATLERR(.VAL,.ISN,E138<0,0>); !YES, GIVE ERROR
%2256% ! Test for switches
%2256% ! Allow /LIST, /NOLIST, /CREF and /NOCREF
%2256% ! Warn if /LIST used with /NOLIST and if /CREF used with /NOCREF
%2455% ! VMS compatibility warning if /CREF or /NOCREF, or if neither
%2455% ! /LIST nor /NOLIST used (VMS default /NOLIST, we default /LIST)
%[722]% WHILE ..ICLPTR EQL "/"
%[722]% DO
%[722]% BEGIN
%2256% IF SWIT20((UPLIT ASCIZ 'NOLIST')<36,7>,.ICLPTR)
%2256% THEN ! Got /NOLIST
%2256% IF .NOLST EQL 2 ! and best not have /LIST
%2256% THEN WARNLEX(E291<0,0>)
%2256% ELSE NOLST=1
%2256% ELSE
%2256% IF SWIT20((UPLIT ASCIZ 'LIST')<36,7>,.ICLPTR)
%2256% THEN ! Got /LIST
%2256% IF .NOLST EQL 1 ! and best not have /NOLIST
%2256% THEN WARNLEX(E291<0,0>)
%2256% ELSE NOLST=2
%2256% ELSE
%2256% IF SWIT20((UPLIT ASCIZ 'NOCREF')<36,7>,.ICLPTR)
%2256% THEN ! Got /NOCREF
%2256% IF .NOCRF EQL 2 ! and best not have /CREF
%2256% THEN WARNLEX(E291<0,0>)
%2256% ELSE
%2256% BEGIN
%2455% IF FLAGVMS THEN WARNLEX(E244<0,0>); ! No /NOCREF on VMS
%2256% NOCRF=1
%2256% END
%2256% ELSE
%2256% IF SWIT20((UPLIT ASCIZ 'CREF')<36,7>,.ICLPTR)
%2256% THEN ! Got /CREF
%2256% IF .NOCRF EQL 1 ! and best not have /NOCREF
%2256% THEN WARNLEX(E291<0,0>)
%2256% ELSE
%2256% BEGIN
%2455% IF FLAGVMS THEN WARNLEX(E245<0,0>); ! No /CREF on VMS
%2256% NOCRF=2
%2256% END
%2256% ELSE
%2256% BEGIN
%2447% LOCAL ACSAVE;
%2447% REGISTER AC1=1;
%2447%
%2447% ACSAVE = .AC1; !SAVE AC1
%2447% AC1 = @XDEVJFN(ICLCHAN+1);
%2447% IFSKIP CLOSF THEN .VREG; !IGNORE ERROR
%2447% AC1 = .ACSAVE; !RESTORE AC1
%2256% FATLEX(E116<0,0>); ! Bad switch
%2256% RETURN
%2256% END
%2256% END; ! of WHILE
%FREE UP THE LITERAL%
%[1224]% SAVSPACE( .LIT[LITSIZ]+LTLSIZ-1 , @LIT );
LITPOINTER _ .LITPNTSAV;
IF .LITPOINTER<RIGHT> NEQ 0 THEN (@LITPOINTER)<RIGHT> _ 0;
END; %FTTENEX%
%2455% IF FLAGVMS ! VMS compatibility insists that we
%2256% THEN IF .NOLST EQL 0 ! have either /NOLIST or /LIST
%2256% THEN WARNLEX(E246<0,0>);
%OK WE GOT THE FILE%
%SAVE THE CURRENT BUFFERS%
%2412% LEXCLA(.GSTEOP); !TERMINATE CURRENT STATEMENT
EOPSVPOOL();
BEGIN !SAVE THE INFO
EXTERNAL EOPSAVE,CURPOOLEND,CURPTR,STLPTR,STPTR;
EXTERNAL LINEPTR,SEQLAST,LINELINE,CHARPOS;
%2447% ICLEVEL = .ICLEVEL + 1; !FINALLY INCREMENT LEVEL!!
%2447% !KEPT UN-INCREMENTED 'TILL NOW
%2447% SVINCL[0,.ICLEVEL] _ .EOPSAVE;
%2447% SVINCL[1,.ICLEVEL] _ .CURPOOLEND;
%2447% SVINCL[2,.ICLEVEL] _ .CURPTR;
%2447% SVINCL[3,.ICLEVEL] _ .STLPTR;
%2447% SVINCL[4,.ICLEVEL] _ .STPTR;
%2447% SVINCL[5,.ICLEVEL] _ .LINEPTR;
IF .SEQLAST NEQ 0
%2447% THEN SVINCL[6,.ICLEVEL] _ .LINELINE !LINE SEQUENCE NUMBER
%2447% ELSE SVINCL[6,.ICLEVEL] _ 0;
%2447% SVINCL[7,.ICLEVEL] _ .CHARPOS;
IF .CHARPOS NEQ 72
THEN LINELINE _ .LINELINE+1; !MULTIPLE STATEMENTS ON LINE
%2447% SAVFLG[.ICLEVEL] _ .FLGREG<0,36>;
FLGREG<ININCLUD> _ 1;
FLGREG<EOCS> _ 1;
%2256% IF .NOCRF EQL 1 THEN FLGREG<CROSSREF> = 0;
%2256% IF .NOLST EQL 1 THEN FLGREG<LISTING> = 0;
SVFLG2[.ICLEVEL] _ .FLAGS2;
FLAGS2<TTYINPUT> _ 0;
%2447% FIXLINENO(); !ZAP LINENO[1]
CURPOOLEND _ POOL<0,0>;
IF EOPRESTORE() EQL EOF
THEN POSTINCL() !RESTORE
END !SAVE THE INFO
END; ! of INCLSTA
GLOBAL ROUTINE POSTINCL=
BEGIN
%RESTORE THE WORLD AFTER AN INCLUDED FILE %
EXTERNAL EOPSAVE,CURPOOLEND,CURPTR,STLPTR;
EXTERNAL STPTR,LINEPTR,SEQLAST,LINELINE;
EXTERNAL EOPRESTORE,SVFLG2;
EXTERNAL SAVFLG,GSTEOP,CHARPOS;
%2447% MACHOP CALLI = #047; !IMMEDIATE CALL (TOPS-10)
%2447% MACRO FILOP&(X) = CALLI(X,#155) $; !GENERAL FILE OPERATOR
%2447% BIND &FOCLS = #7; !FILOP. CLOSE FUNCTION
%2447% MACHOP JSYS = #104; !JUMP TO SYSTEM (TOPS-20)
%2447% MACRO CLOSF = JSYS(0,#22) $; !CLOSE JFN IN AC1
% CLEAN UP LAST LINE%
%2412% LEXCLA(.GSTEOP);
IF NOT FTTENEX
THEN
%2447% BEGIN !TOPS-10
%2447% REGISTER T1; !FILOP. CHANNEL
%2447% LOCAL ARG; !FILOP. BLOCK
%2447%
%2447% ARG = ICLCHAN^18 + &FOCLS; !CHAN,,FUNCTION
%2447% T1 = 1^18 + ARG<0,0>; !LENGTH,,ADDR
%2447% IFSKIP FILOP&(T1) !CLOSE CHANNEL
%2447% THEN .VREG !IGNORE ERRORS
%2447% END !TOPS-10
ELSE
%2447% BEGIN !TOPS-20
%2447% REGISTER AC1=1;
%2447% LOCAL ACSAVE;
%2447%
%2447% ACSAVE = .AC1; !SAVE AC1
%2447% AC1 = @XDEVJFN(ICLCHAN); !GET JFN
%2447% IFSKIP CLOSF THEN .VREG; !CLOSE AND IGNORE ERROR
%2447% AC1 = .ACSAVE !RESTORE AC1
%2447% END; !TOPS-20
%2447% EOPSAVE = @SVINCL[0,.ICLEVEL];
%2447% CURPOOLEND = @SVINCL[1,.ICLEVEL];
%2447% CURPTR = @SVINCL[2,.ICLEVEL];
%2447% STLPTR = @SVINCL[3,.ICLEVEL];
%2447% STPTR = @SVINCL[4,.ICLEVEL];
%2447% LINEPTR = @SVINCL[5,.ICLEVEL];
%2447% IF @SVINCL[6,.ICLEVEL] NEQ 0
%2447% THEN LINELINE = @SVINCL[6,.ICLEVEL]; !LINE SEQUENCE NUMBER
%2447% CHARPOS = @SVINCL[7,.ICLEVEL];
SEQLAST _ 1; !SO NO ONE WILL MESS WITH THE LINELINE
!KEEP VALUES OF SOME FLAGS WHICH MAY HAVE CHANGED
!DURING PROCESSING OF THE INCLUDE FILE, AND WHOSE NEW
!VALUES WE REALLY WANT TO KEEP !!
%2447% SAVFLG[.ICLEVEL]<BTTMSTFL> _ .FLGREG<BTTMSTFL>; !IF 16 CLOBBERED
%2447% SAVFLG[.ICLEVEL]<WARNGERR> _ .FLGREG<WARNGERR>; !WARNINGS GIVEN
%2447% SAVFLG[.ICLEVEL]<FATALERR> _ .FLGREG<FATALERR>; !FATAL ERRORS GIVEN
%2447% SAVFLG[.ICLEVEL]<LABLDUM> _ .FLGREG<LABLDUM>; !LABELS PASSED AS ARGS
%2447% FLGREG<0,36> _ .SAVFLG[.ICLEVEL];
%2447% FLAGS2 _ .SVFLG2[.ICLEVEL];
%2447% ICLEVEL = .ICLEVEL - 1; !DECREMENT INCLUDE LEVEL
%2447% IF .ICLEVEL LSS 0 !DID WE JUST LEAVE THE LAST INCLUDE?
%2447% THEN LINENO[1] _ '?I' !YES, RESET LINENO TO TAB
%2447% ELSE FIXLINENO(); !NO, MAKE IT <*><NUMBER>
EOPRESTORE(); !RESTORE THE BUFFERS
END; ! of POSTINCL
ROUTINE FIXLINENO =
!++
! New [2447] /PLB
! FUNCTIONAL DESCRIPTION:
! Setup LINENO[1] so that a *1 will appear next to the INCLUDEd
! code's line number. The second level of INCLUDE file will
! have *2, the third *3; level 10 will be listed as *A etc.
!
! This routine assumes .FLGREG<ININCLUD> is set.
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! ICLEVEL = Current INCLUDE level
!
! IMPLICIT OUTPUTS:
!
! Blasts LINENO[1]
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN
REGISTER C;
LINENO[1] = '*x?I?0'; !SET UP TEMPLATE
IF .ICLEVEL+1 LEQ 9 !LEVEL 9 OR LESS (ZERO BASED)
THEN C = .ICLEVEL+1+"0" !YES, GET DIGIT 1..9
ELSE C = .ICLEVEL+1+"A"-10; !NO, GET LETTER A..C
LINENO[1]<22,7> = .C; !BLAST IN LEVEL INDICATOR
RETURN .VREG !RETURN NOVALUE
END; !FIXLINENO
GLOBAL ROUTINE ASTER(TYPE) = ! [1527] Rewritten
BEGIN
!***************************************************************
! This routine will scan for the *length construct following the
! data type name in type or IMPLICIT or FUNCTION statements, and
%1575% ! for the forms 'var * len (subs) * len' in type declarations.
! The parameter TYPE is based upon the data type name. This
! routine will return as its value:
! 1. The amended TYPE if a valid * construct was found
! 2. TYPE if no * construct was found
! 3. -1 if there was some error in the * construct
!
%1575% ! Two words are deposited on STK:
%1575% ! length for character data or 0
%1575% ! flag = 1 if *size was specified
!***************************************************************
MACRO ERR50(X) = FATLEX( .CHLEN, X<0,0>, E50<0,0>)$,
ERR24(X) = WARNLEX( X<0,0>, .CHLEN, E24<0,0>)$,
%2252% ERR251(X) = WARNERR( X<0,0>, .ISN, E251<0,0>)$;
REGISTER
BASE T1,
D;
EXTERNAL
E251, ! Extension to Fortran-77: xxxxx length specifier
CONSTEXPR,
CHLEN,
CHDLEN,
ACTLDATYPE;
%1575% ! Put the default character length on STK and also a zero word
%1575% ! for the flag word for *size was specified
%1575% STK[SP = .SP + 1] = CHLEN = .CHDLEN;
%1575% STK[SP = .SP + 1] = 0;
! Look at upcoming character. If '*', continue below, otherwise return
IF .LSAVE EQL 0
THEN
BEGIN
LOOK4CHAR = "*";
IF LEXICAL( .GSTCSCAN ) EQL 0 THEN RETURN .TYPE;
END
ELSE
BEGIN
IF .LEXL<LEFT> NEQ ASTERISK THEN RETURN .TYPE;
LSAVE = 0;
END;
! Got an *, set the flag for *size specified and check for '(*)'
%1575% STK[.SP] = 1;
LOOK4CHAR = (UPLIT ASCIZ '(*)')<36,7>;
IF LEXICAL(.GSTSSCAN) NEQ 0
THEN
BEGIN
IF .TYPE NEQ CHARACTER
THEN RETURN FATLEX (UPLIT'constant',UPLIT'(*)',E0<0,0>);
CHLEN = LENSTAR;
END
ELSE
BEGIN ! digits for length
LOOK4CHAR = "?D"; ! any digit
IF (D = LEXICAL(.GSTCSCAN)) NEQ 0
THEN
BEGIN ! *digits
CHLEN = .D - "0";
WHILE (D = LEXICAL(.GSTCSCAN)) NEQ 0
DO CHLEN = .CHLEN*10 + .D - "0";
END ! *digits
ELSE
BEGIN ! *(expression)
LOOK4CHAR = "(";
IF LEXICAL(.GSTCSCAN) NEQ 0
THEN
BEGIN
IF CONSTEXPR() LSS 0 THEN RETURN .VREG;
IF .LSAVE NEQ 0 THEN LSAVE = 0
ELSE LEXL = LEXEMEGEN();
IF .LEXL<LEFT> NEQ RPAREN
THEN RETURN ERR0L(RPARPLIT);
T1 = .STK[.SP];
SP = .SP - 1;
CHLEN = .T1[CONST2];
END
ELSE
%1667% BEGIN ! error - give found when expecting error
%1667% IF .LSAVE EQL 0
%1667% THEN
%1667% BEGIN
%1667% LEXL = LEXEMEGEN();
%1667% LSAVE = -1;
%1667% END;
%1667% RETURN ERR0L(UPLIT ASCIZ'integer constant or "("');
END; ! error - give found when expecting error
END; ! *(expression)
%1646% ! Give Illegal CHARACTER size modifier is less than 1
%1646% IF .CHLEN LEQ 0 THEN RETURN ERR50(CHARPLIT);
END;
STK[.SP - 1] = .CHLEN; ! Set size specifier on STK
! Check the specified size to see if it is legal. Do the check
! on the basis of ACTLDATYPE of the statement in order to allow
! REAL*8 X*4 and to exclude doubleprecision X*4. Return the
! datatype.
SELECT .ACTLDATYPE OF NSET
INTEGER:(
IF .CHLEN EQL 2
THEN
BEGIN
ERR24(INTGPLIT);
RETURN .ACTLDATYPE
END;
%2250% IF .CHLEN EQL 4
%2250% THEN
%2250% BEGIN
%2250% IF FLAGANSI THEN ERR251(INTGPLIT);
%2250% RETURN .ACTLDATYPE
%2250% END;
RETURN ERR50(INTGPLIT);
);
REAL:(
%2250% IF .CHLEN EQL 4
%2250% THEN
%2250% BEGIN
%2250% IF FLAGANSI THEN ERR251(REALPLIT);
%2250% RETURN .ACTLDATYPE
%2250% END;
%2250% IF .CHLEN EQL 8
%2250% THEN
%2250% BEGIN
%2250% IF FLAGANSI THEN ERR251(REALPLIT);
%2250% RETURN DOUBLPREC
%2250% END;
IF .CHLEN EQL 16
THEN
BEGIN
%2460% ERR24(DOUBPLIT);
%2460% RETURN DOUBLPREC
END;
RETURN ERR50(REALPLIT)
);
COMPLEX:(
%2250% IF .CHLEN EQL 8
%2250% THEN
%2250% BEGIN
%2250% IF FLAGANSI THEN ERR251(COMPLIT);
%2250% RETURN .ACTLDATYPE
%2250% END;
IF .CHLEN EQL 16
THEN
BEGIN
ERR24(COMPLIT);
RETURN .ACTLDATYPE
END;
IF .CHLEN EQL 32
THEN
BEGIN
ERR24(COMPLIT);
RETURN .ACTLDATYPE
END;
RETURN ERR50(COMPLIT)
);
LOGICAL:(
%2250% IF .CHLEN EQL 4
%2250% THEN
%2250% BEGIN
%2250% IF FLAGANSI THEN ERR251(LOGIPLIT);
%2250% RETURN .ACTLDATYPE
%2250% END;
%2250% IF .CHLEN EQL 2
%2250% THEN
%2250% BEGIN
%2250% ERR24(LOGIPLIT);
%2250% RETURN .ACTLDATYPE
%2250% END;
IF .CHLEN EQL 1
THEN
BEGIN
ERR24(LOGIPLIT);
RETURN .ACTLDATYPE
END;
RETURN ERR50(LOGIPLIT)
);
DOUBLPREC:(RETURN ERR50(DOUBPLIT));
CHARACTER:(RETURN .ACTLDATYPE);
TESN
END; ! of ASTER
GLOBAL ROUTINE TYPDECLARE(DTYPE)=
BEGIN
!***************************************************************
! Called by INTESTA, REALSTA, LOGIST, DOUBST, COMPST, and
! CHARSTA statement routines. It handles the *size modifier,
! then uses the syntax of DECLARESPEC to parse a function
! declaration or an explicit type declaration. It then calls
! either FUNCGEN or TYPEGEN to handle the semantics.
!***************************************************************
EXTERNAL LSAVE;
EXTERNAL FUNCGEN,TYPEGEN,SAVSPACE,TYPE,STK;
EXTERNAL PST1ST,PSTATE,PSTIMPL,PSTSPF,ENDSTA;
%1213% EXTERNAL CHDLEN,ACTLDATYPE;
REGISTER BASE T1;
ACTLDATYPE _ .DTYPE; !SAVE ACTUAL TYPE IDENTIFIER CODE
%1213% ! Default length for character data is 1.
%1213% CHDLEN _ 1;
! PICK UP THE *N CONSTRUCT IF ANY
LSAVE _ 0;
IF ( IDTYPE _ ASTER ( .DTYPE )) LSS 0 THEN RETURN .IDTYPE;
%1575% ! ASTER leaves two words on STK:
%1575% ! length for character data
%1575% ! flag = 1 if *size was specified
%1704% ! Scan for optional comma after optional *n construct
%1704% IF .STK[.SP] EQL 1
%1704% THEN
%1704% BEGIN ! *size was specified, look for optional comma
%1704% IF .LSAVE EQL 0
%1704% THEN
%1704% BEGIN
%1704% LOOK4CHAR = ",";
%1704% LEXICAL( .GSTCSCAN ); ! Skip comma
%1704% END
%1704% ELSE
%1704% BEGIN
%1704% IF .LEXL<LEFT> EQL COMMA
%1704% THEN LSAVE = 0;
%1704% END;
%1704% END; ! *size was specified, look for optional comma
%1575% ! Fetch default length for character data left on stack by ASTER
%1575% IF .IDTYPE EQL CHARACTER
%1575% THEN CHDLEN _ .STK[.SP - 1]
%1575% ELSE CHDLEN _ 0;
%1575% SP = .SP - 2; ! Discard the two words ASTER put on STK
IF SYNTAX( DECLARESPEC) LSS 0 THEN RETURN .VREG;
TYPE _ 4;
T1_ .STK[0];
IF .T1[ELMNT] EQL 1
THEN
BEGIN % FUNCTION %
% CHECK THE STATEMENT ORDERING %
IF .PSTATE EQL PST1ST<0,0>
THEN
BEGIN % FINE ITS THE 1ST STATEMENT %
PSTATE _ PSTIMPL<0,0>; ! ADJUST PSTATE TO IMPLICIT
FLGREG<PROGTYP> _ FNPROG;
%1213% ! Add second parameter to FUNCGEN; this is the
%1213% ! 'datatype FUNCTION ....' case
%1213% FUNCGEN(@.T1[ELMNT1], 1)
END
ELSE
BEGIN % MISSING END STATEMENT %
RETURN ENDSTA()
END
END
ELSE
BEGIN % TYPE DECLARATION %
IF .PSTATE EQL PST1ST<0,0>
THEN PSTATE _ PSTSPF<0,0>; ! SPECIFICATION STATE
TYPEGEN(.T1[ELMNT1])
END;
SAVSPACE(.STK[0]<LEFT>,.STK[0])
END; ! of TYPDECLARE
! TYPE STATEMENTS *************
MACRO DATATYPE ( DTYPE ) =
BEGIN
RETURN TYPDECLARE( DTYPE )
END
$;
GLOBAL ROUTINE INTESTA = DATATYPE ( INTEGER );
GLOBAL ROUTINE REALSTA = DATATYPE ( REAL ) ;
GLOBAL ROUTINE LOGISTA = DATATYPE ( LOGICAL ) ;
GLOBAL ROUTINE DOUBSTA = DATATYPE ( DOUBLPREC ) ;
GLOBAL ROUTINE COMPSTA = DATATYPE ( COMPLEX ) ;
GLOBAL ROUTINE CHARSTA =
BEGIN
%1213% ! Add CHARSTA for character declaration
! Set flag for character declaration seen used
! in MRP3R and MRP3G to test if we have to scan
! the symbol table to generate high seg
! character descriptors.
CHDECL _ -1;
DATATYPE ( CHARACTER ) ; ! Now process the character statement
END; ! of CHARSTA
GLOBAL ROUTINE FUNCSTA=
BEGIN
EXTERNAL STK,
FUNCGEN %()%,
SAVSPACE %(SIZE,LOC)%,
TYPE;
REGISTER BASE T1;
!SEMANTIC ANALYSIS BEGINS
T1_.STK[0];
IDTYPE_-1;
TYPE_4;
FLGREG<PROGTYP> _ FNPROG;
%[1213]% ! Add second parameter to FUNCGEN; this is 'FUNCTION ...' case
%[1213]% FUNCGEN(.T1[ELMNT], 0);
SAVSPACE(0,@STK[0]);
.VREG
END; ! of FUNCSTA
GLOBAL ROUTINE SUBRSTA=
BEGIN
EXTERNAL STK,FUNCGEN %()%,SAVSPACE %(SIZE,LOC)%,TYPE;
REGISTER BASE T1;
!SEMANTIC ANALYSIS BEGINS
T1_.STK[0];IDTYPE_-1;TYPE_0;
FLGREG<PROGTYP> _ SUPROG;
%[1213]% ! Add second parameter to FUNCGEN; this is 'SUBROUTINE ...' case
%[1213]% FUNCGEN(.T1[ELMNT], 0);
SAVSPACE(0,@STK[0]);
.VREG
END; ! of SUBRSTA
GLOBAL ROUTINE ENTRSTA=
BEGIN
! Process an ENTRY statement
%1434% ! Rewritten by TFV on 14-Dec-81
REGISTER
BASE FUNCID, ! Name of this function subprogram
BASE IDSYM, ! Name of the entry point
BASE PTR, ! Pointer to the syntactic output
BASE TREE; ! Pointer to the block to pass to the
! EQUIVALENCE statement semantic routine
LOCAL
%2455% SAVEFLAG, ! Save FLAGVMS setting
VAL; ! Used to avoid VREG usage
! Check for error - entry illegal inside a do or block if
IF .DOIFSTK NEQ 0 THEN FATLEX(E75<0,0>);
! Check for error - entry illegal in main program
IF .FLGREG<PROGTYP> EQL MAPROG THEN RETURN FATLEX(E114<0,0>);
IDTYPE = -1; ! Flag for FUNCGEN
FLGREG<MULTENT> = 1; ! Set entries in subroutine flag
PTR = .STK[0]; ! Pointer to syntactic output
IDSYM = @.PTR[ELMNT]; ! Symbol table entry for this
! entry point
%1531% ! An ENTRY point can not be in a SAVE statement.
%1531% IF .IDSYM[IDSAVVARIABLE]
%1531% THEN FATLERR(.IDSYM[IDSYMBOL],UPLIT(ASCIZ'ENTRY name'),
%1531% .ISN,E192<0,0>);
! Equivalence a numeric function and its entry names, character
! functions and their entry points just share the descriptor for the
! result.
IF .FLGREG<PROGTYP> EQL FNPROG
THEN
BEGIN ! Function subprogram
ENTRY = .PROGNAME; ! Name of this subprogram
NAME = IDTAB;
FUNCID = TBLSEARCH(); ! Lookup symbol table entry for
! the subprogram name
IF .FUNCID[VALTYPE] NEQ CHARACTER
THEN
BEGIN ! Numeric function subprogram
! Give an error if this is a character entry point.
! If it is numeric, pretend that we are the syntax
! analyzer and generate an EQUIVALENCE statement
! syntax tree and then give it to EQUISTA for
! semantic processing.
! Check for error - character and numeric entry
! points cannot be mixed.
IF .IDSYM[VALTYPE] EQL CHARACTER
THEN RETURN FATLEX(E178<0,0>);
NAME<LEFT> = 9; ! Size of syntax tree
STK[0] = TREE = CORMAN(); ! Get some space
(.TREE)[0] = .TREE + 1; ! List pointer
(.TREE)[1] = 1^18 + .TREE + 2; ! All pointer
(.TREE)[2] = 1^18 + .TREE + 4; ! All pointer
(.TREE)[3] = .TREE + 6; ! List pointer
(.TREE)[4] = .FUNCID; ! Function name
(.TREE)[4]<LEFT> = IDENTIFIER;
(.TREE)[5] = 0; ! Option
(.TREE)[6] = 1^18 + .TREE + 7; ! All pointer
(.TREE)[7] = .IDSYM; ! Entry name
(.TREE)[8] = 0; ! Option
! Now process the syntax tree using the EQUIVALENCE
! statement semantic routine.
%2270% ! Compatibility flagging is turned off so that we
%2270% ! won't put out a 'program name same as entry name'
%2270% ! flagger warning.
%2455% SAVEFLAG=.F2<CFLGVMS>; ! Remember what flag setting is
%2455% F2<CFLGVMS>=0; ! Turn off flagging temporarily
%2270% VAL=EQUISTA(); ! Equate progname to entryname
%2455% F2<CFLGVMS>=.SAVEFLAG; ! Maybe turn flagging back on
%2270% IF .VAL LSS 0 THEN RETURN .VAL ! Return if error
END ! Numeric function subprogram
ELSE
BEGIN ! Character function subprogram
! Check for error - character and numeric entry
! points cannot be mixed.
IF .IDSYM[VALTYPE] NEQ CHARACTER
THEN RETURN FATLEX(E178<0,0>);
! Check for error - Character entry points must have
! the same length.
IF .IDSYM[IDCHLEN] NEQ .FUNCID[IDCHLEN]
THEN RETURN FATLEX(E179<0,0>);
IDTYPE = CHARACTER; ! used by funcgen
END; ! Character function subprogram
END ! Function subprogram
%2507% ELSE
%2507% BEGIN ! Subroutine subprogram
%2507%
%2507% IDSYM[IDSUBROUTINE] = 1; ! Mark symbol as subroutine
%2507%
%2507% END; ! Subroutine subprogram
TYPE = 1;
%1213% ! Add second parameter to FUNCGEN; this is 'ENTRY ...' case
%1213% FUNCGEN(.PTR[ELMNT],0);
SAVSPACE(0,@PTR)
END; ! of ENTRSTA
GLOBAL ROUTINE PROGSTA=
BEGIN
EXTERNAL NAMDEF;
EXTERNAL PROGNAME;
LEXL_LEXEMEGEN();
IF .LEXL<LEFT> EQL IDENTIFIER
%[1000]% THEN
%[1000]% BEGIN
%[1000]% LOCAL BASE PR1;
PR1_ .LEXL<RIGHT>;
PROGNAME_.PR1[IDSYMBOL];
NAMDEF( ENTRYDEF, .PR1 ); ! DEFINITION OF PROGNAME
PR1[IDATTRIBUT(FENTRYNAME)] _ 1; ! SET ENTRY POINT FLAG
LEXL_LEXEMEGEN();
%[1000]% END
%[1000]% ELSE RETURN ERR0L(PLIT 'PROGRAM name'); ! Flag missing name
IF .LEXL<LEFT> NEQ LINEND
THEN
BEGIN %SKIP ANYTHING LEFT FOR CDC COMPATIBILITY%
EXTERNAL FATLEX,E134;
DO LEXEMEGEN() UNTIL .VREG<LEFT> EQL LINEND;
FATLEX(E134<0,0>)
END;
.VREG
END; ! of PROGSTA
GLOBAL ROUTINE PARASTA=
! Parameter statement.
! [1656] All semantics are done in action routines; just return.
RETURN 0; ! RETURN SUCCESS
GLOBAL ROUTINE BLOCSTA=
BEGIN
EXTERNAL PROGNAME,STK,NAMDEF;
LEXL_LEXEMEGEN();
IF .LEXL<LEFT> EQL IDENTIFIER
THEN(LOCAL BASE PR1;
PR1_ .LEXL<RIGHT>;
PROGNAME_.PR1[IDSYMBOL];
NAMDEF( ENTRYDEF, .PR1 ); ! DEFINITION OF NAME
PR1[IDATTRIBUT(FENTRYNAME)] _ 1; !ENTRY POINT FLAG
LEXL_LEXEMEGEN();
)
ELSE PROGNAME _ SIXBIT'.BLOCK';
FLGREG<PROGTYP> _ BKPROG; !BLOCK DATA SUBPROGRAM FLAG
IF .LEXL<LEFT> NEQ LINEND THEN RETURN NOEOSERRL;
.VREG
END; ! of BLOCSTA
GLOBAL ROUTINE DIMESTA=
BEGIN
EXTERNAL STK,BLDARRAY %(LIST OF ONEARRAY'S)%,SAVSPACE %(SIZE,LOC)%,TYPE;
REGISTER BASE T1;
!SEMANTIC ANALYSIS BEGINS
IDTYPE_-1;TYPE_0;T1_@STK[0];BLDARRAY(.T1[ELMNT]);
SAVSPACE(0,@STK[0]);
.VREG
END; ! of DIMESTA
GLOBAL ROUTINE COMMSTA=
BEGIN
EXTERNAL NAMDEF;
EXTERNAL STK,
BLDARRAY %(ONEARRAY LIST)%,
SAVSPACE %(SIZE,LOC)%,
TYPE,
IDTYPE,
BLKSRCH %(NAME)%;
EXTERNAL FATLEX,
E0;
REGISTER BASE T1;
LOCAL BASE T2;
REGISTER BASE R1:R2;
!SEMANTIC ANALYSIS BEGINS
!------------------------------------------------------------------------------
!THE FIRST LOCATION OF THE LEXEME STACK (STK[0])
!POINTS TO THE LIST OF COMMON GROUPS TO BE SCANNED.
!------------------------------------------------------------------------------
R1_.STK[0];
STK[1]_.R1[ELMNT];
SAVSPACE(0,@R1);
INCR CLST FROM @STK[1] TO @STK[1]+.STK[1]<LEFT> DO
BEGIN
MAP BASE CLST;
R1_.CLST[ELMNT];
IF .R1[ELMNT] EQL 0 THEN ! BLANK COMMON
BEGIN
IF .CLST EQL @STK[1] !IF WE ARE STILL AT THE BEGINNING OF THE LIST
THEN
%1511% BEGIN !IT'S OK
R2_BLKSRCH(SIXBIT '.COMM.');
%1511% ! We need a SAVE rel block
%1511% SAVBLC _ TRUE;
%1511% SAVNED _ TRUE;
%1511% END
ELSE !SOMEONE FORGOT A COMMA
FATLEX(PLIT ', OR /',PLIT 'IDENTIFIER',E0<0,0>)
END
ELSE !SLASHS SEEN GET BLOCK NAME IF THERE
BEGIN
%1256% IF .R1[ELMNT] EQL 2
! OPTION 2, // SEEN. MEANS BLANK COMMON
%1256% THEN
%1511% BEGIN
R2_BLKSRCH(SIXBIT '.COMM.');
%1511% ! Need to rel block to SAVE this
%1511% SAVBLC _ TRUE;
%1511% SAVNED _ TRUE;
%1511% END
ELSE ! OPTION 1, /IDENTIFIER/ SEEN.
BEGIN
T1_.R1[ELMNT1];
T2_.T1[ELMNT1];SAVSPACE(.T1<LEFT>,@T1);
%CHECK AND DEFINE THE NAME %
IF NAMDEF( CMNBLK, .T2 ) LSS 0 THEN RETURN .VREG;
T2[IDATTRIBUT(COMBL)] _ 1; !SET COMMONBLOCK NAME BIT
R2_BLKSRCH(.T2[IDSYMBOL]);
R1_.R1+1; !INCR PTR IF SLASHES FOR CALL TO BLDARRAY COMING UP
END;
END;
IDTYPE_-1;
TYPE_5;
STK[2]<LEFT>_.R2[COMFIRST];
!MUST BE VERY CAREFUL IF BLDARRAY FAILS, FOR UNDER SOME
! CIRCUMSTANCES, STK[2] WILL CONTAIN -1 WHICH KILLS US
STK[2]<RIGHT>_.R2[COMLAST];
IF BLDARRAY(.R1[ELMNT1]) GEQ 0
THEN
BEGIN
!------------------------------------------------------
!STK[2] CONTAINS THE INFORMATION REQUIRED BY
!BLDARRAY TO LINK ELEMENTS OF THE COMMON BLOCK. IT
!IS UPDATED BY BLDARRAY TO CONTAIN LINKS TO THE
!FIRST AND LAST ELEMENT IN THE BLOCK.
!------------------------------------------------------
R2[COMFIRST]_.STK[2]<LEFT>;
R2[COMLAST]_.STK[2]<RIGHT>;
R1 _ .R2[COMFIRST]; !FIRST ITEM IN BLOCK
DO
BEGIN
!PUTTING PTR TO COMMON BLOCK IN EACH ITEM
R1[IDCOMMON] _ .R2;
%2343% !Put variable in proper psect
%2343% IF .R1[VALTYPE] EQL CHARACTER
%2343% THEN
%2343% BEGIN !Character
%2343% R1[IDPSECT] = PSCODE;
%2343% R1[IDPSCHARS] = .R2[COMPSECT];
%2343% END !Character
%2343% ELSE
%2343% BEGIN !Non-Character
%2343% R1[IDPSECT] = .R2[COMPSECT];
%2343% R1[IDPSCHARS] = PSOOPS;
%2343% END; !Non-Character
END
WHILE (R1 _ .R1[IDCOLINK]) NEQ 0;
END %OF FIXING UP COMMON POINTERS%
END;
T1_.STK[1];SAVSPACE(.T1<LEFT>,@T1);
.VREG
END; ! of COMMSTA
GLOBAL ROUTINE SAVESTA= ![1511] New [1531] Rewrite
! Processes SAVE statements
BEGIN
REGISTER BASE PTR1; ! Pointer to something
REGISTER BASE PTR2; ! Pointer to something
REGISTER BASE SYMTAB; ! Symbol table entry
SAVNED = TRUE; ! We need a save statement
! STK[0]
! | len-1,,ptr | ---> | 0=no args |
! +--------------------+
! | len-1,,ptr to args |
PTR1 = .STK<RIGHT>;
IF .PTR1[ELMNT] EQL 0
THEN ! No arguments given, set global flag.
BEGIN
SAVALL = TRUE; ! Save everything possible
SAVLOC = TRUE; ! Save locals (non-commons)
END
ELSE
BEGIN ! Arguments are given, process them.
PTR1 = .PTR1[ELMNT1]; ! Get the pointer
INCR ARG FROM .PTR1<RIGHT> TO .PTR1<RIGHT> + .PTR1<LEFT>
BY 2 DO
BEGIN ! For each argument to SAVE
MAP BASE ARG;
! | len-1,,ptr to args | ---> | 1=var, 2=common |
! +-----------------+
! | len-1,,ptr |
IF .ARG[ELMNT] EQL 1
THEN
BEGIN ! Variable or array
SYMTAB = .ARG[ELMNT1]; ! Symbol table
%2430% ! If this has been declared in a SAVE
%2430% ! statement before, then tell the user
%2430% ! this is extraneous.
%2430%
%2430% IF .SYMTAB[IDSAVVARIABLE]
%2430% THEN IF FLAGEITHER ! /FLAG given
%2430% THEN CFLAGB(.SYMTAB[IDSYMBOL], E301<0,0>)
%2430% ELSE SYMTAB[IDSAVVARIABLE] = 1; ! Found in SAVE
SAVLOC = TRUE; ! Save locals
! If this variable is declared in a common,
! then give an error.
IF .SYMTAB[IDATTRIBUT(INCOM)]
THEN FATLERR(.SYMTAB[IDSYMBOL],
UPLIT(ASCIZ'COMMON variable'),
.ISN,E192<0,0>);
! Dummy's are illegal.
IF .SYMTAB[IDATTRIBUT(DUMMY)]
THEN FATLERR(.SYMTAB[IDSYMBOL],
UPLIT(ASCIZ'Dummy argument'),
.ISN,E192<0,0>);
! External function name is illegal
IF .SYMTAB[IDATTRIBUT(INEXTERN)] OR
.SYMTAB[IDATTRIBUT(USERFUNCTION)]
THEN FATLERR(.SYMTAB[IDSYMBOL],
UPLIT(ASCIZ'External name'),
.ISN,E192<0,0>);
END ! Variable or array
ELSE
BEGIN ! Named common block name
! | len-1,,ptr | ---> | 23 octal (/) |
! +-------------------+
! | ptr to symbol tbl |
! +-------------------+
! | 23 octal (/) |
PTR2 = .ARG[ELMNT1];
SYMTAB = .PTR2[ELMNT1]; ! Symbol table
! Don't link this name if it was already
! specified in a SAVE.
IF NOT .SYMTAB[IDSAVCOMMON]
THEN LKSVCOMMON(.SYMTAB); ! Link it in
END; ! Named common block name
END; ! For each argument to SAVE
END; ! Arguments are given, process them.
END; ! of SAVESTA
GLOBAL ROUTINE LKSVCOMMON(SYMTAB)= ![1531] Rewrite
BEGIN
! Put passed common symbol table pointer into linked list of
! commons for SAVE statement processing.
REGISTER BASE NEWLINK; ! New link to be added to PTRSAVCOMMON
MAP BASE SYMTAB; ! Passed argument - symbol table entry to
! be added.
! Get one word for the link
NAME<LEFT> = 1;
NEWLINK = CORMAN();
! Place in ptr to symbol table
NEWLINK[CW0L] = .SYMTAB;
! Place in ptr to previous common symbol or 0
NEWLINK[CLINK] = .PTRSAVCOMMON;
PTRSAVCOMMON = .NEWLINK;
! Bump count of commons by one
NUMSAVCOMMON = .NUMSAVCOMMON + 1;
! Mark that this common is to be SAVE-d
SYMTAB[IDSAVCOMMON] = 1;
END; ! of LKSVCOMMNON
END
ELUDOM