for typed words, put the specialized definition in a gensym, and check the input...

diff --git a/extra/typed/typed.factor b/extra/typed/typed.factor
index b7feed874b86ed0c2a8595f03c612177bbcad24d..1cfb3394d43963dce67f3ced7433053bfd90a6b2 100644 (file)
--- a/extra/typed/typed.factor
+++ b/extra/typed/typed.factor
@@ -1,6 +1,7 @@
 ! (c)Joe Groff bsd license
-USING: accessors combinators definitions effects fry hints
-kernel kernel.private parser sequences words ;
+USING: accessors combinators combinators.short-circuit
+definitions effects fry hints kernel kernel.private namespaces
+parser quotations see.private sequences words ;
 IN: typed
 
 ERROR: type-mismatch-error word expected-types ;
@@ -43,24 +44,41 @@ ERROR: output-mismatch-error < type-mismatch-error ;
 
 ! defining typed words
 
-PREDICATE: typed < word "typed" word-prop ;
+: typed-gensym-quot ( def word effect -- quot )
+    [ nip effect-in-types swap '[ _ declare @ ] ]
+    [ effect-out-types dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if ] 2bi ;
 
-: typed-def ( word def effect -- quot )
-    [ swap ] dip
+: define-typed-gensym ( word def effect -- gensym )
+    [ 3drop gensym dup ]
+    [ [ swap ] dip typed-gensym-quot ]
+    [ 2nip ] 3tri define-declared ;
+
+PREDICATE: typed < word "typed-word" word-prop ;
+
+: typed-quot ( quot word effect -- quot' )
     [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ] 
-    [ effect-out-types dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if ] 2bi ;
+    [ nip effect-out-types dup typed-stack-effect? [ '[ @ _ declare ] ] [ drop ] if ] 2bi ;
+
+: (typed-def) ( word def effect -- quot )
+    [ define-typed-gensym ] 3keep
+    [ drop [ swap "typed-word" set-word-prop ] [ [ 1quotation ] dip ] 2bi ] dip
+    typed-quot ;
+
+: typed-def ( word def effect -- quot )
+    dup {
+        [ effect-in-types typed-stack-effect? ]
+        [ effect-out-types typed-stack-effect? ]
+    } 1|| [ (typed-def) ] [ drop nip ] if ;
 
 : define-typed ( word def effect -- )
-    {
-        [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-declared ]
-        [ nip effect-in-types "input-classes" set-word-prop ]
-        [ nip effect-out-types "default-output-classes" set-word-prop ]
-        [ drop "typed" set-word-prop ]
-    } 3cleave ;
+    [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ] 
+    [ drop "typed-def" set-word-prop ]
+    [ 2drop "typed-word" word-prop \ word set-global ] 3tri ;
 
 SYNTAX: TYPED:
     (:) define-typed ;
 
 M: typed definer drop \ TYPED: \ ; ;
-M: typed definition "typed" word-prop ;
+M: typed definition "typed-def" word-prop ;
+M: typed declarations. "typed-word" word-prop declarations. ;