>>SOURCE FORMAT IS FREE
identification division.
*> this code is dedicated to the public domain
*> (GnuCOBOL) 2.3-dev.0
program-id. generator.
environment division.
configuration section.
repository.  function all intrinsic.
data division.
working-storage section.
01  program-name pic x(32) value spaces global.
01  input-name pic x(32) value spaces global.
01  input-status pic xx global.

01  ast-record global.
    03  ast-type pic x(14).
    03  ast-value pic x(48).
    03  filler redefines ast-value.
        05  asl-left pic 999.
        05  asl-right pic 999.

01  error-record pic x(64) value spaces global.

01  loadstack global.
    03  l pic 99 value 0.
    03  l-lim pic 99 value 64.
    03  load-entry occurs 64.
        05  l-node pic x(14).
        05  l-left pic 999.
        05  l-right pic 999.
        05  l-link pic 999.

01  abstract-syntax-tree global.
    03  t pic 999 value 0.
    03  t1 pic 999.
    03  t-lim pic 999 value 998.
    03  filler occurs 998.
        05  p1 pic 999.
        05  p2 pic 999.
        05  p3 pic 999.
        05  n1 pic 999.
        05  leaf.
            07  leaf-type pic x(14).
            07  leaf-value pic x(48).
        05  node redefines leaf.
            07  node-type pic x(14).
            07  node-left pic 999.
            07  node-right pic 999.

01  opcodes global.
    03  opFETCH pic x value x'00'.
    03  opSTORE pic x value x'01'.
    03  opPUSH  pic x value x'02'.
    03  opADD   pic x value x'03'.
    03  opSUB   pic x value x'04'.
    03  opMUL   pic x value x'05'.
    03  opDIV   pic x value x'06'.
    03  opMOD   pic x value x'07'.
    03  opLT    pic x value x'08'.
    03  opGT    pic x value x'09'.
    03  opLE    pic x value x'0A'.
    03  opGE    pic x value x'0B'.
    03  opEQ    pic x value x'0C'.
    03  opNE    pic x value x'0D'.
    03  opAND   pic x value x'0E'.
    03  opOR    pic x value x'0F'.
    03  opNEG   pic x value x'10'.
    03  opNOT   pic x value x'11'.
    03  opJMP   pic x value x'13'.
    03  opJZ    pic x value x'14'.
    03  opPRTC  pic x value x'15'.
    03  opPRTS  pic x value x'16'.
    03  opPRTI  pic x value x'17'.
    03  opHALT  pic x value x'18'.

01  variables global.
    03  v pic 99.
    03  v-max pic 99 value 0.
    03  v-lim pic 99 value 16.
    03  variable-entry occurs 16 pic x(48).

01  strings global.
    03  s pic 99.
    03  s-max pic 99 value 0.
    03  s-lim pic 99 value 16.
    03  string-entry occurs 16 pic x(48).

01  generated-code global.
    03  c  pic 999 value 1.
    03  c1 pic 999.
    03  c-lim pic 999 value 512.
    03  kode pic x(512).

procedure division chaining program-name.
start-generator.
    call 'loadast'
    if program-name <> spaces
        call 'readinput' *> close input-file
    end-if
    >>d perform print-ast
    call 'codegen' using t
    call 'emitbyte' using opHALT
    >>d call 'showhex' using kode c
    call 'listcode'
    stop run
    .
print-ast.
    call 'printast' using t
    display 'ast:' upon syserr
    display 't=' t
    perform varying t1 from 1 by 1 until t1 > t
        if leaf-type(t1) = 'Identifier' or 'Integer' or 'String'
            display t1 space trim(leaf-type(t1)) space trim(leaf-value(t1)) upon syserr
        else
            display t1 space node-left(t1) space node-right(t1) space trim(node-type(t1))
                upon syserr
        end-if
    end-perform
    .
