423 lines
13 KiB
COBOL
423 lines
13 KiB
COBOL
>>SOURCE FORMAT IS FREE
|
|
identification division.
|
|
*> this code is dedicated to the public domain
|
|
*> (GnuCOBOL) 2.3-dev.0
|
|
program-id. vminterpreter.
|
|
environment division.
|
|
configuration section.
|
|
repository. function all intrinsic.
|
|
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).
|
|
|
|
working-storage section.
|
|
01 program-name pic x(32).
|
|
01 input-name pic x(32).
|
|
01 input-status pic xx.
|
|
|
|
01 error-record pic x(64) value spaces global.
|
|
|
|
01 v-max pic 99.
|
|
01 parameters.
|
|
03 offset pic 999.
|
|
03 opcode pic x(8).
|
|
03 parm0 pic x(16).
|
|
03 parm1 pic x(16).
|
|
03 parm2 pic x(16).
|
|
|
|
01 opcodes.
|
|
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 filler.
|
|
03 s pic 99.
|
|
03 s-max pic 99 value 0.
|
|
03 s-lim pic 99 value 16.
|
|
03 filler occurs 16.
|
|
05 string-length pic 99.
|
|
05 string-entry pic x(48).
|
|
|
|
01 filler.
|
|
03 v pic 99.
|
|
03 v-lim pic 99 value 16.
|
|
03 variables occurs 16 usage binary-int.
|
|
|
|
01 generated-code global.
|
|
03 c pic 999 value 1.
|
|
03 pc pic 999.
|
|
03 c-lim pic 999 value 512.
|
|
03 kode pic x(512).
|
|
|
|
01 filler.
|
|
03 stack1 pic 999 value 2.
|
|
03 stack2 pic 999 value 1.
|
|
03 stack-lim pic 999 value 998.
|
|
03 stack occurs 998 usage binary-int.
|
|
|
|
01 display-definitions global.
|
|
03 ascii-character.
|
|
05 numeric-value usage binary-char.
|
|
03 display-integer pic -(9)9.
|
|
03 word-x.
|
|
05 word usage binary-int.
|
|
03 word-length pic 9.
|
|
03 string1 pic 99.
|
|
03 length1 pic 99.
|
|
03 count1 pic 99.
|
|
03 display-pending pic x.
|
|
|
|
procedure division.
|
|
start-vminterpreter.
|
|
display 1 upon command-line *> get arg(1)
|
|
accept program-name from argument-value
|
|
move length(word) to word-length
|
|
perform load-code
|
|
perform run-code
|
|
stop run
|
|
.
|
|
run-code.
|
|
move 1 to pc
|
|
perform until pc >= c
|
|
evaluate kode(pc:1)
|
|
when opFETCH
|
|
perform push-stack
|
|
move kode(pc + 1:word-length) to word-x
|
|
add 1 to word *> convert offset to subscript
|
|
move variables(word) to stack(stack1)
|
|
add word-length to pc
|
|
when opPUSH
|
|
perform push-stack
|
|
move kode(pc + 1:word-length) to word-x
|
|
move word to stack(stack1)
|
|
add word-length to pc
|
|
when opNEG
|
|
compute stack(stack1) = -stack(stack1)
|
|
when opNOT
|
|
if stack(stack1) = 0
|
|
move 1 to stack(stack1)
|
|
else
|
|
move 0 to stack(stack1)
|
|
end-if
|
|
when opJMP
|
|
move kode(pc + 1:word-length) to word-x
|
|
move word to pc
|
|
when opHALT
|
|
if display-pending = 'Y'
|
|
display space
|
|
end-if
|
|
exit perform
|
|
when opJZ
|
|
if stack(stack1) = 0
|
|
move kode(pc + 1:word-length) to word-x
|
|
move word to pc
|
|
else
|
|
add word-length to pc
|
|
end-if
|
|
perform pop-stack
|
|
when opSTORE
|
|
move kode(pc + 1:word-length) to word-x
|
|
add 1 to word *> convert offset to subscript
|
|
move stack(stack1) to variables(word)
|
|
add word-length to pc
|
|
perform pop-stack
|
|
when opADD
|
|
add stack(stack1) to stack(stack2)
|
|
perform pop-stack
|
|
when opSUB
|
|
subtract stack(stack1) from stack(stack2)
|
|
perform pop-stack
|
|
when opMUL
|
|
multiply stack(stack1) by stack(stack2)
|
|
*>rounded mode nearest-toward-zero *> doesn't match python
|
|
perform pop-stack
|
|
when opDIV
|
|
divide stack(stack1) into stack(stack2)
|
|
*>rounded mode nearest-toward-zero *> doesn't match python
|
|
perform pop-stack
|
|
when opMOD
|
|
move mod(stack(stack2),stack(stack1)) to stack(stack2)
|
|
perform pop-stack
|
|
when opLT
|
|
if stack(stack2) < stack(stack1)
|
|
move 1 to stack(stack2)
|
|
else
|
|
move 0 to stack(stack2)
|
|
end-if
|
|
perform pop-stack
|
|
when opGT
|
|
if stack(stack2) > stack(stack1)
|
|
move 1 to stack(stack2)
|
|
else
|
|
move 0 to stack(stack2)
|
|
end-if
|
|
perform pop-stack
|
|
when opLE
|
|
if stack(stack2) <= stack(stack1)
|
|
move 1 to stack(stack2)
|
|
else
|
|
move 0 to stack(stack2)
|
|
end-if
|
|
perform pop-stack
|
|
when opGE
|
|
if stack(stack2) >= stack(stack1)
|
|
move 1 to stack(stack2)
|
|
else
|
|
move 0 to stack(stack2)
|
|
end-if
|
|
perform pop-stack
|
|
when opEQ
|
|
if stack(stack2) = stack(stack1)
|
|
move 1 to stack(stack2)
|
|
else
|
|
move 0 to stack(stack2)
|
|
end-if
|
|
perform pop-stack
|
|
when opNE
|
|
if stack(stack2) <> stack(stack1)
|
|
move 1 to stack(stack2)
|
|
else
|
|
move 0 to stack(stack2)
|
|
end-if
|
|
perform pop-stack
|
|
when opAND
|
|
call "CBL_AND" using stack(stack1) stack(stack2) by value word-length
|
|
perform pop-stack
|
|
when opOR
|
|
call "CBL_OR" using stack(stack1) stack(stack2) by value word-length
|
|
perform pop-stack
|
|
when opPRTC
|
|
move stack(stack1) to numeric-value
|
|
if numeric-value = 10
|
|
display space
|
|
move 'N' to display-pending
|
|
else
|
|
display ascii-character with no advancing
|
|
move 'Y' to display-pending
|
|
end-if
|
|
perform pop-stack
|
|
when opPRTS
|
|
add 1 to word *> convert offset to subscript
|
|
move 1 to string1
|
|
move string-length(word) to length1
|
|
perform until string1 > string-length(word)
|
|
move 0 to count1
|
|
inspect string-entry(word)(string1:length1)
|
|
tallying count1 for characters before initial '\' *> ' workaround code highlighter problem
|
|
evaluate true
|
|
when string-entry(word)(string1 + count1 + 1:1) = 'n' *> \n
|
|
display string-entry(word)(string1:count1)
|
|
move 'N' to display-pending
|
|
compute string1 = string1 + 2 + count1
|
|
compute length1 = length1 - 2 - count1
|
|
when string-entry(word)(string1 + count1 + 1:1) = '\' *> ' \\
|
|
display string-entry(word)(string1:count1 + 1) with no advancing
|
|
move 'Y' to display-pending
|
|
compute string1 = string1 + 2 + count1
|
|
compute length1 = length1 - 2 - count1
|
|
when other
|
|
display string-entry(word)(string1:count1) with no advancing
|
|
move 'Y' to display-pending
|
|
add count1 to string1
|
|
subtract count1 from length1
|
|
end-evaluate
|
|
end-perform
|
|
perform pop-stack
|
|
when opPRTI
|
|
move stack(stack1) to display-integer
|
|
display trim(display-integer) with no advancing
|
|
move 'Y' to display-pending
|
|
perform pop-stack
|
|
end-evaluate
|
|
add 1 to pc
|
|
end-perform
|
|
.
|
|
push-stack.
|
|
if stack1 >= stack-lim
|
|
string 'in vminterpreter at ' pc ' stack overflow at ' stack-lim into error-record
|
|
perform report-error
|
|
end-if
|
|
add 1 to stack1 stack2
|
|
>>d display ' push at ' pc space stack1 space stack2
|
|
.
|
|
pop-stack.
|
|
if stack1 < 2
|
|
string 'in vminterpreter at ' pc ' stack underflow' into error-record
|
|
perform report-error
|
|
end-if
|
|
>>d display ' pop at ' pc space stack1 space stack2
|
|
subtract 1 from stack1 stack2
|
|
.
|
|
load-code.
|
|
perform read-input
|
|
if input-status <> '00'
|
|
string 'in vminterpreter no input data' into error-record
|
|
perform report-error
|
|
end-if
|
|
|
|
unstring input-record delimited by all spaces into parm1 v-max parm2 s-max
|
|
if v-max > v-lim
|
|
string 'in vminterpreter datasize exceeds ' v-lim into error-record
|
|
perform report-error
|
|
end-if
|
|
if s-max > s-lim
|
|
string 'in vminterpreter number of strings exceeds ' s-lim into error-record
|
|
perform report-error
|
|
end-if
|
|
|
|
perform read-input
|
|
perform varying s from 1 by 1 until s > s-max
|
|
or input-status <> '00'
|
|
compute string-length(s) string-length(word) = length(trim(input-record)) - 2
|
|
move input-record(2:string-length(word)) to string-entry(s)
|
|
perform read-input
|
|
end-perform
|
|
if s <= s-max
|
|
string 'in vminterpreter not all strings found' into error-record
|
|
perform report-error
|
|
end-if
|
|
|
|
perform until input-status <> '00'
|
|
initialize parameters
|
|
unstring input-record delimited by all spaces into
|
|
parm0 offset opcode parm1 parm2
|
|
evaluate opcode
|
|
when 'fetch'
|
|
call 'emitbyte' using opFETCH
|
|
call 'emitword' using parm1
|
|
when 'store'
|
|
call 'emitbyte' using opSTORE
|
|
call 'emitword' using parm1
|
|
when 'push'
|
|
call 'emitbyte' using opPUSH
|
|
call 'emitword' using parm1
|
|
when 'add' call 'emitbyte' using opADD
|
|
when 'sub' call 'emitbyte' using opSUB
|
|
when 'mul' call 'emitbyte' using opMUL
|
|
when 'div' call 'emitbyte' using opDIV
|
|
when 'mod' call 'emitbyte' using opMOD
|
|
when 'lt' call 'emitbyte' using opLT
|
|
when 'gt' call 'emitbyte' using opGT
|
|
when 'le' call 'emitbyte' using opLE
|
|
when 'ge' call 'emitbyte' using opGE
|
|
when 'eq' call 'emitbyte' using opEQ
|
|
when 'ne' call 'emitbyte' using opNE
|
|
when 'and' call 'emitbyte' using opAND
|
|
when 'or' call 'emitbyte' using opOR
|
|
when 'not' call 'emitbyte' using opNOT
|
|
when 'neg' call 'emitbyte' using opNEG
|
|
when 'jmp'
|
|
call 'emitbyte' using opJMP
|
|
call 'emitword' using parm2
|
|
when 'jz'
|
|
call 'emitbyte' using opJZ
|
|
call 'emitword' using parm2
|
|
when 'prtc' call 'emitbyte' using opPRTC
|
|
when 'prts' call 'emitbyte' using opPRTS
|
|
when 'prti' call 'emitbyte' using opPRTI
|
|
when 'halt' call 'emitbyte' using opHALT
|
|
when other
|
|
string 'in vminterpreter unknown opcode ' trim(opcode) ' at ' offset into error-record
|
|
perform report-error
|
|
end-evaluate
|
|
perform read-input
|
|
end-perform
|
|
.
|
|
read-input.
|
|
if program-name = spaces
|
|
move '00' to input-status
|
|
accept input-record on exception move '10' to input-status end-accept
|
|
exit paragraph
|
|
end-if
|
|
if input-name = spaces
|
|
string program-name delimited by space '.gen' into input-name
|
|
open input input-file
|
|
if input-status <> '00'
|
|
string 'in vminterpreter ' trim(input-name) ' file open status ' input-status
|
|
into error-record
|
|
perform report-error
|
|
end-if
|
|
end-if
|
|
read input-file into input-record
|
|
evaluate input-status
|
|
when '00'
|
|
continue
|
|
when '10'
|
|
close input-file
|
|
when other
|
|
string 'in vminterpreter unexpected input-status: ' input-status into error-record
|
|
perform report-error
|
|
end-evaluate
|
|
.
|
|
report-error.
|
|
display error-record upon syserr
|
|
stop run with error status -1
|
|
.
|
|
identification division.
|
|
program-id. emitbyte.
|
|
data division.
|
|
linkage section.
|
|
01 opcode pic x.
|
|
procedure division using opcode.
|
|
start-emitbyte.
|
|
if c >= c-lim
|
|
string 'in vminterpreter 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.
|
|
data division.
|
|
working-storage section.
|
|
01 word-temp pic x(8).
|
|
linkage section.
|
|
01 word-value any length.
|
|
procedure division using word-value.
|
|
start-emitword.
|
|
if c + word-length >= c-lim
|
|
string 'in vminterpreter emitword c exceeds ' c-lim into error-record
|
|
call 'reporterror'
|
|
end-if
|
|
move word-value to word-temp
|
|
inspect word-temp converting '[' to ' '
|
|
inspect word-temp converting ']' to ' '
|
|
move numval(trim(word-temp)) to word
|
|
move word-x to kode(c:word-length)
|
|
add word-length to c
|
|
.
|
|
end program emitword.
|
|
|
|
end program vminterpreter.
|