Script Library: 1223 scripts
  • Home
  • Script library
  • AltME Archive
  • Mailing list
  • Articles Index
  • Site search
 

Archive version of: apply.r ... version: 4 ... ladislav 26-Dec-2012

Amendment note: License update || Publicly available? Yes

Rebol [
    Title: "Apply"
    File: %apply.r
    Date: 26-Dec-2012/15:00:27+1:00
    Author: "Ladislav Mecir"
    Purpose: {APPLY function definition}
	License: {
		Licensed under the Apache License, Version 2.0 (the "License");
		you may not use this file except in compliance with the License.
		You may obtain a copy of the License at

		http://www.apache.org/licenses/LICENSE-2.0
	}
]

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! (
                either get-word? pick arguments index [
                    use [argument] [
                        error? set/any 'argument pick arguments index
                        insert tail call first [:argument]
                    ]
                ] [
                    insert/only tail call pick arguments index
                ]
            ) | 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 [
    ; Helper functions
    quote: func [:x [any-type!]] [return get/any 'x]
    also: func [x [any-type!] y [any-type!]] [return get/any 'x]
    
    ; Test cases:

    1 == apply :subtract [2 1]

    ; 1 == apply :- [2 1] ; R3 - specific
    
    -2 == apply :- [2] ; R2 - specific

    none == apply func [a] [a] []
    
    none == apply/only func [a] [a] []
    
    1 == apply func [a] [a] [1 2]
    
    1 == apply/only func [a] [a] [1 2]
    
    true == apply func [/a] [a] [true]
    
    none == apply func [/a] [a] [false]
    
    none == apply func [/a] [a] []
    
    true == apply/only func [/a] [a] [true]
    
    true == apply/only func [/a] [a] [false] ; the word 'false
    
    none == apply/only func [/a] [a] []
    
    use [a] [a: true true == apply func [/a] [a] [a]]
    
    use [a] [a: false none == apply func [/a] [a] [a]]
    
    use [a] [a: false true == apply func [/a] [a] ['a]]
    
    use [a] [a: false true == apply func [/a] [a] [/a]]
    
    use [a] [a: false true == apply/only func [/a] [a] [a]]
    
    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]

    ; 2 == do does [apply does [] [return 1] 2] ; a bug
    
    1 == do does [apply does [] [return 1] 2]

    ; 2 == do does [apply func [a] [a] [return 1] 2] ; a bug
    
    1 == do does [apply func [a] [a] [return 1] 2]

    ; unset? apply does [] [return 1] ; a bug
    
    ; 1 == apply func [a] [a] [return 1] ; a bug
    
    ; error? try [apply :add [return 1 2]] ; R3 specific
    
    ; error? try [apply :add [2 return 1]] ; R3 specific
    
    ; error? try [apply :also [return 1 2]] ; R3 specific
    
    ; 2 == apply :also [2 return 1] ; a bug

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

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

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

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

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

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

    error? apply :make [error! ""]

    ; error? apply func [:x [any-type!]] [return get/any 'x] [make error! ""] ; R3 - specific

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

    error? apply/only func [:x [any-type!]] [
        return get/any 'x
    ] head insert copy [] make error! ""
    
    use [x] [x: 1 strict-equal? 1 apply func ['x] [:x] [:x]]
    
    use [x] [x: 1 strict-equal? first [:x] apply/only func ['x] [:x] [:x]]
    
    use [x] [unset 'x strict-equal? first [:x] apply/only func ['x [any-type!]] [
        return get/any 'x
    ] [:x]]
    
    use [x] [x: 1 strict-equal? 1 apply func [:x] [:x] [x]]
    
    use [x] [x: 1 strict-equal? 'x apply func [:x] [:x] ['x]]
    
    use [x] [x: 1 strict-equal? 'x apply/only func [:x] [:x] [x]]
    
    use [x] [x: 1 strict-equal? 'x apply/only func [:x] [return :x] [x]]
    
    use [x] [unset 'x strict-equal? 'x apply/only func [:x [any-type!]] [
        return get/any 'x
    ] [x]]
]