home *** CD-ROM | disk | FTP | other *** search
/ kermit.columbia.edu / kermit.columbia.edu.tar / kermit.columbia.edu / vmspascal / vxhex.for < prev    next >
Text File  |  1988-08-15  |  4KB  |  214 lines
  1.     program k11hex
  2. c
  3. c
  4. c    02-Mar-84  13:50:23  Brian Nelson
  5. c    18-Sep-84         Philip Murton (UTCS)
  6. c                 Minor change for VAX/VMS
  7. c
  8. c     Written in Fortran-77 since if written it in  MACRO-11 I
  9. c    would need two versions (one for RSX and RSTS and another
  10. c    for RT)
  11. c
  12. c    pack and unpack the so-called HEX file for kermit
  13. c
  14.     byte    mode
  15.     byte    infil(40),outfil(40)
  16. c
  17. c    note:    For encoding, RT fortran does not know about
  18. c        eof for direct access files. Will have to fix
  19. c        for RT when I get the rt version done.
  20. c
  21. c
  22. c
  23. c    to compile:
  24. c
  25. c    f77 k11hex=k11hex
  26. c    ftb
  27. c    k11hex=k11hex,lb:f4pots/lb
  28. c    /
  29. c    maxbuf=1000
  30. c    //
  31. c
  32. c
  33. c    Be sure to include MAXBUF=1000 for FTB (or TKB) otherwise
  34. c    it won't run.
  35. c
  36. c-    call errset(39,.true.,.false.,.true.,.false.,32000)
  37. c
  38.     write (7,30000)
  39.     read  (5,30010) infil
  40.     write (7,30020)
  41.     read  (5,30010) outfil
  42.     infil(40)  = 0
  43.     outfil(40) = 0
  44. 10    continue
  45.     write (7,30030)
  46.     read  (5,30010) mode
  47.     if (mode.eq.'e' .or. mode.eq.'E') go to 100
  48.     if (mode.eq.'d' .or. mode.eq.'D') go to 200
  49.     type *,'Please enter E for ENCODE or D for DECODE'
  50.     goto 10
  51. c
  52. c
  53. 100    continue
  54.     open    (unit=1,type='OLD',name=infil,access='DIRECT',
  55.     1     recordsize=512/4 ,readonly,form='UNFORMATTED')
  56.     open    (unit=2,type='NEW',name=outfil,carriagecontrol='LIST')
  57.     call crehex
  58.     close (unit=1)
  59.     close (unit=2)
  60.     stop
  61. c
  62. 200    continue
  63.     open    (unit=1,type='OLD',name=infil,readonly,
  64.     1     carriagecontrol='LIST')
  65.     open    (unit=2,type='NEW',name=outfil,access='DIRECT',
  66.     1     recordsize=512/4,form='UNFORMATTED')
  67.     call cretsk
  68.     close (unit=1)
  69.     close (unit=2)
  70.     stop
  71. c
  72. c
  73. c    
  74. c
  75. 30000    format (1x,'Input  file ? '$)
  76. 30010    format (80a1)
  77. 30020    format (1x,'Output file ? '$)
  78. 30030    format (1x,'Encode or Decode ? '$)
  79. c
  80.     end
  81. c
  82. c
  83. c
  84. c
  85.     subroutine crehex
  86.     implicit integer (a-z)
  87.     byte buffer(512)
  88. c
  89. c
  90.     rnum = 1
  91. 10    continue
  92.     read(1'rnum,err=1000) buffer
  93.     offset = 1
  94.     do 20 j = 1 , 16
  95.     check = 0
  96.     do 15 k = offset,offset+31
  97.      check = check + ord(buffer(k))
  98. 15    continue
  99.     write(2,30000) (buffer(k),k=offset,offset+31),check
  100.     offset = offset + 32
  101. 20    continue
  102.     rnum = rnum + 1
  103.     go to 10
  104. 1000    type *,'All done'
  105.     return
  106. c
  107. 30000    format (32z2.2,':',z6.6)
  108.     end
  109. c
  110. c
  111. c
  112.     subroutine cretsk
  113.     implicit integer (a-z)
  114.     byte buffer(512)
  115.     byte lbuff(64)
  116.     byte cbuff(6)
  117.     byte chr
  118.     integer chmap(256)
  119.     data chmap /256*0/
  120. c
  121.     chmap(48) = 0
  122.     chmap(49) = 1
  123.     chmap(50) = 2
  124.     chmap(51) = 3
  125.     chmap(52) = 4
  126.     chmap(53) = 5
  127.     chmap(54) = 6
  128.     chmap(55) = 7
  129.     chmap(56) = 8
  130.     chmap(57) = 9
  131.     chmap(65) = 10
  132.     chmap(66) = 11
  133.     chmap(67) = 12
  134.     chmap(68) = 13
  135.     chmap(69) = 14
  136.     chmap(70) = 15
  137. c
  138. c
  139.     rnum = 1
  140. 10    continue
  141.     off = 1
  142.     do 90 j = 1 , 16
  143.       read(1,30010,end=100,err=100) lbuff,cbuff
  144.       i = 1
  145.       do 20 k = off,off+31
  146.        buffer(k) = chr( chmap(lbuff(i))*16 + chmap(lbuff(i+1)) )
  147.        i = i + 2
  148. 20      continue
  149.       check = chmap( cbuff(6) )
  150.      1        + chmap( cbuff(5) ) * 16
  151.      2        + chmap( cbuff(4) ) * 256
  152.      3        + chmap( cbuff(3) ) * 4096
  153. c
  154. c-      read(1,30000,end=100,err=100)(buffer(k),k=off,off+31),check
  155.       comchk = 0
  156.       do 70 k = off,off+31
  157.        comchk = comchk + ord(buffer(k))
  158. 70      continue
  159.       if (comchk.eq.check) go to 80
  160.        type *,'Checksum error ',check,comchk
  161.        stop
  162. 80      continue
  163.       off = off + 32
  164. 90    continue
  165.     write(2'rnum) buffer
  166.     rnum = rnum + 1
  167.     go to 10
  168. c
  169. 100    continue
  170.     type *,'all done'
  171.     type *,'For VMS, please make output contiguous as in'
  172.     type *,' '
  173.     type *,' COPY KERMIT.EXE KERMIT.EXE/CONT'
  174.     type *,' '
  175. c    type *,'For RSX, please make  the task image  contiguous as in'
  176. c    type *,' '
  177. c    type *,'   PIP [1,54]KERMIT.TSK/CO=KERMIT.TSK'
  178. c    type *,' '
  179. c    type *,'For RSTS, make the task contiguous, set the protection'
  180. c    type *,'to <104> and the rts name to RSX as in'
  181. c    type *,' '
  182. c    type *,'   PIP [1,2]KERMIT.TSK<104>/MO:16/RTS:RSX=KERMIT.TSK'
  183. c    type *,' '
  184.     return
  185. c
  186. c    for f77 only, the format was '30000    format (32z2,1x,z6)'
  187. c
  188. 30010    format (64a1,1x,6a1)
  189. c
  190.     end
  191. c
  192. c
  193. c
  194.     integer function ord(b)
  195.     byte b
  196.     byte ch(2)
  197.     integer i
  198.     equivalence (ch(1),i)
  199.     ch(1) = b
  200.     ord = i
  201.     return
  202.     end
  203. c
  204. c
  205.     byte function chr(i)
  206.     integer i
  207.     byte b(2)
  208.     integer ch
  209.     equivalence (b(1),ch)
  210.     ch = i
  211.     chr = b(1)
  212.     return
  213.     end
  214.