From 82e01fb58ce061812d38dea71c301b4ab8055c18 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 10 Nov 2011 10:46:56 -0800
Subject: [PATCH] new module typed.namespaces: get/set + type check

---
 .../typed/namespaces/namespaces-tests.factor  | 19 +++++++++
 basis/typed/namespaces/namespaces.factor      | 40 +++++++++++++++++++
 2 files changed, 59 insertions(+)
 create mode 100644 basis/typed/namespaces/namespaces-tests.factor
 create mode 100644 basis/typed/namespaces/namespaces.factor

diff --git a/basis/typed/namespaces/namespaces-tests.factor b/basis/typed/namespaces/namespaces-tests.factor
new file mode 100644
index 0000000000..3e497be51c
--- /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
index 0000000000..bca92ff089
--- /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
+