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
accessors fry ;
IN: memoize
-ERROR: too-many-arguments ;
+<PRIVATE
-M: too-many-arguments summary
- drop "There must be no more than 4 input and 4 output arguments" ;
+! We can't use n*quot, narray and firstn from generalizations because
+! they're macros, and macros use memoize!
+: (n*quot) ( n quot -- quotquot )
+ <repetition> concat >quotation ;
-<PRIVATE
+: [narray] ( length -- quot )
+ [ [ 1 - ] keep '[ _ _ f <array> ] ]
+ [ [ [ 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 ;
: 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 ;
: 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