identification division.
program-id. codegen common recursive.
data division.
working-storage section.
01  r pic ---9.
linkage section.
01  n pic 999.
procedure division using n.
start-codegen.
    if n = 0
        exit program
    end-if
    >>d display 'at 'c ' node=' space n space node-type(n) upon syserr
    evaluate node-type(n)
    when 'Identifier'
        call 'emitbyte' using opFetch
        call 'variableoffset' using leaf-value(n)
        call 'emitword' using v '0'
    when 'Integer'
        call 'emitbyte' using opPUSH
        call 'emitword' using leaf-value(n) '0'
    when 'String'
        call 'emitbyte' using opPUSH
        call 'stringoffset' using leaf-value(n)
        call 'emitword' using s '0'
    when 'Assign'
        call 'codegen' using node-right(n)
        call 'emitbyte' using opSTORE
        move node-left(n) to n1(n)
        call 'variableoffset' using leaf-value(n1(n))
        call 'emitword' using v '0'
    when 'If'
        call 'codegen' using node-left(n)          *> conditional expr
        call 'emitbyte' using opJZ                 *> jump to false path or exit
        move c to p1(n)
        call 'emitword' using '0' '0'
        move node-right(n) to n1(n)                *> true path
        call 'codegen' using node-left(n1(n))
        if node-right(n1(n)) <> 0                  *> there is a false path
            call 'emitbyte' using opJMP            *> jump past false path
            move c to p2(n)
            call 'emitword' using '0' '0'
            compute r = c - p1(n)                  *> fill in jump to false path
            call 'emitword' using r p1(n)
            call 'codegen' using node-right(n1(n)) *> false path
            compute r = c - p2(n)                  *> fill in jump to exit
            call 'emitword' using r p2(n)
        else
            compute r = c - p1(n)
            call 'emitword' using r p1(n)          *> fill in jump to exit
        end-if
    when 'While'
        move c to p3(n)                            *> save address of while start
        call 'codegen' using node-left(n)          *> conditional expr
        call 'emitbyte' using opJZ                 *> jump to exit
        move c to p2(n)
        call 'emitword' using '0' '0'
        call 'codegen' using node-right(n)         *> while body
        call 'emitbyte' using opJMP                *> jump to while start
        compute r = p3(n) - c
        call 'emitword' using r '0'
        compute r = c - p2(n)                      *> fill in jump to exit
        call 'emitword' using r p2(n)
    when 'Sequence'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
    when 'Prtc'
        call 'codegen' using node-left(n)
        call 'emitbyte' using opPRTC
    when 'Prti'
        call 'codegen' using node-left(n)
        call 'emitbyte' using opPRTI
    when 'Prts'
        call 'codegen' using node-left(n)
        call 'emitbyte' using opPRTS
    when 'Less'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opLT
    when 'Greater'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opGT
    when 'LessEqual'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opLE
    when 'GreaterEqual'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opGE
    when 'Equal'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opEQ
    when 'NotEqual'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opNE
    when 'And'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opAND
    when 'Or'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opOR
    when 'Subtract'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opSUB
    when 'Add'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opADD
    when 'Divide'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opDIV
    when 'Multiply'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opMUL
    when 'Mod'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opMOD
    when 'Negate'
       call 'codegen' using node-left(n)
       call 'emitbyte' using opNEG
    when 'Not'
        call 'codegen' using node-left(n)
        call 'emitbyte' using opNOT
    when other
        string 'in generator unknown node type: ' node-type(n) into error-record
        call 'reporterror'
    end-evaluate
    .
end program codegen.

identification division.
program-id. variableoffset common.
data division.
linkage section.
01  variable-value pic x(48).
procedure division using variable-value.
start-variableoffset.
    perform varying v from 1 by 1
    until v > v-max
    or variable-entry(v) = variable-value
        continue
    end-perform
    if v > v-lim
        string 'in generator variable offset v exceeds ' v-lim into error-record
        call 'reporterror'
    end-if
    if v > v-max
        move v to v-max
        move variable-value to variable-entry(v)
    end-if
    .
end program variableoffset.

identification division.
program-id. stringoffset common.
data division.
linkage section.
01  string-value pic x(48).
procedure division using string-value.
start-stringoffset.
    perform varying s from 1 by 1
    until s > s-max
    or string-entry(s) = string-value
        continue
    end-perform
    if s > s-lim
        string ' generator stringoffset s exceeds ' s-lim into error-record
        call 'reporterror'
    end-if
    if s > s-max
        move s to s-max
        move string-value to string-entry(s)
    end-if
    subtract 1 from s *> convert index to offset
    .
end program stringoffset.

identification division.
program-id. emitbyte common.
data division.
linkage section.
01  opcode pic x.
procedure division using opcode.
start-emitbyte.
    if c >= c-lim
        string 'in generator emitbyte c exceeds ' c-lim into error-record
        call 'reporterror'
    end-if
    move opcode to kode(c:1)
    add 1 to c
    .
end program emitbyte.

identification division.
program-id. emitword common.
data division.
working-storage section.
01  word-x.
    03  word usage binary-int.
