From 19b10fb85eda961345ff5085ee94903bc3abe339 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 1 Sep 2009 14:39:22 -0500 Subject: [PATCH 1/9] bring back ( x: type y: type -- ) stack effect syntax, and automatically hint words based on types in their declared effect --- basis/hints/hints.factor | 14 +++++++++++--- core/effects/effects-tests.factor | 6 +++++- core/effects/effects.factor | 14 +++++++++++++- core/effects/parser/parser.factor | 9 +++++---- 4 files changed, 34 insertions(+), 9 deletions(-) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 08d794090c..6694b80909 100644 --- a/basis/hints/hints.factor +++ b/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,14 @@ M: class specializer-declaration ; 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 [ (picker) 2array ] 2map @@ -49,7 +57,7 @@ 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 + [ "method-generic" word-prop specializer ] bi [ specialize-quot ] when* ; : standard-method? ( method -- ? ) @@ -61,7 +69,7 @@ t specialize-method? set-global [ def>> ] keep dup generic? [ drop ] [ [ dup standard-method? [ specialize-method ] [ drop ] if ] - [ "specializer" word-prop [ specialize-quot ] when* ] + [ specializer [ specialize-quot ] when* ] bi ] if ; diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index 37d4fd1195..8adef62795 100644 --- a/core/effects/effects-tests.factor +++ b/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 2 2 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 diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 5cbb0fe36e..8c1699f8d6 100644 --- a/core/effects/effects.factor +++ b/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 ; diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index 66179c5e52..da27dc28b4 100644 --- a/core/effects/parser/parser.factor +++ b/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 ; From 6b512e31876219430fdf445e1a9d76922c756681 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 1 Sep 2009 15:49:08 -0500 Subject: [PATCH 2/9] make type declarations in stack effects strong and throw an error if the inputs don't match --- basis/hints/hints.factor | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 6694b80909..8787843526 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -36,14 +36,21 @@ M: object specializer-declaration class ; [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce ] if-empty ; -: specializer-cases ( quot word -- default alist ) - dup [ array? ] all? [ 1array ] unless [ - [ make-specializer ] keep - [ specializer-declaration ] map '[ _ declare ] pick append - ] { } map>assoc ; +ERROR: type-mismatch-error word expected-types ; -: specialize-quot ( quot specializer -- quot' ) - specializer-cases alist>quot ; +: fallback-def ( word -- quot ) + dup stack-effect effect-in-types dup specialized? + [ [ type-mismatch-error ] 2curry ] + [ drop def>> ] if ; + +: specializer-cases ( quot specializer -- alist ) + dup [ array? ] all? [ 1array ] unless [ + [ nip make-specializer ] + [ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi + ] with { } map>assoc ; + +: specialize-quot ( quot word specializer -- quot' ) + [ drop nip fallback-def ] [ nip specializer-cases ] 3bi alist>quot ; ! compiler.tree.propagation.inlining sets this to f SYMBOL: specialize-method? @@ -57,8 +64,8 @@ t specialize-method? set-global : specialize-method ( quot method -- quot' ) [ specialize-method? get [ method-declaration prepend ] [ drop ] if ] - [ "method-generic" word-prop specializer ] bi - [ specialize-quot ] when* ; + [ dup "method-generic" word-prop specializer ] bi + [ specialize-quot ] [ nip ] if* ; : standard-method? ( method -- ? ) dup method-body? [ @@ -69,7 +76,7 @@ t specialize-method? set-global [ def>> ] keep dup generic? [ drop ] [ [ dup standard-method? [ specialize-method ] [ drop ] if ] - [ specializer [ specialize-quot ] when* ] + [ dup specializer [ specialize-quot ] [ drop ] if* ] bi ] if ; From 32cba4dad36f00487169b745277e3150172121f4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 1 Sep 2009 15:49:21 -0500 Subject: [PATCH 3/9] metadata for classes.struct --- basis/classes/struct/authors.txt | 1 + basis/classes/struct/summary.txt | 1 + 2 files changed, 2 insertions(+) create mode 100644 basis/classes/struct/authors.txt create mode 100644 basis/classes/struct/summary.txt diff --git a/basis/classes/struct/authors.txt b/basis/classes/struct/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/classes/struct/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/classes/struct/summary.txt b/basis/classes/struct/summary.txt new file mode 100644 index 0000000000..f2795cb6e9 --- /dev/null +++ b/basis/classes/struct/summary.txt @@ -0,0 +1 @@ +Tuple-like access to structured raw memory From 333943188e205d797261c29c3f847af6ccce2520 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 1 Sep 2009 15:59:59 -0500 Subject: [PATCH 4/9] typo in specialize-method --- basis/hints/hints.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 8787843526..ffd3a8148d 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -65,7 +65,7 @@ t specialize-method? set-global : specialize-method ( quot method -- quot' ) [ specialize-method? get [ method-declaration prepend ] [ drop ] if ] [ dup "method-generic" word-prop specializer ] bi - [ specialize-quot ] [ nip ] if* ; + [ specialize-quot ] [ drop ] if* ; : standard-method? ( method -- ? ) dup method-body? [ From cb56e955673094df50662d87acfbb24907f6fd30 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 1 Sep 2009 23:13:08 -0500 Subject: [PATCH 5/9] handle the stack effect type as a separate specialization pass, and use coercers when available --- basis/hints/hints.factor | 44 ++++++++++++++++++++++++++-------------- 1 file changed, 29 insertions(+), 15 deletions(-) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index ffd3a8148d..07c80917f1 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -19,13 +19,8 @@ M: class specializer-declaration ; 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 ; + "specializer" word-prop ; : make-specializer ( specs -- quot ) dup length @@ -36,13 +31,6 @@ M: object specializer-declaration class ; [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce ] if-empty ; -ERROR: type-mismatch-error word expected-types ; - -: fallback-def ( word -- quot ) - dup stack-effect effect-in-types dup specialized? - [ [ type-mismatch-error ] 2curry ] - [ drop def>> ] if ; - : specializer-cases ( quot specializer -- alist ) dup [ array? ] all? [ 1array ] unless [ [ nip make-specializer ] @@ -50,7 +38,7 @@ ERROR: type-mismatch-error word expected-types ; ] with { } map>assoc ; : specialize-quot ( quot word specializer -- quot' ) - [ drop nip fallback-def ] [ nip specializer-cases ] 3bi alist>quot ; + [ drop nip def>> ] [ nip specializer-cases ] 3bi alist>quot ; ! compiler.tree.propagation.inlining sets this to f SYMBOL: specialize-method? @@ -72,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 ] @@ -80,6 +68,32 @@ 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 ; From aeba33660143d80adee04d66fba50b34b7c98378 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 2 Sep 2009 11:45:30 -0500 Subject: [PATCH 6/9] 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 ; + From e4158d46fb0f2d7974eedb0dbef1e78428786e7d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 2 Sep 2009 12:13:47 -0500 Subject: [PATCH 7/9] coerce and check output types on typed words; set "input-classes" and "default-output-classes" props on typed words --- extra/typed/typed.factor | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/extra/typed/typed.factor b/extra/typed/typed.factor index 624d3e1e6c..f0a7946c79 100644 --- a/extra/typed/typed.factor +++ b/extra/typed/typed.factor @@ -33,7 +33,12 @@ ERROR: output-mismatch-error < type-mismatch-error ; [ output-mismatch-error ] 2curry ; : typed-outputs ( quot word types -- quot' ) - 2drop ; + { + [ 2drop ] + [ 2nip make-coercer ] + [ 2nip make-specializer ] + [ [ drop ] 2dip output-mismatch-quot ] + } 3cleave '[ @ @ @ _ unless ] ; ! defining typed words @@ -45,8 +50,12 @@ PREDICATE: typed < word "typed" word-prop ; [ 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 ; + { + [ [ 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 ; SYNTAX: TYPED: (:) define-typed ; From 2338938abeb3f7a559d8382181c8ff09e130c4bf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 2 Sep 2009 12:21:58 -0500 Subject: [PATCH 8/9] vocab metadata for typed --- extra/typed/authors.txt | 1 + extra/typed/summary.txt | 1 + extra/typed/typed.factor | 1 + 3 files changed, 3 insertions(+) create mode 100644 extra/typed/authors.txt create mode 100644 extra/typed/summary.txt diff --git a/extra/typed/authors.txt b/extra/typed/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/typed/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/typed/summary.txt b/extra/typed/summary.txt new file mode 100644 index 0000000000..43eb90a11d --- /dev/null +++ b/extra/typed/summary.txt @@ -0,0 +1 @@ +Strongly-typed word definitions diff --git a/extra/typed/typed.factor b/extra/typed/typed.factor index f0a7946c79..b7feed874b 100644 --- a/extra/typed/typed.factor +++ b/extra/typed/typed.factor @@ -1,3 +1,4 @@ +! (c)Joe Groff bsd license USING: accessors combinators definitions effects fry hints kernel kernel.private parser sequences words ; IN: typed From 37a13b2c454c37f244aa7301009fad31065e45bd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 2 Sep 2009 18:45:08 -0500 Subject: [PATCH 9/9] for typed words, put the specialized definition in a gensym, and check the input types and declare the output types in the inlined outer word so the checks can be cleared by the compiler when possible --- extra/typed/typed.factor | 46 ++++++++++++++++++++++++++++------------ 1 file changed, 32 insertions(+), 14 deletions(-) diff --git a/extra/typed/typed.factor b/extra/typed/typed.factor index b7feed874b..1cfb3394d4 100644 --- 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-def ( word def effect -- quot ) - [ swap ] dip - [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ] +: 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-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. ;