Paste: dynamic variables stuff

Author: erg
Mode: factor
Date: Tue, 14 May 2013 21:24:10
Plain Text | 
! Copyright (C) 2011 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs continuations fry kernel math sequences threads
values vectors globals ;
IN: vars

: vchange ( variable quot -- )
    over vars at [
        [ nip ] dip
        [ last swap call ] keep set-last
    ] [
        gchange
    ] if* ; inline

: voff ( variable -- ) [ drop f ] vchange ; inline

: von ( variable -- ) [ drop t ] vchange ; inline

: vget ( variable -- object )
    vars ?at [
        last
    ] [
        gget
    ] if ; inline

: vset ( object variable -- )
    swap '[ drop _ ] vchange ; inline

<PRIVATE

! Used to implement with-var; don't call directly
: push-var ( value variable -- )
    vars 2dup at [
        2nip push
    ] [
        [ 1vector ] 2dip set-at
    ] if* ; inline

ERROR: unbalanced-with-var variable ;

: pop-var ( variable -- )
    dup vars 2dup at [
        dup length dup 1 > [
            1 - swap set-length 3drop
        ] [
            2drop delete-at drop
        ] if
    ] [
        drop unbalanced-with-var
    ] if* ; inline

: vunset ( variable -- )
    vars
    2dup delete-at* nip [
        2drop
    ] [
        drop gunset
    ] if ;

PRIVATE>

: with-var ( object variable quot -- )
    [ [ push-var ] keep ] dip
    swap '[ _ pop-var ] [ ] cleanup ; inline

Annotation: unit tests

Author: erg
Mode: factor
Date: Tue, 14 May 2013 21:24:48
Plain Text | 
! Copyright (C) 2011 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: debugger globals kernel math tools.test vars
vars.private ;
IN: vars.tests

! The order in which these tests are defined matters.

SYMBOL: vartest

[ ] [ vartest gunset ] unit-test
[ ] [ vartest vunset ] unit-test

[ 555 ]
[ 555 vartest [ vartest vget ] with-var ] unit-test

! Test that top of stack is available to vchange's quot
[ 666 ]
[ 555 vartest [ 111 vartest [ + dup ] vchange ] with-var ] unit-test

[ "vartest1234" vget ]
[ T{ undefined-variable { variable "vartest1234" } } = ] must-fail-with

[ 555 vartest [ vartest vget ] with-var vartest vget ]
[ T{ undefined-variable { variable vartest } } = ] must-fail-with

[ 666 ] [
    555 vartest [
        vartest [ 111 + ] vchange
        vartest vget
    ] with-var
] unit-test

[ f ] [
    555 vartest [
        vartest voff
        vartest vget
    ] with-var
] unit-test

[ t ] [
    555 vartest [
        vartest von
        vartest vget
    ] with-var
] unit-test

[ 666 ] [
    555 vartest [
        666 vartest [
            vartest vget
        ] with-var
    ] with-var
] unit-test

[ vartest vget ]
[ T{ undefined-variable { variable vartest } } = ] must-fail-with

[ f ] [ vartest voff vartest vget ] unit-test
[ t ] [ vartest von vartest vget ] unit-test
[ 777 ] [ 777 vartest vset vartest vget ] unit-test

[
    vartest vunset
    vartest vget
] [ T{ undefined-variable { variable vartest } } = ] must-fail-with

[
    5 vartest [ "oops" throw ] with-var
] [ "oops" = ] must-fail-with

[
    [ 5 vartest [ "oops" throw ] with-var ] try
    vartest vget
] [ T{ undefined-variable { variable vartest } } = ] must-fail-with

[ "abc" vunset "abc" pop-var ]
[ T{ unbalanced-with-var { variable "abc" } } = ] must-fail-with

New Annotation

Summary:
Author:
Mode:
Body: