: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
+: build-generics ( -- )
+ [
+ all-words
+ [ generic? ] filter
+ [ make-generic ] each
+ ] with-compilation-unit ;
+
: build-image ( -- image )
800000 <vector> image set
20000 <hashtable> objects set
emit-image-header t, 0, 1, -1,
"Building generic words..." print flush
- remake-generics
+ build-generics
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test combinators.smart math kernel accessors ;
+USING: accessors arrays combinators.smart kernel math
+tools.test ;
IN: combinators.smart.tests
: test-bi ( -- 9 11 )
{ 2 0 } [ [ + ] nullary ] must-infer-as
{ 2 2 } [ [ [ + ] nullary ] preserving ] must-infer-as
+
+: smart-if-test ( a b -- b )
+ [ < ] [ swap - ] [ - ] smart-if ;
+
+[ 7 ] [ 10 3 smart-if-test ] unit-test
+[ 16 ] [ 25 41 smart-if-test ] unit-test
+
+[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 3 smart-apply ] unit-test
+[ { 1 2 3 } { 4 5 6 } ] [ 1 2 3 4 5 6 [ 3array ] 2 smart-apply ] unit-test
dup outputs '[ @ _ ndrop ] ;
MACRO: smart-if ( pred true false -- )
- '[ _ preserving _ _ if ] ; inline
+ '[ _ preserving _ _ if ] ;
+
+MACRO: smart-apply ( quot n -- )
+ [ dup inputs ] dip '[ _ _ mnapply ] ;
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
generic.single combinators deques search-deques macros
-source-files.errors combinators.short-circuit
+source-files.errors combinators.short-circuit classes.algebra
stack-checker stack-checker.dependencies stack-checker.inlining
stack-checker.errors
-compiler.errors compiler.units compiler.utilities
+compiler.errors compiler.units compiler.utilities compiler.crossref
compiler.tree.builder
compiler.tree.optimizer
-compiler.crossref
-
compiler.cfg
compiler.cfg.builder
compiler.cfg.optimizer
: recompile-callers? ( word -- ? )
changed-effects get key? ;
-: recompile-callers ( words -- )
- #! If a word's stack effect changed, recompile all words that
- #! have compiled calls to it.
+: recompile-callers ( word -- )
+ #! If a word's stack effect changed, recompile all words
+ #! that have compiled calls to it.
dup recompile-callers?
- [ compiled-usage keys [ queue-compile ] each ] [ drop ] if ;
+ [ effect-dependencies-of keys [ queue-compile ] each ] [ drop ] if ;
: compiler-message ( string -- )
"trace-compilation" get [ global [ print flush ] bind ] [ drop ] if ;
: start ( word -- )
dup name>> compiler-message
- H{ } clone dependencies set
- H{ } clone generic-dependencies set
+ init-dependencies
clear-compiler-error ;
GENERIC: no-compile? ( word -- ? )
[ compiled-unxref ]
[
dup crossref? [
- dependencies get
- generic-dependencies get
- compiled-xref
+ [ dependencies get generic-dependencies get compiled-xref ]
+ [ conditional-dependencies get set-dependency-checks ]
+ bi
] [ drop ] if
] tri ;
: deoptimize-with ( word def -- * )
#! If the word failed to infer, compile it with the
- #! non-optimizing compiler.
+ #! non-optimizing compiler.
swap [ finish ] [ compiled get set-at ] bi return ;
: not-compiled-def ( word error -- def )
SINGLETON: optimizing-compiler
+M: optimizing-compiler update-call-sites ( class generic -- words )
+ #! Words containing call sites with inferred type 'class'
+ #! which inlined a method on 'generic'
+ compiled-generic-usage swap '[
+ nip dup classoid?
+ [ _ classes-intersect? ] [ drop f ] if
+ ] assoc-filter keys ;
+
M: optimizing-compiler recompile ( words -- alist )
[
<hashed-dlist> compile-queue set
M: optimizing-compiler to-recompile ( -- words )
changed-definitions get compiled-usages
- changed-generics get compiled-generic-usages
+ maybe-changed get outdated-conditional-usages
append assoc-combine keys ;
M: optimizing-compiler process-forgotten-words
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs classes.algebra compiler.units definitions graphs
-grouping kernel namespaces sequences words
-stack-checker.dependencies ;
+USING: arrays assocs classes.algebra compiler.units definitions
+graphs grouping kernel namespaces sequences words fry
+stack-checker.dependencies combinators ;
IN: compiler.crossref
SYMBOL: compiled-crossref
compiled-generic-crossref [ H{ } clone ] initialize
-: compiled-usage ( word -- assoc )
+: effect-dependencies-of ( word -- assoc )
compiled-crossref get at ;
-: (compiled-usages) ( word -- assoc )
- #! If the word is not flushable anymore, we have to recompile
- #! all words which flushable away a call (presumably when the
- #! word was still flushable). If the word is flushable, we
- #! don't have to recompile words that folded this away.
- [ compiled-usage ]
- [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
- [ dependency>= nip ] curry assoc-filter ;
+: definition-dependencies-of ( word -- assoc )
+ effect-dependencies-of [ nip definition-dependency dependency>= ] assoc-filter ;
-: compiled-usages ( seq -- assocs )
+: conditional-dependencies-of ( word -- assoc )
+ effect-dependencies-of [ nip conditional-dependency dependency>= ] assoc-filter ;
+
+: compiled-usages ( assoc -- assocs )
[ drop word? ] assoc-filter
- [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
+ [ [ drop definition-dependencies-of ] { } assoc>map ] keep suffix ;
+
+: dependencies-satisfied? ( word cache -- ? )
+ [ "dependency-checks" word-prop ] dip
+ '[ _ [ satisfied? ] cache ] all? ;
+
+: outdated-conditional-usages ( assoc -- assocs )
+ H{ } clone '[
+ drop
+ conditional-dependencies-of
+ [ drop _ dependencies-satisfied? not ] assoc-filter
+ ] { } assoc>map ;
: compiled-generic-usage ( word -- assoc )
compiled-generic-crossref get at ;
-: (compiled-generic-usages) ( generic class -- assoc )
- [ compiled-generic-usage ] dip
- [
- 2dup [ valid-class? ] both?
- [ classes-intersect? ] [ 2drop f ] if nip
- ] curry assoc-filter ;
+: only-xref ( assoc -- assoc' )
+ [ drop crossref? ] { } assoc-filter-as ;
+
+: set-compiled-generic-uses ( word alist -- )
+ concat f like "compiled-generic-uses" set-word-prop ;
+
+: split-dependencies ( assoc -- effect-deps cond-deps def-deps )
+ [ nip effect-dependency eq? ] assoc-partition
+ [ nip conditional-dependency eq? ] assoc-partition ;
+
+: (store-dependencies) ( word assoc prop -- )
+ [ keys f like ] dip set-word-prop ;
-: compiled-generic-usages ( assoc -- assocs )
- [ (compiled-generic-usages) ] { } assoc>map ;
+: store-dependencies ( word assoc -- )
+ split-dependencies
+ "effect-dependencies" "conditional-dependencies" "definition-dependencies"
+ [ (store-dependencies) ] tri-curry@ tri-curry* tri ;
-: (compiled-xref) ( word dependencies word-prop variable -- )
- [ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ;
+: (compiled-xref) ( word dependencies generic-dependencies -- )
+ compiled-crossref compiled-generic-crossref
+ [ get add-vertex* ] bi-curry@ bi-curry* bi ;
: compiled-xref ( word dependencies generic-dependencies -- )
- [ [ drop crossref? ] { } assoc-filter-as ] bi@
- [ "compiled-uses" compiled-crossref (compiled-xref) ]
- [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
- bi-curry* bi ;
+ [ only-xref ] bi@
+ [ nip set-compiled-generic-uses ]
+ [ drop store-dependencies ]
+ [ (compiled-xref) ]
+ 3tri ;
-: (compiled-unxref) ( word word-prop variable -- )
- [ [ [ dupd word-prop 2 <groups> ] dip get remove-vertex* ] 2curry ]
- [ drop [ remove-word-prop ] curry ]
- 2bi bi ;
+: set-at-each ( keys assoc value -- )
+ '[ _ [ _ ] 2dip set-at ] each ;
+
+: join-dependencies ( effect-deps cond-deps def-deps -- assoc )
+ H{ } clone [
+ [ effect-dependency set-at-each ]
+ [ conditional-dependency set-at-each ]
+ [ definition-dependency set-at-each ] tri-curry tri*
+ ] keep ;
+
+: load-dependencies ( word -- assoc )
+ [ "effect-dependencies" word-prop ]
+ [ "conditional-dependencies" word-prop ]
+ [ "definition-dependencies" word-prop ] tri
+ join-dependencies ;
+
+: (compiled-unxref) ( word dependencies variable -- )
+ get remove-vertex* ;
+
+: compiled-generic-uses ( word -- alist )
+ "compiled-generic-uses" word-prop 2 <groups> ;
: compiled-unxref ( word -- )
- [ "compiled-uses" compiled-crossref (compiled-unxref) ]
- [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
- bi ;
+ {
+ [ dup load-dependencies compiled-crossref (compiled-unxref) ]
+ [ dup compiled-generic-uses compiled-generic-crossref (compiled-unxref) ]
+ [ "effect-dependencies" remove-word-prop ]
+ [ "conditional-dependencies" remove-word-prop ]
+ [ "definition-dependencies" remove-word-prop ]
+ [ "compiled-generic-uses" remove-word-prop ]
+ } cleave ;
: delete-compiled-xref ( word -- )
[ compiled-unxref ]
[ compiled-crossref get delete-at ]
[ compiled-generic-crossref get delete-at ]
tri ;
+
+: set-dependency-checks ( word deps -- )
+ keys f like "dependency-checks" set-word-prop ;
-USING: eval tools.test compiler.units vocabs words kernel ;
+USING: eval tools.test compiler.units vocabs words kernel
+definitions sequences math classes classes.mixin kernel.private ;
IN: compiler.tests.redefine10
-! Mixin redefinition did not recompile all necessary words.
-
-[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
-
-[ ] [
- "USING: kernel math classes ;
- IN: compiler.tests.redefine10
- MIXIN: my-mixin
- INSTANCE: fixnum my-mixin
- : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;"
- eval( -- )
-] unit-test
-
-[ ] [
- "USE: math
- IN: compiler.tests.redefine10
- INSTANCE: float my-mixin"
- eval( -- )
-] unit-test
-
-[ 2.0 ] [
- 1.0 "my-inline" "compiler.tests.redefine10" lookup execute
-] unit-test
+! Mixin redefinition should update predicate call sites
+
+MIXIN: my-mixin
+INSTANCE: fixnum my-mixin
+: my-inline-1 ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
+: my-inline-2 ( a -- b ) dup my-mixin? [ 1 + ] when ;
+: my-inline-3 ( a -- b ) dup my-mixin? [ float? ] [ drop f ] if ;
+: my-inline-4 ( a -- b ) dup float? [ my-mixin? ] [ drop f ] if ;
+: my-inline-5 ( a -- b ) dup my-mixin? [ fixnum? ] [ drop f ] if ;
+: my-inline-6 ( a -- b ) dup fixnum? [ my-mixin? ] [ drop f ] if ;
+
+GENERIC: fake-float? ( obj -- ? )
+
+M: float fake-float? drop t ;
+M: object fake-float? drop f ;
+
+: my-fake-inline-3 ( a -- b ) dup my-mixin? [ fake-float? ] [ drop f ] if ;
+
+: my-baked-inline-3 ( a -- b ) { my-mixin } declare fake-float? ;
+
+[ f ] [ 5 my-inline-3 ] unit-test
+
+[ f ] [ 5 my-fake-inline-3 ] unit-test
+
+[ f ] [ 5 my-baked-inline-3 ] unit-test
+
+[ f ] [ 5 my-inline-4 ] unit-test
+
+[ t ] [ 5 my-inline-5 ] unit-test
+
+[ t ] [ 5 my-inline-6 ] unit-test
+
+[ ] [ [ float my-mixin add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ 2.0 ] [ 1.0 my-inline-1 ] unit-test
+
+[ 2.0 ] [ 1.0 my-inline-2 ] unit-test
+
+[ t ] [ 1.0 my-inline-3 ] unit-test
+
+[ t ] [ 1.0 my-fake-inline-3 ] unit-test
+
+[ t ] [ 1.0 my-baked-inline-3 ] unit-test
+
+[ t ] [ 1.0 my-inline-4 ] unit-test
+
+[ f ] [ 1.0 my-inline-5 ] unit-test
+
+[ f ] [ 1.0 my-inline-6 ] unit-test
+
+[ ] [ [ fixnum my-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ f ] [ 5 my-inline-3 ] unit-test
+
+[ f ] [ 5 my-fake-inline-3 ] unit-test
+
+[ f ] [ 5 my-baked-inline-3 ] unit-test
+
+[ f ] [ 5 my-inline-4 ] unit-test
+
+[ f ] [ 5 my-inline-5 ] unit-test
+
+[ f ] [ 5 my-inline-6 ] unit-test
+
+[ ] [ [ float my-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ 1.0 ] [ 1.0 my-inline-1 ] unit-test
+
+[ 1.0 ] [ 1.0 my-inline-2 ] unit-test
+
+[ f ] [ 1.0 my-inline-3 ] unit-test
+
+[ f ] [ 1.0 my-fake-inline-3 ] unit-test
+
+[ f ] [ 1.0 my-inline-4 ] unit-test
+
+[ f ] [ 1.0 my-inline-5 ] unit-test
+
+[ f ] [ 1.0 my-inline-6 ] unit-test
--- /dev/null
+USING: kernel tools.test eval words ;
+IN: compiler.tests.redefine18
+
+! Mixin bug found by Doug
+
+GENERIC: g1 ( a -- b )
+GENERIC: g2 ( a -- b )
+
+MIXIN: c
+SINGLETON: a
+INSTANCE: a c
+
+M: c g1 g2 ;
+M: a g2 drop a ;
+
+MIXIN: d
+INSTANCE: d c
+
+M: d g2 drop d ;
+
+[ ] [ "IN: compiler.tests.redefine18 SINGLETON: b INSTANCE: b d" eval( -- ) ] unit-test
+
+[ d ] [ "b" "compiler.tests.redefine18" lookup g1 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine18 FORGET: b" eval( -- ) ] unit-test
--- /dev/null
+USING: kernel classes.mixin compiler.units tools.test generic ;
+IN: compiler.tests.redefine19
+
+GENERIC: g ( a -- b )
+
+MIXIN: m1 M: m1 g drop 1 ;
+MIXIN: m2 M: m2 g drop 2 ;
+
+TUPLE: c ;
+
+INSTANCE: c m2
+
+: foo ( -- b ) c new g ;
+
+[ 2 ] [ foo ] unit-test
+
+[ ] [ [ c m1 add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ { m2 m1 } ] [ \ g order ] unit-test
+
+[ 1 ] [ foo ] unit-test
+
+[ ] [ [ c m1 remove-mixin-instance ] with-compilation-unit ] unit-test
--- /dev/null
+IN: compiler.tests.redefine20
+USING: kernel sequences compiler.units definitions classes.mixin
+tools.test ;
+
+GENERIC: cnm-recompile-test ( a -- b )
+
+M: object cnm-recompile-test drop object ;
+
+M: sequence cnm-recompile-test drop sequence ;
+
+TUPLE: funny ;
+
+M: funny cnm-recompile-test call-next-method ;
+
+[ object ] [ funny new cnm-recompile-test ] unit-test
+
+[ ] [ [ funny sequence add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ sequence ] [ funny new cnm-recompile-test ] unit-test
+
+[ ] [ [ funny sequence remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ object ] [ funny new cnm-recompile-test ] unit-test
[ f ] dip build-tree-with ;
:: build-sub-tree ( in-d out-d word/quot -- nodes/f )
- #! We don't want methods on mixins to have a declaration for that mixin.
- #! This slows down compiler.tree.propagation.inlining since then every
- #! inlined usage of a method has an inline-dependency on the mixin, and
- #! not the more specific type at the call site.
- f specialize-method? [
- [
- in-d word/quot build-tree-with unclip-last in-d>> :> in-d'
- {
- { [ dup not ] [ ] }
- { [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] }
- [ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ]
- } cond
- ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
- ] with-variable ;
\ No newline at end of file
+ [
+ in-d word/quot build-tree-with unclip-last in-d>> :> in-d'
+ {
+ { [ dup not ] [ ] }
+ { [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] }
+ [ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ]
+ } cond
+ ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences combinators fry
classes.algebra namespaces assocs words math math.private
#! do it since the logic is a bit more involved
[ cleanup* ] map-flat ;
+! Constant folding
: cleanup-folding? ( #call -- ? )
node-output-infos
[ f ] [ [ literal?>> ] all? ] if-empty ;
-: cleanup-folding ( #call -- nodes )
+: (cleanup-folding) ( #call -- nodes )
#! Replace a #call having a known result with a #drop of its
#! inputs followed by #push nodes for the outputs.
- [ word>> inlined-dependency depends-on ]
[
[ node-output-infos ] [ out-d>> ] bi
[ [ literal>> ] dip #push ] 2map
]
[ in-d>> #drop ]
- tri prefix ;
+ bi prefix ;
+
+: record-predicate-folding ( #call -- )
+ [ node-input-infos first class>> ]
+ [ word>> "predicating" word-prop ]
+ [ node-output-infos first literal>> ] tri
+ [ depends-on-class<= ] [ depends-on-classes-disjoint ] if ;
+
+: record-folding ( #call -- )
+ dup word>> predicate?
+ [ record-predicate-folding ]
+ [ word>> depends-on-definition ]
+ if ;
+
+: cleanup-folding ( #call -- nodes )
+ [ (cleanup-folding) ] [ record-folding ] bi ;
+! Method inlining
: add-method-dependency ( #call -- )
dup method>> word? [
- [ word>> ] [ class>> ] bi depends-on-generic
+ [ [ class>> ] [ word>> ] bi depends-on-generic ]
+ [ [ class>> ] [ word>> ] [ method>> ] tri depends-on-method ]
+ bi
] [ drop ] if ;
+: record-inlining ( #call -- )
+ dup method>>
+ [ add-method-dependency ]
+ [ word>> depends-on-definition ] if ;
+
: cleanup-inlining ( #call -- nodes )
- [
- dup method>>
- [ add-method-dependency ]
- [ word>> inlined-dependency depends-on ] if
- ] [ body>> cleanup ] bi ;
+ [ record-inlining ] [ body>> cleanup ] bi ;
! Removing overflow checks
: (remove-overflow-check?) ( #call -- ? )
compiler.tree.dead-code.liveness ;
IN: compiler.tree.dead-code.simple
-GENERIC: flushable? ( word -- ? )
-
-M: predicate flushable? drop t ;
-
-M: word flushable? "flushable" word-prop ;
-
-M: method-body flushable? "method-generic" word-prop flushable? ;
-
: flushable-call? ( #call -- ? )
dup word>> dup flushable? [
"input-classes" word-prop dup [
] [ drop f ] if ;
: remove-flushable-call ( #call -- node )
- [ word>> flushed-dependency depends-on ]
+ [ word>> depends-on-flushable ]
[ in-d>> #drop remove-dead-code* ]
bi ;
[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a -- c ) 1 + ;" eval( -- ) ] unit-test
[ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f (( a b -- c )) } = ] must-fail-with
+
+! See if redefining a tuple class bumps effect counter
+TUPLE: my-tuple a b c ;
+
+: my-quot ( -- quot ) [ my-tuple boa ] ;
+
+: my-word ( a b c q -- result ) call( a b c -- result ) ;
+
+[ T{ my-tuple f 1 2 3 } ] [ 1 2 3 my-quot my-word ] unit-test
+
+[ ] [ "IN: compiler.tree.propagation.call-effect.tests TUPLE: my-tuple a b ;" eval( -- ) ] unit-test
+
+[ 1 2 3 my-quot my-word ] [ wrong-values? ] must-fail-with
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators combinators.private effects
fry kernel kernel.private make sequences continuations
-quotations words math stack-checker combinators.short-circuit
-stack-checker.transforms compiler.tree.propagation.info
+quotations words math stack-checker stack-checker.dependencies
+combinators.short-circuit stack-checker.transforms
+compiler.tree.propagation.info
compiler.tree.propagation.inlining compiler.units ;
IN: compiler.tree.propagation.call-effect
! call( and execute( have complex expansions.
-! call( uses the following strategy:
+! If the input quotation is a literal, or built up from curry and
+! compose with terminal quotations literal, it is inlined at the
+! call site.
+
+! For dynamic call sites, call( uses the following strategy:
! - Inline caching. If the quotation is the same as last time, just call it unsafely
! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
! and compare it with declaration. If matches, call it unsafely.
[ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
: safe-infer ( quot -- effect )
- [ infer ] [ 2drop +unknown+ ] recover ;
+ [ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ;
: cached-effect-valid? ( quot -- ? )
cache-counter>> effect-counter eq? ; inline
dup literal>> class?
[
literal>>
- [ inlined-dependency depends-on ]
+ [ depends-on-conditionally ]
[ predicate-output-infos ]
bi
] [ 2drop object-info ] if
#! classes mentioned in the declaration are redefined, since
#! now we're making assumptions but their definitions.
declaration>> [
- [ inlined-dependency depends-on ]
+ [ depends-on-conditionally ]
[ <class-info> swap refine-value-info ]
bi
] assoc-each ;
#! is redefined, since now we're making assumptions but the
#! class definition itself.
[ in-d>> first value-info ]
- [ "predicating" word-prop dup inlined-dependency depends-on ] bi*
- predicate-output-infos 1array ;
+ [ "predicating" word-prop ] bi*
+ [ nip depends-on-conditionally ]
+ [ predicate-output-infos 1array ] 2bi ;
: default-output-value-infos ( #call word -- infos )
"default-output-classes" word-prop
: inline-new ( class -- quot/f )
dup tuple-class? [
- dup inlined-dependency depends-on
- [ all-slots [ initial>> literalize ] map ]
- [ tuple-layout '[ _ <tuple-boa> ] ]
- bi append >quotation
+ dup tuple-layout
+ [ depends-on-tuple-layout ]
+ [ drop all-slots [ initial>> literalize ] [ ] map-as ]
+ [ nip ]
+ 2tri
+ '[ @ _ <tuple-boa> ]
] [ drop f ] if ;
\ new [ inline-new ] 1 define-partial-eval
! calls when a C type is redefined
\ heap-size [
dup word? [
- [ inlined-dependency depends-on ] [ heap-size '[ _ ] ] bi
+ [ depends-on-definition ] [ heap-size '[ _ ] ] bi
] [ drop f ] if
] 1 define-partial-eval
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slots arrays definitions generic hashtables summary io kernel
math namespaces make prettyprint prettyprint.config sequences assocs
M: bad-create summary drop "Bad parameters to create" ;
+M: cannot-be-inline summary drop "This type of word cannot be inlined" ;
+
M: attempt-all-error summary drop "Nothing to attempt" ;
M: already-disposed summary drop "Attempting to operate on disposed object" ;
2 1 0 -1 [ + ] [ - ] [ * ] [ / ] 4 spread-curry 4 spread*\r
] unit-test\r
\r
+[ { 1 2 } { 3 4 } { 5 6 } ]\r
+[ 1 2 3 4 5 6 [ 2array ] 2 3 mnapply ] unit-test\r
+\r
+[ { 1 2 3 } { 4 5 6 } ]\r
+[ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test\r
MACRO: mnswap ( m n -- )
1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
+MACRO: mnapply ( quot m n -- )
+ swap
+ [ swap '[ _ ] replicate ] dip '[ _ _ nspread ] ;
+
MACRO: nweave ( n -- )
[ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ;
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences
sequences.private accessors fry ;
<PRIVATE
-TUPLE: chunking-seq { seq read-only } { n read-only } ;
-
-: check-groups ( n -- n )
- dup 0 <= [ "Invalid group count" throw ] when ; inline
-
-: new-groups ( seq n class -- groups )
- [ check-groups ] dip boa ; inline
+MIXIN: chunking
+INSTANCE: chunking sequence
GENERIC: group@ ( n groups -- from to seq )
-M: chunking-seq set-nth group@ <slice> 0 swap copy ;
-
-M: chunking-seq like drop { } like ; inline
-
-INSTANCE: chunking-seq sequence
+M: chunking set-nth group@ <slice> 0 swap copy ;
+M: chunking like drop { } like ; inline
MIXIN: subseq-chunking
+INSTANCE: subseq-chunking chunking
+INSTANCE: subseq-chunking sequence
M: subseq-chunking nth group@ subseq ; inline
MIXIN: slice-chunking
+INSTANCE: slice-chunking chunking
+INSTANCE: slice-chunking sequence
M: slice-chunking nth group@ <slice> ; inline
-
M: slice-chunking nth-unsafe group@ slice boa ; inline
-TUPLE: abstract-groups < chunking-seq ;
+MIXIN: abstract-groups
+INSTANCE: abstract-groups sequence
M: abstract-groups length
[ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline
M: abstract-groups group@
[ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; inline
-TUPLE: abstract-clumps < chunking-seq ;
+MIXIN: abstract-clumps
+INSTANCE: abstract-clumps sequence
M: abstract-clumps length
[ seq>> length 1 + ] [ n>> ] bi [-] ; inline
M: abstract-clumps group@
[ n>> over + ] [ seq>> ] bi ; inline
+TUPLE: chunking-seq { seq read-only } { n read-only } ;
+
+: check-groups ( n -- n )
+ dup 0 <= [ "Invalid group count" throw ] when ; inline
+
+: new-groups ( seq n class -- groups )
+ [ check-groups ] dip boa ; inline
+
PRIVATE>
-TUPLE: groups < abstract-groups ;
+TUPLE: groups < chunking-seq ;
+INSTANCE: groups subseq-chunking
+INSTANCE: groups abstract-groups
: <groups> ( seq n -- groups )
groups new-groups ; inline
-INSTANCE: groups subseq-chunking
-
-TUPLE: sliced-groups < abstract-groups ;
+TUPLE: sliced-groups < chunking-seq ;
+INSTANCE: sliced-groups slice-chunking
+INSTANCE: sliced-groups abstract-groups
: <sliced-groups> ( seq n -- groups )
sliced-groups new-groups ; inline
-INSTANCE: sliced-groups slice-chunking
-
-TUPLE: clumps < abstract-clumps ;
+TUPLE: clumps < chunking-seq ;
+INSTANCE: clumps subseq-chunking
+INSTANCE: clumps abstract-clumps
: <clumps> ( seq n -- clumps )
clumps new-groups ; inline
-INSTANCE: clumps subseq-chunking
-
-TUPLE: sliced-clumps < abstract-clumps ;
+TUPLE: sliced-clumps < chunking-seq ;
+INSTANCE: sliced-clumps slice-chunking
+INSTANCE: sliced-clumps abstract-clumps
: <sliced-clumps> ( seq n -- clumps )
sliced-clumps new-groups ; inline
-INSTANCE: sliced-clumps slice-chunking
-
: group ( seq n -- array ) <groups> { } like ;
: clump ( seq n -- array ) <clumps> { } like ;
: specialize-quot ( quot specializer -- quot' )
[ drop ] [ specializer-cases ] 2bi alist>quot ;
-! compiler.tree.propagation.inlining sets this to f
-SYMBOL: specialize-method?
-
-t specialize-method? set-global
-
: method-declaration ( method -- quot )
[ "method-generic" word-prop dispatch# object <array> ]
[ "method-class" word-prop ]
bi prefix [ declare ] curry [ ] like ;
: specialize-method ( quot method -- quot' )
- [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
+ [ method-declaration prepend ]
[ "method-generic" word-prop ] bi
specializer [ specialize-quot ] when* ;
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel accessors sequences math arrays ;
+USING: combinators kernel locals accessors sequences math arrays ;
IN: images
SINGLETONS:
<PRIVATE
-: pixel@ ( x y image -- start end bitmap )
- [ dim>> first * + ]
- [ bytes-per-pixel [ * dup ] keep + ]
- [ bitmap>> ] tri ;
+:: pixel@ ( x y w image -- start end bitmap )
+ image dim>> first y * x + :> start
+ start w [ image bytes-per-pixel * ] bi@ :> ( start' w' )
+ start' start' w' + image bitmap>> ; inline
: set-subseq ( new-value from to victim -- )
<slice> 0 swap copy ; inline
PRIVATE>
+: pixel-row-at ( x y w image -- pixels )
+ pixel@ subseq ; inline
+
+: pixel-row-slice-at ( x y w image -- pixels )
+ pixel@ <slice> ; inline
+
+: set-pixel-row-at ( pixel x y w image -- )
+ pixel@ set-subseq ; inline
+
: pixel-at ( x y image -- pixel )
- pixel@ subseq ;
+ [ 1 ] dip pixel-row-at ; inline
+
+: pixel-slice-at ( x y image -- pixels )
+ [ 1 ] dip pixel-row-slice-at ; inline
: set-pixel-at ( pixel x y image -- )
- pixel@ set-subseq ;
+ [ 1 ] dip set-pixel-row-at ; inline
+
: decode-macroblock ( -- blocks )
jpeg> components>>
[
- [ mb-dim first2 * iota ]
+ [ mb-dim first2 * ]
[ [ decode-block ] curry replicate ] bi
] map concat ;
: with-interactive-vocabs ( quot -- )
[
- <manifest> manifest set
"scratchpad" set-current-vocab
interactive-vocabs get only-use-vocabs
call
- ] with-scope ; inline
+ ] with-manifest ; inline
: listener ( -- )
- [ [ { } (listener) ] with-interactive-vocabs ] with-return ;
+ [ [ { } (listener) ] with-return ] with-interactive-vocabs ;
MAIN: listener
[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
+[ ] [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ;" eval( -- ) ] unit-test
+ [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ; inline" eval( -- ) ] must-fail
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel sequences words effects combinators assocs
definitions quotations namespaces memoize accessors
PREDICATE: macro < word "macro" word-prop >boolean ;
+M: macro make-inline cannot-be-inline ;
+
M: macro definer drop \ MACRO: \ ; ;
M: macro definition "macro" word-prop ;
M: macro reset-word
[ call-next-method ] [ f "macro" set-word-prop ] bi ;
-M: macro bump-effect-counter* drop t ;
+M: macro always-bump-effect-counter? drop t ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel layouts math math.order namespaces sequences
sequences.private accessors classes.tuple arrays ;
M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; inline
-! For ranges with many elements, the default element-wise methods
-! sequences define are unsuitable because they're O(n)
-M: range equal? over range? [ tuple= ] [ 2drop f ] if ;
-
+! We want M\ tuple hashcode, not M\ sequence hashcode here!
+! sequences hashcode is O(n) in number of elements
M: range hashcode* tuple-hashcode ;
INSTANCE: range immutable-sequence
USING: accessors alien.c-types alien.data byte-arrays
combinators.short-circuit continuations destructors init kernel
locals namespaces random windows.advapi32 windows.errors
-windows.kernel32 windows.types math.bitwise ;
+windows.kernel32 windows.types math.bitwise sequences fry
+literals ;
IN: random.windows
TUPLE: windows-rng provider type ;
[ CryptGenRandom win32-error=0/f ] keep
] with-destructors ;
+ERROR: no-windows-crypto-provider error ;
+
+: try-crypto-providers ( seq -- windows-rng )
+ [ first2 <windows-rng> ] attempt-all
+ dup windows-rng? [ no-windows-crypto-provider ] unless ;
+
[
- MS_DEF_PROV
- PROV_RSA_FULL <windows-rng> system-random-generator set-global
+ {
+ ${ MS_ENHANCED_PROV PROV_RSA_FULL }
+ ${ MS_DEF_PROV PROV_RSA_FULL }
+ } try-crypto-providers
+ system-random-generator set-global
- [ MS_STRONG_PROV PROV_RSA_FULL <windows-rng> ]
- [ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES <windows-rng> ] recover
- secure-random-generator set-global
+ {
+ ${ MS_STRONG_PROV PROV_RSA_FULL }
+ ${ MS_ENH_RSA_AES_PROV PROV_RSA_AES }
+ } try-crypto-providers secure-random-generator set-global
] "random.windows" add-startup-hook
[
M: wrapper apply-object
wrapped>>
- [ dup word? [ called-dependency depends-on ] [ drop ] if ]
+ [ dup word? [ depends-on-effect ] [ drop ] if ]
[ push-literal ]
bi ;
-IN: stack-checker.dependencies.tests
-USING: tools.test stack-checker.dependencies words kernel namespaces
-definitions ;
-: computing-dependencies ( quot -- dependencies )
- H{ } clone [ dependencies rot with-variable ] keep ;
- inline
-
-SYMBOL: a
-SYMBOL: b
-
-[ ] [ a called-dependency depends-on ] unit-test
-
-[ H{ { a called-dependency } } ] [
- [ a called-dependency depends-on ] computing-dependencies
-] unit-test
-
-[ H{ { a called-dependency } { b inlined-dependency } } ] [
- [
- a called-dependency depends-on b inlined-dependency depends-on
- ] computing-dependencies
-] unit-test
-
-[ H{ { a inlined-dependency } { b inlined-dependency } } ] [
- [
- a inlined-dependency depends-on
- a called-dependency depends-on
- b inlined-dependency depends-on
- ] computing-dependencies
-] unit-test
-
-[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
-[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
-[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test
-[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test
-[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
-[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs classes.algebra fry kernel math namespaces
-sequences words ;
+USING: assocs accessors classes.algebra fry generic kernel math
+namespaces sequences words sets combinators.short-circuit ;
+FROM: classes.tuple.private => tuple-layout ;
IN: stack-checker.dependencies
! Words that the current quotation depends on
SYMBOL: dependencies
-SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
+SYMBOLS: effect-dependency conditional-dependency definition-dependency ;
: index>= ( obj1 obj2 seq -- ? )
[ index ] curry bi@ >= ;
: dependency>= ( how1 how2 -- ? )
- { called-dependency flushed-dependency inlined-dependency }
+ { effect-dependency conditional-dependency definition-dependency }
index>= ;
: strongest-dependency ( how1 how2 -- how )
- [ called-dependency or ] bi@ [ dependency>= ] most ;
+ [ effect-dependency or ] bi@ [ dependency>= ] most ;
: depends-on ( word how -- )
over primitive? [ 2drop ] [
] [ 3drop ] if
] if ;
+: depends-on-effect ( word -- )
+ effect-dependency depends-on ;
+
+: depends-on-conditionally ( word -- )
+ conditional-dependency depends-on ;
+
+: depends-on-definition ( word -- )
+ definition-dependency depends-on ;
+
! Generic words that the current quotation depends on
SYMBOL: generic-dependencies
-: ?class-or ( class/f class -- class' )
- swap [ class-or ] when* ;
+: ?class-or ( class class/f -- class' )
+ [ class-or ] when* ;
-: depends-on-generic ( generic class -- )
+: depends-on-generic ( class generic -- )
generic-dependencies get dup
- [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
+ [ [ ?class-or ] change-at ] [ 3drop ] if ;
+
+! Conditional dependencies are re-evaluated when classes change;
+! if any fail, the word is recompiled
+SYMBOL: conditional-dependencies
+
+GENERIC: satisfied? ( dependency -- ? )
+
+: add-conditional-dependency ( ... class -- )
+ boa conditional-dependencies get
+ dup [ conjoin ] [ 2drop ] if ; inline
+
+TUPLE: depends-on-class<= class1 class2 ;
+
+: depends-on-class<= ( class1 class2 -- )
+ \ depends-on-class<= add-conditional-dependency ;
+
+M: depends-on-class<= satisfied?
+ {
+ [ class1>> classoid? ]
+ [ class2>> classoid? ]
+ [ [ class1>> ] [ class2>> ] bi class<= ]
+ } 1&& ;
+
+TUPLE: depends-on-classes-disjoint class1 class2 ;
+
+: depends-on-classes-disjoint ( class1 class2 -- )
+ \ depends-on-classes-disjoint add-conditional-dependency ;
+
+M: depends-on-classes-disjoint satisfied?
+ {
+ [ class1>> classoid? ]
+ [ class2>> classoid? ]
+ [ [ class1>> ] [ class2>> ] bi classes-intersect? not ]
+ } 1&& ;
+
+TUPLE: depends-on-next-method class generic next-method ;
+
+: depends-on-next-method ( class generic next-method -- )
+ over depends-on-conditionally
+ \ depends-on-next-method add-conditional-dependency ;
+
+M: depends-on-next-method satisfied?
+ {
+ [ class>> classoid? ]
+ [ [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ]
+ } 1&& ;
+
+TUPLE: depends-on-method class generic method ;
+
+: depends-on-method ( class generic method -- )
+ over depends-on-conditionally
+ \ depends-on-method add-conditional-dependency ;
+
+M: depends-on-method satisfied?
+ {
+ [ class>> classoid? ]
+ [ [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ]
+ } 1&& ;
+
+TUPLE: depends-on-tuple-layout class layout ;
+
+: depends-on-tuple-layout ( class layout -- )
+ [ drop depends-on-conditionally ]
+ [ \ depends-on-tuple-layout add-conditional-dependency ] 2bi ;
+
+M: depends-on-tuple-layout satisfied?
+ [ class>> tuple-layout ] [ layout>> ] bi eq? ;
+
+TUPLE: depends-on-flushable word ;
+
+: depends-on-flushable ( word -- )
+ [ depends-on-conditionally ]
+ [ \ depends-on-flushable add-conditional-dependency ] bi ;
+
+M: depends-on-flushable satisfied?
+ word>> flushable? ;
+
+: init-dependencies ( -- )
+ H{ } clone dependencies set
+ H{ } clone generic-dependencies set
+ H{ } clone conditional-dependencies set ;
+
+: without-dependencies ( quot -- )
+ [
+ dependencies off
+ generic-dependencies off
+ conditional-dependencies off
+ call
+ ] with-scope ; inline
: inline-word ( word -- )
commit-literals
- [ inlined-dependency depends-on ]
+ [ depends-on-definition ]
[
dup inline-recursive-label [
call-recursive-inline-word
\ clear t "no-compile" set-word-prop
: non-inline-word ( word -- )
- dup called-dependency depends-on
+ dup depends-on-effect
{
{ [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
{ [ dup "special" word-prop ] [ infer-special ] }
\ 3|| t "no-compile" set-word-prop
+: add-next-method-dependency ( method -- )
+ [ "method-class" word-prop ]
+ [ "method-generic" word-prop ] bi
+ 2dup next-method
+ depends-on-next-method ;
+
\ (call-next-method) [
- [
- [ "method-class" word-prop ]
- [ "method-generic" word-prop ] bi
- [ inlined-dependency depends-on ] bi@
- ] [
- [ next-method-quot ]
- [ '[ _ no-next-method ] ] bi or
- ] bi
+ [ add-next-method-dependency ]
+ [ [ next-method-quot ] [ '[ _ no-next-method ] ] bi or ] bi
] 1 define-transform
\ (call-next-method) t "no-compile" set-word-prop
! Constructors
\ boa [
dup tuple-class? [
- dup inlined-dependency depends-on
- [ "boa-check" word-prop [ ] or ]
- [ tuple-layout '[ _ <tuple-boa> ] ]
- bi append
+ dup tuple-layout
+ [ depends-on-tuple-layout ]
+ [ [ "boa-check" word-prop [ ] or ] dip ] 2bi
+ '[ @ _ <tuple-boa> ]
] [ drop f ] if
] 1 define-transform
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors io.backend io.streams.c init fry
namespaces math make assocs kernel parser parser.notes lexer
"coercer"
"combination"
"compiled-generic-uses"
- "compiled-uses"
+ "effect-dependencies"
+ "definition-dependencies"
+ "conditional-dependencies"
+ "dependency-checks"
"constant"
"constraints"
"custom-inlining"
"members"
"memo-quot"
"methods"
- "mixin"
"method-class"
"method-generic"
"modular-arithmetic"
: profiler-usage ( word -- words )
[ smart-usage [ word? ] filter ]
[ compiled-generic-usage keys ]
- [ compiled-usage keys ]
+ [ effect-dependencies-of keys ]
tri 3append prune ;
: usage-counters ( word -- alist )
math kernel kernel.private namespaces parser quotations
sequences slots words locals
locals.parser macros stack-checker.dependencies ;
+FROM: classes.tuple.private => tuple-layout ;
IN: typed
ERROR: type-mismatch-error word expected-types ;
: (unboxer) ( type -- quot )
dup unboxable-tuple-class? [
+ dup dup tuple-layout depends-on-tuple-layout
all-slots [
[ name>> reader-word 1quotation ]
[ class>> (unboxer) ] bi compose
: (unboxed-types) ( type -- types )
dup unboxable-tuple-class?
- [ all-slots [ class>> (unboxed-types) ] map concat ]
+ [
+ dup dup tuple-layout depends-on-tuple-layout
+ all-slots [ class>> (unboxed-types) ] map concat
+ ]
[ 1array ] if ;
: unboxed-types ( types -- types' )
: boxer ( type -- quot )
dup unboxable-tuple-class?
- [ [ all-slots [ class>> ] map make-boxer ] [ [ boa ] curry ] bi compose ]
+ [
+ dup dup tuple-layout depends-on-tuple-layout
+ [ all-slots [ class>> ] map make-boxer ]
+ [ [ boa ] curry ]
+ bi compose
+ ]
[ drop [ ] ] if ;
: make-boxer ( types -- quot )
! defining typed words
-: (depends-on) ( types -- types )
- dup [ inlined-dependency depends-on ] each ; inline
-
MACRO: (typed) ( word def effect -- quot )
[ swap ] dip
[
- nip effect-in-types (depends-on) swap
+ nip effect-in-types swap
[ [ unboxed-types ] [ make-boxer ] bi ] dip
'[ _ declare @ @ ]
]
[
- effect-out-types (depends-on)
+ effect-out-types
dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if
] 2bi ;
[ 2nip ] 3tri define-declared ;
MACRO: typed ( quot word effect -- quot' )
- [ effect-in-types (depends-on) dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
+ [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
[
- nip effect-out-types (depends-on) dup typed-stack-effect?
+ nip effect-out-types dup typed-stack-effect?
[ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if
] 2bi ;
tri
] with-pprint ;
+: filter-interesting ( seq -- seq' )
+ [ [ vocab? ] [ extra-words? ] bi or not ] filter ;
+
PRIVATE>
: (pprint-manifest ( manifest -- quots )
[
[ search-vocabs>> [ '[ _ pprint-using ] , ] unless-empty ]
- [ qualified-vocabs>> [ extra-words? not ] filter [ '[ _ pprint-qualified ] , ] each ]
+ [ qualified-vocabs>> filter-interesting [ '[ _ pprint-qualified ] , ] each ]
[ current-vocab>> [ '[ _ pprint-in ] , ] when* ]
tri
] { } make ;
! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
! Bring up a bare cross-compiling vocabulary.
-"syntax" vocab vocab-words bootstrap-syntax set {
- dictionary
- new-classes
- changed-definitions changed-generics changed-effects
- outdated-generics forgotten-definitions
- root-cache source-files update-map implementors-map
-} [ H{ } clone swap set ] each
+"syntax" vocab vocab-words bootstrap-syntax set
-init-caches
+H{ } clone dictionary set
+H{ } clone root-cache set
+H{ } clone source-files set
+H{ } clone update-map set
+H{ } clone implementors-map set
-! Vocabulary for slot accessors
-"accessors" create-vocab drop
+init-caches
-dummy-compiler compiler-impl set
+bootstrapping? on
call( -- )
call( -- )
-call( -- )
+
+! Vocabulary for slot accessors
+"accessors" create-vocab drop
! After we execute bootstrap/layouts
num-types get f <array> builtins set
-bootstrapping? on
-
[
+call( -- )
+
! Create some empty vocabs where the below primitives and
! classes will go
{
prepare-slots make-slots 1 finalize-slots
[ "slots" set-word-prop ] [ define-accessors ] 2bi ;
+: define-builtin-predicate ( class -- )
+ dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
+
: define-builtin ( symbol slotspec -- )
[ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;
\r
[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test\r
\r
-[ t ] [ growable tuple sequence class-and class<= ] unit-test\r
+[ f ] [ growable tuple sequence class-and class<= ] unit-test\r
\r
-[ t ] [ growable assoc class-and tuple class<= ] unit-test\r
+[ f ] [ growable assoc class-and tuple class<= ] unit-test\r
\r
[ t ] [ object \ f \ f class-not class-or class<= ] unit-test\r
\r
[ t ] [ a union-with-one-member class<= ] unit-test\r
[ f ] [ union-with-one-member class-not integer class<= ] unit-test\r
\r
+MIXIN: empty-mixin\r
+\r
+[ f ] [ empty-mixin class-not null class<= ] unit-test\r
+[ f ] [ empty-mixin null class<= ] unit-test\r
+\r
+[ t ] [ array sequence vector class-not class-and class<= ] unit-test\r
+[ f ] [ vector sequence vector class-not class-and class<= ] unit-test\r
+\r
! class-and\r
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
\r
[ t ] [ slice reversed null class-and* ] unit-test\r
[ t ] [ \ f class-not \ f null class-and* ] unit-test\r
\r
-[ t ] [ vector virtual-sequence null class-and* ] unit-test\r
-\r
[ t ] [ vector array class-not vector class-and* ] unit-test\r
\r
! class-or\r
\r
! classes-intersect?\r
[ t ] [ both tuple classes-intersect? ] unit-test\r
+\r
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test\r
\r
[ t ] [ number vector class-or sequence classes-intersect? ] unit-test\r
-! Copyright (C) 2004, 2008 Slava Pestov.\r
+! Copyright (C) 2004, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel classes combinators accessors sequences arrays\r
vectors assocs namespaces words sorting layouts math hashtables\r
\r
GENERIC: (flatten-class) ( class -- )\r
\r
-: normalize-class ( class -- class' )\r
- {\r
- { [ dup members ] [ members <anonymous-union> normalize-class ] }\r
- { [ dup participants ] [ participants <anonymous-intersection> normalize-class ] }\r
- [ ]\r
- } cond ;\r
+GENERIC: normalize-class ( class -- class' )\r
+\r
+M: object normalize-class ;\r
\r
PRIVATE>\r
\r
-GENERIC: valid-class? ( obj -- ? )\r
+GENERIC: classoid? ( obj -- ? )\r
\r
-M: class valid-class? drop t ;\r
-M: anonymous-union valid-class? members>> [ valid-class? ] all? ;\r
-M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;\r
-M: anonymous-complement valid-class? class>> valid-class? ;\r
-M: word valid-class? drop f ;\r
+M: word classoid? class? ;\r
+M: anonymous-union classoid? members>> [ classoid? ] all? ;\r
+M: anonymous-intersection classoid? participants>> [ classoid? ] all? ;\r
+M: anonymous-complement classoid? class>> classoid? ;\r
\r
: class<= ( first second -- ? )\r
class<=-cache get [ (class<=) ] 2cache ;\r
: left-anonymous-union<= ( first second -- ? )\r
[ members>> ] dip [ class<= ] curry all? ;\r
\r
+: right-union<= ( first second -- ? )\r
+ members [ class<= ] with any? ;\r
+\r
: right-anonymous-union<= ( first second -- ? )\r
members>> [ class<= ] with any? ;\r
\r
[ class-not normalize-class ] map\r
<anonymous-union>\r
] }\r
- [ <anonymous-complement> ]\r
+ [ drop object ]\r
} cond ;\r
\r
: left-anonymous-complement<= ( first second -- ? )\r
{ [ over anonymous-union? ] [ left-anonymous-union<= ] }\r
{ [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }\r
{ [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }\r
+ { [ dup members ] [ right-union<= ] }\r
{ [ dup anonymous-union? ] [ right-anonymous-union<= ] }\r
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }\r
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }\r
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes classes.algebra classes.algebra.private
words kernel kernel.private namespaces sequences math
M: builtin-class rank-class drop 0 ;
-GENERIC: define-builtin-predicate ( class -- )
-
-M: builtin-class define-builtin-predicate
- dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
-
M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ;
M: builtin-class (flatten-class) dup set ;
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions assocs kernel kernel.private
slots.private namespaces make sequences strings words words.symbol
: classes ( -- seq ) implementors-map get keys ;
-: predicate-word ( word -- predicate )
+: create-predicate-word ( word -- predicate )
[ name>> "?" append ] [ vocabulary>> ] bi create ;
+: predicate-word ( word -- predicate )
+ "predicate" word-prop first ;
+
PREDICATE: predicate < word "predicating" word-prop >boolean ;
+M: predicate flushable? drop t ;
+
M: predicate forget*
[ call-next-method ] [ f "predicating" set-word-prop ] bi ;
[ call-next-method ] [ f "predicating" set-word-prop ] bi ;
: define-predicate ( class quot -- )
- [ "predicate" word-prop first ] dip
- (( object -- ? )) define-declared ;
+ [ predicate-word ] dip (( object -- ? )) define-declared ;
: superclass ( class -- super )
#! Output f for non-classes to work with algebra code
dup deferred? [ define-symbol ] [ drop ] if ;
: (define-class) ( word props -- )
+ reset-caches
+ [ drop update-map- ]
[
- {
- [ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
- [ reset-class ]
- [ ?define-symbol ]
- [ changed-definition ]
- [ ]
- } cleave
- ] dip [ assoc-union ] curry change-props
- dup predicate-word
- [ 1quotation "predicate" set-word-prop ]
- [ swap "predicating" set-word-prop ]
- [ drop t "class" set-word-prop ]
+ [
+ {
+ [ dup class? [ drop ] [ implementors-map+ ] if ]
+ [ reset-class ]
+ [ ?define-symbol ]
+ [ ]
+ } cleave
+ ] dip [ assoc-union ] curry change-props
+ dup create-predicate-word
+ [ 1quotation "predicate" set-word-prop ]
+ [ swap "predicating" set-word-prop ]
+ [ drop t "class" set-word-prop ]
+ 2tri
+ ]
+ [ drop update-map+ ]
2tri ;
PRIVATE>
[ nip [ update-class ] each ] [ update-methods ] 2bi ;
: define-class ( word superclass members participants metaclass -- )
- #! If it was already a class, update methods after.
- reset-caches
- make-class-props
- [ drop update-map- ]
- [ (define-class) ]
- [ drop update-map+ ]
- 2tri ;
+ make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
: forget-predicate ( class -- )
dup "predicate" word-prop
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words accessors sequences kernel assocs combinators classes
classes.algebra classes.algebra.private classes.builtin
PREDICATE: intersection-class < class
"metaclass" word-prop intersection-class eq? ;
+<PRIVATE
+
: intersection-predicate-quot ( members -- quot )
[
[ drop t ]
M: intersection-class update-class define-intersection-predicate ;
-: define-intersection-class ( class participants -- )
- [ [ f f ] dip intersection-class define-class ]
- [ drop update-classes ]
- 2bi ;
-
M: intersection-class rank-class drop 2 ;
M: intersection-class instance?
"participants" word-prop [ instance? ] with all? ;
+M: intersection-class normalize-class
+ participants <anonymous-intersection> normalize-class ;
+
M: intersection-class (flatten-class)
participants <anonymous-intersection> (flatten-class) ;
[ intersect-flattened-classes ] map-reduce
[ dup set ] each
] if-empty ;
+
+PRIVATE>
+
+: define-intersection-class ( class participants -- )
+ [ [ f f ] dip intersection-class define-class ]
+ [ drop update-classes ]
+ 2bi ;
INSTANCE: integer mx1
[ t ] [ integer mx1 class<= ] unit-test
-[ t ] [ mx1 integer class<= ] unit-test
-[ t ] [ mx1 number class<= ] unit-test
+[ f ] [ mx1 integer class<= ] unit-test
+[ f ] [ mx1 number class<= ] unit-test
"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval( -- )
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.union words kernel sequences
+USING: classes classes.algebra classes.algebra.private
+classes.union classes.union.private words kernel sequences
definitions combinators arrays assocs generic accessors ;
IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ;
+M: mixin-class normalize-class ;
+
+M: mixin-class (classes-intersect?)
+ members [ classes-intersect? ] with any? ;
+
M: mixin-class reset-class
[ call-next-method ] [ { "mixin" } reset-props ] bi ;
M: mixin-class rank-class drop 3 ;
-: redefine-mixin-class ( class members -- )
- [ (define-union-class) ]
- [ drop t "mixin" set-word-prop ]
- 2bi ;
-
-: define-mixin-class ( class -- )
- dup mixin-class? [
- drop
- ] [
- [ { } redefine-mixin-class ]
- [ H{ } clone "instances" set-word-prop ]
- [ update-classes ]
- tri
- ] if ;
-
TUPLE: check-mixin-class class ;
: check-mixin-class ( mixin -- mixin )
\ check-mixin-class boa throw
] unless ;
+<PRIVATE
+
+: redefine-mixin-class ( class members -- )
+ [ (define-union-class) ]
+ [ drop changed-conditionally ]
+ [ drop t "mixin" set-word-prop ]
+ 2tri ;
+
: if-mixin-member? ( class mixin true false -- )
[ check-mixin-class 2dup members member-eq? ] 2dip if ; inline
[ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
swap redefine-mixin-class ; inline
-: update-classes/new ( mixin -- )
- class-usages
- [ [ update-class ] each ]
- [ implementors [ remake-generic ] each ] bi ;
-
: (add-mixin-instance) ( class mixin -- )
- [ [ suffix ] change-mixin-class ]
- [ [ f ] 2dip "instances" word-prop set-at ]
- 2bi ;
+ #! Call update-methods before adding the member:
+ #! - Call sites of generics specializing on 'mixin'
+ #! where the inferred type is 'class' are updated,
+ #! - Call sites where the inferred type is a subtype
+ #! of 'mixin' disjoint from 'class' are not updated
+ dup class-usages {
+ [ nip update-methods ]
+ [ drop [ suffix ] change-mixin-class ]
+ [ drop [ f ] 2dip "instances" word-prop set-at ]
+ [ 2nip [ update-class ] each ]
+ } 3cleave ;
+
+: (remove-mixin-instance) ( class mixin -- )
+ #! Call update-methods after removing the member:
+ #! - Call sites of generics specializing on 'mixin'
+ #! where the inferred type is 'class' are updated,
+ #! - Call sites where the inferred type is a subtype
+ #! of 'mixin' disjoint from 'class' are not updated
+ dup class-usages {
+ [ drop [ swap remove ] change-mixin-class ]
+ [ drop "instances" word-prop delete-at ]
+ [ 2nip [ update-class ] each ]
+ [ nip update-methods ]
+ } 3cleave ;
+
+PRIVATE>
GENERIC# add-mixin-instance 1 ( class mixin -- )
M: class add-mixin-instance
- #! Note: we call update-classes on the new member, not the
- #! mixin. This ensures that we only have to update the
- #! methods whose specializer intersects the new member, not
- #! the entire mixin (since the other mixin members are not
- #! affected at all). Also, all usages of the mixin will get
- #! updated by transitivity; the mixins usages appear in
- #! class-usages of the member, now that it's been added.
- [ 2drop ] [
- [ (add-mixin-instance) ] 2keep
- [ nip ] [ [ new-class? ] either? ] 2bi
- [ update-classes/new ] [ update-classes ] if
- ] if-mixin-member? ;
-
-: (remove-mixin-instance) ( class mixin -- )
- [ [ swap remove ] change-mixin-class ]
- [ "instances" word-prop delete-at ]
- 2bi ;
+ [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
- #! The order of the three clauses is important here. The last
- #! one must come after the other two so that the entries it
- #! adds to changed-generics are not overwritten.
- [
- [ (remove-mixin-instance) ]
- [ nip update-classes ]
- [ class-usages update-methods ]
- 2tri
- ] [ 2drop ] if-mixin-member? ;
+ [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
M: mixin-class class-forgotten remove-mixin-instance ;
+: define-mixin-class ( class -- )
+ dup mixin-class? [
+ drop
+ ] [
+ [ { } redefine-mixin-class ]
+ [ H{ } clone "instances" set-word-prop ]
+ [ update-classes ]
+ tri
+ ] if ;
+
! Definition protocol implementation ensures that removing an
! INSTANCE: declaration from a source file updates the mixin.
TUPLE: mixin-instance class mixin ;
C: <mixin-instance> mixin-instance
+<PRIVATE
+
: >mixin-instance< ( mixin-instance -- class mixin )
[ class>> ] [ mixin>> ] bi ; inline
+PRIVATE>
+
M: mixin-instance where >mixin-instance< "instances" word-prop at ;
M: mixin-instance set-where >mixin-instance< "instances" word-prop set-at ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser vocabs.parser words kernel classes compiler.units lexer ;
IN: classes.parser
: create-class-in ( string -- word )
current-vocab create
dup save-class-location
- dup predicate-word dup set-word save-location ;
+ dup create-predicate-word dup set-word save-location ;
: CREATE-CLASS ( -- word )
scan create-class-in ;
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.algebra classes.algebra.private kernel
namespaces make words sequences quotations arrays kernel.private
PREDICATE: predicate-class < class
"metaclass" word-prop predicate-class eq? ;
+<PRIVATE
+
GENERIC: predicate-quot ( class -- quot )
M: predicate-class predicate-quot
[ drop f ] , \ if ,
] [ ] make ;
+PRIVATE>
+
: define-predicate-class ( class superclass definition -- )
[ drop f f predicate-class define-class ]
[ nip "predicate-definition" set-word-prop ]
-! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov.
+! Copyright (C) 2008, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.algebra classes.algebra.private
-classes.predicate kernel sequences words ;
+classes.predicate classes.predicate.private kernel sequences
+words ;
IN: classes.singleton
+<PRIVATE
+
: singleton-predicate-quot ( class -- quot ) [ eq? ] curry ;
+PRIVATE>
+
PREDICATE: singleton-class < predicate-class
[ "predicate-definition" word-prop ]
[ singleton-predicate-quot ]
tuple>array
tuple-slots
}
+"Tuples can be compared for slot equality even if the tuple class overrides " { $link equal? } ":"
+{ $subsections tuple= }
"Tuple classes can also be defined at run time:"
{ $subsections define-tuple-class }
{ $see-also "slots" "mirrors" } ;
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
-{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
-{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
+{ $description "Checks if two tuples have equal slot values. This is the default behavior of " { $link = } " on tuples, unless the tuple class subclasses " { $link identity-tuple } " or implements a method on " { $link equal? } ". In cases where equality has been redefined, this word can be used to get the default semantics if needed." } ;
HELP: tuple
{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
math.order namespaces parser parser.notes prettyprint
quotations random see sequences sequences.private slots
slots.private splitting strings summary threads tools.test
-vectors vocabs words words.symbol fry literals ;
+vectors vocabs words words.symbol fry literals memory ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
[ ] [
[
- \ vocab tuple { "xxx" } "slots" get append
+ \ vocab identity-tuple { "xxx" } "slots" get append
define-tuple-class
] with-compilation-unit
all-words drop
[
- \ vocab tuple "slots" get
+ \ vocab identity-tuple "slots" get
define-tuple-class
] with-compilation-unit
] unit-test
[ "prototype" word-prop ] map
[ '[ _ hashcode drop f ] [ drop t ] recover ] filter
] unit-test
+
+! Make sure that tuple reshaping updates code heap roots
+TUPLE: code-heap-ref ;
+
+: code-heap-ref' ( -- a ) T{ code-heap-ref } ;
+
+! Push foo's literal to tenured space
+[ ] [ gc ] unit-test
+
+! Reshape!
+[ ] [ "IN: classes.tuple.tests USE: math TUPLE: code-heap-ref { x integer initial: 5 } ;" eval( -- ) ] unit-test
+
+! Code heap reference
+[ t ] [ code-heap-ref' code-heap-ref? ] unit-test
+[ 5 ] [ code-heap-ref' x>> ] unit-test
+
+! Data heap reference
+[ t ] [ \ code-heap-ref' def>> first code-heap-ref? ] unit-test
+[ 5 ] [ \ code-heap-ref' def>> first x>> ] unit-test
2drop
[
[ update-tuples-after ]
- [ changed-definition ]
+ [ changed-conditionally ]
bi
] each-subclass
]
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
-classes.algebra classes.algebra.private namespaces arrays math
-quotations ;
+classes.private classes.algebra classes.algebra.private
+namespaces arrays math quotations definitions ;
IN: classes.union
PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ;
+<PRIVATE
+
: union-predicate-quot ( members -- quot )
[
[ drop f ]
M: union-class update-class define-union-predicate ;
: (define-union-class) ( class members -- )
- f swap f union-class define-class ;
+ f swap f union-class make-class-props (define-class) ;
+
+PRIVATE>
: define-union-class ( class members -- )
- [ (define-union-class) ] [ drop update-classes ] 2bi ;
+ [ (define-union-class) ]
+ [ drop changed-conditionally ]
+ [ drop update-classes ]
+ 2tri ;
M: union-class rank-class drop 2 ;
M: union-class instance?
"members" word-prop [ instance? ] with any? ;
+M: union-class normalize-class
+ members <anonymous-union> normalize-class ;
+
M: union-class (flatten-class)
members <anonymous-union> (flatten-class) ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
SYMBOL: compiler-impl
+HOOK: update-call-sites compiler-impl ( class generic -- words )
+
+: changed-call-sites ( class generic -- )
+ update-call-sites [ changed-definition ] each ;
+
+M: generic update-generic ( class generic -- )
+ [ changed-call-sites ]
+ [ remake-generic drop ]
+ [ changed-conditionally drop ]
+ 2tri ;
+
+M: sequence update-methods ( class seq -- )
+ implementors [ update-generic ] with each ;
+
HOOK: recompile compiler-impl ( words -- alist )
HOOK: to-recompile compiler-impl ( -- words )
: compile ( words -- ) recompile modify-code-heap ;
! Non-optimizing compiler
-M: f recompile
- [ dup def>> ] { } map>assoc ;
+M: f update-call-sites
+ 2drop { } ;
M: f to-recompile
- changed-definitions get [ drop word? ] assoc-filter
- changed-generics get assoc-union keys ;
+ changed-definitions get [ drop word? ] assoc-filter keys ;
+
+M: f recompile
+ [ dup def>> ] { } map>assoc ;
M: f process-forgotten-words drop ;
: without-optimizer ( quot -- )
[ f compiler-impl ] dip with-variable ; inline
-! Trivial compiler. We don't want to touch the code heap
-! during stage1 bootstrap, it would just waste time.
-SINGLETON: dummy-compiler
-
-M: dummy-compiler to-recompile f ;
-
-M: dummy-compiler recompile drop { } ;
-
-M: dummy-compiler process-forgotten-words drop ;
-
: <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
SYMBOL: definition-observers
! inline caching
: effect-counter ( -- n ) 47 special-object ; inline
-GENERIC: bump-effect-counter* ( defspec -- ? )
+GENERIC: always-bump-effect-counter? ( defspec -- ? )
-M: object bump-effect-counter* drop f ;
+M: object always-bump-effect-counter? drop f ;
<PRIVATE
dup new-definitions get first update
dup new-definitions get second update
dup changed-definitions get update
+ dup maybe-changed get update
dup dup changed-vocabs update ;
: process-forgotten-definitions ( -- )
bi ;
: bump-effect-counter? ( -- ? )
- changed-effects get new-words get assoc-diff assoc-empty? not
- changed-definitions get [ drop bump-effect-counter* ] assoc-any?
- or ;
+ changed-effects get
+ maybe-changed get
+ changed-definitions get [ drop always-bump-effect-counter? ] assoc-filter
+ 3array assoc-combine new-words get assoc-diff assoc-empty? not ;
: bump-effect-counter ( -- )
bump-effect-counter? [
[ drop ] [ notify-definition-observers notify-error-observers ] if ;
: finish-compilation-unit ( -- )
- remake-generics
- to-recompile recompile
- update-tuples
- process-forgotten-definitions
- modify-code-heap
- bump-effect-counter
- notify-observers ;
+ [ ] [
+ remake-generics
+ to-recompile recompile
+ update-tuples
+ process-forgotten-definitions
+ modify-code-heap
+ bump-effect-counter
+ notify-observers
+ ] if-bootstrapping ;
PRIVATE>
: with-nested-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
- H{ } clone changed-generics set
+ H{ } clone maybe-changed set
H{ } clone changed-effects set
H{ } clone outdated-generics set
H{ } clone outdated-tuples set
H{ } clone new-words set
- H{ } clone new-classes set
[ finish-compilation-unit ] [ ] cleanup
] with-scope ; inline
: with-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
- H{ } clone changed-generics set
+ H{ } clone maybe-changed set
H{ } clone changed-effects set
H{ } clone outdated-generics set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
H{ } clone new-words set
- H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set
[ finish-compilation-unit ] [ ] cleanup
-USING: help.markup help.syntax kernel kernel.private
-continuations.private vectors arrays namespaces
-assocs words quotations lexer sequences math ;
-IN: continuations
-
-ARTICLE: "errors-restartable" "Restartable errors"
-"Support for restartable errors is built on top of the basic error handling facility. The following words signals recoverable errors:"
-{ $subsections
- throw-restarts
- rethrow-restarts
-}
-"The list of restarts from the most recently-thrown error is stored in a global variable:"
-{ $subsections restarts }
-"To invoke restarts, see " { $link "debugger" } "." ;
-
-ARTICLE: "errors-post-mortem" "Post-mortem error inspection"
-"The most recently thrown error, together with the continuation at that point, are stored in a pair of global variables:"
-{ $subsections
- error
- error-continuation
-}
-"Developer tools for inspecting these values are found in " { $link "debugger" } "." ;
-
-ARTICLE: "errors-anti-examples" "Common error handling pitfalls"
-"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind."
-{ $heading "Anti-pattern #1: Ignoring errors" }
-"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user."
-{ $heading "Anti-pattern #2: Catching errors too early" }
-"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible."
-$nl
-"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."
-{ $heading "Anti-pattern #3: Dropping and rethrowing" }
-"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
-{ $heading "Anti-pattern #4: Logging and rethrowing" }
-"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;
-
-ARTICLE: "errors" "Exception handling"
-"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
-$nl
-"Two words raise an error in the innermost error handler for the current dynamic extent:"
-{ $subsections
- throw
- rethrow
-}
-"Words for establishing an error handler:"
-{ $subsections
- cleanup
- recover
- ignore-errors
-}
-"Syntax sugar for defining errors:"
-{ $subsections POSTPONE: ERROR: }
-"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
-{ $subsections
- "errors-restartable"
- "debugger"
- "errors-post-mortem"
- "errors-anti-examples"
-}
-"When Factor encouters a critical error, it calls the following word:"
-{ $subsections die } ;
-
-ARTICLE: "continuations.private" "Continuation implementation details"
-"A continuation is simply a tuple holding the contents of the five stacks:"
-{ $subsections
- continuation
- >continuation<
-}
-"The five stacks can be read and written:"
-{ $subsections
- datastack
- set-datastack
- retainstack
- set-retainstack
- callstack
- set-callstack
- namestack
- set-namestack
- catchstack
- set-catchstack
-} ;
-
-ARTICLE: "continuations" "Continuations"
-"At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation."
-$nl
-"Words for working with continuations are found in the " { $vocab-link "continuations" } " vocabulary; implementation details are in " { $vocab-link "continuations.private" } "."
-$nl
-"Continuations can be reified with the following two words:"
-{ $subsections
- callcc0
- callcc1
-}
-"Another two words resume continuations:"
-{ $subsections
- continue
- continue-with
-}
-"Continuations as control-flow:"
-{ $subsections
- attempt-all
- with-return
-}
-"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
-{ $subsections "continuations.private" } ;
-
-ABOUT: "continuations"
-
-HELP: catchstack*
-{ $values { "catchstack" "a vector of continuations" } }
-{ $description "Outputs the current catchstack." } ;
-
-HELP: catchstack
-{ $values { "catchstack" "a vector of continuations" } }
-{ $description "Outputs a copy of the current catchstack." } ;
-
-HELP: set-catchstack
-{ $values { "catchstack" "a vector of continuations" } }
-{ $description "Replaces the catchstack with a copy of the given vector." } ;
-
-HELP: continuation
-{ $values { "continuation" continuation } }
-{ $description "Reifies the current continuation from the point immediately after which the caller returns." } ;
-
-HELP: >continuation<
-{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } }
-{ $description "Takes a continuation apart into its constituents." } ;
-
-HELP: ifcc
-{ $values { "capture" { $quotation "( continuation -- )" } } { "restore" quotation } }
-{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;
-
-{ callcc0 continue callcc1 continue-with ifcc } related-words
-
-HELP: callcc0
-{ $values { "quot" { $quotation "( continuation -- )" } } }
-{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue } " word resumes the continuation." } ;
-
-HELP: callcc1
-{ $values { "quot" { $quotation "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
-{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
-
-HELP: continue
-{ $values { "continuation" continuation } }
-{ $description "Resumes a continuation reified by " { $link callcc0 } "." } ;
-
-HELP: continue-with
-{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }
-{ $description "Resumes a continuation reified by " { $link callcc1 } ". The object will be placed on the data stack when the continuation resumes." } ;
-
-HELP: error
-{ $description "Global variable holding most recently thrown error." }
-{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
-
-HELP: error-continuation
-{ $description "Global variable holding current continuation of most recently thrown error." }
-{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
-
-HELP: restarts
-{ $var-description "Global variable holding the set of possible restarts for the most recently thrown error." }
-{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
-
-HELP: >c
-{ $values { "continuation" continuation } }
-{ $description "Pushes an exception handler continuation on the catch stack. The continuation must have been reified by " { $link callcc1 } "." } ;
-
-HELP: c>
-{ $values { "continuation" continuation } }
-{ $description "Pops an exception handler continuation from the catch stack." } ;
-
-HELP: throw
-{ $values { "error" object } }
-{ $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ;
-
-{ cleanup recover } related-words
-
-HELP: cleanup
-{ $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } }
-{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ;
-
-HELP: recover
-{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } }
-{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
-
-HELP: ignore-errors
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ;
-
-HELP: rethrow
-{ $values { "error" object } }
-{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }
-{ $notes
- "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
-}
-{ $examples
- "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:"
- { $see with-lexer }
-} ;
-
-HELP: throw-restarts
-{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
-{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }
-{ $examples
- "Try invoking one of the two restarts which are offered after the below code throws an error:"
- { $code
- ": restart-test"
- " \"Oops!\" { { \"One\" 1 } { \"Two\" 2 } } condition"
- " \"You restarted: \" write . ;"
- "restart-test"
- }
-} ;
-
-HELP: rethrow-restarts
-{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
-{ $description "Throws a restartable error using " { $link rethrow } ". Otherwise, this word is identical to " { $link throw-restarts } "." } ;
-
-{ throw rethrow throw-restarts rethrow-restarts } related-words
-
-HELP: compute-restarts
-{ $values { "error" object } { "seq" "a sequence" } }
-{ $description "Outputs a sequence of triples, where each triple consists of a human-readable string, an object, and a continuation. Resuming a continuation with the corresponding object restarts execution immediately after the corresponding call to " { $link condition } "."
-$nl
-"This word recursively travels up the delegation chain to collate restarts from nested and wrapped conditions." } ;
-
-HELP: save-error
-{ $values { "error" "an error" } }
-{ $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }
-$low-level-note ;
-
-HELP: with-datastack
-{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }
-{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
-{ $examples
- { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
-} ;
-
-HELP: attempt-all
-{ $values
- { "seq" sequence } { "quot" quotation }
- { "obj" object } }
-{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." }
-{ $examples "The first two numbers throw, the last one doesn't:"
- { $example
- "USING: prettyprint continuations kernel math ;"
- "{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ."
- "6" }
- "All quotations throw, the last exception is rethrown:"
- { $example
- "USING: prettyprint continuations kernel math ;"
- "[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ."
- "5"
- }
-} ;
-
-HELP: return
-{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
-
-HELP: with-return
-{ $values
- { "quot" quotation } }
-{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." }
-{ $examples
- "Only \"Hi\" will print:"
- { $example
- "USING: prettyprint continuations io ;"
- "[ \"Hi\" print return \"Bye\" print ] with-return"
- "Hi"
-} } ;
-
-{ return with-return } related-words
-
-HELP: restart
-{ $values { "restart" restart } }
-{ $description "Invokes a restart." }
-{ $class-description "The class of restarts." } ;
+USING: help.markup help.syntax kernel kernel.private\r
+continuations.private vectors arrays namespaces\r
+assocs words quotations lexer sequences math ;\r
+IN: continuations\r
+\r
+ARTICLE: "errors-restartable" "Restartable errors"\r
+"Support for restartable errors is built on top of the basic error handling facility. The following words signals recoverable errors:"\r
+{ $subsections\r
+ throw-restarts\r
+ rethrow-restarts\r
+}\r
+"The list of restarts from the most recently-thrown error is stored in a global variable:"\r
+{ $subsections restarts }\r
+"To invoke restarts, see " { $link "debugger" } "." ;\r
+\r
+ARTICLE: "errors-post-mortem" "Post-mortem error inspection"\r
+"The most recently thrown error, together with the continuation at that point, are stored in a pair of global variables:"\r
+{ $subsections\r
+ error\r
+ error-continuation\r
+}\r
+"Developer tools for inspecting these values are found in " { $link "debugger" } "." ;\r
+\r
+ARTICLE: "errors-anti-examples" "Common error handling pitfalls"\r
+"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind."\r
+{ $heading "Anti-pattern #1: Ignoring errors" }\r
+"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user."\r
+{ $heading "Anti-pattern #2: Catching errors too early" }\r
+"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible."\r
+$nl\r
+"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."\r
+{ $heading "Anti-pattern #3: Dropping and rethrowing" }\r
+"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."\r
+{ $heading "Anti-pattern #4: Logging and rethrowing" }\r
+"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;\r
+\r
+ARTICLE: "errors" "Exception handling"\r
+"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."\r
+$nl\r
+"Two words raise an error in the innermost error handler for the current dynamic extent:"\r
+{ $subsections\r
+ throw\r
+ rethrow\r
+}\r
+"Words for establishing an error handler:"\r
+{ $subsections\r
+ cleanup\r
+ recover\r
+ ignore-errors\r
+}\r
+"Syntax sugar for defining errors:"\r
+{ $subsections POSTPONE: ERROR: }\r
+"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."\r
+{ $subsections\r
+ "errors-restartable"\r
+ "debugger"\r
+ "errors-post-mortem"\r
+ "errors-anti-examples"\r
+}\r
+"When Factor encouters a critical error, it calls the following word:"\r
+{ $subsections die } ;\r
+\r
+ARTICLE: "continuations.private" "Continuation implementation details"\r
+"A continuation is simply a tuple holding the contents of the five stacks:"\r
+{ $subsections\r
+ continuation\r
+ >continuation<\r
+}\r
+"The five stacks can be read and written:"\r
+{ $subsections\r
+ datastack\r
+ set-datastack\r
+ retainstack\r
+ set-retainstack\r
+ callstack\r
+ set-callstack\r
+ namestack\r
+ set-namestack\r
+ catchstack\r
+ set-catchstack\r
+} ;\r
+\r
+ARTICLE: "continuations" "Continuations"\r
+"At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation."\r
+$nl\r
+"Words for working with continuations are found in the " { $vocab-link "continuations" } " vocabulary; implementation details are in " { $vocab-link "continuations.private" } "."\r
+$nl\r
+"Continuations can be reified with the following two words:"\r
+{ $subsections\r
+ callcc0\r
+ callcc1\r
+}\r
+"Another two words resume continuations:"\r
+{ $subsections\r
+ continue\r
+ continue-with\r
+}\r
+"Continuations as control-flow:"\r
+{ $subsections\r
+ attempt-all\r
+ with-return\r
+}\r
+"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."\r
+{ $subsections "continuations.private" } ;\r
+\r
+ABOUT: "continuations"\r
+\r
+HELP: catchstack*\r
+{ $values { "catchstack" "a vector of continuations" } }\r
+{ $description "Outputs the current catchstack." } ;\r
+\r
+HELP: catchstack\r
+{ $values { "catchstack" "a vector of continuations" } }\r
+{ $description "Outputs a copy of the current catchstack." } ;\r
+\r
+HELP: set-catchstack\r
+{ $values { "catchstack" "a vector of continuations" } }\r
+{ $description "Replaces the catchstack with a copy of the given vector." } ;\r
+\r
+HELP: continuation\r
+{ $values { "continuation" continuation } }\r
+{ $description "Reifies the current continuation from the point immediately after which the caller returns." } ;\r
+\r
+HELP: >continuation<\r
+{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } }\r
+{ $description "Takes a continuation apart into its constituents." } ;\r
+\r
+HELP: ifcc\r
+{ $values { "capture" { $quotation "( continuation -- )" } } { "restore" quotation } }\r
+{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;\r
+\r
+{ callcc0 continue callcc1 continue-with ifcc } related-words\r
+\r
+HELP: callcc0\r
+{ $values { "quot" { $quotation "( continuation -- )" } } }\r
+{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue } " word resumes the continuation." } ;\r
+\r
+HELP: callcc1\r
+{ $values { "quot" { $quotation "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }\r
+{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;\r
+\r
+HELP: continue\r
+{ $values { "continuation" continuation } }\r
+{ $description "Resumes a continuation reified by " { $link callcc0 } "." } ;\r
+\r
+HELP: continue-with\r
+{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }\r
+{ $description "Resumes a continuation reified by " { $link callcc1 } ". The object will be placed on the data stack when the continuation resumes." } ;\r
+\r
+HELP: error\r
+{ $description "Global variable holding most recently thrown error." }\r
+{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;\r
+\r
+HELP: error-continuation\r
+{ $description "Global variable holding current continuation of most recently thrown error." }\r
+{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;\r
+\r
+HELP: restarts\r
+{ $var-description "Global variable holding the set of possible restarts for the most recently thrown error." }\r
+{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;\r
+\r
+HELP: >c\r
+{ $values { "continuation" continuation } }\r
+{ $description "Pushes an exception handler continuation on the catch stack. The continuation must have been reified by " { $link callcc1 } "." } ;\r
+\r
+HELP: c>\r
+{ $values { "continuation" continuation } }\r
+{ $description "Pops an exception handler continuation from the catch stack." } ;\r
+\r
+HELP: throw\r
+{ $values { "error" object } }\r
+{ $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ;\r
+\r
+{ cleanup recover } related-words\r
+\r
+HELP: cleanup\r
+{ $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } }\r
+{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ;\r
+\r
+HELP: recover\r
+{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } }\r
+{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;\r
+\r
+HELP: ignore-errors\r
+{ $values { "quot" quotation } }\r
+{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ;\r
+\r
+HELP: rethrow\r
+{ $values { "error" object } }\r
+{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }\r
+{ $notes\r
+ "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."\r
+}\r
+{ $examples\r
+ "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:"\r
+ { $see with-lexer }\r
+} ;\r
+\r
+HELP: throw-restarts\r
+{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }\r
+{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }\r
+{ $examples\r
+ "Try invoking one of the two restarts which are offered after the below code throws an error:"\r
+ { $code\r
+ ": restart-test"\r
+ " \"Oops!\" { { \"One\" 1 } { \"Two\" 2 } } condition"\r
+ " \"You restarted: \" write . ;"\r
+ "restart-test"\r
+ }\r
+} ;\r
+\r
+HELP: rethrow-restarts\r
+{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }\r
+{ $description "Throws a restartable error using " { $link rethrow } ". Otherwise, this word is identical to " { $link throw-restarts } "." } ;\r
+\r
+{ throw rethrow throw-restarts rethrow-restarts } related-words\r
+\r
+HELP: compute-restarts\r
+{ $values { "error" object } { "seq" "a sequence" } }\r
+{ $description "Outputs a sequence of triples, where each triple consists of a human-readable string, an object, and a continuation. Resuming a continuation with the corresponding object restarts execution immediately after the corresponding call to " { $link condition } "."\r
+$nl\r
+"This word recursively travels up the delegation chain to collate restarts from nested and wrapped conditions." } ;\r
+\r
+HELP: save-error\r
+{ $values { "error" "an error" } }\r
+{ $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }\r
+$low-level-note ;\r
+\r
+HELP: with-datastack\r
+{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }\r
+{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }\r
+{ $examples\r
+ { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }\r
+} ;\r
+\r
+HELP: attempt-all\r
+{ $values\r
+ { "seq" sequence } { "quot" quotation }\r
+ { "obj" object } }\r
+{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." }\r
+{ $examples "The first two numbers throw, the last one doesn't:"\r
+ { $example\r
+ "USING: prettyprint continuations kernel math ;"\r
+ "{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ."\r
+ "6" }\r
+ "All quotations throw, the last exception is rethrown:"\r
+ { $example\r
+ "USING: prettyprint continuations kernel math ;"\r
+ "[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ."\r
+ "5"\r
+ }\r
+} ;\r
+\r
+HELP: return\r
+{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;\r
+\r
+HELP: with-return\r
+{ $values\r
+ { "quot" quotation } }\r
+{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." }\r
+{ $examples\r
+ "Only \"Hi\" will print:"\r
+ { $example\r
+ "USING: prettyprint continuations io ;"\r
+ "[ \"Hi\" print return \"Bye\" print ] with-return"\r
+ "Hi"\r
+} } ;\r
+\r
+{ return with-return } related-words\r
+\r
+HELP: restart\r
+{ $values { "restart" restart } }\r
+{ $description "Invokes a restart." }\r
+{ $class-description "The class of restarts." } ;\r
-USING: kernel math namespaces io tools.test sequences vectors
-continuations debugger parser memory arrays words
-kernel.private accessors eval ;
-IN: continuations.tests
-
-: (callcc1-test) ( n obj -- n' obj )
- [ 1 - dup ] dip ?push
- over 0 = [ "test-cc" get continue-with ] when
- (callcc1-test) ;
-
-: callcc1-test ( x -- list )
- [
- "test-cc" set V{ } clone (callcc1-test)
- ] callcc1 nip ;
-
-: callcc-namespace-test ( -- ? )
- [
- "test-cc" set
- 5 "x" set
- [
- 6 "x" set "test-cc" get continue
- ] with-scope
- ] callcc0 "x" get 5 = ;
-
-[ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test
-[ t ] [ callcc-namespace-test ] unit-test
-
-[ 5 throw ] [ 5 = ] must-fail-with
-
-[ t ] [
- [ "Hello" throw ] ignore-errors
- error get-global
- "Hello" =
-] unit-test
-
-"!!! The following error is part of the test" print
-
-[ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test
-
-"!!! The following error is part of the test" print
-
-[ ] [ [ [ "2 car" ] eval ] try ] unit-test
-
-[ f throw ] must-fail
-
-! Weird PowerPC bug.
-[ ] [
- [ "4" throw ] ignore-errors
- gc
- gc
-] unit-test
-
-! ! See how well callstack overflow is handled
-! [ clear drop ] must-fail
-!
-! : callstack-overflow callstack-overflow f ;
-! [ callstack-overflow ] must-fail
-
-: don't-compile-me ( -- ) ;
-: foo ( -- ) callstack "c" set don't-compile-me ;
-: bar ( -- a b ) 1 foo 2 ;
-
-<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >>
-
-[ 1 2 ] [ bar ] unit-test
-
-[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test
-
-[ 1 ] [ "c" get innermost-frame-scan ] unit-test
-
-SYMBOL: always-counter
-SYMBOL: error-counter
-
-[
- 0 always-counter set
- 0 error-counter set
-
- [ ] [ always-counter inc ] [ error-counter inc ] cleanup
-
- [ 1 ] [ always-counter get ] unit-test
- [ 0 ] [ error-counter get ] unit-test
-
- [
- [ "a" throw ]
- [ always-counter inc ]
- [ error-counter inc ] cleanup
- ] [ "a" = ] must-fail-with
-
- [ 2 ] [ always-counter get ] unit-test
- [ 1 ] [ error-counter get ] unit-test
-
- [
- [ ]
- [ always-counter inc "a" throw ]
- [ error-counter inc ] cleanup
- ] [ "a" = ] must-fail-with
-
- [ 3 ] [ always-counter get ] unit-test
- [ 1 ] [ error-counter get ] unit-test
-] with-scope
-
-[ ] [ [ return ] with-return ] unit-test
-
-[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with
-
-[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test
-
-[ with-datastack ] must-infer
+USING: kernel math namespaces io tools.test sequences vectors\r
+continuations debugger parser memory arrays words\r
+kernel.private accessors eval ;\r
+IN: continuations.tests\r
+\r
+: (callcc1-test) ( n obj -- n' obj )\r
+ [ 1 - dup ] dip ?push\r
+ over 0 = [ "test-cc" get continue-with ] when\r
+ (callcc1-test) ;\r
+\r
+: callcc1-test ( x -- list )\r
+ [\r
+ "test-cc" set V{ } clone (callcc1-test)\r
+ ] callcc1 nip ;\r
+\r
+: callcc-namespace-test ( -- ? )\r
+ [\r
+ "test-cc" set\r
+ 5 "x" set\r
+ [\r
+ 6 "x" set "test-cc" get continue\r
+ ] with-scope\r
+ ] callcc0 "x" get 5 = ;\r
+\r
+[ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test\r
+[ t ] [ callcc-namespace-test ] unit-test\r
+\r
+[ 5 throw ] [ 5 = ] must-fail-with\r
+\r
+[ t ] [\r
+ [ "Hello" throw ] ignore-errors\r
+ error get-global\r
+ "Hello" =\r
+] unit-test\r
+\r
+"!!! The following error is part of the test" print\r
+\r
+[ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test\r
+\r
+"!!! The following error is part of the test" print\r
+\r
+[ ] [ [ [ "2 car" ] eval ] try ] unit-test\r
+\r
+[ f throw ] must-fail\r
+\r
+! Weird PowerPC bug.\r
+[ ] [\r
+ [ "4" throw ] ignore-errors\r
+ gc\r
+ gc\r
+] unit-test\r
+\r
+! ! See how well callstack overflow is handled\r
+! [ clear drop ] must-fail\r
+! \r
+! : callstack-overflow callstack-overflow f ;\r
+! [ callstack-overflow ] must-fail\r
+\r
+: don't-compile-me ( -- ) ;\r
+: foo ( -- ) callstack "c" set don't-compile-me ;\r
+: bar ( -- a b ) 1 foo 2 ;\r
+\r
+<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >>\r
+\r
+[ 1 2 ] [ bar ] unit-test\r
+\r
+[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test\r
+\r
+[ 1 ] [ "c" get innermost-frame-scan ] unit-test\r
+\r
+SYMBOL: always-counter\r
+SYMBOL: error-counter\r
+\r
+[\r
+ 0 always-counter set\r
+ 0 error-counter set\r
+\r
+ [ ] [ always-counter inc ] [ error-counter inc ] cleanup\r
+\r
+ [ 1 ] [ always-counter get ] unit-test\r
+ [ 0 ] [ error-counter get ] unit-test\r
+\r
+ [\r
+ [ "a" throw ]\r
+ [ always-counter inc ]\r
+ [ error-counter inc ] cleanup\r
+ ] [ "a" = ] must-fail-with\r
+\r
+ [ 2 ] [ always-counter get ] unit-test\r
+ [ 1 ] [ error-counter get ] unit-test\r
+\r
+ [\r
+ [ ]\r
+ [ always-counter inc "a" throw ]\r
+ [ error-counter inc ] cleanup\r
+ ] [ "a" = ] must-fail-with\r
+\r
+ [ 3 ] [ always-counter get ] unit-test\r
+ [ 1 ] [ error-counter get ] unit-test\r
+] with-scope\r
+\r
+[ ] [ [ return ] with-return ] unit-test\r
+\r
+[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with\r
+\r
+[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test\r
+\r
+[ with-datastack ] must-infer\r
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences namespaces assocs math accessors ;
IN: definitions
: changed-definition ( defspec -- )
dup changed-definitions get set-in-unit ;
-SYMBOL: changed-effects
+SYMBOL: maybe-changed
+
+: changed-conditionally ( class -- )
+ dup maybe-changed get set-in-unit ;
-SYMBOL: changed-generics
+SYMBOL: changed-effects
SYMBOL: outdated-generics
SYMBOL: new-words
-SYMBOL: new-classes
-
: new-word ( word -- )
dup new-words get set-in-unit ;
: new-word? ( word -- ? )
new-words get key? ;
-: new-class ( word -- )
- dup new-classes get set-in-unit ;
-
-: new-class? ( word -- ? )
- new-classes get key? ;
-
GENERIC: where ( defspec -- loc )
M: object where drop f ;
\ check-method boa throw
] unless ; inline
-: changed-generic ( class generic -- )
- changed-generics get
- [ [ [ class-or ] when* ] change-at ] [ no-compilation-unit ] if* ;
-
: remake-generic ( generic -- )
dup outdated-generics get set-in-unit ;
: remake-generics ( -- )
outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
+GENERIC: update-generic ( class generic -- )
+
: with-methods ( class generic quot -- )
- [ drop changed-generic ]
- [ [ "methods" word-prop ] dip call ]
- [ drop remake-generic drop ]
- 3tri ; inline
+ [ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
: method-word-name ( class generic -- string )
[ name>> ] bi@ "=>" glue ;
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
+M: method-body flushable?
+ "method-generic" word-prop flushable? ;
+
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
[ call-next-method ] bi
] if ;
-M: sequence update-methods ( class seq -- )
- implementors [
- [ changed-generic ] [ remake-generic drop ] 2bi
- ] with each ;
-
: define-generic ( word combination effect -- )
[ nip swap set-stack-effect ]
[
[ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
[ error>> bad-dispatch-position? ]
must-fail-with
+
+[ ] [ "IN: generic.single.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test
+ [ "IN: generic.single.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.algebra
combinators definitions generic hashtables kernel
PREDICATE: single-generic < generic
"combination" word-prop single-combination? ;
+M: single-generic make-inline cannot-be-inline ;
+
GENERIC: dispatch# ( word -- n )
M: generic dispatch# "combination" word-prop dispatch# ;
HELP: null
{ $class-description
"The canonical empty class with no instances."
+}
+{ $notes
+ "Unlike " { $snippet "null" } " in Java or " { $snippet "NULL" } " in C++, this is not a value signifying empty, or nothing. Use " { $link f } " for this purpose."
} ;
HELP: most
HELP: next-power-of-2
{ $values { "m" "a non-negative integer" } { "n" "an integer" } }
-{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ;
+{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 2." } ;
HELP: power-of-2?
{ $values { "n" integer } { "?" "a boolean" } }
: with-file-vocabs ( quot -- )
[
- <manifest> manifest set
"syntax" use-vocab
bootstrap-syntax get [ use-words ] when*
call
- ] with-scope ; inline
+ ] with-manifest ; inline
SYMBOL: print-use-hook
definitions ;
: record-top-level-form ( quot file -- )
- (>>top-level-form) H{ } notify-definition-observers ;
+ (>>top-level-form)
+ [ ] [ H{ } notify-definition-observers ] if-bootstrapping ;
: record-checksum ( lines source-file -- )
[ crc32 checksum-lines ] dip (>>checksum) ;
IN: vocabs.parser.tests
-USING: vocabs.parser tools.test eval kernel accessors ;
+USING: vocabs.parser tools.test eval kernel accessors definitions
+compiler.units words vocabs ;
[ "FROM: kernel => doesnotexist ;" eval( -- ) ]
[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
[ "RENAME: doesnotexist kernel => newname" eval( -- ) ]
[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
-must-fail-with
\ No newline at end of file
+must-fail-with
+
+: aaa ( -- ) ;
+
+[
+ [ ] [ "aaa" "vocabs.parser.tests" "uutt" add-renamed-word ] unit-test
+
+ [ ] [ "vocabs.parser.tests" dup add-qualified ] unit-test
+
+ [ aaa ] [ "uutt" search ] unit-test
+ [ aaa ] [ "vocabs.parser.tests:aaa" search ] unit-test
+
+ [ ] [ [ "bbb" "vocabs.parser.tests" create drop ] with-compilation-unit ] unit-test
+
+ [ "bbb" ] [ "vocabs.parser.tests:bbb" search name>> ] unit-test
+
+ [ ] [ [ \ aaa forget ] with-compilation-unit ] unit-test
+
+ [ ] [ [ "bbb" "vocabs.parser.tests" lookup forget ] with-compilation-unit ] unit-test
+
+ [ f ] [ "uutt" search ] unit-test
+
+ [ f ] [ "vocabs.parser.tests:aaa" search ] unit-test
+
+ [ ] [ "vocabs.parser.tests.foo" set-current-vocab ] unit-test
+
+ [ ] [ [ "bbb" current-vocab create drop ] with-compilation-unit ] unit-test
+
+ [ t ] [ "bbb" search >boolean ] unit-test
+
+ [ ] [ [ "vocabs.parser.tests.foo" forget-vocab ] with-compilation-unit ] unit-test
+
+ [ [ "bbb" current-vocab create drop ] with-compilation-unit ] [ error>> no-current-vocab? ] must-fail-with
+
+ [ begin-private ] [ error>> no-current-vocab? ] must-fail-with
+
+ [ end-private ] [ error>> no-current-vocab? ] must-fail-with
+
+ [ f ] [ "bbb" search >boolean ] unit-test
+
+] with-manifest
\ No newline at end of file
-! Copyright (C) 2007, 2009 Daniel Ehrenberg, Bruno Deferrari,
+! Copyright (C) 2007, 2010 Daniel Ehrenberg, Bruno Deferrari,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel namespaces sequences
sets strings vocabs sorting accessors arrays compiler.units
-combinators vectors splitting continuations math
+combinators vectors splitting continuations math words
parser.notes ;
IN: vocabs.parser
{ search-vocab-names hashtable }
{ search-vocabs vector }
{ qualified-vocabs vector }
-{ extra-words vector }
{ auto-used vector } ;
: <manifest> ( -- manifest )
H{ } clone >>search-vocab-names
V{ } clone >>search-vocabs
V{ } clone >>qualified-vocabs
- V{ } clone >>extra-words
V{ } clone >>auto-used ;
M: manifest clone
[ clone ] change-search-vocab-names
[ clone ] change-search-vocabs
[ clone ] change-qualified-vocabs
- [ clone ] change-extra-words
[ clone ] change-auto-used ;
TUPLE: extra-words words ;
: (from) ( vocab words -- vocab words words' vocab )
2dup swap load-vocab ;
-: extract-words ( seq vocab -- assoc' )
+: extract-words ( seq vocab -- assoc )
[ words>> extract-keys dup ] [ name>> ] bi
[ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
+: excluding-words ( seq vocab -- assoc )
+ [ nip words>> ] [ extract-words ] 2bi assoc-diff ;
+
+: qualified-words ( prefix vocab -- assoc )
+ words>> swap [ swap [ swap ":" glue ] dip ] curry assoc-map ;
+
: (lookup) ( name assoc -- word/f )
at dup forward-reference? [ drop f ] when ;
: set-current-vocab ( name -- )
create-vocab
- [ manifest get (>>current-vocab) ]
- [ words>> <extra-words> (add-qualified) ] bi ;
+ [ manifest get (>>current-vocab) ] [ (add-qualified) ] bi ;
: with-current-vocab ( name quot -- )
manifest get clone manifest [
manifest get current-vocab>> [ no-current-vocab ] unless* ;
: begin-private ( -- )
- manifest get current-vocab>> vocab-name ".private" ?tail
+ current-vocab name>> ".private" ?tail
[ drop ] [ ".private" append set-current-vocab ] if ;
: end-private ( -- )
- manifest get current-vocab>> vocab-name ".private" ?tail
+ current-vocab name>> ".private" ?tail
[ set-current-vocab ] [ drop ] if ;
: using-vocab? ( vocab -- ? )
TUPLE: qualified vocab prefix words ;
: <qualified> ( vocab prefix -- qualified )
- 2dup
- [ load-vocab words>> ] [ CHAR: : suffix ] bi*
- [ swap [ prepend ] dip ] curry assoc-map
- qualified boa ;
+ (from) qualified-words qualified boa ;
: add-qualified ( vocab prefix -- )
<qualified> (add-qualified) ;
TUPLE: exclude vocab names words ;
: <exclude> ( vocab words -- from )
- (from) [ nip words>> ] [ extract-words ] 2bi assoc-diff exclude boa ;
+ (from) excluding-words exclude boa ;
: add-words-excluding ( vocab words -- )
<exclude> (add-qualified) ;
: search ( name -- word/f )
manifest get search-manifest ;
+
+<PRIVATE
+
+GENERIC: update ( search-path-elt -- valid? )
+
+: trim-forgotten ( qualified-vocab -- valid? )
+ [ [ nip "forgotten" word-prop not ] assoc-filter ] change-words
+ words>> assoc-empty? not ;
+
+M: from update trim-forgotten ;
+M: rename update trim-forgotten ;
+M: extra-words update trim-forgotten ;
+M: exclude update trim-forgotten ;
+
+M: qualified update
+ dup vocab>> vocab [
+ dup [ prefix>> ] [ vocab>> load-vocab ] bi qualified-words
+ >>words
+ ] [ drop f ] if ;
+
+M: vocab update dup name>> vocab eq? ;
+
+: update-manifest ( manifest -- )
+ [ dup [ name>> vocab ] when ] change-current-vocab
+ [ [ drop vocab ] assoc-filter ] change-search-vocab-names
+ dup search-vocab-names>> keys [ vocab ] V{ } map-as >>search-vocabs
+ qualified-vocabs>> [ update ] filter! drop ;
+
+M: manifest definitions-changed ( assoc manifest -- )
+ nip update-manifest ;
+
+PRIVATE>
+
+: with-manifest ( quot -- )
+ <manifest> manifest [
+ [ call ] [
+ [ manifest get add-definition-observer call ]
+ [ manifest get remove-definition-observer ]
+ [ ]
+ cleanup
+ ] if-bootstrapping
+ ] with-variable ; inline
[ { } ]
[
all-words [
- "compiled-uses" word-prop 2 <groups>
- keys [ "forgotten" word-prop ] filter
+ [ "effect-dependencies" word-prop ]
+ [ "definition-dependencies" word-prop ]
+ [ "conditional-dependencies" word-prop ] tri
+ 3append [ "forgotten" word-prop ] filter
] map harvest
] unit-test
: make-deprecated ( word -- )
t "deprecated" set-word-prop ;
-: make-inline ( word -- )
+ERROR: cannot-be-inline word ;
+
+GENERIC: make-inline ( word -- )
+
+M: word make-inline
dup inline? [ drop ] [
[ t "inline" set-word-prop ]
[ changed-effect ]
: define-inline ( word def effect -- )
[ define-declared ] [ 2drop make-inline ] 3bi ;
+GENERIC: flushable? ( word -- ? )
+
+M: word flushable? "flushable" word-prop ;
+
GENERIC: reset-word ( word -- )
M: word reset-word
+ dup flushable? [ dup changed-conditionally ] when
{
"unannotated-def" "parsing" "inline" "recursive"
"foldable" "flushable" "reading" "writing" "reader"
: create ( name vocab -- word )
check-create 2dup lookup
- dup [ 2nip ] [ drop vocab-name <word> dup reveal ] if ;
+ dup [ 2nip ] [
+ drop
+ vocab-name <word>
+ dup reveal
+ dup changed-definition
+ ] if ;
: constructor-word ( name vocab -- word )
[ "<" ">" surround ] dip create ;
[ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
} 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
+:: (bind-float-vertex-attribute) ( program-instance ptr name dim gl-type normalize? stride offset -- )
+ program-instance name attribute-index :> idx
+ idx 0 >= [
+ idx glEnableVertexAttribArray
+ idx dim gl-type normalize? stride offset ptr <displaced-alien> glVertexAttribPointer
+ ] when ; inline
+
+:: (bind-int-vertex-attribute) ( program-instance ptr name dim gl-type stride offset -- )
+ program-instance name attribute-index :> idx
+ idx 0 >= [
+ idx glEnableVertexAttribArray
+ idx dim gl-type stride offset ptr <displaced-alien> glVertexAttribIPointer
+ ] when ; inline
+
:: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
vertex-attribute name>> hyphens>underscores :> name
vertex-attribute component-type>> :> type
{ [ name not ] [ [ 2drop ] ] }
{
[ type unnormalized-integer-components? ]
- [
- {
- name attribute-index [ glEnableVertexAttribArray ] keep
- dim gl-type stride offset
- } >quotation :> dip-block
-
- { dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
- ]
+ [ { name dim gl-type stride offset (bind-int-vertex-attribute) } >quotation ]
}
- [
- {
- name attribute-index [ glEnableVertexAttribArray ] keep
- dim gl-type normalize? stride offset
- } >quotation :> dip-block
-
- { dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
- ]
+ [ { name dim gl-type normalize? stride offset (bind-float-vertex-attribute) } >quotation ]
} cond ;
:: [bind-vertex-format] ( vertex-attributes -- quot )
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors byte-arrays fry images kernel locals math
+math.functions math.order math.vectors namespaces sequences
+sorting ;
+IN: images.atlas
+
+! sort rects by height/width/whatever
+! use least power of two greater than k * greatest width for atlas width
+! pack stripes(y 0):
+! place first rect at x 0
+! place rects that fit in remaining stripe
+! pack stripes(y + height)
+! if height > max height
+
+TUPLE: image-placement
+ { image read-only }
+ loc ;
+
+CONSTANT: atlas-waste-factor 1.25
+CONSTANT: atlas-padding 1
+
+ERROR: atlas-image-formats-dont-match images ;
+
+<PRIVATE
+
+: width ( dim -- width ) first atlas-padding + ; inline
+: height ( dim -- height ) second atlas-padding + ; inline
+: area ( dim -- area ) [ width ] [ height ] bi * ; inline
+
+:: (pack-stripe) ( image-placements atlas-width @y -- stripe-height/f )
+ 0 :> @x!
+ f :> stripe-height!
+ image-placements [| ip |
+ ip loc>> [
+ ip image>> dim>> :> dim
+ stripe-height [ dim height stripe-height 0 or max stripe-height! ] unless
+ dim width :> w
+ atlas-width w @x + >= [
+ ip { @x @y } >>loc drop
+ @x w + @x!
+ ] when
+ ] unless
+ ] each
+ stripe-height ;
+
+:: (pack-images) ( images atlas-width sort-quot -- placements )
+ images sort-quot inv-sort-with [ f image-placement boa ] map :> image-placements
+ 0 :> @y!
+ [ image-placements atlas-width @y (pack-stripe) dup ] [ @y + @y! ] while drop
+ image-placements ; inline
+
+: atlas-image-format ( image-placements -- component-order component-type upside-down? )
+ [ image>> ] map dup unclip '[ _
+ [ [ component-order>> ] bi@ = ]
+ [ [ component-type>> ] bi@ = ]
+ [ [ upside-down?>> ] bi@ = ] 2tri and and
+ ] all?
+ [ first [ component-order>> ] [ component-type>> ] [ upside-down?>> ] tri ]
+ [ atlas-image-formats-dont-match ] if ; inline
+
+: atlas-dim ( image-placements -- dim )
+ [ [ loc>> ] [ image>> dim>> ] bi v+ atlas-padding v+n ] [ vmax ] map-reduce
+ [ next-power-of-2 ] map ; inline
+
+:: <atlas-image> ( image-placements component-order component-type upside-down? -- atlas )
+ image-placements atlas-dim :> dim
+ <image>
+ dim >>dim
+ component-order >>component-order
+ component-type >>component-type
+ upside-down? >>upside-down?
+ dim product component-order component-type (bytes-per-pixel) * <byte-array> >>bitmap ; inline
+
+:: copy-image-into-atlas ( image-placement atlas -- )
+ image-placement image>> :> image
+ image dim>> first2 :> ( w h )
+ image-placement loc>> first2 :> ( x y )
+
+ h iota [| row |
+ 0 row w image pixel-row-slice-at
+ x y row + w atlas set-pixel-row-at
+ ] each ; inline
+
+: copy-images-into-atlas ( image-placements atlas -- )
+ '[ _ copy-image-into-atlas ] each ; inline
+
+PRIVATE>
+
+: (guess-atlas-dim) ( images -- width )
+ [ dim>> area ] [ + ] map-reduce sqrt
+ atlas-waste-factor *
+ .5 + >integer ;
+
+: guess-atlas-dim ( images -- width )
+ [ (guess-atlas-dim) ] [ [ dim>> width ] [ max ] map-reduce ] bi max next-power-of-2 ;
+
+: pack-images ( images atlas-width -- placements )
+ [ dim>> second ] (pack-images) ;
+
+: pack-atlas ( images -- image-placements )
+ dup guess-atlas-dim pack-images ;
+
+: (make-atlas) ( image-placements -- image )
+ dup dup atlas-image-format <atlas-image> [ copy-images-into-atlas ] keep ;
+
+: make-atlas ( images -- image-placements atlas-image )
+ pack-atlas dup (make-atlas) ;
--- /dev/null
+Tool for generating an atlas image from an array of images
}
};
+struct code_block_become_visitor {
+ slot_visitor<slot_become_visitor> *workhorse;
+
+ explicit code_block_become_visitor(slot_visitor<slot_become_visitor> *workhorse_) :
+ workhorse(workhorse_) {}
+
+ void operator()(code_block *compiled, cell size)
+ {
+ workhorse->visit_code_block_objects(compiled);
+ workhorse->visit_embedded_literals(compiled);
+ }
+};
+
+struct code_block_write_barrier_visitor {
+ code_heap *code;
+
+ explicit code_block_write_barrier_visitor(code_heap *code_) :
+ code(code_) {}
+
+ void operator()(code_block *compiled, cell size)
+ {
+ code->write_barrier(compiled);
+ }
+};
+
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
to coalesce equal but distinct quotations and wrappers. */
void factor_vm::primitive_become()
}
/* Update all references to old objects to point to new objects */
- slot_visitor<slot_become_visitor> workhorse(this,slot_become_visitor(&become_map));
- workhorse.visit_roots();
- workhorse.visit_contexts();
+ {
+ slot_visitor<slot_become_visitor> workhorse(this,slot_become_visitor(&become_map));
+ workhorse.visit_roots();
+ workhorse.visit_contexts();
- object_become_visitor object_visitor(&workhorse);
- each_object(object_visitor);
+ object_become_visitor object_visitor(&workhorse);
+ each_object(object_visitor);
+
+ code_block_become_visitor code_block_visitor(&workhorse);
+ each_code_block(code_block_visitor);
+ }
/* Since we may have introduced old->new references, need to revisit
- all objects on a minor GC. */
+ all objects and code blocks on a minor GC. */
data->mark_all_cards();
- primitive_minor_gc();
+
+ {
+ code_block_write_barrier_visitor code_block_visitor(code);
+ each_code_block(code_block_visitor);
+ }
}
}
projects / factor.git / commitdiff