diff --git a/basis/memoize/memoize-docs.factor b/basis/memoize/memoize-docs.factor index 674fa005c2..58ba60af7c 100644 --- a/basis/memoize/memoize-docs.factor +++ b/basis/memoize/memoize-docs.factor @@ -19,12 +19,10 @@ ABOUT: "memoize" HELP: define-memoized { $values { "word" word } { "quot" quotation } { "effect" effect } } -{ $description "defines the given word at runtime as one which memoizes its output given a particular input" } -{ $notes "A maximum of four input and four output arguments can be used" } -{ $see-also POSTPONE: MEMO: } ; +{ $description "Defines the given word at run time as one which memoizes its outputs given a particular input." } ; HELP: MEMO: { $syntax "MEMO: word ( stack -- effect ) definition ;" } -{ $description "defines the given word at parsetime as one which memoizes its output given a particular input. The stack effect is mandatory." } -{ $notes "A maximum of four input and four output arguments can be used" } -{ $see-also define-memoized } ; +{ $description "Defines the given word at parse time as one which memoizes its output given a particular input. The stack effect is mandatory." } ; + +{ define-memoized POSTPONE: MEMO: } related-words diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 771c11c130..11dfd705c2 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -7,9 +7,18 @@ IN: memoize.tests MEMO: fib ( m -- n ) dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; +MEMO: x ( a b c d e -- f g h i j ) + [ 1 + ] 4 ndip ; + [ 89 ] [ 10 fib ] unit-test -[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1 + ] 4 ndip ;" eval( -- ) ] must-fail +[ + 1 0 0 0 0 + 1 0 0 0 0 +] [ + 0 0 0 0 0 x + 0 0 0 0 0 x +] unit-test MEMO: see-test ( a -- b ) reverse ; diff --git a/basis/memoize/memoize.factor b/basis/memoize/memoize.factor index 74ca07cda3..21291318b1 100644 --- a/basis/memoize/memoize.factor +++ b/basis/memoize/memoize.factor @@ -5,18 +5,32 @@ parser math assocs effects definitions quotations summary accessors fry ; IN: memoize -ERROR: too-many-arguments ; - -M: too-many-arguments summary - drop "There must be no more than 4 input and 4 output arguments" ; - concat >quotation ; + +: [narray] ( length -- quot ) + [ [ 1 - ] keep '[ _ _ f ] ] + [ [ [ set-nth ] 2keep [ 1 - ] dip ] (n*quot) ] bi + [ nip ] 3append ; + +: [firstn] ( length -- quot ) + [ 0 swap ] swap + [ [ nth ] 2keep [ 1 + ] dip ] (n*quot) + [ 2drop ] 3append ; + : packer ( seq -- quot ) - length { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ; + length dup 4 <= + [ { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ] + [ [narray] ] if ; : unpacker ( seq -- quot ) - length { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ; + length dup 4 <= + [ { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ] + [ [firstn] ] if ; : pack/unpack ( quot effect -- newquot ) [ in>> packer ] [ out>> unpacker ] bi surround ; @@ -24,11 +38,7 @@ M: too-many-arguments summary : 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 ; @@ -62,4 +72,4 @@ M: memoized reset-word : invalidate-memoized ( inputs... word -- ) [ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ; -\ invalidate-memoized t "no-compile" set-word-prop \ No newline at end of file +\ invalidate-memoized t "no-compile" set-word-prop