01  loc pic 999.
linkage section.
01  word-value any length.
01  loc-value any length.
procedure division using word-value loc-value.
start-emitword.
    if c + length(word) > c-lim
        string 'in generator emitword exceeds ' c-lim into error-record
        call 'reporterror'
    end-if
    move numval(word-value) to word
    move numval(loc-value) to loc
    if loc = 0
        move word-x to kode(c:length(word))
        add length(word) to c
    else
        move word-x to kode(loc:length(word))
    end-if
    .
end program emitword.

identification division.
program-id. listcode common.
data division.
working-storage section.
01  word-x.
    03  word usage binary-int.
01  address-display pic ---9.
01  address-absolute pic zzz9.
01  data-display pic -(9)9.
01  v-display pic z9.
01  s-display pic z9.
01  c-display pic zzz9.
procedure division.
start-listcode.
    move v-max to v-display
    move s-max to s-display
    display 'Datasize: ' trim(v-display) space 'Strings: ' trim(s-display)

    perform varying s from 1 by 1
    until s > s-max
        display string-entry(s)
    end-perform

    move 1 to c1
    perform until c1 >= c
        compute c-display = c1 - 1
        display c-display space with no advancing
        evaluate kode(c1:1)
        when opFETCH
            add 1 to c1
            move kode(c1:4) to word-x
            compute address-display = word - 1
            display 'fetch [' trim(address-display) ']'
            add 3 to c1
        when opSTORE
            add 1 to c1
            move kode(c1:4) to word-x
            compute address-display = word - 1
            display 'store [' trim(address-display) ']'
            add 3 to c1
        when opPUSH
            add 1 to c1
            move kode(c1:4) to word-x
            move word to data-display
            display 'push  ' trim(data-display)
            add 3 to c1
        when opADD   display 'add'
        when opSUB   display 'sub'
        when opMUL   display 'mul'
        when opDIV   display 'div'
        when opMOD   display 'mod'
        when opLT    display 'lt'
        when opGT    display 'gt'
        when opLE    display 'le'
        when opGE    display 'ge'
        when opEQ    display 'eq'
        when opNE    display 'ne'
        when opAND   display 'and'
        when opOR    display 'or'
        when opNEG   display 'neg'
        when opNOT   display 'not'
        when opJMP
            move kode(c1 + 1:length(word)) to word-x
            move word to address-display
            compute address-absolute = c1 + word
            display 'jmp    (' trim(address-display) ') ' trim(address-absolute)
            add length(word) to c1
        when opJZ
            move kode(c1 + 1:length(word)) to word-x
            move word to address-display
            compute address-absolute = c1 + word
            display 'jz     (' trim(address-display) ') ' trim(address-absolute)
            add length(word) to c1
        when opPRTC  display 'prtc'
        when opPRTI  display 'prti'
        when opPRTS  display 'prts'
        when opHALT  display 'halt'
        when other
            string 'in generator unknown opcode ' kode(c1:1) into error-record
            call 'reporterror'
        end-evaluate
        add 1 to c1
    end-perform
    .
end program listcode.

identification division.
program-id. loadast common recursive.
procedure division.
start-loadast.
    if l >= l-lim
        string 'in generator loadast l exceeds ' l-lim into error-record
        call 'reporterror'
    end-if
    add 1 to l
    call 'readinput'
    evaluate true
    when ast-record = ';'
    when input-status = '10'
        move 0 to return-code
    when ast-type = 'Identifier'
    when ast-type = 'Integer'
    when ast-type = 'String'
        call 'makeleaf' using ast-type ast-value
        move t to return-code
    when ast-type = 'Sequence'
        move ast-type to l-node(l)
        call 'loadast'
        move return-code to l-left(l)
        call 'loadast'
        move t to l-right(l)
        call 'makenode' using l-node(l) l-left(l) l-right(l)
        move t to return-code
    when other
        move ast-type to l-node(l)
        call 'loadast'
        move return-code to l-left(l)
        call 'loadast'
        move return-code to l-right(l)
        call 'makenode' using l-node(l) l-left(l) l-right(l)
        move t to return-code
    end-evaluate
    subtract 1 from l
    .
end program loadast.

identification division.
program-id. printast common recursive.
data division.
linkage section.
01  n pic 999.
procedure division using n.
start-printast.
    if n = 0
        display ';' upon syserr
        exit program
    end-if
    display leaf-type(n) upon syserr
    evaluate leaf-type(n)
    when 'Identifier'
    when 'Integer'
    when 'String'
        display leaf-type(n) space trim(leaf-value(n)) upon syserr
    when other
        display node-type(n) upon syserr
        call 'printast' using node-left(n)
        call 'printast' using node-right(n)
    end-evaluate
    .
