 |
| rebcode - cht'i patch | |
| coccinelle | 23-Feb-2007/22:52:22+1:00 |
| Voilà un petit patch pour rebcode de manière à pouvoir appeler des routines. Je trouvais quand même un peu ennuyeux de ne pas pouvoir organiser mon code. Voici le patch :
; Patch to rebcode assembler
; - setl: ["Set variable to label offset (0 based offset)" word! word!]
; - call: ["call a sub routine" word! word!]
; - ret: ["return from sub routine" word!]
system/internal/rebcode*: make system/internal/rebcode* [
fix-bl: func [block /local labels here label][
labels: make block! 16
block-action: :fix-bl
if debug? [print "=== Fixing binding and labels... ==="]
parse block [
some [
here:
subblock-rule (here/1: bind here/1 words)
|
'label word! (here/1: bind here/1 words insert insert tail labels here/2 index? here)
|
'setl word! word!
|
'call word! word! (
insert at here 4 reduce [
bind 'bra words
here/2
]
)
|
'ret word! (insert at here 2 none) skip
|
opcode-rule (here/1: bind here/1 words)
|
skip (error here)
]
]
parse block [
some [
here:
['bra word! | 'brat word! | 'braf word!] (
fix-label labels at here 2 here 0
)
|
'brab into [some word!] word! (
label: here/2
forall label [
fix-label labels label here -1
]
)
|
'brab word! word! (
fix-label labels at here 2 here -1
)
|
'setl word! word! (
here/1: bind 'set words
here/3: any [
select labels to word! here/3
error/with here join "Missing label '" [here/3 ":"]
]
)
|
'call word! word! (
here/1: bind 'set words
here/2: here/3
here/3: 4 + (index? here)
)
|
'ret none! word! (
here/1: bind 'brab words
here/2: negate 2 + index? here
)
|
opcode-rule
|
skip (print "ICI" error here)
]
]
]
system/internal/assemble: func [
"REBCODE Assembler"
body
/local frame here do-blks labels tmp rule
][
body: second :body
fix-bl body
]
]
Voici un exemple d'emploi :test: rebcode [ i [integer!] /local ret-ofs begin ][ setl sub-ofs sub print ["sub offset is" sub-ofs newline] brab [lab-1 lab-2] i label lab-1 print "call from lab-1" call sub ret-ofs print "returned to ret-1" exit label sub print ["return offset is" ret-ofs] ret ret-ofs label lab-2 print "call from lab-2" call sub ret-ofs print "returned to ret-2" exit ]Ce qui donne donne : >> test 0 offset of sub label is 21 call from lab-1 return offset is 17 returned to ret-1 >> test 1 offset of sub label is 21 call from lab-2 return offset is 36 returned to ret-2 >> | |
| coccinelle | 24-Feb-2007/0:29:04+1:00 |
| J'ai amélioré la chose en stackant les adresses de retour. L'écriture est nettement simplififée et les call multiples et/ou récursifs sont possibles. Voici la nouvelle version :
; Patch to rebcode assembler
; - setl: ["Set variable to label offset (0 based offset)" word! word!]
; - call: ["Call (unconditional) to sub-routine" word!]
; - callf: ["Call to sub-routine if the T flag is not set." word!]
; - callt: ["Call to sub-routine if the T flag is set." word!]
; - ret: ["Return (unconditional) from sub-routine"]
; - retf: ["Return from sub-routine if the T flag is not set."]
; - rett: ["Return from sub-routine if the T flag is set."]
system/internal/rebcode*: make system/internal/rebcode* [
call-stack: []
call-ofs: 0
fix-bl: func [block /local labels here label][
labels: make block! 16
block-action: :fix-bl
if debug? [print "=== Fixing binding and labels... ==="]
parse block [
some [
here:
subblock-rule (here/1: bind here/1 words)
|
'label word! (here/1: bind here/1 words insert insert tail labels here/2 index? here)
|
'setl word! word!
|
['call | 'callt | 'callf] word! (
change/part here compose [
(bind 'insert words) call-stack (5 + index? here) 1
(bind select [call bra callt brat callf braf] here/1 words) (here/2)
(bind 'remove words) call-stack 1
] 2
) 7 skip
|
'ret (
change/part here compose [
(bind 'pick words) call-ofs call-stack 1
ret offset call-ofs
] 1
) 6 skip
|
['rett | 'retf] (
change/part here compose [
(here/1) offset
(bind 'pick words) call-ofs call-stack 1
ret offset call-ofs
] 1
) 8 skip
|
opcode-rule (here/1: bind here/1 words)
|
skip (print "ICI" probe block error here)
]
]
parse block [
some [
here:
['bra word! | 'brat word! | 'braf word!] (
fix-label labels at here 2 here 0
)
|
'brab into [some word!] word! (
label: here/2
forall label [
fix-label labels label here -1
]
)
|
'brab word! word! (
fix-label labels at here 2 here -1
)
|
'setl word! word! (
here/1: bind 'set words
here/3: any [
select labels to word! here/3
error/with here join "Missing label '" [here/3 ":"]
]
)
|
'ret 'offset 'call-ofs (
here/1: bind 'brab words
here/2: negate 2 + index? here
)
|
['rett | 'retf] 'offset (
here/1: bind select [rett braf retf brat] here/1 words
here/2: 7
)
|
opcode-rule
|
skip (print "LA" probe block error here)
]
]
]
system/internal/assemble: func [
"REBCODE Assembler"
body
/local frame here do-blks labels tmp rule
][
body: second :body
fix-bl body
]
]
qui s'emploie maintenant ainsi : test: rebcode [ i [integer!] /local ret-ofs begin ][ setl sub-ofs sub print ["offset of sub label is" sub-ofs newline] brab [lab-1 lab-2] i label lab-1 print "call from lab-1" call sub print "returned to ret-1" exit label sub pick ret-ofs call-stack 1 print ["return offset is" ret-ofs] ret label lab-2 print "call from lab-2" call sub print "returned to ret-2" exit ] | |
|
Login required to Post. | |