shatter the four-argument barrier in memoize

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" }
+{ $description "Defines the given word at run time as one which memoizes its outputs given a particular input." } ;
-{ $notes "A maximum of four input and four output arguments can be used" }
-{ $see-also POSTPONE: MEMO: } ;
 
 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." }
+{ $description "Defines the given word at parse time 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 } ;
+{ define-memoized POSTPONE: MEMO: } related-words

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 ;
 

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" ;
-
 <PRIVATE
 
+! 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 ;
+
+: [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 ;
@@ -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
+\ invalidate-memoized t "no-compile" set-word-prop