--- /dev/null
+Tuple-like access to structured raw memory
! 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 ;
+: specializer ( word -- specializer )
+ "specializer" word-prop ;
+
: make-specializer ( specs -- quot )
dup length <reversed>
[ (picker) 2array ] 2map
[ ] [ 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?
: 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? [
[ 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 ;
-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 ;
--- /dev/null
+Strongly-typed word definitions
--- /dev/null
+! (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. ;
+