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

Regression fixes

db4
Slava Pestov 2008-02-25 19:37:43 -06:00
parent 438f00a6a5
commit 84016a36c0
18 changed files with 103 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/compiler/tests/curry.factor
View File

@ -1,5 +1,5 @@
USING: tools.test compiler quotations math kernel sequences USING: tools.test quotations math kernel sequences
assocs namespaces ; assocs namespaces compiler.units ;
IN: temporary IN: temporary
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test

2
core/compiler/tests/float.factor
View File

@ -1,5 +1,5 @@
IN: temporary IN: temporary
USING: compiler kernel kernel.private memory math USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ; math.private tools.test math.floats.private ;
[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test [ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test

13
core/compiler/tests/intrinsics.factor
View File

@ -1,10 +1,11 @@
IN: temporary IN: temporary
USING: arrays compiler kernel kernel.private math math.constants USING: arrays compiler.units kernel kernel.private math
math.private sequences strings tools.test words continuations math.constants math.private sequences strings tools.test words
sequences.private hashtables.private byte-arrays strings.private continuations sequences.private hashtables.private byte-arrays
system random layouts vectors.private sbufs.private strings.private system random layouts vectors.private
strings.private slots.private alien alien.accessors sbufs.private strings.private slots.private alien
alien.c-types alien.syntax namespaces libc sequences.private ; alien.accessors alien.c-types alien.syntax namespaces libc
sequences.private ;
! Make sure that intrinsic ops compile to correct code. ! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test [ ] [ 1 [ drop ] compile-call ] unit-test

2
core/compiler/tests/simple.factor
View File

@ -1,4 +1,4 @@
USING: compiler tools.test kernel kernel.private USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings sequences.private math.private math combinators strings
alien arrays memory ; alien arrays memory ;
IN: temporary IN: temporary

2
core/compiler/tests/tuples.factor
View File

@ -1,5 +1,5 @@
IN: temporary IN: temporary
USING: kernel tools.test compiler ; USING: kernel tools.test compiler.units ;
TUPLE: color red green blue ; TUPLE: color red green blue ;

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations assocs namespaces sequences words USING: kernel continuations assocs namespaces sequences words
vocabs definitions hashtables ; vocabs definitions hashtables init ;
IN: compiler.units IN: compiler.units
SYMBOL: old-definitions SYMBOL: old-definitions
@ -37,12 +37,13 @@ SYMBOL: recompile-hook
SYMBOL: definition-observers SYMBOL: definition-observers
definition-observers global [ V{ } like ] change-at
GENERIC: definitions-changed ( assoc obj -- ) GENERIC: definitions-changed ( assoc obj -- )
[ V{ } clone definition-observers set-global ]
"compiler.units" add-init-hook
: add-definition-observer ( obj -- ) : add-definition-observer ( obj -- )
definition-observers get push-new ; definition-observers get push ;
: remove-definition-observer ( obj -- ) : remove-definition-observer ( obj -- )
definition-observers get delete ; definition-observers get delete ;

2
core/inference/state/state-tests.factor
View File

@ -1,5 +1,5 @@
IN: temporary IN: temporary
USING: tools.test inference.state ; USING: tools.test inference.state words ;
SYMBOL: a SYMBOL: a
SYMBOL: b SYMBOL: b

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

@ -1,4 +1,4 @@
USING: arrays compiler generic hashtables inference kernel USING: arrays compiler.units generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private optimizer.backend classes inference.dataflow tuples.private

2
core/parser/parser.factor
View File

@ -468,7 +468,7 @@ SYMBOL: interactive-vocabs
#! If a class word had a compound definition which was #! If a class word had a compound definition which was
#! removed, it must go back to being a symbol. #! removed, it must go back to being a symbol.
new-definitions get first2 diff new-definitions get first2 diff
[ nip define-symbol ] assoc-each ; [ nip dup reset-generic define-symbol ] assoc-each ;
: forget-smudged ( -- ) : forget-smudged ( -- )
smudged-usage forget-all smudged-usage forget-all

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

@ -1,6 +1,6 @@
USING: arrays generic assocs kernel math namespaces USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations sequences tools.test words definitions parser quotations
vocabs continuations tuples compiler.units ; vocabs continuations tuples compiler.units io.streams.string ;
IN: temporary IN: temporary
[ 4 ] [ [ 4 ] [
@ -156,11 +156,13 @@ SYMBOL: quot-uses-b
[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test [ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test
[ ] [ [ ] [
"IN: temporary GENERIC: symbol-generic" eval "IN: temporary GENERIC: symbol-generic" <string-reader>
"symbol-generic-test" parse-stream drop
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary TUPLE: symbol-generic ;" eval "IN: temporary TUPLE: symbol-generic ;" <string-reader>
"symbol-generic-test" parse-stream drop
] unit-test ] unit-test
[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test [ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test

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

@ -1,6 +1,7 @@
IN: temporary IN: temporary
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory ; compiler kernel namespaces cocoa.classes tools.test memory
compiler.units ;
CLASS: { CLASS: {
{ +superclass+ "NSObject" } { +superclass+ "NSObject" }

21
extra/concurrency/flags/flags.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: boxes kernel threads ;
IN: concurrency.flags
TUPLE: flag value? thread ;
: <flag> ( -- flag ) f <box> flag construct-boa ;
: raise-flag ( flag -- )
dup flag-value? [
dup flag-thread ?box
[ resume ] [ drop t over set-flag-value? ] if
] unless drop ;
: lower-flag ( flag -- )
dup flag-value? [
f swap set-flag-value?
] [
[ flag-thread >box ] curry "flag" suspend drop
] if ;

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

@ -15,7 +15,7 @@ TUPLE: mailbox threads data ;
: mailbox-put ( obj mailbox -- ) : mailbox-put ( obj mailbox -- )
[ mailbox-data push-front ] keep [ mailbox-data push-front ] keep
mailbox-threads notify-all ; mailbox-threads notify-all yield ;
: block-unless-pred ( pred mailbox timeout -- ) : block-unless-pred ( pred mailbox timeout -- )
2over mailbox-data dlist-contains? [ 2over mailbox-data dlist-contains? [

4
extra/html/elements/elements.factor
View File

@ -87,14 +87,14 @@ SYMBOL: html
#! word. #! word.
foo> [ ">" write-html ] empty-effect html-word ; foo> [ ">" write-html ] empty-effect html-word ;
: </foo> [ "</" % % ">" % ] "" make ; : </foo> "</" swap ">" 3append ;
: def-for-html-word-</foo> ( name -- ) : def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned #! Return the name and code for the </foo> patterned
#! word. #! word.
</foo> dup [ write-html ] curry empty-effect html-word ; </foo> dup [ write-html ] curry empty-effect html-word ;
: <foo/> [ "<" % % "/>" % ] "" make ; : <foo/> "<" swap "/>" 3append ;
: def-for-html-word-<foo/> ( name -- ) : def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned #! Return the name and code for the <foo/> patterned

60
extra/io/unix/unix-tests.factor
View File

@ -4,12 +4,12 @@ sequences prettyprint system ;
IN: temporary IN: temporary
! Unix domain stream sockets ! Unix domain stream sockets
[ : socket-server "unix-domain-socket-test" temp-file ;
[
"unix-domain-socket-test" resource-path delete-file
] ignore-errors
"unix-domain-socket-test" resource-path <local> [
[ socket-server delete-file ] ignore-errors
socket-server <local>
<server> [ <server> [
stdio get accept [ stdio get accept [
"Hello world" print flush "Hello world" print flush
@ -17,14 +17,14 @@ IN: temporary
] with-stream ] with-stream
] with-stream ] with-stream
"unix-domain-socket-test" resource-path delete-file socket-server delete-file
] "Test" spawn drop ] "Test" spawn drop
yield yield
[ { "Hello world" "FOO" } ] [ [ { "Hello world" "FOO" } ] [
[ [
"unix-domain-socket-test" resource-path <local> <client> socket-server <local> <client>
[ [
readln , readln ,
"XYZ" print flush "XYZ" print flush
@ -33,17 +33,16 @@ yield
] { } make ] { } make
] unit-test ] unit-test
: datagram-server "unix-domain-datagram-test" temp-file ;
: datagram-client "unix-domain-datagram-test-2" temp-file ;
! Unix domain datagram sockets ! Unix domain datagram sockets
[ [ datagram-server delete-file ] ignore-errors
"unix-domain-datagram-test" resource-path delete-file [ datagram-client delete-file ] ignore-errors
] ignore-errors
: server-addr "unix-domain-datagram-test" temp-file <local> ;
: client-addr "unix-domain-datagram-test-2" temp-file <local> ;
[ [
[ [
server-addr <datagram> "d" set datagram-server <local> <datagram> "d" set
"Receive 1" print "Receive 1" print
@ -67,58 +66,53 @@ yield
"Done" print "Done" print
"unix-domain-datagram-test" resource-path delete-file datagram-server delete-file
] with-scope ] with-scope
] "Test" spawn drop ] "Test" spawn drop
yield yield
[ [ datagram-client delete-file ] ignore-errors
"unix-domain-datagram-test-2" resource-path delete-file
] ignore-errors
client-addr <datagram> datagram-client <local> <datagram>
"d" set "d" set
[ ] [ [ ] [
"hello" >byte-array "hello" >byte-array
server-addr datagram-server <local>
"d" get send "d" get send
] unit-test ] unit-test
[ "olleh" t ] [ [ "olleh" t ] [
"d" get receive "d" get receive
server-addr = datagram-server <local> =
>r >string r> >r >string r>
] unit-test ] unit-test
[ ] [ [ ] [
"hello" >byte-array "hello" >byte-array
server-addr datagram-server <local>
"d" get send "d" get send
] unit-test ] unit-test
[ "hello world" t ] [ [ "hello world" t ] [
"d" get receive "d" get receive
server-addr = datagram-server <local> =
>r >string r> >r >string r>
] unit-test ] unit-test
[ ] [ "d" get dispose ] unit-test [ ] [ "d" get dispose ] unit-test
! Test error behavior ! Test error behavior
: another-datagram "unix-domain-datagram-test-3" temp-file ;
[ [ another-datagram delete-file ] ignore-errors
"unix-domain-datagram-test-3" resource-path delete-file
] ignore-errors
"unix-domain-datagram-test-2" temp-file delete-file datagram-client delete-file
[ ] [ client-addr <datagram> "d" set ] unit-test [ ] [ datagram-client <local> <datagram> "d" set ] unit-test
[ [ B{ 1 2 3 } another-datagram <local> "d" get send ] must-fail
B{ 1 2 3 } "unix-domain-datagram-test-3" <local> "d" get send
] must-fail
[ ] [ "d" get dispose ] unit-test [ ] [ "d" get dispose ] unit-test
@ -126,7 +120,7 @@ client-addr <datagram>
[ "d" get receive ] must-fail [ "d" get receive ] must-fail
[ B{ 1 2 } server-addr "d" get send ] must-fail [ B{ 1 2 } datagram-server <local> "d" get send ] must-fail
! Invalid parameter tests ! Invalid parameter tests
@ -140,7 +134,7 @@ client-addr <datagram>
[ [
image [ image [
B{ 1 2 } server-addr B{ 1 2 } datagram-server <local>
stdio get send stdio get send
] with-file-reader ] with-file-reader
] must-fail ] must-fail

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

@ -2,17 +2,12 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables kernel models math namespaces sequences USING: arrays hashtables kernel models math namespaces sequences
quotations math.vectors combinators sorting vectors dlists quotations math.vectors combinators sorting vectors dlists
models threads concurrency.messaging ; models threads concurrency.flags ;
IN: ui.gadgets IN: ui.gadgets
SYMBOL: ui-thread SYMBOL: ui-notify-flag
: notify-ui-thread ( -- ) : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
self ui-thread get-global eq? [
"notify" ui-thread get-global send
] unless ;
: stop-ui-thread ( -- ) "stop" ui-thread get-global send ;
TUPLE: rect loc dim ; TUPLE: rect loc dim ;

5
extra/ui/tools/search/search.factor
View File

@ -7,7 +7,7 @@ source-files definitions strings tools.completion tools.crossref
tuples ui.commands ui.gadgets ui.gadgets.editors tuples ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
ui.gestures ui.operations vocabs words vocabs.loader ui.gestures ui.operations vocabs words vocabs.loader
tools.browser unicode.case calendar ; tools.browser unicode.case calendar ui ;
IN: ui.tools.search IN: ui.tools.search
TUPLE: live-search field list ; TUPLE: live-search field list ;
@ -45,7 +45,8 @@ search-field H{
} set-gestures } set-gestures
: <search-model> ( producer -- model ) : <search-model> ( producer -- model )
>r g live-search-field gadget-model 1/5 seconds <delay> >r g live-search-field gadget-model
ui-running? [ 1/5 seconds <delay> ] when
[ "\n" join ] r> append <filter> ; [ "\n" join ] r> append <filter> ;
: <search-list> ( seq limited? presenter -- gadget ) : <search-list> ( seq limited? presenter -- gadget )

29
extra/ui/ui.factor
View File

@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words prettyprint dlists sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators ui.gestures ui.backend ui.render continuations init combinators
hashtables concurrency.messaging ; hashtables concurrency.flags ;
IN: ui IN: ui
! Assoc mapping aliens to gadgets ! Assoc mapping aliens to gadgets
@ -138,18 +138,25 @@ SYMBOL: ui-hook
: ui-try ( quot -- ) [ ui-error ] recover ; : ui-try ( quot -- ) [ ui-error ] recover ;
SYMBOL: ui-thread
: ui-running ( quot -- ) : ui-running ( quot -- )
t \ ui-running set-global t \ ui-running set-global
[ f \ ui-running set-global ] [ ] cleanup ; inline [ f \ ui-running set-global ] [ ] cleanup ; inline
: ui-running? ( -- ? )
\ ui-running get-global ;
: update-ui-loop ( -- ) : update-ui-loop ( -- )
receive { { "notify" [ ] } { "stop" [ stop ] } } case ui-running? ui-thread get-global self eq? [
ui-notify-flag get lower-flag
[ update-ui ] ui-try [ update-ui ] ui-try
update-ui-loop ; update-ui-loop
] when ;
: start-ui-thread ( -- ) : start-ui-thread ( -- )
[ update-ui-loop ] [ self ui-thread set-global update-ui-loop ]
"UI update" spawn ui-thread set-global ; "UI update" spawn drop ;
: open-world-window ( world -- ) : open-world-window ( world -- )
dup pref-dim over set-gadget-dim dup relayout graft ; dup pref-dim over set-gadget-dim dup relayout graft ;
@ -173,17 +180,17 @@ M: object close-window
find-world [ ungraft ] when* ; find-world [ ungraft ] when* ;
: start-ui ( -- ) : start-ui ( -- )
start-ui-thread
restore-windows? [ restore-windows? [
restore-windows restore-windows
] [ ] [
init-ui ui-hook get call init-ui ui-hook get call
] if update-ui ; ] if
notify-ui-thread start-ui-thread ;
: ui-running? ( -- ? ) [
\ ui-running get-global ; f \ ui-running set-global
<flag> ui-notify-flag set-global
[ f \ ui-running set-global ] "ui" add-init-hook ] "ui" add-init-hook
HOOK: ui ui-backend ( -- ) HOOK: ui ui-backend ( -- )