end program printast.

identification division.
program-id. makenode common.
data division.
linkage section.
01  parm-type any length.
01  parm-l-left pic 999.
01  parm-l-right pic 999.
procedure division using parm-type parm-l-left parm-l-right.
start-makenode.
    if t >= t-lim
        string 'in generator makenode t exceeds ' t-lim into error-record
        call 'reporterror'
    end-if
    add 1 to t
    move parm-type to node-type(t)
    move parm-l-left to node-left(t)
    move parm-l-right to node-right(t)
    .
end program makenode.

identification division.
program-id. makeleaf common.
data division.
linkage section.
01  parm-type any length.
01  parm-value pic x(48).
procedure division using parm-type parm-value.
start-makeleaf.
    add 1 to t
    if t >= t-lim
        string 'in generator makeleaf t exceeds ' t-lim into error-record
        call 'reporterror'
    end-if
    move parm-type to leaf-type(t)
    move parm-value to leaf-value(t)
    .
end program makeleaf.

identification division.
program-id. readinput common.
environment division.
input-output section.
file-control.
    select input-file assign using input-name
        status is input-status
        organization is line sequential.
data division.
file section.
fd  input-file.
01  input-record pic x(64).
procedure division.
start-readinput.
    if program-name = spaces
        move '00' to input-status
        accept ast-record on exception move '10' to input-status end-accept
        exit program
    end-if
    if input-name = spaces
        string program-name delimited by space '.ast' into input-name
        open input input-file
        if input-status = '35'
            string 'in generator ' trim(input-name) ' not found' into error-record
            call 'reporterror'
        end-if
    end-if
    read input-file into ast-record
    evaluate input-status
    when '00'
        continue
    when '10'
        close input-file
    when other
        string 'in generator ' trim(input-name) ' unexpected input-status: ' input-status
            into error-record
        call 'reporterror'
    end-evaluate
    .
end program readinput.

program-id. reporterror common.
procedure division.
start-reporterror.
report-error.
    display error-record upon syserr
    stop run with error status -1
    .
end program reporterror.

identification division.
program-id. showhex common.

data division.
working-storage section.
01  hex.
    03  filler pic x(32) value '000102030405060708090A0B0C0D0E0F'.
    03  filler pic x(32) value '101112131415161718191A1B1C1D1E1F'.
    03  filler pic x(32) value '202122232425262728292A2B2C2D2E2F'.
    03  filler pic x(32) value '303132333435363738393A3B3C3D3E3F'.
    03  filler pic x(32) value '404142434445464748494A4B4C4D4E4F'.
    03  filler pic x(32) value '505152535455565758595A5B5C5D5E5F'.
    03  filler pic x(32) value '606162636465666768696A6B6C6D6E6F'.
    03  filler pic x(32) value '707172737475767778797A7B7C7D7E7F'.
    03  filler pic x(32) value '808182838485868788898A8B8C8D8E8F'.
    03  filler pic x(32) value '909192939495969798999A9B9C9D9E9F'.
    03  filler pic x(32) value 'A0A1A2A3A4A5A6A7A8A9AAABACADAEAF'.
    03  filler pic x(32) value 'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF'.
    03  filler pic x(32) value 'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF'.
    03  filler pic x(32) value 'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF'.
    03  filler pic x(32) value 'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF'.
    03  filler pic x(32) value 'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF'.

01  cdx pic 9999.
01  bdx pic 999.
01  byte-count pic 9.
01  bytes-per-word pic 9 value 4.
01  word-count pic 9.
01  words-per-line pic 9 value 8.

linkage section.
01  data-field any length.
01  length-data-field pic 999.

procedure division using
    by reference data-field
    by reference length-data-field.
start-showhex.
    move 1 to byte-count
    move 1 to word-count
    perform varying cdx from 1 by 1
    until cdx > length-data-field
         compute bdx = 2 * ord(data-field(cdx:1)) - 1 end-compute
         display hex(bdx:2) with no advancing upon syserr
         add 1 to byte-count end-add
         if byte-count > bytes-per-word
             display ' ' with no advancing upon syserr
             move 1 to byte-count
             add 1 to word-count end-add
         end-if
         if word-count > words-per-line
             display ' ' upon syserr
             move 1 to word-count
         end-if
    end-perform
    if word-count <> 1
    or byte-count <> 1
        display ' ' upon syserr
    end-if
    display ' ' upon syserr
    goback
    .
end program showhex.
end program generator.