%EXTERNALROUTINE OLDPS(%STRING (63) S)
%EXTERNALROUTINESPEC DATE %alias "EMAS3DATE"(%STRING (*) %NAME S)
%INTEGER I,J,K,SS,NBIP,SSYM
%STRING (31) ST49,ST50,ST51
%STRING (127) HEADER
%EXTERNALROUTINESPEC EMAS3(%STRINGNAME CMD,PARAMS, %INTEGERNAME FLAG)
%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, %INTEGERNAME NUM,NEXT)
%ROUTINESPEC LOOK UP(%INTEGERARRAYNAME WORD,LETT, %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 %ANDRETURN
      EMAS3("DEFINE","ST49,".ST49,EFLAG)
      EMAS3("define","ST50,".ST50,EFLAG)
      EMAS3("define","ST51,".ST51,EFLAG)
      SELECT INPUT(49)
      DATE(HEADER)
      SELECT OUTPUT(51)
      HEADER="! PRODUCED BY OLDPS FROM ".ST49." ON ".HEADER
      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='{' %START
         READSTRING('}');               ! discard comment
         ->NEXTS
      %FINISH
      %IF I='D' %THENSTART;             !'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'''' %OR I=M'"' %THEN ->LIT
      %IF I=',' %THENSTART
         SYMBOL(ALT)=ASL
         ALT=ASL
         ASL=ASL+1
         ->NEXTP
      %FINISH
      %IF I=';' %THEN SYMBOL(ALT)=ASL %AND SYMBOL(DEF)=ASL %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:  SSYM=I
      READ STRING(SSYM)
      PRINT STR(CC,0)
      PRINTSYMBOL(SSYM)
      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 %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
         %RETURNUNLESS NIDFLAG=0
      %REPEAT
      SELECT OUTPUT(0)
      PRINTSTRING("NO ERRORS
")
      %CYCLE I=1001,1,DNUM-1
         %IF PUSE(I)=0 %THENSTART
            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 %ANDRETURN
      J=J+1
      CC(J)=I
      ->NEXTS
%END
%ROUTINE RECORD(%INTEGERARRAYNAME WORD,LETT, %INTEGERNAME 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, %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 %THENSTART
         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 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