Trailing-Edge
-
PDP-10 Archives
-
AP-D480B-SB_1978
-
sta3.bli
There are 12 other files named sta3.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/MD/DCE
MODULE STA3(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;
REQUIRE META72.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;
GLOBAL BIND STA3V = 5^24 + 1^18 + 61; !VERSION DATE: 5-MAY-77
%(
REVISION HISTORY
43 ----- ----- IN "EQUISTA", WITHIN THE LOCAL ROUTINE
"GEQITEM", BEFORE CALLING "BLDVAR" FOR AN
ARRAY REF IN AN EQUIVALENCE STMNT, TEMPORARILY TURN OFF THE "BOUNDS"
FLAG, SO WONT TRY TO DO SS CHECKING
46 ----- ----- HAVE STATEMENT FUNCTIONS RESTORE THE SYMBOL
TABLE WHICH WAS MESSED UP TO CREATE THE TEMPROARY
DUMMIES
47 ----- ----- MAKE THE SFNEXPR FIELD OF THE STATEMENT
FUNCTION NODE POINT TO AN ASSIGNMENT OF THE
FUNCTION NAME TO THE EXPRESSION RATHER THAN JUST
POINTING TO THE EXPRESSION
48 ----- ----- FIX EXTESTA SO IT DOESN'T SAVSPAC THE SAME THING TWICE
49 ----- ----- FENTRYNAME IS NO LONGER SET ON STATEMENT FUNCTION
NAMES
50 ----- ----- EQUIVALENCE - PUT THE VARIABLE WHICH IS IN
COMMON AT THE TOP OF THE LIST SO THAT IF THE
CALCULATION OF ITS DISPLACEMENT IS DELAYED UNTIL
OUTMOD, ITS DISPLACEMENT WILL BE CALCULATED BEFORE
THE OTHER VARIABLES WHICH REFERENCE ITS DISPLACEMENT
ARE SHOVED INTO COMMON. WHAT FUN
51 ----- ----- CHECK BOTH NEGATIVE AND POSITIVE LIMITS OF
EQUIVALENCE SUBSCRIPTS
52 ----- ----- FIX DUMYIDMOD SO THAT IT DOES NOT CHANGE THE
TYPE OF FUNCTION NAMES EXPLICITLY TYPED IN
THE FUNCTION STATEMENT
HAVE THE IMPLICIT STATEMENT SET VALTYPE FOR
SUBROUTINE AND PROGRAM NAMES ALSO
JUST IN CASE THE ARE USED FOR SOMETHING ELSE
LATER
53 ----- ----- DOLOOP - WHEN ALREADY DEFINED TERMINAL IS DETECTED
PROCESS THE STATEMENT ANYWAY SO THE UNDEFINED
DO TERMINAL LISTING WON'T GET MESSED UP
54 ----- ----- FIX UP ACTIVE DO INDEX CHECKING SO THAT IT CHECKS
ALL ACTIVE INDICES NOT JUST THE LAST
NAMSET WILL NOW MAKE A CHECK FOR INDEX MODIFICATION
55 ----- ----- IN LOGICALIF - RESTORE LABLOFSTATEMENT AND
STMNDESC ON ANY ERROR RETURNS SO THAT IF THIS
STATEMENT TERMINATES A DO LOOP THE DOCHECK
CALL AFTER SEMANTICS WILL HAVE THE RIGHT INFO
***** BEGIN VERSION 4A
56 235 ----- IN NAMESTA , DEFINE ITEM AS NAMELIST ITEM
57 255 15432 IN DOLOOP, CHECK IF CURRENT STATEMENT # IS SAME AS
ENDING STATEMENT #.
***** BEGIN VERSION 4B *****
57 324 16750 IF PROCESSING OF STATEMENT FUNCTION FAILS,
SYMBOL TABLE NEEDED FIXING UP BEFORE CONTINUING.
58 417 QAR WITH 57 IN, A(1)=1 WILL DIE IF NOT DIMENSIONED
MUST CHECK FOR CONSTANTS AS PARAMS ON LEFT
59 420 QAR AFTER BOGUS STATEMENT FN SEEN, REMOVE
THE INFO THAT IT WAS A ST FN. THIS PREVENTS
LATER STATEMENTS FROM RELYING ON THIS INFO.
***** BEGIN VERSION 5A *****
60 534 QAR/21817 VARIOUS PROBLEMS WITH EDIT 59, ESPECIALLY
WITH QUOTED STRINGS IN VARIABLE LIST (BAD
FORMAT STATEMENT, ETC.)
61 570 22703 FN(2,3) CAUSES ILL MEM REF UNDER SOME CIRCUMSTANCES
)% !END REVISION HISTORY
!THE NUMBER IN COMMENT'S IS THE STATEMENTS LOCATION
!IN THE HASH TABLE .
FORWARD
% 30% IMPLSTA, !IMPLICIT
% 65% EQUISTA, !EQUIVALENCE
% 71% NAMESTA, !NAMELIST
% 79% UNLOSTA, !UNLOAD
% 88% SKIPSTA, !SKIPRECORD OR SKIPFILE
% 91% EXTESTA, !EXTERNAL
DOLOOP, !DO LOOP
LOGICALIF, !"LOGICAL" IF
ARITHIF, !"ARITHMETIC" IF
STATEFUNC; !STATEMENT FUNCTION
ROUTINE GEQITEM(PTR)= !GENERATE AN EQUIVALENCE ITEM ENTRY
BEGIN
EXTERNAL BLDVAR,SETUSE,NAMSET;
MACRO ERR52 = ( FATLEX(E52<0,0>))$,
ERR53 = ( FATLEX(E53<0,0>))$;
LOCAL BASE T1;
REGISTER BASE T2:R1:R2;
LOCAL BASE EPTR ; MAP BASE PTR ;
NAME _ EQLTAB; EPTR _ NEWENTRY(); !MAKE AN EQUIV ITEM NODE
EPTR[EQLID] _ R1 _ .PTR[ELMNT]; !PTR TO SYMBOL IN EQUIVALENCE
R1[IDATTRIBUT(INEQV)] _ 1;
IF .R1[IDATTRIBUT(DUMMY)] THEN ERR52; !IF DUMMY SYMBOL THEN ERROR
IF .PTR[ELMNT1] NEQ 0
THEN !ITEM IS SUBSCRIPTED
BEGIN
IF .R1[IDDIM] NEQ 0 AND .R1[IDATTRIBUT(INTYPE)] NEQ 0
%DELAY PROCESSING IF NOT DIMENSIONED OR TYPED %
THEN !ITEM ALSO DIMENSIONED
IF (T2 _ .PTR[ELMNT2]; .T2[ELMNT]<LEFT>) EQL 0
THEN
BEGIN !A SINGLE SUBSCRIPT
NAMSET ( ARRAYNM1, .R1 ); !DEFINE NAME
T1 _ @.T2[ELMNT]; !PTR TO SUBSCRIPT
SAVSPACE(0,.T2); SAVSPACE(.PTR<LEFT>,.PTR);
IF .T1[OPR1] NEQ CONSTFL OR .T1[VALTYPE] NEQ INTEGER
THEN RETURN ERR53;
!NOW GEN THE OFFSET
EPTR[EQLDISPL] _ - .T1[CONST2] !THE SUBSCRIPT VALUE
+( T2 _ .R1[IDDIM]; T2 _ .T2[DIMENL(0)]; .T2[CONST2]);
IF .EPTR[EQLDISPL] LEQ -(2^18) OR .EPTR[EQLDISPL] GEQ (2^18)
THEN RETURN FATLEX(E103<0,0>);
IF .R1[DBLFLG] THEN EPTR[EQLDISPL] _ .EPTR[EQLDISPL] * 2;
EPTR[EQLLIST] _ 0;
END
ELSE
BEGIN
LOCAL SAVEBOUNDSFLG; !TO SAVE THE VAL OF THE "BOUNDS" SWITCH
SAVEBOUNDSFLG_.FLGREG<BOUNDS>; !SAVE THE VAL OF THE BOUNDS SWITCH
FLGREG<BOUNDS>_0; !TURN OFF THE BOUNDS-CHECK FLAG
! WHILE EXPANDING THE ADDR CALC FOR AN ARRAY
! REFERENCE UNDER AN EQUIVALENCE STMNT
SETUSE _ SETT; !BLDVAR FLAG
T1 _ BLDVAR(.PTR); !RETURNS PTR TO ARRAY REF EXPRESSION NODE
FLGREG<BOUNDS>_.SAVEBOUNDSFLG; !RESTORE THE BOUNDS SWITCH
IF .T1 LSS 0 THEN RETURN .VREG; !BLDVAR ERROR
!MUST DELETE THIS NODE AFTER USE
!T1[ARG2PTR] MUST BE ZERO OTHERWISE
!ERROR DUE TO NON-CONSTANT SUBSCRIPT
IF .T1[ARG2PTR] NEQ 0 THEN ERR53;
EPTR[EQLDISPL] _-(EXTSIGN(.T1[TARGET])); !HALF WORD VALUE MUST BE EXTENDED
EPTR[EQLLIST] _ 0; !SO THAT WE KNOW DISPL IS COMPUTED
END
ELSE !SET EQLLIST PTR TO POINT TO LIST OF SUBSCRIPTS
!FOR USE IN LATER CALCULATION WHEN DIMENSIONS ARE KNOWN
BEGIN
R2 _ .PTR[ELMNT2]; T1 _ .R2[ELMNT]; SAVSPACE(0,.R2);
NAMSET(VARYREF,.R1);
EPTR[EQLINDIC]_ 1; !FLAG FOR NOT YET DIMENSIONED OR TYPED
EPTR[EQLLIST] _ .T1; !PTR TO SUBSCRIPT LIST
END;
END !OF ITEM IS SUBSCRIPTED
ELSE !ITEM NOT SUBSCRIPTED
BEGIN
IF NAMSET(VARYREF,.R1) LSS 0 THEN RETURN .VREG; !NAME CONFLICT
EPTR[EQLDISPL] _ 0;
END;
RETURN .EPTR
END; !OF ROUTINE GEQITEM
GLOBAL ROUTINE EQUISTA=
BEGIN
LOCAL BASE T1;
REGISTER BASE R1 :R2;
EXTERNAL EQVPTR,CORMAN,NAME,NEWENTRY,BLDVAR,STK,SAVSPACE;
MACRO ERR52 = ( FATLEX(E52<0,0>))$,
ERR53 = ( FATLEX(E53<0,0>))$;
!MACRO GENERATES AN EQUIVALENCE GROUP ENTRY
!ENTRIES ARE LINKED BY NEWENTRY()
!
MACRO GEQGROUP(EPTR)=
BEGIN
NAME _ EQVTAB; ENTRY _ R1 _ EPTR;
R2 _ NEWENTRY();
R1 _ EPTR[EQLID];
IF .R1[IDATTRIBUT(INCOM)] THEN (R2[EQVINCOM]_1;
R2[EQVHEAD] _ EPTR;
);
R2[EQVISN] _ .ISN; !LINE NUMBER FOR POSSIBLE ERROR MESSAGES
.R2
END$;
!
LOCAL BASE GRUPHD;
LOCAL BASE ELISTPTR :EGROUP; !PTR TO LAST EQUIV ITEM ENTRY
!SEMANTIC ANALYSIS BEGINS
T1 _ @.STK[0]; !LIST PTR TO LIST OF EQV GROUPS
INCR GROUP FROM .T1 TO .T1+.T1<LEFT> DO
BEGIN MAP BASE GROUP;
!EACH EQUIV GROUP IS COMPOSED OF 2 PARTS:
!1. APTR TO THE FIRST EQUIV ITEM AND A LIST PTR TO A LIST
! OF EQUIV ITEM PTRS
!EACH EQUIV ITEM IS A PTR TO A 3 OR 4 PART LIST
! .IDENTIFIER
! .OPTION (0 OR 1)
! .PTR TO SUBSCRIPT EXPRESSION LISTS PTR (IF OPTION 1)
!
GRUPHD _ .GROUP[ELMNT];
IF (ELISTPTR _ GEQITEM(.GRUPHD[ELMNT])) LSS 0 THEN RETURN -1; !GENERATE AN EQUIVALENCE ITEM NODE
EGROUP _ GEQGROUP(.ELISTPTR); !MACRO GENERATES AN EQUIVALENCE GROUP ENTRY
R1 _ .GRUPHD[ELMNT1]; !PTR TO LIST EQUIVALENCED TO "GRUPHD"
INCR LST FROM .R1 TO .R1+.R1<LEFT> DO
BEGIN !PROCESS LIST OF ITEMS EQUIVALENCE TO GROUP HEAD
MAP BASE LST;
ELISTPTR _ .EGROUP[EQVLAST]; !PTR TO LAST ITEM IN GROUP
IF (R2 _ GEQITEM(.LST[ELMNT])) LSS 0 THEN RETURN -1;
R1 _ .R2[EQLID]; !PTR TO SYMBOL NODE
IF .R1[IDATTRIBUT(INCOM)]
THEN IF .EGROUP[EQVINCOM] THEN FATLEX(E48<0,0>) !TWO ITEMS IN COMMON
ELSE (EGROUP[EQVINCOM] _ 1;
% MOVE THE ONE IN COMMON TO THE HEAD OF THE LIST
SO THAT THE CALCULATION OF ITS DISPLACEMENT WILL
BE ASSURED WHEN THINGS ARE MOVED INTO COMMON %
R2[EQLLINK] _ .EGROUP[EQVFIRST];
EGROUP[EQVFIRST] _ EGROUP[EQVHEAD] _ .R2
)
ELSE
BEGIN
% LINK IT TO THE END OF THE LIST%
ELISTPTR[EQLLINK] _ EGROUP[EQVLAST] _ .R2
END;
END; !END OF INCR LST...
END; !END OF INCR GROUP
[email protected][0];
SAVSPACE(.T1<LEFT>,.T1); SAVSPACE(0,.STK[0]);
.VREG
END;
GLOBAL ROUTINE EXTESTA=
BEGIN
EXTERNAL TYPE,STK,SAVSPACE %(SIZE,LOC)%,BLDARRAY %(ONEARRAY LIST)%,NAMDEF;
REGISTER BASE T1:T2;
!SEMANTIC ANALYSIS BEGINS
%PROCESS LIST OF EXTERNALS %
INCR EXLST FROM .(@STK[0])<RIGHT> TO ( .(@STK[0])<RIGHT>+.(@STK[0])<LEFT> ) DO
BEGIN
MAP BASE EXLST;
T1 _ .EXLST[ELMNT]; !POINTER TO OPTION - ID BLOCK
IF .T1[ELMNT] EQL 0
THEN
BEGIN %NO PRECEEDING CHARACTER SO NOT LIBRARY FUNCTION %
T2 _ .T1[ELMNT1];
IF NAMDEF(EXTDEF,.T2) LSS 0 THEN RETURN .VREG;
T2[IDATTRIBUT(INEXTERN)] _ 1;
END
ELSE
BEGIN %LIBRARY FUNCTION%
IF .T1[ELMNT] EQL 2
THEN %ASTERISK% T2 _ .T1[ELMNT2] !SKIP *
ELSE %ANDSIGN% T2 _ .T1[ELMNT1];
%ANY CONFLICTS%
IF NAMDEF( EXTDEFS, .T2 ) LSS 0 THEN RETURN .VREG;
%OK%
T2[IDATTRIBUT(INEXTSGN)] _ 1;
END;
T2[OPERSP] _ IF .T2[IDATTRIBUT(DUMMY)] THEN FORMLFN ELSE FNNAME;
SAVSPACE(.T1<LEFT>,@T1<RIGHT>)
END;
SAVSPACE( .(@STK[0])<LEFT>, .(@STK[0])<RIGHT> );
SAVSPACE( 0, .STK[0]<RIGHT> )
END;
GLOBAL ROUTINE DUMYIDMOD=
BEGIN
!FIXES UP THE VALTYPE OF DUMMY VARIABLES AFTER AN IMPLICIT
!STATEMENT WAS PROCESSED
EXTERNAL SORCPTR,TYPTAB;
REGISTER BASE R1:R2:T2; LOCAL BASE T1;
!
!DO THE FUNCTION NAME IF PRESENT
!
R1 _ .SORCPTR<RIGHT>;
R2 _ .R1[ENTSYM];
IF NOT .R2[IDATTRIBUT(INTYPE)]
THEN
BEGIN
T2 _ .R2[IDSYMBOL]<30,6>; !FIRST CHARACTER
R2[VALTYPE] _ .TYPTAB[.T2-SIXBIT"A"]<RIGHT>
END;
!NOW REST OF DUMMYS
!
IF (T1 _ .R1[ENTLIST]) NEQ 0 !T1 POINTS TO ARGLIST
THEN
DECR I FROM .(.T1+1)<RIGHT>-1 TO 0 DO
BEGIN
R2 _ .(.T1+2)[.I]<RIGHT>; !PTR TO ARG
T2 _ .R2[IDSYMBOL]<30,6>;
R2[VALTYPE] _ .TYPTAB[.T2-SIXBIT"A"]<RIGHT>;
END
END; !OF DUMTIDMOD
GLOBAL ROUTINE IMPLSTA=
BEGIN
EXTERNAL DUMYIDMOD,SORCPTR;
REGISTER BASE R1;
!SEMANTIC ANALYSIS BEGINS
IF (R1 _ .SORCPTR<RIGHT>) NEQ 0
THEN ( IF .R1[SRCID] EQL ENTRID
THEN DUMYIDMOD(); )
ELSE ( %SET TYPE OF PROGRAM OR BLOCK DATA NAMES JUST INCASE %
EXTERNAL PROGNAME,TBLSEARCH,NAME,ENTRY,TYPTAB;
REGISTER BASE T2;
IF .PROGNAME NEQ SIXBIT'MAIN.' AND
.PROGNAME NEQ SIXBIT'.BLOCK'
THEN
BEGIN
ENTRY _ .PROGNAME;
NAME _ IDTAB;
R1 _ TBLSEARCH();
T2 _ .R1[IDSYMBOL]<30,6>; !FIRST CHARACTER
R1[VALTYPE] _ .TYPTAB[.T2-SIXBIT"A"]<RIGHT>
END
);
.VREG
END;
!GLOBAL ROUTINE GLOBSTA=
!BEGIN
!!
!! ROUTINE COMMENTED IN 1(41)-116
!!
!! EXTERNAL STK,BLDARRAY %(ONEARRAY LIST)%,SAVSPACE %(SIZE,LOC)%,TYPE;
!! MAP BASE T1;MACRO ELMNT=0,0,FULL$;
! BIND GLOBPLIT= PLIT'GLOBAL';
!%1(41)-117% ENTRY[1]_GLOBPLIT;
!%1(41)-117% ERROUT(73);!STATEMENT NOT YET SUPPORTED
!!
!! COMMENT REST OF ROUTINE IN EDIT 1(41)-114
!!
!! IF SCAN(PLIT'AL') LSS 0 THEN (ENTRY[1]_GLOBPLIT;ERROUT(E12));
!! IF SYNTAX(GLOBALSPEC) LSS 0 THEN RETURN -1;
!!SEMANTIC ANALYSIS BEGINS
!! IDTYPE_-1;TYPE_1;T1_.STK[0];
!! BLDARRAY(.T1[ELMNT]);SAVSPACE(0,@STK[0]);
!! .VREG
!%1(41)-117% RETURN -1
!END;
GLOBAL ROUTINE NAMESTA=
BEGIN
%
ROUTINE EXPECTS STK[0] TO CONTAIN A POINTER TO ALIST POINTER
OF THE FORM (COUNT,,PTR). THE LIST PTR POINTS TO A LIST OF
COUNT+1 POINTERS THAT EACH POINT TO A 4 WORD BLOCK OF THE FORM:
0. /
1. NAMELIST NAME PTR
2. /
3. LIST POINTER (COUNT,,LISTPTR)
WHERE THE LIST POINTER IN 3. POINTS TO ALIST OF IDENTIFIER PTRS
THAT ARE THE ITEMS IN THE NAMELIST
%
MACRO ERR58(X)=FATLEX(X,E58<0,0>)$;
EXTERNAL SAVSPACE,NAME,NEWENTRY,STK,CORMAN,ENTRY;
EXTERNAL NAMDEF,NAMREF;
REGISTER BASE R1:R2;
LOCAL BASE T1:T2;
!SEMANTIC ANALYSIS BEGINS
T1 _ @.STK[0]; !GET PTR TO NAMELIST BLOCK
INCR NLST FROM .T1 TO .T1+.T1<LEFT> DO
BEGIN
MAP BASE NLST;
T1 _ .NLST[ELMNT]; !PTR TO BLOCKLIST NAME
R1 _ .T1[ELMNT1]; !PTR TO NAMELIST NAME
IF NAMDEF(NMLSTDEF, .R1) LSS 0 THEN RETURN .VREG;
R1[IDATTRIBUT(NAMNAM)] _ 1;
R2 _ .T1[ELMNT3]; !PTR TO LIST OF NAMELST ANME PTRS
SAVSPACE(.T1<LEFT>,.T1);
INCR ILST FROM .R2 TO .R2+.R2<LEFT> DO
BEGIN
MAP BASE ILST;
T2 _ .ILST[ELMNT]; !GET PTR TO NAMELIST ITEM
!CHECK FOR ILLEGAL NAMES
%**;[235], ROUTINE NAMESTA , REPLACE @ LINE 3757 , DT/MD ,11/18/74 %
%[235]% IF NAMDEF(NMLSTITM,.T2) GTR 0 !CHECK FOR NAMELIST ITEM
THEN ILST[ELMNT]<LEFT> _ 0;
END; !END OF INCR ILST
NAME _ NAMTAB; T2 _ NEWENTRY();
T2[NAMLIST] _ .R2<RIGHT>;
T2[NAMCNT] _ .R2<LEFT>+1;
T2[NAMLID] _ .R1; !NAMLIST NAME
%**;[235],ROUTINE NAMESTA , SET POINTER TO NAMELIST NODE IN NAMELIST NAME ENTRY %
%**;[235], ADD AT LINE 3764 %
%[235]% R1[IDCOLINK]_.T2; !SET POINTER IN NAMELIST NAME ENTRY
END; !OF INCR NLST
T1 _ @.STK[0]; SAVSPACE(.T1<LEFT>,.T1); SAVSPACE(0,.STK[0]);
.VREG
END;
GLOBAL ROUTINE SKIPSTA=
BEGIN
EXTERNAL BLDUTILITY;
REGISTER R;
BIND DUM = PLIT( REC NAMES 'RECORD?0', FIL NAMES 'FILE?0' );
R _ SKIPDATA;
LOOK4CHAR _ REC<36,7>;
DECR I FROM 1 TO 0
DO
BEGIN
IF LEXICAL(.GSTSSCAN) NEQ 0
THEN
BEGIN % GOT ONE %
IF SYNTAX(UTILSPEC) LSS 0 THEN RETURN .VREG;
RETURN BLDUTILITY(.R)
END;
R _ SKIPFDATA; ! TRY FILE
LOOK4CHAR _ FIL<36,7>
END;
RETURN FATLEX(E12<0,0>); !MISSPELLED
END;
GLOBAL ROUTINE UNLOSTA=
BEGIN
EXTERNAL BLDUTILITY;
!SEMANTIC ANALYSIS BEGINS
BLDUTILITY(UNLODATA);
.VREG
END;
GLOBAL ROUTINE DOLOOP =
BEGIN
REGISTER BASE T1:T2;REGISTER BASE R1:R2;
EXTERNAL STK,SP,NEWENTRY %()%,SAVSPACE %(SIZE,LOC)%,ONEPLIT,TBLSEARCH %()%,CORMAN %()%;
EXTERNAL DONESTLEVEL, !CURRENT LEVEL OF DO NESTING
LASDOLABEL, !LABEL PTR TO LAST LABEL SEEN IN DO STATEMENT
%**;[255],STA3,JNT,10-MAR-75%
%**;[255],IN DOLOOP @ 3803%
STALABL, ![255] CURRENT STATEMENT LABEL
ISN, ![255] CURRENT ISN
DOXPN, !MAKES DO INITIALIZATION TREE
CURDOINDEX, !PTR TO CURRENT DO INDEX VARIABLE
ADDLOOP; !MAKES DO TREE STRUCTURE FOR OPTIMIZER
EXTERNAL NAMSET,CKDOINDEX;
LOCAL BEFOREDO; !HOLDS DO PREDECESSOR
MACRO ADDOLAB(X,Y)= NAME<LEFT> _ 2; !LINK IN NEW LABEL
T2 _ CORMAN();
T2[ELMNT] _ .LASDOLABEL; !SAVE LAST
T2[ELMNT1] _ .CURDOINDEX; !SAVE INDEX
LASDOLABEL<LEFT> _ .T2;
LASDOLABEL<RIGHT> _ X;
CURDOINDEX _ Y; !INDEX POINTER
$;
!
MACRO
LBL=0,0,RIGHT$,INDX=0,1,FULL$,INITIAL=0,2,FULL$,FINAL=0,3,FULL$,
INCROPT=0,4,FULL$,INCREMENT=0,5,FULL$;
!------------------------------------------------------------------------------------------------------------------
! THE SYNTAX ROUTINE RETURNS A POINTER IN STK[0] WHICH POINTS TO THE LIST:
!
! LABEL(21^18+LOC) - LABEL OF DO TERMINAL STATEMENT
! IDENTIFIER(20^18+LOC) - DO INDEX
! EXPRESSION(1^18+LOC) - POINTER TO POINTER TO INITIAL VALUE OF DO INDEX
! EXPRESSION(1^18+LOC) - POINTER TO POINTER TO FINAL VALUE OF DO INDEX
! OPTION 0 - INCREMENT OF DO INDEX IS ONE
! OPTION 1 - INCREMENT OF DO INDEX IS EXPRESSION FOLLOWING
! LIST(1^18+LOC) - POINTER TO POINTER TO POINTER TO INCREMENT OF DO INDEX
!------------------------------------------------------------------------------------------------------------------
T1_.STK[0]; !T1_LOC(LIST)
R1_.T1[LBL];R2_.T1[INDX];
IF (T2_.R1[SNHDR]) NEQ 0 THEN !ERROR DO TERMINAL ALREADY SEEN
FATLEX(.T2[SRCISN],.R1[SNUMBER],E20<0,0>); !DON'T RETURN
%**;[255],STA3,JNT,10-MAR-75%
%**;[255],IN DOLOOP @ 3835%
IF .R1[SNUMBER] EQL .STALABL THEN ![255] IF IT'S THE NUMBER ON THIS STATEMENT
FATLEX(.ISN,.R1[SNUMBER],E20<0,0>); ![255] FATAL ERROR
IF CKDOINDEX(.R2<RIGHT>)
THEN RETURN FATLEX( R2[IDSYMBOL], E21<0,0>); !DO INDEX ALREADY ACTIVE
IF NAMSET(VARIABL1, .R2) LSS 0 THEN RETURN .VREG;
ADDOLAB(.R1,.R2); !LINK IN NEW LOOP LABEL TO PREVIOUS ONES
BEFOREDO _ .SORCPTR<RIGHT>; !PTR TO STATEMENT NODE PRECEDING DO
NAME_IDOFSTATEMENT_DODATA;NAME<RIGHT>_SORTAB;
T2_NEWENTRY();
T2[DOPRED] _ IF .BEFOREDO EQL 0 THEN .SORCPTR<LEFT> ELSE .BEFOREDO; !LINK IN PREVIOUS STATEMENT NODE
DONESTLEVEL _ .DONESTLEVEL+1;
T2[DOSYM]_.R2;T2[DOLBL]_.R1;
R2_.R1[SNDOLNK];R1[SNDOLVL]_.R1[SNDOLVL]+1;NAME<LEFT>_1;R1[SNDOLNK]_CORMAN();
(@VREG)<LEFT>_@T2;(@VREG)<RIGHT>_@R2;
R1_.T1[INITIAL];R2_.T1[FINAL];T2[DOM1]_.R1%[ELMNT]%;T2[DOM2]_.R2%[ELMNT]%;
! SAVSPACE(.R1<LEFT>,@R1);SAVSPACE(.R2<LEFT>,@R2);
IF .T1[INCROPT] NEQ 0 THEN
BEGIN
R1_.T1[INCREMENT];T2[DOM3]_.R1[ELMNT];
SAVSPACE(.R1<LEFT>,.R1);
END ELSE T2[DOM3]_.ONEPLIT;
SAVSPACE(.T1<LEFT>,.T1);
ADDLOOP(.DONESTLEVEL); !FOR OPTIMIZER
DOXPN(.T2<RIGHT>); !CREATE THE NODE FOR THE DO INITIALIZATION CODE
.VREG
END;
GLOBAL ROUTINE LOGICALIF=
BEGIN
LOCAL BASE IFEXPR,LASTTRUESRC,SAVLABEL,SAVDESC;
REGISTER BASE T1:T2;
EXTERNAL SAVSPACE, %SAVSPACE(SIZE,PNTR)%
LABLOFSTATEMENT, %LABEL ON IF STATEMENT%
STALABL, % ALSO CONTAINS THE LABEL %
GSTIFCLASIF, %CLASSIFIER()%
ENDOFILE, ! RETURN FROM LEXICAL
STMNDESC, ! STATEMENT DESCRIPTION BLOCK
STK,SP,LOOK4LABEL,
NEWENTRY; %NEWENTRY()%
IFEXPR _ .STK[0]; !SAVING PTR TO EXPR PTR
!SEMANTIC ANALYSIS BEGINS
SAVDESC _ @STMNDESC; ! SAVE THE STATMENT DESCRIPTION POINTER
IF LEXICAL( .GSTIFCLASIF ) EQL ENDOFILE<0,0> THEN ( STMNDESC _ .SAVDESC; RETURN -1); ! UNRECOGNIZED STATEMENT
IF .BADIFOBJ ( @STMNDESC ) THEN ( STMNDESC_.SAVDESC; RETURN FATLEX(E23<0,0>)); ! ILLEGAL LOGICAL IF OBJECT
!
!STK[0] CONTAINS A PTR TO PTR TO PTR TO EXPRESSION NODE
!
STK[0] _ .IFEXPR; !RESTORING THE PTR
T2_.STK[0];IFEXPR_.T2[ELMNT];SAVSPACE(.T2<LEFT>,.T2);LASTTRUESRC_.LASTSRC;
LOOK4LABEL _ 0; !CLEAR LABEL FLAG
SP_-1; !RESET STK PTR FOR PARSE
SAVLABEL _ .LABLOFSTATEMENT; LABLOFSTATEMENT _ STALABL _ 0;
%EXECUTE THE SYNTAX IF NECESSARY %
IF( T1 _ .SYNOW(@STMNDESC)) NEQ 0
THEN IF SYNTAX(.T1) LSS 0
THEN (STMNDESC_.SAVDESC;LABLOFSTATEMENT_.SAVLABEL; RETURN -1);
IF (.STMNROUTINE(@STMNDESC))() LSS 0
THEN (LABLOFSTATEMENT_.SAVLABEL;STMNDESC_.SAVDESC; RETURN -1); !STATEMENT HAD AN ERROR
!------------------------------------------------------------------------------------------------------------------
! REMOVE THE FALSE SOURCE NODE FROM THE LINKED LIST OF SOURCE STATEMENTS
!------------------------------------------------------------------------------------------------------------------
STMNDESC _ .SAVDESC; ! RESTORE THE STATEMENT DESCRIPTION POINTER
T1_.LASTSRC; IF .LASTTRUESRC EQL 0 THEN LASTSRC _ .SORCPTR<LEFT> ELSE LASTSRC_.LASTTRUESRC;
IF .T1[SRCID] EQL SFNID %STATEMENT FUNCTION% THEN FATLEX(E23<0,0>);
LABLOFSTATEMENT _ .SAVLABEL;
NAME_IDOFSTATEMENT_IFLDATA; NAME<RIGHT> _ SORTAB;T2_NEWENTRY();
T2[LIFEXPR]_.IFEXPR;T2[LIFSTATE]_.T1;
IF .IFEXPR[OPRCLS]NEQ DATAOPR
THEN IFEXPR[PARENT] _ .T2; !EXPR NODE POINTS TO SRC NODE
T1[SRCLBL] _ 0; ! REMOVING ANY LABEL THE STATEMENT HAD FROM THE STATEMENT PART
END;
GLOBAL ROUTINE ARITHIF=
BEGIN
EXTERNAL STK,WARNOUT,SP,NEWENTRY %()%,SAVSPACE %(SIZE,LOC)%,TBLSEARCH %()%;
REGISTER BASE T1:T2;REGISTER BASE R1:R2;
MACRO IFEXPR=0,0,FULL$,LTLABEL=0,1,FULL$,EQLABEL=0,2,FULL$,
GTOPT=0,3,FULL$,GTLABEL=0,4,FULL$;
!SEMANTIC ANALYSIS BEGINS
T1_.STK[0]; !T1_LOC(LIST)
R1_.T1[LTLABEL];R2_.T1[EQLABEL];
IF .T1[GTOPT] NEQ 0 THEN
BEGIN
T2_.T1[GTLABEL];T1_.T2[ELMNT];SAVSPACE(.T2<LEFT>,@T2);
END ELSE T1_@R2;
NAME_IDOFSTATEMENT_IFADATA;NAME<RIGHT>_SORTAB;T2_NEWENTRY();
T2[AIFLESS]_.R1<RIGHT>;
T2[AIFEQL]_.R2<RIGHT>;
T2[AIFGTR]_.T1<RIGHT>;
T1_.STK[0]; R1 _ T2[AIFEXPR]_.T1[ELMNT];
!
!CHECK TO POINT BACK TO SRC NODE
!
IF .R1[OPRCLS] NEQ DATAOPR
THEN R1[PARENT] _ .T2; !EXPR POINTS BACK TO SRC NODE
%(**CHECK FOR COMPLEX EXPRESSION - THIS IS ILLEGAL**)%
IF .R1[VALTYPE] EQL COMPLEX THEN WARNLEX(E99<0,0>);
SAVSPACE(.T1<LEFT>,@T1);
END;
ROUTINE BLDSFN= !BUILDS A STATEMENT FUNCTION SOURCE TREE NODE
BEGIN
EXTERNAL STK,NEWENTRY,CORMAN,NAME,ASTATFUN,IDOFSTATMENT,SAVSPACE,ASGNTYPER;
LOCAL BASE T1; REGISTER BASE R1:R2:T2;
!
!STK[0] CONTAINS APTR TO THE OUTPUT FROM A STATEFUNCTION PARSE
!
!BUILD THE NODE
!
NAME _ IDOFSTATEMENT _ SFNDATA; NAME<RIGHT> _ SORTAB;
R1 _ NEWENTRY();
T1 _ .STK[0];
R1[SFNNAME] _ .ASTATFUN; !PTR PUT IN ASTATFUN BY STATEFUNC ROUTINE
R1[SFNEXPR] _ R2 _ .T1[ELMNT1]; !PTR TO EXPRESSION
ASGNTYPER(.R1); !CHECK FOR TYPE CONVERSION
R2 _ .R1[SFNEXPR]; !RESTORE EXPRESSION PTR
! MAKE SFNEXPR POINT TO AN ASSIGNMENT NODE
NAME<LEFT> _ ASGNSIZ+SRCSIZ;
T2 _ CORMAN();
T2[OPRCLS] _ STATEMENT;
T2[OPERSP] _ ASGNID;
T2[LHEXP] _ .ASTATFUN;
T2[A1VALFLG] _ 1;
T2[RHEXP] _ .R2;
R1[SFNEXPR] _ .T2;
IF .R2[OPRCLS] NEQ DATAOPR THEN R2[PARENT] _ .R1; !PTR TO STATEMENT FUNCTION AS PARENT
!BUILD THE NEW ARGLIST BLOCK 2 WORDS LONGER THAN NUM OF ARGS
NAME<LEFT> _ .T1[ELMNT]<LEFT>+1+2;
T2 _ CORMAN();
R2 _ .T1[ELMNT];
T2[ELMNT1] _ .T1[ELMNT]<LEFT>+1; !NUMBER OF ARGS
T2 _ .T2+2;
DECR I FROM .T1[ELMNT]<LEFT> TO 0 DO
BEGIN
%RESTORE THE SYMBOL TABLE%
LOCAL BASE ID:TMP:SAV;
ID _ @(.R2)[.I];
SAV _ .ID[IDSYMBOL];
TMP _ .ID[CLINK];
ID[IDSYMBOL] _ .TMP[IDSYMBOL];
TMP[IDSYMBOL] _ .SAV;
(.T2)[.I] _ .TMP; !TRANSFERING ARGLIST TO NEW BLOCK
%CHECK FOR DUPLICATE DUMMIES%
SAV _ .I-1;
UNTIL .SAV LSS 0
DO
BEGIN
TMP _ @@(@R2)[.SAV]; !NEXT PARAMETER
IF .ID[IDSYMBOL] EQL .TMP[IDSYMBOL]
THEN FATLEX(.ID[IDSYMBOL],E87<0,0>);
SAV _ .SAV-1
END;
END;
R1[SFNLIST] _ T2 _ .T2-2; !PUT THE POINTER VALUE BACK TO BEGINNNING OF BLOCK
SAVSPACE(.R2<LEFT>,.R2); SAVSPACE(.STK[0]<LEFT>,.STK[0]);
RETURN .R1
END;
GLOBAL ROUTINE STATEFUNC=
BEGIN
REGISTER BASE R1:T1:T2;
EXTERNAL
NAMDEF,NAMSET,
STMNDESC,
ARRXPND, %ARRXPND(ARRAYNAME, SUBSCRIPTLIST)
SUBSCRIPTLIST= LOC(COUNT,SUBSCRIPT#1,...,SUBSCRIPT#COUNT-1)%
SAVSPACE, %SAVSPACE(SIZE,LOCATION)%
NEWENTRY, %NEWENTRY()%
MULTIASGN, %MULTIASGN()%
ASTATFUN, !FLAG PTR WHEN PARSING A STATEMENT FUNCTION
STK,SP;
EXTERNAL PSTATE,PSTEXECU,STALABL,DSCSTFN,LABDEF,DSCASGNMT;
MACRO
CNT= 0,0,LEFT$;
LOCAL LNAME;
T2_LEXEMEGEN();
IF .T2<LEFT> NEQ IDENTIFIER THEN RETURN FATLEX(.ISN,E10<0,0>); !UNRECOGNIZED STATEMENT
LNAME _ .T2; !SAVING THE ARRAY OR FUNCTION NAME PTR
IF .T2[OPRSP1] NEQ ARRAYNM1 THEN
BEGIN
%STATEMENT FUNCTION%
STMNDESC _ DSCSTFN<0,0>; ! UPDATE THE STATEMENT DESCRIPTION
% CHECK STATEMENT ORDERING %
IF .PSTATE EQL PSTEXECU<0,0>
THEN % OUT OF ORDER OR UNDEMENSIONED ARRAY %
WARNLEX(KEYWRD(@STMNDESC)<0,0>,E107<0,0>);
% CHECK LABEL%
IF .STALABL NEQ 0
THEN % NO LABELED STATEMENT FUNCTIONS %
FATLEX(KEYWRD(@STMNDESC)<0,0>,E110<0,0>);
%RECORD THEN DEFINITON%
IF NAMDEF( STFNDEF, .T2 ) LSS 0 THEN RETURN .VREG;
T2[IDATTRIBUT(SFN)]_1;T2[OPERSP]_FNNAME;
ASTATFUN _ .T2<RIGHT>; !FLAG PTR USED IN MULTIA ASGN
IF SYNTAX(STATEFUNCSPEC) LSS 0 THEN
%[324] IN STATEFUNC LINE 4060 INSERT %
%[324] CLEAN UP SYMBOL TABLE BEFORE LEAVING.%
%[324]% BEGIN
%[324]% ASTATFUN _ 0;
!**;[420] STATEFUNC @4060, DCE, 5-AUG-76
!**;[420] REMOVE BOGUS STATEMENT FUNCTION DEFINITION
!**;[420] TO PREVENT LATER CONFUSION, E. G.
!**;[420] A(1)=1; A(1)=1 WITHOUT DIM ST GIVES UGLY ERRORS!
%[420]% T1_.LNAME;
%[420]% T1[OPRSP1]_VARIABL1;
%[420]% T1[IDATTRIBUTE(SFN)]_0;
!**;[534], STATEFUNC @4090, DCE, 17-FEB-77
!**;[534], IN CASE THERE ARE PROBLEMS WITH THE FORMAT OF STK UNDER
!**;[534], A VARIETY OF BADLY FORMED STATEMENT FUNCTIONS, BE
!**;[534], MORE CAUTIOUS, AND ABORT IF THINGS LOOK SUSPICIOUS
%[534]% IF .STK<RIGHT> EQL 0 THEN RETURN -1;
%[534]% IF (.(T2_R1_@STK)<RIGHT>) EQL 0 THEN RETURN -1;
!**;[534], THE FOLLOWING STMNT CHECKS FOR .F AS FIRST 2 CHARS
!**;[534], WHERE THEY MAY OCCUR UNDER UNUSUAL SYNTACTIC PROBLEMS
!**;[534], IN THIS CASE, SIMPLY GET OUT, FOR WE ARE NOT SURE WHAT
!**;[534], STATE STK AND ITS SUCCESSORS MAY BE IN!
%[534]% IF .(T2[IDSYMBOL])<24,12> EQL SIXBIT ".F" THEN RETURN -1;
!**;[570], STATEFUNC @4092, DCE, 5-MAY-77
!**;[570], MUST GO IN ASCENDING ORDER TO CATCH ERRORS
%[570]% INCR I FROM 0 TO .STK<LEFT> DO
%[324]% BEGIN
%[324]% LOCAL BASE SAV;
%[324]% T2_ @(.R1)[.I];
!**;[570], STATEFUNC @4096, DCE, 5-MAY-77
!**;[570], BE SURE THAT WE ARE NOT INADVERTENTLY IN THE CONSTANT
!**;[570], TABLE RATHER THAN THE SYMBOL TABLE, E.G. FN(3,2)
%[570]% IF .T2[OPERSP] EQL CONSTANT
%[570]% THEN RETURN -1;
%[324]% SAV_ .T2[IDSYMBOL];
%[324]% T1_ .T2[CLINK];
!**;[417] STATEFUNC @ 4060, DCE, 5-AUG-76
!**;[417] MAKE SURE THAT IT IS A VARIABLE (NOT CONSTANT)
%[417]% IF .T2 NEQ 0 THEN
%[417]% (T2[IDSYMBOL]_.T1[IDSYMBOL];
%[417]% T1[IDSYMBOL]_.SAV)
%[324]% END;
%[324]% RETURN -1
%[324]% END;
BLDSFN(); !BUILD ASTATEFUNCTION NODE
ASTATFUN _ 0; !RESET SINCE PARSE IS FINISHED
RETURN
END;
!------------------------------------------------------------------------------------------------------------------
! AN ARRAY ASSIGNMENT WITH POSSIBLE MULTIPLE ASSIGNMENTS
!------------------------------------------------------------------------------------------------------------------
STMNDESC _ DSCASGNMT<0,0>; ! UPDATE THE STATEMENT DESCRIPTION
% SET ORDERING%
PSTATE _ PSTEXECU<0,0>;
IF .STALABL NEQ 0
THEN LABDEF(); ! ENTER THE LABEL IN THE LABEL TABLE
NAMSET(ARRAYNM1, .T2);
IF SYNTAX(ARRAYASSIGNSPEC) LSS 0 THEN RETURN -1;
T1_.STK[0];T2_.T1[ELMNT]; !T1_LIST BASE
INCR SCR FROM @T2 TO @T2+.T2<LEFT> DO
BEGIN
MAP BASE SCR;
MACRO SCRFLAGS=0,0,LEFT$,SCRCNT=0,0,LEFT$,SCRLOC=0,0,RIGHT$;
R1_.SCR[ELMNT];
SCR[SCRFLAGS]_0;SCR[SCRLOC]_.R1;!PTR TO SUBSCRIPT EXPRESSION
IF .R1[OPRCLS] EQL DATAOPR THEN SCR[P1AVALFLG]_1
ELSE
IF .R1[OPRCLS] EQL ARRAYREF THEN SCR[P1AVALFLG]_1;
END;
IF (T2_ARRXPND(@LNAME,@T2))LSS 0 THEN RETURN -1;
RETURN MULTIASGN(.T2) ! GIVE IT THE LEFT HAND SIDE
END;
END
ELUDOM