EXTERNALROUTINE  OLDPS alias  "s#go"
INTEGER  I, J, K, SS, NBIP
STRING (31) ST49,ST50,ST51
STRING (127)HEADER
INTEGERARRAY  CLETT(0:1000), SYMBOL(1300:3000), CC(0:300)
INTEGER  CNEXT, DNEXT, CNUM, DNUM, ALT, DEF, ASL, NIDFLAG, eflag
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
         HEADER="! PRODUCED BY newps FROM "
         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&127)
         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