Rebol [
    Title: "Tfunc"
    File: %tfunc.r
    Date: 3/Jul/2004/7:28
    Author: "Ladislav Mecir"
    Web: http://www.fm.vslib.cz/~ladislav/rebol
]

#include-check %default.r

tfunc: func [
    {
        Create a function, which:
        - is transparent for return, exit, throw
        - can return any value using return'
        - can exit using exit'
        - can handle errors using throw'
        - is transparent for "foreign" return', exit', throw'
    }
    ; Note: "Needs Core 2.6 or higher"
    [catch]
    spec [block!] {Help string (opt) followed by arg words (and opt type and string)}
    body [block!] {The body block of the function}
] [
    ; Preserve the original spec block
    spec: copy spec
    ; Make sure spec contains a documentation string
    unless string? pick spec 1 [insert spec "(undocumented)"]
    ; Make sure spec contains "attribute"
    unless any [
        block? pick spec 2
        string? pick spec 2
    ] [insert/only next spec "tfunc"]
    use [f spc] [
        use [return' exit' throw'] [
            return':  make function! [[throw] value [any-type!]] [
                ; let f know, that this is the proper return'
                spc/2: "tfunc"
                return get/any 'value
            ]
            exit': make function! [[throw]] [
                ; let f know, that this is the proper exit'
                spc/2: "tfunc"
                exit
            ]
            throw': make function! [error [error!]] [
                ; let f know, that this is the proper throw'
                spc/2: [catch]
                throw error
            ]
            ; let the body use the above 'return', 'exit' and 'throw'
            body: bind/copy body 'return'
            f: default [make function! spec compose [1 2 (body)]] [throw error]
            spc: third :f
            change second :f [spc/2: [throw]]
		    :f
        ]
    ]
]

tbody: func [
    {the body of a Tfunc}
    f [function!]
] [
    skip second :f 2
]    

; A call of the following functions outside of a tfunc is an error
system/error/throw: make system/error/throw [
    no-tfunc: "Return', exit' or throw' not in a tfunc"
]
return': func [[catch]] [throw make error! [throw no-tfunc]]
exit': func [[catch]] [throw make error! [throw no-tfunc]]
throw': func [[catch]] [throw make error! [throw no-tfunc]]

catch': func [
    {Catches a throw' from a block and returns its value.}
    block [block!] "Block to evaluate"
    /local result1 result2 result1?
] [
	; create a "fresh block"
	set [throw' block] use [throw'] reduce ['throw' copy/deep block]
	set throw' func [value [any-type!]] [
		error? set/any 'result1 get/any 'value
		result1?: true
		make error! ""
	]
	either error? set/any 'result2 try block [
		either result1? [return get/any 'result1] [result2]
	] [return get/any 'result2]
]