New primitive to strip compiled quotation definitions

core/bootstrap/primitives.factor

@@ -260,7 +260,7 @@ H{ } clone update-map set
     { "<tuple>" "tuples.private" }
     { "tuple>array" "tuples" }
     { "profiling" "tools.profiler.private" }
-    { "become" "tuples.private" }
+    { "become" "kernel.private" }
     { "(sleep)" "threads.private" }
     { "<float-array>" "float-arrays" }
     { "curry" "kernel" }
@@ -271,6 +271,7 @@ H{ } clone update-map set
     { "innermost-frame-scan" "kernel.private" }
     { "set-innermost-frame-quot" "kernel.private" }
     { "call-clear" "kernel" }
+    { "strip-compiled-quotations" "quotations" }
 }
 dup length [ >r first2 r> make-primitive ] 2each
 

core/memory/memory.factor

@@ -1,7 +1,9 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: memory
-USING: arrays kernel sequences vectors system ;
+USING: arrays kernel sequences vectors system hashtables
+kernel.private sbufs growable assocs namespaces quotations
+math strings combinators ;
 
 : (each-object) ( quot -- )
     next-object dup
@@ -14,3 +16,29 @@ USING: arrays kernel sequences vectors system ;
     pusher >r each-object r> >array ; inline
 
 : save ( -- ) image save-image ;
+
+<PRIVATE
+
+: intern-objects ( predicate -- )
+    instances
+    dup H{ } clone [ [ ] cache ] curry map
+    become ; inline
+
+: prepare-compress-image ( -- seq )
+    [ sbuf? ] instances [ underlying ] map ;
+
+PRIVATE>
+
+: compress-image ( -- )
+    prepare-compress-image "bad-strings" [
+        [
+            {
+                { [ dup quotation? ] [ t ] }
+                { [ dup wrapper? ] [ t ] }
+                { [ dup fixnum? ] [ f ] }
+                { [ dup number? ] [ t ] }
+                { [ dup string? ] [ dup "bad-strings" get memq? not ] }
+                { [ t ] [ f ] }
+            } cond nip
+        ] intern-objects
+    ] with-variable ;