%EXTERNALROUTINE PSPROG2(%STRING(63) S)
%EXTERNALSTRINGFNSPEC DATE
%INTEGER I, J, K, SS, NBIP
%STRING(15) ST49,ST50,ST51
%EXTERNALROUTINESPEC DEFINE(%STRING(63)S)
%INTEGERARRAY SYMBOL(1300:3000), CC(0:300)
%INTEGER CNEXT, DNEXT, CNUM, DNUM, ALT, DEF, ASL, NIDFLAG
%INTEGERARRAY KK, DWORD(1001:1200), DLETT(0:1000)
%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)
         %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)
         ASL=1300
         CNEXT=0
         DNEXT=0
         CNUM=0
         NIDFLAG=0
         DNUM=1000
         READ(NBIP)
L1:       READ SYMBOL(I)
         %IF I=68 %THEN ->L3;            !'D'
         %IF I=80 %THEN ->L4;            !'P'
         %IF I=69 %THEN ->L5;            !'E'
         ->L1
L3:       READ SYMBOL(I)
         READSTRING(')')
         RECORD(DWORD, DLETT, DNUM, DNEXT)
         ->L1
L4:       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
L6:       READ SYMBOL(I)
         PRINTSYMBOL(I)
         %IF I='(' %THEN ->L7;           !
         %IF I=M'''' %THEN ->LLIT;       !'''OR EQUIVALENT                
                                        !       
         %IF I=44 %THEN ->L9;            !','                             
                                        !         
         %IF I=59 %THEN ->L10;           !
         %IF I=48 %THEN ->L11;           !'0'                             
                                        !         
         %IF I='*' %THEN I=999 %AND ->L12
         ->L6
L7:       READ STRING(')')
         PRINT STR(CC, 0)
         PRINTSYMBOL(')')
         LOOK UP(DWORD, DLETT, 1001, DNUM, 0)
L12:      SYMBOL(ASL)=I
         ASL=ASL+1
         ->L6
LLIT:     READ STRING(M'''')
         PRINT STR(CC, 0)
         PRINTSYMBOL(M'''')
         %CYCLE I=1,1,CC(0)
            SYMBOL(ASL)=CC(I)
            ASL=ASL+1
         %REPEAT
         ->L6
L9:       SYMBOL(ALT)=ASL
         ALT=ASL
         ASL=ASL+1
         ->L6
L10:      SYMBOL(ALT)=ASL
         SYMBOL(DEF)=ASL
         ->L1
L11:      I=1000
         ->L12
L5:
       PDDICT
         %CYCLE I=1300, 1, ASL-1
            %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('! PRODUCED FROM '.ST49.' BY PSPROG2S ON '.DATE)
            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
")
         %RETURN
%ROUTINE READ STRING(%INTEGER TERMINATOR)
%INTEGER UNDER;  UNDER=0
         J=0
L1:       READ SYMBOL(I)
         %IF I='%' %THEN UNDER=128 %AND ->L1
         %IF 'A'<=I<='Z' %THEN I=I+UNDER %ELSE UNDER=0
         %IF I=32 %THEN ->L1;            !'_'                             
                                        !         
         %IF I=TERMINATOR %THEN CC(0)=J %AND %RETURN
         J=J+1
         CC(J)=I
         ->L1
%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 ->LNXT
            %REPEAT
            %RETURN
LNXT:        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 PRINT STR(%INTEGERARRAYNAME CC, %INTEGER PTR)
%INTEGER I, J, K
         SS=CC(PTR);  K=SS
         %IF CC(PTR+1)>128 %THEN SS=SS+1 %AND PRINT SYMBOL('%')
         %CYCLE I=1, 1, K
            PRINT SYMBOL(CC(PTR+I))
         %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