diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index b7e4bebe15..9dbe72d9cb 100755
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -1,10 +1,22 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel classes classes.builtin combinators accessors
-sequences arrays vectors assocs namespaces words sorting layouts
-math hashtables kernel.private sets math.order ;
+USING: kernel classes combinators accessors sequences arrays
+vectors assocs namespaces words sorting layouts math hashtables
+kernel.private sets math.order ;
IN: classes.algebra
+TUPLE: anonymous-union members ;
+
+C: <anonymous-union> anonymous-union
+
+TUPLE: anonymous-intersection participants ;
+
+C: <anonymous-intersection> anonymous-intersection
+
+TUPLE: anonymous-complement class ;
+
+C: <anonymous-complement> anonymous-complement
+
: 2cache ( key1 key2 assoc quot -- value )
>r >r 2array r> [ first2 ] r> compose cache ; inline
@@ -18,10 +30,19 @@ DEFER: (class-not)
: class-not ( class -- complement )
class-not-cache get [ (class-not) ] cache ;
-DEFER: (classes-intersect?) ( first second -- ? )
+GENERIC: (classes-intersect?) ( first second -- ? )
+
+: normalize-class ( class -- class' )
+ {
+ { [ dup members ] [ members <anonymous-union> ] }
+ { [ dup participants ] [ participants <anonymous-intersection> ] }
+ [ ]
+ } cond ;
: classes-intersect? ( first second -- ? )
- classes-intersect-cache get [ (classes-intersect?) ] 2cache ;
+ classes-intersect-cache get [
+ normalize-class (classes-intersect?)
+ ] 2cache ;
DEFER: (class-and)
@@ -33,18 +54,6 @@ DEFER: (class-or)
: class-or ( first second -- class )
class-or-cache get [ (class-or) ] 2cache ;
-TUPLE: anonymous-union members ;
-
-C: <anonymous-union> anonymous-union
-
-TUPLE: anonymous-intersection participants ;
-
-C: <anonymous-intersection> anonymous-intersection
-
-TUPLE: anonymous-complement class ;
-
-C: <anonymous-complement> anonymous-complement
-
: superclass<= ( first second -- ? )
>r superclass r> class<= ;
@@ -63,13 +72,6 @@ C: <anonymous-complement> anonymous-complement
: anonymous-complement<= ( first second -- ? )
[ class>> ] bi@ swap class<= ;
-: normalize-class ( class -- class' )
- {
- { [ dup members ] [ members <anonymous-union> ] }
- { [ dup participants ] [ participants <anonymous-intersection> ] }
- [ ]
- } cond ;
-
: normalize-complement ( class -- class' )
class>> normalize-class {
{ [ dup anonymous-union? ] [
@@ -116,40 +118,15 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
} cond
] if ;
-: anonymous-union-intersect? ( first second -- ? )
+M: anonymous-union (classes-intersect?)
members>> [ classes-intersect? ] with contains? ;
-: anonymous-intersection-intersect? ( first second -- ? )
+M: anonymous-intersection (classes-intersect?)
participants>> [ classes-intersect? ] with all? ;
-: anonymous-complement-intersect? ( first second -- ? )
+M: anonymous-complement (classes-intersect?)
class>> class<= not ;
-: tuple-class-intersect? ( first second -- ? )
- {
- { [ over tuple eq? ] [ 2drop t ] }
- { [ over builtin-class? ] [ 2drop f ] }
- { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
- [ swap classes-intersect? ]
- } cond ;
-
-: builtin-class-intersect? ( first second -- ? )
- {
- { [ 2dup eq? ] [ 2drop t ] }
- { [ over builtin-class? ] [ 2drop f ] }
- [ swap classes-intersect? ]
- } cond ;
-
-: (classes-intersect?) ( first second -- ? )
- normalize-class {
- { [ dup anonymous-union? ] [ anonymous-union-intersect? ] }
- { [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] }
- { [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] }
- { [ dup tuple-class? ] [ tuple-class-intersect? ] }
- { [ dup builtin-class? ] [ builtin-class-intersect? ] }
- { [ dup superclass ] [ superclass classes-intersect? ] }
- } cond ;
-
: anonymous-union-and ( first second -- class )
members>> [ class-and ] with map <anonymous-union> ;
@@ -225,26 +202,13 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
tuck [ class<= ] with all? [ peek ] [ drop f ] if
] if ;
-DEFER: (flatten-class)
-DEFER: flatten-builtin-class
+GENERIC: (flatten-class) ( class -- )
-: flatten-intersection-class ( class -- )
- participants [ flatten-builtin-class ] map
- dup empty? [
- drop builtins get [ (flatten-class) ] each
- ] [
- unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
- ] if ;
+M: anonymous-union (flatten-class)
+ members>> [ (flatten-class) ] each ;
-: (flatten-class) ( class -- )
- {
- { [ dup tuple-class? ] [ dup set ] }
- { [ dup builtin-class? ] [ dup set ] }
- { [ dup members ] [ members [ (flatten-class) ] each ] }
- { [ dup participants ] [ flatten-intersection-class ] }
- { [ dup superclass ] [ superclass (flatten-class) ] }
- [ drop ]
- } cond ;
+M: word (flatten-class)
+ normalize-class (flatten-class) ;
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
@@ -258,7 +222,7 @@ DEFER: flatten-builtin-class
flatten-builtin-class keys
[ "type" word-prop ] map natural-sort ;
-: class-tags ( class -- tag/f )
+: class-tags ( class -- seq )
class-types [
dup num-tags get >=
[ drop \ hi-tag tag-number ] when
diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor
index acbbc5e841..f349d0a126 100644
--- a/core/classes/builtin/builtin.factor
+++ b/core/classes/builtin/builtin.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes words kernel kernel.private namespaces
-sequences math math.private ;
+USING: accessors classes classes.algebra words kernel
+kernel.private namespaces sequences math math.private
+combinators assocs ;
IN: classes.builtin
SYMBOL: builtins
@@ -31,3 +32,24 @@ M: builtin-class rank-class drop 0 ;
M: builtin-class instance?
class>type builtin-instance? ;
+
+M: builtin-class (flatten-class) dup set ;
+
+M: builtin-class (classes-intersect?)
+ {
+ { [ 2dup eq? ] [ 2drop t ] }
+ { [ over builtin-class? ] [ 2drop f ] }
+ [ swap classes-intersect? ]
+ } cond ;
+
+M: anonymous-intersection (flatten-class)
+ participants>>
+ participants [ flatten-builtin-class ] map
+ dup empty? [
+ drop builtins get sift [ (flatten-class) ] each
+ ] [
+ unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
+ ] if ;
+
+M: anonymous-complement (flatten-class)
+ drop builtins get sift [ (flatten-class) ] each ;
diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
index 5f02212bad..fcad00bb18 100755
--- a/core/classes/classes-docs.factor
+++ b/core/classes/classes-docs.factor
@@ -65,10 +65,6 @@ HELP: classes
{ $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ;
-HELP: tuple-class
-{ $class-description "The class of tuple class words." }
-{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
-
HELP: update-map
{ $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 56c3b0a0ab..34f2fcf196 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -32,9 +32,6 @@ SYMBOL: implementors-map
PREDICATE: class < word
"class" word-prop ;
-PREDICATE: tuple-class < class
- "metaclass" word-prop tuple-class eq? ;
-
: classes ( -- seq ) implementors-map get keys ;
: predicate-word ( word -- predicate )
diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor
index 0eae1b62d3..5df580d82f 100644
--- a/core/classes/intersection/intersection.factor
+++ b/core/classes/intersection/intersection.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
-namespaces arrays math quotations ;
+classes.algebra classes.builtin namespaces arrays math quotations ;
IN: classes.intersection
PREDICATE: intersection-class < class
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index 3067b7d9dd..e6d6b5a0d4 100755
--- a/core/classes/predicate/predicate.factor
+++ b/core/classes/predicate/predicate.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes kernel namespaces words sequences quotations
-arrays kernel.private assocs combinators ;
+USING: classes classes.algebra kernel namespaces words sequences
+quotations arrays kernel.private assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class
@@ -51,3 +51,9 @@ M: predicate-class rank-class drop 1 ;
M: predicate-class instance?
2dup superclass instance?
[ predicate-instance? ] [ 2drop f ] if ;
+
+M: predicate-class (flatten-class)
+ superclass (flatten-class) ;
+
+M: predicate-class (classes-intersect?)
+ superclass classes-intersect? ;
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 8c2525731e..fd8b450eed 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -332,6 +332,10 @@ $nl
ABOUT: "tuples"
+HELP: tuple-class
+{ $class-description "The class of tuple class words." }
+{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
+
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 83d85b68d8..66a75387f1 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -3,10 +3,13 @@
USING: arrays definitions hashtables kernel kernel.private math
namespaces sequences sequences.private strings vectors words
quotations memory combinators generic classes classes.algebra
-classes.private slots.deprecated slots.private slots
-compiler.units math.private accessors assocs effects ;
+classes.builtin classes.private slots.deprecated slots.private
+slots compiler.units math.private accessors assocs effects ;
IN: classes.tuple
+PREDICATE: tuple-class < class
+ "metaclass" word-prop tuple-class eq? ;
+
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: not-a-tuple object ;
@@ -135,7 +138,8 @@ ERROR: bad-superclass class ;
dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype )
- [ all-slots [ initial>> ] map ] keep slots>tuple ;
+ [ all-slots [ initial>> ] map ] keep
+ over [ ] contains? [ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;
@@ -289,6 +293,16 @@ M: tuple-class rank-class drop 0 ;
M: tuple-class instance?
dup tuple-layout echelon>> tuple-instance? ;
+M: tuple-class (flatten-class) dup set ;
+
+M: tuple-class (classes-intersect?)
+ {
+ { [ over tuple eq? ] [ 2drop t ] }
+ { [ over builtin-class? ] [ 2drop f ] }
+ { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
+ [ swap classes-intersect? ]
+ } cond ;
+
M: tuple clone
(clone) dup delegate clone over set-delegate ;
@@ -304,7 +318,8 @@ M: tuple hashcode*
] recursive-hashcode ;
M: tuple-class new
- "prototype" word-prop (clone) ;
+ dup "prototype" word-prop
+ [ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa
[ "boa-check" word-prop call ]
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index 6ae4e1bdc3..e3deb25e7a 100755
--- a/core/classes/union/union.factor
+++ b/core/classes/union/union.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
-namespaces arrays math quotations ;
+classes.algebra namespaces arrays math quotations ;
IN: classes.union
PREDICATE: union-class < class
diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor
index 61e2b82f4f..550bab72f4 100755
--- a/core/generator/registers/registers.factor
+++ b/core/generator/registers/registers.factor
@@ -563,7 +563,7 @@ M: loc lazy-store
] if ;
: class-tag ( class -- tag/f )
- class-tags dup length 1 = [ first ] [ drop f ] if ;
+ dup [ class-tags dup length 1 = [ first ] [ drop f ] if ] when ;
: class-matches? ( actual expected -- ? )
{
diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor
index 9cee497d6d..54fc3c8ca3 100644
--- a/core/generic/standard/standard-tests.factor
+++ b/core/generic/standard/standard-tests.factor
@@ -309,3 +309,11 @@ M: xref-tuple-2 xref-test (xref-test) ;
\ xref-test
\ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
] unit-test
+
+[ t ] [
+ { } \ nth effective-method nip \ sequence \ nth method eq?
+] unit-test
+
+[ t ] [
+ \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
+] unit-test
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 89c2a2a396..f8b3c00c31 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -105,7 +105,9 @@ ERROR: no-next-method class generic ;
] [ ] make ;
: single-effective-method ( obj word -- method )
- [ order [ instance? ] with find-last nip ] keep method ;
+ [ [ order [ instance? ] with find-last nip ] keep method ]
+ [ "default-method" word-prop ]
+ bi or ;
TUPLE: standard-combination # ;
diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor
index b11d656b03..39a501c7f8 100755
--- a/core/slots/slots-docs.factor
+++ b/core/slots/slots-docs.factor
@@ -2,7 +2,7 @@ USING: help.markup help.syntax generic kernel.private parser
words kernel quotations namespaces sequences words arrays
effects generic.standard classes.builtin
slots.private classes strings math assocs byte-arrays alien
-math ;
+math classes.tuple ;
IN: slots
ARTICLE: "accessors" "Slot accessors"
diff --git a/extra/benchmark/dispatch1/dispatch1.factor b/extra/benchmark/dispatch1/dispatch1.factor
index 1c8701f73f..430162892d 100644
--- a/extra/benchmark/dispatch1/dispatch1.factor
+++ b/extra/benchmark/dispatch1/dispatch1.factor
@@ -1,4 +1,4 @@
-USING: classes kernel sequences vocabs math ;
+USING: classes classes.tuple kernel sequences vocabs math ;
IN: benchmark.dispatch1
GENERIC: g ( obj -- obj )
diff --git a/extra/benchmark/dispatch5/dispatch5.factor b/extra/benchmark/dispatch5/dispatch5.factor
index 727d288765..8b6bd76f3a 100755
--- a/extra/benchmark/dispatch5/dispatch5.factor
+++ b/extra/benchmark/dispatch5/dispatch5.factor
@@ -1,4 +1,4 @@
-USING: classes kernel sequences vocabs math ;
+USING: classes classes.tuple kernel sequences vocabs math ;
IN: benchmark.dispatch5
MIXIN: g
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index 915ad0c648..6cea58058e 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors parser generic kernel classes words slots assocs
-sequences arrays vectors definitions prettyprint
-math hashtables sets macros namespaces ;
+USING: accessors parser generic kernel classes classes.tuple
+words slots assocs sequences arrays vectors definitions
+prettyprint math hashtables sets macros namespaces ;
IN: delegate
: protocol-words ( protocol -- words )
diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor
index 2128142615..7f130fc7e3 100755
--- a/extra/io/unix/backend/backend.factor
+++ b/extra/io/unix/backend/backend.factor
@@ -168,7 +168,7 @@ M: stdin dispose
: wait-for-stdin ( stdin -- n )
[ control>> CHAR: X over io:stream-write1 io:stream-flush ]
- [ size>> "uint" heap-size swap io:stream-read *uint ]
+ [ size>> "size_t" heap-size swap io:stream-read *uint ]
bi ;
:: refill-stdin ( buffer stdin size -- )
diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor
index 86691e89a0..ebcc924ce2 100755
--- a/extra/tools/deploy/deploy-tests.factor
+++ b/extra/tools/deploy/deploy-tests.factor
@@ -12,42 +12,36 @@ namespaces continuations layouts accessors ;
] with-directory ;
: small-enough? ( n -- ? )
- >r "test.image" temp-file file-info size>> r> <= ;
+ >r "test.image" temp-file file-info size>> r> cell 4 / * <= ;
[ ] [ "hello-world" shake-and-bake ] unit-test
-[ t ] [
- cell 8 = 8 5 ? 100000 * small-enough?
-] unit-test
+[ t ] [ 500000 small-enough? ] unit-test
[ ] [ "sudoku" shake-and-bake ] unit-test
-[ t ] [
- cell 8 = 20 10 ? 100000 * small-enough?
-] unit-test
+[ t ] [ 800000 small-enough? ] unit-test
[ ] [ "hello-ui" shake-and-bake ] unit-test
+[ t ] [ 1300000 small-enough? ] unit-test
+
[ "staging.math-compiler-ui-strip.image" ] [
"hello-ui" deploy-config
[ bootstrap-profile staging-image-name file-name ] bind
] unit-test
-[ t ] [
- cell 8 = 35 17 ? 100000 * small-enough?
-] unit-test
-
[ ] [ "maze" shake-and-bake ] unit-test
-[ t ] [
- cell 8 = 30 15 ? 100000 * small-enough?
-] unit-test
+[ t ] [ 1200000 small-enough? ] unit-test
+
+[ ] [ "tetris" shake-and-bake ] unit-test
+
+[ t ] [ 1200000 small-enough? ] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test
-[ t ] [
- cell 8 = 50 30 ? 100000 * small-enough?
-] unit-test
+[ t ] [ 2500000 small-enough? ] unit-test
{
"tools.deploy.test.1"
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index 05bf3c9642..2dd334d024 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -4,7 +4,7 @@ USING: accessors qualified io.streams.c init fry namespaces
assocs kernel parser lexer strings.parser tools.deploy.config
vocabs sequences words words.private memory kernel.private
continuations io prettyprint vocabs.loader debugger system
-strings sets ;
+strings sets vectors quotations byte-arrays ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
@@ -79,8 +79,8 @@ IN: tools.deploy.shaker
[
[
props>> swap
- '[ drop , member? not ] assoc-filter
- sift-assoc f assoc-like
+ '[ drop , member? not ] assoc-filter sift-assoc
+ dup assoc-empty? [ drop f ] [ >alist >vector ] if
] keep (>>props)
] with each ;
@@ -93,7 +93,10 @@ IN: tools.deploy.shaker
"compiled-uses"
"constraints"
"declared-effect"
+ "default"
+ "default-method"
"default-output-classes"
+ "derived-from"
"identities"
"if-intrinsics"
"infer"
@@ -103,15 +106,18 @@ IN: tools.deploy.shaker
"loc"
"members"
"methods"
+ "method-class"
+ "method-generic"
"combination"
"cannot-infer"
- "default-method"
+ "no-compile"
"optimizer-hooks"
"output-classes"
"participants"
"predicate"
"predicate-definition"
"predicating"
+ "tuple-dispatch-generic"
"slots"
"slot-names"
"specializer"
@@ -127,6 +133,8 @@ IN: tools.deploy.shaker
strip-prettyprint? [
{
+ "break-before"
+ "break-after"
"delimiter"
"flushable"
"foldable"
@@ -265,13 +273,27 @@ IN: tools.deploy.shaker
21 setenv
] [ drop ] if ;
+: compress ( pred string -- )
+ "Compressing " prepend show
+ instances
+ dup H{ } clone [ [ ] cache ] curry map
+ become ; inline
+
+: compress-byte-arrays ( -- )
+ [ byte-array? ] "byte arrays" compress ;
+
+: compress-quotations ( -- )
+ [ quotation? ] "quotations" compress ;
+
+: compress-strings ( -- )
+ [ string? ] "strings" compress ;
+
: finish-deploy ( final-image -- )
"Finishing up" show
>r { } set-datastack r>
{ } set-retainstack
V{ } set-namestack
V{ } set-catchstack
-
"Saving final image" show
[ save-image-and-exit ] call-clear ;
@@ -295,7 +317,10 @@ SYMBOL: deploy-vocab
deploy-vocab get vocab-main set-boot-quot*
stripped-word-props >r
stripped-globals strip-globals
- r> strip-words ;
+ r> strip-words
+ compress-byte-arrays
+ compress-quotations
+ compress-strings ;
: (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave
diff --git a/extra/tools/walker/walker-tests.factor b/extra/tools/walker/walker-tests.factor
index 2d4a6c3396..7f154a4dbf 100755
--- a/extra/tools/walker/walker-tests.factor
+++ b/extra/tools/walker/walker-tests.factor
@@ -1,6 +1,7 @@
USING: tools.walker io io.streams.string kernel math
math.private namespaces prettyprint sequences tools.test
-continuations math.parser threads arrays tools.walker.debug ;
+continuations math.parser threads arrays tools.walker.debug
+generic.standard ;
IN: tools.walker.tests
[ { } ] [
@@ -97,6 +98,9 @@ IN: tools.walker.tests
[ { 6 } ]
[ [ [ 3 throw ] [ 2 * ] recover ] test-walker ] unit-test
+[ { T{ no-method f + nth } } ]
+[ [ [ 0 \ + nth ] [ ] recover ] test-walker ] unit-test
+
[ { } ] [
[ "a" "b" set "c" "d" set [ ] test-walker ] with-scope
] unit-test
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index f3cfb88cef..f9055fb6cf 100755
--- a/extra/tools/walker/walker.factor
+++ b/extra/tools/walker/walker.factor
@@ -83,6 +83,9 @@ M: object add-breakpoint ;
: (step-into-continuation) ( -- )
continuation callstack >>call break ;
+: (step-into-call-next-method) ( class generic -- )
+ next-method-quot (step-into-quot) ;
+
! Messages sent to walker thread
SYMBOL: step
SYMBOL: step-out
@@ -132,6 +135,7 @@ SYMBOL: +stopped+
{ if [ (step-into-if) ] }
{ dispatch [ (step-into-dispatch) ] }
{ continuation [ (step-into-continuation) ] }
+ { (call-next-method) [ (step-into-call-next-method) ] }
} [ "step-into" set-word-prop ] assoc-each
{
diff --git a/vm/code_gc.c b/vm/code_gc.c
index e0abdc5a61..03661999c5 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -308,6 +308,8 @@ DEFINE_PRIMITIVE(code_room)
/* Dump all code blocks for debugging */
void dump_heap(F_HEAP *heap)
{
+ CELL size = 0;
+
F_BLOCK *scan = first_block(heap);
while(scan)
@@ -319,9 +321,11 @@ void dump_heap(F_HEAP *heap)
status = "free";
break;
case B_ALLOCATED:
+ size += object_size(block_to_compiled(scan)->relocation);
status = "allocated";
break;
case B_MARKED:
+ size += object_size(block_to_compiled(scan)->relocation);
status = "marked";
break;
default:
@@ -333,6 +337,8 @@ void dump_heap(F_HEAP *heap)
scan = next_block(heap,scan);
}
+
+ printf("%ld bytes of relocation data\n",size);
}
/* Compute where each block is going to go, after compaction */