diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 4fba7efba3..21a91e567d 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser kernel sequences words effects combinators assocs definitions quotations namespaces memoize accessors ; @@ -7,7 +7,7 @@ IN: macros > 1 ; + stack-effect in>> 1 ; PRIVATE> diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 7ee56866ce..03549d9b80 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel memoize tools.test parser generalizations prettyprint io.streams.string sequences eval ; @@ -17,6 +17,10 @@ MEMO: see-test ( a -- b ) reverse ; [ [ \ see-test see ] with-string-writer ] unit-test -[ ] [ "IN: memoize.tests : fib ;" eval ] unit-test +[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval ] unit-test [ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test + +[ sq ] (( a -- b )) memoize-quot "q" set + +[ 9 ] [ 3 "q" get call ] unit-test diff --git a/basis/memoize/memoize.factor b/basis/memoize/memoize.factor index 7b8c30c534..3bc573dff5 100644 --- a/basis/memoize/memoize.factor +++ b/basis/memoize/memoize.factor @@ -1,47 +1,45 @@ -! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel hashtables sequences arrays words namespaces make parser math assocs effects definitions quotations summary -accessors ; +accessors fry ; IN: memoize -: packer ( n -- quot ) - { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ; - -: unpacker ( n -- quot ) - { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ; - -: #in ( word -- n ) - stack-effect in>> length ; - -: #out ( word -- n ) - stack-effect out>> length ; - -: pack/unpack ( quot word -- newquot ) - [ dup #in unpacker % swap % #out packer % ] [ ] make ; - -: make-memoizer ( quot word -- quot ) - [ - [ #in packer % ] keep - [ "memoize" word-prop , ] keep - [ pack/unpack , ] keep - \ cache , - #out unpacker % - ] [ ] make ; - ERROR: too-many-arguments ; M: too-many-arguments summary drop "There must be no more than 4 input and 4 output arguments" ; -: check-memoized ( word -- ) - [ #in ] [ #out ] bi [ 4 > ] either? [ too-many-arguments ] when ; +> packer ] [ out>> unpacker ] bi surround ; + +: unpack/pack ( quot effect -- newquot ) + [ in>> unpacker ] [ out>> packer ] bi surround ; + +: check-memoized ( effect -- ) + [ in>> ] [ out>> ] bi [ length 4 > ] either? [ too-many-arguments ] when ; + +: make-memoizer ( table quot effect -- quot ) + [ check-memoized ] keep + [ unpack/pack '[ _ _ cache ] ] keep + pack/unpack ; + +PRIVATE> : define-memoized ( word quot -- ) - over check-memoized - 2dup "memo-quot" set-word-prop - over H{ } clone "memoize" set-word-prop - over make-memoizer define ; + [ H{ } clone ] dip + [ pick stack-effect make-memoizer define ] + [ nip "memo-quot" set-word-prop ] + [ drop "memoize" set-word-prop ] + 3tri ; : MEMO: (:) define-memoized ; parsing @@ -57,11 +55,10 @@ M: memoized reset-word bi ; : memoize-quot ( quot effect -- memo-quot ) - gensym swap dupd "declared-effect" set-word-prop - dup rot define-memoized 1quotation ; + [ H{ } clone ] 2dip make-memoizer ; : reset-memoized ( word -- ) "memoize" word-prop clear-assoc ; : invalidate-memoized ( inputs... word -- ) - [ #in packer call ] [ "memoize" word-prop delete-at ] bi ; + [ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ; diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index e61021e633..5095f9e93e 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -190,7 +190,7 @@ IN: tools.deploy.shaker "Stripping default methods" show [ [ generic? ] instances - [ "No method" throw ] (( -- * )) define-temp + [ "No method" throw ] define-temp dup t "default" set-word-prop '[ [ _ "default-method" set-word-prop ] [ make-generic ] bi