Rebol [
    Title: "Subfunc"
    Date: 23-Aug-2005/10:32:41+2:00
    File: %subfunc.r
    Author: [{Gabriele Santilli} {Ladislav Mecir} {Romano Paolo Tenca}]
    Purpose: {
        A functional creating wrapper functions, function "inheritance".
    }
    Web: http://www.fm.vslib.cz/~ladislav/rebol
    Category: [General]
]

#include-check %pass-args.r

comment [
    ; Usage:

    sinsert: subfunc :insert load mold third :insert [
	    print "Inserting..."
		super
    ]
]

subfunc: function [
    "Create a wrapper around a function"
    [catch]
    super [any-function!] "Parent function"
    new-spec [block!] {
        Spec for the subfunction.
        Matching arguments and refinements will be
        used to call the parent function.
        Subfunction can have more arguments/refinements,
        than its parent.
    }
    body [block!]
    /word {use the given word}
        call {to call the parent function}
] [sub context] [
    ; use Super (without arguments) to call the parent function
    ; if not told otherwise
    call: any [call 'super]
    ; create a new call context
    call: first use reduce [call] reduce [reduce [call]]
    ; find a word from the super spec, if any
    context: to word! any [
        pick first :super 1
        ; otherwise return a global word
        'none
    ]
    body: compose [(bind/copy body call) (context)]
    sub: throw-on-error [make function! new-spec body]
    context: last second :sub
    remove back tail second :sub
    set call pass-args :super context
    :sub
]