Merge branch 'master' of git://factorcode.org/git/factor

basis/classes/struct/authors.txt

@@ -0,0 +1 @@
+Joe Groff

basis/classes/struct/summary.txt

@@ -0,0 +1 @@
+Tuple-like access to structured raw memory

basis/hints/hints.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs byte-arrays byte-vectors classes
-combinators definitions fry generic generic.single
+combinators definitions effects fry generic generic.single
 generic.standard hashtables io.binary io.streams.string kernel
 kernel.private math math.parser namespaces parser sbufs
 sequences splitting splitting.private strings vectors words ;
@@ -19,6 +19,9 @@ M: class specializer-declaration ;
 
 M: object specializer-declaration class ;
 
+: specializer ( word -- specializer )
+    "specializer" word-prop ;
+
 : make-specializer ( specs -- quot )
     dup length <reversed>
     [ (picker) 2array ] 2map
@@ -28,14 +31,14 @@ M: object specializer-declaration class ;
         [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
     ] if-empty ;
 
-: specializer-cases ( quot word -- default alist )
+: specializer-cases ( quot specializer -- alist )
     dup [ array? ] all? [ 1array ] unless [
-        [ make-specializer ] keep
-        [ specializer-declaration ] map '[ _ declare ] pick append
-    ] { } map>assoc ;
+        [ nip make-specializer ]
+        [ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi
+    ] with { } map>assoc ;
 
-: specialize-quot ( quot specializer -- quot' )
-    specializer-cases alist>quot ;
+: specialize-quot ( quot word specializer -- quot' )
+    [ drop nip def>> ] [ nip specializer-cases ] 3bi alist>quot ;
 
 ! compiler.tree.propagation.inlining sets this to f
 SYMBOL: specialize-method?
@@ -49,8 +52,8 @@ t specialize-method? set-global
 
 : specialize-method ( quot method -- quot' )
     [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
-    [ "method-generic" word-prop "specializer" word-prop ] bi
-    [ specialize-quot ] when* ;
+    [ dup "method-generic" word-prop specializer ] bi
+    [ specialize-quot ] [ drop ] if* ;
 
 : standard-method? ( method -- ? )
     dup method-body? [
@@ -61,7 +64,7 @@ t specialize-method? set-global
     [ def>> ] keep
     dup generic? [ drop ] [
         [ dup standard-method? [ specialize-method ] [ drop ] if ]
-        [ "specializer" word-prop [ specialize-quot ] when* ]
+        [ dup specializer [ specialize-quot ] [ drop ] if* ]
         bi
     ] if ;
 

core/effects/effects-tests.factor

@@ -1,4 +1,5 @@
-USING: effects tools.test prettyprint accessors sequences ;
+USING: effects kernel tools.test prettyprint accessors
+quotations sequences ;
 IN: effects.tests
 
 [ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
@@ -23,3 +24,6 @@ IN: effects.tests
 [ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test
 [ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test
 [ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test
+
+[ { object object } ] [ (( a b -- )) effect-in-types ] unit-test
+[ { object sequence } ] [ (( a b: sequence -- )) effect-in-types ] unit-test

core/effects/effects.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.parser math.order namespaces make sequences strings
-words assocs combinators accessors arrays ;
+words assocs combinators accessors arrays quotations ;
 IN: effects
 
 TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
@@ -53,6 +53,13 @@ M: effect effect>string ( effect -- string )
         ")" %
     ] "" make ;
 
+GENERIC: effect>type ( obj -- type )
+M: object effect>type drop object ;
+M: word effect>type ;
+! attempting to specialize on callable breaks compiling
+! M: effect effect>type drop callable ;
+M: pair effect>type second effect>type ;
+
 GENERIC: stack-effect ( word -- effect/f )
 
 M: word stack-effect "declared-effect" word-prop ;
@@ -87,3 +94,8 @@ M: effect clone
         [ [ [ "obj" ] replicate ] bi@ ] dip
         effect boa
     ] if ; inline
+
+: effect-in-types ( effect -- input-types )
+    in>> [ effect>type ] map ;
+: effect-out-types ( effect -- input-types )
+    out>> [ effect>type ] map ;

core/effects/parser/parser.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: lexer sets sequences kernel splitting effects
-combinators arrays ;
+combinators arrays vocabs.parser classes ;
 IN: effects.parser
 
 DEFER: parse-effect
@@ -13,10 +13,11 @@ ERROR: bad-effect ;
         dup { f "(" "((" } member? [ bad-effect ] [
             ":" ?tail [
                 scan {
-                    { "(" [ ")" parse-effect ] }
-                    { f [ ")" unexpected-eof ] }
+                    { [ dup "(" = ] [ drop ")" parse-effect ] }
+                    { [ dup search class? ] [ search ] }
+                    { [ dup f = ] [ ")" unexpected-eof ] }
                     [ bad-effect ]
-                } case 2array
+                } cond 2array
             ] when
         ] if
     ] if ;

extra/typed/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/typed/summary.txt

@@ -0,0 +1 @@
+Strongly-typed word definitions

extra/typed/typed.factor

@@ -0,0 +1,84 @@
+! (c)Joe Groff bsd license
+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 ;
+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 ]
+        [ 2nip make-coercer ]
+        [ 2nip make-specializer ]
+        [ [ drop ] 2dip output-mismatch-quot ]
+    } 3cleave '[ @ @ @ _ unless ] ;
+
+! defining typed words
+
+: 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 ;
+
+: 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 ] 
+    [ 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-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-def" word-prop ;
+M: typed declarations. "typed-word" word-prop declarations. ;
+