cobdata

In response to thread COBOL tool, this program parses a copybook, displays offset and
length of each element. This version handles REDEFINES (up to 10 levels deep), OCCURS,
group names and editing pictures.

@OPTIONS SRF(FREE,FREE)
identification division *> Fujitsu requires this to be the first line
. program-id. cobdata
. author. Robert Wagner.

* This program interprets Cobol source describing a record layout,
* typically a copybook.
* Output shows offset and length of each element.
*
* Example input:
* 01 INVOICE-RECORD.
* 10 OP-CO-NO PIC X(3).
* 10 CONTROL-SET-SEQ-NO PIC S9(9) USAGE COMP.
* 10 INVOICE-SEQ-NO PIC S9(4) USAGE COMP.
* 10 AP-CNTRL-ENTITY-CD PIC X(4).
* 10 INVOICE-GROUP-OCCURS OCCURS 3.
* 15 INVOICE-TYPE-CD PIC X(2) OCCURS 3.
* 15 PIC X(2) OCCURS 3.
* 10 LEGACY-VENDOR-NO PIC X(10).
* 10 AP-VENDOR-NO PIC X(30).
* 10 AP-PO-NO PIC X(30).
* 10 AP-EDITED_FIELD PIC ---,zzz.99-.
* 10 INVOICE-DT PIC X(10).
* 10 TOTAL-INVOICE-AM PIC S9(11)V9(2) USAGE COMP-3.
* 10 TOTAL-MERCH-AM PIC S9(11)V99 USAGE COMP-3.
* 10 TERMS-CD PIC XX.
* 10 CARRIER-CD PIC X(10).
* 10 CARRIER-PRO-NO PIC X(10).
* 10 SHIP-DT PIC X(10).
* 10 SHIP-VIA-CD PIC X(3).
* 10 SHIP-LOC-NO PIC X(3).
* 10 SHIP-WT PIC X(10).
* 10 R1 REDEFINES SHIP-WT.
* 15 PIC X(02).
* 15 TARGET1 PIC X(03).
* 15 R2 REDEFINES TARGET1.
* 20 PIC X(02).
* 20 PIC X(02).
* 15 PIC x(02).
* 10 R2 REDEFINES R1 PIC X(05).
* 10 SHIP-UNITS-DC PIC X(10).
* 10 SHIP-TY PIC X(2).

* Example output:
* Lvl Name Pos Len Typ Oc
* 1 01 invoice-record 1 214
* 2 10 op-co-no 1 3
* 3 10 control-set-seq-no 4 4 b
* 4 10 invoice-seq-no 8 2 b
* 5 10 ap-cntrl-entity-cd 10 4
* 6 10 invoice-group-occurs 14 36 3
* 7 15 invoice-type-cd 14 18 9
* 8 15 32 18 9
* 9 10 legacy-vendor-no 50 10
* 10 10 ap-vendor-no 60 30
* 11 10 ap-po-no 90 30
* 12 10 ap-edited 120 11
* 13 10 invoice-dt 131 10
* 14 10 total-invoice-am 141 7 p
* 15 10 total-merch-am 148 7 p
* 16 10 terms-cd 155 2
* 17 10 carrier-cd 157 10
* 18 10 carrier-pro-no 167 10
* 19 10 ship-dt 177 10
* 20 10 ship-via-cd 187 3
* 21 10 ship-loc-no 190 3
* 22 10 ship-wt 193 10
* 23 10 r1 193 7
* 24 15 193 2
* 25 15 target1 195 3
* 26 15 r2 195 4
* 27 20 195 2
* 28 20 197 2
* 29 15 198 2
* 30 10 r2 193 5
* 31 10 ship-units-dc 203 10
* 32 10 ship-ty 213 2
* Record length 214


. data division
. working-storage section
. 01 global-variables value low-values global
. 05 pic x
. 88 end-of-input value 'e'
. 05 pic x
. 88 end-of-sentence value 'e'
. 88 not-end-of-sentence value low-value
. 05 pic x
. 88 end-of-data-file value 'e'
. 01 word-area global
. 05 word-count binary pic s9(04)
. 05 word-limit value 200 binary pic s9(04)
. 05 word-entry occurs 1 to 200 depending on word-count
. 10 word-length binary pic s9(04)
. 10 word-text
. 15 word-byte occurs 50 pic x(01)
. 01 line-text-area global
. 05 line-length binary pic s9(04)
. 05 line-limit binary pic s9(04)
. 05 line-text
. 10 line-byte occurs 1 to 256 depending on line-length pic x
. 01 layout-area global
. 05 layout-count value zero binary pic s9(04)
. 05 layout-limit value 200 binary pic s9(04)
. 05 layout-entry occurs 1 to 200 depending on layout-count indexed x
. 10 layout-level pic x(02)
. 10 layout-name pic x(31)
. 10 layout-occurs binary pic s9(04)
. 10 layout-offset binary pic s9(04)
. 10 layout-length binary pic s9(04)
. 10 layout-extended-length binary pic s9(04)
. 10 layout-type pic x(01)
. 88 type-binary value 'b'
. 88 type-packed value 'p'
. 10 layout-redefines-name pic x(31).
. 10 layout-redefines-stack.
. 15 layout-redefines-depth binary pic s9(02).
. 15 layout-redefines-entry occurs 10 binary pic s9(04).

