home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / fortran / ratfor.lbr / TRNLIT.RTF < prev    next >
Encoding:
Text File  |  1986-04-27  |  6.0 KB  |  241 lines
  1. #========= translit program from chapter 2 ==========
  2.  
  3.  include "b:ratdefn.rtf"
  4.  
  5. define(MAXARR,100)
  6. define(MAXSET,100)
  7. define(ESCAPE,ATSIGN)
  8. define(DASH,MINUS)
  9. define(NOT,BANG)
  10. # addset - put    c  in  set(j)  if it fits,  increment  j
  11.    integer function addset(c, set, j, maxsiz)
  12.    integer j, maxsiz
  13.    character c, set(maxsiz)
  14.  
  15.    if (j > maxsiz)
  16.       addset = NO
  17.    else {
  18.       set(j) = c
  19.       j = j + 1
  20.       addset = YES
  21.       }
  22.    return
  23.    end
  24. # dodash - expand array(i-1)-array(i+1) into set(j)... from valid
  25.    subroutine dodash(valid, array, i, set, j, maxset)
  26.    character esc
  27.    integer addset, index
  28.    integer i, j, junk, k, limit, maxset
  29.    character array(ARB), set(maxset), valid(ARB)
  30.  
  31.    i = i + 1
  32.    j = j - 1
  33.    limit = index(valid, esc(array, i))
  34.    for (k = index(valid, set(j)); k <= limit; k = k + 1)
  35.       junk = addset(valid(k), set, j, maxset)
  36.    return
  37.    end
  38. # esc - map  array(i)  into escaped character if appropriate
  39.    character function esc(array, i)
  40.    character array(ARB)
  41.    integer i
  42.  
  43.    if (array(i) ^= ESCAPE)
  44.       esc = array(i)
  45.    else if (array(i+1) == EOS)     # \*a not special at end
  46.       esc = ESCAPE
  47.    else {
  48.       i = i + 1
  49.       if (array(i) == LETN)
  50.      esc = NEWLINE
  51.       else if (array(i) == LETT)
  52.      esc = TAB
  53.       else
  54.      esc = array(i)
  55.       }
  56.    return
  57.    end
  58. # filset - expand set at  array(i)  into  set(j),  stop at  delim
  59.    subroutine filset(delim, array, i, set, j, maxset)
  60.    character esc
  61.    integer addset, index
  62.    integer i, j, junk, maxset
  63.    character array(ARB), delim, set(maxset)
  64. #   string digits "0123456789"
  65.    character digits(11)
  66. #   string lowalf "abcdefghijklmnopqrstuvwxyz"
  67.    character lowalf(27)
  68. #   string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  69.    character upalf(27)
  70.    data digits(1)/DIG0/, digits(2)/DIG1/, digits(3)/DIG2/
  71.    data digits(4)/DIG3/, digits(5)/DIG4/, digits(6)/DIG5/
  72.    data digits(7)/DIG6/, digits(8)/DIG7/, digits(9)/DIG8/
  73.    data digits(10)/DIG9/, digits(11)/EOS/
  74.    data lowalf(01)/LETA/
  75.    data lowalf(02)/LETB/
  76.    data lowalf(03)/LETC/
  77.    data lowalf(04)/LETD/
  78.    data lowalf(05)/LETE/
  79.    data lowalf(06)/LETF/
  80.    data lowalf(07)/LETG/
  81.    data lowalf(08)/LETH/
  82.    data lowalf(09)/LETI/
  83.    data lowalf(10)/LETJ/
  84.    data lowalf(11)/LETK/
  85.    data lowalf(12)/LETL/
  86.    data lowalf(13)/LETM/
  87.    data lowalf(14)/LETN/
  88.    data lowalf(15)/LETO/
  89.    data lowalf(16)/LETP/
  90.    data lowalf(17)/LETQ/
  91.    data lowalf(18)/LETR/
  92.    data lowalf(19)/LETS/
  93.    data lowalf(20)/LETT/
  94.    data lowalf(21)/LETU/
  95.    data lowalf(22)/LETV/
  96.    data lowalf(23)/LETW/
  97.    data lowalf(24)/LETX/
  98.    data lowalf(25)/LETY/
  99.    data lowalf(26)/LETZ/
  100.    data lowalf(27)/EOS/
  101.    data upalf(01) /BIGA/
  102.    data upalf(02) /BIGB/
  103.    data upalf(03) /BIGC/
  104.    data upalf(04) /BIGD/
  105.    data upalf(05) /BIGE/
  106.    data upalf(06) /BIGF/
  107.    data upalf(07) /BIGG/
  108.    data upalf(08) /BIGH/
  109.    data upalf(09) /BIGI/
  110.    data upalf(10) /BIGJ/
  111.    data upalf(11) /BIGK/
  112.    data upalf(12) /BIGL/
  113.    data upalf(13) /BIGM/
  114.    data upalf(14) /BIGN/
  115.    data upalf(15) /BIGO/
  116.    data upalf(16) /BIGP/
  117.    data upalf(17) /BIGQ/
  118.    data upalf(18) /BIGR/
  119.    data upalf(19) /BIGS/
  120.    data upalf(20) /BIGT/
  121.    data upalf(21) /BIGU/
  122.    data upalf(22) /BIGV/
  123.    data upalf(23) /BIGW/
  124.    data upalf(24) /BIGX/
  125.    data upalf(25) /BIGY/
  126.    data upalf(26) /BIGZ/
  127.    data upalf(27) /EOS/
  128.  
  129.    for ( ; array(i) ^= delim & array(i) ^= EOS; i = i + 1)
  130.       if (array(i) == ESCAPE)
  131.      junk = addset(esc(array, i), set, j, maxset)
  132.       else if (array(i) ^= DASH)
  133.      junk = addset(array(i), set, j, maxset)
  134.       else if (j <= 1 | array(i+1) == EOS)   # literal -
  135.      junk = addset(DASH, set, j, maxset)
  136.       else if (index(digits, set(j-1)) > 0)
  137.      call dodash(digits, array, i, set, j, maxset)
  138.       else if (index(lowalf, set(j-1)) > 0)
  139.      call dodash(lowalf, array, i, set, j, maxset)
  140.       else if (index(upalf, set(j-1)) > 0)
  141.      call dodash(upalf, array, i, set, j, maxset)
  142.       else
  143.      junk = addset(DASH, set, j, maxset)
  144.    return
  145.    end
  146. # makset - make set from  array(k)  in    set
  147.    integer function makset(array, k, set, size)
  148.    integer addset
  149.    integer i, j, k, size
  150.    character array(ARB), set(size)
  151.  
  152.    i = k
  153.    j = 1
  154.    call filset(EOS, array, i, set, j, size)
  155.    makset = addset(EOS, set, j, size)
  156.    return
  157.    end
  158. # translit - map characters
  159.    character getc
  160.    character arg(MAXARR), c, from(MAXSET), to(MAXSET)
  161.    integer getarg, length, makset, xindex
  162.    integer allbut, collap, i, lastto
  163.  
  164.    call initio
  165.  
  166.    if (getarg(1, arg, MAXARR) == EOF)
  167.       call error("usage: translit from to.")
  168.    else if (arg(1) == NOT) {
  169.       allbut = YES
  170.       if (makset(arg, 2, from, MAXSET) == NO)
  171.      call error("from: too large.")
  172.     }
  173.    else {
  174.       allbut = NO
  175.       if (makset(arg, 1, from, MAXSET) == NO)
  176.      call error("from: too large.")
  177.       }
  178.    if (getarg(2, arg, MAXARR) == EOF)
  179.       to(1) = EOS
  180.    else if (makset(arg, 1, to, MAXSET) == NO)
  181.      call error("to: too large.")
  182.  
  183.  lastto = length(to)
  184.    if (length(from) > lastto | allbut == YES)
  185.       collap = YES
  186.    else
  187.       collap = NO
  188.    repeat {
  189.       i = xindex(from, getc(c), allbut, lastto)
  190.       if (collap == YES & i >= lastto & lastto > 0) {  # collapse
  191.      call putc(to(lastto))
  192.      repeat
  193.         i = xindex(from, getc(c), allbut, lastto)
  194.         until (i < lastto)
  195.      }
  196.       if (c == EOF)
  197.        { call putc(EOF)
  198.      break }
  199.       if (i > 0 & lastto > 0)    # translate
  200.      call putc(to(i))
  201.       else if (i == 0)        # copy
  202.      call putc(c)
  203.           # else delete
  204.       }
  205.    stop
  206.    end
  207. # xindex - invert condition returned by index
  208.    integer function xindex(array, c, allbut, lastto)
  209.    character array(ARB), c
  210.    integer index
  211.    integer allbut, lastto
  212.  
  213.    if (c == EOF)
  214.       xindex = 0
  215.    else if (allbut == NO)
  216.       xindex = index(array, c)
  217.    else if (index(array, c) > 0)
  218.       xindex = 0
  219.    else
  220.       xindex = lastto + 1
  221.    return
  222.    end
  223. 
  224.  
  225.  
  226.  
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  
  239.  
  240.  
  241.