Rebol [
    Author: "Ladislav Mecir"
    Date: 12-May-2006/15:58+2:00
    Purpose: {REBOL code from the bindology article}
    File: %contexts.r
    Title: "Contexts"
]

do http://www.rebol.org/download-a-script.r?script-name=closure.r

spelling?: func [
    {return the spelling of a WORD}
    word [any-word!]
] [
	case [
    	word? :word [mold :word]
    	set-word? :word [head remove back tail mold :word]
    	true [next mold :word]
    ]
]

variable?: func [
    {is the given WORD a variable?}
    word [any-word!]
] [
    found? bind? :word
]

different-binding: func [
    {
    	for a given WORD yield a word having
        strict equal spelling, equal type and different binding
    }
    word [any-word!] {the given word}
] [
    bind :word case [
        'self = :word [use [self] ['self]]
        set-word? :word [make object! reduce [:word none]]
        true [first second make function! reduce ['self :word] [self]]
    ]
]

aliases?: func [
    {find out, if WORD1 and WORD2 are aliases}
    word1 [any-word!]
    word2 [any-word!]
] [
    found? all [
        equal? :word1 :word2
        not strict-equal? spelling? :word1 spelling? :word2
    ]
]

same-variable?: func [
	{are WORD1 and WORD2 the same variable?}
    word1 [any-word!]
    word2 [any-word!]
] [
    found? all [
        equal? :word1 :word2
        equal? bind? :word1 bind? :word2
    ]
]

aliases?: func [
    {find out, if WORD1 and WORD2 are aliases}
    word1 [any-word!]
    word2 [any-word!]
    /local context
] [
    found? all [
        equal? :word1 :word2
        (
            if context: any [bind? :word1 bind? :word2] [
                word1: in context :word1
                word2: in context :word2
            ]
            ; WORD1 and WORD2 have equal binding now
            not same? :word1 :word2
        )
    ]
]

context-words?: func [
	{get the words in a given CONTEXT}
	context [object!]
] [
	bind first context context
]

global-context: bind? 'system

global?: func [
    {find out if a WORD is global}
    word [any-word!]
] [
    same? global-context bind? :word
]

local?: func [
    {find out, if a WORD is local}
    word [any-word!]
] [
    not any [
        none? bind? :word
        global? :word
    ]
]

code-string: {
    'f 'g 'h
    use [g h] [
        colorize "USE 1"
        'f 'g 'h
        use [h] [
            colorize "USE 2"
            'f 'g 'h
        ]
    ]
}

emit: func [text [char! string! block!]] [
    append result either block? text [rejoin text] [text]
]