. procedure division.
perform one-sentence until end-of-input
call 'structure-level-operations'
call 'display-structure'
goback

. one-sentence.
set not-end-of-sentence to true
move zero to word-count
perform one-word until end-of-sentence or end-of-input or
word-count not less than word-limit
if word-count not equal to zero and layout-count < layout-limit
call 'syntax'
end-if
. one-word.
call 'parse'

. identification division
. program-id. syntax
*> Transforms a free-form Cobol sentence into a layout-entry.
. data division
. working-storage section
. 01 unqualified-variables
. 05 n binary pic s9(04)
. 05 m binary pic s9(04)
. 05 takes-space-count-in-word binary pic s9(04)
. 05 pic-count-in-word binary pic s9(04)
. 05 numeric-count-in-word binary pic s9(04)
. 05 pic x(01)
. 88 picture-word value 'p'
. 88 not-picture-word value 'n'
. 05 pic x(01)
. 88 type-seen value 'y'
. 88 type-not-seen value 'n'
. 05 byte-type pic x(01)
. 88 takes-space-type value 'x' '9' 'a' 'z' '*' '-' '+' '.' ','
. 88 no-space-type value 'v' 's' 'p'
. 88 numeric-type value '0' thru '9'
. 05 work-number pic 9(04)
. 05 redefines work-number.
. 10 pic x(03)
. 10 work-number-4 pic x(01)

. procedure division.
add 1 to layout-count
initialize layout-entry (layout-count)
move 1 to layout-occurs (layout-count)
move word-text (1) to layout-level (layout-count)
if word-length (1) equal to 1
string '0' word-text (1) delimited by space
into layout-level (layout-count)
end-if
perform varying n from 2 by 1 until n > word-count
evaluate word-text (n)
when 'pic'
when 'picture'
perform pickup-picture
when 'occurs'
perform pickup-occurs
when 'binary'
when 'comp'
when 'computational'
when 'comp-4'
when 'comp-5'
set type-binary (layout-count) to true
when 'packed-decimal'
when 'comp-3'
when 'computational-3'
set type-packed (layout-count) to true
when 'redefines'
move word-text (n + 1)
to layout-redefines-name (layout-count)
when other
if n equal to 2
move word-text (2) to layout-name (layout-count)
end-if
end-evaluate
end-perform
if type-binary (layout-count)
evaluate layout-length (layout-count)
when 1 thru 4
move 2 to layout-length (layout-count)
when 5 thru 9
move 4 to layout-length (layout-count)
when other
move 8 to layout-length (layout-count)
end-evaluate
end-if
if type-packed (layout-count)
compute layout-length (layout-count) rounded =
(layout-length (layout-count) + 1) / 2
end-if

goback
. pickup-occurs.
add 1 to n
if n < word-count and word-text (n + 1) = 'to'
add 2 to n
end-if
perform pickup-number
move work-number to layout-occurs (layout-count)
. pickup-picture.
*> Picture s9(9)v9(2) will be in four words: s9, 9, v9, 2.
add 1 to n
set picture-word to true
set type-not-seen to true
perform varying n from n by 1 until n > word-count or
not-picture-word
move zero to pic-count-in-word, numeric-count-in-word,
takes-space-count-in-word, work-number
perform varying m from 1 by 1 until m > word-length (n)
move word-byte (n, m) to byte-type
if numeric-type
add 1 to numeric-count-in-word
multiply 10 by work-number
move byte-type to work-number-4
end-if
if takes-space-type
add 1 to pic-count-in-word
add 1 to takes-space-count-in-word
end-if
if no-space-type
add 1 to pic-count-in-word
set type-not-seen to true
end-if
end-perform
evaluate true
when numeric-count-in-word equal to word-length (n) and
type-seen
add work-number -1 to layout-length (layout-count)
when pic-count-in-word equal to word-length (n) and
type-not-seen
set type-seen to true
add takes-space-count-in-word to layout-length (layout-count)
when other
set not-picture-word to true
subtract 2 from n *> in case OCCURS follows picture
end-evaluate
end-perform

. pickup-number.
move zero to work-number
perform varying m from 1 by 1 until m > word-length (n)
multiply 10 by work-number
move word-byte (n, m) to work-number-4
end-perform
. end program syntax

