Trailing-Edge
-
PDP-10 Archives
-
AP-D480B-SB_1978
-
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) 1973,1977 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: D. B. TOLMAN/DCE/SJW
MODULE LEXSUP(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN %LEXSUP%
GLOBAL BIND LEXSV = 5^24 + 1^18 + 11; ! VERSION DATE: 16-MAY-77
%(
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
9 366 18210 FIX SAVLINE CLOBBERING NAME
10 477 QA831 MAKE ERROR MESSAGE NAMLEX'S MORE READABLE
********** BEGIN VERSION 5A **********
11 573 ----- REQUIRE DBUGIT.REQ
)%
EXTERNAL E19,E20,E91,E113;
EXTERNAL LINELINE,LINEPTR,CHARPOS,CLASLINE,CLASPTR,CLASLPT,CLASPOS,CURPTR,DECREMENT,BACKLINE,CREFIT;
REQUIRE DBUGIT.REQ; ![573] SJW 16-MAY-77
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,
!**;[362], LEXSUP @3295, DCE, 26-MAR-76
!**;[362], MAKE LOGICAL VARIABLES DISTINCT CONSTANTS
GLOGI = LOGICAL, %[362]%
GINTEGER = INTEGER,
GDOUBLPREC = DOUBLPREC,
GDUBOCT = DOUBLOCT,
GOCTAL = OCTAL;
BIND DUMM = PLIT (
GIDTAB GLOBALLY NAMES IDTAB,
GCONTAB GLOBALLY NAMES CONTAB
);
BIND VECTOR NAMLEX=PLIT( LEXNAME GLOBALLY NAMES
%0% PLIT'UNKNOWN?0',
%1% PLIT'IDENTIFIER?0',
%2% PLIT'CONSTANT?0',
%3% PLIT'LIT STRING?0', ![477]
%4% PLIT'LABEL',
%5% PLIT'STATEMENT END?0',
%6% PLIT'RELATIONAL OP?0', ![477]
%7% PLIT'.NOT.?0',
%8% PLIT'.AND.?0',
%9% PLIT'.OR.?0',
%10% PLIT'.EQV. OR .XOR.?0',
%11% PLIT'"**" OR "^"?0',
%12% PLIT'"&"?0',
%13% PLIT'"("?0',
%14% PLIT'")"?0',
%15% PLIT'":" ?0',
%16% PLIT'","?0',
%17% PLIT'"$"?0',
%18% PLIT'"-"?0',
%19% PLIT'"/"?0',
%20% PLIT'"+"?0',
%21% PLIT'"*"?0',
%22% PLIT'"="?0',
);
! 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 = PLIT (
% THIS IS A TABLE USED TO SCAN FOR AND IDENTIFY THE "."ED OPERATORS %
NDOTOP GLOBALLY NAMES 'E', DOTNE,
'OT', LOGICALNOT^18,
0,
'.NE. OR .NOT.?0',
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 = PLIT ( 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;
!**;[366], SAVLINE @3471, DCE, 2-APR-76
LOCAL NAMESAVE; ![366]
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 %
!**;[366], SAVLINE @3477, DCE, 2-APR-76
!**;[366], SAVE AND RESTORE NAME AROUND THIS CALL
NAMESAVE_.NAME; ![366]
NAME<LEFT> _ 4;
ADDR _ CORMAN();
NAME_.NAMESAVE; ![366]
(@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
(@BACKLINE<LEFT>) _ @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 ) =
BEGIN
% MAKE A LITERAL TABLE ENTRY FOR .CHARS CHARACTERS %
LOCAL WDS;
LOCAL PEXPRNODE LITENTRY;
EXTERNAL NAME,NEWENTRY;
WDS _ ( .CHARS -1 ) /5 + 2;
NAME<LEFT> _ ( IF .WDS LEQ 2 THEN 5 ELSE 3 + .WDS );
NAME<RIGHT> _ LITTAB;
LITENTRY _ NEWENTRY();
LITENTRY[LITSIZ] _ .WDS;
LITENTRY[OPERATOR] _ LITCONST;
LITENTRY[LITEXWDFLG] _ 1; ! TRAILING NULL FLAG
RETURN .LITENTRY
END;
GLOBAL ROUTINE
ENDOFLIT ( POINT, LITENTRY, LASTWORD ) =
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 - 1;
SAVSPACE ( .LASTWORD - .POINT - 1 , .POINT+2 );
END;
GLOBAL ROUTINE
LABDEF =
BEGIN
% MAKE A STATEMENT LABEL DEFINITION ENTRY %
REGISTER T1,T2;
EXTERNAL LABLOFSTATEMENT,TBLSEARCH,STALABL,NAME,ENTRY,FATLERR,STMNDESC,GFORMAT,ISN;
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>);
END
ELSE
BEGIN % CHECK FORMAT VS EXECUTABLE %
EXTERNAL GFORMAT,DOCHECK;
IF .ORDERCODE(@STMNDESC) EQL GFORMAT<0,0>
THEN
BEGIN % FORMAT STATEMENT LABEL %
IF .T1[SNEXECU]
THEN
BEGIN % A NO NO %
FATLERR(.STALABL,.ISN,E91<0,0>);
END
ELSE ( T1[SNIO] _ 1; LABLOFSTATEMENT _ .T1 )
END
ELSE
BEGIN % EXECUTABLE STATEMENT %
IF .T1[SNIO]
THEN
BEGIN
FATLERR( .STALABL,.ISN,E113<0,0> );
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>)
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;
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 %
IF ( T2 _ .ORDERCODE(@STMNDESC) ) EQL GIOCODE<0,0> AND NOT .NONIOINIO
THEN
BEGIN % IN IO STATEMENT %
IF .T1[ SNEXECU ]
THEN FATLEX ( .ENTRY[0], E113<0,0> )
ELSE % OK %
T1[ SNIO ] _ 1;
END
ELSE
BEGIN % NON- IO STATEMENTS %
IF .T1[ SNIO ]
THEN FATLEX ( .ENTRY[0],E91<0,0> )
ELSE %OK%
T1[ SNEXECU ] _ 1;
NONIOINIO _ 0;
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(PLIT'ENDOFILE?0')
ELSE
IF .VALUE EQL ( NOT ENDOFILE<0,0>)
THEN STRNGOUT(PLIT'NOT ENDOFILE?0')
ELSE
IF .VALUE EQL 1
THEN STRNGOUT(PLIT'TRUE?0')
ELSE
IF .VALUE EQL 0
THEN STRNGOUT(PLIT'FALSE?0')
ELSE STRNGOUT(PLIT'UNKNOWN?0');
STRNGOUT ( PLIT' 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