colorize: func [
    {emit a table row containing text and the colorized code block}
    text [string!]
    /local space?
] [
    emit ["^/|-^/| " text "^/| "]
    space?: ""
    parse code-block rule: [
        (
            emit [space? #"["]
            space?: ""
        )
        any [
            [
                set word any-word! (
                    emit [
                        space?
                        {}
                        mold :word
                        
                    ]
                ) | into rule | set word skip (
                    emit [space? mold :word]
                )
            ]
            (space?: " ")
        ]
        (emit #"]")
    ]
]

make-context-model: func [
	{context creation simulation}
    words [block!] {context words, needs to be non-empty}
] [
    bind? first use words reduce [reduce [first words]]
]

use-model: function [
    {USE simulation, works for non-empty WORDS block}
    [throw]
    words [block!] "Local word(s) to the block"
    body [block!] "Block to evaluate"
] [new-context] [
    unless empty? words [
        ; create a new context
        new-context: make-context-model words
        ; bind the body to the new Context
        bind body new-context
    ]
    do body
]

nm-use: func [
    {
        Defines words local to a block.
        Does't modify the BODY argument.
    }
    [throw]
    words [block!] {Local words to the block}
    body [block!] {Block to evaluate}
] [
    use words copy/deep body
]

spec-eval: func [
    {evaluate the SPEC like MAKE OBJECT! does}
    spec [block!]
] [
    any-type? catch [loop 1 spec]
]

make-object!-model: function [
    {MAKE OBJECT! simulation}
    spec [block!]
] [set-words object sw] [
    ; find all set-words in SPEC
    set-words: copy [self]
    parse spec [
        any [
            copy sw set-word! (append set-words sw) |
            skip
        ]
    ]
    ; create a context with the desired local words
    object: make-context-model set-words
    ; set 'self in object to refer to the object
    object/self: object
    ; bind the SPEC to the blank object
    bind spec in object 'self
    ; evaluate it
    spec-eval spec
    ; return the value of 'self as the result
    return get/any in object 'self
]

specbind: function [
    {bind only known-words}
    block [block!]
    known-words [block!]
] [p w bind-one kw] [
    bind-one: [
        p:
        [
            copy w any-word! (
                if kw: find known-words first w [
                    change p bind w first kw
                ]
            ) | copy w [path! | set-path! | lit-path!] (
                if kw: find known-words first first w [
                    change p bind w first kw
                ]
            ) | into [any bind-one] | skip
        ]
    ]
    parse block [any bind-one]
    block
]

make-proto: function [
    {MAKE PROTO simulation}
    proto [object!]
    spec [block!]
] [set-words object sw word value spc body pwords] [
	; get local words from proto
    set-words: copy first proto

    ; append all set-words from SPEC
    parse spec [
        any [
            copy sw set-word! (append set-words sw) |
            skip
        ]
    ]

    ; create a blank object with the desired local words
    object: make-context-model set-words
    object/self: object

    ; copy the contents of the proto
    pwords: bind first proto object
    repeat i (length? first proto) - 1 [
        word: pick next first proto i
        any-type? set/any 'value pick next second proto i
        any [
            all [string? get/any 'value set in object word copy value]
            all [
                block? get/any 'value
                value: specbind copy/deep value pwords
                set in object word value
            ]
            all [
                function? get/any 'value
                spc: load mold third :value
                body: specbind copy/deep second :value pwords
                set in object word func spc body
            ]
            any-type? set/any in object word get/any 'value
        ]
    ]

    bind spec object
    spec-eval spec
    return get/any in object 'self
]

locals?: func [
    {Get all locals from a spec block.}
    spec [block!]
    /args {get only arguments}
    /local locals item item-rule
] [
    locals: make block! 16
    item-rule: either args [
		[
			refinement! to end (item-rule: [end skip]) |
			set item any-word! (insert tail locals to word! :item) | skip
		]
	] [
		[
			set item any-word! (insert tail locals to word! :item) | skip
		]
	]
    parse spec [any item-rule]
    locals
]

set-words: func [
    {Get all set-words from a block}
    block [block!]
    /deep {also search in subblocks/parens}
    /local elem words rule here
] [
    words: make block! length? block
    rule: either deep [
        [
            any [
                set elem set-word! (
                    insert tail words to word! :elem
                ) | here: [block! | paren!] :here into rule | skip
            ]
        ]
    ] [
        [
            any [
                set elem set-word! (
                    insert tail words to word! :elem
                ) | skip
            ]
        ]
    ]
    parse block rule
    words
]

funcs: func [
    {Define a function with auto local and static variables.}
    [throw]
    spec [block!] {Help string (opt) followed by arg words with opt type and string}
    init [block!] {Set-words become static variables, shallow scan}
    body [block!] {Set-words become local variables, deep scan}
    /local svars lvars
] [
    ; Preserve the original Spec, Init and Body
    spec: copy spec
    init: copy/deep init
    body: copy/deep body
    ; Collect static and local variables
    svars: set-words init
    lvars: set-words/deep body
    unless empty? svars [
        ; create the static context and bind Init and Body to it
        use svars reduce [reduce [init body]]
    ]
    unless empty? lvars: exclude exclude lvars locals? spec svars [
        ; declare local variables
        insert any [find spec /local insert tail spec /local] lvars
    ]
    do init
    make function! spec body
]

function!-model: make object! [
    spec: none
    body: none
    context: none
    context-words: none
    recursion-level: none
]

func-model: function [
    {create a function!-model}
    spec [block!]
    body [block!]
] [result aw] [
    result: make function!-model []

    ; SPEC and BODY are deep copied
    result/spec: copy/deep spec
    result/body: copy/deep body

    ; context words are collected from SPEC
    result/context-words: locals? spec
    either empty? result/context-words [
    	result/context: [[] []]
    ] [
        result/context: make-context-model result/context-words
        bind result/body result/context
        bind result/context-words result/context
    ]

    ; RECURSION-LEVEL is set to zero
    result/recursion-level: 0

    result
]

call-stack-model: make block! []

exec: func [body] [do body]

evaluate-model: function [
    {evaluate a function!-model}
    f-model {the evaluated function!-model}
    values [block!] {the supplied values}
] [old-values result] [
    ; detect recursive call
    if (f-model/recursion-level: f-model/recursion-level + 1) > 1 [
        ; push the old values of context words to the stack
        insert/only tail call-stack-model second f-model/context
    ]
    set/any f-model/context-words values

    ; execute the function body
    error? set/any 'result exec f-model/body

    ; restore the former values from the stack, if needed
    if (f-model/recursion-level: f-model/recursion-level - 1) > 0 [
    	; pop the old values of the context words from the stack
        set/any f-model/context-words last call-stack-model
        remove back tail call-stack-model
    ]

    return get/any 'result
]