Trailing-Edge
-
PDP-10 Archives
-
BB-4157D-BM
-
sources/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,1977 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: F.J. INFANTE, D. B. TOLMAN/DCE
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 = 5^24+1^18+53; !VERSION DATE: 9-AUG-77
%(
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
)%
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;
IF .LEXL<LEFT>