new module typed.namespaces: get/set + type check

diff --git a/basis/typed/namespaces/namespaces-tests.factor b/basis/typed/namespaces/namespaces-tests.factor
new file mode 100644 (file)
index 0000000..3e497be
--- /dev/null
+++ b/basis/typed/namespaces/namespaces-tests.factor
@@ -0,0 +1,19 @@
+USING: compiler.tree.debugger math tools.test typed.namespaces ;
+IN: typed.namespaces.tests
+
+SYMBOL: pi
+
+[ 22/7 pi float typed-set ] [ variable-type-error? ] must-fail-with
+
+{ 3.14159265358979 } [
+    3.14159265358979 pi float typed-set
+    pi float typed-get
+] unit-test
+
+[
+    3.14159265358979 pi float typed-set
+    pi integer typed-get
+] [ variable-type-error? ] must-fail-with
+
+
+{ t } [ [ 2.0 pi float typed-get * ] { * } inlined? ] unit-test

diff --git a/basis/typed/namespaces/namespaces.factor b/basis/typed/namespaces/namespaces.factor
new file mode 100644 (file)
index 0000000..bca92ff
--- /dev/null
+++ b/basis/typed/namespaces/namespaces.factor
@@ -0,0 +1,40 @@
+USING: arrays classes fry kernel kernel.private locals macros
+namespaces ;
+IN: typed.namespaces
+
+ERROR: variable-type-error variable value type ;
+
+<PRIVATE
+
+MACRO: declare1 ( type -- quot: ( value -- value ) )
+    1array '[ _ declare ] ;
+
+: typed-get-unsafe ( name type -- value )
+    [ get ] dip declare1 ; inline
+
+: typed-get-global-unsafe ( name type -- value )
+    [ get-global ] dip declare1 ; inline
+
+PRIVATE>
+
+:: (typed-get) ( name type getter: ( name -- value ) -- value )
+    name getter call :> value
+    value type instance? [ name value type variable-type-error ] unless
+    value type declare1 ; inline
+
+: typed-get ( name type -- value )
+    [ get ] (typed-get) ; inline
+
+: typed-get-global ( name type -- value )
+    [ get-global ] (typed-get) ; inline
+
+:: (typed-set) ( value name type setter: ( value name -- ) -- )
+    value type instance? [ name value type variable-type-error ] unless
+    value name setter call ; inline
+
+: typed-set ( value name type -- )
+    [ set ] (typed-set) ; inline
+
+: typed-set-global ( value name type -- )
+    [ set-global ] (typed-set) ; inline
+