Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_V7wLink_Feb83
-
lexsup.bli
There are 12 other files named lexsup.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
! OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1973, 1983
!AUTHOR: D. B. TOLMAN/DCE/SJW/TFV/CKS/EDS/AHM
MODULE LEXSUP(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN %LEXSUP%
GLOBAL BIND LEXSUV = 7^24 + 0^18 + #1712; ! Version Date: 7-Jan-83
%(
***** Begin Revision History *****
2 ----- ----- MOVE CREFIT TO NEW MODULE UNEND IN ORDER TO
FIX ONCE AND FOR ALL THE SAVING
THE LAST GETSEG TO FORTB PROBLEM
3 ----- ----- ROUTINE BACKUP - THE CHARACTER POSITION COUNTER
CHARPOS WAS BEING DECREMENTED RATHER
THAN INCREMENTD BY 1 AS IT SHOULD HAVE BEEN
4 ----- ----- RETURN FROM LABREF WHEN LABEL TOO LARGE OR
TOO SMALL TO AVOID ADDITIONAL SPURIOUS ERROR
MESSAGES
5 ----- ----- REMOVE EDIT 4 BECAUSE WORSE THINGS HAPPEN
WHEN THE FINAL LIST OF UNDEFINED LABELS IS
COMPILED IF NOTHING IS DEFINED. LIKE INTERNAL
COMPILER ERRORS.
6 ----- ----- ENDOFLIT WAS NOT ZEROING LAST
WORD OF THE LITERAL PROPERLY
7 ----- ----- IN LABDEF - DON'T CALL DOCHECK JUST CHECK
TO SEE IF LIGIT DO TERMINATOR
DOCHECK CALLED AFTER SEMANTICS NOW
8 362 18245 SEPARATE LOGICAL AND OCTAL REPRESENTATIONS, (DCE)
9 366 18210 FIX SAVLINE CLOBBERING NAME, (DCE)
10 477 QA831 MAKE ERROR MESSAGE NAMLEX'S MORE READABLE
***** Begin Version 5A *****
11 573 ----- REQUIRE DBUGIT.REQ, (SJW)
***** Begin Version 5B *****
12 737 ----- IMPLEMENT .NEQV. OPERATOR, (DCE)
13 746 13673 ALLOW FORMAT STMNT NUMBERS TO BE ASSIGNED TO VARS,
(DCE)
***** Begin Version 6 *****
17 1100 EDS 9-Jun-81 10-31141
Build label definition entry for statement even
if the label is multiply defined or used in executable
context and gets a ENF error (E91). This will prevent
an NNF error (E70) and an undefined label error.
***** Begin Version 7 *****
14 1212 TFV 29-Apr-81 ------
Replace LITCONST with HOLLCONST
16 1221 CKS 4-Jun-81
Use LTLSIZ instead of 3 to get size of literal table node.
18 1224 CKS 12-Jun-81
Calculate LITSIZ right; use LTLSIZ to subtract off node header size
instead of magic numbers.
19 1245 TFV 3-Aug-81 ------
Fix LITDEF and ENDOFLIT to handle character/hollerith constants.
20 1243 CKS 8-Sep-81
Add // to LEXNAM plit
21 1402 CKS 23-Oct-81
Allow declaration statements to be labeled, catch in LABDEF and LABREF
15 1453 CKS 14-May-81 (formerly edit 1070)
In SAVLINE, replace @BACKLINE<LEFT> with .BACKLINE<LEFT>. Except you
have to say (.BACKLINE<LEFT>)<FULL> or BLISS blows it.
22 1470 CKS 2-Feb-82
Add tic lexeme (') to LEXNAM plit
1526 AHM 10-May-82
Make LABDEF set SNPSECT to PSCODE or PSDATA depending on
whether the label is being set on a FORMAT statement or code.
1712 AHM 7-Jan-83
Set the psect index for labels on declaration statements to
PSCODE in LABDEF so that we don't ICE from a PSOOPS when
dumping the labels (SUBROUTINE and friends can actually
produce code that gets labeled).
***** End Revision History *****
)%
EXTERNAL LINELINE,LINEPTR,CHARPOS,CLASLINE,CLASPTR,CLASLPT,CLASPOS,CURPTR,DECREMENT,BACKLINE,CREFIT;
REQUIRE DBUGIT.REQ;
REQUIRE LEXNAM.BLI;
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
% THESE BINDS ARE REQUIRED BY LEXICAL BECAUSE ITS GETTING TO
BIG TO COMPILE WITH FIRST AND TABLES %
GLOBAL BIND
GREAL = REAL,
GLOGI = LOGICAL,
GINTEGER = INTEGER,
GDOUBLPREC = DOUBLPREC,
GDUBOCT = DOUBLOCT,
GOCTAL = OCTAL;
BIND DUMM = UPLIT (
GIDTAB GLOBALLY NAMES IDTAB,
GCONTAB GLOBALLY NAMES CONTAB
);
BIND VECTOR NAMLEX=UPLIT( LEXNAME GLOBALLY NAMES
%0% UPLIT'unknown?0',
%1% UPLIT'identifier?0',
%2% UPLIT'constant?0',
%3% UPLIT'lit string?0',
%4% UPLIT'label?0',
%5% UPLIT'statement end?0',
%6% UPLIT'relational op?0',
%7% UPLIT'.NOT.?0',
%8% UPLIT'.AND.?0',
%9% UPLIT'.OR.?0',
%10% UPLIT'.EQV. or .XOR.?0',
%11% UPLIT'"**" or "^"?0',
%12% UPLIT'"&"?0',
%13% UPLIT'"("?0',
%14% UPLIT'")"?0',
%15% UPLIT'":" ?0',
%16% UPLIT'","?0',
%17% UPLIT'"$"?0',
%18% UPLIT'"-"?0',
%19% UPLIT'"/"?0',
%20% UPLIT'"+"?0',
%21% UPLIT'"*"?0',
%22% UPLIT'"="?0',
%23% UPLIT'"//"?0', ! [1243]
%24% UPLIT'"''"?0' ! [1470]
);
! MACROS WHICH DEFINE THE RELATIONAL LEXEME CODES
MACRO
REL(N) = RELATIONLOP^18+N$,
DOTNE = REL(6)$,
DOTEQ = REL(2)$,
DOTGT = REL(7)$,
DOTLT = REL(1)$,
DOTGE = REL(5)$,
DOTLE = REL(3)$;
BIND DUMMIE = UPLIT (
% THIS IS A TABLE USED TO SCAN FOR AND IDENTIFY THE "."ED OPERATORS %
NDOTOP GLOBALLY NAMES 'EQV', LOGICALMATCH^18+2, ![737]
'E', DOTNE,
'OT', LOGICALNOT^18,
0,
'.NE. OR .NOT. OR .NEQV.?0', ![737]
ADOTOP GLOBALLY NAMES 'ND', LOGICALAND^18,
0,
'.AND.?0',
ODOTOP GLOBALLY NAMES 'R', LOGICALOR^18,
0,
'.OR.?0',
XDOTOP GLOBALLY NAMES 'OR', LOGICALMATCH^18+2,
0,
'.XOR.?0',
EDOTOP GLOBALLY NAMES 'QV', LOGICALMATCH^18+1,
'Q', DOTEQ,
0,
'.EQ. OR .EQV.?0',
GDOTOP GLOBALLY NAMES 'T', DOTGT,
'E', DOTGE,
0,
'.GT. OR .GE.?0',
LDOTOP GLOBALLY NAMES 'T', DOTLT,
'E', DOTLE,
0,
'.LT. OR .LE.?0',
TDOTOP GLOBALLY NAMES 'RUE', -2,
0,
'.TRUE.?0',
FDOTOP GLOBALLY NAMES 'ALSE', -1,
0,
'.FALSE.?0'
);
BIND DUMDUM = UPLIT ( DOTOPTAB GLOBALLY NAMES
% THIS TABLE GIVES A POINTER TO THE VALID CHARACTER STRINGS
WHICH COULD FOLLOW THE FIRST LETTER OF A DOTTED OPERATOR%
%A% ADOTOP<36,7>,
%B% 0,
%C% 0,
%D% 0,
%E% EDOTOP<36,7>,
%F% FDOTOP<36,7>,
%G% GDOTOP<36,7>,
%H% 0,
%I% 0,
%J% 0,
%K% 0,
%L% LDOTOP<36,7>,
%M% 0,
%N% NDOTOP<36,7>,
%O% ODOTOP<36,7>,
%P% 0,
%Q% 0,
%R% 0,
%S% 0,
%T% TDOTOP<36,7>,
%U% 0,
%V% 0,
%W% 0,
%X% XDOTOP<36,7>,
%Y%0,
%Z% 0
);
GLOBAL ROUTINE
BACKPRINT =
BEGIN
LOCAL TLINE,TCUR,TPTR,ADJUST;
EXTERNAL LINELINE,CURPTR,LINEPTR,BACKLINE,NOCR,PRINT,CLASLPT;
% THIS ROUTINE IS CALLED IF A LINE TERMINATOR WAS ENCOUNTERED
DURING SOME LOOKAHEAD AND NO BACKUP WAS REQUIRED %
% SAVE CURRENT LINE ATTRIBUTES %
TLINE_ .LINELINE;
TCUR _ .CURPTR;
TPTR _ .LINEPTR;
ADJUST _ @(@BACKLINE<RIGHT>+3) - .CLASLPT; ! CHECK TO SEE IF BUFFER WAS MOVED
% PRINT THOSE LINES THAT WERE MISSED %
DO
BEGIN
LINELINE _ @(@BACKLINE<RIGHT>+1) - .ADJUST;
CURPTR _ @(@BACKLINE<RIGHT>+2) - .ADJUST;
LINEPTR _ @(@BACKLINE<RIGHT> + 3) - .ADJUST;
NOCR _ 1;
PRINT();
END
UNTIL ( BACKLINE<RIGHT> _ @(@BACKLINE<RIGHT>)) EQL 0;
BACKLINE _ 0;
LINELINE _ .TLINE;
CURPTR _ .TCUR;
LINEPTR _ .TPTR;
END;
GLOBAL ROUTINE
SAVLINE =
BEGIN
LOCAL ADDR;
LOCAL NAMESAVE;
EXTERNAL NAME,CORMAN,LINELINE,CURPTR,LINEPTR,BACKLINE;
% THIS LINE IS BEING PASSED OVER DURING A LOOKAHEAD WITHOUT PRINTING
IF NO BACKUP IS NEEDED THEN THIS LINE WILL HAVE TO BE PRINTED %
% SAVE THE LINE ATTRIBUTES %
NAMESAVE_.NAME;
NAME<LEFT> _ 4;
ADDR _ CORMAN();
NAME_.NAMESAVE;
(@ADDR)<FULL> _ 0; ! LINK
((@ADDR)+1)<FULL> _ .LINELINE;
((@ADDR)+2)<FULL> _ .CURPTR ;
((@ADDR)+3)<FULL> _ .LINEPTR ;
IF .BACKLINE EQL 0
THEN
BEGIN
BACKLINE<LEFT> _ @ADDR;
BACKLINE<RIGHT> _ @ADDR;
END
ELSE
BEGIN
%1453% (.BACKLINE<LEFT>)<FULL> _ @ADDR;
BACKLINE<LEFT> _ @ADDR
END
END;
GLOBAL ROUTINE
BAKSAV =
BEGIN
% SAVE THE CURRENT POSITION FOR POSSIBLE BACKUP %
EXTERNAL CLASPTR,CLASLINE,CLASPOS,CLASLPT,CHARPOS;
CLASPTR _ .CURPTR;
CLASLINE _ .LINELINE;
CLASPOS _ .CHARPOS;
CLASLPT _ .LINEPTR;
END;
GLOBAL ROUTINE
BACKUP =
BEGIN
% BACKUP TO JUST BEFORE THE SAVED CHARACTER POSITION %
CURPTR _ .CLASPTR;
DECREMENT ( CURPTR<0,0> );
LINELINE _ .CLASLINE;
CHARPOS _ .CLASPOS + 1;
LINEPTR _ .CLASLPT;
BACKLINE _ 0;
END;
GLOBAL ROUTINE LITDEF ( CHARS , TYPE) =
BEGIN
% MAKE A LITERAL TABLE ENTRY FOR .CHARS CHARACTERS %
LOCAL WDS;
LOCAL PEXPRNODE LITENTRY;
EXTERNAL NAME,NEWENTRY;
WDS _ ( .CHARS -1 ) /5 + 2;
%1221% NAME<LEFT> _ ( IF .WDS LEQ 2 THEN 2 ELSE .WDS ) + LTLSIZ;
NAME<RIGHT> _ LITTAB;
LITENTRY _ NEWENTRY();
LITENTRY[LITSIZ] _ .WDS;
%1245% LITENTRY[LITLEN] _ .CHARS; ! Set up length for character constant
%1245% ! Set operator field to HOLLCONST or CHARCONST
%1245% IF .TYPE EQL HOLLDEF
%1245% THEN LITENTRY[OPERATOR] _ HOLLCONST
%1245% ELSE LITENTRY[OPERATOR] _ CHARCONST;
LITENTRY[LITEXWDFLG] _ 1; ! TRAILING NULL FLAG
RETURN .LITENTRY
END; ! LITDEF
GLOBAL ROUTINE ENDOFLIT ( POINT, LITENTRY, LASTWORD , CHARS) =
BEGIN
% CLEAN UP THE LITERAL ENTRY AND RETURN ANY UNUSED STORAGE %
% POINT < RIGHT> IS ADDRESS OF ZERO WORD TERMINATOR
ZERO THE WORD, CALCULATE THE LENGTH OF THE LITERAL, SET
THE SIZE, AND RETURN UNUSED PORTION TO FREE STORAGE %
MAP PEXPRNODE LITENTRY;
EXTERNAL SAVSPACE;
LOCAL WDS;
(.POINT<RIGHT>+1)<FULL> _ 0; ! ZERO LAST WORD
LITENTRY[LITSIZ] _ .POINT - .LITENTRY + 2 - LTLSIZ;
%1245% LITENTRY[LITLEN] _ .CHARS; ! Set up length for character constant
SAVSPACE ( .LASTWORD - .POINT - 1 , .POINT+2 );
END; ! ENDOFLIT
GLOBAL ROUTINE LABDEF=
BEGIN
% MAKE A STATEMENT LABEL DEFINITION ENTRY %
%1402% ! For error messages
%1402% BIND VECTOR IOEXPLIT = UPLIT (UPLIT ' FORMAT?0', UPLIT 'n executable statement?0');
REGISTER T1,T2;
EXTERNAL LABLOFSTATEMENT,TBLSEARCH,STALABL,NAME,ENTRY,FATLERR,STMNDESC,GFORMAT,ISN;
EXTERNAL E171;
MAP BASE T1:T2;
BIND LABDF = 3; !CREFIT PARAMETER
IF .FLGREG<CROSSREF> THEN CREFIT( .STALABL, LABDF);
% MAKE THE ENTRY %
NAME _ LABTAB;
ENTRY[0] _ .STALABL;
T1 _ TBLSEARCH();
IF ( T2 _ .T1[SNHDR] ) NEQ 0
THEN
BEGIN % MULTIPLY DEFINED %
FATLERR ( .T2[SRCISN], .T1[SNUMBER], .ISN,E20<0,0>);
%[1100]% LABLOFSTATEMENT _ .T1;
END
ELSE
BEGIN % CHECK FORMAT VS EXECUTABLE VS DECLARATION %
EXTERNAL GFORMAT,GILLEGAL,DOCHECK;
IF .ORDERCODE(@STMNDESC) EQL GFORMAT<0,0>
THEN
BEGIN % FORMAT STATEMENT LABEL %
IF .T1[SNEXECU]
THEN FATLERR(.STALABL,.ISN,E91<0,0>)
%[1100]% ELSE T1[SNIO] _ 1;
%[1100]% LABLOFSTATEMENT _ .T1;
%1526% T1[SNPSECT] = PSDATA; ! FORMATs live in the lowseg
END
ELSE
%1402% IF .LABOK(@STMNDESC) EQL GILLEGAL<0,0>
%1402% THEN
%1402% BEGIN % DECLARATION STATEMENT %
%1402% IF .T1[SNEXECU] OR .T1[SNIO]
%1402% THEN FATLERR(.IOEXPLIT[.T1[SNEXECU]],.STALABL,
%1402% .ISN,E171<0,0>);
%1402% T1[SNDECL] _ 1;
%1712% T1[SNPSECT] = PSCODE; ! Declarations can generate
%1712% ! code in the hiseg
%1402% LABLOFSTATEMENT _ .T1;
%1402% END
%1402% ELSE
BEGIN % EXECUTABLE STATEMENT %
IF .T1[SNIO]
THEN
BEGIN
FATLERR( .STALABL,.ISN,E113<0,0> );
%[1100]% LABLOFSTATEMENT _ .T1;
END
ELSE
BEGIN
EXTERNAL FATLEX,E67;
T1[SNEXECU] _ 1;
LABLOFSTATEMENT _ .T1 ;
% DO NEST CHECKING %
IF .T1[SNDOLVL] NEQ 0
THEN % CHECK FOR RATIONAL DOLOOP TERMINATION STATEMENT %
IF .BADOTERM( @STMNDESC ) THEN FATLEX(E67<0,0>);
%1526% T1[SNPSECT] = PSCODE; ! Statements live in
%1526% ! the hiseg
END
END;
END
END; %LABDEF%
GLOBAL ROUTINE LABREF=
BEGIN
GLOBAL NONIOINIO; ! IF SET IT INDICATES THAT THE LABEL IS OK EVEN THOUGH ITS AN
! EXECUTABLE LABEL IN AN IO STATEMENT
% THIS ROUTINE HANDLES LABEL REFERENCES %
% THE LABEL IS IN ENTRY[1] , IN DECIMAL %
EXTERNAL FATLEX,LEXLINE,NAME,ENTRY,TBLSEARCH,GIOCODE,STMNDESC,LOOK4LABEL;
EXTERNAL E172;
REGISTER T1,T2;
MAP BASE T1;
BIND LABRF = 4; !CREFIT PARAMETER
LOOK4LABEL _ 0;
% CHECK FOR LEGAL LABEL %
IF .ENTRY[1] LEQ 0 OR .ENTRY[1] GTR 99999
THEN ( FATLEX(E19<0,0>); ENTRY[1] _ 0);
% ONE DOES NOT RETURN HERE ON AN ERROR BECAUSE
THEN NO LABEL IS RETURNED AND WHEN THE COMPILER
CHECKS AT THE END FOR UNDEFINED LABELS THERE
IS A BIG HOLE AND WE GO OFF THE DEEP END.
SO ITS SEEMS BEST TO SUFFER THOROUGH A FEW
UNLIKELY EXTRANEOUS MESSAGES ASSOCIATED WITH
MORE THAN ONE OCCURRANCE OF LARGE OR 0 LABELS %
IF .FLGREG<CROSSREF> THEN CREFIT( .ENTRY[1], LABRF );
ENTRY[0] _ .ENTRY[1];
NAME _ LABTAB;
T1 _ TBLSEARCH();
% CHECK LEGALITY OF REFERENCE %
%1402% IF .T1[SNDECL]
%1402% THEN FATLEX (.ENTRY[0], E172<0,0>)
%1402% ELSE
IF ( T2 _ .ORDERCODE(@STMNDESC) ) EQL GIOCODE<0,0> AND NOT .NONIOINIO
THEN
BEGIN % IN IO STATEMENT %
IF .T1[SNEXECU]
%[1100]% THEN FATLEX ( .ENTRY[0], E156<0,0> )
ELSE % OK %
T1[ SNIO ] _ 1;
END
ELSE
BEGIN % NON- IO STATEMENTS %
![746] ALLOW ASSIGN STATEMENTS TO PICK UP FORMAT STATEMENT LABELS.
![746] THIS IS IN PREPARATION FOR USING THEM IN I/O STATEMENTS FOR
![746] THE FORTRAN-77 STANDARD.
%[746]% EXTERNAL ASSISTA;
%[746]% NONIOINIO _ 0;
%[746]% ! ASSIGN STATEMENT COULD MEAN EITHER TYPE, SO JUST GET OUT...
%[746]% IF .(@STMNDESC)<RIGHT> EQL ASSISTA<0,0> THEN RETURN .T1;
%1402% IF .T1[SNIO] OR .T1[SNDECL]
%1402% THEN FATLEX ( .ENTRY[0],E157<0,0> )
ELSE %OK%
T1[ SNEXECU ] _ 1;
END;
RETURN .T1
END;
BEGIN % TRACE ROUTINES %
IF DBUGIT
THEN
BEGIN
GLOBAL ROUTINE
TRACLEX ( VALUE ) =
BEGIN
EXTERNAL STRNGOUT,ENDOFILE,LEXNAME;
OWN LEXEME;
LEXEME _ .VALUE;
IF .VALUE<LEFT> GEQ IDENTIFIER AND .VALUE<LEFT> LEQ LASTLEX
THEN
BEGIN
STRNGOUT ( .LEXNAME[.VALUE<LEFT>] );
IF .VALUE<LEFT> EQL LITSTRING
THEN
BEGIN
EXTERNAL CHAROUT;
BIND CR=#15,LF=#12;
CHAROUT(CR);CHAROUT(LF);
STRNGOUT( .VALUE<RIGHT>+3 );
CHAROUT(CR);CHAROUT(LF)
END
END
ELSE
IF .VALUE EQL ENDOFILE<0,0>
THEN STRNGOUT(UPLIT'ENDOFILE?0')
ELSE
IF .VALUE EQL ( NOT ENDOFILE<0,0>)
THEN STRNGOUT(UPLIT'NOT ENDOFILE?0')
ELSE
IF .VALUE EQL 1
THEN STRNGOUT(UPLIT'TRUE?0')
ELSE
IF .VALUE EQL 0
THEN STRNGOUT(UPLIT'FALSE?0')
ELSE STRNGOUT(UPLIT'UNKNOWN?0');
STRNGOUT ( UPLIT' RETURNED?M?J?0');
RETURN .VALUE
END; % TRACLEX%
GLOBAL ROUTINE
TRACE(STATE,CHAR,CODE,ACTION) =
BEGIN
BIND CR = 13, LF = 10;
EXTERNAL LINENO;
BIND LASTBIGCODE = 32,LASTSMALCODE=11;
EXTERNAL BIGSTATE,SMALSTATE,STBITS,STPACK;
EXTERNAL STRNGOUT,CHAROUT,DECODELINE;
LOCAL TMP;
STRNGOUT ( PLIT( 'CHAR '));
IF .CHAR LSS " " THEN CHAROUT (" ") ELSE CHAROUT(.CHAR);
CHAROUT("/");
DECODELINE (.CHAR);
STRNGOUT(LINENO<0,0>);
STRNGOUT ( PLIT('CODE '));
DECODELINE(.CODE);
STRNGOUT(LINENO<0,0>);
STRNGOUT (PLIT('ACTION '));
DECODELINE (.ACTION);
STRNGOUT(LINENO<0,0>);
STRNGOUT (PLIT('STATE '));
IF @@STATE EQL 1 % CODETYPE BIG %
THEN
BEGIN % BIGSTATE %
TMP _ ((.STATE<RIGHT> - BIGSTATE<0,0> ) /( LASTBIGCODE+1 )) * STPACK<0,0>
+ (STPACK<0,0>-(.STATE<30,6>/STBITS<0,0>)-1);
DECODELINE(.TMP);
STRNGOUT (LINENO<0,0>);
CHAROUT("B")
END
ELSE
BEGIN % SMALSTATE %
TMP _ ((.STATE<RIGHT> - SMALSTATE<0,0> ) /( LASTSMALCODE+1 )) * STPACK<0,0>
+ (STPACK<0,0>-(.STATE<30,6>/STBITS<0,0>)-1);
DECODELINE(.TMP);
STRNGOUT (LINENO<0,0>);
CHAROUT("S")
END;
CHAROUT(CR); CHAROUT (LF);
END; %ROUTINE TRACE %
END
END;
END
ELUDOM