externalroutine  oldps(string (63) s)
externalstringfnspec  date
integer  i, j, k, ss, nbip
string (31) st49,st50,st51
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, 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)
         asl=1300
         cnext=0
         dnext=0
         cnum=0
         nidflag=0
         dnum=1000
         read(nbip)
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)
         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("! PRODUCED BY OLDPS FROM ".st49." ON ".date)
            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 
            newlines(2)
            newlines(2)
         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 
            newlines(2)
            printstring("%CONSTINTEGER SS=")
            write(ss, 1)
            newlines(2)
            return  unless  nidflag=0
         repeat 
         select output(99)
         printstring("NO ERRORS
")
         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