Skip to content
Permalink
master
Switch branches/tags

Name already in use

A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?
Go to file
 
 
Cannot retrieve contributors at this time
Red[
Title: "Various function! related tools"
Author: "Boleslav Březovský"
Note: {
For details about these functions, see my articles:
`apply`, `ufc` - http://red.qyz.cz/apply-and-ufcs.html
`dispatcher` - http://red.qyz.cz/pattern-matching.html
}
]
actions: has [
"Return block of all actions"
result
][
result: []
if empty? result [
result: collect [
foreach word words-of system/words [
if action? get/any word [keep word]
]
]
]
result
]
op: func [
"Defines op! with given spec and body"
spec [block!]
body [block!]
][
make op! func spec body
]
; --- get arity and refinements ------------------------------------------------
arity?: func [
"Return function's arity" ; TODO: support for lit-word! and get-word! ?
fn [any-function!] "Function to examine"
/local result count name count-rule refinement-rule append-name
][
result: copy []
count: 0
name: none
append-name: quote (repend result either name [[name count]][[count]])
count-rule: [
some [
word! (count: count + 1)
| ahead refinement! refinement-rule
| skip
]
]
refinement-rule: [
append-name
set name refinement!
(count: 0)
count-rule
]
parse spec-of :fn count-rule
do append-name
either find result /local [
head remove/part find result /local 2
][result]
]
refinements?: func [
"Return block of refinements for given function"
fn [any-function!] "Function to examine"
/local value
][
parse spec-of :fn [
collect [some [set value refinement! keep (to word! value) | skip]]
]
]
; --- unified function call syntax ---------------------------------------------
ufcs: func [
"Apply functions to given series"
series [series!] "Series to manipulate"
dialect [block!] "Block of actions and arguments, without first argument (series defined above)"
/local result action args code arity refs ref-stack refs?
][
result: none
code: []
until [
; do some preparation
clear code
action: take dialect
arity: arity? get action
args: arity/1 - 1
refs: refinements? get action
ref-stack: clear []
refs?: false
unless zero? args [append ref-stack take dialect]
; check for refinements
while [find refs first dialect][
refs?: true
ref: take dialect
either path? action [
append action ref
][
action: make path! reduce [action ref]
]
unless zero? select arity ref [
append ref-stack take dialect
]
]
; put all code together
append/only code action
append/only code series
unless empty? ref-stack [append code ref-stack]
series: do code
empty? dialect
]
series
]
ufc: function [
"Apply functions to given series"
data [series!] "Series to manipulate"
dialect [block!] "Block of actions and arguments, without first argument (series defined above)"
][
foreach [cmd args] dialect [
data: apply get cmd head insert/only args data
]
data
]
; --- apply function -----------------------------------------------------------
apply: func [
"Apply a function to a block of arguments"
fn [any-function!] "Function value to apply"
args [block!] "Block of arguments (to quote refinement use QUOTE keyword)"
/local refs vals val
][
refs: copy []
vals: copy []
set-val: [set val skip (append/only vals val)]
parse args [
some [
'quote set-val
| set val refinement! (append refs to word! val)
| set-val
]
]
do compose [(make path! head insert refs 'fn) (vals)]
]
map: func [
"Apply code over block of values"
data
code
/local f
][
data: copy data
f: get take code
forall data [
data/1: apply :f compose [(first data) (code)]
]
data
]
map-each: func [
'word
series
code
][
collect [
until [
set :word first series
keep do code
series: next series
tail? series
]
]
]
; --- dispatch function --------------------------------------------------------
dispatcher: func [
"Return dispatcher function that can be extended with DISPATCH"
spec [block!] "Function specification"
][
func spec [
case []
]
]
dispatch: func [
"Add new condition and action to DISPATCHER function"
dispatcher [any-function!] "Dispatcher function to use"
cond [block! none!] "Block of conditions to pass or NONE for catch-all condition (forces /RELAX)"
body [block! none!] "Action to do when condition is fulfilled or NONE for removing rule"
/relax "Add condition to end of rules instead of beginning"
/local this cases mark penultimo
][
cases: second body-of :dispatcher
penultimo: back back tail cases
unless equal? true first penultimo [penultimo: tail cases]
if cond [bind cond :dispatcher]
if body [bind body :dispatcher]
this: compose/deep [all [(cond)] [(body)]]
case [
all [not cond not body not empty? penultimo][remove/part penultimo 2] ; remove catch-all rule (if exists)
all [not body mark: find/only cases cond][remove/part back mark 3] ; remove rule (if exists)
all [not cond true = first penultimo][change/only next penultimo body] ; change catch-all rule (if exists)
not cond [repend cases [true body]] ; add catch-all rule
mark: find/only cases cond [change/part back mark this 3] ; change existing rule (if exists)
relax [insert penultimo this] ; add new rule to end
'default [insert cases this] ; add new rule to beginning
]
:dispatcher
]
; --- function constructors --------------------------------------------
dfunc: func [
"Define function with default values for local words"
spec
body
][
; format for default values is [set-word: value] after /local refinement
; it's possible to mix normal words (without default value) and set-words
local: copy []
locals: copy #()
if mark: find spec /local [
parse next mark [
some [
set word set-word!
set value skip (
append local to word! word
locals/:word: value
)
| set word word! (append local word)
]
]
remove/part mark length? mark
append spec compose [/local (local)]
foreach word words-of locals [
insert body reduce [to set-word! word locals/:word]
]
]
func spec body
]
fce: func [
"The ultimate function constructor" ; right now supports /local only
spec [block!]
body [block!]
/local local-mark locals locs expose? body-rule word length
][
; get local words defined in function specs
parse spec [
any [
ahead /local local-mark: skip
copy locals to [refinement! | issue! | end]
| remove #expose (expose?: true)
| skip
]
]
unless locals [locals: copy []]
locs: clear []
; get local words defined in function body using local
parse body body-rule: [
some [
ahead [/local [set-word! | word!]]
remove skip set word skip (append locs to word! word)
| ['foreach | 'remove-each] set word [word! | block!] (append locs word)
| 'repeat set word word! (append locs word)
| ahead [block! | paren!] into body-rule
| skip
]
]
length: length? locals
either expose? [
remove/part local-mark 1 + length
][
append locals locs
locals: unique locals
either local-mark [
change/part next local-mark locals length
][
append spec head insert locals /local
]
]
func spec body
]