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/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) ; diff --git a/extra/rewrite-closures/tags.txt b/basis/constructors/tags.txt similarity index 100% rename from extra/rewrite-closures/tags.txt rename to basis/constructors/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/delegate-tests.factor b/basis/delegate/delegate-tests.factor index 4b02407735..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,13 +121,22 @@ 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 -[ 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 +146,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 +154,46 @@ 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 + +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..0c16b7c336 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 +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 -- ) + [ class>> swap first method ] keep + over [ + over "consultation" word-prop eq? + [ forget ] [ drop ] if + ] [ 2drop ] 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 +131,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 +152,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/unmaintained/bitfields/tags.txt b/basis/delegate/tags.txt similarity index 100% rename from unmaintained/bitfields/tags.txt rename to basis/delegate/tags.txt 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/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 ; 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..923f890adf 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) ; @@ -492,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 @@ -503,8 +504,25 @@ 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 + +! 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 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/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/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 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/unmaintained/fs/tags.txt b/basis/ui/text/pango/tags.txt similarity index 100% rename from unmaintained/fs/tags.txt rename to basis/ui/text/pango/tags.txt 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 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" } "." ; 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/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/compiler/units/units.factor b/core/compiler/units/units.factor index 0577f8b83c..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) ; @@ -72,14 +75,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..351a8f98fd 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 ] @@ -113,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 3fcf489413..5ec9ea9b3c 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -556,3 +556,37 @@ 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 +] 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 + +! 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/parser/parser.factor b/core/parser/parser.factor index cbf8754821..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 ) @@ -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) ; @@ -216,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 reader-method? ] [ f ] } + { [ dup writer-method? ] [ f ] } + [ t ] + } cond nip + ] filter ; : removed-definitions ( -- assoc1 assoc2 ) new-definitions old-definitions 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 ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index af5fa38aeb..de3be98ceb 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 @@ -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 ":" [ diff --git a/extra/4DNav/4DNav.factor b/extra/4DNav/4DNav.factor index 91c1c94b35..d761eaf473 100755 --- a/extra/4DNav/4DNav.factor +++ b/extra/4DNav/4DNav.factor @@ -13,6 +13,7 @@ sequences combinators continuations colors +colors.constants prettyprint vars quotations @@ -28,23 +29,19 @@ ui.gadgets.panes ui.gadgets.borders ui.gadgets.handler ui.gadgets.slate - ui.gadgets.theme ui.gadgets.frames ui.gadgets.tracks ui.gadgets.labels - ui.gadgets.labelled + ui.gadgets.labeled ui.gadgets.lists ui.gadgets.buttons ui.gadgets.packs ui.gadgets.grids ui.gestures - ui.tools.workspace ui.gadgets.scrollers splitting vectors math.vectors -rewrite-closures -self values 4DNav.turtle 4DNav.window3D @@ -55,6 +52,8 @@ fry adsoda adsoda.tools ; +QUALIFIED-WITH: ui.pens.solid s + IN: 4DNav VALUE: selected-file @@ -74,10 +73,13 @@ VAR: present-space ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! replacement of namespaces.lib +! namespace utilities : make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ; +: closed-quot ( quot -- quot ) + namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! waiting for deep-cleave-quots @@ -131,11 +133,11 @@ VAR: present-space : model-projection-chooser ( -- gadget ) observer3d> projection-mode>> { { 1 "perspective" } { 0 "orthogonal" } } - ; + ; : collision-detection-chooser ( -- gadget ) observer3d> collision-mode>> - { { t "on" } { f "off" } } ; + { { t "on" } { f "off" } } ; : model-projection ( x -- space ) present-space> swap space-project ; @@ -184,8 +186,11 @@ VAR: present-space ! menu ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +USE: ui.gadgets.labeled.private + : menu-rotations-4D ( -- gadget ) - + 3 3 + { 1 1 } >>filled-cell 1 >>fill "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] button* add-gadget @@ -225,7 +230,8 @@ VAR: present-space ; : menu-translations-4D ( -- gadget ) - + 3 3 + { 1 1 } >>filled-cell 1 >>fill 1 >>fill "X+" [ drop { 1 0 0 0 } translation-step v*n @@ -325,12 +331,13 @@ VAR: present-space [ ".xml" tail? ] filter [ append-path ] with map [ add-gadget ] each - swap ; + swap ; ! ----------------------------------------------------- : menu-rotations-3D ( -- gadget ) - + 3 3 + { 1 1 } >>filled-cell "Turn\n left" [ rotation-step turn-left ] camera-button @left grid-add "Turn\n right" [ rotation-step turn-right ] @@ -348,7 +355,8 @@ VAR: present-space ; : menu-translations-3D ( -- gadget ) - + 3 3 + { 1 1 } >>filled-cell "left\n(alt)" [ translation-step strafe-left ] camera-button @left grid-add "right\n(alt)" [ translation-step strafe-right ] @@ -477,8 +485,7 @@ M: space adsoda-display-model { 0 1 } menu-bar f track-add - - { 200 400 } >>max-dim + f track-add "Projection mode : "