From aeba33660143d80adee04d66fba50b34b7c98378 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 2 Sep 2009 11:45:30 -0500
Subject: [PATCH] separate stack effect typing from hints. put it in a "typed"
 vocab, and have a TYPED: word that adds the type checking directly to the
 word

---
 basis/hints/hints.factor | 28 +-------------------
 extra/typed/typed.factor | 56 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 57 insertions(+), 27 deletions(-)
 create mode 100644 extra/typed/typed.factor

diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor
index 07c80917f1..73142cf747 100644
--- a/basis/hints/hints.factor
+++ b/basis/hints/hints.factor
@@ -60,7 +60,7 @@ t specialize-method? set-global
         "method-generic" word-prop standard-generic?
     ] [ drop f ] if ;
 
-: (specialized-def) ( word -- quot )
+: specialized-def ( word -- quot )
     [ def>> ] keep
     dup generic? [ drop ] [
         [ dup standard-method? [ specialize-method ] [ drop ] if ]
@@ -68,32 +68,6 @@ t specialize-method? set-global
         bi
     ] if ;
 
-ERROR: type-mismatch-error word expected-types ;
-
-: typed-stack-effect? ( effect -- ? )
-    [ object = ] all? not ;
-
-: type-mismatch-quot ( word types -- quot )
-    [ type-mismatch-error ] 2curry ;
-
-: make-coercer ( types -- quot )
-    [ "coercer" word-prop [ ] or ]
-    [ swap \ dip [ ] 2sequence prepend ]
-    map-reduce ;
-
-: typed-inputs ( quot word -- quot' )
-    dup stack-effect effect-in-types {
-        [ 2nip make-coercer ]
-        [ 2nip make-specializer ]
-        [ nip swap '[ _ declare @ ] ]
-        [ [ drop ] 2dip type-mismatch-quot ]
-    } 3cleave '[ @ @ _ _ if ] ;
-
-: specialized-def ( word -- quot )
-    [ (specialized-def) ] keep
-    dup stack-effect effect-in-types typed-stack-effect?
-    [ typed-inputs ] [ drop ] if ;
-
 : specialized-length ( specializer -- n )
     dup [ array? ] all? [ first ] when length ;
 
diff --git a/extra/typed/typed.factor b/extra/typed/typed.factor
new file mode 100644
index 0000000000..624d3e1e6c
--- /dev/null
+++ b/extra/typed/typed.factor
@@ -0,0 +1,56 @@
+USING: accessors combinators definitions effects fry hints
+kernel kernel.private parser sequences words ;
+IN: typed
+
+ERROR: type-mismatch-error word expected-types ;
+ERROR: input-mismatch-error < type-mismatch-error ;
+ERROR: output-mismatch-error < type-mismatch-error ;
+
+! typed inputs
+
+: typed-stack-effect? ( effect -- ? )
+    [ object = ] all? not ;
+
+: input-mismatch-quot ( word types -- quot )
+    [ input-mismatch-error ] 2curry ;
+
+: make-coercer ( types -- quot )
+    [ "coercer" word-prop [ ] or ]
+    [ swap \ dip [ ] 2sequence prepend ]
+    map-reduce ;
+
+: typed-inputs ( quot word types -- quot' )
+    {
+        [ 2nip make-coercer ]
+        [ 2nip make-specializer ]
+        [ nip swap '[ _ declare @ ] ]
+        [ [ drop ] 2dip input-mismatch-quot ]
+    } 3cleave '[ @ @ _ _ if ] ;
+
+! typed outputs
+
+: output-mismatch-quot ( word types -- quot )
+    [ output-mismatch-error ] 2curry ;
+
+: typed-outputs ( quot word types -- quot' )
+    2drop ;
+
+! defining typed words
+
+PREDICATE: typed < word "typed" word-prop ;
+
+: typed-def ( word def effect -- quot )
+    [ swap ] dip
+    [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ] 
+    [ effect-out-types dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if ] 2bi ;
+
+: define-typed ( word def effect -- )
+    [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-declared ]
+    [ drop "typed" set-word-prop ] 3bi ;
+
+SYNTAX: TYPED:
+    (:) define-typed ;
+
+M: typed definer drop \ TYPED: \ ; ;
+M: typed definition "typed" word-prop ;
+