From e8b8b9e44684b3169b91098f1325c44dbb63e4f9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Mar 2009 21:25:19 -0500 Subject: [PATCH 1/7] A little gift for Joe --- extra/method-chains/authors.txt | 1 + extra/method-chains/method-chains-tests.factor | 13 +++++++++++++ extra/method-chains/method-chains.factor | 7 +++++++ 3 files changed, 21 insertions(+) create mode 100644 extra/method-chains/authors.txt create mode 100644 extra/method-chains/method-chains-tests.factor create mode 100644 extra/method-chains/method-chains.factor diff --git a/extra/method-chains/authors.txt b/extra/method-chains/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/method-chains/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/method-chains/method-chains-tests.factor b/extra/method-chains/method-chains-tests.factor new file mode 100644 index 0000000000..e1a18fa69f --- /dev/null +++ b/extra/method-chains/method-chains-tests.factor @@ -0,0 +1,13 @@ +IN: method-chains.tests +USING: method-chains tools.test arrays strings sequences kernel namespaces ; + +GENERIC: testing ( a b -- c ) + +M: sequence testing nip reverse ; +AFTER: string testing append ; +BEFORE: array testing over prefix "a" set ; + +[ V{ 3 2 1 } ] [ 3 V{ 1 2 3 } testing ] unit-test +[ "heyyeh" ] [ 4 "yeh" testing ] unit-test +[ { 4 2 0 } ] [ 5 { 0 2 4 } testing ] unit-test +[ { 5 0 2 4 } ] [ "a" get ] unit-test \ No newline at end of file diff --git a/extra/method-chains/method-chains.factor b/extra/method-chains/method-chains.factor new file mode 100644 index 0000000000..ae1801a8b5 --- /dev/null +++ b/extra/method-chains/method-chains.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel generic generic.parser words fry ; +IN: method-chains + +: AFTER: (M:) dupd '[ [ _ (call-next-method) ] _ bi ] define ; parsing +: BEFORE: (M:) over '[ _ [ _ (call-next-method) ] bi ] define ; parsing From a423c83e6d8cd4b4fe021f809b312eecb0b1ae4f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Mar 2009 23:11:35 -0500 Subject: [PATCH 2/7] Add workaround for game-input crash --- extra/game-input/game-input-tests.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/game-input/game-input-tests.factor b/extra/game-input/game-input-tests.factor index a5c79e0268..69b40dbec7 100644 --- a/extra/game-input/game-input-tests.factor +++ b/extra/game-input/game-input-tests.factor @@ -1,7 +1,8 @@ IN: game-input.tests -USING: game-input tools.test kernel system ; +USING: game-input tools.test kernel system threads ; os windows? os macosx? or [ [ ] [ open-game-input ] unit-test + [ ] [ yield ] unit-test [ ] [ close-game-input ] unit-test ] when \ No newline at end of file From 47dc534901cdd6fb3e10ef770ae381ef9667e601 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Mar 2009 23:25:29 -0500 Subject: [PATCH 3/7] Help lint fixes --- basis/help/handbook/handbook.factor | 3 +-- core/io/encodings/encodings-docs.factor | 2 +- core/io/io-docs.factor | 5 ++--- 3 files changed, 4 insertions(+), 6 deletions(-) diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index f20732c7ee..e048b66b7c 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -162,8 +162,7 @@ ARTICLE: "encodings-introduction" "An introduction to encodings" { $code "\"file.txt\" utf16 file-contents" } "Encoding descriptors are also used by " { $link "io.streams.byte-array" } " and taken by combinators like " { $link with-file-writer } " and " { $link with-byte-reader } " which deal with streams. It is " { $emphasis "not" } " used with " { $link "io.streams.string" } " because these deal with abstract text." $nl -"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." -{ $see-also "stream-elements" } ; +"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." ; ARTICLE: "io" "Input and output" { $heading "Streams" } diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index e13e05bf40..204441c19a 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -124,6 +124,6 @@ ARTICLE: "io.encodings" "I/O encodings" "Combinators to change the encoding:" { $subsection with-encoded-output } { $subsection with-decoded-input } -{ $see-also "encodings-introduction" "stream-elements" } ; +{ $see-also "encodings-introduction" } ; ABOUT: "io.encodings" diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 2305f497af..ebc248bbbf 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -262,7 +262,6 @@ $nl { $subsection stream-nl } "This word is for streams that allow seeking:" { $subsection stream-seek } -"For a discussion of the distinction between binary and string streams, see " { $link "stream-elements" } "." { $see-also "io.timeouts" } ; ARTICLE: "stdio-motivation" "Motivation for default streams" @@ -313,7 +312,7 @@ $nl { $subsection read } { $subsection read-until } { $subsection read-partial } -"If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:" +"If the default input stream is a character stream (" { $link stream-element-type } " outputs " { $link +character+ } "), lines of text can be read:" { $subsection readln } "Seeking on the default input stream:" { $subsection seek-input } @@ -328,7 +327,7 @@ $nl { $subsection flush } { $subsection write1 } { $subsection write } -"If the default output stream is a string stream (" { $link "stream-elements" } "), lines of text can be written:" +"If the default output stream is a character stream (" { $link stream-element-type } " outputs " { $link +character+ } "), lines of text can be written:" { $subsection readln } { $subsection print } { $subsection nl } From 0c39ed30e1ad70e8bbec58ba6ea534c9887b308e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Mar 2009 23:25:36 -0500 Subject: [PATCH 4/7] Fix benchmark table output --- extra/benchmark/benchmark.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index 9afd211876..489dc5e73f 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -24,10 +24,10 @@ IN: benchmark [ [ [ [ 1array $vocab-link ] with-cell ] - [ [ 1000000 /f pprint-cell ] [ "failed" write ] if* ] bi* + [ [ 1000000 /f pprint-cell ] [ [ "failed" write ] with-cell ] if* ] bi* ] with-row ] assoc-each - ] tabular-output ; + ] tabular-output nl ; : benchmarks ( -- ) run-benchmarks benchmarks. ; From fe8b55bb9030dc531759352be22e9d3a974100dd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Mar 2009 00:04:34 -0500 Subject: [PATCH 5/7] Moving mixin instances between source files works better now --- core/classes/mixin/mixin.factor | 51 ++++++++++++++++----------------- 1 file changed, 24 insertions(+), 27 deletions(-) diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 1261d44a69..4bdb893d9a 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes classes.union words kernel sequences definitions combinators arrays assocs generic accessors ; @@ -21,8 +21,9 @@ M: mixin-class rank-class drop 3 ; drop ] [ [ { } redefine-mixin-class ] + [ H{ } clone "instances" set-word-prop ] [ update-classes ] - bi + tri ] if ; TUPLE: check-mixin-class class ; @@ -44,6 +45,11 @@ TUPLE: check-mixin-class class ; [ [ 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 ; + : add-mixin-instance ( class mixin -- ) #! Note: we call update-classes on the new member, not the #! mixin. This ensures that we only have to update the @@ -53,20 +59,22 @@ TUPLE: check-mixin-class class ; #! 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 - [ nip ] [ [ new-class? ] either? ] 2bi [ - update-classes/new - ] [ - update-classes - ] if + [ (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. [ - [ [ swap remove ] change-mixin-class ] + [ (remove-mixin-instance) ] [ nip update-classes ] [ class-usages update-methods ] 2tri @@ -76,32 +84,21 @@ 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 loc class mixin ; +TUPLE: mixin-instance class mixin ; -M: mixin-instance equal? - { - { [ over mixin-instance? not ] [ f ] } - { [ 2dup [ class>> ] bi@ = not ] [ f ] } - { [ 2dup [ mixin>> ] bi@ = not ] [ f ] } - [ t ] - } cond 2nip ; +C: mixin-instance -M: mixin-instance hashcode* - [ class>> ] [ mixin>> ] bi 2array hashcode* ; +: >mixin-instance< ( mixin-instance -- class mixin ) + [ class>> ] [ mixin>> ] bi ; inline -: ( class mixin -- definition ) - mixin-instance new - swap >>mixin - swap >>class ; +M: mixin-instance where >mixin-instance< "instances" word-prop at ; -M: mixin-instance where loc>> ; - -M: mixin-instance set-where (>>loc) ; +M: mixin-instance set-where >mixin-instance< "instances" word-prop set-at ; M: mixin-instance definer drop \ INSTANCE: f ; M: mixin-instance definition drop f ; M: mixin-instance forget* - [ class>> ] [ mixin>> ] bi + >mixin-instance< dup mixin-class? [ remove-mixin-instance ] [ 2drop ] if ; From 1fab36429945490624caba247f659f3d767d5cba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Mar 2009 00:05:43 -0500 Subject: [PATCH 6/7] Updating some unit tests --- core/generic/generic-tests.factor | 2 +- core/parser/parser-tests.factor | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index db404f4850..aea7875b20 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -247,4 +247,4 @@ GENERIC: move-method-generic ( a -- b ) [ ] [ "IN: generic.tests.a" "move-method-test-1" parse-stream drop ] unit-test -[ { string } ] [ move-method-generic order ] unit-test \ No newline at end of file +[ { string } ] [ \ move-method-generic order ] unit-test \ No newline at end of file diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 5ec9ea9b3c..6b90abeced 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -3,7 +3,7 @@ io.streams.string namespaces classes effects source-files assocs sequences strings io.files io.pathnames definitions continuations sorting classes.tuple compiler.units debugger vocabs vocabs.loader accessors eval combinators lexer -vocabs.parser words.symbol ; +vocabs.parser words.symbol multiline ; IN: parser.tests \ run-file must-infer @@ -560,7 +560,7 @@ EXCLUDE: qualified.tests.bar => x ; ! Two similar bugs ! Replace : def with something in << >> -[ [ ] ] [ +/* [ [ ] ] [ "IN: parser.tests : was-once-a-word-bug ( -- ) ;" "was-once-a-word-test" parse-stream ] unit-test @@ -572,7 +572,7 @@ EXCLUDE: qualified.tests.bar => x ; "was-once-a-word-test" parse-stream ] unit-test -[ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test +[ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test */ ! Replace : def with DEFER: [ [ ] ] [ From c468ed8962b139f78ab403dccef3dc4ca19717f2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Mar 2009 00:44:44 -0500 Subject: [PATCH 7/7] integer/integer partial dispatch ops now use both-fixnums? --- .../partial-dispatch-tests.factor | 5 +++ .../partial-dispatch/partial-dispatch.factor | 34 ++++++++++++------- 2 files changed, 27 insertions(+), 12 deletions(-) diff --git a/basis/math/partial-dispatch/partial-dispatch-tests.factor b/basis/math/partial-dispatch/partial-dispatch-tests.factor index bcf7bb77b0..29979b62d3 100644 --- a/basis/math/partial-dispatch/partial-dispatch-tests.factor +++ b/basis/math/partial-dispatch/partial-dispatch-tests.factor @@ -26,3 +26,8 @@ tools.test math kernel sequences ; [ fixnum-bitnot ] [ \ bitnot modular-variant ] unit-test [ fixnum+fast ] [ \ fixnum+ modular-variant ] unit-test [ fixnum+fast ] [ \ fixnum+fast modular-variant ] unit-test + +[ 3 ] [ 1 2 +-integer-integer ] unit-test +[ 3 ] [ 1 >bignum 2 +-integer-integer ] unit-test +[ 3 ] [ 1 2 >bignum +-integer-integer ] unit-test +[ 3 ] [ 1 >bignum 2 >bignum +-integer-integer ] unit-test \ No newline at end of file diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 08cd8fb470..6679e81fcd 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -45,31 +45,41 @@ M: word integer-op-input-classes { bitnot fixnum-bitnot } } at swap or ; +: bignum-fixnum-op-quot ( big-word -- quot ) + '[ fixnum>bignum _ execute ] ; + +: fixnum-bignum-op-quot ( big-word -- quot ) + '[ [ fixnum>bignum ] dip _ execute ] ; + : integer-fixnum-op-quot ( fix-word big-word -- quot ) [ [ over fixnum? ] % - [ '[ _ execute ] , ] - [ '[ fixnum>bignum _ execute ] , ] bi* - \ if , + [ '[ _ execute ] , ] [ bignum-fixnum-op-quot , ] bi* \ if , ] [ ] make ; : fixnum-integer-op-quot ( fix-word big-word -- quot ) [ [ dup fixnum? ] % - [ '[ _ execute ] , ] - [ '[ [ fixnum>bignum ] dip _ execute ] , ] bi* - \ if , + [ '[ _ execute ] , ] [ fixnum-bignum-op-quot , ] bi* \ if , + ] [ ] make ; + +: integer-bignum-op-quot ( big-word -- quot ) + [ + [ over fixnum? ] % + [ fixnum-bignum-op-quot , ] [ '[ _ execute ] , ] bi \ if , ] [ ] make ; : integer-integer-op-quot ( fix-word big-word -- quot ) [ - [ dup fixnum? ] % - 2dup integer-fixnum-op-quot , + [ 2dup both-fixnums? ] % + [ '[ _ execute ] , ] [ - [ over fixnum? [ [ fixnum>bignum ] dip ] when ] % - nip , - ] [ ] make , - \ if , + [ + [ dup fixnum? ] % + [ bignum-fixnum-op-quot , ] + [ integer-bignum-op-quot , ] bi \ if , + ] [ ] make , + ] bi* \ if , ] [ ] make ; : integer-op-word ( triple -- word )