! 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 ;
M: object specializer-declaration class ;
+: specialized? ( types -- ? )
+ [ object = ] all? not ;
+
+: specializer ( word -- specializer )
+ [ "specializer" word-prop ]
+ [ stack-effect effect-in-types ] bi
+ dup specialized? [ suffix ] [ drop ] if ;
+
: make-specializer ( specs -- quot )
dup length <reversed>
[ (picker) 2array ] 2map
: specialize-method ( quot method -- quot' )
[ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
- [ "method-generic" word-prop "specializer" word-prop ] bi
+ [ "method-generic" word-prop specializer ] bi
[ specialize-quot ] when* ;
: standard-method? ( method -- ? )
[ def>> ] keep
dup generic? [ drop ] [
[ dup standard-method? [ specialize-method ] [ drop ] if ]
- [ "specializer" word-prop [ specialize-quot ] when* ]
+ [ specializer [ specialize-quot ] when* ]
bi
] if ;
-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
[ 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
! 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 } ;
")" %
] "" 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 ;
[ [ [ "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 ;
! 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
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 ;