Merge branch 'master' of git://factorcode.org/git/factor
commit
7ea5c76563
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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." } ;
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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? ;
|
||||
|
|
|
@ -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." }
|
||||
|
|
|
@ -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 ]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 -- ? )
|
||||
{
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 # ;
|
||||
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: classes kernel sequences vocabs math ;
|
||||
USING: classes classes.tuple kernel sequences vocabs math ;
|
||||
IN: benchmark.dispatch5
|
||||
|
||||
MIXIN: g
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
{
|
||||
|
|
|
@ -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 */
|
||||
|
|
Loading…
Reference in New Issue