. identification division
. program-id. parse
*> Parser. Returns the next word.

. data division
. working-storage section
. 01 unqualified-variables
. 05 n value 1 binary pic s9(04)
. 05 m binary pic s9(04)
. 05 byte-type pic x(01)
. 88 in-a-word value 'x' '9'
. 88 alpha-character value 'x'
. 88 numeric-character value '9'
. 05 quote-character pic x(01)
. 88 in-a-quote value x'22' x'27'
. 05 a-byte pic x(01)
. 88 full-stop value '.'

. procedure division.
move space to byte-type
perform varying n from n by 1 until in-a-word or in-a-quote
if n greater than line-length
call 'read-input'
move zero to n
if end-of-input goback end-if
else
perform pickup-byte
if end-of-sentence
goback
end-if
end-if
end-perform

add 1 to word-count
move spaces to word-text (word-count)
subtract 1 from n

perform varying word-length (word-count) from 1 by 1 until
not (in-a-word or in-a-quote) or
word-length (word-count) not less length of word-text or
end-of-sentence
move word-length (word-count) to m
move a-byte to word-byte (word-count, m)
if in-a-quote and a-byte equal to quote-character and
word-length (word-count) greater than 1
move space to quote-character
end-if
add 1 to n
if n greater than line-length goback end-if
perform pickup-byte
end-perform
subtract 1 from word-length (word-count)

goback

. pickup-byte.
move line-byte (n) to a-byte, byte-type
inspect byte-type converting
'abcdefghijklmnopqrstuvwxyz-+,*.0123456789' to
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx9999999999'
if full-stop and
(n not less than line-length or
line-byte (n + 1) equal to space)
and not in-a-quote
set end-of-sentence to true
move space to a-byte, byte-type
add 1 to n
end-if

. identification division
. program-id. read-input
*> Returns the next line from input file
*> Deletes comments
. environment division
. input-output section
. file-control
. select input-file assign to 'cobdata.in'
organization is line sequential

. data division
. file section
. fd input-file
. 01 input-record pic x(256)
. 01 input-card.
. 05 columns-1-6 pic x(06)
. 05 columns-7-72
. 10 pic x(01)
. 10 columns-8-72 pic x(65)
. 05 columns-73-80 pic x(08)

. working-storage section
. 01 persistent-variables
. 05 value low-value pic x(01)
. 88 file-open value 'y'
. 88 file-closed value low-value
. 05 value low-value pic x(01)
. 88 free-form value 'f'.
. 88 fixed-form value low-value.
. 01 unqualified-variables.
. 05 n binary pic s9(04)

. procedure division.
if file-closed
open input input-file
set file-open to true
end-if

read input-file at end
set end-of-input to true
close input-file
set file-closed to true
move zero to line-length
goback
end-read

if fixed-form
move 66 to line-length, line-limit
move columns-7-72 to line-text
else
move 256 to line-length, line-limit
move input-record to line-text
end-if

if columns-7-72 equal to '$SET SOURCEFORMAT"FREE"' or
columns-8-72 equal to '@OPTIONS SRF(FREE,FREE)'
set free-form to true
move zero to line-limit
end-if
if columns-7-72 equal to '$SET SOURCEFORMAT"FIXED"' or
columns-8-72 equal to '@OPTIONS SRF(FIX,FIX)'
set fixed-form to true
move zero to line-limit
end-if
if line-byte (1) equal to '*' or '/'
move zero to line-limit
end-if
move zero to line-length
perform varying n from 1 by 1 until n greater than line-limit
if line-byte (n) equal to '*' and
n less than line-length and
line-byte (n + 1) equal to '>'
exit perform
end-if
if line-byte (n) not equal to space
move n to line-length
end-if
end-perform
if line-length greater than zero
inspect line-text converting
'ABCDEFGHIJKLMNOPQRSTUVWXYZ' to
'abcdefghijklmnopqrstuvwxyz'
end-if
goback
. end program read-input
. end program parse

