Trailing-Edge
-
PDP-10 Archives
-
AP-D480B-SB_1978
-
sta1.bli
There are 12 other files named sta1.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/SJW/DCE
MODULE STA1(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
! LEXNAM, FIRST, TABLES, META72, ASHELP
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE META72.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;
GLOBAL BIND STA1V = 5^24 + 1^18 + 66; !VERSION DATE: 13-JAN-77
%(
REVISION HISTORY
57 ----- ----- FIX COMPLEX CONSTANTS IN DATA STATEMENTS SO THAT
THE ENTIRE CONSTANT CAN BE SIGNED
58 ----- ----- OPENCLOSE - FIX BUG THAT UNIT = WOULD DESTROY
THE CODE OF THE LAST PARAMETER .
AND WHILE WE ARE THERE FIX UP A FEW PARAMETER
VALUE LEGALITY CHECKS
59 ----- ----- CHECK FOR ILLEGAL LIST DIRECTED REREAD
60 ----- ----- IN DATAGEN - MUST CHECK THE SIGN OF THE
REPEAT COUNT ITSELF NOT JUST SIGNFLG
BECAUSE OF POSSIBLE NEGATIVE PARMETERS
61 ----- ----- FIX ERROR MESSAGE CALL FOR NON-ARRAY OPEN
STATEMENT PARAMETER VALUES
62 313 16666 FIX DIALOG WITH NO =
63 VER5 ----- HANDLE ERR= IN OPENCLOSE
64 424 QA690 ERROR IF DIRECTORY= NOT LITERAL OR ARRAY
NAME IN OPENCLOSE
BEGIN VERSION 5A, 7-NOV-76
65 521 QA900 FIX E15 PARAMS TO FATLEX IN OPENCLOSE
66 531 20323 GIVE WARNING FOR PARAMETER USED AS ASSOC VAR
)%
!THE NUMBER IN COMMENT'S IS THE STATEMENTS LOCATION
!IN THE HASH TABLE .
FORWARD
% 3% DATASTA, !DATA
% 8% PRINSTA, !PRINT
% 18% OPENSTA, !OPEN
% 34% FINDSTA, !FIND
% 39% REWISTA, !REWIND
% 45% RERESTA, !REREAD
% 63% BKSPST, !BACKSPACE OR BACKFILE
% 67% DECOSTA, !DECODE
% 83% CLOSSTA, !CLOSE
% 84% ENDFSTA, !ENDFILE
% 95% ENCOSTA, !ENCODE
%113% TYPESTA; !TYPE
GLOBAL ROUTINE BLDUTILITY(NODEDATA)=
BEGIN
%
ROUTINE BUILDS A STATEMENT NODE FOR REWIND AND UNLOAD STATEMENTS
STK[0] CONTAINS A PTR TO A PTR TO A BLOCK OF 2WORDS
1. CHOICE 1(CONSTANT) OR 2(VARIABLE)
2. PTR TO CONSTANT NODE OR SYNTAX OUTPUT FROM PARSE OF VARIABLESPEC
BLDVAR IS CALLED IF CHOICE 2 TO BUILD A VARIABLE REFERENCE NODE
%
EXTERNAL NAME,NEWENTRY,STK,SAVSPACE,BLDVAR,SETUSE;
REGISTER BASE T1;
REGISTER BASE R2;
MACRO ERR55=(FATLEX(E55<0,0>))$;
T1_@(.STK[0]+1);
SETUSE _ USE; ! FLAG FOR BLDVAR
IF .T1[ELMNT] NEQ 1
THEN
BEGIN
R2_ BLDVAR(.T1[ELMNT1]);
% 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> );
END
ELSE R2 _ .T1[ELMNT1];
IF .R2[VALTYPE] NEQ INTEGER THEN ERR55; !NON-INTEGER UNIT
NAME _ IDOFSTATEMENT _ .NODEDATA; NAME<RIGHT> _ SORTAB;
T1 _ NEWENTRY(); !MAKING SORCE NODE
T1[IOUNIT] _ .R2;
SAVSPACE(.STK[0]<LEFT>,.STK[0]);
END; !OF BLDUTILITY
GLOBAL ROUTINE BLDIO1(NODEDATA)= !BUILDS AN IO NODE FOR TYPE,PRINT,PUNCH,ACCEPT,BACKSPACE,BACKFILE,ENDFILE,SKIPFILE,SKIPRECORD
BEGIN
REGISTER BASE T1;REGISTER BASE R1:R2;
EXTERNAL STK,SAVSPACE %(SIZE, LOC)%,BLDFORMAT %(FPNT)%,DATALIST %(LPNT)%,
NEWENTRY %()%,TYPE,IODOXPN;
LOCAL F;
!----------------------------------------------------------------------------------------------------------
!THIS ROUTINE EXPECTS SYNTAX TO RETURN A POINTER IN STK[0] TO A
!FORMAT SPECIFICATION AND AN OPTIONAL IO LIST. SEE EXPANSIONS OF
!METASYMBOLS PRINT, FORMATID, AND DATAITEM FOR DETAILS.
!----------------------------------------------------------------------------------------------------------
R1_.STK[0];
TYPE_IF .NODEDATA EQL WRITDATA THEN WRITEE ELSE READD %READ AND REREAD % ;
!ABOVE FOR SETTING FLAG (STORD) IN LIST ITEMS SYMBOL TABLE ENTRIES
FLAG _ -1; !FLAG SAYS DON'T LOOK FOR END= IN BLDFORMAT
STK[4] _ 0; ! CLEAR THE FORMAT RETURN SPOT
IF BLDFORMAT(.R1) LSS 0 THEN RETURN .VREG;
F_.STK[4];
IF .R1[ELMNT2] NEQ 0 THEN !I/O LIST
BEGIN
R2_.R1[ELMNT3]; !GET PTR TO I/O LIST PTRS
!
!GENERATE LINKED LIST OF I/O NODES
!
IF (R2 _ DATALIST(.R2[ELMNT])) LSS 0 THEN RETURN .VREG;
END
ELSE
BEGIN % NO IOLIST%
IF .F EQL -1 THEN RETURN FATLEX(E96<0,0>);
%NO IO LIST FOR LIST DIRECTED IO%
R2_0;
END;
SAVSPACE(.R1<LEFT>,.R1);
NAME_IDOFSTATEMENT_.NODEDATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
T1[IOFORM]_.F;
T1[IORECORD]_0;T1[IOLIST]_.R2<LEFT>;
IODOXPN(.T1); !DO XPN FOR IOLISTS
RETURN .T1
END;
GLOBAL ROUTINE PRINSTA=
BEGIN
REGISTER BASE T1;
!SEMANTIC ANALYSIS BEGINS
T1 _ BLDIO1(WRITDATA); !BUILDS THE PRINT STAEMENT IO NODE
T1[IOUNIT]_MAKECNST(INTEGER,0,-3); !PRINTID
.VREG
END;
GLOBAL ROUTINE TYPESTA=
BEGIN
REGISTER BASE T1;
!SEMANTIC ANALYSIS BEGINS
T1 _ BLDIO1(WRITDATA);
T1[IOUNIT] _ MAKECNST(INTEGER,0,-1); !TYPE ID
.VREG
END;
GLOBAL ROUTINE BLDEDCODE(NODEDATA)=
BEGIN
REGISTER BASE T1;REGISTER BASE R1:R2;
EXTERNAL STK,SAVSPACE %(SIZE,LOC)%, BLDFORMAT %(FPNT)%,BLDVAR %(VPNT)%,
IODOXPN,DATALIST %(LPNT)%,TYPE,CORMAN %()%,NEWENTRY %()%;
EXTERNAL SETUSE,STMNDESC;
MACRO ERR15(X)=RETURN FATLEX( INTGPLIT<0,0>, X, E15<0,0> )$;
LOCAL CH,F,B;
!----------------------------------------------------------------------------------------------------------
!THIS ROUTINE EXPECTS SYNTAX TO RETURN A POINTER IN STK[0] TO AN
!ENCODE/DECODE SPECIFICATION (CHARACTERS,FORMAT,BUFFER) FOLLOWED BY
!AN I/O LIST. SEE EXPANSIONS OF METASYMBOLS ENCODE, ENCODECODESPEC,
!EXPRESSION, FORMATID, VARIABLESPEC AND DATAITEM FOR DETAILS.
!----------------------------------------------------------------------------------------------------------
R1_.STK[0];
R2_.R1[ELMNT];
IF .R2[VALTYPE] NEQ INTEGER THEN ERR15 (PLIT SIXBIT 'COUNT');
CH_@R2;
!
!BLDFORMAT RETURNS RESULTS IN STK[4]
!
STK[4]_ 0;
FLAG _ 1; ! NO END= OR ERR= FLAG TO BLDFORMAT
IF BLDFORMAT(R1[ELMNT1]) LSS 0 THEN RETURN .VREG; !NOTE NON-DOTTED PARAMETER
IF (F_.STK[4]) EQL -1 THEN RETURN FATLEX(KEYWRD(@STMNDESC),E101<0,0>);
%NO LIST DIRECTED ENCODE/DECODE%
SETUSE _ IF .TYPE EQL WRITEE THEN SETT ELSE USE; !FLAG FOR BLDVAR
IF (B_BLDVAR(.R1[ELMNT3])) LSS 0 THEN RETURN .VREG;
IF .R1[ELMNT4] NEQ 0
THEN
BEGIN
IF (R2 _ DATALIST(.R1[ELMNT5])) LSS 0 THEN RETURN .VREG
END
ELSE R2 _ 0; ! NO IOLIST
NAME_IDOFSTATEMENT_.NODEDATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
T1[IOUNIT]_.B;T1[IOFORM]_.F;T1[IORECORD]_.CH;T1[IOLIST]_.R2<LEFT>;
IODOXPN(.T1); !DO DOXPN FOR IOLIST
SAVSPACE(.R1<LEFT>,@R1);
.VREG
END;
GLOBAL ROUTINE ENCOSTA=
BEGIN
!SEMANTIC ANALYSIS BEGINS
TYPE _ WRITEE; !FLAG FOR DATALIST
BLDEDCODE(ENCODATA); !BUILD AN ENCODE STATEMENT NODE
.VREG
END;
GLOBAL ROUTINE DECOSTA=
BEGIN
!SEMANTIC ANALYSIS BEGINS
TYPE _ READD; ! FLAG FOR DATALIST
BLDEDCODE(DECODATA); !BUILD A DECODE STATEMENT NODE
.VREG
END;
GLOBAL ROUTINE RERESTA=
BEGIN
REGISTER BASE T1;
EXTERNAL STMNDESC,FATLEX,E101;
!SEMANTIC ANALYSIS BEGINS
!
T1 _ BLDIO1(REREDATA);
IF .T1[IOFORM] EQL #777777
THEN FATLEX(KEYWRD(@STMNDESC),E101<0,0>);
%NO LIST DIRECTED REREADS%
T1[IOUNIT] _ MAKECNST(INTEGER,0,-6); !RE READ ID
.VREG
END;
GLOBAL ROUTINE BKSPST=
BEGIN
EXTERNAL BLDREPT;
REGISTER R;
BIND DUM = PLIT( SP NAMES 'SPACE?0', FIL NAMES 'FILE?0' );
R _ BACKDATA;
LOOK4CHAR _ SP<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 _ BKFILDATA; ! TRY FILE
LOOK4CHAR _ FIL<36,7>
END;
RETURN FATLEX(E12<0,0>); !MISSPELLED
END;
GLOBAL ROUTINE REWISTA=
BEGIN
!SEMANTIC ANALYSIS BEGINS
BLDUTILITY(REWIDATA); !BUILD A REWIND STATEMENT NODE
.VREG
END;
GLOBAL ROUTINE ENDFSTA=
BEGIN
!SEMANTIC ANALYSIS BEGINS
BLDUTILITY(ENDFDATA); !BUILD AN ENDFILE STATEMENT NODE
.VREG
END;
GLOBAL ROUTINE FINDSTA=
BEGIN
REGISTER BASE T1; REGISTER BASE R1:R2;
EXTERNAL STK,SAVSPACE %(SIZE,LOC)%,BLDVAR %(VPNT)%,NEWENTRY %()%;
EXTERNAL SETUSE;
MACRO ERR15(X) = RETURN FATLEX( INTGPLIT<0,0>, X, E15<0,0> ) $;
!SEMANTIC ANALYSIS BEGINS
!----------------------------------------------------------------------------------------------------------
!THIS ROUTINE EXPECTS SYNTAX TO RETURN A POINTER IN STK[0]
!TO A UNIT NUMBER (INTEGER CONSTANT OR VARIABLE) FOLLOWED
!BY A RECORD NUMBER. SEE EXPANSIONS OF METASYMBOLS FIND,
!VARIABLESPEC AND EXPRESSION FOR DETAILS.
!----------------------------------------------------------------------------------------------------------
R1_.STK[0];R2_.R1[ELMNT1]; !R2_LOC (CONSTANT OR VARIABLE)
IF .R1[ELMNT]EQL 1 THEN !CONSTANT
BEGIN
IF .R2[VALTYPE] NEQ INTEGER THEN ERR15(PLIT SIXBIT'UNIT');
END
ELSE !VARIABLE
BEGIN
T1_.R2[ELMNT]; !T1_LOC (IDENTIFIER)
IF .T1[VALTYPE] NEQ INTEGER THEN ERR15(T1[IDSYMBOL]);
SETUSE _ USE; !BLDVAR FLAG
IF (R2_BLDVAR(@R2)) LSS 0 THEN RETURN .VREG;
END;
NAME_IDOFSTATEMENT_FINDDATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
T1[IOUNIT]_@R2;T1[IOFORM]_0;
T1[IORECORD]_.R1[ELMNT2];T1[IOLIST]_0;
T1[IOERR]_T1[IOEND]_0;
SAVSPACE(.R1<LEFT>,@R1);
.VREG
END;
ROUTINE CMPLXCONGEN(PTR , SIGNN )= !BUILDS A COMPLEX ONSTANT NODE FROM DATA LIST
!SEMANTIC OUTPUT
BEGIN
REGISTER SIGNFLG;
LOCAL BASE REALPT :IMAGPT;
EXTERNAL CNSTCM,C1H,C1L,C2H,C2L,COPRIX,KDPRL,KDNEGB,KTYPCB;
REGISTER BASE T1:T2;
ROUTINE SIGNEDREAL(CONST)=
%(****************************
GIVEN A PTR TO A CONSTANT TABLE ENTRY FOR THE REAL OR
IMAGINARY PART OF A COMPLEX CONST, (WHERE THAT PART MAY
ITSELF BE ANY TYPE) RETURN THE SINGLE-WD REAL
VALUE TO BE USED FOR THAT PART OF THE CONSTANT.
THE REGISTER-VARIABLE "SIGNFLG" IS ASSUMED TO BE "TRUE"
IF THE CONSTANT INDICATED BY "CONST" SHOULD BE NEGATED.
SIGNN - IS THE SIGN OF THE TOTAL CONSTANT
*******************************)%
BEGIN
MAP PEXPRNODE CONST;
C1H_.CONST[CONST1]; !HI ORDER PART
C1L_.CONST[CONST2]; !LOW ORDER PART
%(***IF CONST IS NOT REAL, CONVERT IT TO REAL. THE CONSTANT FOLDING
ROUTINE TAKES ITS ARG IN THE GLOBALS C1H,C1L***)%
IF .CONST[VALTYPE] NEQ REAL
THEN
BEGIN
COPRIX_KKTPCNVIX(REAL2,.CONST[VALTP2]); !INDEX INTO CONSTNT FOLDER
! FOR THE TYPE-CONV DESIRED
CNSTCM(); !CONVERT THE CONST IN C1H,C1L
! LEAVING RESULT IN C2H,C2L;
C1H_.C2H;
C1L_.C2L
END;
%(***ROUND THE 2 WD REAL TO A SINGLE-WD REAL***)%
IF .CONST[VALTYPE] NEQ DOUBLOCT
THEN
BEGIN !DONT ROUND DOUBLE-OCTAL
COPRIX_KDPRL; !INDEX INTO THE CONST FOLDER FOR ROUNDING
! DOUBLE-WD REAL TO SINGLE-WD REAL
CNSTCM(); !ROUND THE DOUBLE-WD REAL IN C1H-C1L, LEAVING
! RESULT IN C2H
C1H_ .C2H
END;
%(***IF THE VALUE SHOULD BE NEGATED, DO SO***)%
IF .SIGNFLG
THEN RETURN -.C1H
ELSE RETURN .C1H
END;
%(***PROCESS REAL PART**)%
T1 _ .PTR;
SIGNFLG _ .SIGNN;
IF .T1[ELMNT] NEQ 0 !IS IT SIGNED?
THEN
(IF .T1[ELMNT] EQL 2 THEN SIGNFLG _ -1 -.SIGNN;
T1_.T1+1;
);
REALPT_SIGNEDREAL(.T1[ELMNT1]);
%(***PROCESS IMAGINARY PART**)%
SIGNFLG _ .SIGNN;
T1_.T1+2; !SKIP TO IMAG PART
IF .T1[ELMNT] NEQ 0
THEN (IF .T1[ELMNT] EQL 2 THEN SIGNFLG_ -1 -.SIGNN;
T1_.T1+1;
);
IMAGPT _ SIGNEDREAL(.T1[ELMNT1]);
!NOW MAKE ACOMPLEX CONSTANT NODE
RETURN MAKECNST(COMPLEX,.REALPT,.IMAGPT);
END; !OF ROUTINE CPLXCONGEN
GLOBAL ROUTINE DATAGEN(CONLIST)=
BEGIN
EXTERNAL CORMAN,NAME,SAVSPACE;
LOCAL REPEAT,COUNT,DATCSIZ,SIGNFLG;
LOCAL BASE CONNODE :CONPTR;
LABEL DAT1;
MACRO ERR54 = ( FATLEX(E54<0,0>))$;
EXTERNAL CNSTCM,C1H,C1L,C2H,C2L,COPRIX,KDPRL,KDNEGB;
MACRO DNEG(X,Y)=
BEGIN
C1H _ X[CONST1]; !HIGH ORDER
C1L _ X[CONST2]; !LOW ORDER
COPRIX _ KDNEGB + .CKA10FLG;
CNSTCM(); !CONVERT TO NEG
MAKECNST(Y,.C2H,.C2L)
END$;
MACRO DDATCONNODE =
BEGIN
NAME<LEFT> _ 2; CONNODE _ CORMAN();
IF .CONPTR EQL 0
THEN (CONPTR<LEFT> _ CONPTR<RIGHT> _ .CONNODE)
ELSE (CONPTR[CLINK] _ .CONNODE;
CONPTR<RIGHT> _.CONNODE;
);
END$;
REGISTER BASE T1:T2; MAP BASE CONLIST;
%
ROUTINE BUILDS A LIST OF DATA CONSTANTS AND KEEPS COUNT FOR LATER USE
BY THE DATA LIST PROCESSING ROUTINES
%
CONPTR _ 0; COUNT _ 0;
INCR CONITEM FROM .CONLIST TO .CONLIST+.CONLIST<LEFT> BY 2 DO
BEGIN
MAP BASE CONITEM;
REPEAT _ 1; !INITIALIZE
SIGNFLG _ 0;
!SEE IF CONSTANT IS LITERAL OR NUMBER
DAT1: IF .CONITEM[ELMNT] EQL 1
THEN !NUMBER
BEGIN
T1 _ .CONITEM[ELMNT1]; !PTR TO 2 OR 3 WORD SET CONST [* CONST]
IF .T1[ELMNT] NEQ 0
THEN( !SIGHNED CONSTANT
IF .T1[ELMNT] EQL 2 !MINUS
THEN SIGNFLG_-1 ELSE SIGNFLG_0;
T1 _ .T1+1;! TO GET PAST THE SIGN
)
ELSE SIGNFLG _ 0;
%NOW DECIDE WHETHER WE HAVE A CONSTANT OR COMPLEX CONSTANT%
IF .T1[ELMNT1] EQL 2
THEN
BEGIN %COMPLEX CONSTANT%
T2 _ CMPLXCONGEN( .T1[ELMNT2] , .SIGNFLG );
COUNT _ .COUNT + 2;
SIGNFLG _ 0; !COMPLEX SIGNS ARE DONE
END
ELSE
BEGIN %ITS AN INTEGER OR REAL%
T1 _ .T1[ELMNT2]; !POINTER TO CONSTANT-OPTION
T2 _ .T1[ELMNT]; !PTR TO FIRST CONSTANT OR REPEAT COUNT
IF .T1[ELMNT1] NEQ 0
THEN (!REPEAT FACTOR T2 POINTS TO REPEAT CONST
IF .T2[VALTYPE] NEQ INTEGER
THEN (ERR54; REPEAT _ 0; LEAVE DAT1);
%DO THIS IN CASE OF NEGATIVE PARAMETER VALUES%
IF .SIGNFLG NEQ 0
THEN T2 _ MAKECNST(INTEGER,0,-.T2[CONST2]);
IF .T2[CONST2] LSS 0 THEN (ERR54; REPEAT _ 0; LEAVE DAT1);
REPEAT _ .T2[CONST2]; !REPEAT VALUE
T1 _ .T1[ELMNT2]; !PTR TO REPEATED CONST OR LITERAL
T2 _ .T1[ELMNT2]; !PTR TO ACTUAL CONSTANT OR LITSTRING NODE
IF .T1[ELMNT1] EQL 1
THEN !NUMBER
(
IF .T2[ELMNT] NEQ 0
THEN (!SIGNED NUMBER
IF .T2[ELMNT] EQL 2
THEN SIGNFLG_-1 ELSE SIGNFLG_0;
T2 _ .T2+1
)
ELSE SIGNFLG _ 0;
%NOW WHAT KIND OF CONSTANT DO WE HAVE%
IF .T2[ELMNT1] EQL 2
THEN
BEGIN %COMPLEX%
T2_ CMPLXCONGEN( .T2[ELMNT2] , .SIGNFLG );
COUNT _ .COUNT+2;
SIGNFLG _ 0
END
ELSE
BEGIN %REAL OR INTEGER OR DOUBLE%
T2 _ .T2[ELMNT2]; !CONSTANT LEXEME
DATCSIZ _ IF .T2[DBLFLG] THEN 2 ELSE 1
END
)
ELSE !LITERAL
DATCSIZ _ .T2[LITSIZ]
)
ELSE ( %NO REPEAT%
DATCSIZ _ IF .T2[DBLFLG] THEN 2 ELSE 1;
);
COUNT _ .COUNT + .DATCSIZ * .REPEAT;
IF .SIGNFLG NEQ 0
THEN IF .T2[VALTP1] EQL INTEG1
THEN T2 _ MAKECNST(INTEGER,0,-.T2[CONST2])
ELSE T2 _ DNEG(.T2,.T2[VALTYPE]); !NEGATE THE NUMBER
END % CONSTANT OR COMPLEX %
END
ELSE !LITERAL
BEGIN
T2 _ .CONITEM[ELMNT1]; !PTR TO LITERAL STRING NODE
COUNT _ .COUNT + .T2[LITSIZ];
END;
DDATCONNODE; !BUILD AND LINK A DATA CONSTANT NODE
CONPTR[DATARPT] _ .REPEAT;
CONPTR[DCONST] _ .T2;
END; !OF INCR LOOP
RETURN .COUNT^18+ .CONPTR<LEFT>;
END;
GLOBAL ROUTINE DATASTA=
BEGIN
REGISTER BASE T1;
REGISTER BASE R1:R2;
LOCAL ITEMLIST,CONLIST;
EXTERNAL DATAGEN %(LOC,SIZE)%,SAVSPACE %(SIZE,LOC)%,STK,SP,DATALIST,TYPE,NEWENTRY;
EXTERNAL DATASUBCHK;
!SEMANTIC ANALYSIS BEGINS
[email protected][0]; !T1_LOC(DATASPEC OR LIST A,LINEND)
INCR DAT FROM .T1 TO .T1+.T1<LEFT> DO
BEGIN !PROCESS LIST OF DATA SPECIFICATIONS
MAP BASE DAT;
R1 _ .DAT[ELMNT]; !PTR TO 2 ITEM LIST - 1.DATALIST PTR
! 2.CONLIST PTR
T1 _ .R1[ELMNT1]; !PROCESS CONLIST PTR FIRST FO COUNT NUMBER OF CONSTANTS
!T1 POINTS TO 3 WORD LIST (SLASH,CONLISTPTR,SLASH)
R2 _ .T1[ELMNT1]; !GET PTR TO LIST OF CONSTANT SPECS
SAVSPACE (.T1<LEFT>,.T1); !GET BACK SPACE
CONLIST _ DATAGEN(.R2);
SAVSPACE(.R2<LEFT>,.R2);
!
!NOW PROCESS LIST OF DATA ITEM SPECIFICATIONS
!USE THE SAME ROUTINE AS USED BY IO LISTS AND RETURN PTR
!TO SAME KIND OF LIST STRUCTURE AS IO LISTS
!
TYPE _ DATALST; !SIGNAL DATA STATEMENT TO DATALIST ROUTINE
SP _ 0; !RESET FOR USE IN DATALIST
ITEMLIST _ DATALIST(.R1[ELMNT]); !USEING FIRST ITEM POINTED TO BY R1
DATASUBCHK(.ITEMLIST<LEFT>,0,0); !CHECK SUBSCRIPTS ON LIST ITEMS FOR VALIDITY
SAVSPACE(.R1<LEFT>,.R1); !RETRIEVE SOME SPACE
!
!NOW BUILD A DATA STATEMENT NODE AND LINK TO ANY PREVIOUS ONES
!
NAME _ DATATAB; !ID OF DATA TABLE FOR NEWENTRY
R2 _ NEWENTRY();
!FILL IN PTRS TO LISTS IN DATA NODE
!
R2[DATITEMS] _ .ITEMLIST<LEFT>; R2[DATCONS] _ .CONLIST;
R2[DATCOUNT] _ .CONLIST<LEFT>; !NUMBER OF CONSTANTS SPECIFIED
R2[DATISN]_.ISN; !STMNT NUMBER (NEEDED FOR ERROR MESSAGES
! IN ALLOCATION ROUTINE)
END; !OF INCR LOOP
T1 _ @.STK[0]; SAVSPACE(.T1<LEFT>,.T1); SAVSPACE(0,.STK[0]);
.VREG
END; !OF DATASTA
GLOBAL ROUTINE STRNGSCAN= !STRING SCAN
!PUTS A STRING OF UP TO 6 SIXBIT CHARACTERS
!IN SIX LEFT JUSTIFIED AND RETURNS IT
BEGIN
EXTERNAL LEXICAL,GSTCSCAN,LOOK4CHAR;
REGISTER SIX,C;
LOOK4CHAR _ "?L"; ! ANY LETTER
DECR SHIFT FROM 30 TO 0 BY 6 DO !PACK THE FIRST 6 CHARACTERS
BEGIN
MACHOP ADDI=#271;
SIX_.SIX^6;
IF ( C _ LEXICAL(.GSTCSCAN ) ) EQL 0
THEN RETURN ( SIX _ .SIX^.SHIFT ) ! NO MORE LETTERS
ELSE ADDI ( SIX, -" ", C ) ! CONVERT TO SIXBIT AND PUT IN SIX
END;
DO
IF LEXICAL(.GSTCSCAN) EQL 0 THEN RETURN .SIX ! SKIP ALL CHARS PAST 6
WHILE 1;
END; !OF STRNGSCAN
GLOBAL ROUTINE OPENCLOSE(OPENCLOSDATA)=
BEGIN
OWN BASE PT;
REGISTER BASE R1:T1:T2;
EXTERNAL FATLEX;
!**;[531], OPENCLOSE @3958, DCE, 13-JAN-77
%[531]% EXTERNAL E143;
EXTERNAL LEXEMEGEN %()%, LSAVE, LEXL, STK,SP,SYNTAX %(META)%,
BLDVAR %(VPNT)%, CORMAN %()%, NEWENTRY %()%,STRNGSCAN;
%[V5]% EXTERNAL NONIOINIO; ! FLAG FOR LABREF THRU LEXICAL
%[V5]% EXTERNAL LABELS %()%; ! SET LOOK4LABELS
%[V5]% EXTERNAL E34; ! DUPLICATE ERR= PARAMETER
LABEL OPEN1,OPEN2;
MACRO CHKCTYPE(X)=
BEGIN
PT _ .X;
IF .PT[VALTYPE] NEQ INTEGER
AND .PT[VALTYPE] NEQ OCTAL
THEN RETURN FATLEX ( PLIT SIXBIT'VALUE',E94<0,0>);
END$;
MACRO CHKTYPE(X)=
BEGIN
PT _ .X;
IF .PT[VALTYPE] NEQ INTEGER
THEN RETURN FATLEX ( PT[IDSYMBOL],E94<0,0>);
END$;
MACRO CHKVTYP(X)=
BEGIN
PT_.X;
IF .PT[VALTYPE] EQL LOGICAL
THEN RETURN FATLEX ( PT[IDSYMBOL],E94<0,0>);
END$;
MACRO
UNITP = #25$,
%[V5]% ERREQ = #26$, ! ARGID FOR ERR=
ACCESS(I) = (PARAM[I]+1)<LEFT> $,
ARGID(I) = (PARAM[I]+1)<RIGHT> $,
DIALOG = 1$,
OPENACCESS = 0,0,0,18$, !ACESSS MODE
OPENARGID = 18,18$, !TYPE OF ARGUMENT
ERR15(X)=(PT_.LEXL;RETURN FATLEX(X,PT,E15<0,0>))$;
%[V5]% MACRO ERR34 = RETURN FATLEX (PLIT 'PARAMETER',
%[V5]% PLIT (SIXBIT 'ERR'),
%[V5]% E34<0,0>)$;
MACHOP BLT=#251;LOCAL RQD;
%[V5]% BIND NUMPARAM = 18;
BIND PARAM=PLIT( ! CONST VAR LIT NAME ARRAY NULL
%1% SIXBIT'UNIT ',0 ^18+ #25 , ! X X
%2% SIXBIT'FILE',1 ^18+ #6 , ! X X
%3% SIXBIT'RECORD',0 ^18+ #14 , ! X X
%4% SIXBIT'ASSOCI',3 ^18+ #22 , ! X
!%5% SIXBIT'ERROR ',3 ^18+ #21 , ! X
%6% SIXBIT'DIALOG',2 ^18+ #1 , ! X X X
%7% SIXBIT'DEVICE',1 ^18+ #3 , ! X X
%8% SIXBIT'ACCESS',1 ^18+ #2 , ! X X
%9% SIXBIT'MODE ',1 ^18+ #12 , ! X X
%10% SIXBIT'PROTEC',0 ^18+ #7 , ! X X
%11% SIXBIT'DIRECT',2 ^18+ #10 , ! X X
%12% SIXBIT'DISPOS',1 ^18+ #15 , ! X X
%13% SIXBIT'FILESI',0 ^18+ #13 , ! X X
%14% SIXBIT'BLOCKS',0 ^18+ #5 , ! X X
%15% SIXBIT'BUFFER',0 ^18+ #4 , ! X X
%16% SIXBIT'VERSIO',0 ^18+ #16 , ! X X
!%17% SIXBIT 'LIMIT',0 ^18+ #11 , ! X X
!%18% SIXBIT'REELS ',2 ^18+ #17 , ! X X
!%19% SIXBIT'MOUNT ',2 ^18+ #20 , ! X X
%20% SIXBIT'PARITY',1 ^18+ #23,
%21% SIXBIT'DENSIT',1 ^18+ #24,
%22% SIXBIT'ERR ',5 ^18+ #26 ! HANDLED SEPARATELY %[V5]%
);
BIND OPENPLIT= PLIT'OPEN';
EXTERNAL SETUSE,NAMREF;
LOCAL OARGID; !OPENARG ID
%[V5]% LOCAL BASE ERRLAB; ! ERR= LABEL
ROUTINE GETVARB =
BEGIN
IF SYNTAX(VARIABLESPEC) LSS 0 THEN RETURN .VREG;
R1_.STK[.SP];
IF (R1 _ STK[.SP]_BLDVAR(@R1)) LSS 0 THEN RETURN .VREG;
% BLDVAR ALLOWS ARRAYS WITHOUT SUBSCRIPTS SO DON'T LET THEM THROUGH HERE %
IF .R1<LEFT> EQL IDENTIFIER
THEN IF .R1[OPRSP1] EQL ARRAYNM1
THEN RETURN FATLEX ( R1[IDSYMBOL], ARPLIT<0,0>, E4<0,0> );
END; %GETVARB%
!SEMANTIC ANALYSIS BEGINS
!----------------------------------------------------------------------------------------------------------
!THIS ROUTINE SCANS THE PARAMETERS OF THE OPEN STATEMENT
!FOR THE UNIQUE PARAMETER NAMES SPECIFIED ABOVE IN THE PARAM
!PLIT. FOR EACH UNIQUE PARAMETER NAME THERE IS ONLY ONE OF
!SIX POSSIBLE PARAMETER TYPES WHICH IS LEGAL. THESE ARE SPECIFIED
!BY THE SECOND ENTRY OF EACH SUBPLIT AS: CONSTANT OR VARIABLE (0),
!VARIABLE OR LITERAL (1), LITERAL OR ARRAY NAME (2), VARIABLE (3),
!OR A UNIQUE NAME (4). THESE PARAMETERS, AFTER BEING SCANNED
!ARE PLACED IN A PSEUDO-OPEN NODE ON THE STACK FORM
!PARAMETER NUMBER^18+LOC.
!----------------------------------------------------------------------------------------------------------
SETUSE _ USE; ! BLDVAR FLAG - ALL VARIABLES HERE ARE REFERENCE
RQD _ 0; !RESET RQUIRED ARG (UNIT)
%[V5]% ERRLAB _ 0; ! RESET ERR= LABEL
LEXL_LEXEMEGEN(); STK[0]_0; SP_-1;
IF .LEXL NEQ LPAREN^18 THEN ERR0L(LPARPLIT);
DO
BEGIN
LABEL UNITSKIP;
UNITSKIP:BEGIN
LEXL_STRNGSCAN();
IF .LEXL EQL 0 THEN ( LEXL_LEXEMEGEN();EXITLOOP ); ! NO NAME TO BE FOUND
R1_.LEXL;
OPEN1:BEGIN
INCR I FROM 0 TO ( NUMPARAM-1 ) * 2 BY 2 DO
BEGIN
IF .R1 EQL @PARAM[.I] THEN (OARGID_.ARGID(.I);R1 _ .ACCESS(.I);LEAVE OPEN1 );
END;
ERR15(PLIT'OPEN/CLOSE PARAMETER')
END ; %OPEN1%
IF .OARGID EQL UNITP THEN RQD_-1; !SET REQUIRED FLAG
LEXL_LEXEMEGEN();
IF .LEXL NEQ EQUAL^18 THEN
%**;[313],STA1,JNT,02-JUL-75%
%**;[313],IN OPENCLOSE @ 4058%
(IF .OARGID EQL DIALOG THEN ![313] DIALOG IS ONLY POSSIBILITY
(STK[SP_.SP+1]<WHOLE>_DIALOG^18; ![313] SET TO DIALOG WITH 0 PTR
LSAVE_-1; ![313] DON'T GET ANOTHER LEXEME
LEAVE UNITSKIP) ![313] ON TO NEXT PARAMETER
ELSE ERR0L(PLIT'"="');
);
%[V5]% IF .OARGID EQL ERREQ
%[V5]% THEN BEGIN ! PROCESS ERR= LABEL
%[V5]% IF .ERRLAB NEQ 0
%[V5]% THEN ERR34; ! DUPLICATE ERR= PARAMETER
%[V5]% LABELS (); ! SET "LABEL REQUIRED" SWITCH
%[V5]% NONIOINIO _ 1; ! EXECUTABLE LABEL IN IO STATEMENT OK
%[V5]% ERRLAB _ LEXEMEGEN ();
%[V5]%! LOOK4LABELS & NONIOINIO ALREADY RESET
%[V5]% LSAVE _ 0; ! GET NEXT LEXEME
%[V5]% LEAVE UNITSKIP; ! DON'T PUT ANYTHING IN STK
%[V5]% END;
LEXL_LEXEMEGEN(); LSAVE _ -1;
CASE .R1 OF SET
BEGIN !CONSTANT OR VARIABLE
IF .LEXL<LEFT> EQL CONSTLEX
THEN (CHKCTYPE(LEXL<RIGHT>);
STK[SP_.SP+1]_.LEXL<RIGHT>;
LSAVE _ 0)
ELSE IF .LEXL<LEFT> EQL IDENTIFIER THEN
BEGIN
CHKTYPE(LEXL<RIGHT>); !MAKE SURE ARG IS INTEGER
IF GETVARB() LSS 0 THEN RETURN .VREG
END ELSE ERR0L(PLIT'CONSTANT OR VARIABLE');
IF .RQD EQL -1 THEN(RQD _ .STK[.SP]<RIGHT>; SP_.SP-1;LEAVE UNITSKIP %DON'T SET OPENARGID%);
END;
BEGIN !VARIABLE OR LITERAL
IF .LEXL<LEFT> EQL LITSTRING THEN (STK[SP_.SP+1]_.LEXL<RIGHT>; LSAVE _ 0)
ELSE IF .LEXL<LEFT> EQL IDENTIFIER THEN
BEGIN
CHKVTYP(LEXL<RIGHT>); !MAKE SURE ARG TYPE IS VALID
IF GETVARB() LSS 0 THEN RETURN .VREG
END ELSE ERR0L (PLIT'VARIABLE OR LITERAL');
END;
BEGIN !LITERAL OR ARRAY NAME
IF .LEXL<LEFT> EQL LITSTRING THEN STK[SP_.SP+1]_.LEXL<RIGHT>
ELSE IF .LEXL<LEFT> EQL IDENTIFIER THEN
BEGIN
R1_@LEXL;
IF .R1[OPRSP1] NEQ ARRAYNM1
THEN RETURN FATLEX(PLIT'ARRAY',R1[IDSYMBOL],E15<0,0>)
ELSE STK[SP_.SP+1]_@R1;
NAMREF ( ARRAYNM1, .R1 )
!**[424} OPENCLOSE @4138 SJW 17-AUG-76
%[424]% END ELSE ERR0L (PLIT 'LITERAL OR ARRAY NAME');
LSAVE _ 0;
END;
BEGIN !VARIABLE
IF .LEXL<LEFT> EQL IDENTIFIER THEN
BEGIN
CHKTYPE(LEXL<RIGHT>); !MAKE SURE ARG IS INTEGER
!**;[531], OPENCLOSE @4110, DCE, 13-JAN-77
!**;[531], GIVE WARNING FOR SUBROUTINE PARAMETER USED AS ASSOCIATE VAR
%[531]% T1_.LEXL;
%[531]% IF .T1[OPR1] EQL FMLVARFL
%[531]% THEN WARNERR(.ISN,E143<0,0>);
IF GETVARB() LSS 0 THEN RETURN .VREG
END ELSE ERR0L(PLIT'VARIABLE');
END
TES;
STK[.SP]<OPENARGID>_.OARGID;
END; % OF UNIT SKIP %
IF .LSAVE NEQ 0 THEN LSAVE _ 0 ELSE LEXL _ LEXEMEGEN();
END WHILE .LEXL<LEFT> EQL COMMA;
IF .LEXL NEQ RPAREN^18 THEN ERR0L(RPARPLIT);
IF LEXEMEGEN() NEQ LINEND^18 THEN ERR0L(PLIT'LINEND');
IF .RQD EQL 0 THEN
!**[521] OPENCLOSE @4162 SJW 24-NOV-76
![521] FIX PARAMS TO E15 IN FATLEX: E15 =?B IS NOT ?C
![521] 1ST PARAM IS ?C IN 7BIT
![521] 2ND PARAM IS ?B IN 6BIT
RETURN FATLEX(PLIT 'DEFINED',PLIT SIXBIT'UNIT',E15<0,0>);
IF .SP GEQ 0
THEN(
NAME<LEFT>_.SP+1;R1_CORMAN();
T1<LEFT>_STK[0];T1<RIGHT>_.R1;T2_.R1+.SP;BLT(T1,0,T2);
)
ELSE R1 _ 0;
NAME_IDOFSTATEMENT_.OPENCLOSDATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
T1[OPSIZ]_.SP+1;T1[OPLST]_.R1; T1[IOUNIT] _ .RQD;
%[V5]% T1 [IOERR] _ .ERRLAB<RIGHT>;
SP _ -1;
.VREG
END;
GLOBAL ROUTINE OPENSTA=
BEGIN
EXTERNAL OPENCLOSE;
OPENCLOSE(OPENDATA);
.VREG
END;
GLOBAL ROUTINE CLOSSTA=
BEGIN
EXTERNAL OPENCLOSE;
OPENCLOSE(CLOSDATA);
.VREG
END;
END
ELUDOM