Trailing-Edge
-
PDP-10 Archives
-
BB-D480C-SB_1981
-
sta2.bli
There are 26 other files named sta2.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
! OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: F.J. INFANTE, D. B. TOLMAN/DCE/SJW/EGM
MODULE STA2(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
! REQUIRES FTTENX.REQ, LEXNAM, FIRST, TABLES, META72, ASHELP
REQUIRE FTTENX.REQ;
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE META72.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;
GLOBAL BIND STA2V = 6^24 + 0^18 + 48; ! Version Date: 17-Jul-81
%(
***** 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
***** End Revision History *****
)%
GLOBAL ACTLDATYPE; !SET TO THE CODE OF THE SPECIFIC DATA TYPE IDENTIFIER
!IN ORDER TO DIFFERENTIATE BETWEEN REAL*8 AND
!DOUBLEPRECISION WHEN DOING THE SIZE MODIFIER
!OVERRIDE
!USED IN ASTER AND SET IN TYPDECLARE
!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
GLOBAL ROUTINE
INCLSTA =
BEGIN % INCLUDE STATEMENT%
GLOBAL SVFLG2;
EXTERNAL EOPSVPOOL,POOL,EOPRESTORE;
EXTERNAL LEXICAL,GSTCSCAN,GSTSSCAN,LOOK4CHAR,LEXEMEGEN,GSTEOP;
BIND EOF = #200;
MACHOP LOOKUP = #076, OPEN = #050, JFCL = #255;
OWN TMP;
MACRO DEFAULT = TMP<LEFT>$,
%[722]% NOLST = TMP<0,1>$,
%[722]% NOCRF = TMP<1,1>$;
EXTERNAL SAVFLG;
MACRO PROJNUM = DIRECTORY(ICL)<LEFT>$,
PROGNUM = DIRECTORY(ICL)<RIGHT>$,
ERRORR(X) = RETURN FATLEX(X<0,0>)$;
FORWARD
PPN,PPNUM,SCANFIL,FILSP,SWITCH;
ROUTINE FILSP =
BEGIN IF NOT FTTENEX THEN BEGIN
REGISTER R;
%GET DEVICE OR FILE NAME%
WHILE 1 DO
BEGIN
EXTERNAL E122;
IF (R_SCANFIL()) EQL 0 THEN RETURN 0;
LOOK4CHAR _ ":";
IF LEXICAL(.GSTCSCAN) EQL 0
THEN
BEGIN %FILE NAME%
EXITLOOP
END
ELSE
BEGIN %DEVICE NAME%
IF .DEVICE(ICL) NEQ 0
THEN RETURN FATLEX( SIXBIT'DEVICE', E122<0,0>);
DEVICE(ICL) _ .R
END
END %LOOP% ;
%STORE FILE NAME%
IF .FILENAME(ICL) NEQ 0
THEN RETURN FATLEX( SIXBIT'FILE', E122<0,0>);
FILENAME(ICL) _ .R;
LOOK4CHAR _ ".";
IF LEXICAL(.GSTCSCAN) EQL 0
THEN
BEGIN
%DEFAULT%
DEFAULT _ 1;
(FILENAME(ICL)+1) _ SIXBIT'FOR';
END
ELSE
BEGIN
DEFAULT _ 0;
(FILENAME(ICL)+1) _ SCANFIL()
END;
RETURN 1
END END;
ROUTINE PPN =
BEGIN IF NOT FTTENEX THEN BEGIN %PICK UP THE PPN%
LOOK4CHAR _ "[";
IF LEXICAL (.GSTCSCAN) EQL 0
THEN ( DIRECTORY(ICL) _ 0;
RETURN 0 !NONE
);
IF (PROJNUM _ PPNUM() ) EQL 0
THEN RETURN -1; !ERROR
LOOK4CHAR _ ",";
IF LEXICAL(.GSTCSCAN) EQL 0
THEN RETURN -1; !ERROR
IF ( PROGNUM _ PPNUM() ) EQL 0
THEN RETURN -1; !ERROR
LOOK4CHAR _ "]";
IF LEXICAL(.GSTCSCAN) EQL 0
THEN RETURN -1; !ERROR
RETURN 1 !GOT ONE
END END;
ROUTINE PPNUM =
BEGIN IF NOT FTTENEX THEN BEGIN %GET PPN%
REGISTER NUM,C;
NUM _ 0;
LOOK4CHAR _ "?D";
UNTIL ( C _ LEXICAL(.GSTCSCAN) ) EQL 0
DO NUM _ .NUM*8 + .C -"0";
RETURN .NUM
END END;
ROUTINE SCANFIL =
BEGIN IF NOT FTTENEX THEN BEGIN
%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 END;
ROUTINE SWITCH =
BEGIN IF NOT FTTENEX THEN BEGIN
![722] REWRITE SWITCH PROCESSING TO ALLOW /NOCREF ON INCLUDE STATEMENT
%[722]% % GET /NOLIST OR /NOCREF OR BOTH %
%[722]% LOOK4CHAR_"/";
%[722]%
%[722]% IF LEXICAL(.GSTCSCAN) EQL 0 THEN RETURN 0;
%[722]% DO
%[722]% BEGIN
%[722]%
%[722]% LOOK4CHAR_PLIT'NOLIST'<36,7>;
%[722]% IF LEXICAL(.GSTSSCAN) NEQ 0
%[722]% THEN NOLST_1 !FOUND /NOLIST
%[722]% ELSE !TRY NOCREF
%[722]% BEGIN
%[722]% LOOK4CHAR_PLIT'NOCREF'<36,7>;
%[722]% IF LEXICAL(.GSTSSCAN) NEQ 0
%[722]% THEN NOCRF_1 !FOUND /NOCREF
%[722]% ELSE RETURN -1 !ERROR
%[722]% END;
%[722]% LOOK4CHAR_"/"
%[722]% END UNTIL LEXICAL(.GSTCSCAN) EQL 0;
%[722]%
%[722]% RETURN 1;
END END;
%LETS DO IT%
IF .FLGREG<ININCLUD> THEN RETURN FATLEX(E120<0,0>);
IF NOT FTTENEX THEN
BEGIN
FILENAME(ICL) _ 0;
TMP _ 0;
DIRECTORY(ICL) _ 0;
DEVICE(ICL) _ 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
IF .FILENAME(ICL) EQL 0 OR .DEVICE(ICL) EQL 0
THEN IF FILSP() EQL 1
THEN LEAVE LOOP !FOUND ONE
ELSE IF .VREG LSS 0
THEN RETURN .VREG;
IF .DIRECTORY(ICL) EQL 0
THEN IF PPN() EQL 1
THEN LEAVE LOOP
ELSE IF .VREG LSS 0
THEN ERRORR(E117);
IF SWITCH() 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%
IF .DEVICE(ICL) EQL 0
THEN DEVICE(ICL) _ SIXBIT'DSK';
BEGIN %MAKE SURE THAT THE DEVICE IS A DISK%
MACHOP DEVCHR = #047;
EXTERNAL E124;
VREG _ .DEVICE(ICL);
DEVCHR ( VREG,4);
IF NOT .VREG<34,1> %DISK DEVICE%
THEN RETURN FATLERR(.ISN,E124<0,0>)
END;
IF .FILENAME(ICL) EQL 0
THEN ERRORR(E118); !NO FILE NAME
STATUS(ICL) _ 0; !ASCII
BUFFERS(ICL) _ BUFHDR(ICL)<0,0>;
OPEN (ICL, STATUS(ICL));
JFCL(0,0);
LOK:BEGIN
WHILE 1 DO
BEGIN
VREG _ -1;
LOOKUP(ICL,FILENAME(ICL));
VREG _ 0; !FILE NOT FOUND
IF .VREG NEQ 0 THEN LEAVE LOK; !OK FOUND THE FILE
%TRY WITHOUT .FOR %
IF .DEFAULT NEQ 0
THEN
BEGIN
EXTENSION(ICL) _ 0;
DEFAULT _ 0
END
ELSE ERRORR(E119)
END %WHILE 1%
END %LOK%
END;
END
ELSE
BEGIN %FTTENEX%
EXTERNAL OPNICL,E138;
GLOBAL ICLPTR; !FILESPEC POINTER
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
VAL _ OPNICL(); !OPEN THE FILE
IF .VAL NEQ 0 !WAS THERE AN ERROR
THEN RETURN FATLERR(.VAL,.ISN,E138<0,0>);
%MESSAGE POINTER GIVEN IN VREG%
![722] REWRITE SO THAT /NOCREF ALLOWED ON INCLUDE STATEMENT
%[722]% % OK, GOT IT, NOW LOOK FOR /NOLIST OR /NOCREF %
%[722]%
%[722]% NOLST_0;
%[722]% NOCRF_0;
%[722]%
%[722]% WHILE ..ICLPTR EQL "/"
%[722]% DO
%[722]% BEGIN
%[722]% % SEE WHAT THE SWITCH IS %
%[722]%
%[722]% LABEL CHKLST;
%[722]% LOCAL PNT,SAVICL;
%[755]% REGISTER CHAR;
%[755]% MACRO UPLOW(L) = %( CONVERT LOWER CASE TO UPPER )%
%[755]% BEGIN
%[755]% VREG=L;
%[755]% IF .VREG GEQ #141 %( LOWER CASE A )% AND
%[755]% .VREG LEQ #172 %( LOWER CASE Z )%
%[755]% THEN VREG=.VREG-#40; %( UPPER CASE )%
%[755]% .VREG
%[755]% END$;
%[722]%
%[722]% %TRY /NOLIST %
%[722]% VAL_0; !NOLST NOT FOUND YET ON THIS PASS
%[722]% PNT_(PLIT'NOLIST')<36,7>;
%[722]% SAVICL_.ICLPTR;
%[722]% CHKLST: BEGIN
%[755]% UNTIL (CHAR_SCANI(PNT)) EQL 0
%[755]% DO IF .CHAR NEQ UPLOW(SCANI(ICLPTR))
%[722]% THEN LEAVE CHKLST;
%[722]% NOLST_1; VAL_1; !WE FOUND /NOLIST
%[722]% SCANI(ICLPTR); !BUMP POINTER
%[722]% END;
%[722]%
%[722]% IF .VAL EQL 0 THEN !TRY FOR /NOCREF
%[722]% BEGIN
%[722]% ICLPTR_.SAVICL; !BACK UP THE POINTER
%[722]% PNT_(PLIT'NOCREF')<36,7>;
%[722]%
%[755]% UNTIL (CHAR_SCANI(PNT)) EQL 0
%[722]% DO
%[722]% BEGIN
%[755]% IF .CHAR NEQ UPLOW(SCANI(ICLPTR))
%[722]% THEN ( EXTERNAL CLOICL;
%[722]% FATLEX(E116<0,0>);!BAD SWITCH
%[722]% CLOICL();
%[722]% RETURN )
%[722]% END;
%[722]% NOCRF_1; !WE FOUND /NOCREF
%[722]% SCANI(ICLPTR)
%[722]% END;
%[722]% END;
%FREE UP THE LITERAL%
SAVSPACE( .LIT[LITSIZ]+2 , @LIT );
LITPOINTER _ .LITPNTSAV;
IF .LITPOINTER<RIGHT> NEQ 0 THEN (@LITPOINTER)<RIGHT> _ 0;
END; %FTTENEX%
%OK WE GOT THE FILE%
%SAVE THE CURRENT BUFFERS%
LEXICAL (.GSTEOP); !TERMINATE CURRENT STATEMENT
EOPSVPOOL();
%SAVE THE INFO%
BEGIN
GLOBAL SVINCL[8];
EXTERNAL LINENO;
EXTERNAL EOPSAVE,CURPOOLEND,CURPTR,STLPTR,STPTR,LINEPTR,SEQLAST,LINELINE,CHARPOS;
SVINCL[0] _ .EOPSAVE;
SVINCL[1] _ .CURPOOLEND;
SVINCL[2] _ .CURPTR;
SVINCL[3] _ .STLPTR;
SVINCL[4] _ .STPTR;
SVINCL[5] _ .LINEPTR;
IF .SEQLAST NEQ 0
THEN SVINCL[6] _ .LINELINE !LINESEQUENCE NUMBER
ELSE SVINCL[6] _ 0;
SVINCL[7] _ .CHARPOS;
IF .CHARPOS NEQ 72
THEN LINELINE _ .LINELINE+1; !MULTIPLE STATEMENTS ON LINE
SAVFLG _ .FLGREG<0,36>;
FLGREG<ININCLUD> _ 1;
FLGREG<EOCS> _ 1;
![722] HANDLE NO CREFFING TOO
%[722]% IF .NOCRF THEN FLGREG<CROSSREF> _ 0;
IF .NOLST THEN FLGREG<LISTING> _ 0;
SVFLG2 _ .FLAGS2;
FLAGS2<TTYINPUT> _ 0;
%SET LINENO[1] SO THAT AN * WILL APPEAR NEXT TO THE
INCLUDED CODES LINE NUMBER %
LINENO[1] _ '* ';
CURPOOLEND _ POOL<0,0>;
IF EOPRESTORE() EQL EOF
THEN
BEGIN
EXTERNAL POSTINCL;
POSTINCL(); !RESTORE
END
END
END;
GLOBAL ROUTINE
POSTINCL =
BEGIN
%RESTORE THE WORLD AFTER AN INCLUDED FILE %
EXTERNAL SVINCL[8];
EXTERNAL EOPSAVE,CURPOOLEND,CURPTR,STLPTR,STPTR,LINEPTR,SEQLAST,LINELINE;
EXTERNAL EOPRESTORE,SVFLG2;
EXTERNAL LINENO;
EXTERNAL SAVFLG,GSTEOP,LEXICAL,CHARPOS;
MACHOP CLOSE = #070;
% CLEAN UP LAST LINE%
LEXICAL(.GSTEOP);
IF NOT FTTENEX
THEN
CLOSE (ICL,0) !CLOSE THE FILE
ELSE
( EXTERNAL CLOICL;
CLOICL();
);
EOPSAVE _ .SVINCL[0];
CURPOOLEND _ .SVINCL[1];
CURPTR _ .SVINCL[2];
STLPTR _ .SVINCL[3];
STPTR _ .SVINCL[4];
LINEPTR _ .SVINCL[5];
IF .SVINCL[6] NEQ 0
THEN LINELINE _ .SVINCL[6]; !LINESEQUENCE NUMBER
CHARPOS _ .SVINCL[7];
SEQLAST _ 1; !SO NO ONE WILL MESS WITH THE LINELINE
LINENO[1] _ ' '; !RESET LINENO TO TAB
!KEEP VALUES OF SOME FLAGS WHICH MAY HAVE CHANGED
! DURING PROCESSING OF THE INCLUDE FILE, AND WHOSE NEW
! VALUES WE REALLY WANT TO KEEP!
SAVFLG<BTTMSTFL> _ .FLGREG<BTTMSTFL>; !IF 16 CLOBBERED
SAVFLG<WARNGERR> _ .FLGREG<WARNGERR>; !WARNINGS GIVEN
SAVFLG<FATALERR> _ .FLGREG<FATALERR>; !FATAL ERRORS GIVEN
SAVFLG<LABLDUM> _ .FLGREG<LABLDUM>; !LABELS PASSED AS ARGS
FLGREG<0,36> _ .SAVFLG;
FLAGS2 _ .SVFLG2;
EOPRESTORE(); !RESTORE THE BUFFERS
END;
GLOBAL ROUTINE
ASTER (TYPE) =
BEGIN
% THIS ROUTINE WILL SCAN FOR THE *DIGIT CONSTRUCT FOLLOWING THE
DATA TYPE NAME IN TYPE OR IMPLICIT OR FUNCTION STATEMENTS.
THE PARAMETER TYPE IS BASED UPON THE DATA TYPE NAME.
THIS ROUTINE WILL RETURN AS ITS VALUE:
1. THE AMMENDED TYPE IF A VALID * CONSTRUCT WAS FOUND
2. TYPE IF NO * CONSTRUCT WAS FOUND
3. -1 IF THERE WAS SOME ERROR IN THE * CONSTRUCT
%
EXTERNAL LSAVE,LEXL;
MACRO ERR50(X) = FATLEX( .TYPDIG, X<0,0>, E50<0,0> ) $,
ERR24(X) = WARNLEX ( X<0,0>, .TYPDIG, E24<0,0> ) $;
REGISTER TYPDIG,D;
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 * %
LOOK4CHAR _ "?D"; ! ANY DIGIT
IF ( D _ LEXICAL ( .GSTCSCAN )) EQL 0 THEN D _ SIXBIT" " + " ";
%THIS WILL CAUSE AN ERROR%
% GET AS MANY DIGITS AS THERE ARE %
TYPDIG _ 0;
DO TYPDIG _ .TYPDIG^6 + .D-" " ! KEEP IN SIXBIT FOR POSSIBLE ERROR OUTPUT
UNTIL( D _ LEXICAL ( .GSTCSCAN )) EQL 0 ;
RETURN (
% DO THIS ON THE BASIS OF ACTLDATYPE IN ORDER TO ALLOW
REAL*8 X*4 AND EXCLUDE DOUBLEPRECISION X*4 %
SELECT .ACTLDATYPE OF NSET
INTEGER:( IF .TYPDIG EQL SIXBIT"2"
THEN (ERR24(INTGPLIT); .ACTLDATYPE )
ELSE IF .TYPDIG EQL SIXBIT"4"
THEN .ACTLDATYPE
ELSE ERR50( INTGPLIT)
);
REAL: ( IF .TYPDIG EQL SIXBIT"4"
THEN .ACTLDATYPE
ELSE IF .TYPDIG EQL SIXBIT"8"
THEN DOUBLPREC
ELSE ERR50( REALPLIT)
);
COMPLEX:( IF .TYPDIG EQL SIXBIT"8"
THEN .ACTLDATYPE
ELSE IF .TYPDIG EQL SIXBIT"16"
THEN ( ERR24(COMPLIT); .ACTLDATYPE )
ELSE ERR50 ( COMPLIT)
);
LOGICAL:( IF .TYPDIG EQL SIXBIT"4"
THEN .ACTLDATYPE
ELSE IF .TYPDIG EQL SIXBIT"1"
THEN ( ERR24(LOGIPLIT); .ACTLDATYPE )
ELSE ERR50 ( LOGIPLIT )
);
DOUBLPREC:( ERR50 ( DOUBPLIT ) )
TESN )
END; % ROUTINE ASTER %
GLOBAL ROUTINE
TYPDECLARE ( DTYPE ) = !CALLED BY INTESTA,REALSTA,DOUBST
!COMPST,LOGIST STATATEMENT ROUTINES
!TO HANDLE THE CHECKING
!THE DIFFERENCE BETWEEN A FUNCTIONDECLARATION AND A IMPLE TYPE DECLARATION
BEGIN
EXTERNAL LSAVE;
EXTERNAL FUNCGEN,TYPEGEN,SAVSPACE,TYPE,STK;
EXTERNAL PST1ST,PSTATE,PSTIMPL,PSTSPF,ENDSTA;
REGISTER BASE T1;
ACTLDATYPE _ .DTYPE; !SAVE ACTUAL TYPE IDENTIFIER CODE
% PICK UP THE *N CONSTRUCT IF ANY %
LSAVE _ 0; !DIFFERENTIATES BETWEEN THIS AND THE OVERRIDE CALLS
IF ( IDTYPE _ ASTER ( .DTYPE )) LSS 0 THEN RETURN .VREG;
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;
FUNCGEN(@.T1[ELMNT1])
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 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;
FUNCGEN(.T1[ELMNT]);SAVSPACE(0,@STK[0]);
.VREG
END;
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;
FUNCGEN(.T1[ELMNT]);SAVSPACE(0,@STK[0]);
.VREG
END;
GLOBAL ROUTINE ENTRSTA=
BEGIN
EXTERNAL NAMDEF;
EXTERNAL STK,FUNCGEN %()%,SAVSPACE %(SIZE,LOC)%,TYPE,LASDOLABEL ;
REGISTER BASE T1;
IF .LASDOLABEL NEQ 0 THEN FATLEX(E75<0,0>); !ENTRY ILLEGAL INSIDE A DO LOOP
IF .FLGREG<PROGTYP> EQL MAPROG THEN RETURN FATLEX(E114<0,0>); !ENTRY ILLEGAL IN MAIN PROGRAM
!SEMANTIC ANALYSIS BEGINS
FLGREG<MULTENT> _ 1; ! SET ENTRIES IN SUBROUTINE FLAG
T1_.STK[0];
%EQUIVALENCE FUNCTION AND ITS ENTRY NAMES%
IF .FLGREG<PROGTYP> EQL FNPROG
THEN
BEGIN
%WE WILL PRETEND THAT WE ARE THE SYNTAX ANALYZER AND
GENERATE AN EQUIVALENCE SYNTAX TREE AND THEN
GIVE IT TO EQUISTA FOR DISPOSITION %
EXTERNAL NAME,ENTRY,TBLSEARCH,CORMAN,STK,EQUISTA;
REGISTER BASE TREE;
NAME<LEFT> _ 9; !GET SOME SPACE
STK[0] _ TREE _ CORMAN(); !ALL NODE
(.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] _ ( ENTRY _ .PROGNAME;
NAME _ IDTAB;
TBLSEARCH() ); !FUNCTION NAME
(.TREE)[4]<LEFT> _ IDENTIFIER;
(.TREE)[5] _ 0; !OPTION
(.TREE)[6] _ 1^18 + .TREE+7; !ALL POINTER
(.TREE)[7] _ @.T1[ELMNT]; !ENTRY NAME
(.TREE)[8] _ 0; !OPTION
%NOW PROCESS IT%
IF EQUISTA() LSS 0 THEN RETURN .VREG
END;
IDTYPE_-1;
TYPE_1;
FUNCGEN(.T1[ELMNT]);SAVSPACE(0,@T1);
.VREG
END;
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;
GLOBAL ROUTINE
PARASTA =
BEGIN
% PROCESS THE PARAMETER STATEMENT %
! STK[0] CONTAINS APOINTER TO A LIST POINTER
! EACH LIST COMPONENT IS AN ALL POINTER TO
! A 3 ELEMENT BLOCK OF IDENTIFIER - OPTION - CONSTLEX/LITSTRING
EXTERNAL SAVSPACE,NAMDEF;
REGISTER BASE T2:R2:R1;
LOCAL BASE T1:POSCON;
T1 _ @(@STK[0]); !LIST POINTER
SAVSPACE ( 0, @STK[0] ); !SAVE THE LIST POINTER
!PROCESS THE LIST OF ID = CONST
INCR PRMLST FROM @T1 TO @T1 + .T1<LEFT>
DO
BEGIN
MAP BASE PRMLST;
T2 _ .PRMLST[ELMNT]; !ALL POINTER
R2 _ .T2[ELMNT]; !IDENTIFIER
%RECORD THE DEFINTION%
IF NAMDEF ( PARADEF, .R2 ) LSS 0 THEN RETURN .VREG;
R2[IDATTRIBUT(PARAMT)] _ -1;
IF .T2[ELMNT1] EQL 1
THEN
BEGIN %CONSTANT%
R1 _ .T2[ELMNT2]; !POINTER TO (+/-)CONSTLEX
CASE .R1[ELMNT] OF SET
%NO SIGN% BEGIN
R2[IDPARAVAL] _ .R1[ELMNT1]
END;
% + % BEGIN
R2[IDPARAVAL] _ .R1[ELMNT2]
END;
% - % BEGIN
POSCON _ .R1[ELMNT2];
R2[IDPARAVAL] _ ( NEGCNST( POSCON )
AND #777777 ) + CONSTLEX^18
END
TES;
SAVSPACE ( .R1<LEFT> , @R1 )
END
ELSE
BEGIN
R2[IDPARAVAL] _ .T2[ELMNT2]; !LITSTRING
END;
SAVSPACE ( .T2<LEFT>, @T2 )
END;
SAVSPACE ( .T1<LEFT>, @T1)
END; %PARASTA%
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;
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;
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 !IT'S OK
R2_BLKSRCH(SIXBIT '.COMM.')
ELSE !SOMEONE FORGOT A COMMA
FATLEX(PLIT ', OR /',PLIT 'IDENTIFIER',E0<0,0>)
END
ELSE !SLASHS SEEN GET BLOCK NAME IF THERE
BEGIN
T1_.R1[ELMNT1];
IF .T1[ELMNT1] EQL 0 THEN R2_BLKSRCH(SIXBIT '.COMM.')
ELSE
BEGIN
T2_.T1[ELMNT2];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]);
END;
R1_.R1+1; !INCR PTR IF SLASHES FOR CALL TO BLDARRAY COMING UP
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
R1[IDCOMMON] _ .R2 !PUTTING PTR TO BLOCK IN EACH ITEM
WHILE (R1 _ .R1[IDCOLINK]) NEQ 0;
END %OF FIXING UP COMMON POINTERS%
END;T1_.STK[1];SAVSPACE(.T1<LEFT>,@T1);
.VREG
END;
END
ELUDOM