. identification division
. program-id. structure-level-operations
. data division
. working-storage section
. 01 unqualified-variables
. 05 n binary pic s9(04)
. 05 n1 binary pic s9(04)
. 05 n2 binary pic s9(04)
. procedure division.
perform varying n from 1 by 1 until n > layout-count
*> propogate group level OCCURS down to subordinates
if layout-occurs (n) not equal to 1
compute n1 = n + 1
perform varying n1 from n1 by 1
until n1 greater than layout-count
or layout-level (n1) not > layout-level (n)
multiply layout-occurs (n) by layout-occurs (n1)
end-perform
end-if
*> propogate REDEFINES down to subordinates
if layout-redefines-name (n) not equal to spaces
set x to 1
search layout-entry
at end
display 'Could not find redefines target '
layout-redefines-name (n)
when layout-name (x) = layout-redefines-name (n)
and layout-redefines-depth (n) < 10
add 1 to layout-redefines-depth (n)
move layout-redefines-depth (n) to n2
set layout-redefines-entry (n, n2) to x
compute n1 = n + 1
perform varying n1 from n1 by 1
until n1 greater than layout-count
or layout-level (n1) not > layout-level (n)
move layout-redefines-stack (n)
to layout-redefines-stack (n1)
end-perform
end-search
end-if
*> compute extended length
compute layout-extended-length (n) =
layout-length (n) * layout-occurs (n)
end-perform
perform varying n from 1 by 1 until n > layout-count
*> compute all offsets
evaluate true
when n equal to 1
move 1 to layout-offset (n)
when layout-redefines-depth (n) = layout-redefines-depth (n - 1)
and layout-redefines-name (n) = spaces
compute layout-offset (n) =
layout-offset (n - 1) + layout-extended-length (n - 1)
when layout-redefines-depth (n) > layout-redefines-depth (n - 1)
move layout-redefines-depth (n) to n2
move layout-redefines-entry (n, n2) to n1
compute layout-offset (n) = layout-offset (n1)
when layout-redefines-depth (n) < layout-redefines-depth (n - 1)
or layout-redefines-name (n) not = spaces
compute n1 = n - 1
perform varying n1 from n1 by -1
until n1 less than 1
or (layout-redefines-depth (n1) not >
layout-redefines-depth (n) and
layout-level (n1) not >
layout-level (n))
continue
end-perform
if n1 not less than 1
compute layout-offset (n) = layout-offset (n1)
if layout-redefines-name (n) equal to spaces
add layout-extended-length (n1)
to layout-offset (n)
end-if
else
display 'Internal error on ' layout-name (n)
end-if
end-evaluate
end-perform
perform varying n from 1 by 1 until n > layout-count
*> compute length of group names
if layout-extended-length (n) = zero
compute n1 = n + 1
perform varying n1 from n1 by 1
until n1 greater than layout-count
or layout-level (n1) not > layout-level (n)
if layout-redefines-depth (n1) not >
layout-redefines-depth (n)
add layout-extended-length (n1)
to layout-extended-length (n)
end-if
end-perform
end-if
end-perform
goback
. end program structure-level-operations

. identification division
. program-id. display-structure
*> Displays the structure on output file or console
. environment division
. input-output section
. file-control
. select output-file assign to 'cobdata.out'
organization is line sequential

. data division
. file section
. fd output-file
. 01 output-line pic x(256)
. working-storage section
. 01 unqualified-variables
. 05 n value zero binary pic s9(04)
. 01 display-line.
. 05 edited-count pic z(04)-
. 05 edited-level pic x(03)
. 05 edited-name pic x(31)
. 05 edited-offset pic z(04)
. 05 edited-length pic z(04)
. 05 pic x(01)
. 05 edited-type pic x(03)
. 05 edited-occurs pic z(03)
. procedure division.
open output output-file
move ' Lvl Name Pos Len Typ Occ'
to display-line
perform write-a-line
perform varying n from 1 by 1 until n > layout-count
move spaces to display-line
move n to edited-count
move layout-level (n) to edited-level
move layout-name (n) to edited-name
move layout-offset (n) to edited-offset
move layout-extended-length (n) to edited-length
move layout-type (n) to edited-type
if layout-occurs (n) > 1
move layout-occurs (n) to edited-occurs
end-if
perform write-a-line
end-perform
move spaces to display-line
move 'Record length' to edited-name
compute edited-length =
layout-offset (layout-count) + layout-length (layout-count) - 1
perform write-a-line
close output-file
goback
. write-a-line.
display display-line
write output-line from display-line
. end program display-structure

. end program cobdata

