From 81c96ca410c828bbea6a2e0077dc9e0c8d77f590 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Mar 2009 16:21:06 -0600 Subject: [PATCH 01/20] Add a unit test as a sanity check for a broken Win64 Pango --- basis/ui/text/text-tests.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/ui/text/text-tests.factor b/basis/ui/text/text-tests.factor index d800c88d44..939e262997 100644 --- a/basis/ui/text/text-tests.factor +++ b/basis/ui/text/text-tests.factor @@ -1,4 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test ui.text ; +USING: tools.test ui.text fonts ; IN: ui.text.tests + +[ 0.0 ] [ 0 sans-serif-font "aaa" offset>x ] unit-test From 12a53bbdc0528b55b945f10e42f1446048f09608 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Mar 2009 17:34:21 -0600 Subject: [PATCH 02/20] add seeking to byte-array streams --- basis/io/streams/byte-array/byte-array.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/basis/io/streams/byte-array/byte-array.factor b/basis/io/streams/byte-array/byte-array.factor index b877e97cf1..16160cd42d 100644 --- a/basis/io/streams/byte-array/byte-array.factor +++ b/basis/io/streams/byte-array/byte-array.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays byte-vectors kernel io.encodings io.streams.string sequences io namespaces io.encodings.private accessors sequences.private -io.streams.sequence destructors ; +io.streams.sequence destructors math combinators ; IN: io.streams.byte-array : ( encoding -- stream ) @@ -20,6 +20,14 @@ M: byte-reader stream-read1 sequence-read1 ; M: byte-reader stream-read-until sequence-read-until ; M: byte-reader dispose drop ; +M: byte-reader stream-seek ( n seek-type stream -- ) + swap { + { seek-absolute [ (>>i) ] } + { seek-relative [ [ + ] change-i drop ] } + { seek-end [ dup underlying>> length >>i [ + ] change-i drop ] } + [ bad-seek-type ] + } case ; + : ( byte-array encoding -- stream ) [ B{ } like 0 byte-reader boa ] dip ; From a93c3d96b5fdf95a9a1ae65c3d822317f1e36aea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Mar 2009 17:35:33 -0600 Subject: [PATCH 03/20] add using --- basis/tools/annotations/annotations-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index 2a65ea5236..9210c2cab1 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -1,5 +1,5 @@ USING: tools.test tools.annotations tools.time math parser eval -io.streams.string kernel ; +io.streams.string kernel strings ; IN: tools.annotations.tests : foo ; @@ -45,4 +45,4 @@ M: string blah-generic ; { string blah-generic } watch -[ ] [ "hi" blah-generic ] unit-test \ No newline at end of file +[ ] [ "hi" blah-generic ] unit-test From e4a0396550c800335bb3fe057121bcbd5471848f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Mar 2009 19:48:04 -0600 Subject: [PATCH 04/20] Add parse-quotation hook to parser which locals overrides. '[ and [ use this hook. Fixes locals bug reported by erg --- basis/fry/fry.factor | 2 +- basis/functors/functors.factor | 17 ++----- basis/locals/errors/errors.factor | 10 ++-- basis/locals/locals-docs.factor | 19 +++++-- basis/locals/locals-tests.factor | 21 +++++--- basis/locals/locals.factor | 16 +++--- basis/locals/parser/parser.factor | 66 +++++++++++++++++-------- basis/locals/rewrite/sugar/sugar.factor | 18 ++++--- core/parser/parser-tests.factor | 14 ++++++ core/parser/parser.factor | 10 ++-- core/syntax/syntax.factor | 2 +- extra/literals/literals-tests.factor | 6 +-- extra/literals/literals.factor | 2 +- 13 files changed, 129 insertions(+), 74 deletions(-) diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index e62a42749f..9ffad43cf4 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -53,4 +53,4 @@ M: callable deep-fry M: object deep-fry , ; -: '[ \ ] parse-until fry over push-all ; parsing +: '[ parse-quotation fry over push-all ; parsing diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 0b9c9caa45..6592a3c4f2 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -122,20 +122,13 @@ DEFER: ;FUNCTOR delimiter functor-words use get delq ; : parse-functor-body ( -- form ) - t in-lambda? [ - V{ } clone - push-functor-words - "WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda) - parsed-lambda - pop-functor-words - >quotation - ] with-variable ; + push-functor-words + "WHERE" parse-bindings* + [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) 1quotation + pop-functor-words ; : (FUNCTOR:) ( -- word def ) - CREATE - parse-locals dup push-locals - parse-functor-body swap pop-locals - rewrite-closures first ; + CREATE-WORD [ parse-functor-body ] parse-locals-definition ; PRIVATE> diff --git a/basis/locals/errors/errors.factor b/basis/locals/errors/errors.factor index d11405ddb5..e7b4c5a884 100644 --- a/basis/locals/errors/errors.factor +++ b/basis/locals/errors/errors.factor @@ -29,12 +29,12 @@ ERROR: :>-outside-lambda-error ; M: :>-outside-lambda-error summary drop ":> cannot be used outside of lambda expressions" ; -ERROR: bad-lambda-rewrite output ; - -M: bad-lambda-rewrite summary - drop "You have found a bug in locals. Please report." ; - ERROR: bad-local args obj ; M: bad-local summary drop "You have found a bug in locals. Please report." ; + +ERROR: bad-rewrite args obj ; + +M: bad-rewrite summary + drop "You have found a bug in locals. Please report." ; diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index a4a9ca448b..0998d84530 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -134,19 +134,30 @@ $nl "ordinary-word-test ordinary-word-test eq? ." "t" } -"In a word with locals, literals expand into code which constructs the literal, and so every invocation pushes a new object:" +"In a word with locals, literals which do not contain locals still behave in the same way:" { $example "USE: locals" "IN: scratchpad" "TUPLE: person first-name last-name ;" - ":: ordinary-word-test ( -- tuple )" + ":: locals-word-test ( -- tuple )" " T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;" - "ordinary-word-test ordinary-word-test eq? ." + "locals-word-test locals-word-test eq? ." + "t" +} +"However, literals with locals in them actually expand into code for constructing a new object:" +{ $example + "USING: locals splitting ;" + "IN: scratchpad" + "TUPLE: person first-name last-name ;" + ":: constructor-test ( -- tuple )" + " \"Jane Smith\" \" \" split1 :> last :> first" + " T{ person { first-name first } { last-name last } } ;" + "constructor-test constructor-test eq? ." "f" } "One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time." { $heading "Example" } -"For example, here is an implementation of the " { $link 3array } " word which uses this feature:" +"Here is an implementation of the " { $link 3array } " word which uses this feature:" { $code ":: 3array ( x y z -- array ) { x y z } ;" } ; ARTICLE: "locals-mutable" "Mutable locals" diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 08c667447c..2f5c72a53c 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -357,12 +357,12 @@ ERROR: punned-class x ; [ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test :: literal-identity-test ( -- a b ) - { } V{ } ; + { 1 } V{ } ; -[ t f ] [ +[ t t ] [ literal-identity-test literal-identity-test - swapd [ eq? ] [ eq? ] 2bi* + [ eq? ] [ eq? ] bi-curry* bi* ] unit-test :: mutable-local-in-literal-test ( a! -- b ) a 1 + a! { a } ; @@ -401,9 +401,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test [ - "USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval + "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]" + eval call ] [ error>> >r/r>-in-fry-error? ] must-fail-with - + :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline : funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ; @@ -503,8 +504,14 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test ! erg found this problem -:: erg's-:>-bug ( n ? -- n ) [ n :> n n ] [ n :> b b ] if ; +:: erg's-:>-bug ( n ? -- n ) ? [ n :> n n ] [ n :> b b ] if ; [ 3 ] [ 3 f erg's-:>-bug ] unit-test -[ 3 ] [ 3 t erg's-:>-bug ] unit-test \ No newline at end of file +[ 3 ] [ 3 t erg's-:>-bug ] unit-test + +:: erg's-:>-bug-2 ( n ? -- n ) ? n '[ _ :> n n ] [ n :> b b ] if ; + +[ 3 ] [ 3 f erg's-:>-bug-2 ] unit-test + +[ 3 ] [ 3 t erg's-:>-bug-2 ] unit-test \ No newline at end of file diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index f745f6243f..190be61e23 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -9,19 +9,13 @@ IN: locals scan locals get [ :>-outside-lambda-error ] unless* [ make-local ] bind parsed ; parsing -: [| parse-lambda parsed-lambda ; parsing +: [| parse-lambda over push-all ; parsing -: [let - "|" expect "|" parse-bindings - \ ] (parse-lambda) parsed-lambda ; parsing +: [let parse-let over push-all ; parsing -: [let* - "|" expect "|" parse-bindings* - \ ] (parse-lambda) parsed-lambda ; parsing +: [let* parse-let* over push-all ; parsing -: [wlet - "|" expect "|" parse-wbindings - \ ] (parse-lambda) parsed-lambda ; parsing +: [wlet parse-wlet over push-all ; parsing : :: (::) define ; parsing @@ -31,6 +25,8 @@ IN: locals : MEMO:: (::) define-memoized ; parsing +USE: syntax + { "locals.macros" "locals.fry" diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor index f6baaf9ba7..d987e2c91d 100644 --- a/basis/locals/parser/parser.factor +++ b/basis/locals/parser/parser.factor @@ -6,6 +6,11 @@ locals.rewrite.closures locals.types make namespaces parser quotations sequences splitting words vocabs.parser ; IN: locals.parser +SYMBOL: in-lambda? + +: ?rewrite-closures ( form -- form' ) + in-lambda? get [ 1array ] [ rewrite-closures ] if ; + : make-local ( name -- word ) "!" ?tail [ @@ -20,28 +25,33 @@ IN: locals.parser [ [ dup name>> set ] [ ] [ ] tri ] dip "local-word-def" set-word-prop ; -SYMBOL: locals - : push-locals ( assoc -- ) use get push ; : pop-locals ( assoc -- ) - use get delete ; + use get delq ; -SYMBOL: in-lambda? +SINGLETON: lambda-parser -: (parse-lambda) ( assoc end -- quot ) - [ +SYMBOL: locals + +: ((parse-lambda)) ( assoc quot -- quot' ) + '[ in-lambda? on - over locals set - over push-locals - parse-until >quotation - swap pop-locals - ] with-scope ; + lambda-parser quotation-parser set + [ locals set ] [ push-locals @ ] [ pop-locals ] tri + ] with-scope ; inline + +: (parse-lambda) ( assoc -- quot ) + [ \ ] parse-until >quotation ] ((parse-lambda)) ; : parse-lambda ( -- lambda ) "|" parse-tokens make-locals - \ ] (parse-lambda) ; + (parse-lambda) + ?rewrite-closures ; + +M: lambda-parser parse-quotation ( -- quotation ) + H{ } clone (parse-lambda) ; : parse-binding ( end -- pair/f ) scan { @@ -65,6 +75,10 @@ SYMBOL: in-lambda? : parse-bindings ( end -- bindings vars ) [ (parse-bindings) ] with-bindings ; +: parse-let ( -- form ) + "|" expect "|" parse-bindings + (parse-lambda) ?rewrite-closures ; + : parse-bindings* ( end -- words assoc ) [ namespace push-locals @@ -72,6 +86,10 @@ SYMBOL: in-lambda? namespace pop-locals ] with-bindings ; +: parse-let* ( -- form ) + "|" expect "|" parse-bindings* + (parse-lambda) ?rewrite-closures ; + : (parse-wbindings) ( end -- ) dup parse-binding dup [ first2 [ make-local-word ] keep 2array , @@ -81,21 +99,29 @@ SYMBOL: in-lambda? : parse-wbindings ( end -- bindings vars ) [ (parse-wbindings) ] with-bindings ; +: parse-wlet ( -- form ) + "|" expect "|" parse-wbindings + (parse-lambda) ?rewrite-closures ; + : parse-locals ( -- vars assoc ) "(" expect ")" parse-effect word [ over "declared-effect" set-word-prop ] when* in>> [ dup pair? [ first ] when ] map make-locals ; -: parse-locals-definition ( word -- word quot ) - parse-locals \ ; (parse-lambda) +: parse-locals-definition ( word reader -- word quot ) + [ parse-locals ] dip + ((parse-lambda)) [ "lambda" set-word-prop ] - [ rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ] 2bi ; + [ rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ] 2bi ; inline -: (::) ( -- word def ) CREATE-WORD parse-locals-definition ; +: (::) ( -- word def ) + CREATE-WORD + [ parse-definition ] + parse-locals-definition ; : (M::) ( -- word def ) CREATE-METHOD - [ parse-locals-definition ] with-method-definition ; - -: parsed-lambda ( accum form -- accum ) - in-lambda? get [ parsed ] [ rewrite-closures over push-all ] if ; + [ + [ parse-definition ] + parse-locals-definition + ] with-method-definition ; \ No newline at end of file diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor index f0b8ac7240..87568d596a 100755 --- a/basis/locals/rewrite/sugar/sugar.factor +++ b/basis/locals/rewrite/sugar/sugar.factor @@ -37,13 +37,13 @@ M: array rewrite-literal? [ rewrite-literal? ] any? ; M: quotation rewrite-literal? [ rewrite-literal? ] any? ; +M: vector rewrite-literal? [ rewrite-literal? ] any? ; + M: wrapper rewrite-literal? wrapped>> rewrite-literal? ; -M: hashtable rewrite-literal? drop t ; +M: hashtable rewrite-literal? >alist rewrite-literal? ; -M: vector rewrite-literal? drop t ; - -M: tuple rewrite-literal? drop t ; +M: tuple rewrite-literal? tuple>array rewrite-literal? ; M: object rewrite-literal? drop f ; @@ -58,12 +58,16 @@ GENERIC: rewrite-element ( obj -- ) M: array rewrite-element dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; -M: vector rewrite-element rewrite-sequence ; +M: vector rewrite-element + dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; -M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ; +M: hashtable rewrite-element + dup rewrite-literal? [ >alist rewrite-sequence \ >hashtable , ] [ , ] if ; M: tuple rewrite-element - [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % ; + dup rewrite-literal? [ + [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % + ] [ , ] if ; M: quotation rewrite-element rewrite-sugar* ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 3fcf489413..9284f8949b 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -556,3 +556,17 @@ EXCLUDE: qualified.tests.bar => x ; [ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ] [ error>> no-word-error? ] must-fail-with + +[ [ ] ] [ + "IN: parser.tests : was-once-a-word-bug ( -- ) ;" + "was-once-a-word-test" parse-stream +] unit-test + +[ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test + +[ [ ] ] [ + "IN: parser.tests USE: words << \"was-once-a-word-bug\" \"parser.tests\" create [ ] (( -- )) define-declared >>" + "was-once-a-word-test" parse-stream +] unit-test + +[ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index cbf8754821..e39422945e 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -113,12 +113,16 @@ ERROR: staging-violation word ; : parse-until ( end -- vec ) 100 swap (parse-until) ; +SYMBOL: quotation-parser + +HOOK: parse-quotation quotation-parser ( -- quot ) + +M: f parse-quotation \ ] parse-until >quotation ; + : parsed ( accum obj -- accum ) over push ; : (parse-lines) ( lexer -- quot ) - [ - f parse-until >quotation - ] with-lexer ; + [ f parse-until >quotation ] with-lexer ; : parse-lines ( lines -- quot ) lexer-factory get call (parse-lines) ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index af5fa38aeb..8ee8b27fbc 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -94,7 +94,7 @@ IN: bootstrap.syntax lexer get skip-blank parse-string parsed ] define-syntax - "[" [ \ ] [ >quotation ] parse-literal ] define-syntax + "[" [ parse-quotation parsed ] define-syntax "{" [ \ } [ >array ] parse-literal ] define-syntax "V{" [ \ } [ >vector ] parse-literal ] define-syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax diff --git a/extra/literals/literals-tests.factor b/extra/literals/literals-tests.factor index 0e933d5209..024c94e4f2 100644 --- a/extra/literals/literals-tests.factor +++ b/extra/literals/literals-tests.factor @@ -2,11 +2,11 @@ USING: kernel literals math tools.test ; IN: literals.tests << -: six-six-six 6 6 6 ; +: six-six-six ( -- a b c ) 6 6 6 ; >> -: five 5 ; -: seven-eleven 7 11 ; +: five ( -- a ) 5 ; +: seven-eleven ( -- b c ) 7 11 ; [ { 5 } ] [ { $ five } ] unit-test [ { 7 11 } ] [ { $ seven-eleven } ] unit-test diff --git a/extra/literals/literals.factor b/extra/literals/literals.factor index d3cfcaae23..6bff666f07 100644 --- a/extra/literals/literals.factor +++ b/extra/literals/literals.factor @@ -3,4 +3,4 @@ USING: accessors continuations kernel parser words quotations vectors ; IN: literals : $ scan-word [ def>> call ] curry with-datastack >vector ; parsing -: $[ \ ] parse-until >quotation with-datastack >vector ; parsing +: $[ parse-quotation with-datastack >vector ; parsing From 180c7207472d0b0571aad5ebd515d73e257054ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Mar 2009 19:48:21 -0600 Subject: [PATCH 05/20] Change link --- basis/ui/tools/listener/listener-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/tools/listener/listener-docs.factor b/basis/ui/tools/listener/listener-docs.factor index d03995988c..caff45e40e 100644 --- a/basis/ui/tools/listener/listener-docs.factor +++ b/basis/ui/tools/listener/listener-docs.factor @@ -24,7 +24,7 @@ ARTICLE: "ui-listener" "UI listener" { $operations \ word } { $command-map interactor "quotation" } { $heading "Editing commands" } -"The text editing commands are standard; see " { $link "ui.gadgets.editors" } "." +"The text editing commands are standard; see " { $link "gadgets-editors-commands" } "." { $heading "Implementation" } "Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } "). Clickable presentations can also be printed to the listener; see " { $link "ui-presentations" } "." ; From bf663e830a7d1138c442e65c9d06a3830cbb1845 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Mar 2009 20:02:31 -0600 Subject: [PATCH 06/20] Changing a method into a generated slot accessor would result in the generated accessor being forgotten --- basis/delegate/delegate-tests.factor | 18 ++++++++++++++--- core/classes/tuple/tuple-tests.factor | 28 +++++++++++++++++++++++++++ core/parser/parser.factor | 12 ++++++++---- 3 files changed, 51 insertions(+), 7 deletions(-) diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index 4b02407735..ff55fb1282 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -125,7 +125,7 @@ PROTOCOL: silly-protocol do-me ; DEFER: slot-protocol-test-3 SLOT: y -[ f ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test +[ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test [ [ ] ] [ <" IN: delegate.tests @@ -135,7 +135,7 @@ CONSULT: y>> slot-protocol-test-3 x>> ;"> "delegate-test-1" parse-stream ] unit-test -[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test +[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test [ [ ] ] [ <" IN: delegate.tests @@ -143,4 +143,16 @@ TUPLE: slot-protocol-test-3 x y ;"> "delegate-test-1" parse-stream ] unit-test -[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test \ No newline at end of file +! We now have a real accessor for the y slot; we don't want it to +! get lost +[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test + +! We want to be able to override methods after consultation +[ [ ] ] [ + <" IN: delegate.tests + USING: delegate kernel sequences delegate.protocols accessors ; + TUPLE: override-method-test seq ; + CONSULT: sequence-protocol override-method-test seq>> ; + M: override-method-test like drop ; "> + "delegate-test-2" parse-stream +] unit-test \ No newline at end of file diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 8d2610ccd7..d221d28da9 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -703,3 +703,31 @@ TUPLE: bogus-hashcode-2 x ; M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ; [ ] [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test + +DEFER: change-slot-test +SLOT: kex + +[ ] [ + "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;" + "change-slot-test" parse-stream + drop +] unit-test + +[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test + +[ ] [ + "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test kex ;" + "change-slot-test" parse-stream + drop +] unit-test + +[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test + +[ ] [ + "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;" + "change-slot-test" parse-stream + drop +] unit-test + +[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test +[ f ] [ \ change-slot-test \ kex>> method "reading" word-prop ] unit-test \ No newline at end of file diff --git a/core/parser/parser.factor b/core/parser/parser.factor index e39422945e..9e578120f4 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -220,10 +220,14 @@ print-use-hook [ [ ] ] initialize "quiet" get [ drop ] [ "Loading " write print flush ] if ; : filter-moved ( assoc1 assoc2 -- seq ) - swap assoc-diff [ - drop where dup [ first ] when - file get path>> = - ] assoc-filter keys ; + swap assoc-diff keys [ + { + { [ dup where dup [ first ] when file get path>> = not ] [ f ] } + { [ dup "reading" word-prop ] [ f ] } + { [ dup "writing" word-prop ] [ f ] } + [ t ] + } cond nip + ] filter ; : removed-definitions ( -- assoc1 assoc2 ) new-definitions old-definitions From d27bbe844c9cdee7c0a402834d4f2b29de0b6c98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Mar 2009 20:07:33 -0600 Subject: [PATCH 07/20] Add test case for old bug dharmatech found that has since been fixed --- basis/locals/locals-tests.factor | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 2f5c72a53c..923f890adf 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -493,7 +493,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call ] unit-test -! Discovered by littledan +! littledan found this problem [ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test [ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test @@ -514,4 +514,15 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ 3 ] [ 3 f erg's-:>-bug-2 ] unit-test -[ 3 ] [ 3 t erg's-:>-bug-2 ] unit-test \ No newline at end of file +[ 3 ] [ 3 t erg's-:>-bug-2 ] unit-test + +! dharmatech found this problem +GENERIC: ed's-bug ( a -- b ) + +M: string ed's-bug reverse ; +M: integer ed's-bug neg ; + +:: ed's-test-case ( a -- b ) + { [ a ed's-bug ] } && ; + +[ t ] [ \ ed's-test-case optimized>> ] unit-test \ No newline at end of file From 44815fd981efb3fecddadd8bc1506bd4b21362d0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Mar 2009 23:33:03 -0600 Subject: [PATCH 08/20] Better handling of case when user-defined accessor becomes auto-generated --- core/parser/parser.factor | 6 +++--- core/slots/slots.factor | 4 ++++ 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 9e578120f4..ac1c2695f2 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -5,7 +5,7 @@ sequences strings vectors words words.symbol quotations io combinators sorting splitting math.parser effects continuations io.files vocabs io.encodings.utf8 source-files classes hashtables compiler.errors compiler.units accessors sets -lexer vocabs.parser ; +lexer vocabs.parser slots ; IN: parser : location ( -- loc ) @@ -223,8 +223,8 @@ print-use-hook [ [ ] ] initialize swap assoc-diff keys [ { { [ dup where dup [ first ] when file get path>> = not ] [ f ] } - { [ dup "reading" word-prop ] [ f ] } - { [ dup "writing" word-prop ] [ f ] } + { [ dup reader-method? ] [ f ] } + { [ dup writer-method? ] [ f ] } [ t ] } cond nip ] filter ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index ea020c5c55..71c2bdcc90 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -10,8 +10,12 @@ TUPLE: slot-spec name offset class initial read-only ; PREDICATE: reader < word "reader" word-prop ; +PREDICATE: reader-method < method-body "reading" word-prop ; + PREDICATE: writer < word "writer" word-prop ; +PREDICATE: writer-method < method-body "writing" word-prop ; + : ( -- slot-spec ) slot-spec new object bootstrap-word >>class ; From 37bc52afa8240b448d475a2c67ad2d196592fb67 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Mar 2009 23:33:30 -0600 Subject: [PATCH 09/20] Redefining methods didn't always update callers if more than one method on the same generic was redefined in a compilation unit --- basis/compiler/tests/redefine1.factor | 30 +++++++++++++++++++++------ core/compiler/units/units.factor | 12 +++++------ core/definitions/definitions.factor | 16 ++------------ core/generic/generic.factor | 7 +++++++ 4 files changed, 38 insertions(+), 27 deletions(-) diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index b5835de5fd..0875967bd2 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -1,24 +1,42 @@ USING: accessors compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic -definitions arrays words assocs eval ; +definitions arrays words assocs eval strings ; IN: compiler.tests -GENERIC: method-redefine-test ( a -- b ) +GENERIC: method-redefine-generic-1 ( a -- b ) -M: integer method-redefine-test 3 + ; +M: integer method-redefine-generic-1 3 + ; -: method-redefine-test-1 ( -- b ) 3 method-redefine-test ; +: method-redefine-test-1 ( -- b ) 3 method-redefine-generic-1 ; [ 6 ] [ method-redefine-test-1 ] unit-test -[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test +[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test [ 7 ] [ method-redefine-test-1 ] unit-test -[ ] [ [ fixnum \ method-redefine-test method forget ] with-compilation-unit ] unit-test +[ ] [ [ fixnum \ method-redefine-generic-1 method forget ] with-compilation-unit ] unit-test [ 6 ] [ method-redefine-test-1 ] unit-test +GENERIC: method-redefine-generic-2 ( a -- b ) + +M: integer method-redefine-generic-2 3 + ; + +: method-redefine-test-2 ( -- b ) 3 method-redefine-generic-2 ; + +[ 6 ] [ method-redefine-test-2 ] unit-test + +[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test + +[ 7 ] [ method-redefine-test-2 ] unit-test + +[ ] [ + [ + fixnum string [ \ method-redefine-generic-2 method forget ] bi@ + ] with-compilation-unit +] unit-test + ! Test ripple-up behavior : hey ( -- ) ; : there ( -- ) hey ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 0577f8b83c..6fb7fc8ad5 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -72,14 +72,12 @@ SYMBOL: outdated-tuples SYMBOL: update-tuples-hook SYMBOL: remake-generics-hook +: index>= ( obj1 obj2 seq -- ? ) + [ index ] curry bi@ >= ; + : dependency>= ( how1 how2 -- ? ) - [ - { - called-dependency - flushed-dependency - inlined-dependency - } index - ] bi@ >= ; + { called-dependency flushed-dependency inlined-dependency } + index>= ; : strongest-dependency ( how1 how2 -- how ) [ called-dependency or ] bi@ [ dependency>= ] most ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 726116909f..db99d7e3a3 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -9,13 +9,9 @@ SYMBOL: inlined-dependency SYMBOL: flushed-dependency SYMBOL: called-dependency - - SYMBOL: changed-definitions : changed-definition ( defspec -- ) @@ -23,14 +19,8 @@ SYMBOL: changed-definitions SYMBOL: changed-generics -: changed-generic ( class generic -- ) - changed-generics get set-in-unit ; - SYMBOL: remake-generics -: remake-generic ( generic -- ) - dup remake-generics get set-in-unit ; - SYMBOL: new-classes : new-class ( word -- ) @@ -52,11 +42,9 @@ M: object forget* drop ; SYMBOL: forgotten-definitions : forgotten-definition ( defspec -- ) - dup forgotten-definitions get - [ no-compilation-unit ] unless* - set-at ; + dup forgotten-definitions get set-in-unit ; -: forget ( defspec -- ) dup forgotten-definition forget* ; +: forget ( defspec -- ) [ forgotten-definition ] [ forget* ] bi ; : forget-all ( definitions -- ) [ forget ] each ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index c520b4aaac..93c3e7f75c 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -71,6 +71,13 @@ 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 remake-generics get set-in-unit ; + : with-methods ( class generic quot -- ) [ drop changed-generic ] [ [ "methods" word-prop ] dip call ] From 42224eb4e77289772201b4eff90d61d5b87b4337 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Mar 2009 23:34:01 -0600 Subject: [PATCH 10/20] Propagation pass: add inlined node counts to total node count, so that the more we inline the less we are eager to inline more --- .../tree/propagation/inlining/inlining.factor | 19 +++++++++---------- .../tree/propagation/propagation.factor | 2 +- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index b2388c30d2..953956c3bd 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -17,8 +17,10 @@ IN: compiler.tree.propagation.inlining ! we are more eager to inline SYMBOL: node-count -: count-nodes ( nodes -- ) - 0 swap [ drop 1+ ] each-node node-count set ; +: count-nodes ( nodes -- n ) + 0 swap [ drop 1+ ] each-node ; + +: compute-node-count ( nodes -- ) count-nodes node-count set ; ! We try not to inline the same word too many times, to avoid ! combinatorial explosion @@ -33,9 +35,6 @@ M: word splicing-nodes M: callable splicing-nodes build-sub-tree analyze-recursive normalize ; -: propagate-body ( #call -- ) - body>> (propagate) ; - ! Dispatch elimination : eliminate-dispatch ( #call class/f word/quot/f -- ? ) dup [ @@ -44,7 +43,7 @@ M: callable splicing-nodes 2dup splicing-nodes [ >>method ] [ >>body ] bi* ] if - propagate-body t + body>> (propagate) t ] [ 2drop f >>method f >>body f >>class drop f ] if ; : inlining-standard-method ( #call word -- class/f method/f ) @@ -161,10 +160,10 @@ SYMBOL: history : inline-word-def ( #call word quot -- ? ) over history get memq? [ 3drop f ] [ [ - swap remember-inlining - dupd splicing-nodes >>body - propagate-body - ] with-scope + [ remember-inlining ] dip + [ drop ] [ splicing-nodes ] 2bi + [ >>body drop ] [ count-nodes ] [ (propagate) ] tri + ] with-scope node-count +@ t ] if ; diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor index 2a9825e3f1..3dd2c4998a 100644 --- a/basis/compiler/tree/propagation/propagation.factor +++ b/basis/compiler/tree/propagation/propagation.factor @@ -20,5 +20,5 @@ IN: compiler.tree.propagation H{ } clone 1array value-infos set H{ } clone 1array constraints set H{ } clone inlining-count set - dup count-nodes + dup compute-node-count dup (propagate) ; From bfb6b4642ac7c624e0285050587347c628f38071 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Mar 2009 00:42:43 -0600 Subject: [PATCH 11/20] Consultations now implement the definition protocol; removing one from a source file forgets consulted methods --- basis/delegate/delegate-tests.factor | 45 ++++++++++++++- basis/delegate/delegate.factor | 85 ++++++++++++++++++++++------ core/compiler/units/units.factor | 3 + core/generic/generic.factor | 2 +- core/parser/parser-tests.factor | 20 +++++++ core/syntax/syntax.factor | 3 +- 6 files changed, 136 insertions(+), 22 deletions(-) diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index ff55fb1282..e2bea82e68 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -1,6 +1,7 @@ USING: delegate kernel arrays tools.test words math definitions compiler.units parser generic prettyprint io.streams.string -accessors eval multiline ; +accessors eval multiline generic.standard delegate.protocols +delegate.private assocs ; IN: delegate.tests TUPLE: hello this that ; @@ -35,7 +36,7 @@ M: hello bing hello-test ; [ 3 ] [ 1 0 f 2 whoa ] unit-test [ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test -[ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test +[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test [ H{ } ] [ bee protocol-consult ] unit-test [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test @@ -112,6 +113,7 @@ PROTOCOL: silly-protocol do-me ; [ ] [ T{ a-tuple } do-me ] unit-test +! Change method definition to consultation [ [ ] ] [ <" IN: delegate.tests USE: kernel @@ -119,8 +121,17 @@ PROTOCOL: silly-protocol do-me ; CONSULT: silly-protocol a-tuple drop f ; "> "delegate-test" parse-stream ] unit-test +! Method should be there [ ] [ T{ a-tuple } do-me ] unit-test +! Now try removing the consulation +[ [ ] ] [ + <" IN: delegate.tests "> "delegate-test" parse-stream +] unit-test + +! Method should be gone +[ T{ a-tuple } do-me ] [ no-method? ] must-fail-with + ! A slot protocol issue DEFER: slot-protocol-test-3 SLOT: y @@ -155,4 +166,34 @@ TUPLE: slot-protocol-test-3 x y ;"> CONSULT: sequence-protocol override-method-test seq>> ; M: override-method-test like drop ; "> "delegate-test-2" parse-stream +] unit-test + +DEFER: seq-delegate + +! See if removing a consultation updates protocol-consult word prop +[ [ ] ] [ + <" IN: delegate.tests + USING: accessors delegate delegate.protocols ; + TUPLE: seq-delegate seq ; + CONSULT: sequence-protocol seq-delegate seq>> ;"> + "remove-consult-test" parse-stream +] unit-test + +[ t ] [ + seq-delegate + sequence-protocol \ protocol-consult word-prop + key? +] unit-test + +[ [ ] ] [ + <" IN: delegate.tests + USING: delegate delegate.protocols ; + TUPLE: seq-delegate seq ;"> + "remove-consult-test" parse-stream +] unit-test + +[ f ] [ + seq-delegate + sequence-protocol \ protocol-consult word-prop + key? ] unit-test \ No newline at end of file diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index a4eef54907..5e8d627434 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -2,10 +2,13 @@ ! Portions copyright (C) 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes.tuple definitions generic -generic.standard hashtables kernel lexer make math parser -generic.parser sequences sets slots words words.symbol fry ; +generic.standard hashtables kernel lexer math parser +generic.parser sequences sets slots words words.symbol fry +locals combinators.short-circuit compiler.units ; IN: delegate + ( group class quot -- consultation ) + f consultation boa ; + +: create-consult-method ( word consultation -- method ) + [ class>> swap first create-method dup fake-definition ] keep + [ drop ] [ "consultation" set-word-prop ] 2bi ; + +PREDICATE: consult-method < method-body "consultation" word-prop ; + +M: consult-method reset-word + [ call-next-method ] [ f "consultation" set-word-prop ] bi ; + +: consult-method-quot ( quot word -- object ) + [ second [ [ dip ] curry ] times ] [ first ] bi + '[ _ call _ execute ] ; + +: consult-method ( word consultation -- ) + [ create-consult-method ] + [ quot>> swap consult-method-quot ] 2bi define ; : change-word-prop ( word prop quot -- ) [ swap props>> ] dip change-at ; inline -: register-protocol ( group class quot -- ) - [ \ protocol-consult ] 2dip - '[ [ _ _ swap ] dip ?set-at ] change-word-prop ; +: each-generic ( consultation quot -- ) + [ [ group>> group-words ] keep ] dip curry each ; inline -: define-consult ( group class quot -- ) - [ register-protocol ] - [ [ group-words ] 2dip '[ _ _ consult-method ] each ] - 3bi ; +: register-consult ( consultation -- ) + [ group>> \ protocol-consult ] [ ] [ class>> ] tri + '[ [ _ _ ] dip ?set-at ] change-word-prop ; + +: consult-methods ( consultation -- ) + [ consult-method ] each-generic ; + +: unregister-consult ( consultation -- ) + [ class>> ] [ group>> ] bi + \ protocol-consult word-prop delete-at ; + +:: unconsult-method ( word consultation -- ) + consultation class>> word first method + dup { [ ] [ "consultation" word-prop consultation eq? ] } 1&& + [ forget ] [ drop ] if ; + +: unconsult-methods ( consultation -- ) + [ unconsult-method ] each-generic ; + +PRIVATE> + +: define-consult ( consultation -- ) + [ register-consult ] [ consult-methods ] bi ; : CONSULT: - scan-word scan-word parse-definition define-consult ; parsing + scan-word scan-word parse-definition + [ save-location ] [ define-consult ] bi ; parsing + +M: consultation where loc>> ; + +M: consultation set-where (>>loc) ; + +M: consultation forget* + [ unconsult-methods ] [ unregister-consult ] bi ; ! Protocols +alist ] [ added-words ] 2bi - [ swap first2 consult-method ] cross-2each ; + [ drop protocol-consult values ] [ added-words ] 2bi + [ swap consult-method ] cross-2each ; : initialize-protocol-props ( protocol wordlist -- ) [ @@ -81,6 +129,11 @@ M: tuple-class group-words : fill-in-depth ( wordlist -- wordlist' ) [ dup word? [ 0 2array ] when ] map ; +: show-words ( wordlist' -- wordlist ) + [ dup second zero? [ first ] when ] map ; + +PRIVATE> + : define-protocol ( protocol wordlist -- ) [ drop define-symbol ] [ fill-in-depth @@ -97,8 +150,6 @@ PREDICATE: protocol < word protocol-words ; ! Subclass of symbol? M: protocol forget* [ f forget-old-definitions ] [ call-next-method ] bi ; -: show-words ( wordlist' -- wordlist ) - [ dup second zero? [ first ] when ] map ; M: protocol definition protocol-words show-words ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 6fb7fc8ad5..178e29fd93 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -23,6 +23,9 @@ TUPLE: redefine-error def ; : remember-definition ( definition loc -- ) new-definitions get first (remember-definition) ; +: fake-definition ( definition -- ) + old-definitions get [ delete-at ] with each ; + : remember-class ( class loc -- ) [ dup new-definitions get first key? [ dup redefine-error ] when ] dip new-definitions get second (remember-definition) ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 93c3e7f75c..351a8f98fd 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -120,7 +120,7 @@ M: method-body crossref? 2bi ; : create-method ( class generic -- method ) - 2dup method dup [ 2nip ] [ + 2dup method dup [ 2nip dup reset-generic ] [ drop [ dup ] 2keep reveal-method diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 9284f8949b..5ec9ea9b3c 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -557,6 +557,9 @@ EXCLUDE: qualified.tests.bar => x ; [ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ] [ error>> no-word-error? ] must-fail-with +! Two similar bugs + +! Replace : def with something in << >> [ [ ] ] [ "IN: parser.tests : was-once-a-word-bug ( -- ) ;" "was-once-a-word-test" parse-stream @@ -570,3 +573,20 @@ EXCLUDE: qualified.tests.bar => x ; ] unit-test [ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test + +! Replace : def with DEFER: +[ [ ] ] [ + "IN: parser.tests : is-not-deferred ( -- ) ;" + "is-not-deferred" parse-stream +] unit-test + +[ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test +[ f ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test + +[ [ ] ] [ + "IN: parser.tests DEFER: is-not-deferred" + "is-not-deferred" parse-stream +] unit-test + +[ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test +[ t ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 8ee8b27fbc..de3be98ceb 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -135,8 +135,7 @@ IN: bootstrap.syntax "DEFER:" [ scan current-vocab create - dup old-definitions get [ delete-at ] with each - set-word + [ fake-definition ] [ set-word ] [ [ undefined ] define ] tri ] define-syntax ":" [ From 00f586fc335bd9744dd9e78ae155ed422fb30ff8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Mar 2009 00:49:57 -0600 Subject: [PATCH 12/20] Fix bootstrap: delegate cannot depend on locals since locals depends on delegate --- basis/delegate/delegate.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index 5e8d627434..0c16b7c336 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs classes.tuple definitions generic generic.standard hashtables kernel lexer math parser generic.parser sequences sets slots words words.symbol fry -locals combinators.short-circuit compiler.units ; +compiler.units ; IN: delegate > ] [ group>> ] bi \ protocol-consult word-prop delete-at ; -:: unconsult-method ( word consultation -- ) - consultation class>> word first method - dup { [ ] [ "consultation" word-prop consultation eq? ] } 1&& - [ forget ] [ drop ] if ; +: unconsult-method ( word consultation -- ) + [ class>> swap first method ] keep + over [ + over "consultation" word-prop eq? + [ forget ] [ drop ] if + ] [ 2drop ] if ; : unconsult-methods ( consultation -- ) [ unconsult-method ] each-generic ; From a472b904ebde17c7aa276add8f89bc4b77e59327 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Mar 2009 00:56:52 -0600 Subject: [PATCH 13/20] Fix delegate docs --- basis/delegate/delegate-docs.factor | 12 ++++++++++-- basis/delegate/tags.txt | 1 + 2 files changed, 11 insertions(+), 2 deletions(-) create mode 100644 basis/delegate/tags.txt diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor index 5a2f4802e9..9456941880 100644 --- a/basis/delegate/delegate-docs.factor +++ b/basis/delegate/delegate-docs.factor @@ -1,4 +1,4 @@ -USING: help.syntax help.markup ; +USING: help.syntax help.markup delegate.private ; IN: delegate HELP: define-protocol @@ -8,7 +8,7 @@ HELP: define-protocol HELP: PROTOCOL: { $syntax "PROTOCOL: protocol-name words... ;" } -{ $description "Defines an explicit protocol, which can be used as a basis for delegation or mimicry." } ; +{ $description "Defines an explicit protocol, which can be used as a basis for delegation." } ; { define-protocol POSTPONE: PROTOCOL: } related-words @@ -22,6 +22,12 @@ HELP: CONSULT: { $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } } { $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ; +HELP: SLOT-PROTOCOL: +{ $syntax "SLOT-PROTOCOL: protocol-name slots... ;" } +{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ; + +{ define-protocol POSTPONE: PROTOCOL: } related-words + { define-consult POSTPONE: CONSULT: } related-words HELP: group-words @@ -40,6 +46,8 @@ $nl "Defining new protocols:" { $subsection POSTPONE: PROTOCOL: } { $subsection define-protocol } +"Defining new protocols consisting of slot accessors:" +{ $subsection POSTPONE: SLOT-PROTOCOL: } "Defining consultation:" { $subsection POSTPONE: CONSULT: } { $subsection define-consult } diff --git a/basis/delegate/tags.txt b/basis/delegate/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/delegate/tags.txt @@ -0,0 +1 @@ +extensions From c2a061392951a31ac9e801a5e25f53901e0973a7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Mar 2009 00:57:04 -0600 Subject: [PATCH 14/20] Updating meta-data --- basis/constructors/tags.txt | 1 + extra/literals/tags.txt | 1 + 2 files changed, 2 insertions(+) create mode 100644 basis/constructors/tags.txt diff --git a/basis/constructors/tags.txt b/basis/constructors/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/constructors/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/extra/literals/tags.txt b/extra/literals/tags.txt index 71c0ff7282..4f4a20b1cb 100644 --- a/extra/literals/tags.txt +++ b/extra/literals/tags.txt @@ -1 +1,2 @@ +extensions syntax From 375c5e69b50b7c00bc363d080eebd20e9d0fb025 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Mar 2009 01:22:21 -0600 Subject: [PATCH 15/20] Various load-everything fixes --- basis/opengl/opengl.factor | 2 +- basis/tools/vocabs/browser/browser.factor | 4 +- basis/ui/gadgets/canvas/canvas.factor | 14 +- basis/ui/pens/polygon/polygon-docs.factor | 2 +- basis/ui/pens/polygon/polygon.factor | 3 +- basis/ui/windows/summary.txt | 1 - basis/ui/x11/summary.txt | 1 - basis/ui/x11/x11.factor | 297 ------------------ extra/annotations/annotations.factor | 3 +- extra/bunny/outlined/outlined.factor | 2 +- extra/color-picker/color-picker.factor | 14 +- extra/demos/demos.factor | 2 +- extra/game-input/game-input-tests.factor | 7 + extra/images/viewer/viewer.factor | 2 +- extra/joystick-demo/joystick-demo.factor | 20 +- extra/key-caps/key-caps.factor | 2 +- extra/lcd/lcd.factor | 4 +- extra/maze/maze.factor | 2 +- extra/nehe/nehe.factor | 8 +- extra/opengl/demo-support/demo-support.factor | 4 +- extra/slides/slides.factor | 11 +- extra/spheres/spheres.factor | 2 +- extra/tetris/gl/gl.factor | 6 +- extra/tetris/tetromino/tetromino.factor | 18 +- .../L-system/L-system.factor | 0 .../L-system/models/abop-1/abop-1.factor | 0 .../L-system/models/abop-2/abop-2.factor | 0 .../L-system/models/abop-3/abop-3.factor | 0 .../L-system/models/abop-4/abop-4.factor | 0 .../abop-5-angular/abop-5-angular.factor | 0 .../L-system/models/abop-5/abop-5.factor | 0 .../L-system/models/abop-6/abop-6.factor | 0 .../L-system/models/airhorse/airhorse.factor | 0 .../L-system/models/tree-5/tree-5.factor | 0 {extra => unmaintained}/boids/authors.txt | 0 {extra => unmaintained}/boids/boids.factor | 0 {extra => unmaintained}/boids/summary.txt | 0 .../bubble-chamber/bubble-chamber.factor | 0 .../hadron-chamber/hadron-chamber.factor | 0 .../bubble-chamber/hadron-chamber/tags.txt | 0 .../bubble-chamber/large/large.factor | 0 .../bubble-chamber/large/tags.txt | 0 .../bubble-chamber/medium/medium.factor | 0 .../bubble-chamber/medium/tags.txt | 0 .../bubble-chamber/original/original.factor | 0 .../bubble-chamber/original/tags.txt | 0 .../quark-chamber/quark-chamber.factor | 0 .../bubble-chamber/quark-chamber/tags.txt | 0 .../bubble-chamber/small/small.factor | 0 .../bubble-chamber/small/tags.txt | 0 .../bubble-chamber/ten-hadrons/tags.txt | 0 .../ten-hadrons/ten-hadrons.factor | 0 .../cairo-demo/authors.txt | 0 .../cairo-demo/cairo-demo.factor | 0 .../cairo-gadgets}/gadgets.factor | 0 .../cairo-gadgets}/summary.txt | 0 .../cairo-samples/cairo-samples.factor | 0 .../cartesian/cartesian.factor | 0 {extra => unmaintained}/cfdg/authors.txt | 0 {extra => unmaintained}/cfdg/cfdg.factor | 0 {extra => unmaintained}/cfdg/gl/authors.txt | 0 {extra => unmaintained}/cfdg/gl/gl.factor | 0 .../cfdg/models/aqua-star/aqua-star.factor | 0 .../cfdg/models/aqua-star/authors.txt | 0 .../cfdg/models/aqua-star/tags.txt | 0 .../cfdg/models/chiaroscuro/authors.txt | 0 .../models/chiaroscuro/chiaroscuro.factor | 0 .../cfdg/models/chiaroscuro/tags.txt | 0 .../cfdg/models/flower6/authors.txt | 0 .../cfdg/models/flower6/deploy.factor | 0 .../cfdg/models/flower6/flower6.factor | 0 .../cfdg/models/flower6/tags.txt | 0 .../cfdg/models/game1-turn6/authors.txt | 0 .../models/game1-turn6/game1-turn6.factor | 0 .../cfdg/models/game1-turn6/tags.txt | 0 .../cfdg/models/lesson/authors.txt | 0 .../cfdg/models/lesson/lesson.factor | 0 .../cfdg/models/lesson/tags.txt | 0 .../cfdg/models/rules08/rules08.factor | 0 .../cfdg/models/rules08/tags.txt | 0 .../cfdg/models/sierpinski/authors.txt | 0 .../cfdg/models/sierpinski/sierpinski.factor | 0 .../cfdg/models/sierpinski/tags.txt | 0 .../cfdg/models/snowflake/authors.txt | 0 .../cfdg/models/snowflake/snowflake.factor | 0 .../cfdg/models/snowflake/tags.txt | 0 .../cfdg/models/spirales/spirales.factor | 0 .../cfdg/models/spirales/tags.txt | 0 {extra => unmaintained}/cfdg/summary.txt | 0 .../frame-buffer/frame-buffer.factor | 0 .../golden-section/authors.txt | 0 .../golden-section/deploy.factor | 0 .../golden-section/golden-section.factor | 0 .../golden-section/summary.txt | 0 .../golden-section/tags.txt | 0 .../ui => unmaintained/irc-ui}/authors.txt | 0 .../commandparser/commandparser.factor | 0 .../irc-ui}/commands/commands.factor | 0 .../irc/ui => unmaintained/irc-ui}/ircui-rc | 0 .../irc-ui}/load/load.factor | 0 .../ui => unmaintained/irc-ui}/summary.txt | 0 .../irc/ui => unmaintained/irc-ui}/ui.factor | 0 {extra => unmaintained}/pong/pong.factor | 0 .../processing/shapes/shapes.factor | 0 .../slate}/authors.txt | 0 .../slate/slate-docs.factor | 0 .../slate/slate.factor | 0 .../springies}/authors.txt | 0 .../springies/models/2snake/2snake.factor | 0 .../springies/models/2snake}/authors.txt | 0 .../springies/models/2snake/tags.txt | 0 .../springies/models/2x2snake/2x2snake.factor | 0 .../springies/models/2x2snake}/authors.txt | 0 .../springies/models/2x2snake/deploy.factor | 0 .../springies/models/2x2snake/tags.txt | 0 .../springies/models/3snake/3snake.factor | 0 .../springies/models/3snake}/authors.txt | 0 .../springies/models/3snake/tags.txt | 0 .../springies/models/ball}/authors.txt | 0 .../springies/models/ball/ball.factor | 0 .../springies/models/ball/tags.txt | 0 .../springies/models/belt-tire}/authors.txt | 0 .../models/belt-tire/belt-tire.factor | 0 .../springies/models/belt-tire/deploy.factor | 0 .../springies/models/belt-tire/tags.txt | 0 .../springies/models/nifty}/authors.txt | 0 .../springies/models/nifty/nifty.factor | 0 .../springies/models/nifty/tags.txt | 0 .../springies/models/urchin}/authors.txt | 0 .../springies/models/urchin/tags.txt | 0 .../springies/models/urchin/urchin.factor | 0 .../springies/springies.factor | 0 {extra => unmaintained}/springies/summary.txt | 0 {extra => unmaintained}/springies/tags.factor | 0 .../springies/ui}/authors.txt | 0 .../springies/ui/ui.factor | 0 .../gadgets => unmaintained}/tabs/authors.txt | 0 .../gadgets => unmaintained}/tabs/summary.txt | 0 .../gadgets => unmaintained}/tabs/tabs.factor | 0 {extra => unmaintained}/trails/trails.factor | 0 140 files changed, 70 insertions(+), 361 deletions(-) delete mode 100644 basis/ui/windows/summary.txt delete mode 100644 basis/ui/x11/summary.txt delete mode 100755 basis/ui/x11/x11.factor create mode 100644 extra/game-input/game-input-tests.factor rename {extra => unmaintained}/L-system/L-system.factor (100%) rename {extra => unmaintained}/L-system/models/abop-1/abop-1.factor (100%) rename {extra => unmaintained}/L-system/models/abop-2/abop-2.factor (100%) rename {extra => unmaintained}/L-system/models/abop-3/abop-3.factor (100%) rename {extra => unmaintained}/L-system/models/abop-4/abop-4.factor (100%) rename {extra => unmaintained}/L-system/models/abop-5-angular/abop-5-angular.factor (100%) rename {extra => unmaintained}/L-system/models/abop-5/abop-5.factor (100%) rename {extra => unmaintained}/L-system/models/abop-6/abop-6.factor (100%) rename {extra => unmaintained}/L-system/models/airhorse/airhorse.factor (100%) rename {extra => unmaintained}/L-system/models/tree-5/tree-5.factor (100%) rename {extra => unmaintained}/boids/authors.txt (100%) rename {extra => unmaintained}/boids/boids.factor (100%) rename {extra => unmaintained}/boids/summary.txt (100%) rename {extra => unmaintained}/bubble-chamber/bubble-chamber.factor (100%) rename {extra => unmaintained}/bubble-chamber/hadron-chamber/hadron-chamber.factor (100%) rename {extra => unmaintained}/bubble-chamber/hadron-chamber/tags.txt (100%) rename {extra => unmaintained}/bubble-chamber/large/large.factor (100%) rename {extra => unmaintained}/bubble-chamber/large/tags.txt (100%) rename {extra => unmaintained}/bubble-chamber/medium/medium.factor (100%) rename {extra => unmaintained}/bubble-chamber/medium/tags.txt (100%) rename {extra => unmaintained}/bubble-chamber/original/original.factor (100%) rename {extra => unmaintained}/bubble-chamber/original/tags.txt (100%) rename {extra => unmaintained}/bubble-chamber/quark-chamber/quark-chamber.factor (100%) rename {extra => unmaintained}/bubble-chamber/quark-chamber/tags.txt (100%) rename {extra => unmaintained}/bubble-chamber/small/small.factor (100%) rename {extra => unmaintained}/bubble-chamber/small/tags.txt (100%) rename {extra => unmaintained}/bubble-chamber/ten-hadrons/tags.txt (100%) rename {extra => unmaintained}/bubble-chamber/ten-hadrons/ten-hadrons.factor (100%) rename {extra => unmaintained}/cairo-demo/authors.txt (100%) rename {extra => unmaintained}/cairo-demo/cairo-demo.factor (100%) rename {basis/cairo/gadgets => unmaintained/cairo-gadgets}/gadgets.factor (100%) rename {basis/cairo/gadgets => unmaintained/cairo-gadgets}/summary.txt (100%) rename {extra => unmaintained}/cairo-samples/cairo-samples.factor (100%) rename {extra/ui/gadgets => unmaintained}/cartesian/cartesian.factor (100%) rename {extra => unmaintained}/cfdg/authors.txt (100%) rename {extra => unmaintained}/cfdg/cfdg.factor (100%) rename {extra => unmaintained}/cfdg/gl/authors.txt (100%) rename {extra => unmaintained}/cfdg/gl/gl.factor (100%) rename {extra => unmaintained}/cfdg/models/aqua-star/aqua-star.factor (100%) rename {extra => unmaintained}/cfdg/models/aqua-star/authors.txt (100%) rename {extra => unmaintained}/cfdg/models/aqua-star/tags.txt (100%) rename {extra => unmaintained}/cfdg/models/chiaroscuro/authors.txt (100%) rename {extra => unmaintained}/cfdg/models/chiaroscuro/chiaroscuro.factor (100%) rename {extra => unmaintained}/cfdg/models/chiaroscuro/tags.txt (100%) rename {extra => unmaintained}/cfdg/models/flower6/authors.txt (100%) rename {extra => unmaintained}/cfdg/models/flower6/deploy.factor (100%) rename {extra => unmaintained}/cfdg/models/flower6/flower6.factor (100%) rename {extra => unmaintained}/cfdg/models/flower6/tags.txt (100%) rename {extra => unmaintained}/cfdg/models/game1-turn6/authors.txt (100%) rename {extra => unmaintained}/cfdg/models/game1-turn6/game1-turn6.factor (100%) rename {extra => unmaintained}/cfdg/models/game1-turn6/tags.txt (100%) rename {extra => unmaintained}/cfdg/models/lesson/authors.txt (100%) rename {extra => unmaintained}/cfdg/models/lesson/lesson.factor (100%) rename {extra => unmaintained}/cfdg/models/lesson/tags.txt (100%) rename {extra => unmaintained}/cfdg/models/rules08/rules08.factor (100%) rename {extra => unmaintained}/cfdg/models/rules08/tags.txt (100%) rename {extra => unmaintained}/cfdg/models/sierpinski/authors.txt (100%) rename {extra => unmaintained}/cfdg/models/sierpinski/sierpinski.factor (100%) rename {extra => unmaintained}/cfdg/models/sierpinski/tags.txt (100%) rename {extra => unmaintained}/cfdg/models/snowflake/authors.txt (100%) rename {extra => unmaintained}/cfdg/models/snowflake/snowflake.factor (100%) rename {extra => unmaintained}/cfdg/models/snowflake/tags.txt (100%) rename {extra => unmaintained}/cfdg/models/spirales/spirales.factor (100%) rename {extra => unmaintained}/cfdg/models/spirales/tags.txt (100%) rename {extra => unmaintained}/cfdg/summary.txt (100%) rename {extra => unmaintained}/frame-buffer/frame-buffer.factor (100%) rename {extra => unmaintained}/golden-section/authors.txt (100%) rename {extra => unmaintained}/golden-section/deploy.factor (100%) rename {extra => unmaintained}/golden-section/golden-section.factor (100%) rename {extra => unmaintained}/golden-section/summary.txt (100%) rename {extra => unmaintained}/golden-section/tags.txt (100%) rename {extra/irc/ui => unmaintained/irc-ui}/authors.txt (100%) rename {extra/irc/ui => unmaintained/irc-ui}/commandparser/commandparser.factor (100%) rename {extra/irc/ui => unmaintained/irc-ui}/commands/commands.factor (100%) rename {extra/irc/ui => unmaintained/irc-ui}/ircui-rc (100%) rename {extra/irc/ui => unmaintained/irc-ui}/load/load.factor (100%) rename {extra/irc/ui => unmaintained/irc-ui}/summary.txt (100%) rename {extra/irc/ui => unmaintained/irc-ui}/ui.factor (100%) rename {extra => unmaintained}/pong/pong.factor (100%) rename {extra => unmaintained}/processing/shapes/shapes.factor (100%) rename {extra/springies => unmaintained/slate}/authors.txt (100%) mode change 100644 => 100755 rename {extra/ui/gadgets => unmaintained}/slate/slate-docs.factor (100%) rename {extra/ui/gadgets => unmaintained}/slate/slate.factor (100%) rename {extra/springies/models/2snake => unmaintained/springies}/authors.txt (100%) mode change 100755 => 100644 rename {extra => unmaintained}/springies/models/2snake/2snake.factor (100%) rename {extra/springies/models/2x2snake => unmaintained/springies/models/2snake}/authors.txt (100%) rename {extra => unmaintained}/springies/models/2snake/tags.txt (100%) rename {extra => unmaintained}/springies/models/2x2snake/2x2snake.factor (100%) rename {extra/springies/models/3snake => unmaintained/springies/models/2x2snake}/authors.txt (100%) rename {extra => unmaintained}/springies/models/2x2snake/deploy.factor (100%) rename {extra => unmaintained}/springies/models/2x2snake/tags.txt (100%) rename {extra => unmaintained}/springies/models/3snake/3snake.factor (100%) rename {extra/springies/models/ball => unmaintained/springies/models/3snake}/authors.txt (100%) rename {extra => unmaintained}/springies/models/3snake/tags.txt (100%) rename {extra/springies/models/belt-tire => unmaintained/springies/models/ball}/authors.txt (100%) rename {extra => unmaintained}/springies/models/ball/ball.factor (100%) rename {extra => unmaintained}/springies/models/ball/tags.txt (100%) rename {extra/springies/models/nifty => unmaintained/springies/models/belt-tire}/authors.txt (100%) rename {extra => unmaintained}/springies/models/belt-tire/belt-tire.factor (100%) rename {extra => unmaintained}/springies/models/belt-tire/deploy.factor (100%) rename {extra => unmaintained}/springies/models/belt-tire/tags.txt (100%) rename {extra/springies/models/urchin => unmaintained/springies/models/nifty}/authors.txt (100%) rename {extra => unmaintained}/springies/models/nifty/nifty.factor (100%) rename {extra => unmaintained}/springies/models/nifty/tags.txt (100%) rename {extra/springies/ui => unmaintained/springies/models/urchin}/authors.txt (100%) rename {extra => unmaintained}/springies/models/urchin/tags.txt (100%) rename {extra => unmaintained}/springies/models/urchin/urchin.factor (100%) rename {extra => unmaintained}/springies/springies.factor (100%) rename {extra => unmaintained}/springies/summary.txt (100%) rename {extra => unmaintained}/springies/tags.factor (100%) rename {extra/ui/gadgets/slate => unmaintained/springies/ui}/authors.txt (100%) rename {extra => unmaintained}/springies/ui/ui.factor (100%) rename {extra/ui/gadgets => unmaintained}/tabs/authors.txt (100%) rename {extra/ui/gadgets => unmaintained}/tabs/summary.txt (100%) rename {extra/ui/gadgets => unmaintained}/tabs/tabs.factor (100%) rename {extra => unmaintained}/trails/trails.factor (100%) diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 4b2906db95..e08a7487ae 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -42,7 +42,7 @@ MACRO: all-enabled ( seq quot -- ) [ words>values ] dip '[ _ _ (all-enabled) ] ; MACRO: all-enabled-client-state ( seq quot -- ) - [ words>values ] dip '[ _ (all-enabled-client-state) ] ; + [ words>values ] dip '[ _ _ (all-enabled-client-state) ] ; : do-matrix ( mode quot -- ) swap [ glMatrixMode glPushMatrix call ] keep diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor index 3550424b83..7896cabd2e 100644 --- a/basis/tools/vocabs/browser/browser.factor +++ b/basis/tools/vocabs/browser/browser.factor @@ -288,7 +288,7 @@ M: vocab-tag article-name name>> ; M: vocab-tag article-content \ $tagged-vocabs swap name>> 2array ; -M: vocab-tag article-parent drop "vocab-index" ; +M: vocab-tag article-parent drop "vocab-tags" ; M: vocab-tag summary article-title ; @@ -302,6 +302,6 @@ M: vocab-author article-name name>> ; M: vocab-author article-content \ $authored-vocabs swap name>> 2array ; -M: vocab-author article-parent drop "vocab-index" ; +M: vocab-author article-parent drop "vocab-authors" ; M: vocab-author summary article-title ; diff --git a/basis/ui/gadgets/canvas/canvas.factor b/basis/ui/gadgets/canvas/canvas.factor index 1c36f4f9fd..710a9fb492 100644 --- a/basis/ui/gadgets/canvas/canvas.factor +++ b/basis/ui/gadgets/canvas/canvas.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: ui.backend ui.gadgets -ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces -classes.tuple colors accessors ; +USING: ui.backend ui.gadgets ui.gadgets.worlds ui.pens.solid opengl +opengl.gl kernel namespaces classes.tuple colors colors.constants +accessors ; IN: ui.gadgets.canvas TUPLE: canvas < gadget dlist ; : new-canvas ( class -- canvas ) - new black >>interior ; inline + new COLOR: black >>interior ; inline : delete-canvas-dlist ( canvas -- ) [ find-gl-context ] @@ -23,8 +23,6 @@ TUPLE: canvas < gadget dlist ; [ 2nip ] [ drop make-canvas-dlist ] if ; inline : draw-canvas ( canvas quot -- ) - origin get [ - cache-canvas-dlist glCallList - ] with-translation ; inline + cache-canvas-dlist glCallList ; inline M: canvas ungraft* delete-canvas-dlist ; diff --git a/basis/ui/pens/polygon/polygon-docs.factor b/basis/ui/pens/polygon/polygon-docs.factor index 706c1449a6..dfe687f398 100644 --- a/basis/ui/pens/polygon/polygon-docs.factor +++ b/basis/ui/pens/polygon/polygon-docs.factor @@ -1,5 +1,5 @@ +USING: colors help.markup help.syntax ui.pens ; IN: ui.pens.polygon -USING: help.markup help.syntax ; HELP: polygon { $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:" diff --git a/basis/ui/pens/polygon/polygon.factor b/basis/ui/pens/polygon/polygon.factor index 4fc05c468b..4d7793dd65 100644 --- a/basis/ui/pens/polygon/polygon.factor +++ b/basis/ui/pens/polygon/polygon.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: ; +USING: accessors colors help.markup help.syntax kernel opengl +opengl.gl sequences specialized-arrays.float ui.pens ; IN: ui.pens.polygon ! Polygon pen diff --git a/basis/ui/windows/summary.txt b/basis/ui/windows/summary.txt deleted file mode 100644 index 9a0a894850..0000000000 --- a/basis/ui/windows/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Windows UI backend diff --git a/basis/ui/x11/summary.txt b/basis/ui/x11/summary.txt deleted file mode 100644 index 046c83ad89..0000000000 --- a/basis/ui/x11/summary.txt +++ /dev/null @@ -1 +0,0 @@ -X11 UI backend diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor deleted file mode 100755 index 2a622a6985..0000000000 --- a/basis/ui/x11/x11.factor +++ /dev/null @@ -1,297 +0,0 @@ -! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types arrays ui ui.gadgets -ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render -ui.event-loop assocs kernel math namespaces opengl sequences -strings x11.xlib x11.events x11.xim x11.glx x11.clipboard -x11.constants x11.windows io.encodings.string io.encodings.ascii -io.encodings.utf8 combinators combinators.short-circuit command-line -math.vectors classes.tuple opengl.gl threads math.geometry.rect -environment ascii ; -IN: ui.x11 - -SINGLETON: x11-ui-backend - -: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ; - -TUPLE: x11-handle-base glx ; -TUPLE: x11-handle < x11-handle-base xic window ; -TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ; - -C: x11-handle -C: x11-pixmap-handle - -M: world expose-event nip relayout ; - -M: world configure-event - over configured-loc >>window-loc - swap configured-dim >>dim - ! In case dimensions didn't change - relayout-1 ; - -CONSTANT: modifiers - { - { S+ HEX: 1 } - { C+ HEX: 4 } - { A+ HEX: 8 } - } - -CONSTANT: key-codes - H{ - { HEX: FF08 "BACKSPACE" } - { HEX: FF09 "TAB" } - { HEX: FF0D "RET" } - { HEX: FF8D "ENTER" } - { HEX: FF1B "ESC" } - { HEX: FFFF "DELETE" } - { HEX: FF50 "HOME" } - { HEX: FF51 "LEFT" } - { HEX: FF52 "UP" } - { HEX: FF53 "RIGHT" } - { HEX: FF54 "DOWN" } - { HEX: FF55 "PAGE_UP" } - { HEX: FF56 "PAGE_DOWN" } - { HEX: FF57 "END" } - { HEX: FF58 "BEGIN" } - { HEX: FFBE "F1" } - { HEX: FFBF "F2" } - { HEX: FFC0 "F3" } - { HEX: FFC1 "F4" } - { HEX: FFC2 "F5" } - { HEX: FFC3 "F6" } - { HEX: FFC4 "F7" } - { HEX: FFC5 "F8" } - { HEX: FFC6 "F9" } - } - -: key-code ( keysym -- keycode action? ) - dup key-codes at [ t ] [ 1string f ] ?if ; - -: event-modifiers ( event -- seq ) - XKeyEvent-state modifiers modifier ; - -: valid-input? ( string gesture -- ? ) - over empty? [ 2drop f ] [ - mods>> { f { S+ } } member? [ - [ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all? - ] [ - [ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all? - ] if - ] if ; - -: key-down-event>gesture ( event world -- string gesture ) - dupd - handle>> xic>> lookup-string - [ swap event-modifiers ] dip key-code ; - -M: world key-down-event - [ key-down-event>gesture ] keep - [ propagate-key-gesture drop ] - [ 2over valid-input? [ nip user-input ] [ 3drop ] if ] - 3bi ; - -: key-up-event>gesture ( event -- gesture ) - dup event-modifiers swap 0 XLookupKeysym key-code ; - -M: world key-up-event - [ key-up-event>gesture ] dip propagate-key-gesture ; - -: mouse-event>gesture ( event -- modifiers button loc ) - [ event-modifiers ] - [ XButtonEvent-button ] - [ mouse-event-loc ] - tri ; - -M: world button-down-event - [ mouse-event>gesture [ ] dip ] dip - send-button-down ; - -M: world button-up-event - [ mouse-event>gesture [ ] dip ] dip - send-button-up ; - -: mouse-event>scroll-direction ( event -- pair ) - XButtonEvent-button { - { 4 { 0 -1 } } - { 5 { 0 1 } } - { 6 { -1 0 } } - { 7 { 1 0 } } - } at ; - -M: world wheel-event - [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip - send-wheel ; - -M: world enter-event motion-event ; - -M: world leave-event 2drop forget-rollover ; - -M: world motion-event - [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip - move-hand fire-motion ; - -M: world focus-in-event - nip - dup handle>> xic>> XSetICFocus focus-world ; - -M: world focus-out-event - nip - dup handle>> xic>> XUnsetICFocus unfocus-world ; - -M: world selection-notify-event - [ handle>> window>> selection-from-event ] keep - user-input ; - -: supported-type? ( atom -- ? ) - { "UTF8_STRING" "STRING" "TEXT" } - [ x-atom = ] with any? ; - -: clipboard-for-atom ( atom -- clipboard ) - { - { XA_PRIMARY [ selection get ] } - { XA_CLIPBOARD [ clipboard get ] } - [ drop ] - } case ; - -: encode-clipboard ( string type -- bytes ) - XSelectionRequestEvent-target - XA_UTF8_STRING = utf8 ascii ? encode ; - -: set-selection-prop ( evt -- ) - dpy get swap - [ XSelectionRequestEvent-requestor ] keep - [ XSelectionRequestEvent-property ] keep - [ XSelectionRequestEvent-target ] keep - [ 8 PropModeReplace ] dip - [ - XSelectionRequestEvent-selection - clipboard-for-atom contents>> - ] keep encode-clipboard dup length XChangeProperty drop ; - -M: world selection-request-event - drop dup XSelectionRequestEvent-target { - { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] } - { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] } - { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] } - [ drop send-notify-failure ] - } cond ; - -M: x11-ui-backend (close-window) ( handle -- ) - dup xic>> XDestroyIC - dup glx>> destroy-glx - window>> dup unregister-window - destroy-window ; - -M: world client-event - swap close-box? [ ungraft ] [ drop ] if ; - -: gadget-window ( world -- ) - dup window-loc>> over rect-dim glx-window - over "Factor" create-xic rot - 2dup window>> register-window - >>handle drop ; - -: wait-event ( -- event ) - QueuedAfterFlush events-queued 0 > [ - next-event dup - None XFilterEvent zero? [ drop wait-event ] unless - ] [ - ui-wait wait-event - ] if ; - -M: x11-ui-backend do-events - wait-event dup XAnyEvent-window window dup - [ handle-event ] [ 2drop ] if ; - -: x-clipboard@ ( gadget clipboard -- prop win ) - atom>> swap - find-world handle>> window>> ; - -M: x-clipboard copy-clipboard - [ x-clipboard@ own-selection ] keep - (>>contents) ; - -M: x-clipboard paste-clipboard - [ find-world handle>> window>> ] dip atom>> convert-selection ; - -: init-clipboard ( -- ) - XA_PRIMARY selection set-global - XA_CLIPBOARD clipboard set-global ; - -: set-title-old ( dpy window string -- ) - dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ; - -: set-title-new ( dpy window string -- ) - [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip - utf8 encode dup length XChangeProperty drop ; - -M: x11-ui-backend set-title ( string world -- ) - handle>> window>> swap - [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ; - -M: x11-ui-backend set-fullscreen* ( ? world -- ) - handle>> window>> "XClientMessageEvent" - tuck set-XClientMessageEvent-window - swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? - over set-XClientMessageEvent-data0 - ClientMessage over set-XClientMessageEvent-type - dpy get over set-XClientMessageEvent-display - "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type - 32 over set-XClientMessageEvent-format - "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1 - [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ; - -M: x11-ui-backend (open-window) ( world -- ) - dup gadget-window - handle>> window>> dup set-closable map-window ; - -M: x11-ui-backend raise-window* ( world -- ) - handle>> [ - dpy get swap window>> XRaiseWindow drop - ] when* ; - -M: x11-handle select-gl-context ( handle -- ) - dpy get swap - [ window>> ] [ glx>> ] bi glXMakeCurrent - [ "Failed to set current GLX context" throw ] unless ; - -M: x11-handle flush-gl-context ( handle -- ) - dpy get swap window>> glXSwapBuffers ; - -M: x11-pixmap-handle select-gl-context ( handle -- ) - dpy get swap - [ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent - [ "Failed to set current GLX context" throw ] unless ; - -M: x11-pixmap-handle flush-gl-context ( handle -- ) - drop ; - -M: x11-ui-backend (open-offscreen-buffer) ( world -- ) - dup dim>> glx-pixmap >>handle drop ; -M: x11-ui-backend (close-offscreen-buffer) ( handle -- ) - dpy get swap - [ glx-pixmap>> glXDestroyGLXPixmap ] - [ pixmap>> XFreePixmap drop ] - [ glx>> glXDestroyContext ] 2tri ; - -M: x11-ui-backend offscreen-pixels ( world -- alien w h ) - [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ; - -M: x11-ui-backend ui ( -- ) - [ - f [ - [ - init-clipboard - start-ui - event-loop - ] with-xim - ] with-x - ] ui-running ; - -M: x11-ui-backend beep ( -- ) - dpy get 100 XBell drop ; - -x11-ui-backend ui-backend set-global - -[ "DISPLAY" os-env "ui" "listener" ? ] -main-vocab-hook set-global diff --git a/extra/annotations/annotations.factor b/extra/annotations/annotations.factor index 6685e4e036..b3eccad6a3 100644 --- a/extra/annotations/annotations.factor +++ b/extra/annotations/annotations.factor @@ -1,6 +1,7 @@ ! (c)2009 Joe Groff, Doug Coleman. see BSD license USING: accessors combinators.short-circuit definitions functors -kernel lexer namespaces parser prettyprint sequences words ; +kernel lexer namespaces parser prettyprint tools.crossref +sequences words ; IN: annotations << diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index c91a895ce1..7491ed8bcb 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -1,6 +1,6 @@ USING: arrays bunny.model bunny.cel-shaded continuations destructors kernel math multiline opengl opengl.shaders -opengl.framebuffers opengl.gl opengl.demo-support fry +opengl.framebuffers opengl.gl opengl.textures opengl.demo-support fry opengl.capabilities sequences ui.gadgets combinators accessors macros locals ; IN: bunny.outlined diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 69c21b10f7..d7919aafd1 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions math.parser models models.arrow models.range models.product sequences ui -ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs -ui.gadgets.sliders ui.render math.rectangles accessors +ui.gadgets ui.gadgets.tracks ui.gadgets.labels ui.gadgets.packs +ui.gadgets.sliders ui.pens.solid ui.render math.rectangles accessors ui.gadgets.grids colors ; IN: color-picker @@ -12,7 +12,7 @@ IN: color-picker TUPLE: color-preview < gadget ; : ( model -- gadget ) - color-preview new-gadget + color-preview new swap >>model { 100 100 } >>dim ; @@ -32,16 +32,16 @@ M: color-preview model-changed bi ; : ( -- gadget ) - + vertical { 5 5 } >>gap - [ @top grid-add ] + [ f track-add ] [ - [ @center grid-add ] + [ 1 track-add ] [ [ [ truncate number>string ] map " " join ] - @bottom grid-add + f track-add ] bi ] bi* ; diff --git a/extra/demos/demos.factor b/extra/demos/demos.factor index b411df1e30..fd7aafb601 100644 --- a/extra/demos/demos.factor +++ b/extra/demos/demos.factor @@ -10,7 +10,7 @@ IN: demos : demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ; : ( vocab-name -- button ) - dup '[ drop [ _ run ] call-listener ] { 0 0 } >>align ; + dup '[ drop [ _ run ] call-listener ] ; : ( -- gadget ) 1 >>fill demo-vocabs [ add-gadget ] each ; diff --git a/extra/game-input/game-input-tests.factor b/extra/game-input/game-input-tests.factor new file mode 100644 index 0000000000..a5c79e0268 --- /dev/null +++ b/extra/game-input/game-input-tests.factor @@ -0,0 +1,7 @@ +IN: game-input.tests +USING: game-input tools.test kernel system ; + +os windows? os macosx? or [ + [ ] [ open-game-input ] unit-test + [ ] [ close-game-input ] unit-test +] when \ No newline at end of file diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index faed31a0e5..b920b60430 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -19,7 +19,7 @@ M: image-gadget draw-gadget* ( gadget -- ) image>> draw-image ; : ( image -- gadget ) - \ image-gadget new-gadget + \ image-gadget new swap >>image ; : image-window ( path -- gadget ) diff --git a/extra/joystick-demo/joystick-demo.factor b/extra/joystick-demo/joystick-demo.factor index c7a774af31..3f24a5bb39 100755 --- a/extra/joystick-demo/joystick-demo.factor +++ b/extra/joystick-demo/joystick-demo.factor @@ -1,7 +1,7 @@ USING: ui ui.gadgets sequences kernel arrays math colors -ui.render math.vectors accessors fry ui.gadgets.packs game-input -ui.gadgets.labels ui.gadgets.borders alarms -calendar locals strings ui.gadgets.buttons +colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors +accessors fry ui.gadgets.packs game-input ui.gadgets.labels +ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons combinators math.parser assocs threads ; IN: joystick-demo @@ -56,11 +56,11 @@ CONSTANT: pov-polygons [ z-indicator>> (>>loc) ] 2bi* ; : move-pov ( gadget pov -- ) - swap pov>> [ interior>> -rot = [ gray ] [ white ] if >>color drop ] + swap pov>> [ interior>> -rot = COLOR: gray COLOR: white ? >>color drop ] with assoc-each ; :: add-pov-gadget ( gadget direction polygon -- gadget direction gadget ) - gadget white polygon [ add-gadget ] keep + gadget COLOR: white polygon [ add-gadget ] keep direction swap ; : add-pov-gadgets ( gadget -- gadget ) @@ -69,14 +69,14 @@ CONSTANT: pov-polygons : ( -- gadget ) axis-gadget new add-pov-gadgets - black [ >>z-indicator ] [ add-gadget ] bi - red [ >>indicator ] [ add-gadget ] bi + COLOR: black [ >>z-indicator ] [ add-gadget ] bi + COLOR: red [ >>indicator ] [ add-gadget ] bi dup [ 0.0 0.0 0.0 move-axis ] [ f move-pov ] bi ; TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ; : add-gadget-with-border ( parent child -- parent ) - { 2 2 } gray >>boundary add-gadget ; + { 2 2 } COLOR: gray >>boundary add-gadget ; : add-controller-label ( gadget controller -- gadget ) [ >>controller ] [ product-string