Rebol [ Title: "Apply" File: %apply.r Date: 7-May-2009/9:25:31+2:00 Author: "Ladislav Mecir" Purpose: {APPLY function definition} ] 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]] ]