"Robert" <no@e.mail> wrote in message
news:mi4pb49oj9u9fjsatnkans7dr4qkimaq3v@4ax.com...
> In response to thread COBOL tool, this program parses a copybook,
> displays offset and
> length of each element. This version handles REDEFINES (up to 10 levels
> deep), OCCURS,
> group names and editing pictures.
>
> @OPTIONS SRF(FREE,FREE)
> identification division *> Fujitsu requires this to be the first line
> . program-id. cobdata
> . author. Robert Wagner.
>
> * This program interprets Cobol source describing a record layout,
> * typically a copybook.
> * Output shows offset and length of each element.
> *
> * Example input:
> * 01 INVOICE-RECORD.
> * 10 OP-CO-NO PIC X(3).
> * 10 CONTROL-SET-SEQ-NO PIC S9(9) USAGE COMP.
> * 10 INVOICE-SEQ-NO PIC S9(4) USAGE COMP.
> * 10 AP-CNTRL-ENTITY-CD PIC X(4).
> * 10 INVOICE-GROUP-OCCURS OCCURS 3.
> * 15 INVOICE-TYPE-CD PIC X(2) OCCURS 3.
> * 15 PIC X(2) OCCURS 3.
> * 10 LEGACY-VENDOR-NO PIC X(10).
> * 10 AP-VENDOR-NO PIC X(30).
> * 10 AP-PO-NO PIC X(30).
> * 10 AP-EDITED_FIELD PIC ---,zzz.99-.
> * 10 INVOICE-DT PIC X(10).
> * 10 TOTAL-INVOICE-AM PIC S9(11)V9(2) USAGE COMP-3.
> * 10 TOTAL-MERCH-AM PIC S9(11)V99 USAGE COMP-3.
> * 10 TERMS-CD PIC XX.
> * 10 CARRIER-CD PIC X(10).
> * 10 CARRIER-PRO-NO PIC X(10).
> * 10 SHIP-DT PIC X(10).
> * 10 SHIP-VIA-CD PIC X(3).
> * 10 SHIP-LOC-NO PIC X(3).
> * 10 SHIP-WT PIC X(10).
> * 10 R1 REDEFINES SHIP-WT.
> * 15 PIC X(02).
> * 15 TARGET1 PIC X(03).
> * 15 R2 REDEFINES TARGET1.
> * 20 PIC X(02).
> * 20 PIC X(02).
> * 15 PIC x(02).
> * 10 R2 REDEFINES R1 PIC X(05).
> * 10 SHIP-UNITS-DC PIC X(10).
> * 10 SHIP-TY PIC X(2).
>
> * Example output:
> * Lvl Name Pos Len Typ Oc
> * 1 01 invoice-record 1 214
> * 2 10 op-co-no 1 3
> * 3 10 control-set-seq-no 4 4 b
> * 4 10 invoice-seq-no 8 2 b
> * 5 10 ap-cntrl-entity-cd 10 4
> * 6 10 invoice-group-occurs 14 36 3
> * 7 15 invoice-type-cd 14 18 9
> * 8 15 32 18 9
> * 9 10 legacy-vendor-no 50 10
> * 10 10 ap-vendor-no 60 30
> * 11 10 ap-po-no 90 30
> * 12 10 ap-edited 120 11
> * 13 10 invoice-dt 131 10
> * 14 10 total-invoice-am 141 7 p
> * 15 10 total-merch-am 148 7 p
> * 16 10 terms-cd 155 2
> * 17 10 carrier-cd 157 10
> * 18 10 carrier-pro-no 167 10
> * 19 10 ship-dt 177 10
> * 20 10 ship-via-cd 187 3
> * 21 10 ship-loc-no 190 3
> * 22 10 ship-wt 193 10
> * 23 10 r1 193 7
> * 24 15 193 2
> * 25 15 target1 195 3
> * 26 15 r2 195 4
> * 27 20 195 2
> * 28 20 197 2
> * 29 15 198 2
> * 30 10 r2 193 5
> * 31 10 ship-units-dc 203 10
> * 32 10 ship-ty 213 2
> * Record length 214
>
>
> . data division
> . working-storage section
> . 01 global-variables value low-values global
> . 05 pic x
> . 88 end-of-input value 'e'
> . 05 pic x
> . 88 end-of-sentence value 'e'
> . 88 not-end-of-sentence value low-value
> . 05 pic x
> . 88 end-of-data-file value 'e'
> . 01 word-area global
> . 05 word-count binary pic s9(04)
> . 05 word-limit value 200 binary pic s9(04)
> . 05 word-entry occurs 1 to 200 depending on word-count
> . 10 word-length binary pic s9(04)
> . 10 word-text
> . 15 word-byte occurs 50 pic x(01)
> . 01 line-text-area global
> . 05 line-length binary pic s9(04)
> . 05 line-limit binary pic s9(04)
> . 05 line-text
> . 10 line-byte occurs 1 to 256 depending on line-length pic x
> . 01 layout-area global
> . 05 layout-count value zero binary pic s9(04)
> . 05 layout-limit value 200 binary pic s9(04)
> . 05 layout-entry occurs 1 to 200 depending on layout-count indexed x
> . 10 layout-level pic x(02)
> . 10 layout-name pic x(31)
> . 10 layout-occurs binary pic s9(04)
> . 10 layout-offset binary pic s9(04)
> . 10 layout-length binary pic s9(04)
> . 10 layout-extended-length binary pic s9(04)
> . 10 layout-type pic x(01)
> . 88 type-binary value 'b'
> . 88 type-packed value 'p'
> . 10 layout-redefines-name pic x(31).
> . 10 layout-redefines-stack.
> . 15 layout-redefines-depth binary pic s9(02).
> . 15 layout-redefines-entry occurs 10 binary pic s9(04).
>
> . procedure division.
> perform one-sentence until end-of-input
> call 'structure-level-operations'
> call 'display-structure'
> goback
>
> . one-sentence.
> set not-end-of-sentence to true
> move zero to word-count
> perform one-word until end-of-sentence or end-of-input or
> word-count not less than word-limit
> if word-count not equal to zero and layout-count < layout-limit
> call 'syntax'
> end-if
> . one-word.
> call 'parse'
>
> . identification division
> . program-id. syntax
> *> Transforms a free-form Cobol sentence into a layout-entry.
> . data division
> . working-storage section
> . 01 unqualified-variables
> . 05 n binary pic s9(04)
> . 05 m binary pic s9(04)
> . 05 takes-space-count-in-word binary pic s9(04)
> . 05 pic-count-in-word binary pic s9(04)
> . 05 numeric-count-in-word binary pic s9(04)
> . 05 pic x(01)
> . 88 picture-word value 'p'
> . 88 not-picture-word value 'n'
> . 05 pic x(01)
> . 88 type-seen value 'y'
> . 88 type-not-seen value 'n'
> . 05 byte-type pic x(01)
> . 88 takes-space-type value 'x' '9' 'a' 'z' '*' '-' '+' '.' ','
> . 88 no-space-type value 'v' 's' 'p'
> . 88 numeric-type value '0' thru '9'
> . 05 work-number pic 9(04)
> . 05 redefines work-number.
> . 10 pic x(03)
> . 10 work-number-4 pic x(01)
>
> . procedure division.
> add 1 to layout-count
> initialize layout-entry (layout-count)
> move 1 to layout-occurs (layout-count)
> move word-text (1) to layout-level (layout-count)
> if word-length (1) equal to 1
> string '0' word-text (1) delimited by space
> into layout-level (layout-count)
> end-if
> perform varying n from 2 by 1 until n > word-count
> evaluate word-text (n)
> when 'pic'
> when 'picture'
> perform pickup-picture
> when 'occurs'
> perform pickup-occurs
> when 'binary'
> when 'comp'
> when 'computational'
> when 'comp-4'
> when 'comp-5'
> set type-binary (layout-count) to true
> when 'packed-decimal'
> when 'comp-3'
> when 'computational-3'
> set type-packed (layout-count) to true
> when 'redefines'
> move word-text (n + 1)
> to layout-redefines-name (layout-count)
> when other
> if n equal to 2
> move word-text (2) to layout-name (layout-count)
> end-if
> end-evaluate
> end-perform
> if type-binary (layout-count)
> evaluate layout-length (layout-count)
> when 1 thru 4
> move 2 to layout-length (layout-count)
> when 5 thru 9
> move 4 to layout-length (layout-count)
> when other
> move 8 to layout-length (layout-count)
> end-evaluate
> end-if
> if type-packed (layout-count)
> compute layout-length (layout-count) rounded =
> (layout-length (layout-count) + 1) / 2
> end-if
>
> goback
> . pickup-occurs.
> add 1 to n
> if n < word-count and word-text (n + 1) = 'to'
> add 2 to n
> end-if
> perform pickup-number
> move work-number to layout-occurs (layout-count)
> . pickup-picture.
> *> Picture s9(9)v9(2) will be in four words: s9, 9, v9, 2.
> add 1 to n
> set picture-word to true
> set type-not-seen to true
> perform varying n from n by 1 until n > word-count or
> not-picture-word
> move zero to pic-count-in-word, numeric-count-in-word,
> takes-space-count-in-word, work-number
> perform varying m from 1 by 1 until m > word-length (n)
> move word-byte (n, m) to byte-type
> if numeric-type
> add 1 to numeric-count-in-word
> multiply 10 by work-number
> move byte-type to work-number-4
> end-if
> if takes-space-type
> add 1 to pic-count-in-word
> add 1 to takes-space-count-in-word
> end-if
> if no-space-type
> add 1 to pic-count-in-word
> set type-not-seen to true
> end-if
> end-perform
> evaluate true
> when numeric-count-in-word equal to word-length (n) and
> type-seen
> add work-number -1 to layout-length (layout-count)
> when pic-count-in-word equal to word-length (n) and
> type-not-seen
> set type-seen to true
> add takes-space-count-in-word to layout-length
> (layout-count)
> when other
> set not-picture-word to true
> subtract 2 from n *> in case OCCURS follows picture
> end-evaluate
> end-perform
>
> . pickup-number.
> move zero to work-number
> perform varying m from 1 by 1 until m > word-length (n)
> multiply 10 by work-number
> move word-byte (n, m) to work-number-4
> end-perform
> . end program syntax
>
> . identification division
> . program-id. parse
> *> Parser. Returns the next word.
>
> . data division
> . working-storage section
> . 01 unqualified-variables
> . 05 n value 1 binary pic s9(04)
> . 05 m binary pic s9(04)
> . 05 byte-type pic x(01)
> . 88 in-a-word value 'x' '9'
> . 88 alpha-character value 'x'
> . 88 numeric-character value '9'
> . 05 quote-character pic x(01)
> . 88 in-a-quote value x'22' x'27'
> . 05 a-byte pic x(01)
> . 88 full-stop value '.'
>
> . procedure division.
> move space to byte-type
> perform varying n from n by 1 until in-a-word or in-a-quote
> if n greater than line-length
> call 'read-input'
> move zero to n
> if end-of-input goback end-if
> else
> perform pickup-byte
> if end-of-sentence
> goback
> end-if
> end-if
> end-perform
>
> add 1 to word-count
> move spaces to word-text (word-count)
> subtract 1 from n
>
> perform varying word-length (word-count) from 1 by 1 until
> not (in-a-word or in-a-quote) or
> word-length (word-count) not less length of word-text or
> end-of-sentence
> move word-length (word-count) to m
> move a-byte to word-byte (word-count, m)
> if in-a-quote and a-byte equal to quote-character and
> word-length (word-count) greater than 1
> move space to quote-character
> end-if
> add 1 to n
> if n greater than line-length goback end-if
> perform pickup-byte
> end-perform
> subtract 1 from word-length (word-count)
>
> goback
>
> . pickup-byte.
> move line-byte (n) to a-byte, byte-type
> inspect byte-type converting
> 'abcdefghijklmnopqrstuvwxyz-+,*.0123456789' to
> 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx9999999999'
> if full-stop and
> (n not less than line-length or
> line-byte (n + 1) equal to space)
> and not in-a-quote
> set end-of-sentence to true
> move space to a-byte, byte-type
> add 1 to n
> end-if
>
> . identification division
> . program-id. read-input
> *> Returns the next line from input file
> *> Deletes comments
> . environment division
> . input-output section
> . file-control
> . select input-file assign to 'cobdata.in'
> organization is line sequential
>
> . data division
> . file section
> . fd input-file
> . 01 input-record pic x(256)
> . 01 input-card.
> . 05 columns-1-6 pic x(06)
> . 05 columns-7-72
> . 10 pic x(01)
> . 10 columns-8-72 pic x(65)
> . 05 columns-73-80 pic x(08)
>
> . working-storage section
> . 01 persistent-variables
> . 05 value low-value pic x(01)
> . 88 file-open value 'y'
> . 88 file-closed value low-value
> . 05 value low-value pic x(01)
> . 88 free-form value 'f'.
> . 88 fixed-form value low-value.
> . 01 unqualified-variables.
> . 05 n binary pic s9(04)
>
> . procedure division.
> if file-closed
> open input input-file
> set file-open to true
> end-if
>
> read input-file at end
> set end-of-input to true
> close input-file
> set file-closed to true
> move zero to line-length
> goback
> end-read
>
> if fixed-form
> move 66 to line-length, line-limit
> move columns-7-72 to line-text
> else
> move 256 to line-length, line-limit
> move input-record to line-text
> end-if
>
> if columns-7-72 equal to '$SET SOURCEFORMAT"FREE"' or
> columns-8-72 equal to '@OPTIONS SRF(FREE,FREE)'
> set free-form to true
> move zero to line-limit
> end-if
> if columns-7-72 equal to '$SET SOURCEFORMAT"FIXED"' or
> columns-8-72 equal to '@OPTIONS SRF(FIX,FIX)'
> set fixed-form to true
> move zero to line-limit
> end-if
> if line-byte (1) equal to '*' or '/'
> move zero to line-limit
> end-if
> move zero to line-length
> perform varying n from 1 by 1 until n greater than line-limit
> if line-byte (n) equal to '*' and
> n less than line-length and
> line-byte (n + 1) equal to '>'
> exit perform
> end-if
> if line-byte (n) not equal to space
> move n to line-length
> end-if
> end-perform
> if line-length greater than zero
> inspect line-text converting
> 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' to
> 'abcdefghijklmnopqrstuvwxyz'
> end-if
> goback
> . end program read-input
> . end program parse
>
> . identification division
> . program-id. structure-level-operations
> . data division
> . working-storage section
> . 01 unqualified-variables
> . 05 n binary pic s9(04)
> . 05 n1 binary pic s9(04)
> . 05 n2 binary pic s9(04)
> . procedure division.
> perform varying n from 1 by 1 until n > layout-count
> *> propogate group level OCCURS down to subordinates
> if layout-occurs (n) not equal to 1
> compute n1 = n + 1
> perform varying n1 from n1 by 1
> until n1 greater than layout-count
> or layout-level (n1) not > layout-level (n)
> multiply layout-occurs (n) by layout-occurs (n1)
> end-perform
> end-if
> *> propogate REDEFINES down to subordinates
> if layout-redefines-name (n) not equal to spaces
> set x to 1
> search layout-entry
> at end
> display 'Could not find redefines target '
> layout-redefines-name (n)
> when layout-name (x) = layout-redefines-name (n)
> and layout-redefines-depth (n) < 10
> add 1 to layout-redefines-depth (n)
> move layout-redefines-depth (n) to n2
> set layout-redefines-entry (n, n2) to x
> compute n1 = n + 1
> perform varying n1 from n1 by 1
> until n1 greater than layout-count
> or layout-level (n1) not > layout-level (n)
> move layout-redefines-stack (n)
> to layout-redefines-stack (n1)
> end-perform
> end-search
> end-if
> *> compute extended length
> compute layout-extended-length (n) =
> layout-length (n) * layout-occurs (n)
> end-perform
> perform varying n from 1 by 1 until n > layout-count
> *> compute all offsets
> evaluate true
> when n equal to 1
> move 1 to layout-offset (n)
> when layout-redefines-depth (n) = layout-redefines-depth
> (n - 1)
> and layout-redefines-name (n) = spaces
> compute layout-offset (n) =
> layout-offset (n - 1) + layout-extended-length (n -
> 1)
> when layout-redefines-depth (n) > layout-redefines-depth
> (n - 1)
> move layout-redefines-depth (n) to n2
> move layout-redefines-entry (n, n2) to n1
> compute layout-offset (n) = layout-offset (n1)
> when layout-redefines-depth (n) < layout-redefines-depth
> (n - 1)
> or layout-redefines-name (n) not = spaces
> compute n1 = n - 1
> perform varying n1 from n1 by -1
> until n1 less than 1
> or (layout-redefines-depth (n1) not >
> layout-redefines-depth (n) and
> layout-level (n1) not >
> layout-level (n))
> continue
> end-perform
> if n1 not less than 1
> compute layout-offset (n) = layout-offset (n1)
> if layout-redefines-name (n) equal to spaces
> add layout-extended-length (n1)
> to layout-offset (n)
> end-if
> else
> display 'Internal error on ' layout-name (n)
> end-if
> end-evaluate
> end-perform
> perform varying n from 1 by 1 until n > layout-count
> *> compute length of group names
> if layout-extended-length (n) = zero
> compute n1 = n + 1
> perform varying n1 from n1 by 1
> until n1 greater than layout-count
> or layout-level (n1) not > layout-level (n)
> if layout-redefines-depth (n1) not >
> layout-redefines-depth (n)
> add layout-extended-length (n1)
> to layout-extended-length (n)
> end-if
> end-perform
> end-if
> end-perform
> goback
> . end program structure-level-operations
>
> . identification division
> . program-id. display-structure
> *> Displays the structure on output file or console
> . environment division
> . input-output section
> . file-control
> . select output-file assign to 'cobdata.out'
> organization is line sequential
>
> . data division
> . file section
> . fd output-file
> . 01 output-line pic x(256)
> . working-storage section
> . 01 unqualified-variables
> . 05 n value zero binary pic s9(04)
> . 01 display-line.
> . 05 edited-count pic z(04)-
> . 05 edited-level pic x(03)
> . 05 edited-name pic x(31)
> . 05 edited-offset pic z(04)
> . 05 edited-length pic z(04)
> . 05 pic x(01)
> . 05 edited-type pic x(03)
> . 05 edited-occurs pic z(03)
> . procedure division.
> open output output-file
> move ' Lvl Name Pos Len Typ Occ'
> to display-line
> perform write-a-line
> perform varying n from 1 by 1 until n > layout-count
> move spaces to display-line
> move n to edited-count
> move layout-level (n) to edited-level
> move layout-name (n) to edited-name
> move layout-offset (n) to edited-offset
> move layout-extended-length (n) to edited-length
> move layout-type (n) to edited-type
> if layout-occurs (n) > 1
> move layout-occurs (n) to edited-occurs
> end-if
> perform write-a-line
> end-perform
> move spaces to display-line
> move 'Record length' to edited-name
> compute edited-length =
> layout-offset (layout-count) + layout-length (layout-count) - 1
> perform write-a-line
> close output-file
> goback
> . write-a-line.
> display display-line
> write output-line from display-line
> . end program display-structure
>
> . end program cobdata
> .
>
>
> Pete: did you receive my email? If you want changes, respond here or
> email.

Thanks Robert. No, I didn't receive any email from you, but seeing your post
here made me search my SPAM folder and THEN I found it :-) I have since
responded privately.

Cheers,

Pete.
--
"I used to write COBOL...now I can do anything."