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

Merge branch 'master' of git://github.com/slavapestov/factor

db4
Erik Charlebois 2010-01-29 15:57:31 -08:00
parent e44973e2c7 36618bc46e
commit 1c8b4f08a4
54 changed files with 1110 additions and 774 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/combinators/smart/smart-tests.factor
View File

@ -1,6 +1,7 @@
! 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 )
@ -59,3 +60,6 @@ IN: combinators.smart.tests
[ 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

3
basis/combinators/smart/smart.factor
View File

@ -51,3 +51,6 @@ MACRO: nullary ( quot -- quot' )
MACRO: smart-if ( pred true false -- )
'[ _ preserving _ _ if ] ;
MACRO: smart-apply ( quot n -- )
[ dup inputs ] dip '[ _ _ mnapply ] ;

35
basis/compiler/compiler.factor
View File

@ -3,18 +3,16 @@
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
@ -40,19 +38,18 @@ SYMBOL: compiled
: 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 -- ? )
@ -88,15 +85,15 @@ M: word combinator? inline? ;
[ compiled-unxref ]
[
dup crossref? [
dependencies get
generic-dependencies get
compiled-xref
[ dependencies get generic-dependencies get compiled-xref ]
[ conditional-dependencies get save-conditional-dependencies ]
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 )
@ -183,6 +180,14 @@ t compile-dependencies? set-global
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 forgotten-class?
[ drop f ] [ _ classes-intersect? ] if
] assoc-filter keys ;
M: optimizing-compiler recompile ( words -- alist )
[
<hashed-dlist> compile-queue set
@ -198,7 +203,7 @@ M: optimizing-compiler recompile ( words -- alist )
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

115
basis/compiler/crossref/crossref.factor
View File

@ -1,8 +1,8 @@
! 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
@ -13,56 +13,99 @@ SYMBOL: compiled-generic-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 ;
: compiled-generic-usages ( assoc -- assocs )
[ (compiled-generic-usages) ] { } assoc>map ;
: set-compiled-generic-uses ( word alist -- )
concat f like "compiled-generic-uses" set-word-prop ;
: (compiled-xref) ( word dependencies word-prop variable -- )
[ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ;
: 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 ;
: store-dependencies ( word assoc -- )
split-dependencies
"effect-dependencies" "definition-dependencies" "conditional-dependencies"
[ (store-dependencies) ] tri-curry@ tri-curry* tri ;
: (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 ]
[ "definition-dependencies" word-prop ]
[ "conditional-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 ]
[ "definition-dependencies" remove-word-prop ]
[ "conditional-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 ;
: save-conditional-dependencies ( word deps -- )
keys f like "dependency-checks" set-word-prop ;

97
basis/compiler/tests/redefine10.factor
View File

@ -1,26 +1,83 @@
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.
! Mixin redefinition should update predicate call sites
[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
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 ;
[ ] [
"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
GENERIC: fake-float? ( obj -- ? )
[ ] [
"USE: math
IN: compiler.tests.redefine10
INSTANCE: float my-mixin"
eval( -- )
] unit-test
M: float fake-float? drop t ;
M: object fake-float? drop f ;
[ 2.0 ] [
1.0 "my-inline" "compiler.tests.redefine10" lookup execute
] unit-test
: 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

25
basis/compiler/tests/redefine18.factor Normal file
View File

@ -0,0 +1,25 @@
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

23
basis/compiler/tests/redefine19.factor Normal file
View File

@ -0,0 +1,23 @@
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

23
basis/compiler/tests/redefine20.factor Normal file
View File

@ -0,0 +1,23 @@
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

22
basis/compiler/tree/builder/builder.factor
View File

@ -50,17 +50,11 @@ PRIVATE>
[ 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 ;
[
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 ;

39
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -1,4 +1,4 @@
! 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
@ -36,32 +36,51 @@ GENERIC: cleanup* ( node -- node/nodes )
#! 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 -- ? )

10
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -9,14 +9,6 @@ compiler.tree.propagation.info
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 [
@ -98,7 +90,7 @@ M: #push remove-dead-code*
] [ drop f ] if ;
: remove-flushable-call ( #call -- node )
[ word>> flushed-dependency depends-on ]
[ word>> depends-on-flushable ]
[ in-d>> #drop remove-dead-code* ]
bi ;

13
basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
View File

@ -79,3 +79,16 @@ TUPLE: a-tuple x ;
[ ] [ "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

13
basis/compiler/tree/propagation/call-effect/call-effect.factor
View File

@ -2,14 +2,19 @@
! 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.
@ -58,7 +63,7 @@ M: compose cached-effect
[ 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

2
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -318,7 +318,7 @@ generic-comparison-ops [
dup literal>> class?
[
literal>>
[ inlined-dependency depends-on ]
[ depends-on-conditionally ]
[ predicate-output-infos ]
bi
] [ 2drop object-info ] if

7
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -36,7 +36,7 @@ M: #declare propagate-before
#! 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 ;
@ -110,8 +110,9 @@ M: #declare propagate-before
#! 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

12
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -163,10 +163,12 @@ ERROR: bad-partial-eval quot word ;
: 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
@ -293,6 +295,6 @@ CONSTANT: lookup-table-at-max 256
! 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

5
basis/generalizations/generalizations-tests.factor
View File

@ -108,3 +108,8 @@ IN: generalizations.tests
2 1 0 -1 [ + ] [ - ] [ * ] [ / ] 4 spread-curry 4 spread*
] unit-test
[ { 1 2 } { 3 4 } { 5 6 } ]
[ 1 2 3 4 5 6 [ 2array ] 2 3 mnapply ] unit-test
[ { 1 2 3 } { 4 5 6 } ]
[ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test

4
basis/generalizations/generalizations.factor
View File

@ -124,6 +124,10 @@ MACRO: cleave* ( n -- )
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 ] ;

8
basis/grouping/grouping.factor
View File

@ -1,4 +1,4 @@
! 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 ;
@ -20,14 +20,16 @@ M: chunking-seq set-nth group@ <slice> 0 swap copy ;
M: chunking-seq like drop { } like ; inline
INSTANCE: chunking-seq sequence
MIXIN: subseq-chunking
INSTANCE: subseq-chunking sequence
M: subseq-chunking nth group@ subseq ; inline
MIXIN: slice-chunking
INSTANCE: slice-chunking sequence
M: slice-chunking nth group@ <slice> ; inline
M: slice-chunking nth-unsafe group@ slice boa ; inline

7
basis/hints/hints.factor
View File

@ -41,18 +41,13 @@ M: object specializer-declaration class ;
: 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* ;

2
basis/images/jpeg/jpeg.factor
View File

@ -287,7 +287,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: decode-macroblock ( -- blocks )
jpeg> components>>
[
[ mb-dim first2 * iota ]
[ mb-dim first2 * ]
[ [ decode-block ] curry replicate ] bi
] map concat ;

2
basis/macros/macros.factor
View File

@ -32,4 +32,4 @@ 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 ;

25
basis/random/windows/windows.factor
View File

@ -1,7 +1,8 @@
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 ;
@ -58,13 +59,23 @@ M: windows-rng random-bytes* ( n tuple -- bytes )
[ CryptGenRandom win32-error=0/f ] keep
] with-destructors ;
[
MS_DEF_PROV
PROV_RSA_FULL <windows-rng> system-random-generator set-global
ERROR: no-windows-crypto-provider error ;
[ 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
: try-crypto-providers ( seq -- windows-rng )
[ first2 <windows-rng> ] attempt-all
dup windows-rng? [ no-windows-crypto-provider ] unless ;
[
{
${ 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 }
${ MS_ENH_RSA_AES_PROV PROV_RSA_AES }
} try-crypto-providers secure-random-generator set-global
] "random.windows" add-startup-hook
[

2
basis/stack-checker/backend/backend.factor
View File

@ -74,7 +74,7 @@ GENERIC: apply-object ( obj -- )
M: wrapper apply-object
wrapped>>
[ dup word? [ called-dependency depends-on ] [ drop ] if ]
[ dup word? [ depends-on-effect ] [ drop ] if ]
[ push-literal ]
bi ;

36
basis/stack-checker/dependencies/dependencies-tests.factor
View File

@ -1,37 +1 @@
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

105
basis/stack-checker/dependencies/dependencies.factor
View File

@ -1,23 +1,24 @@
! 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 ;
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 ] [
@ -26,12 +27,96 @@ SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
] [ 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>> ] [ class2>> ] bi class<= ;
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>> ] [ class2>> ] bi classes-intersect? not ;
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>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ;
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>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ;
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

2
basis/stack-checker/inlining/inlining.factor
View File

@ -140,7 +140,7 @@ SYMBOL: enter-out
: inline-word ( word -- )
commit-literals
[ inlined-dependency depends-on ]
[ depends-on-definition ]
[
dup inline-recursive-label [
call-recursive-inline-word

2
basis/stack-checker/known-words/known-words.factor
View File

@ -273,7 +273,7 @@ M: bad-executable summary
\ 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 ] }

24
basis/stack-checker/transforms/transforms.factor
View File

@ -124,15 +124,15 @@ IN: stack-checker.transforms
\ 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
@ -140,10 +140,10 @@ IN: stack-checker.transforms
! 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

4
basis/tools/deploy/shaker/shaker.factor
View File

@ -1,4 +1,4 @@
! 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
@ -128,6 +128,7 @@ IN: tools.deploy.shaker
"combination"
"compiled-generic-uses"
"compiled-uses"
"conditional-dependencies"
"constant"
"constraints"
"custom-inlining"
@ -159,7 +160,6 @@ IN: tools.deploy.shaker
"members"
"memo-quot"
"methods"
"mixin"
"method-class"
"method-generic"
"modular-arithmetic"

2
basis/tools/profiler/profiler.factor
View File

@ -40,7 +40,7 @@ IN: tools.profiler
: 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 )

25
basis/typed/typed.factor
View File

@ -4,6 +4,7 @@ combinators.short-circuit definitions effects fry hints
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 ;
@ -31,6 +32,7 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
: (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
@ -49,7 +51,10 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
: (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' )
@ -75,7 +80,12 @@ DEFER: make-boxer
: 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 )
@ -84,18 +94,15 @@ DEFER: make-boxer
! 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 ;
@ -118,9 +125,9 @@ M: typed-gensym crossref?
[ 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 ;

3
core/bootstrap/primitives.factor
View File

@ -126,6 +126,9 @@ call( -- )
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 ;

15
core/classes/algebra/algebra-tests.factor
View File

@ -79,9 +79,9 @@ INSTANCE: union-with-one-member mixin-with-one-member
[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
[ t ] [ growable tuple sequence class-and class<= ] unit-test
[ f ] [ growable tuple sequence class-and class<= ] unit-test
[ t ] [ growable assoc class-and tuple class<= ] unit-test
[ f ] [ growable assoc class-and tuple class<= ] unit-test
[ t ] [ object \ f \ f class-not class-or class<= ] unit-test
@ -130,6 +130,14 @@ INSTANCE: union-with-one-member mixin-with-one-member
[ t ] [ a union-with-one-member class<= ] unit-test
[ f ] [ union-with-one-member class-not integer class<= ] unit-test
MIXIN: empty-mixin
[ f ] [ empty-mixin class-not null class<= ] unit-test
[ f ] [ empty-mixin null class<= ] unit-test
[ t ] [ array sequence vector class-not class-and class<= ] unit-test
[ f ] [ vector sequence vector class-not class-and class<= ] unit-test
! class-and
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
@ -146,8 +154,6 @@ INSTANCE: union-with-one-member mixin-with-one-member
[ t ] [ slice reversed null class-and* ] unit-test
[ t ] [ \ f class-not \ f null class-and* ] unit-test
[ t ] [ vector virtual-sequence null class-and* ] unit-test
[ t ] [ vector array class-not vector class-and* ] unit-test
! class-or
@ -160,6 +166,7 @@ INSTANCE: union-with-one-member mixin-with-one-member
! classes-intersect?
[ t ] [ both tuple classes-intersect? ] unit-test
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
[ t ] [ number vector class-or sequence classes-intersect? ] unit-test

28
core/classes/algebra/algebra.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
@ -34,22 +34,18 @@ DEFER: (class-or)
GENERIC: (flatten-class) ( class -- )
: normalize-class ( class -- class' )
{
{ [ dup members ] [ members <anonymous-union> normalize-class ] }
{ [ dup participants ] [ participants <anonymous-intersection> normalize-class ] }
[ ]
} cond ;
GENERIC: normalize-class ( class -- class' )
M: object normalize-class ;
PRIVATE>
GENERIC: valid-class? ( obj -- ? )
GENERIC: forgotten-class? ( obj -- ? )
M: class valid-class? drop t ;
M: anonymous-union valid-class? members>> [ valid-class? ] all? ;
M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;
M: anonymous-complement valid-class? class>> valid-class? ;
M: word valid-class? drop f ;
M: word forgotten-class? "forgotten" word-prop ;
M: anonymous-union forgotten-class? members>> [ forgotten-class? ] any? ;
M: anonymous-intersection forgotten-class? participants>> [ forgotten-class? ] any? ;
M: anonymous-complement forgotten-class? class>> forgotten-class? ;
: class<= ( first second -- ? )
class<=-cache get [ (class<=) ] 2cache ;
@ -93,6 +89,9 @@ M: word valid-class? drop f ;
: left-anonymous-union<= ( first second -- ? )
[ members>> ] dip [ class<= ] curry all? ;
: right-union<= ( first second -- ? )
members [ class<= ] with any? ;
: right-anonymous-union<= ( first second -- ? )
members>> [ class<= ] with any? ;
@ -117,7 +116,7 @@ M: word valid-class? drop f ;
[ class-not normalize-class ] map
<anonymous-union>
] }
[ <anonymous-complement> ]
[ drop object ]
} cond ;
: left-anonymous-complement<= ( first second -- ? )
@ -147,6 +146,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
{ [ over anonymous-union? ] [ left-anonymous-union<= ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
{ [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
{ [ dup members ] [ right-union<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union<= ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }

7
core/classes/builtin/builtin.factor
View File

@ -1,4 +1,4 @@
! 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
@ -20,11 +20,6 @@ M: object class tag type>class ; inline
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 ;

49
core/classes/classes.factor
View File

@ -1,4 +1,4 @@
! 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
@ -37,11 +37,16 @@ PREDICATE: class < word "class" word-prop ;
: 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 ;
@ -49,8 +54,7 @@ M: predicate reset-word
[ 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
@ -133,19 +137,24 @@ M: sequence implementors [ implementors ] gather ;
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>
@ -161,13 +170,7 @@ GENERIC: update-methods ( class seq -- )
[ 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

19
core/classes/intersection/intersection.factor
View File

@ -1,4 +1,4 @@
! 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
@ -8,6 +8,8 @@ IN: classes.intersection
PREDICATE: intersection-class < class
"metaclass" word-prop intersection-class eq? ;
<PRIVATE
: intersection-predicate-quot ( members -- quot )
[
[ drop t ]
@ -23,16 +25,14 @@ PREDICATE: intersection-class < class
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) ;
@ -47,3 +47,10 @@ M: 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 ;

4
core/classes/mixin/mixin-tests.factor
View File

@ -38,8 +38,8 @@ MIXIN: mx1
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( -- )

129
core/classes/mixin/mixin.factor
View File

@ -1,20 +1,81 @@
! 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 ;
TUPLE: check-mixin-class class ;
: check-mixin-class ( mixin -- mixin )
dup mixin-class? [
\ check-mixin-class boa throw
] unless ;
<PRIVATE
: redefine-mixin-class ( class members -- )
[ (define-union-class) ]
[ drop changed-conditionally ]
[ drop t "mixin" set-word-prop ]
2bi ;
2tri ;
: if-mixin-member? ( class mixin true false -- )
[ check-mixin-class 2dup members member-eq? ] 2dip if ; inline
: change-mixin-class ( class mixin quot -- )
[ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
swap redefine-mixin-class ; inline
: (add-mixin-instance) ( class mixin -- )
#! 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
[ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
[ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
M: mixin-class class-forgotten remove-mixin-instance ;
: define-mixin-class ( class -- )
dup mixin-class? [
@ -26,73 +87,19 @@ M: mixin-class rank-class drop 3 ;
tri
] if ;
TUPLE: check-mixin-class class ;
: check-mixin-class ( mixin -- mixin )
dup mixin-class? [
\ check-mixin-class boa throw
] unless ;
: if-mixin-member? ( class mixin true false -- )
[ check-mixin-class 2dup members member-eq? ] 2dip if ; inline
: change-mixin-class ( class mixin quot -- )
[ [ 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 ;
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 ;
: 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? ;
M: mixin-class class-forgotten remove-mixin-instance ;
! 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 ;

4
core/classes/parser/parser.factor
View File

@ -1,4 +1,4 @@
! 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
@ -9,7 +9,7 @@ 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 ;

6
core/classes/predicate/predicate.factor
View File

@ -1,4 +1,4 @@
! 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
@ -8,6 +8,8 @@ IN: classes.predicate
PREDICATE: predicate-class < class
"metaclass" word-prop predicate-class eq? ;
<PRIVATE
GENERIC: predicate-quot ( class -- quot )
M: predicate-class predicate-quot
@ -18,6 +20,8 @@ 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 ]

9
core/classes/singleton/singleton.factor
View File

@ -1,11 +1,16 @@
! 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 ]

5
core/classes/tuple/tuple-docs.factor
View File

@ -200,6 +200,8 @@ ARTICLE: "tuple-introspection" "Tuple introspection"
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" } ;
@ -348,8 +350,7 @@ HELP: tuple-class
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."

2
core/classes/tuple/tuple.factor
View File

@ -223,7 +223,7 @@ M: tuple-class update-class
2drop
[
[ update-tuples-after ]
[ changed-definition ]
[ changed-conditionally ]
bi
] each-subclass
]

20
core/classes/union/union.factor
View File

@ -1,13 +1,15 @@
! 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 ]
@ -24,15 +26,23 @@ PREDICATE: union-class < class
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) ;

44
core/compiler/units/units.factor
View File

@ -1,4 +1,4 @@
! 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
@ -43,6 +43,20 @@ PRIVATE>
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 )
@ -52,12 +66,14 @@ HOOK: process-forgotten-words 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 ;
@ -92,9 +108,9 @@ GENERIC: definitions-changed ( assoc obj -- )
! 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
@ -108,6 +124,7 @@ M: object bump-effect-counter* drop f ;
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 ( -- )
@ -117,9 +134,10 @@ M: object bump-effect-counter* drop f ;
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? [
@ -148,25 +166,23 @@ 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

548
core/continuations/continuations-docs.factor
View File

@ -1,274 +1,274 @@
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
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." } ;

216
core/continuations/continuations-tests.factor
View File

@ -1,108 +1,108 @@
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
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

17
core/definitions/definitions.factor
View File

@ -1,4 +1,4 @@
! 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
@ -15,28 +15,23 @@ SYMBOL: changed-definitions
: changed-definition ( defspec -- )
dup changed-definitions get set-in-unit ;
SYMBOL: changed-effects
SYMBOL: maybe-changed
SYMBOL: changed-generics
: changed-conditionally ( class -- )
dup maybe-changed get set-in-unit ;
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 ;

19
core/generic/generic.factor
View File

@ -87,21 +87,16 @@ TUPLE: check-method class generic ;
\ 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 ;
@ -109,6 +104,9 @@ TUPLE: check-method class generic ;
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 ;
@ -174,11 +172,6 @@ M: method-body forget*
[ 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 ]
[

3
core/kernel/kernel-docs.factor
View File

@ -672,6 +672,9 @@ HELP: object
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

5
core/words/words.factor
View File

@ -110,9 +110,14 @@ M: word make-inline
: 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"

32
extra/gpu/shaders/shaders.factor
View File

@ -128,6 +128,20 @@ TR: hyphens>underscores "-" "_" ;
[ 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
@ -141,23 +155,9 @@ TR: hyphens>underscores "-" "_" ;
{ [ 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 )