rebcode - cht'i patch
coccinelle23-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
>>
coccinelle24-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.


Powered by RebelBB and REBOL 2.7.8.4.2