Trailing-Edge
-
PDP-10 Archives
-
AP-D480B-SB_1978
-
sta0.bli
There are 26 other files named sta0.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: F.J. INFANTE/HPW/ D. B. TOLMAN/DCE
MODULE STA0(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE META72.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;
GLOBAL BIND STA0V = 4^24+2^18+46; !VERSION DATE: 09-DEC-75
%(
REVISION HISTORY
44 ----- ----- CATCH ILLEGAL LIST DIRECTED RANDOM ACCESS
45 ----- ----- MOVE DO INDEX MODIFICATION CHECK TO NAMSET SO THAT
IT WILL GET ALL CASES OF MODIFICATION
46 336 17259 CHECK FOR ILLEGAL I/O LIST WITH NAMELIST
)%
!THE NUMBER IN COMMENT'S IS THE STATEMENTS LOCATION
!IN THE HASH TABLE .
FORWARD
MULTIASGN,
ASSIGNMENT, ! ASSIGNMENT
% 1% PUNCSTA, !PUNCH
% 38% CALLSTA, !CALL
% 49% GOTOSTA, !GOTO
% 53% PAUSSTA, !PAUSE
% 57% RETUSTA, !RETURN
% 73% ACCESTA, !ACCEPT
% 78% READSTA, !READ
% 90% WRITSTA, !WRITE
% 98% CONTSTA, !CONTINUE
%109% ASSISTA, !ASSIGN
%114% STOPSTA; !STOP
GLOBAL ROUTINE
MULTIASGN ( LEFTSIDE ) =
BEGIN
REGISTER BASE R1:R2;
EXTERNAL NEWENTRY %()%,SAVSPACE %(SIZE,LOC)%,STK,ASGNTYPER,LABLOFSTATEMENT;
EXTERNAL WARNLEX;
MACRO
EXPRBASE=1,0,FULL$;
NAME_IDOFSTATEMENT_ASGNDATA;NAME<RIGHT>_SORTAB;
R1_NEWENTRY();
R2_.STK[0];
R1[RHEXP]_.R2[ELMNT1] % EXPRESSION POINTER %;
R1[LHEXP]_R2_.LEFTSIDE;
ASGNTYPER(.R1); !CHECKING FOR ASSIGNMENT CONVERSION
R2 _ .R1[LHEXP]; !RESTORING EXP PTR INCASE OF TYPE CONVERSION NODE INSERTED
IF .R2[OPRCLS] EQL DATAOPR THEN R1[A1VALFLG]_1 ELSE R2[PARENT] _ .R1;
R2 _ .R1[RHEXP]; !RESTORE RH EXP PTR
IF .R2[OPRCLS] EQL DATAOPR THEN R1[A2VALFLG]_1
ELSE ( R2[PARENT] _ .R1; IF .R2[FNCALLSFLG] THEN R1[FNCALLSFLG] _1);
SAVSPACE(.STK[0]<LEFT>,@STK[0])
END;
GLOBAL ROUTINE
ASSIGNMENT =
BEGIN
EXTERNAL NAMSET,NAMDEF;
REGISTER BASE T1:T2;
EXTERNAL STK,SP,NEWENTRY %()%,SAVSPACE %(SIZE,LOC)%,MULTIASGN %()%,PROGNAME;
!------------------------------------------------------------------------------------------------------------------
! SYNTAX RETURNS A LIST POINTER (COUNT^18+LOC) IN STK[0]. THIS LIST CONTAINS:
!
! IDENTIFIER(20^18+LOC) - TO BE ASSIGNED
! POINTER TO LOGICAL EXPRESSION - (COUNT^18+LOC)
!
!------------------------------------------------------------------------------------------------------------------
T1_.STK[0]; !T1_LIST POINTER (COUNT^18+LOC)
T2_.T1[ELMNT]; !T2_LOC(IDENTIFIER)
% CHECK TO SEE IF ITS REALLY A VARIABLE %
IF NAMSET( VARIABL1, .T2 ) LSS 0 THEN RETURN .VREG;
% GENERATE THE ASSIGNMENT NODE %
MULTIASGN(.T2) ! GIVE IT THE LEFT HAND SIDE
END;
GLOBAL ROUTINE ASSISTA=
BEGIN
EXTERNAL SAVSPACE %(SIZE,LOC)%,BLDVAR %(VPNT)%,NEWENTRY %()%, ASIPTR,TBLSEARCH %()%,STK,TYPE,SETUSE,NAMSET;
MAP BASE ASIPTR;REGISTER BASE R1:R2;
!SEMANTIC ANALYSIS BEGINS
!--------------------------------------------------------------------------------
!THE CALL TO SYNTAX LEAVES A LIST POINTER ON THE STACK (STK[0]).
!THE POINTER POINTS TO THE LIST:
!
!LABEL (LABELEX^18+LOC) - THE LABEL TO BE ASSIGNED
!VARIABLESPEC - POINTER TO SCALAR OR ARRAY ELEMENT
!--------------------------------------------------------------------------------
R1_.STK[0]; !R1_LIST POINTER
% SET SETUSE FLAG FOR BLDVAR %
SETUSE _ SETT;
IF(STK[2]_R2_BLDVAR(.R1[ELMNT1])) LSS 0 THEN RETURN .VREG;
% BLDVAR ALLOWS ARRAYS WITHOUT SUBSCRIPTS SO DON'T LET THEM THROUGH HERE %
IF .R2<LEFT> EQL IDENTIFIER
THEN IF .R2[OPRSP1] EQL ARRAYNM1
THEN RETURN FATLEX ( R2[IDSYMBOL], ARPLIT<0,0>, E4<0,0> );
R2[IDATTRIBUT(INASSI)]_1;
NAME_IDOFSTATEMENT_ASSIDATA;NAME<RIGHT>_SORTAB;R2_NEWENTRY();
R2[ASILBL]_.R1[ELMNT];R2[ASISYM]_@STK[2];SAVSPACE(.R1<LEFT>,@R1);
IF .ASIPTR<LEFT> EQL 0 THEN ASIPTR<LEFT>_ASIPTR<RIGHT>_@R2
ELSE
BEGIN
ASIPTR[ASILINK]_@R2;ASIPTR<RIGHT>_@R2
END;
.VREG
END;
GLOBAL ROUTINE GOTOSTA=
BEGIN
EXTERNAL SAVSPACE %(SIZE,LOC)%,TBLSEARCH %()%,NEWENTRY %()%,STK,BLDVAR %(VPNT)%,SETUSE;
EXTERNAL EXPRTYPER,CNVNODE; !DOES TYPE CONVERSION IF NECESSARY
MACRO GETLAB =
INCR LLST FROM @STK[2] TO @STK[2]+.STK[2]<LEFT> DO
BEGIN
MAP BASE LLST;
LLST[ELMNT] _ .(@LLST[ELMNT])<RIGHT>
END
$;
LOCAL BASE T1; REGISTER BASE R1:T2:R2;
!SEMANTIC ANALYSIS BEGINS
!---------------------------------------------------------------------------------
!THE SYNTAX ROUTINE RETURNS A POINTER IN STK[0] TO THE LIST:
!
!CHOICE 1 - SIMPLE GOTO
! LABEL (LABELEX^18+LOC)
!CHOICE 2 - ASSIGNED OR COMPUTED GOTO
! CHOICE 1 - ASSIGNED GOTO
! COUNT^18+LOC - POINTER TO ASSIGNED VARIABLE AND LABEL LIST
! CHOICE 2 - COMPUTED GOTO
! COUNT^18+LOC - POINTER TO LABEL LIST AND CONTROL EXPRESSION
!
!SEE EXPANSION OF METASYMBOL GOTO FOR COMPLETE EXPANSION
!---------------------------------------------------------------------------------
R1_.STK[0]; !R1_LIST POINTER
IF .R1[ELMNT] EQL 1 THEN !CHOICE 1 - SIMPLE GOTO
BEGIN
NAME_IDOFSTATEMENT_GOTODATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
T1[GOTOLBL]_.R1[ELMNT1];T1[GOTONUM]_T1[GOTOLIST]_0;
RETURN
END;
!------------------------------------------------------------------------------
!AT THIS POINT WE HAVE EITHER A COMPUTED OR ASSIGNED GOTO.
!R1[ELMNT1] TELLS US WHICH. CHOICE 1 = ASSIGNED GOTO,
!CHOICE 2 = COMPUTED GOTO.
!------------------------------------------------------------------------------
R2_.R1[ELMNT2]; !R2_LOC (ASSIGNED OR COMPUTED GOTO COMPONENTS)
IF .R1[ELMNT1] EQL 1 THEN !ASSIGNED GOTO
BEGIN
SETUSE _ SETT; ! BLDVAR FLAG
IF (STK[1]_T1_BLDVAR(.R2[ELMNT])) LSS 0 THEN RETURN .VREG;
% CHECK BLDVAR RETURN FOR UNSUBSCRIPTED ARRAY REFERENCE %
IF .T1<LEFT> EQL IDENTIFIER
THEN IF T1[OPRSP1] EQL ARRAYNM1
THEN RETURN FATLEX ( T1[IDSYMBOL], ARPLIT, E4<0,0> ) ;
IF .R2[ELMNT1] NEQ 0 THEN !ASSIGNED GOTO WITH LABEL LIST
BEGIN
T1_.R2[ELMNT2];STK[2]_.T1[ELMNT1]; !SKIP OPTIONAL COMMA
GETLAB;
SAVSPACE(.R2[ELMNT2]<LEFT>,.R2[ELMNT2]);
STK[2]<LEFT> _ .STK[2]<LEFT>+1; !INCREMENT COUNT OF LABELS
END
ELSE STK[2]_0;NAME_IDOFSTATEMENT_AGODATA;
END
ELSE
BEGIN !COMPUTED GOTO
STK[2]_.R2[ELMNT];
GETLAB;
T2 _ STK[1] _.R2[ELMNT2]; !SKIP OPTIONAL COMMA
STK[2]<LEFT> _ .STK[2]<LEFT>+1; !INCREMENT COUNT OF LABELS
IF .T2[VALTYPE] NEQ INTEGER THEN STK[1] _ CNVNODE(.T2,INTEGER,0);
NAME_IDOFSTATEMENT_CGODATA;
END;
SAVSPACE(.R1<LEFT>,@R1);
NAME<RIGHT>_SORTAB;T1_NEWENTRY();
!PTR TO LABEL NUM OF LABELS INLIST PTR TO LIST
T1[GOTOLBL]_.STK[1];T1[GOTONUM]_.STK[2]<LEFT>;T1[GOTOLIST]_.STK[2]<RIGHT>;
T2_.T1[GOTOLBL]; IF .T2[OPRCLS] NEQ DATAOPR THEN T2[PARENT] _ .T1;
.VREG
END;
GLOBAL ROUTINE CALLSTA=
BEGIN
REGISTER T2=2;
REGISTER BASE T1; MAP BASE T2;REGISTER BASE R1:R2;
EXTERNAL E121;
EXTERNAL STK,SAVSPACE %(SIZE,LOC)%,CORMAN %()%,NEWENTRY %()%,TBLSEARCH %()%,NAMSET,NAMREF,NAMDEF;
MACRO
CARGPTR=0,0,RIGHT$,CAFLGFLD=0,0,LEFT$,
ERR15(X) = RETURN FATLEX(X,R2[IDSYMBOL],E15<0,0>) $;
MACHOP BLT=#251;
LOCAL BASE CALLNODE;
!SEMANTIC ANALYSIS BEGINS
!------------------------------------------------------------------------------------------------------------
!THIS ROUTINE EXPECTS TO RETURN A POINTER IN STK[0] TO A SUBROUTINE NAME OPTIONALLY FOLLOWED BY AN
!ARGUMENT LIST. SEE EXPANSION OF METASYMBOL CALL FOR DETAILS.
!------------------------------------------------------------------------------------------------------------
R1_.STK[0];
R2_.R1[ELMNT]; !R2_LOC(SUBROUTINE NAME)
% DEFINE AND CHECK THE FUNCTION NAME %
IF NAMREF( FNNAME1 , .R2 ) LSS 0 THEN RETURN .VREG;
IF .R2[IDATTRIBUT(SFN)] THEN RETURN FATLERR(.ISN,E121<0,0>);
STK[1]_.R2;
!
!MAKE A CALL STATEMENT NODE
!
NAME_IDOFSTATEMENT_CALLDATA;NAME<RIGHT>_SORTAB;CALLNODE _NEWENTRY();
IF .R1[ELMNT1] NEQ 0 THEN !ARGUMENT LIST
BEGIN
R2_STK[4]<0,0>;T1_@.R1[ELMNT2];
INCR ARG FROM @T1 TO @T1+.T1<LEFT> BY 2 DO
BEGIN
MAP BASE ARG:R2;
T2_.ARG[ELMNT1];
R2[CAFLGFLD]_0;R2[CARGPTR]_.T2;
IF .ARG[ELMNT] EQL 1 THEN !EXPRESSION
BEGIN
IF .T2[OPRCLS] EQL DATAOPR
THEN (R2[P1AVALFLG]_1;
IF .T2[OPRSP1] EQL ARRAYNM1
OR .T2[OPRSP1] EQL VARIABL1
THEN NAMSET(VARYREF, .T2 )
)
ELSE
BEGIN
T2[PARENT] _ .CALLNODE;
IF .T2[OPRCLS] EQL ARRAYREF
THEN NAMSET( ARRAYNM1, .T2[ARG1PTR])
END;
END
ELSE !STATEMENT NUMBER
BEGIN
R2[P1AVALFLG]_1;
END;R2_.R2+1;
END;T1_@.R1[ELMNT2];SAVSPACE(.T1<LEFT>,.T1); SAVSPACE(0,.R1[ELMNT2]);
STK[3]_.R2-STK[4]; STK[3]<LEFT> _ 0;
NAME<LEFT>_.STK[3]+2; R2_CORMAN();
T1<LEFT>_STK[3];T1<RIGHT>_@R2+1;T2_@R2+1+.STK[3];BLT(T1,0,T2);
END ELSE R2_0;
CALLNODE[CALSYM]_.STK[1];CALLNODE[CALLIST]_.R2;
FLGREG<BTTMSTFL>_0;
SAVSPACE(.R1<LEFT>,@R1);
.VREG
END;
GLOBAL ROUTINE RETUSTA=
BEGIN
REGISTER BASE T1:R2;
EXTERNAL STK,EXPRTYPER,SAVSPACE %(SIZE,LOC)%,NEWENTRY %()%;
EXTERNAL LSAVE,LEXL,LEXNAME,EXPRESS,CNVNODE;
LEXL_LEXEMEGEN(); LSAVE _ -1;
IF .LEXL<LEFT> NEQ LINEND
THEN
BEGIN
IF ( STK[0] _ EXPRESS() ) LSS 0
THEN RETURN .VREG;
IF .LEXL<LEFT> NEQ EOSLEX
THEN RETURN NOEOSERRL
END
ELSE STK[0] _ 0;
!SEMANTIC ANALYSIS BEGINS
!-----------------------------------------------------------------------------------------------------------
!THIS ROUTINE EXPECTS IN STK[0], A POINTER TO AN OPTIONAL RETURN EXPRESSION OR 0.
!-----------------------------------------------------------------------------------------------------------
NAME_IDOFSTATEMENT_RETUDATA;NAME<RIGHT>_SORTAB;R2_NEWENTRY();
R2[RETEXPR]_T1_.STK[0];
IF .T1 NEQ 0
THEN (IF .T1[OPRCLS] NEQ DATAOPR THEN T1[PARENT] _ .R2;
IF .T1[VALTYPE] NEQ INTEGER THEN R2[RETEXPR] _ CNVNODE(.T1,INTEGER,0);
);
.VREG
END;
GLOBAL ROUTINE CONTSTA=
BEGIN
EXTERNAL NEWENTRY;
IF LEXEMEGEN() NEQ LINEND^18 THEN RETURN NOEOSERRV;
!SEMANTIC ANALYSIS BEGINS
NAME _ IDOFSTATEMENT _ CONTDATA; NAME<RIGHT>_SORTAB; NEWENTRY();
.VREG
END;
GLOBAL ROUTINE LITOROCT=
BEGIN
!
!PARSES OPTIONAL [LITERAL OR OCTAL STRING ] AFTER STOP OR PAUSE
!RETURNS LEXEME FOR EITHER
!
REGISTER R2;
EXTERNAL GSTOPOBJ,STLEXEME,LEXICAL;
IF ( R2_LEXICAL( .GSTOPOBJ )) EQL 0
THEN
BEGIN % ITS NOT A DIGIT OR ' %
IF LEXICAL (.GSTLEXEME ) NEQ EOSLEX^18
THEN
BEGIN % AND ITS NOT ENDOF STATEMENT EITHER %
RETURN FATLEX( PLIT'OCTAL DIGIT STRING OR ''TEXT''?0',LEXPLITV,E0<0,0>)
END
% ELSE EOS IS OK %
END
ELSE
BEGIN % MAKE SURE THAT THERE WERE NO ERRORS IN THE OBJECT %
IF .R2 EQL EOSLEX^18
THEN RETURN -1; ! SOME SORT OF ERROR OCCURED
%OTHERWISE ITS AN OCTAL OR LITERAL
WHICH MUST BE FOLLOWED BY EOS %
IF LEXICAL(.GSTLEXEME) NEQ EOSLEX^18
THEN RETURN NOEOSERRV
END;
RETURN .R2
END; % LITOROCT %
GLOBAL ROUTINE STOPSTA=
BEGIN
REGISTER BASE R1:R2;
EXTERNAL STK,SAVSPACE %(SIZE,LOC)%,NEWENTRY %()%,LITOROCT;
IF (R2 _ LITOROCT()) LSS 0 THEN RETURN -1;
NAME_IDOFSTATEMENT_STOPDATA;NAME<RIGHT>_SORTAB;R1_NEWENTRY();
R1[STOPIDENT]_@R2;
.VREG
END;
GLOBAL ROUTINE PAUSSTA=
BEGIN
REGISTER BASE R1:R2;
EXTERNAL STK,SAVSPACE %(SIZE,LOC)%,NEWENTRY %()%,LITOROCT;
IF (R2 _ LITOROCT()) LSS 0 THEN RETURN -1;
NAME_IDOFSTATEMENT_PAUSDATA;NAME<RIGHT>_SORTAB;R1_NEWENTRY();
R1[PAUSIDENT]_.R2;
.VREG
END;
GLOBAL ROUTINE RWBLD(NODEDATA)=
BEGIN
REGISTER BASE T1;REGISTER BASE R1:R2;
EXTERNAL STK,SAVSPACE %(SIZE,LOC)%,BLDUNIT %(VPNT)%,BLDFORMAT %(FPNT)%,
IODOXPN,DATALIST %(LPNT)%,TYPE,CORMAN %()%,NEWENTRY %()%;
LOCAL U,R,F,ER,EN;
MAP BASE U;
%
ROUTINE BUILDS A READ OR WRITE STATEMENT NODE
CALLED FROM READST OR WRITST WITH READ OR WRITE DATA
DOESN'T RETURN ANYTHING SIGNIFICANT EXCEPT WHEN ERROR CONDITION
THEN RETURNS -1
%
!----------------------------------------------------------------------------------------------------------
!THIS ROUTINE EXPECTS SYNTAX TO RETURN A POINTER IN STK[0] TO A
!FULL UNIT SPECIFICATION (UNIT, RECORD NUMBER, FORMAT, END AND ERR) OR
!A FORMAT SPECIFICATION (FORMAT, END AND ERR) FOLLOWED BY AN OPTIONAL
!IO LIST. SEE EXPANSIONS OF THE METASYMBOLS READSPEC, IOSPEC,
!FORMAT ID AND DATAITEM FOR DETAILS.
!----------------------------------------------------------------------------------------------------------
R1_.STK[0];
IF .R1[ELMNT] EQL 1 THEN !FULL UNIT SPECIFICATION
BEGIN
IF BLDUNIT(.R1[ELMNT1]) LSS 0 THEN RETURN .VREG;
END
ELSE !FORMAT SPECIFICATION
BEGIN
STK[4]_0;STK[5]_STK[6]_0; !SET FORMAT,END,ERR TO ZERO
R1 _.R1+1; !SET PTR TO POINT TO FORMATSPEC EXPECTED BY BLDFORMAT IN ACT1
FLAG _ -1; !SIGNAL BLDFORMAT NOT TO EXPECT AN END= OR ERR=
IF BLDFORMAT (.R1) LSS 0 THEN RETURN .VREG;
STK[2]_ IF .NODEDATA EQL READDATA THEN MAKECNST(INTEGER,0,-5) ELSE MAKECNST(INTEGER,0,-3); !READID OR PRINT ID
STK[3]_0;!CLEAR RECORD, INDICATE READ FROM STANDARD DEVICE
END;
IF .STK[3] NEQ 0
THEN
BEGIN
EXTERNAL FATLEX,E101;
R_@.STK[3];
%LETS NOT HAVE ANY LIST DIRECTED RANDOM ACCESS%
IF .STK[4] EQL -1
THEN FATLEX( PLIT'RANDOM ACCESS?0',E101<0,0>)
END
ELSE R _ 0;
U_.STK[2];F_.STK[4];ER_.STK[5];EN_.STK[6];
IF .R1[ELMNT2] NEQ 0 THEN !IO LIST
BEGIN
!**;[336],RWBLD @3802, DCE, 09-DEC-75
![336], TEST FOR NAMELIST I/O - IT IS ILLEGAL WITH I/O LIST!
%[336]% EXTERNAL FATLEX,E102;
%[336]% REGISTER BASE SNAME;
%[336]% SNAME_.F;
%[336]% IF .SNAME NEQ -1 THEN
%[336]% IF .SNAME[IDATTRIBUT(NAMNAM)] EQL 1
%[336]% THEN FATLEX(E102<0,0>);
R2_.R1[ELMNT3]; SAVSPACE(.R1[ELMNT3]<LEFT>,.R1[ELMNT3]);
IF (R2 _ DATALIST(.R2[ELMNT1])) LSS 0 THEN RETURN .VREG;
END
ELSE
BEGIN %NO IOLIST%
IF .F EQL -1 THEN RETURN FATLEX(E96<0,0>);
% LIST DIRECTED WITH NO IOLIST%
R2_0;
END;
NAME _IDOFSTATEMENT_.NODEDATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
T1[IOUNIT]_.U;T1[IOFORM]_.F;T1[IORECORD]_.R;T1[IOLIST]_.R2<LEFT>;
T1[IOERR]_.ER;T1[IOEND]_.EN;
IODOXPN(.T1); !DO DOXPN FOR IOLIST
IF .U[CONST2] LSS 0 THEN R1 _ .R1-1; !UNDO INCREMENT IF FORMAT WITHOUT A UNIT
SAVSPACE(.R1<LEFT>,@R1);
.VREG
END;
GLOBAL ROUTINE READSTA=
BEGIN
!SEMANTIC ANALYSIS BEGINS
!
TYPE _ READD; !FLAG FOR DATALIST
RWBLD(READDATA); !BUILD READ/WRITE NODE
.VREG
END;
GLOBAL ROUTINE ACCESTA=
BEGIN
REGISTER BASE T1;
EXTERNAL BLDIO1;
T1 _ BLDIO1(READDATA); !BUILD A READ NODE
T1[IOUNIT] _ MAKECNST(INTEGER,0,-4); !ACCEPT ID
.VREG
END;
GLOBAL ROUTINE PUNCSTA=
BEGIN
REGISTER BASE T1;
EXTERNAL BLDIO1;
T1 _ BLDIO1(WRITDATA); !BUILD A WRITE (PUNCH) NODE
T1[IOUNIT] _ MAKECNST(INTEGER,0,-2); !PUNCH PAPER TAPE ID
.VREG
END;
GLOBAL ROUTINE WRITSTA=
BEGIN
!SEMANTIC ANALYSIS BEGINS
TYPE _ WRITEE; ! FLAG FOR DATALIST
RWBLD(WRITDATA); !BUILD A WRITE IO STATEMENT NODE
.VREG
END;
END
ELUDOM