*>>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin 
      *> Date:      22-Oct-2008 
      *> Purpose:   Test the OCDUMP routine 
      *> Tectonics: cobc -x ocdump.cob
      *> ***************************************************************
       identification division.
       program-id. testdump.

       data division.
       local-storage section.
       01 buffer               pic x(64) value spaces.
       01 int                  usage binary-long value 123.
       01 addr                 usage pointer.

       01 len                  usage binary-long.

      *> **************************************************************
       procedure division.
       move "abcdefghijklmnopqrstuvwxyz0123456789" to buffer
       move function length(buffer) to len

       display "Buffer Dump: " buffer(1:len) end-display
       call "OCDUMP" using buffer len end-call

       display "Alpha literal Dump" end-display
       move 17 to len
       call "OCDUMP" using "abcdefghijklmopqr" len end-call

       display "Integer Dump: " int end-display
       move function byte-length(int) to len
       call "OCDUMP" using int len end-call

       display "Numeric Literal Dump: " 0 end-display
       move function byte-length(0) to len
       call "OCDUMP" using 0 len end-call

       display "Hex Literal Dump" end-display
´      move 4 to len
       call "OCDUMP" using x"f5f5f5f5" len end-call

       set addr to address of buffer
       display "Pointer Dump: " addr end-display
       move function byte-length(addr) to len
       call "OCDUMP" using addr len end-call 

       goback.
       end program testdump.
      *> **************************************************************

       
      *>>SOURCE FORMAT IS FIXED
      *> ***************************************************************
      *> Author:    Brian Tiffin     
      *>            Changed by Asger Kjelstrup 
      *> Date:      26-Oct-2008 
      *> Purpose:   Hex Dump display 
      *> Tectonics: cobc -c ocdump.cob
      *> ***************************************************************
       identification division.
       program-id. OCDUMP.

       data division.
       local-storage section.
       01 addr                            usage pointer.
       01 addr2addr                       usage pointer.
       01 counter                         usage binary-long.
       01 byline               pic 99     usage comp-5.
       01 offset               pic 9999   usage computational-5.
       01 byte                 pic x      based.
       01 datum                pic 999    usage computational-5.
       01 high                 pic 99     usage computational-5.
       01 low                  pic 99     usage computational-5.
       01 is-ascii             pic x(6).
       01 is-32-bit            pic x(6).
       01 is-big-endian        pic x.
       01 endian-order      pic x(10).

       01 show-hex-group.
          02 hex-line.
             05 show-hexes        pic x(48).
          02 filler redefines hex-line.
             05 filler occurs  16.
               07 filler occurs  3.
                 10 show-hex    pic x.

       01 dots                 pic x(16)  value '................'.
       01 show                 pic x(16).

       01 hex.
          02 high-hex          pic x.
          02 low-hex           pic x.
       01 hex-digit            pic x(16)  value '0123456789abcdef'.

       linkage section.
       01 buffer               pic x.
       01 len                  usage binary-long.
      *> **************************************************************
       
       procedure division using buffer len.

       perform starting-address

       set address  of byte to address of buffer

       perform varying counter from 0 by 16
               until   counter  >=   len
          move counter to offset
          move spaces to show-hexes
          move dots to show
          perform varying byline from 1 by 1
                  until   byline  >  16
             if (counter + byline) > len
                move spaces to show-hexes(3*(byline - 1):3)
                move space to show(byline:1)
             else
                perform calc-hex-value
                if datum > 31 and datum <= 128
                   move byte to show(byline:1)
                end-if
                set address of byte up by 1
             end-if
          end-perform
          display offset "  " show-hexes show
       end-perform
       display ""

       goback.

       CALC-HEX-VALUE SECTION.
         compute  datum = function ord(byte) - 1
         divide   datum by 16 giving high remainder low
         move hex-digit(high + 1:1) to show-hex(byline 1)
         move hex-digit(low + 1:1)  to show-hex(byline 2)
       .

       STARTING-ADDRESS SECTION.
         perform TEST-ASCII
         perform TEST-64bit
         perform TEST-ENDIAN
         set addr      to address of buffer
         set addr2addr to address of addr

      *> To show hex-address, reverse if Big-Little Endian 
         if is-big-endian = "Y"
            set addr2addr up   by function byte-length(addr)
            set addr2addr down by 1
         end-if
         perform varying byline from 1 by 1
                 until byline > function byte-length(addr)
            set address of byte to addr2addr
            perform calc-hex-value
            if is-big-endian = "Y"
              set addr2addr down by 1
            else
              set addr2addr up by 1
            end-if
         end-perform

      *> Display characteristics and headline
         subtract 1 from byline
         display ""
         display "Dump of memory beginning at Hex-address: " 
                  show-hexes(1:3*byline) 
         display "Program runs in " is-32-bit " architecture. "
                 "Char-set is " is-ascii "."
         display  "Byte order is " endian-order " endian."
         display ""
         display "Offs  "
               "HEX-- -- -- 5- -- -- -- -- 10 -- -- -- -- 15 -- "
               "CHARS----1----5-"
       .
       
       TEST-ASCII SECTION.
      *>  WDiscover if running Ascii or Ebcdic
          if " " = X"20"
            move "ASCII " to is-ascii
          else
            if " " = X"40"
              move "EBCDIC" to is-ascii
            else
              move "?" to is-ascii
            end-if
          end-if
       .

       TEST-64BIT SECTION.
      *> Check 32/64 bit.Longer pointers in 64-bit architecture
         if function length(addr) <= 4
           move "32-bit" to is-32-bit
         else
           move "64-bit" to is-32-bit
         end-if
       .

       TEST-ENDIAN SECTION.
      *> Number-bytes are shuffled in Big-Little endian
         move 128 to byline
         set address of byte to address of byline
         if function ord(byte) > 0
            move "Y" to is-big-endian
            move "Big-Little" to endian-order
         else 
            move "N" to is-big-endian
            move "Little-Big" to endian-order
         end-if
       .

       end program OCDUMP.