diff --git a/basis/cache/cache-tests.factor b/basis/cache/cache-tests.factor new file mode 100755 index 0000000000..ea1c22b2cf --- /dev/null +++ b/basis/cache/cache-tests.factor @@ -0,0 +1,50 @@ +USING: cache tools.test accessors destructors kernel assocs +namespaces ; +IN: cache.tests + +TUPLE: mock-disposable < disposable n ; + +: ( n -- mock-disposable ) + mock-disposable new-disposable swap >>n ; + +M: mock-disposable dispose* drop ; + +[ ] [ "cache" set ] unit-test + +[ 0 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get 2 >>max-age drop ] unit-test + +[ ] [ 1 dup "a" set 2 "cache" get set-at ] unit-test + +[ 1 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get purge-cache ] unit-test + +[ ] [ 2 3 "cache" get set-at ] unit-test + +[ 2 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get purge-cache ] unit-test + +[ 1 ] [ "cache" get assoc-size ] unit-test + +[ ] [ 3 dup "b" set 4 "cache" get set-at ] unit-test + +[ 2 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get purge-cache ] unit-test + +[ 1 ] [ "cache" get assoc-size ] unit-test + +[ f ] [ 2 "cache" get key? ] unit-test + +[ 3 ] [ 4 "cache" get at n>> ] unit-test + +[ t ] [ "a" get disposed>> ] unit-test + +[ f ] [ "b" get disposed>> ] unit-test + +[ ] [ "cache" get clear-assoc ] unit-test + +[ t ] [ "b" get disposed>> ] unit-test diff --git a/basis/cache/cache.factor b/basis/cache/cache.factor old mode 100644 new mode 100755 index a226500c63..1247774bee --- a/basis/cache/cache.factor +++ b/basis/cache/cache.factor @@ -25,19 +25,21 @@ M: cache-assoc set-at [ ] 2dip assoc>> set-at ; -M: cache-assoc clear-assoc assoc>> clear-assoc ; +M: cache-assoc clear-assoc + [ assoc>> values dispose-each ] + [ assoc>> clear-assoc ] + bi ; M: cache-assoc >alist assoc>> [ value>> ] { } assoc-map-as ; INSTANCE: cache-assoc assoc -M: cache-assoc dispose* - [ values dispose-each ] [ clear-assoc ] bi ; +M: cache-assoc dispose* clear-assoc ; PRIVATE> : purge-cache ( cache -- ) dup max-age>> '[ - [ nip [ 1 + ] change-age age>> _ >= ] assoc-partition - [ values dispose-each ] dip + [ nip [ 1 + ] change-age age>> _ < ] assoc-partition + values dispose-each ] change-assoc drop ;