steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

New primitive to strip compiled quotation definitions

release
Slava Pestov 2007-10-09 02:08:40 -04:00
parent 5c58a50ac8
commit 2c3aec2260
2 changed files with 31 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/bootstrap/primitives.factor
View File

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

30
core/memory/memory.factor
View File

@ -1,7 +1,9 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: memory 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 -- ) : (each-object) ( quot -- )
next-object dup next-object dup
@ -14,3 +16,29 @@ USING: arrays kernel sequences vectors system ;
pusher >r each-object r> >array ; inline pusher >r each-object r> >array ; inline
: save ( -- ) image save-image ; : 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 ;