98 lines
2.2 KiB
Factor
98 lines
2.2 KiB
Factor
IN: scratchpad
|
|
USE: arithmetic
|
|
USE: combinators
|
|
USE: compiler
|
|
USE: inspector
|
|
USE: kernel
|
|
USE: lists
|
|
USE: logic
|
|
USE: namespaces
|
|
USE: random
|
|
USE: stack
|
|
USE: stdio
|
|
USE: strings
|
|
USE: test
|
|
USE: words
|
|
USE: vocabularies
|
|
|
|
"Namespace tests." print
|
|
|
|
[ t ] [ global [ "global" get ] bind global ] [ = ] test-word
|
|
[ [ 1 0 0 0 ] ] [ [ >n ] ] [ balance>list ] test-word
|
|
[ [ 1 1 0 0 ] ] [ [ get ] ] [ balance>list ] test-word
|
|
[ [ 2 0 0 0 ] ] [ [ set ] ] [ balance>list ] test-word
|
|
[ [ 0 1 0 0 ] ] [ [ namestack* ] ] [ balance>list ] test-word
|
|
[ [ 0 1 0 0 ] ] [ [ namestack ] ] [ balance>list ] test-word
|
|
[ [ 1 0 0 0 ] ] [ [ set-namestack* ] ] [ balance>list ] test-word
|
|
[ [ 1 0 0 0 ] ] [ [ set-namestack ] ] [ balance>list ] test-word
|
|
[ [ 0 1 0 0 ] ] [ [ n> ] ] [ balance>list ] test-word
|
|
|
|
<namespace> "test-namespace" set
|
|
|
|
: test-namespace ( -- )
|
|
<namespace> dup [ namespace = ] bind ;
|
|
|
|
: test-this-1 ( -- )
|
|
<namespace> dup [ this = ] bind ;
|
|
|
|
: test-this-2 ( -- )
|
|
interpreter dup [ this = ] bind ;
|
|
|
|
[ t ] [ ] [ test-namespace ] test-word
|
|
[ t ] [ ] [ test-this-1 ] test-word
|
|
[ t ] [ ] [ test-this-2 ] test-word
|
|
|
|
! These stress-test a lot of code.
|
|
global describe
|
|
"vocabularies" get describe
|
|
|
|
: namespace-compile ( x -- x )
|
|
<namespace> [ "x" set ] extend [ "x" get ] bind ; word must-compile
|
|
|
|
[ 12 ] [ 12 ] [ namespace-compile ] test-word
|
|
|
|
! A compiler bug in tailcalls that manifests with the namestack
|
|
|
|
: namespace-tail-call-bug ( x -- x )
|
|
dup 0 = [
|
|
drop
|
|
] [
|
|
pred <namespace> [ dup "x" set namespace-tail-call-bug ] bind
|
|
] ifte ; word must-compile
|
|
|
|
[ f ] [ ] [ 10 namespace-tail-call-bug "x" get 0 = ] test-word
|
|
|
|
! Object paths should not resolve further up in the namestack.
|
|
|
|
<namespace> "test-namespace" set
|
|
[ f ]
|
|
[ [ "test-namespace" "test-namespace" ] ]
|
|
[ object-path ]
|
|
test-word
|
|
|
|
[ f ]
|
|
[ [ "alalal" "boobobo" "bah" ] ]
|
|
[ object-path ]
|
|
test-word
|
|
|
|
[ t ]
|
|
[ this [ ] ]
|
|
[ object-path = ]
|
|
test-word
|
|
|
|
[ t ]
|
|
[ "test-word" intern [ "global" "vocabularies" "test" "test-word" ] ]
|
|
[ object-path = ]
|
|
test-word
|
|
|
|
10 "some-global" set
|
|
[ f ]
|
|
[ ]
|
|
[ <namespace> [ f "some-global" set "some-global" get ] bind ]
|
|
test-word
|
|
|
|
! I did a n> in extend and forgot the obvious case
|
|
[ t ] [ "dup" intern dup ] [ [ ] extend = ] test-word
|
|
|
|
"Namespace tests passed." print
|