Clean up memoize code to not use gensym anymore

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
 <PRIVATE
 
 : real-macro-effect ( word -- effect' )
-    "declared-effect" word-prop in>> 1 <effect> ;
+    stack-effect in>> 1 <effect> ;
 
 PRIVATE>
 

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

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 -- )
+<PRIVATE
-    [ #in ] [ #out ] bi [ 4 > ] either? [ too-many-arguments ] when ;
+
+: packer ( seq -- quot )
+    length { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ;
+
+: unpacker ( seq -- quot )
+    length { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ;
+
+: 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 ;
+
+PRIVATE>
 
 : define-memoized ( word quot -- )
-    over check-memoized
+    [ H{ } clone ] dip
-    2dup "memo-quot" set-word-prop
+    [ pick stack-effect make-memoizer define ]
-    over H{ } clone "memoize" set-word-prop
+    [ nip "memo-quot" set-word-prop ]
-    over make-memoizer define ;
+    [ 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
+    [ H{ } clone ] 2dip make-memoizer ;
-    dup rot define-memoized 1quotation ;
 
 : 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 ;

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