Trailing-Edge
-
PDP-10 Archives
-
BB-4157E-BM
-
fortran-compiler/act0.bli
There are 12 other files named act0.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/TFV/EGM/AHM
MODULE ACT0(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
REQUIRE ASHELP.BLI;
GLOBAL BIND ACT0V = 6^24+0^18+61; ! Version Date: 25-Sep-81
%(
***** 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 '
***** End Revision History *****
)%
FORWARD
FUNCTIONSCAN, !
TYPEID, !
TOQUOTE, !
RECORDMARK, !
EXPRLIST, !
IMPLICITSPEC,
LABELS,
TMPGN,
SUBLOCAL,
ASTERTYPE,
PNAMSET;
GLOBAL ROUTINE
ASTERTYPE =
BEGIN %HANDLES THE *N TYPE OVERRIDE CONSTRUCT%
EXTERNAL ASTER,IDTYPE,STMNDESC,GTYPCOD;
IF .ORDERCODE(@STMNDESC) NEQ GTYPCOD<0,0>
THEN RETURN 0;
IF ASTER( .IDTYPE ) LSS 0 THEN RETURN .VREG
ELSE
STK[SP_.SP+1] _ .VREG;
RETURN 0
END; %ASTERTYPE%
GLOBAL ROUTINE
PNAMSET =
BEGIN % SET PROGNAME SO IT WILL COME OUT ON THE HEADING%
EXTERNAL PROGNAME,STMNDESC,ENTRSTA,IDTYPE,GTYPCOD,ASTER;
IF .STMNROUTINE(@STMNDESC) NEQ ENTRSTA<0,0>
THEN
BEGIN
REGISTER BASE ID;
ID _ .STK[.SP]<RIGHT>;
PROGNAME _ .ID[IDSYMBOL];
%PICK UP AND *N AFTER FUNCTION NAMES
IDIOTIC AS IT MAY SEEM %
IF .ORDERCODE(@STMNDESC) EQL GTYPCOD<0,0> %HAD TYPE SPECIFIED%
THEN IF ( IDTYPE _ ASTER(.IDTYPE) ) LSS 0
THEN RETURN .VREG;
END;
RETURN 0
END; %PNAMSET%
GLOBAL ROUTINE
TMPGN =
BEGIN % GENERATES A .F TYPE TEMPORARY , RETURNS ITS NAME BUT DOES
NOT ENTER IT IN THE SYMBOL TABLE %
EXTERNAL FNTMP;
MACRO MAKNAM(NUMB)=
(.NUMB<9,3>+16)^18 + (.NUMB<6,3>+16)^12 + (.NUMB<3,3>+16)^6
+ (.NUMB<0,3>+16)$;
VREG _ SIXBIT'.F'+MAKNAM(FNTMP);
FNTMP_.FNTMP+1;
RETURN .VREG
END; %TMPGN%
GLOBAL ROUTINE
SUBLOCAL =
BEGIN % THIS ROUTINE IS CALLED TO GENERATE A SPECIAL NON-CONFILCTING
VARIABLES FOR
STATEMENT FUNCTION DUMMY PARAMETERS
A DUMMY VARIABLE IS GENERATED AND INSERTED INTO THE SYMBOL
TABLE DIRECTLY AFTER THE ACTUAL IDENTIFIER. THE NAMES ARE
THEN INTERCHANGED SO THAT EXPRES WILL GET THE DUMMY. THEN
THE SEMANTIC ROUTINES WILL REINTERCHANGE THE NAMES FOR THE
REST OF THE PROGRAM
STATEMENT FUNCTION PARAMETERS WILL GET THE TYPE OF THE
ACTUAL VARIABLE, GET DUMMY SET AND FORMLVAR
%
REGISTER BASE ID:SAV:TMP;
! ID - ACTUAL VARIABLE
! SAV - USED TO SWITCH NAMES
! TMP - GENERATED VARIABLE
EXTERNAL ENTRY , NAME, NEWENTRY, LEXICAL,GSTLEXEME,TYPE;
EXTERNAL ASTATFUN,DATASTA,STMNDESC;
MAP BASE ASTATFUN;
%GET A VARIABLE%
STK[SP_.SP+1] _ LEXL _ LEXICAL(.GSTLEXEME);
IF .LEXL<LEFT> NEQ IDENTIFIER
THEN
IF .LEXL<LEFT> EQL CONSTLEX
THEN RETURN FATLEX(PLIT'DIMENSIONED',ASTATFUN[IDSYMBOL],E15<0,0>)
ELSE RETURN ERR0L(IDENPLIT);
ID _ .LEXL<RIGHT>;
%NOW GENERATE A NEW SYMBOL , INSERT IT IN THE SYMBOL TABLE
AFTER THE ACTUAL SYMBOL AND SWAP THE NAMES %
SAV _ .ID[CLINK];
NAME _ IDTAB;
TMP _ ID[CLINK] _ NEWENTRY();
TMP[CLINK] _ .SAV;
TMP[IDSYMBOL] _ .ID[IDSYMBOL]; !REAL NAME
ID[IDSYMBOL] _ TMPGN(); !NEW NAME
TMP[IDATTRIBUT(DUMMY)] _ -1;
TMP[OPERSP] _ FORMLVAR;
TMP[VALTYPE] _ .ID[VALTYPE];
RETURN 0
END; %SUBLOCAL%
GLOBAL ROUTINE FUNCTIONSCAN =
BEGIN
% SCAN FOR THE STRING "FUNCTION". IF IT IS FOUND THEN
CALL THIS A FUNCTION. WE WILL INVOKE THE RULE THAT IDENTIFIERS
MUST BE LESS THAN OR EQUAL TO 6 CHARACTERS IN MAKING THIS
DECISION.
%
LOOK4CHAR _ FNPLIT<29,7>; ! SKIP THE BLANK
IF LEXICAL ( .GSTSSCAN ) EQL 0
THEN RETURN -1 ! NO FUNCTION
ELSE RETURN 0 ! GOT ONE
END;
GLOBAL ROUTINE LABELS =
BEGIN
EXTERNAL LOOK4LABEL;
% 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;
GLOBAL ROUTINE NOLABELS =
BEGIN
% SHUT OFF THE LABEL FLAG %
EXTERNAL LOOK4LABEL;
LOOK4LABEL _ 0;
RETURN 0
END;
GLOBAL ROUTINE TYPEID =
BEGIN
% THIS ROUTINE WILL PICK UP THE DATA TYPE WORDS IN IMPLICIT
STATEMENTS. IT THEN CALLS ASTER TO PICK UP THE *DIGIT CONSTRUCT
IF ANY AND THEN SETS THE TYPE FOR USE IN THE ROUTINE
IMPLICITSPEC AND RETURNS
%
EXTERNAL LOOK4CHAR,ASTER,TYPE,GSTSSCAN,GSTCSCAN,ACTLDATYPE;
REGISTER R1,R2;
LOOK4CHAR _ "?L"; ! ANY LETTER
SELECT LEXICAL( .GSTCSCAN ) OF NSET
"I": EXITSELECT (R1_INTEGER;R2_INTGPLIT<22,7>);
"R": EXITSELECT (R1_REAL;R2_REALPLIT<22,7>);
"D": EXITSELECT (R1_DOUBLPREC;R2_DOUBPLIT<22,7>);
"C": EXITSELECT (R1_COMPLEX;R2_COMPLIT<22,7>);
"L": EXITSELECT (R1_LOGICAL;R2_LOGIPLIT<22,7>);
OTHERWISE: RETURN FATLEX(E17<0,0>)
TESN;
LOOK4CHAR _ .R2;
IF LEXICAL( .GSTSSCAN ) EQL 0 THEN RETURN FATLEX(E17<0,0>);
ACTLDATYPE _ .R1;
RETURN ( TYPE _ ASTER(.R1) )
END;
GLOBAL ROUTINE IMPLICITSPEC=
BEGIN
% THIS ROUTINE WILL PICK UP THE LETTER AND LETTER-LETTER
CONSTRUCTS IN IMPLICIT STATEMENTS. IT WILL THEN ASJUST THE
BASIC TYPE TABLE APPROPRIATELY.
%
LOCAL L1,L2;
EXTERNAL TYPE,TYPTAB;
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 %
IF .TYPTAB[.L1]<LEFT> EQL #777777 THEN WARNLEX(E88<0,0>) ELSE TYPTAB[.L1]<LEFT> _ #777777;
TYPTAB[.L1]<RIGHT> _ .TYPE; !SET IMPLICIT TYPE FOR IDENTIFIERS
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%
DO (TYPTAB[.L1]<RIGHT> _ .TYPE; !SET IMPLICIT TYPE FOR RANGE OF LETTERS
IF .TYPTAB[.L1]<LEFT> EQL #777777 THEN WARNLEX(E88<0,0>) ELSE TYPTAB[.L1]<LEFT> _ #777777;
) WHILE (L1 _ .L1+1) LEQ .L2;
RETURN 0
END
ELSE
RETURN FATLEX(E18<0,0>)
END
END;
GLOBAL ROUTINE TOQUOTE=
BEGIN
% PICKS UP THE "TO" FOR ASSIGN STATEMENTS %
LOOK4CHAR _ ( PLIT'TO?0' )<36,7>;
IF LEXICAL( .GSTSSCAN ) EQL 0
THEN RETURN FATLEX(E10<0,0>)
ELSE RETURN 0
END;
GLOBAL ROUTINE RECORDMARK=
BEGIN
EXTERNAL LEXEMEGEN,LSAVE,STK,SP,EXPRESSION,LEXL,COPYLIST;
EXTERNAL ENTRY,FINDSTA,STMNDESC;
IF .LEXL<LEFT> EQL IDENTIFIER
THEN
BEGIN % WE MUST LOOK FOR THE OPTIONAL SUBSCRIPTS FOLLOWING THE IDENTIFIED
BECAUSE SOME UNMENTIONABLE COMPANY LIKES 'S AS WELL AS # FOR
RECORD MARKS AND ONE DOES NOT GET 'S BACK FROM THE LEXICAL
ANALYZER VERY EASILY
%
LOCAL LSP1;
LSP1 _ .SP-1; !SAVING SP
LOOK4CHAR _ "(";
IF LEXICAL(.GSTCSCAN) NEQ 0
THEN
BEGIN % PICK UP THE SUBSCRIPT EXPRESSION %
LOCAL LSP;
STK[SP _ .SP+1] _ 1; !ARRAY REF OPTION
LSP _ .SP; !SAVING
WHILE 1 DO
BEGIN
LSAVE _ 0; !SO EXPRESSION WILL GENERATE ITS OWN LEXEME
IF EXPRESSION() LSS 0
THEN RETURN -1;
!EXPRESSION WILL ALWAYS CREATE NEXT LEXEME
IF .LEXL<LEFT> NEQ COMMA THEN EXITLOOP;
END;
%[777]% IF .LEXL<LEFT> EQL RPAREN
%[777]% THEN LSAVE _ 0 ! Rparen lexeme has been used
%[777]% ELSE ERR0L(RPARPLIT);
COPYLIST(.LSP); !PUT LIST IN FREE STORAGE
COPYLIST(.LSP); !FORM ALL POINTER A'LA VARIABLESPEC
END
ELSE STK[SP _ .SP+1] _ 0;
COPYLIST(.LSP1);
END;
% NOW WE MUST LOOK FOR THE RECORD MARK %
LOOK4CHAR _ "'";
IF LEXICAL(.GSTCSCAN ) EQL 0
THEN
BEGIN % TRY # %
%[1061]% EXTERNAL WARNERR,E150;
LOOK4CHAR _ "#";
!%[760]% Recordmark is now optional in FIND statement
%[760]% IF LEXICAL ( .GSTCSCAN ) EQL 0 THEN RETURN -1;
%1132% WARNERR(.ISN,E150<0,0>); ! Use REC= or ' instead of #
%[1061]% RETURN 1
END;
RETURN .VREG ! FOUND A RECORD MARK
END;
GLOBAL ROUTINE EXPRLIST=
BEGIN
!------------------------------------------------------------------------------------------------------------------
! PROCESS THE ARGUMENT LIST OF A CALL STATEMENT
LOCAL LSP;
MACRO STKSIZE=250$; !FOR CHECKING STK OVERFLOW
EXTERNAL EXPRES,STK,SP,SYNTAX %(NODE)%,LSAVE,LEXEMEGEN %()%,LEXL,COPYLIST %(START)%,NAMREF;
EXTERNAL LOOK4LABEL;
REGISTER BASE T1;
T1_.STK[.SP-1]; !T1_LOC(IDENTIFIER)
IF NAMREF(FNNAME1, .T1 ) LSS 0 THEN RETURN .VREG; ! AME CONFLICT
T1[OPERSP] _ IF .T1[IDATTRIBUT(DUMMY)] THEN FORMLFN ELSE FNNAME;
!------------------------------------------------------------------------------------------------------------------
! NOW SCAN THE LIST OF EXPRESSIONS (ONE OR MORE SEPERATED BY COMMAS)
! WHICH MUST FOLLOW.
!------------------------------------------------------------------------------------------------------------------
LSP_.SP;
LSAVE_-1;
WHILE 1 DO
BEGIN
LEXL_LEXEMEGEN();
FLGREG<FELFLG>_1;
IF (.LEXL<LEFT> NEQ DOLLAR) AND (.LEXL<LEFT> NEQ ANDSGN)
!ALLOW * AS INITIAL CHARACTER FOR LABEL TOO.
AND (.LEXL<LEFT> NEQ ASTERISK)
THEN (STK[SP_.SP+1]_1; !EXPRESSION
IF EXPRES() LSS 0 THEN RETURN .VREG;
!EXPRES PUTS ITS RESULT ON STK[SP_.SP+1] AND RETURNS NEXT LEX IN LEXL
)
ELSE (STK[SP_.SP+1] _ 2; !LABEL ARG
LOOK4LABEL _ 1;
STK[SP_.SP+1] _ LEXEMEGEN();
IF .VREG<LEFT> NEQ LABELEX
THEN RETURN FATLEX(LABLPLIT,LEXPLITV,E0<0,0>);
%[716]% T1 _ .VREG<RIGHT>; !GET LABEL ADDRESS
%[716]% T1[SNRFS] _ 1; !MARK LABEL AS BEING JUMPED TO
%[716]% ! BY A RETURN FROM A SUBROUTINE CALL
LEXL _ LEXEMEGEN();
);
IF .LEXL<LEFT> NEQ COMMA THEN EXITLOOP;
%MAKE SURE THAT A SUPER LONG LIST
OF ARGUMENTS WILL NOT OVERFLOW STK.%
IF .SP GTR STKSIZE-3 THEN (COPYLIST(.LSP);LSP_.SP);
END;
LSAVE _ -1;
COPYLIST(.LSP);
RETURN 0
END;
END ELUDOM