Trailing-Edge
-
PDP-10 Archives
-
decuslib10-02
-
43,50263/eactph.sno
There are 2 other files named eactph.sno in the archive. Click here to see a list.
* * * * * * * * *
* * DECLARATIONS * * * * *
* * * * * * * * *
*
* LOCAL
*
DECLARE('SNOBOL.SUBPROGRAM','EACTPH')
DECLARE('OPTION','NO.STNO')
DECLARE('PURGE.VARIABLE',ALL)
DECLARE('PURGE.LABEL',ALL)
DECLARE('EXTERNAL.FUNCTION','PUTOUT,ERRMSG,NEWLAB,SUBS,GETATR,
.GETBKT')
DECLARE('ENTRY.VARIABLE','BRKTB1,BRKTB2,BRKTB3,BRKTB4')
DECLARE('INTEGER','BRKTB1,BRKTB2,BRKTB3,BRKTB4')
DECLARE('INTEGER','I,J,K,L,M,NVAR,NSYM')
DECLARE('ENTRY.FUNCTION','INIEAC()')
DECLARE('ENTRY.FUNCTION','EACTPH()')
*
* SYSTEM COMMON
*
* TABLES AND LISTS
DECLARE('EXTERNAL.VARIABLE',
.'SYMBTB,XNAMTB,KEYWTB,CTRLTB,DECLTB,CROSTB,CONSTB,ENTFTB,DSIZTB,
.BOPRTB,UOPRTB')
DECLARE('EXTERNAL.VARIABLE',
.'ENTRLS,EXTRLS,FORTLS')
* ARRAYS
DECLARE('EXTERNAL.VARIABLE',
.'PTVRAR,PTFNAR,PRIMAR,GOTOAR,DECLAR,PROGAR,VARBAR,MACHAR,STENAR,BOPRAR,
.UOPRAR,PATRAR,EXPRAR,AROPAR,ARITAR,EACTAR')
* PARAMETERS (STRINGS,DATATYPES)
DECLARE('EXTERNAL.VARIABLE',
.'C,INDENT,SPLASH,ITNAM,ITENT,NOFAIL,SNONAM,SUBNAM,PARBLK,PRGNAM,STARTP,
.TEMLOC,P1,P2,P3,P4,P5')
* PARAMETERS (INTEGERS)
DECLARE('EXTERNAL.VARIABLE',
.'P,OBJFLG,LISTSR,INTGER,ITTYP,ITATR,PRGALV,PRGALL,PRGALF,STNFLG,HSHSIZ,
.STRTIM,DMPFLG,LISTOB,STNO,MAXTMP')
DECLARE('INTEGER',
.'P,OBJFLG,LISTSR,INTGER,ITTYP,ITATR,PRGALV,PRGALL,PRGALF,STNFLG,HSHSIZ,
.STRTIM,DMPFLG,LISTOB,STNO,MAXTMP')
DECLARE('EXTERNAL.VARIABLE',
.'XNATRB,VTATRB,VDATRB,LTATRB,FTATRB,FDATRB,TXATRB,VNATRB,VXATRB,VIATRB,
.VGATRB,LIATRB,LGATRB,FIATRB,FGATRB,FXATRB,SKATRB,SDATRB,BTATRB')
DECLARE('INTEGER',
.'XNATRB,VTATRB,VDATRB,LTATRB,FTATRB,FDATRB,TXATRB,VNATRB,VXATRB,VIATRB,
.VGATRB,LIATRB,LGATRB,FIATRB,FGATRB,FXATRB,SKATRB,SDATRB,BTATRB')
DECLARE('EXTERNAL.VARIABLE',
.'XNVATR,XNLATR,XNFATR,XNXMSK,VTVATR,VDDATR,VDPATR,VDDMSK,LTDATR,LTTMSK,
.FTFATR,FDPATR,FDIATR,FDDMSK,TXTATR,TXTMSK,VNNATR,VXXATR,VIPATR,VGGATR,
.LIPATR,LGGATR,FIPATR,FGGATR,FXXATR,FXXMSK,SKRATR,SDRATR,BTRATR')
DECLARE('INTEGER',
.'XNVATR,XNLATR,XNFATR,XNXMSK,VTVATR,VDDATR,VDPATR,VDDMSK,LTDATR,LTTMSK,
.FTFATR,FDPATR,FDIATR,FDDMSK,TXTATR,TXTMSK,VNNATR,VXXATR,VIPATR,VGGATR,
.LIPATR,LGGATR,FIPATR,FGGATR,FXXATR,FXXMSK,SKRATR,SDRATR,BTRATR')
* SPECIAL CHARACTERS,CHARACTER SEQUENCES, AND CHARACTER CLASSES
DECLARE('EXTERNAL.VARIABLE',
.'FFCHR,CRLCHR,LFCHR,CRCHR,SQCHR,DQCHR,TBCHR,LCSCHR,BLNCHR,EQLCHR,
.QTSCHR,ELTCHR,LBCHR')
* PATTERNS AND MATCHES
DECLARE('EXTERNAL.VARIABLE',
.'COMSPT,INTGPT,BLNKPT,OPBLPT,PCOMPT,PCPRMT,IDENPT,DCLCMT,RSIDPT,LABLPT,
.POPRMT,IDENMT,SQLTPT,DQLTPT,LBDCPT,IDDCPT')
*
* MINIMAL SYMBOL TABLE
*
DECLARE('UNPURGE.VARIABLE','INIEAC,EACTPH,PUTLIT,STR1')
DECLARE('UNPURGE.LABEL','INIEAC EACTPH PUTLIT')
DECLARE('PURGE.FUNCTION','DATA,ARRAY,DIFFER,DATATYPE,SIZE,
.SUBSTR,IDENT')
* * * * * * * * *
* * INITIALIZE END-ACTION PHASE * * *
* * * * * * * * *
INIEAC DEFINE('PUTLIT(STR1)')
DATA('SYM(INAM,ATRB)')
DATA('SNT(SNX,STY,SNM,SVL)') :(RETURN)
* * * * * * * * *
* * GENERATE END-ACTION STORAGE * * *
* * * * * * * * *
EACTPH
* TEMP LOCATIONS
PUTOUT(SUBS(EACTAR<1>,TEMLOC,MAXTMP))
* RELEASE CODE ARRAYS IN CASE STORAGE IS NEEDED
*
GOTOAR =
DECLAR =
PROGAR =
VARBAR =
MACHAR =
STENAR =
PATRAR =
PTVRAR =
PTFNAR =
EXPRAR =
AROPAR =
ARITAR =
* CONVERT INTEGER AND REAL CONSTANTS TABLE TO ARRAY, GENERATE
* REQUIRED CONSTANTS AND/OR DESCRIPTORS
?INE(OBJFLG + LISTOB,0) :F(EAC2)
LISTAR = ARRAY(CONSTB) :F(EAC2)
CONSTB = ?TABLE(CONSTB)
I = 1
EAC1 STR1 = LISTAR<I,1> :F(EAC2)
J =
J = ?DIFFER(DATATYPE(STR1),'INTEGER') 1
STR2 = LISTAR<I,2>
ITATR = ATRB(STR2)
STR2 = INAM(STR2)
(?INE(AND(ITATR,1048576),0) ?PUTOUT(SUBS(EACTAR<2 + J>,STR2,
.STR1)))
(?INE(AND(ITATR,524288),0) ?PUTOUT(SUBS(EACTAR<4 + J>,STR2,STR1)
.))
I = I + 1 :(EAC1)
EAC2 LISTAR =
* CONVERT SYMBOL TABLE TO ARRAY, INITIALIZE FOR SYMBOL LOOP
VARBLK = NEWLAB()
LISTAR = ARRAY(SYMBTB)
SYMBTB = ?TABLE(SYMBTB)
I = 1
* SYMBOL LOOP, GENERATE ALL STORAGE EXCEPT UNDEDICATED VARIABLE
* LOCATIONS AND SYMBOL BLOCK ENTRIES
EAC3 STR1 = LISTAR<I,1> :F(EAC22)
STR2 = LISTAR<I,2>
ITATR = ATRB(STR2)
STR2 = INAM(STR2)
?INE(OBJFLG + LISTOB,0) :F(EAC10)
* STRING ATTRIBUTES
ITTYP = 3
GETATR()
* BREAK TABLE ATTRIBUTE
ITTYP = 4
(?GETATR() ?INE(BTATRB,0) ?GETBKT(STR1) ?PUTOUT(SUBS(EACTAR<6>,
.STR2,BRKTB1)) ?PUTOUT(SUBS(EACTAR<7>,RSHIFT(BRKTB2,18),AND(BRKTB2,
.262143))) ?PUTOUT(SUBS(EACTAR<7>,RSHIFT(BRKTB3,18),AND(BRKTB3,262143)))
. ?PUTOUT(SUBS(EACTAR<7>,RSHIFT(BRKTB4,18),AND(BRKTB4,262143))))
* VARIABLE ATTRIBUTES
ITTYP = 5
(?GETATR() ?INE(VTATRB,0) ?INE(VDATRB,VDPATR)) :F(EAC10)
(?INE(VXATRB,0) ?IEQ(VNATRB,0)) :S(EAC10)
(?INE(VXATRB,0) ?PUTOUT(SUBS(EACTAR<11>,STR2,VDATRB / VDDATR,
.XNAMTB[STR2]))) :S(EAC10)
NVAR = ?IEQ(VDATRB,0) NVAR + 1 :F(EAC5)
STR3 = ?INE(XNATRB,XNVATR) 'N' STR2 :S(EAC4)
STR3 = XNAMTB[STR2]
EAC4 STR3 = SUBS(EACTAR<8>,STR3,VARBLK,NVAR) :(EAC8)
EAC5 STR3 = ?INE(XNATRB,XNVATR) 'V' STR2 :S(EAC6)
STR3 = XNAMTB[STR2]
EAC6 (?INE(VDATRB,VDDATR) ?PUTOUT(SUBS(EACTAR<9>,STR3))) :S(EAC7)
J = DSIZTB[STR2]
K = J / 5
K = ?INE(J,5 * K) K + 1
PUTOUT(SUBS(EACTAR<10>,STR3,K))
EAC7 (?IEQ(VNATRB,0) ?IEQ(VGATRB,0) ?INE(VIATRB,0)) :S(EAC10)
STR3 = SUBS(EACTAR<11>,STR2,VDATRB / VDDATR,STR3)
EAC8 (?IEQ(VGATRB,0) ?INE(VIATRB,0) ?PUTOUT(STR3)) :S(EAC10)
SKATRB = 1
K = 1 + VGATRB / VGGATR
K = ?INE(SDATRB,0) 8 + K :F(EAC9)
SDATRB =
EAC9 SYMLST = SNT(SYMLST,K,STR2,STR3)
NSYM = NSYM + 1
* LABEL ATTRIBUTES
EAC10 ITTYP = 6
(?GETATR() ?INE(LTATRB,0)) :F(EAC14)
(?INE(LTATRB,LTDATR) ?ERRMSG('UNDEFINED LABEL: ' STR1))
?INE(OBJFLG + LISTOB,0) :F(EAC21)
(?IEQ(LGATRB,0) ?INE(LIATRB,0) ?IEQ(LTATRB,LTDATR)) :S(EAC15)
STR3 = ?INE(XNATRB,XNLATR) 'L' STR2 :S(EAC11)
STR3 = XNAMTB[STR2]
EAC11 STR3 = ?INE(LTATRB,LTDATR) SUBS(EACTAR<31>,STR3,EACTAR<12>)
. :S(EAC12)
STR3 = SUBS(EACTAR<13>,STR3)
EAC12 (?IEQ(LGATRB,0) ?INE(LIATRB,0) ?PUTOUT(STR3)) :S(EAC15)
SKATRB = 1
K = 3 + LGATRB / LGGATR
K = ?INE(SDATRB,0) 8 + K :F(EAC13)
SDATRB =
EAC13 SYMLST = SNT(SYMLST,K,STR2,STR3)
NSYM = NSYM + 1
* FUNCTION ATTRIBUTES
EAC14 ?INE(OBJFLG + LISTOB,0) :F(EAC21)
EAC15 ITTYP = 7
(?GETATR() ?INE(FTATRB,0) ?IEQ(FDATRB,0) ?INE(FXATRB,FXXATR))
. :F(EAC19)
STR3 = ?IEQ(FXATRB,0) SUBS(EACTAR<14>,STR2) :S(EAC17)
STR3 = ?IEQ(FXATRB,FXXMSK) PRIMAR<TXATRB / TXTATR> :F(EAC16)
STR3 RTAB(3) $ K REM $ STR3
STR3 = SUBS(EACTAR<16>,STR2,K,STR3) :(EAC17)
EAC16 STR3 = ENTFTB[STR2]
K = STR3<4>
STR3 = SUBS(EACTAR<15>,STR1,K,STR2)
EAC17 (?IEQ(FGATRB,0) ?INE(FIATRB,0) ?PUTOUT(STR3)) :S(EAC19)
SKATRB = 1
K = 5 + FGATRB / FGGATR
K = ?INE(SDATRB,0) 8 + K :F(EAC18)
SDATRB =
EAC18 SYMLST = SNT(SYMLST,K,STR2,STR3)
NSYM = NSYM + 1
* GENERATE STRING BLOCK AND DESCRIPTOR,IF REQUIRED
EAC19 (?INE(SDATRB,0) ?PUTOUT(SUBS(EACTAR<17>,STR2)))
J = ?INE(SKATRB,0) SIZE(STR1) :F(EAC21)
K = J / 5
K = ?INE(J,5 * K) K + 1
PUTOUT(SUBS(EACTAR<18>,STR2,K,J))
(?ILE(J,60) ?PUTLIT(STR1)) :S(EAC21)
P =
EAC20 K = 60
K = ?IGT(K,J - P) J - P
PUTLIT(SUBSTR(STR1,K,P))
P = ?INE(P + K,J) P + 60 :S(EAC20)
* BOTTOM OF SYMBOL LOOP
EAC21 I = I + 1 :(EAC3)
* END OF SYMBOL LOOP
EAC22 LISTAR =
?INE(OBJFLG + LISTOB,0) :F(RETURN)
* GENERATE VARIABLE BLOCK
(?IGT(NVAR,0) ?PUTOUT(SUBS(EACTAR<20>,VARBLK,NVAR)))
* GENERATE SYMBOL BLOCK
SYMBLK = ?IGT(NSYM,0) NEWLAB() :F(EAC24)
PUTOUT(SUBS(EACTAR<25>,SYMBLK,NSYM))
EAC23 I = STY(SYMLST)
STR1 =
STR1 = ?INE(AND(I,8),0) SUBS(EACTAR<26>,SNM(SYMLST))
I = AND(I,7)
PUTOUT(SUBS(EACTAR<27>,I,STR1,SNM(SYMLST),SVL(SYMLST)))
SYMLST = SNX(SYMLST)
IDENT(SYMLST) :F(EAC23)
* GENERATE PARAMETER BLOCK
EAC24 VARBLK = ?IEQ(NVAR,0) '0'
SYMBLK = ?IEQ(NSYM,0) '0'
STNO = ?INE(STNFLG,1) 0
PUTOUT(SUBS(EACTAR<21>,PRGNAM,PARBLK,VARBLK,SYMBLK,STNO))
* GENERATE 'ENTRY.FUNCTION' INITIALIZATIONS
LISTAR = ?DIFFER(ENTFTB) ARRAY(ENTFTB) :F(EAC27)
ENTFTB = ?TABLE(ENTFTB)
I = 1
EAC25 STR1 = LISTAR<I,1> :F(EAC27)
STR2 = LISTAR<I,2>
STR3 = STR2<3>
STR3 = ?IDENT(STR3) '0' :S(EAC26)
STR3 = SUBS(EACTAR<22>,STR3)
EAC26 PUTOUT(SUBS(EACTAR<23>,STR2<1>,PARBLK,STR1,STR2<2>,STR3))
I = I + 1 :(EAC25)
* GENERATE 'ENTRY.FORTRAN.FUNCTION' INITIALIZATIONS
EAC27 STR1 = ?DIFFER(FORTLS) FORTLS<5> :F(EAC29)
STR1 = ?IDENT(STR1) '0' :S(EAC28)
STR1 = SUBS(EACTAR<22>,STR1)
EAC28 PUTOUT(SUBS(EACTAR<24>,FORTLS<2>,FORTLS<3>,PARBLK,FORTLS<4>,
.STR1))
FORTLS = FORTLS<1> :(EAC27)
* GENERATE END STATEMENT
EAC29 (?INE(DMPFLG,0) ?PUTOUT(EACTAR<30>))
(?DIFFER(SNONAM) ?PUTOUT(SUBS(EACTAR<29>,STARTP))) :S(RETURN)
PUTOUT(EACTAR<28>) :(RETURN)
* * * * * * * * *
* * SUBROUTINES * * * * *
* * * * * * * * *
* * PUTLIT(STR1) OUTPUTS QUOTED STRING
* IF STRING CONTAINS BOTH SINGLE AND DOUBLE QUOTES, IT IS BRO-
* KEN UP AND THE TOUGH SECTION PUT OUT AS BYTES
*
PUTLIT STR1 BREAK(SQCHR) :S(PUTLT1)
PUTOUT(SUBS(EACTAR<19>,SQCHR,STR1)) :(RETURN)
PUTLT1 STR1 BREAK(DQCHR) :S(PUTLT2)
PUTOUT(SUBS(EACTAR<19>,DQCHR,STR1)) :(RETURN)
PUTLT2 L = SIZE(STR1)
(?IGT(L,5) ?PUTLIT(SUBSTR(STR1,5)) ?PUTLIT(SUBSTR(STR1
.,SIZE(STR1) - 5,5))) :S(RETURN)
A = ARRAY('5',0)
L =
PUTLT3 &ALPHABET ARB SUBSTR(STR1,1,L) @M :F(PUTLT4)
L = L + 1
A<L> = M - 1 :(PUTLT3)
PUTLT4 PUTOUT(SUBS(EACTAR<32>,A<1>,A<2>,A<3>,A<4>,A<5>))
. :(RETURN)
* * * * * * * * *
END