Data update
This commit is contained in:
Ingy döt Net
parent
4bb20c9b71
commit
cbaf4c4b64
12390 changed files with 318560 additions and 27248 deletions
652
Task/Compiler-code-generator/COBOL/compiler-code-generator.cob
Normal file
652
Task/Compiler-code-generator/COBOL/compiler-code-generator.cob
Normal file
|
|
@ -0,0 +1,652 @@
|
|||
>>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.
|
||||
|
|
@ -0,0 +1,287 @@
|
|||
Const NULL As Any Ptr = 0
|
||||
Const WORD_SIZE = 4
|
||||
|
||||
Enum NodeTypes
|
||||
nd_Ident, nd_String, nd_Integer, nd_Sequence, nd_If, nd_Prtc, nd_Prts, nd_Prti, nd_While
|
||||
nd_Assign, nd_Negate, nd_Not, nd_Mul, nd_Div, nd_Mod, nd_Add, nd_Sub, nd_Lss, nd_Leq
|
||||
nd_Gtr, nd_Geq, nd_Eql, nd_Neq, nd_And, nd_Or
|
||||
End Enum
|
||||
|
||||
Enum ByteCode
|
||||
bcFetch, bcStore, bcPush, bcAdd, bcSub, bcMul, bcDiv, bcMod, bcLt, bcGt, bcLe, bcGe
|
||||
bcEq, bcNe, bcAnd, bcOr, bcNeg, bcNot, bcJmp, bcJz, bcPrtc, bcPrts, bcPrti, bcHalt
|
||||
End Enum
|
||||
|
||||
Type Node
|
||||
nodTyp As NodeTypes
|
||||
izda As Node Ptr
|
||||
dcha As Node Ptr
|
||||
sValue As String
|
||||
iValue As Long
|
||||
End Type
|
||||
|
||||
Type SymbolEntry
|
||||
nombre As String
|
||||
offset As Integer
|
||||
End Type
|
||||
|
||||
Dim Shared As Ubyte code(0 To 9999)
|
||||
Dim Shared As Integer codeSize = 0
|
||||
Dim Shared As SymbolEntry stringPool(0 To 99)
|
||||
Dim Shared As SymbolEntry globals(0 To 99)
|
||||
Dim Shared As Integer numStrings = 0
|
||||
Dim Shared As Integer numGlobals = 0
|
||||
|
||||
Sub EmitByte(b As Ubyte)
|
||||
code(codeSize) = b
|
||||
codeSize += 1
|
||||
End Sub
|
||||
|
||||
Sub EmitWord(w As Long)
|
||||
Dim As Long value = w
|
||||
For i As Integer = 0 To 3
|
||||
code(codeSize + i) = 0
|
||||
Next
|
||||
*Cast(Long Ptr, @code(codeSize)) = value
|
||||
codeSize += 4
|
||||
End Sub
|
||||
|
||||
Sub EmitWordAt(at As Integer, n As Long)
|
||||
For i As Integer = 0 To 3
|
||||
code(at + i) = 0
|
||||
Next
|
||||
*Cast(Long Ptr, @code(at)) = n
|
||||
End Sub
|
||||
|
||||
Function Hole() As Integer
|
||||
Dim As Integer t = codeSize
|
||||
EmitWord(0)
|
||||
Return t
|
||||
End Function
|
||||
|
||||
Function FetchVarOffset(nombre As String) As Integer
|
||||
nombre = Trim(nombre)
|
||||
|
||||
For i As Integer = numGlobals - 1 To 0 Step -1
|
||||
If globals(i).nombre = nombre Then Return i
|
||||
Next
|
||||
|
||||
globals(numGlobals).nombre = nombre
|
||||
globals(numGlobals).offset = numGlobals
|
||||
numGlobals += 1
|
||||
Return numGlobals - 1
|
||||
End Function
|
||||
|
||||
Function FetchStringOffset(s As String) As Integer
|
||||
s = Trim(s)
|
||||
If Left(s, 1) = """" Then s = Mid(s, 2, Len(s) - 2)
|
||||
|
||||
For i As Integer = numStrings - 1 To 0 Step -1
|
||||
If stringPool(i).nombre = s Then Return i
|
||||
Next
|
||||
|
||||
stringPool(numStrings).nombre = s
|
||||
numStrings += 1
|
||||
Return numStrings - 1
|
||||
End Function
|
||||
|
||||
Function GetNodeType(text As String) As NodeTypes
|
||||
text = Trim(text)
|
||||
Select Case text
|
||||
Case "Identifier": Return nd_Ident
|
||||
Case "String" : Return nd_String
|
||||
Case "Integer" : Return nd_Integer
|
||||
Case "Sequence" : Return nd_Sequence
|
||||
Case "If" : Return nd_If
|
||||
Case "While" : Return nd_While
|
||||
Case "Assign" : Return nd_Assign
|
||||
Case "Add" : Return nd_Add
|
||||
Case "Less" : Return nd_Lss
|
||||
Case "Prts" : Return nd_Prts
|
||||
Case "Prti" : Return nd_Prti
|
||||
Case Else
|
||||
Print "Error: Unknown symbol "; text
|
||||
End 1
|
||||
End Select
|
||||
Return 0
|
||||
End Function
|
||||
|
||||
Sub CodeGen(n As Node Ptr)
|
||||
If n = NULL Then Return
|
||||
|
||||
Select Case n->nodTyp
|
||||
Case nd_Integer
|
||||
EmitByte(bcPush)
|
||||
EmitWord(n->iValue)
|
||||
|
||||
Case nd_String
|
||||
EmitByte(bcPush)
|
||||
EmitWord(FetchStringOffset(n->sValue))
|
||||
|
||||
Case nd_Ident
|
||||
EmitByte(bcFetch)
|
||||
EmitWord(FetchVarOffset(n->sValue))
|
||||
|
||||
Case nd_Assign
|
||||
Dim As Integer offset = FetchVarOffset(n->izda->sValue)
|
||||
CodeGen(n->dcha)
|
||||
EmitByte(bcStore)
|
||||
EmitWord(offset)
|
||||
|
||||
Case nd_If
|
||||
CodeGen(n->izda)
|
||||
EmitByte(bcJz)
|
||||
Dim As Integer p1 = Hole()
|
||||
CodeGen(n->dcha->izda)
|
||||
If n->dcha->dcha <> NULL Then
|
||||
EmitByte(bcJmp)
|
||||
Dim As Integer p2 = Hole()
|
||||
EmitWordAt(p1, codeSize - p1)
|
||||
CodeGen(n->dcha->dcha)
|
||||
EmitWordAt(p2, codeSize - p2)
|
||||
Else
|
||||
EmitWordAt(p1, codeSize - p1)
|
||||
End If
|
||||
|
||||
Case nd_While
|
||||
Dim startPos As Integer = codeSize
|
||||
|
||||
CodeGen(n->izda)
|
||||
|
||||
EmitByte(bcJz)
|
||||
Dim jzPos As Integer = codeSize
|
||||
EmitWord(0)
|
||||
|
||||
CodeGen(n->dcha)
|
||||
|
||||
EmitByte(bcJmp)
|
||||
Dim jmpOpPos As Integer = codeSize
|
||||
EmitWord(startPos - jmpOpPos)
|
||||
|
||||
EmitWordAt(jzPos, codeSize - jzPos)
|
||||
|
||||
Case nd_Sequence
|
||||
If n->izda <> NULL Then CodeGen(n->izda)
|
||||
If n->dcha <> NULL Then CodeGen(n->dcha)
|
||||
|
||||
Case nd_Prtc, nd_Prti, nd_Prts
|
||||
CodeGen(n->izda)
|
||||
Select Case n->nodTyp
|
||||
Case nd_Prtc: EmitByte(bcPrtc)
|
||||
Case nd_Prti: EmitByte(bcPrti)
|
||||
Case nd_Prts: EmitByte(bcPrts)
|
||||
End Select
|
||||
|
||||
Case nd_Add
|
||||
CodeGen(n->izda)
|
||||
CodeGen(n->dcha)
|
||||
EmitByte(bcAdd)
|
||||
|
||||
Case nd_Lss
|
||||
CodeGen(n->izda)
|
||||
CodeGen(n->dcha)
|
||||
EmitByte(bcLt)
|
||||
End Select
|
||||
End Sub
|
||||
|
||||
Function LoadAst() As Node Ptr
|
||||
Static As String linea
|
||||
Line Input #1, linea
|
||||
linea = Trim(linea)
|
||||
If linea = "" Orelse linea = ";" Then Return NULL
|
||||
|
||||
Dim As Integer posic = Instr(linea, " ")
|
||||
Dim As String head, tail
|
||||
If posic = 0 Then
|
||||
head = linea
|
||||
tail = ""
|
||||
Else
|
||||
head = Left(linea, posic - 1)
|
||||
tail = Trim(Mid(linea, posic + 1))
|
||||
End If
|
||||
|
||||
Dim As Node Ptr n = New Node
|
||||
n->nodTyp = GetNodeType(head)
|
||||
|
||||
Select Case n->nodTyp
|
||||
Case nd_Integer
|
||||
n->iValue = Vallng(tail)
|
||||
Return n
|
||||
Case nd_String, nd_Ident
|
||||
n->sValue = tail
|
||||
Return n
|
||||
End Select
|
||||
|
||||
n->izda = LoadAst()
|
||||
n->dcha = LoadAst()
|
||||
Return n
|
||||
End Function
|
||||
|
||||
Sub ListCode()
|
||||
Print "Datasize:"; numGlobals; " Strings:"; numStrings
|
||||
For i As Integer = 0 To numStrings - 1
|
||||
Print """"; stringPool(i).nombre; """"
|
||||
Next
|
||||
|
||||
Dim As Integer pc = 0
|
||||
While pc < codeSize
|
||||
Print Using "#####"; pc;
|
||||
|
||||
Dim As Integer op = code(pc)
|
||||
pc += 1
|
||||
|
||||
Dim As Long v = *Cast(Long Ptr, @code(pc))
|
||||
Select Case op
|
||||
Case bcFetch
|
||||
Print " fetch [" & v & "]"
|
||||
pc += 4
|
||||
Case bcStore
|
||||
Print " store [" & v & "]"
|
||||
pc += 4
|
||||
Case bcPush
|
||||
Print " push "; v
|
||||
pc += 4
|
||||
Case bcAdd: Print " add"
|
||||
Case bcSub: Print " sub"
|
||||
Case bcMul: Print " mul"
|
||||
Case bcDiv: Print " div"
|
||||
Case bcMod: Print " mod"
|
||||
Case bcLt : Print " lt"
|
||||
Case bcGt : Print " gt"
|
||||
Case bcLe : Print " le"
|
||||
Case bcGe : Print " ge"
|
||||
Case bcEq : Print " eq"
|
||||
Case bcNe : Print " ne"
|
||||
Case bcAnd: Print " and"
|
||||
Case bcOr : Print " or"
|
||||
Case bcNeg: Print " neg"
|
||||
Case bcNot: Print " not"
|
||||
Case bcJmp
|
||||
Print " jmp (" & v; ") " & pc + v
|
||||
pc += 4
|
||||
Case bcJz
|
||||
Print " jz (" & v; ") " & pc + v
|
||||
pc += 4
|
||||
Case bcPrtc: Print " prtc"
|
||||
Case bcPrti: Print " prti"
|
||||
Case bcPrts: Print " prts"
|
||||
Case bcHalt: Print " halt"
|
||||
End Select
|
||||
Wend
|
||||
End Sub
|
||||
|
||||
' Main program
|
||||
If Command(1) <> "" Then
|
||||
Open Command(1) For Input As #1
|
||||
Else
|
||||
Print "Usage: compiler input.ast"
|
||||
Sleep: End 1
|
||||
End If
|
||||
|
||||
Dim As Node Ptr ast = LoadAst()
|
||||
CodeGen(ast)
|
||||
EmitByte(bcHalt)
|
||||
ListCode()
|
||||
Close #1
|
||||
|
||||
Sleep
|
||||
172
Task/Compiler-code-generator/Red/compiler-code-generator-1.red
Normal file
172
Task/Compiler-code-generator/Red/compiler-code-generator-1.red
Normal file
|
|
@ -0,0 +1,172 @@
|
|||
Red [
|
||||
Title: "Compiler/code generator"
|
||||
Author: "hinjolicious"
|
||||
]
|
||||
|
||||
#include %lex2.red
|
||||
#include %parse.red
|
||||
|
||||
ast: copy []
|
||||
|
||||
ops: #[MUL: MUL DIV: DIV MOD: MOD ADD: ADD SUB: SUB NEG: NEG NOT: NOT
|
||||
LT: LT GT: GT LEQ: LE GEQ: GE EQ: EQ NEQ: NE AND: AND OR: OR]
|
||||
unary: [NEG: NEG NOT: NOT]
|
||||
|
||||
code: copy []
|
||||
str-pool: #[]
|
||||
var-pool: #[]
|
||||
str-n: var-n: 0
|
||||
wsize: 4
|
||||
|
||||
error: func [msg][ print ["ERROR:" msg halt] ]
|
||||
slice: func [blk st n][ copy/part at blk st n ]
|
||||
i2b: func [v][ to-binary v ]
|
||||
b2i: func [v][ to-integer v ]
|
||||
|
||||
i2blk: func [i /local b blk x][
|
||||
b: to-binary i
|
||||
blk: copy []
|
||||
foreach x b [append blk x]
|
||||
blk ]
|
||||
|
||||
blk2i: func [blk /local b x][
|
||||
b: make binary! wsize
|
||||
foreach x blk [append b x]
|
||||
to-integer b ]
|
||||
|
||||
emit-byte: func [x][ append code x ]
|
||||
emit-word: func [x][ append code i2blk x ]
|
||||
emit-word-at: func [a n][ change/part (at code a) (i2blk n) wsize ]
|
||||
|
||||
hole: func [/local t][
|
||||
t: length? code
|
||||
emit-word 0
|
||||
t ]
|
||||
|
||||
var-offset: func [name /local n][
|
||||
n: var-pool/:name
|
||||
if n == none [
|
||||
var-pool/:name: var-n
|
||||
n: var-n
|
||||
var-n: var-n + 1 ]
|
||||
n ]
|
||||
|
||||
str-offset: func [str /local n][
|
||||
n: str-pool/:str
|
||||
if n = none [
|
||||
str-pool/:str: str-n
|
||||
n: str-n
|
||||
str-n: str-n + 1 ]
|
||||
n ]
|
||||
|
||||
_gen: func [a /local n p1 p2 ][
|
||||
case [
|
||||
none = a [exit]
|
||||
'ID = a/1 [ emit-byte 'FETCH emit-word var-offset a/2 ]
|
||||
'INT = a/1 [ emit-byte 'PUSH emit-word a/2 ]
|
||||
'STR = a/1 [ emit-byte 'PUSH emit-word str-offset a/2 ]
|
||||
'ASGN = a/1 [ n: var-offset a/2/2 _gen a/3 emit-byte 'STORE emit-word n ]
|
||||
'IF = a/1 [
|
||||
_gen a/2 ; if cond
|
||||
emit-byte 'JZ ; if false, jump to to else
|
||||
p1: hole ; reserve for else address
|
||||
_gen a/3/2 ; then body
|
||||
if a/3/3 <> none [
|
||||
emit-byte 'JMP ; skip the else body
|
||||
p2: hole ] ; reserve the location
|
||||
emit-word-at (p1 + 1) ((length? code) - p1) ; fix for jz
|
||||
if a/3/3 <> none [
|
||||
_gen a/3/3 ; else body
|
||||
emit-word-at (p2 + 1) ((length? code) - p2) ] ] ; fix for jmp
|
||||
'WHILE = a/1 [
|
||||
p1: length? code ; before while
|
||||
_gen a/2 ; while cond
|
||||
emit-byte 'JZ ; if false, jump to after while
|
||||
p2: hole ; reserve after while address
|
||||
_gen a/3 ; while body
|
||||
emit-byte 'JMP ; jump-back to before while
|
||||
emit-word (p1 - (length? code))
|
||||
emit-word-at (p2 + 1) ((length? code) - p2) ] ; fix jz to this location
|
||||
'SEQ = a/1 [ _gen a/2 _gen a/3 ]
|
||||
'PRTC = a/1 [ _gen a/2 emit-byte 'PRTC ]
|
||||
'PRTI = a/1 [ _gen a/2 emit-byte 'PRTI ]
|
||||
'PRTS = a/1 [ _gen a/2 emit-byte 'PRTS ]
|
||||
ops/(:a/1) [ _gen a/2 _gen a/3 emit-byte ops/(:a/1) ]
|
||||
unary/(:a/1) [ _gen a/2 emit-byte unary/(:a/1) ]
|
||||
true [ error rejoin ["Expecting operator, found '" a/1 "'"] ]
|
||||
]
|
||||
] ; _gen
|
||||
|
||||
gen: func [ast][
|
||||
clear code clear str-pool clear var-pool str-n: var-n: 0
|
||||
_gen ast emit-byte 'HALT
|
||||
code ]
|
||||
|
||||
list-code: func[/local out s op c][
|
||||
out: copy ""
|
||||
|
||||
pad-pc: func [x][pad/left x 5]
|
||||
pad-op: func [x][pad x 6]
|
||||
|
||||
append out rejoin ["Datasize: " length? var-pool " Strings: " length? str-pool "^/"]
|
||||
foreach [a b] sort/skip (to-block str-pool) 2 [
|
||||
append out rejoin [mold a "^/"] ]
|
||||
|
||||
pc: 0
|
||||
while [pc < length? code][
|
||||
s: pad-pc pc
|
||||
op: code/(:pc + 1) ; 1-based block
|
||||
pc: pc + 1
|
||||
switch/default to-lit-word op [
|
||||
'FETCH [ x: blk2i slice code (pc + 1) wsize c: rejoin [pad-op op "[" x "]"] pc: pc + wsize ]
|
||||
'STORE [ x: blk2i slice code (pc + 1) wsize c: rejoin [pad-op op "[" x "]"] pc: pc + wsize ]
|
||||
'PUSH [ x: blk2i slice code (pc + 1) wsize c: rejoin [pad-op op x] pc: pc + wsize ]
|
||||
'ADD [ c: "ADD" ]
|
||||
'SUB [ c: "SUB" ]
|
||||
'MUL [ c: "MUL" ]
|
||||
'DIV [ c: "DIV" ]
|
||||
'MOD [ c: "MOD" ]
|
||||
'LT [ c: "LT" ]
|
||||
'GT [ c: "GT" ]
|
||||
'LE [ c: "LE" ]
|
||||
'GE [ c: "GE" ]
|
||||
'EQ [ c: "EQ" ]
|
||||
'NE [ c: "NE" ]
|
||||
'AND [ c: "AND" ]
|
||||
'OR [ c: "OR" ]
|
||||
'NEG [ c: "NEG" ]
|
||||
'NOT [ c: "NOT" ]
|
||||
'JMP [ x: blk2i slice code (pc + 1) wsize c: rejoin [pad-op op "(" x ") " pc + x] pc: pc + wsize ]
|
||||
'JZ [ x: blk2i slice code (pc + 1) wsize c: rejoin [pad-op op "(" x ") " pc + x] pc: pc + wsize ]
|
||||
'PRTC [ c: "PRTC" ]
|
||||
'PRTI [ c: "PRTI" ]
|
||||
'PRTS [ c: "PRTS" ]
|
||||
'HALT [ c: "HALT" ]
|
||||
][ error rejoin ["list-code: Unknown opcode " op] ]
|
||||
append out rejoin [s " " c "^/"]
|
||||
]
|
||||
out
|
||||
] ; list-code
|
||||
|
||||
test: does [
|
||||
while [(tx: ask "Code: ") <> ""] [
|
||||
case [
|
||||
tx = "r" [tx: read fn: request-file]
|
||||
all [tx = "s" fn <> "" tcode <> ""] [
|
||||
out-fn: replace fn ".t" ".tcode"
|
||||
write out-fn tcode
|
||||
print ["Saved to " out-fn]
|
||||
continue ] ]
|
||||
?? fn
|
||||
?? tx
|
||||
lx: lex tx
|
||||
?? lx
|
||||
ast: parse lx
|
||||
?? ast
|
||||
gen ast
|
||||
?? code
|
||||
tcode: list-code
|
||||
print tcode
|
||||
]
|
||||
]
|
||||
test
|
||||
160
Task/Compiler-code-generator/Red/compiler-code-generator-2.red
Normal file
160
Task/Compiler-code-generator/Red/compiler-code-generator-2.red
Normal file
|
|
@ -0,0 +1,160 @@
|
|||
Red [
|
||||
Title: "Compiler/code generator"
|
||||
Author: "hinjolicious"
|
||||
Purpose: "list-based code generator that is more suitable Red's native block data structure"
|
||||
]
|
||||
|
||||
#include %lex2-bak.red
|
||||
#include %parse.red
|
||||
|
||||
ast: copy []
|
||||
|
||||
ops: #[MUL: MUL DIV: DIV MOD: MOD ADD: ADD SUB: SUB NEG: NEG NOT: NOT
|
||||
LT: LT GT: GT LEQ: LE GEQ: GE EQ: EQ NEQ: NE AND: AND OR: OR]
|
||||
unary: [NEG: NEG NOT: NOT]
|
||||
|
||||
code: copy []
|
||||
str-pool: #[]
|
||||
var-pool: #[]
|
||||
str-n: var-n: 0
|
||||
wsize: 1 ; we're using an integer based code
|
||||
|
||||
error: func [msg][ print ["ERROR:" msg halt] ]
|
||||
|
||||
emit: func [x][ append code x ]
|
||||
emit-at: func [a n][ change at code a n ]
|
||||
hole: func [/local t][ t: length? code emit 0 t ]
|
||||
|
||||
var-offset: func [name /local n][
|
||||
n: var-pool/:name
|
||||
if n == none [
|
||||
var-pool/:name: var-n
|
||||
n: var-n
|
||||
var-n: var-n + 1 ]
|
||||
n ]
|
||||
|
||||
str-offset: func [str /local n][
|
||||
n: str-pool/:str
|
||||
if n = none [
|
||||
str-pool/:str: str-n
|
||||
n: str-n
|
||||
str-n: str-n + 1 ]
|
||||
n ]
|
||||
|
||||
_gen: func [a /local n p1 p2 ][
|
||||
case [
|
||||
none = a [exit]
|
||||
'ID = a/1 [ emit 'FETCH emit a/2 ] ;var-offset a/2 ]
|
||||
'INT = a/1 [ emit 'PUSH emit a/2 ]
|
||||
'STR = a/1 [ emit 'PUSH emit a/2 ] ;str-offset a/2 ]
|
||||
;'ASGN = a/1 [ n: var-offset a/2/2 _gen a/3 emit 'STORE emit n ]
|
||||
'ASGN = a/1 [ n: a/2/2 _gen a/3 emit 'STORE emit n ]
|
||||
'IF = a/1 [
|
||||
_gen a/2 ; if cond
|
||||
emit 'JZ ; if false, jump to to else
|
||||
p1: hole ; reserve for else address
|
||||
_gen a/3/2 ; then body
|
||||
if a/3/3 <> none [
|
||||
emit 'JMP ; skip the else body
|
||||
p2: hole ] ; reserve the location
|
||||
emit-at (p1 + 1) ((length? code) - p1) ; fix for jz
|
||||
if a/3/3 <> none [
|
||||
_gen a/3/3 ; else body
|
||||
emit-at (p2 + 1) ((length? code) - p2) ] ] ; fix for jmp
|
||||
'WHILE = a/1 [
|
||||
p1: length? code ; before while
|
||||
_gen a/2 ; while cond
|
||||
emit 'JZ ; if false, jump to after while
|
||||
p2: hole ; reserve after while address
|
||||
_gen a/3 ; while body
|
||||
emit 'JMP ; jump-back to before while
|
||||
emit (p1 - (length? code))
|
||||
emit-at (p2 + 1) ((length? code) - p2) ] ; fix jz to this location
|
||||
'SEQ = a/1 [ _gen a/2 _gen a/3 ]
|
||||
'PRTC = a/1 [ _gen a/2 emit 'PRTC ]
|
||||
'PRTI = a/1 [ _gen a/2 emit 'PRTI ]
|
||||
'PRTS = a/1 [ _gen a/2 emit 'PRTS ]
|
||||
ops/(:a/1) [ _gen a/2 _gen a/3 emit ops/(:a/1) ]
|
||||
unary/(:a/1) [ _gen a/2 emit unary/(:a/1) ]
|
||||
true [ error rejoin ["Expecting operator, found '" a/1 "'"] ]
|
||||
]
|
||||
] ; _gen
|
||||
|
||||
gen: func [ast][
|
||||
;clear code clear str-pool clear var-pool str-n: var-n: 0
|
||||
code: copy []
|
||||
str-pool: #[]
|
||||
var-pool: #[]
|
||||
str-n: var-n: 0
|
||||
|
||||
_gen ast emit 'HALT
|
||||
code ]
|
||||
|
||||
list-code: func[/local out s op c][
|
||||
out: copy ""
|
||||
|
||||
pad-pc: func [x][pad/left x 5]
|
||||
pad-op: func [x][pad x 6]
|
||||
|
||||
append out rejoin ["Datasize: " length? var-pool " Strings: " length? str-pool "^/"]
|
||||
foreach [a b] sort/skip (to-block str-pool) 2 [
|
||||
append out rejoin [mold a "^/"] ]
|
||||
|
||||
pc: 0
|
||||
while [pc < length? code][
|
||||
s: pad-pc pc
|
||||
op: code/(:pc + 1) ; 1-based block
|
||||
pc: pc + 1
|
||||
switch/default to-lit-word op [
|
||||
'FETCH [ x: code/(pc + 1) c: rejoin [pad-op op x] pc: pc + 1 ]
|
||||
'STORE [ x: code/(pc + 1) c: rejoin [pad-op op x] pc: pc + 1 ]
|
||||
'PUSH [ x: code/(pc + 1) c: rejoin [pad-op op x] pc: pc + 1 ]
|
||||
'ADD [ c: "ADD" ]
|
||||
'SUB [ c: "SUB" ]
|
||||
'MUL [ c: "MUL" ]
|
||||
'DIV [ c: "DIV" ]
|
||||
'MOD [ c: "MOD" ]
|
||||
'LT [ c: "LT" ]
|
||||
'GT [ c: "GT" ]
|
||||
'LE [ c: "LE" ]
|
||||
'GE [ c: "GE" ]
|
||||
'EQ [ c: "EQ" ]
|
||||
'NE [ c: "NE" ]
|
||||
'AND [ c: "AND" ]
|
||||
'OR [ c: "OR" ]
|
||||
'NEG [ c: "NEG" ]
|
||||
'NOT [ c: "NOT" ]
|
||||
'JMP [ x: code/(pc + 1) c: rejoin [pad-op op "(" x ") " pc + x] pc: pc + 1 ]
|
||||
'JZ [ x: code/(pc + 1) c: rejoin [pad-op op "(" x ") " pc + x] pc: pc + 1 ]
|
||||
'PRTC [ c: "PRTC" ]
|
||||
'PRTI [ c: "PRTI" ]
|
||||
'PRTS [ c: "PRTS" ]
|
||||
'HALT [ c: "HALT" ]
|
||||
][ error rejoin ["list-code: Unknown opcode " op] ]
|
||||
append out rejoin [s " " c "^/"]
|
||||
]
|
||||
out
|
||||
] ; list-code
|
||||
|
||||
test: does [
|
||||
while [(tx: ask "Code: ") <> ""] [
|
||||
case [
|
||||
tx = "r" [tx: read fn: request-file]
|
||||
all [tx = "s" fn <> "" tcode <> ""] [
|
||||
out-fn: replace fn ".t" ".tcode"
|
||||
write out-fn tcode
|
||||
print ["Saved to " out-fn]
|
||||
continue ] ]
|
||||
?? fn
|
||||
?? tx
|
||||
lx: lex tx
|
||||
?? lx
|
||||
ast: parse lx
|
||||
?? ast
|
||||
gen ast
|
||||
?? code
|
||||
tcode: list-code
|
||||
print tcode
|
||||
]
|
||||
]
|
||||
test
|
||||
Loading…
Add table
Add a link
Reference in a new issue