EXTERNALROUTINE OLDPS(STRING (63) S)
EXTERNALSTRINGFNSPEC DATE
INTEGER I, J, K, SS, NBIP
STRING (31) ST49,ST50,ST51
STRING (127)HEADER
EXTERNALROUTINESPEC DEFINE(STRING (63)S)
INTEGERARRAY CLETT(0:1000), SYMBOL(1300:3000), CC(0:300)
INTEGER CNEXT, DNEXT, CNUM, DNUM, ALT, DEF, ASL, NIDFLAG
INTEGERARRAY KK, PUSE, DWORD(1001:1200), DLETT(0:1000), CWORD(1:200)
ROUTINESPEC READ STRING(INTEGER TERMINATOR)
ROUTINESPEC RECORD(INTEGERARRAYNAME WORD, LETT, C
INTEGERNAME NUM, NEXT)
ROUTINESPEC LOOK UP(INTEGERARRAYNAME WORD, LETT, C
INTEGER FIRST, LAST, INSERT)
ROUTINESPEC PDDICT
ROUTINESPEC PRINT STR(INTEGERARRAYNAME CC, INTEGER PTR)
ROUTINESPEC PCDICT
UNLESS S->ST49.(",").ST50.(",").ST51 THEN C
PRINTSTRING("PARAMS?????") AND NEWLINE AND RETURN
DEFINE("ST49,".ST49)
DEFINE("ST50,".ST50)
DEFINE("ST51,".ST51)
SELECT INPUT(49)
SELECT OUTPUT(51)
HEADER="! PRODUCED BY OLDPS FROM ".ST49." ON ".DATE
PRINTSTRING(HEADER)
ASL=1300
CNEXT=0
DNEXT=0
CNUM=0
NIDFLAG=0
DNUM=1000
READ(NBIP)
CYCLE I=1001,1,1200
PUSE(I)=0
REPEAT
NEXTS: READ SYMBOL(I)
IF I='D' THEN START ; !'D'
READ SYMBOL(I)
READSTRING(')')
RECORD(DWORD, DLETT, DNUM, DNEXT)
->NEXTS
FINISH
IF I='P' THEN ->PHRS
IF I='E' THEN ->EEND
->NEXTS
PHRS: NEWLINES(2)
PRINTSYMBOL(I)
READSYMBOL(I)
PRINTSYMBOL(I)
READ STRING(')')
PRINT STR(CC, 0)
PRINTSYMBOL(')')
LOOK UP(DWORD, DLETT, 1001+NBIP, DNUM, 0)
KK(I)=ASL
DEF=ASL
ALT=ASL+1
ASL=ASL+2
NEXTP: READ SYMBOL(I)
PRINTSYMBOL(I)
IF I='(' THEN ->BIPORPHR
IF I=M'''' THEN ->LIT
IF I=',' THEN START
SYMBOL(ALT)=ASL
ALT=ASL
ASL=ASL+1
->NEXTP
FINISH
IF I=';' THEN SYMBOL(ALT)=ASL AND SYMBOL(DEF)=ASL C
AND ->NEXTS
IF I='0' THEN SYMBOL(ASL)=1000 AND ASL=ASL+1 AND ->NEXTP
IF I='*' THEN SYMBOL(ASL)=999 AND ASL=ASL+1 AND ->NEXTP
->NEXTP
BIPORPHR:READ STRING(')')
PRINT STR(CC, 0)
PRINTSYMBOL(')')
LOOK UP(DWORD, DLETT, 1001, DNUM, 0)
PUSE(I)=PUSE(I)+1
SYMBOL(ASL)=I
ASL=ASL+1
->NEXTP
LIT: READ STRING(M'''')
PRINT STR(CC, 0)
PRINTSYMBOL(M'''')
LOOK UP (CWORD,CLETT,1,CNUM,1)
SYMBOL(ASL)=I
ASL=ASL+1
->NEXTP
EEND: PCDICT
PDDICT
CYCLE I=1300, 1, ASL-1
IF 1<=SYMBOL(I)<=CNUM THEN SYMBOL(I)=CWORD(SYMBOL(I))
IF 1001+NBIP<=SYMBOL(I)<=DNUM C
THEN SYMBOL(I)=KK(SYMBOL(I))
REPEAT
SS=KK(DNUM)
NEWLINE
CYCLE K=1, 1, 2
SELECT OUTPUT(50) IF K=2
PRINTSTRING(HEADER)
PRINTSTRING("
%CONSTBYTEINTEGERARRAY CLETT(0:")
WRITE(CNEXT-1, 1)
PRINTSTRING(")=")
CYCLE I=0, 1, CNEXT-1
WRITE(CLETT(I), 3)
J=','
J=';' IF I=CNEXT-1
PRINT SYMBOL(J)
NEWLINE IF I-(I//14)*14=0
REPEAT
NEWLINE
PRINTSTRING("
%CONSTINTEGERARRAY SYMBOL(1300:")
WRITE(ASL-1, 1); PRINTSTRING(")=")
CYCLE I=1300, 1, ASL-1
WRITE(SYMBOL(I), 5)
J=','
J=';' IF I=ASL-1
PRINTSYMBOL(J)
NEWLINE IF (I-1299)-((I-1299)//10)*10=1
REPEAT
NEWLINE
PRINTSTRING("%CONSTINTEGER SS=")
WRITE(SS, 1)
NEWLINE
RETURN UNLESS NIDFLAG=0
REPEAT
SELECT OUTPUT(99)
PRINTSTRING("NO ERRORS
")
CYCLE I=1001,1,DNUM-1
IF PUSE(I)=0 THEN START
PRINTSTRING("
WARNING PHRASE NOT USED :")
PRINT STR(DLETT,DWORD(I))
NEWLINE
FINISH
REPEAT
RETURN
ROUTINE READ STRING(INTEGER TERMINATOR)
INTEGER UNDER; UNDER=0
J=0
NEXTS: READ SYMBOL(I)
IF I='%' THEN UNDER=128 AND ->NEXTS
IF 'A'<=I<='Z' THEN I=I+UNDER ELSE UNDER=0
IF I=32 THEN ->NEXTS; !'_'
!
IF I=TERMINATOR THEN CC(0)=J AND RETURN
J=J+1
CC(J)=I
->NEXTS
END
ROUTINE RECORD(INTEGER ARRAY NAME WORD,LETT, C
INTEGER NAME NUM,NEXT)
NUM=NUM+1
WORD(NUM)=NEXT
CYCLE I=0, 1, CC(0)
LETT(NEXT+I)=CC(I)
REPEAT
NEXT=NEXT+CC(0)+1
END
ROUTINE LOOK UP(INTEGERARRAYNAME WORD, LETT, C
INTEGER FIRST, LAST, INSERT)
I=FIRST
WHILE I<=LAST CYCLE
J=WORD(I)
CYCLE K=0, 1, LETT(J)
IF LETT(J+K)#CC(K) THEN ->NXT
REPEAT
RETURN
NXT: I=I+1
REPEAT
IF INSERT=0 THEN START
PRINTSTRING("
****************PHRASE NOT IN DICTIONARY*********** ")
PRINT STR(CC, 0)
NIDFLAG=NIDFLAG+1
RETURN
FINISH
RECORD(WORD, LETT, CNUM, CNEXT)
! INSERT INTO C DICTIONARY
I=CNUM
END
ROUTINE PCDICT
INTEGER J, K, L
NEWPAGE
PRINTSTRING(" KEY TO LITERAL DICTIONARY (CLETT)
")
CYCLE J=1, 1, CNUM
K=CWORD(J)
WRITE(K, 4); SPACES(2)
PRINT STR(CLETT, K)
SPACES(17-SS)
NEWLINE IF J&3=0
REPEAT
END
ROUTINE PRINT STR(INTEGERARRAYNAME CC, INTEGER PTR)
INTEGER I, J, K, DEL
SS=CC(PTR); K=SS; DEL=0
CYCLE I=1, 1, K
J=CC(PTR+I)
IF DEL=0 AND J>128 THEN SS=SS+1 AND DEL=1 AND C
PRINT SYMBOL('%')
PRINT SYMBOL(J)
REPEAT
END
ROUTINE PDDICT
INTEGER J
NEWLINES(4)
PRINTSTRING(" KEY TO MAIN TABLE (SYMBOL)
")
CYCLE J=1001, 1, DNUM
IF J<=1000+NBIP THEN WRITE(J, 4) ELSE WRITE(KK(J), 4)
SPACES(2)
PRINT STR(DLETT, DWORD(J))
SPACES(17-SS)
NEWLINE IF (J-1000)&3=0
REPEAT
END
END
ENDOFFILE