Archive version of: apply.r ... version: 2 ... ladislav 7-May-2009

Rebol [
    Title: "Apply"
    File: %apply.r
    Date: 7-May-2009/8:59:07+2:00
    Author: "Ladislav Mecir"
    Purpose: {
        APPLY function definition,
        this version is compatible with R3 native
    }
]

use [return1 return2 do-block] [
    return1: func [
        {special return function setting the given ATTRIBUTE word}
        [throw]
        attribute [word!]
        value [any-type!]
    ] [
        set attribute {no-attribute}
        return get/any 'value
    ]

    return2: func [
        {
            special return function using the given ATTRIBUTE value
            to adjust the spec of the APPLY function
        }
        [throw]
        value [any-type!]
        attribute
    ] [
        poke third :apply 2 attribute
        return get/any 'value
    ]

    do-block: func [
        {function doing a block}
        block [block!]
    ] [
        do block
    ]

    apply: func [
        {apply a function to a block of arguments}
        [throw]
        f [any-function!]
        arguments [block!]
        /only {use arguments as-is, do not reduce the block!}
        /local call path index refinement attribute
        parameter get-argument ignore-argument
    ] [
        unless only [
            error? set/any 'parameter do-block [
                arguments: reduce arguments
                attribute: true
            ]
            unless attribute [return2 get/any 'parameter [throw]]
        ]
        ; code calling the function
        call: reduce ['return1 first ['attribute] path: to path! 'f]
        index: 1 ; index of the argument to be processed
        parameter: get-argument: [
            word! (insert insert/only insert tail call 'pick arguments index)
            | lit-word! (
                use [argument] [
                    error? set/any 'argument pick arguments index
                    insert tail call first [:argument]
                ]
            ) | get-word! (
                use [argument] [
                    error? set/any 'argument pick arguments index
                    insert tail call 'argument
                ]
            )
        ]
        ignore-argument: [word! | lit-word! | get-word!]
        parse third :f [
            any [
                [
                    set refinement refinement! (
                        parameter: either all [pick arguments index true] [
                            insert tail path to word! refinement
                            get-argument
                        ] [ignore-argument]
                    ) | parameter
                ] (index: index + 1) ; argument processed
                | skip
            ]
        ]
        attribute: [throw]
        return2 do-block call attribute
    ]
]

comment [
    ; Test cases:

    1 == apply/only :subtract [2 1]

    paren! == apply/only :type? [()]

    'paren! == apply/only :type? [() true]

    [1] == head apply :insert [copy [] [1] none none none]

    [1] == head apply :insert [copy [] [1] none none false]

    [[1]] == head apply :insert [copy [] [1] none none true]

    native! == apply :type? [:print]

    get-word! == apply/only :type? [:print]

    1 == do does [apply :return [1] 2]

    unset? apply func [x [any-type!]] [return get/any 'x] [()]

    error? apply :make [error! ""]

    strict-equal? first [:x] apply/only func ['x [any-type!]] [
        return get/any 'x
    ] [:x]

    unset? apply func ['x [any-type!]] [return get/any 'x] [()]

    error? apply/only func ['x [any-type!]] [
        return get/any 'x
    ] head insert copy [] make error! ""

    strict-equal? 'x apply/only func [:x [any-type!]] [
        return get/any 'x
    ] [x]

    unset? apply func [:x [any-type!]] [return get/any 'x] [()]

    error? apply/only func [:x [any-type!]] [
        return get/any 'x
    ] head insert copy [] make error! ""
]