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

Bug fixes and cleanups

db4
Slava Pestov 2008-06-11 02:58:38 -05:00
parent 66e8af04a8
commit c95851e34f
53 changed files with 355 additions and 211 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/alien/compiler/compiler.factor
View File

@ -7,7 +7,7 @@ math.parser classes alien.arrays alien.c-types alien.strings
alien.structs alien.syntax cpu.architecture alien inspector
quotations assocs kernel.private threads continuations.private
libc combinators compiler.errors continuations layouts accessors
init ;
init sets ;
IN: alien.compiler
TUPLE: #alien-node < node return parameters abi ;
@ -339,7 +339,7 @@ SYMBOL: callbacks
[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
: register-callback ( word -- ) dup callbacks get set-at ;
: register-callback ( word -- ) callbacks get conjoin ;
M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;

7
core/assocs/assocs-docs.factor
View File

@ -79,7 +79,6 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
"Utility operations built up from the " { $link "assocs-protocol" } ":"
{ $subsection delete-at* }
{ $subsection delete-any }
{ $subsection rename-at }
{ $subsection change-at }
{ $subsection at+ }
@ -242,12 +241,6 @@ HELP: delete-at*
{ $description "Removes an entry from the assoc and outputs the previous value together with a boolean indicating whether it was present." }
{ $side-effects "assoc" } ;
HELP: delete-any
{ $values { "assoc" assoc } { "key" "a key" } { "value" "a value" } }
{ $description "Removes an undetermined entry from the assoc and outputs it." }
{ $errors "Throws an error if the assoc is empty." }
{ $notes "This word is useful when using an assoc as an unordered queue which requires constant-time membership tests. Entries are enqueued with " { $link set-at } " and dequeued with " { $link delete-any } "." } ;
HELP: rename-at
{ $values { "newkey" object } { "key" object } { "assoc" assoc } }
{ $description "Removes the values associated to " { $snippet "key" } " and re-adds it as " { $snippet "newkey" } ". Does nothing if the assoc does not contain " { $snippet "key" } "." }

6
core/assocs/assocs.factor
View File

@ -76,12 +76,6 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: rename-at ( newkey key assoc -- )
tuck delete-at* [ -rot set-at ] [ 3drop ] if ;
: delete-any ( assoc -- key value )
[
[ 2drop t ] assoc-find
[ "Assoc is empty" throw ] unless over
] keep delete-at ;
: assoc-empty? ( assoc -- ? )
assoc-size zero? ;

2
core/classes/classes.factor
View File

@ -99,8 +99,8 @@ M: word reset-class drop ;
: (define-class) ( word props -- )
>r
dup reset-class
dup class? [ dup new-class ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
dup word-props
r> assoc-union over set-word-props

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

@ -51,8 +51,12 @@ TUPLE: check-mixin-class mixin ;
#! updated by transitivity; the mixins usages appear in
#! class-usages of the member, now that it's been added.
[ 2drop ] [
[ [ suffix ] change-mixin-class ] 2keep drop
dup new-class? [ update-classes/new ] [ update-classes ] if
[ [ suffix ] change-mixin-class ] 2keep
tuck [ new-class? ] either? [
update-classes/new
] [
update-classes
] if
] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )

41
core/compiler/compiler.factor
View File

@ -4,20 +4,25 @@ USING: kernel namespaces arrays sequences io inference.backend
inference.state generator debugger words compiler.units
continuations vocabs assocs alien.compiler dlists optimizer
definitions math compiler.errors threads graphs generic
inference combinators ;
inference combinators dequeues search-dequeues ;
IN: compiler
: ripple-up ( word -- )
compiled-usage [ drop queue-compile ] assoc-each ;
SYMBOL: +failed+
: ripple-up ( words -- )
dup "compiled-effect" word-prop +failed+ eq?
[ usage [ word? ] filter ] [ compiled-usage keys ] if
[ queue-compile ] each ;
: ripple-up? ( word effect -- ? )
#! If the word has previously been compiled and had a
#! different stack effect, we have to recompile any callers.
swap "compiled-effect" word-prop [ = not ] keep and ;
: save-effect ( word effect -- )
[
over "compiled-effect" word-prop = [
dup "compiled-uses" word-prop
[ dup ripple-up ] when
] unless drop
]
[ "compiled-effect" set-word-prop ] 2bi ;
[ dupd ripple-up? [ ripple-up ] [ drop ] if ]
[ "compiled-effect" set-word-prop ]
2bi ;
: compile-begins ( word -- )
f swap compiler-error ;
@ -26,9 +31,10 @@ IN: compiler
[ swap compiler-error ]
[
drop
[ compiled-unxref ]
[ f swap compiled get set-at ]
[ f save-effect ]
bi
[ +failed+ save-effect ]
tri
] 2bi ;
: compile-succeeded ( effect word -- )
@ -40,6 +46,7 @@ IN: compiler
] tri ;
: (compile) ( word -- )
dup dup "compile-count" word-prop 0 or 1 + "compile-count" set-word-prop
[
H{ } clone dependencies set
@ -54,19 +61,15 @@ IN: compiler
} cleave
] curry with-return ;
: compile-loop ( assoc -- )
dup assoc-empty? [ drop ] [
dup delete-any drop (compile)
yield
compile-loop
] if ;
: compile-loop ( dequeue -- )
[ (compile) yield ] slurp-dequeue ;
: decompile ( word -- )
f 2array 1array t modify-code-heap ;
: optimized-recompile-hook ( words -- alist )
[
H{ } clone compile-queue set
<hashed-dlist> compile-queue set
H{ } clone compiled set
[ queue-compile ] each
compile-queue get compile-loop

4
core/compiler/tests/insane.factor Normal file
View File

@ -0,0 +1,4 @@
IN: compiler.tests
USING: words kernel inference alien.strings tools.test ;
[ ] [ \ if redefined [ string>alien ] infer. ] unit-test

14
core/compiler/tests/redefine.factor
View File

@ -1,14 +0,0 @@
IN: compiler.tests
USING: compiler tools.test math parser ;
GENERIC: method-redefine-test ( a -- b )
M: integer method-redefine-test 3 + ;
: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
[ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test

67
core/compiler/tests/redefine1.factor Normal file
View File

@ -0,0 +1,67 @@
IN: compiler.tests
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs ;
GENERIC: method-redefine-test ( a -- b )
M: integer method-redefine-test 3 + ;
: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
[ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test
[ ] [ [ fixnum \ method-redefine-test method forget ] with-compilation-unit ] unit-test
[ 6 ] [ method-redefine-test-1 ] unit-test
! Test ripple-up behavior
: hey ( -- ) ;
: there ( -- ) hey ;
[ t ] [ \ hey compiled? ] unit-test
[ t ] [ \ there compiled? ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ hey compiled? ] unit-test
[ f ] [ \ there compiled? ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
[ t ] [ \ there compiled? ] unit-test
! Just changing the stack effect didn't mark a word for recompilation
DEFER: change-effect
[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- b )" eval ] unit-test
{ 1 1 } [ change-effect ] must-infer-as
[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- )" eval ] unit-test
{ 1 0 } [ change-effect ] must-infer-as
: good ( -- ) ;
: bad ( -- ) good ;
: ugly ( -- ) bad ;
[ t ] [ \ good compiled? ] unit-test
[ t ] [ \ bad compiled? ] unit-test
[ t ] [ \ ugly compiled? ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ good compiled? ] unit-test
[ f ] [ \ bad compiled? ] unit-test
[ f ] [ \ ugly compiled? ] unit-test
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
[ t ] [ \ good compiled? ] unit-test
[ t ] [ \ bad compiled? ] unit-test
[ t ] [ \ ugly compiled? ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test

18
core/compiler/tests/redefine2.factor Normal file
View File

@ -0,0 +1,18 @@
IN: compiler.tests
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs ;
DEFER: blah
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: blah ; M: blah nth 2drop 3 ; INSTANCE: blah sequence" eval ] unit-test
[ t ] [ blah new sequence? ] unit-test
[ 3 ] [ 0 blah new nth-unsafe ] unit-test
[ ] [ [ blah sequence remove-mixin-instance ] with-compilation-unit ] unit-test
[ f ] [ blah new sequence? ] unit-test
[ 0 blah new nth-unsafe ] must-fail

32
core/compiler/tests/redefine3.factor Normal file
View File

@ -0,0 +1,32 @@
IN: compiler.tests
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs ;
GENERIC: sheeple ( obj -- x )
M: object sheeple drop "sheeple" ;
MIXIN: empty-mixin
M: empty-mixin sheeple drop "wake up" ;
: sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test compiled? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ t ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test compiled? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

6
core/compiler/tests/reload.factor Normal file
View File

@ -0,0 +1,6 @@
IN: compiler.tests
USE: vocabs.loader
"parser" reload
"sequences" reload
"kernel" reload

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

@ -79,9 +79,15 @@ SYMBOL: update-tuples-hook
: call-update-tuples-hook ( -- )
update-tuples-hook get call ;
: unxref-forgotten-definitions ( -- )
forgotten-definitions get
keys [ word? ] filter
[ delete-compiled-xref ] each ;
: finish-compilation-unit ( -- )
call-recompile-hook
call-update-tuples-hook
unxref-forgotten-definitions
dup [ drop crossref? ] assoc-contains? modify-code-heap ;
: with-nested-compilation-unit ( quot -- )

6
core/generator/generator.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer
optimizer.specializers prettyprint quotations sequences system
threads words vectors ;
threads words vectors sets dequeues ;
IN: generator
SYMBOL: compile-queue
@ -16,7 +16,7 @@ SYMBOL: compiled
{ [ dup compiled get key? ] [ drop ] }
{ [ dup inlined-block? ] [ drop ] }
{ [ dup primitive? ] [ drop ] }
[ dup compile-queue get set-at ]
[ compile-queue get push-front ]
} cond ;
: maybe-compile ( word -- )

38
core/generic/generic.factor
View File

@ -58,18 +58,17 @@ TUPLE: check-method class generic ;
: affected-methods ( class generic -- seq )
"methods" word-prop swap
[ nip classes-intersect? ] curry assoc-filter
[ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
values ;
: update-generic ( class generic -- )
[ affected-methods [ +called+ changed-definition ] each ]
[ make-generic ]
bi ;
affected-methods [ +called+ changed-definition ] each ;
: with-methods ( class generic quot -- )
[ drop update-generic ]
[ [ "methods" word-prop ] dip call ]
[ drop update-generic ] 3bi ;
inline
[ drop make-generic drop ]
3tri ; inline
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
@ -81,7 +80,7 @@ M: method-body stack-effect
"method-generic" word-prop stack-effect ;
M: method-body crossref?
drop t ;
"forgotten" word-prop not ;
: method-word-props ( class generic -- assoc )
[
@ -106,8 +105,8 @@ M: method-body crossref?
] if ;
: <default-method> ( generic combination -- method )
object bootstrap-word pick <method>
[ -rot make-default-method define ] keep ;
[ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
[ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
: define-default-method ( generic combination -- )
dupd <default-method> "default-method" set-word-prop ;
@ -137,13 +136,15 @@ M: method-body definer
M: method-body forget*
dup "forgotten" word-prop [ drop ] [
[
[ ]
[ "method-class" word-prop ]
[ "method-generic" word-prop ] tri
3dup method eq? [
[ delete-at ] with-methods
call-next-method
] [ 3drop ] if
dup "default" word-prop [ call-next-method ] [
dup
[ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
3dup method eq? [
[ delete-at ] with-methods
call-next-method
] [ 3drop ] if
] if
]
[ t "forgotten" set-word-prop ] bi
] if ;
@ -178,7 +179,10 @@ M: class forget* ( class -- )
[ call-next-method ] bi ;
M: assoc update-methods ( class assoc -- )
implementors [ update-generic ] with each ;
implementors [
[ update-generic ]
[ make-generic drop ] 2bi
] with each ;
: define-generic ( word combination -- )
over "combination" word-prop over = [

2
core/generic/standard/engines/tuple/tuple.factor
View File

@ -64,7 +64,7 @@ M: engine-word stack-effect
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
M: engine-word crossref? drop t ;
M: engine-word crossref? "forgotten" word-prop not ;
M: engine-word irrelevant? drop t ;

4
core/graphs/graphs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces sequences ;
USING: assocs kernel namespaces sequences sets ;
IN: graphs
SYMBOL: graph
@ -41,7 +41,7 @@ SYMBOL: previous
over previous get key? [
2drop
] [
over dup previous get set-at
over previous get conjoin
dup slip
[ nip (closure) ] curry assoc-each
] if ; inline

5
core/inference/backend/backend.factor
View File

@ -4,7 +4,8 @@ USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors
generic.standard.engines.tuple accessors math.order definitions ;
generic.standard.engines.tuple accessors math.order definitions
sets ;
IN: inference.backend
: recursive-label ( word -- label/f )
@ -28,7 +29,7 @@ SYMBOL: visited
: (redefined) ( word -- )
dup visited get key? [ drop ] [
[ reset-on-redefine reset-props ]
[ dup visited get set-at ]
[ visited get conjoin ]
[
crossref get at keys
[ word? ] filter

46
core/inference/inference-tests.factor
View File

@ -546,26 +546,26 @@ ERROR: custom-error ;
[ [ erg's-inference-bug ] infer ] must-fail
! : inference-invalidation-a ( -- );
! : inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
! : inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ;
!
! [ 7 ] [ 4 3 inference-invalidation-c ] unit-test
!
! { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
!
! [ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test
!
! [ 3 ] [ inference-invalidation-c ] unit-test
!
! { 0 1 } [ inference-invalidation-c ] must-infer-as
!
! GENERIC: inference-invalidation-d ( obj -- )
!
! M: object inference-invalidation-d inference-invalidation-c 2drop ;
!
! \ inference-invalidation-d must-infer
!
! [ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test
!
! [ [ inference-invalidation-d ] infer ] must-fail
: inference-invalidation-a ( -- ) ;
: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline
[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
[ ] [ "IN: inference.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test
[ 3 ] [ inference-invalidation-c ] unit-test
{ 0 1 } [ inference-invalidation-c ] must-infer-as
GENERIC: inference-invalidation-d ( obj -- )
M: object inference-invalidation-d inference-invalidation-c 2drop ;
\ inference-invalidation-d must-infer
[ ] [ "IN: inference.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test
[ [ inference-invalidation-d ] infer ] must-fail

5
core/inference/inference.factor
View File

@ -9,19 +9,22 @@ IN: inference
GENERIC: infer ( quot -- effect )
M: callable infer ( quot -- effect )
[ f infer-quot ] with-infer drop ;
[ recursive-state get infer-quot ] with-infer drop ;
: infer. ( quot -- )
#! Safe to call from inference transforms.
infer effect>string print ;
GENERIC: dataflow ( quot -- dataflow )
M: callable dataflow
#! Not safe to call from inference transforms.
[ f infer-quot ] with-infer nip ;
GENERIC# dataflow-with 1 ( quot stack -- dataflow )
M: callable dataflow-with
#! Not safe to call from inference transforms.
[
V{ } like meta-d set
f infer-quot

4
core/libc/libc.factor
View File

@ -3,7 +3,7 @@
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: alien assocs continuations destructors init kernel
namespaces accessors ;
namespaces accessors sets ;
IN: libc
<PRIVATE
@ -38,7 +38,7 @@ ERROR: realloc-error ptr size ;
[ H{ } clone mallocs set-global ] "libc" add-init-hook
: add-malloc ( alien -- )
dup mallocs get-global set-at ;
mallocs get-global conjoin ;
: delete-malloc ( alien -- )
[

2
core/parser/parser-tests.factor
View File

@ -421,8 +421,6 @@ must-fail-with
] unit-test
] times
[ ] [ "parser" reload ] unit-test
[ ] [
[ "this-better-not-exist" forget-vocab ] with-compilation-unit
] unit-test

4
core/prettyprint/sections/sections.factor
View File

@ -3,7 +3,7 @@
USING: arrays generic hashtables io kernel math assocs
namespaces sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
io.streams.nested accessors ;
io.streams.nested accessors sets ;
IN: prettyprint.sections
! State
@ -20,7 +20,7 @@ TUPLE: pprinter last-newline line-count indent ;
: <pprinter> ( -- pprinter ) 0 1 0 pprinter boa ;
: record-vocab ( word -- )
word-vocabulary [ dup pprinter-use get set-at ] when* ;
word-vocabulary [ pprinter-use get conjoin ] when* ;
! Utility words
: line-limit? ( -- ? )

1
core/search-dequeues/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

2
core/search-dequeues/search-dequeues-docs.factor
View File

@ -10,6 +10,8 @@ $nl
"Default implementation:"
{ $subsection <hashed-dlist> } ;
ABOUT: "search-dequeues"
HELP: <search-dequeue> ( assoc dequeue -- search-dequeue )
{ $values { "assoc" assoc } { "dequeue" dequeue } { "search-dequeue" search-dequeue } }
{ $description "Creates a new " { $link search-dequeue } "." } ;

1
core/search-dequeues/summary.txt Normal file
View File

@ -0,0 +1 @@
Double-ended queues with sub-linear membership testing

1
core/search-dequeues/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

3
core/sequences/sequences-tests.factor
View File

@ -243,6 +243,3 @@ unit-test
[ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
! Hardcore
[ ] [ "sequences" reload ] unit-test

10
core/syntax/syntax.factor
View File

@ -182,8 +182,14 @@ IN: bootstrap.syntax
] define-syntax
"(" [
")" parse-effect word
[ swap "declared-effect" set-word-prop ] [ drop ] if*
")" parse-effect
word dup [
swap
[ "declared-effect" set-word-prop ]
[ drop redefined ]
[ drop +inlined+ changed-definition ]
2tri
] [ 2drop ] if
] define-syntax
"((" [

2
core/threads/threads-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private io
threads.private continuations dlists init quotations strings
assocs heaps boxes namespaces ;
assocs heaps boxes namespaces dequeues ;
IN: threads
ARTICLE: "threads-start/stop" "Starting and stopping threads"

6
core/threads/threads.factor
View File

@ -4,7 +4,7 @@
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
dlists assocs system combinators init boxes accessors
math.order ;
math.order dequeues ;
IN: threads
SYMBOL: initial-thread
@ -86,7 +86,7 @@ PRIVATE>
: sleep-time ( -- ms/f )
{
{ [ run-queue dlist-empty? not ] [ 0 ] }
{ [ run-queue dequeue-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
[ sleep-queue heap-peek nip millis [-] ]
} cond ;
@ -146,7 +146,7 @@ DEFER: next
: next ( -- * )
expire-sleep-loop
run-queue dup dlist-empty? [
run-queue dup dequeue-empty? [
drop no-runnable-threads
] [
pop-back dup array? [ first2 ] [ f swap ] if (next)

13
core/words/words-tests.factor
View File

@ -183,3 +183,16 @@ SYMBOL: quot-uses-b
[ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test
[ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
[ { } ]
[
all-words [
"compiled-uses" word-prop
keys [ "forgotten" word-prop ] contains?
] filter
] unit-test
[ { } ] [
crossref get keys
[ word? ] filter [ "forgotten" word-prop ] filter
] unit-test

34
core/words/words.factor
View File

@ -80,8 +80,7 @@ GENERIC# (quot-uses) 1 ( obj assoc -- )
M: object (quot-uses) 2drop ;
M: word (quot-uses)
>r dup crossref? [ dup r> set-at ] [ r> 2drop ] if ;
M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ;
: seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
@ -103,12 +102,16 @@ compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
[ drop crossref? ] assoc-filter
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ;
[ "compiled-uses" set-word-prop ]
[ compiled-crossref get add-vertex* ]
2bi ;
: compiled-unxref ( word -- )
dup "compiled-uses" word-prop
compiled-crossref get remove-vertex* ;
[
dup "compiled-uses" word-prop
compiled-crossref get remove-vertex*
]
[ f "compiled-uses" set-word-prop ] bi ;
: delete-compiled-xref ( word -- )
dup compiled-unxref
@ -177,9 +180,10 @@ GENERIC: subwords ( word -- seq )
M: word subwords drop f ;
: reset-generic ( word -- )
dup subwords forget-all
dup reset-word
{ "methods" "combination" "default-method" } reset-props ;
[ subwords forget-all ]
[ reset-word ]
[ { "methods" "combination" "default-method" } reset-props ]
tri ;
: gensym ( -- word )
"( gensym )" f <word> ;
@ -216,12 +220,12 @@ M: word where "loc" word-prop ;
M: word set-where swap "loc" set-word-prop ;
M: word forget*
dup "forgotten" word-prop [
dup delete-xref
dup delete-compiled-xref
dup word-name over word-vocabulary vocab-words delete-at
dup t "forgotten" set-word-prop
] unless drop ;
dup "forgotten" word-prop [ drop ] [
[ delete-xref ]
[ [ word-name ] [ word-vocabulary vocab-words ] bi delete-at ]
[ t "forgotten" set-word-prop ]
tri
] if ;
M: word hashcode*
nip 1 slot { fixnum } declare ;

17
extra/concurrency/conditions/conditions.factor
View File

@ -1,21 +1,20 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists dlists.private threads kernel arrays sequences
alarms ;
USING: dequeues threads kernel arrays sequences alarms ;
IN: concurrency.conditions
: notify-1 ( dlist -- )
dup dlist-empty? [ drop ] [ pop-back resume-now ] if ;
: notify-1 ( dequeue -- )
dup dequeue-empty? [ drop ] [ pop-back resume-now ] if ;
: notify-all ( dlist -- )
[ resume-now ] dlist-slurp ;
: notify-all ( dequeue -- )
[ resume-now ] slurp-dequeue ;
: queue-timeout ( queue timeout -- alarm )
#! Add an alarm which removes the current thread from the
#! queue, and resumes it, passing it a value of t.
>r self over push-front* [
tuck delete-node
dlist-node-obj t swap resume-with
>r [ self swap push-front* ] keep [
[ delete-node ] [ drop node-value ] 2bi
t swap resume-with
] 2curry r> later ;
: wait ( queue timeout status -- )

4
extra/concurrency/locks/locks.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists kernel threads continuations math
USING: dequeues dlists kernel threads continuations math
concurrency.conditions ;
IN: concurrency.locks
@ -80,7 +80,7 @@ TUPLE: rw-lock readers writers reader# writer ;
: release-write-lock ( lock -- )
f over set-rw-lock-writer
dup rw-lock-readers dlist-empty?
dup rw-lock-readers dequeue-empty?
[ notify-writer ] [ rw-lock-readers notify-all ] if ;
: reentrant-read-lock-ok? ( lock -- ? )

9
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: concurrency.mailboxes
USING: dlists threads sequences continuations destructors
namespaces random math quotations words kernel arrays assocs
init system concurrency.conditions accessors debugger ;
USING: dlists dequeues threads sequences continuations
destructors namespaces random math quotations words kernel
arrays assocs init system concurrency.conditions accessors
debugger ;
TUPLE: mailbox threads data disposed ;
@ -13,7 +14,7 @@ M: mailbox dispose* threads>> notify-all ;
<dlist> <dlist> f mailbox boa ;
: mailbox-empty? ( mailbox -- bool )
data>> dlist-empty? ;
data>> dequeue-empty? ;
: mailbox-put ( obj mailbox -- )
[ data>> push-front ]

4
extra/concurrency/messaging/messaging-tests.factor
View File

@ -2,12 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel threads vectors arrays sequences
namespaces tools.test continuations dlists strings math words
namespaces tools.test continuations dequeues strings math words
match quotations concurrency.messaging concurrency.mailboxes
concurrency.count-downs accessors ;
IN: concurrency.messaging.tests
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
[ ] [ my-mailbox mailbox-data clear-dequeue ] unit-test
[ "received" ] [
[

22
extra/help/lint/lint.factor
View File

@ -5,7 +5,7 @@ words strings classes tools.vocabs namespaces io
io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate
macros combinators.lib sequences.lib math sets ;
macros math sets ;
IN: help.lint
: check-example ( element -- )
@ -46,16 +46,15 @@ IN: help.lint
: check-values ( word element -- )
{
[ over "declared-effect" word-prop ]
[ dup contains-funky-elements? not ]
[ over macro? not ]
{ [ over "declared-effect" word-prop ] [ 2drop ] }
{ [ dup contains-funky-elements? not ] [ 2drop ] }
{ [ over macro? not ] [ 2drop ] }
[
2dup extract-values >array
>r effect-values >array
r> assert=
t
[ effect-values >array ]
[ extract-values >array ]
bi* assert=
]
} 0&& 3drop ;
} cond ;
: check-see-also ( word element -- )
nip \ $see-also swap elements [
@ -114,7 +113,10 @@ M: help-error error.
vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
H{ } clone [
[
>r >r dup >link where ?first r> at r> [ ?push ] change-at
>r >r dup >link where dup
[ first r> at r> [ ?push ] change-at ]
[ r> r> 2drop 2drop ]
if
] 2curry each
] keep ;

4
extra/io/paths/paths.factor
View File

@ -1,5 +1,5 @@
USING: io.files kernel sequences accessors
dlists arrays sequences.lib ;
dlists dequeues arrays sequences.lib ;
IN: io.paths
TUPLE: directory-iterator path bfs queue ;
@ -18,7 +18,7 @@ TUPLE: directory-iterator path bfs queue ;
dup path>> over push-directory ;
: next-file ( iter -- file/f )
dup queue>> dlist-empty? [ drop f ] [
dup queue>> dequeue-empty? [ drop f ] [
dup queue>> pop-back first2
[ over push-directory next-file ] [ nip ] if
] if ;

25
extra/logging/logging.factor
View File

@ -4,7 +4,7 @@ USING: logging.server sequences namespaces concurrency.messaging
words kernel arrays shuffle tools.annotations
prettyprint.config prettyprint debugger io.streams.string
splitting continuations effects arrays.lib parser strings
combinators.lib quotations fry symbols accessors ;
quotations fry symbols accessors ;
IN: logging
SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
@ -42,21 +42,18 @@ SYMBOL: log-service
<PRIVATE
: one-string? ( obj -- ? )
{
[ dup array? ]
[ dup length 1 = ]
[ dup first string? ]
} 0&& nip ;
PREDICATE: one-string-array < array
[ length 1 = ] [ [ string? ] all? ] bi and ;
: stack>message ( obj -- inputs>message )
dup one-string? [ first ] [
H{
{ string-limit f }
{ line-limit 1 }
{ nesting-limit 3 }
{ margin 0 }
} clone [ unparse ] bind
dup one-string-array? [ first ] [
[
string-limit off
1 line-limit set
3 nesting-limit set
0 margin set
unparse
] with-scope
] if ;
PRIVATE>

5
extra/macros/macros-docs.factor
View File

@ -21,7 +21,7 @@ HELP: macro-expand
{ $values { "..." "inputs to a macro" } { "word" macro } { "quot" quotation } }
{ $description "Expands a macro. Useful for debugging." }
{ $examples
{ $code "{ [ dup integer? ] [ dup 0 > ] [ dup 13 mod zero? ] } \ && macro-expand ." }
{ $code "USING: math macros combinators.lib ;" "{ [ integer? ] [ 0 > ] [ 13 mod zero? ] } \ 1&& macro-expand ." }
} ;
ARTICLE: "macros" "Macros"
@ -31,9 +31,6 @@ $nl
{ $subsection POSTPONE: MACRO: }
"Expanding macros for debugging purposes:"
{ $subsection macro-expand }
! "Two sample macros which implement short-circuiting boolean operators (as found in C, Java and similar languages):"
! { $subsection && }
! { $subsection || }
"Macros are really just a very thin layer of syntax sugar over " { $link "compiler-transforms" } "." ;
ABOUT: "macros"

3
extra/macros/macros-tests.factor
View File

@ -12,3 +12,6 @@ unit-test
"USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval
[ \ see-test see ] with-string-writer =
] unit-test
[ ] [ "USING: macros inference kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test

2
extra/multi-methods/multi-methods.factor
View File

@ -154,7 +154,7 @@ M: method-body stack-effect
"multi-method-generic" word-prop stack-effect ;
M: method-body crossref?
drop t ;
"forgotten" word-prop not ;
: method-word-name ( specializer generic -- string )
[ word-name % "-" % unparse % ] "" make ;

1
extra/sequences/deep/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

1
extra/sequences/modified/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

1
extra/sequences/repeating/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

13
extra/serialize/serialize-tests.factor
View File

@ -4,7 +4,7 @@
USING: tools.test kernel serialize io io.streams.byte-array math
alien arrays byte-arrays sequences math prettyprint parser
classes math.constants io.encodings.binary random
combinators.lib assocs ;
assocs ;
IN: serialize.tests
: test-serialize-cell
@ -15,12 +15,11 @@ IN: serialize.tests
[ t ] [
100 [
drop
{
[ 40 [ test-serialize-cell ] all? ]
[ 4 [ 40 * test-serialize-cell ] all? ]
[ 4 [ 400 * test-serialize-cell ] all? ]
[ 4 [ 4000 * test-serialize-cell ] all? ]
} &&
40 [ test-serialize-cell ] all?
4 [ 40 * test-serialize-cell ] all?
4 [ 400 * test-serialize-cell ] all?
4 [ 4000 * test-serialize-cell ] all?
and and and
] all?
] unit-test

4
extra/tools/deploy/shaker/strip-debugger.factor
View File

@ -1,8 +1,8 @@
USING: kernel threads threads.private ;
IN: debugger
: print-error die ;
: print-error ( error -- ) die drop ;
: error. die ;
: error. ( error -- ) die drop ;
M: thread error-in-thread ( error thread -- ) die 2drop ;

8
extra/tools/deploy/shaker/strip-libc.factor
View File

@ -1,10 +1,10 @@
USING: libc.private ;
IN: libc
: malloc (malloc) check-ptr ;
: malloc ( size -- newalien ) (malloc) check-ptr ;
: realloc (realloc) check-ptr ;
: realloc ( alien size -- newalien ) (realloc) check-ptr ;
: calloc (calloc) check-ptr ;
: calloc ( size count -- newalien ) (calloc) check-ptr ;
: free (free) ;
: free ( alien -- ) (free) ;

14
extra/ui/gadgets/gadgets-tests.factor
View File

@ -1,6 +1,6 @@
IN: ui.gadgets.tests
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
namespaces models kernel dlists math sets
namespaces models kernel dlists dequeues math sets
math.parser ui sequences hashtables assocs io arrays
prettyprint io.streams.string ;
@ -130,26 +130,26 @@ M: mock-gadget ungraft*
[
<dlist> \ graft-queue [
[ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
[ t ] [ graft-queue dlist-empty? ] unit-test
[ t ] [ graft-queue dequeue-empty? ] unit-test
] with-variable
<dlist> \ graft-queue [
[ t ] [ graft-queue dlist-empty? ] unit-test
[ t ] [ graft-queue dequeue-empty? ] unit-test
<mock-gadget> "g" set
[ ] [ "g" get queue-graft ] unit-test
[ f ] [ graft-queue dlist-empty? ] unit-test
[ f ] [ graft-queue dequeue-empty? ] unit-test
[ { f t } ] [ "g" get gadget-graft-state ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ { f t } ] [ "g" get gadget-graft-state ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
[ { f f } ] [ "g" get gadget-graft-state ] unit-test
[ t ] [ graft-queue dlist-empty? ] unit-test
[ t ] [ graft-queue dequeue-empty? ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ ] [ notify-queued ] unit-test
[ { t t } ] [ "g" get gadget-graft-state ] unit-test
[ t ] [ graft-queue dlist-empty? ] unit-test
[ t ] [ graft-queue dequeue-empty? ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
@ -185,7 +185,7 @@ M: mock-gadget ungraft*
[ { f t } ] [ "1" get gadget-graft-state ] unit-test
[ { f t } ] [ "2" get gadget-graft-state ] unit-test
[ { f t } ] [ "3" get gadget-graft-state ] unit-test
[ ] [ [ "x" print notify ] graft-queue swap dlist-slurp ] unit-test
[ ] [ graft-queue [ "x" print notify ] slurp-dequeue ] unit-test
[ ] [ notify-queued ] unit-test
[ V{ { t t } } ] [ status-flags ] unit-test
] with-variable ;

15
extra/ui/gadgets/gadgets.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables kernel models math namespaces sequences
quotations math.vectors combinators sorting vectors dlists
models threads concurrency.flags math.order ;
USING: accessors arrays hashtables kernel models math namespaces
sequences quotations math.vectors combinators sorting vectors
dlists dequeues models threads concurrency.flags math.order ;
IN: ui.gadgets
SYMBOL: ui-notify-flag
@ -252,13 +252,12 @@ M: gadget layout* drop ;
: graft-queue ( -- dlist ) \ graft-queue get ;
: unqueue-graft ( gadget -- )
graft-queue over gadget-graft-node delete-node
dup gadget-graft-state first { t t } { f f } ?
swap set-gadget-graft-state ;
[ graft-node>> graft-queue delete-node ]
[ [ first { t t } { f f } ? ] change-graft-state drop ] bi ;
: (queue-graft) ( gadget flags -- )
over set-gadget-graft-state
dup graft-queue push-front* swap set-gadget-graft-node
>>graft-state
dup graft-queue push-front* >>graft-node drop
notify-ui-thread ;
: queue-graft ( gadget -- )

2
extra/ui/tools/browser/browser.factor
View File

@ -14,7 +14,7 @@ TUPLE: browser-gadget pane history ;
>r >link r> history>> set-model ;
: <help-pane> ( browser-gadget -- gadget )
history>> [ [ dup help ] try drop ] <pane-control> ;
history>> [ [ help ] curry try ] <pane-control> ;
: init-history ( browser-gadget -- )
"handbook" >link <history> >>history drop ;

8
extra/ui/ui.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words
prettyprint dlists dequeues sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators
hashtables concurrency.flags sets ;
@ -15,7 +15,7 @@ SYMBOL: stop-after-last-window?
: event-loop? ( -- ? )
{
{ [ stop-after-last-window? get not ] [ t ] }
{ [ graft-queue dlist-empty? not ] [ t ] }
{ [ graft-queue dequeue-empty? not ] [ t ] }
{ [ windows get-global empty? not ] [ t ] }
[ f ]
} cond ;
@ -126,7 +126,7 @@ SYMBOL: ui-hook
in-layout? on
layout-queue [
dup layout find-world [ , ] when*
] dlist-slurp
] slurp-dequeue
] { } make prune ;
: redraw-worlds ( seq -- )
@ -141,7 +141,7 @@ SYMBOL: ui-hook
} case ;
: notify-queued ( -- )
graft-queue [ notify ] dlist-slurp ;
graft-queue [ notify ] slurp-dequeue ;
: update-ui ( -- )
[ notify-queued layout-queued redraw-worlds ] assert-depth ;