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]]
]