Merge branch 'master' of git://factorcode.org/git/factor

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>> ;">
     <string-reader> "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 ;">
     <string-reader> "delegate-test-1" parse-stream
 ] unit-test
 
-[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
+! 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 ; ">
+    <string-reader> "delegate-test-2" parse-stream
+] unit-test

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

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)
-        <let*> parsed-lambda
-        pop-functor-words
-        >quotation
-    ] with-variable ;
+    push-functor-words
+    "WHERE" parse-bindings*
+    [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
+    pop-functor-words ;
 
 : (FUNCTOR:) ( -- word def )
-    CREATE
-    parse-locals dup push-locals
-    parse-functor-body swap pop-locals <lambda>
-    rewrite-closures first ;
+    CREATE-WORD [ parse-functor-body ] parse-locals-definition ;
 
 PRIVATE>
 

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
 
 : <byte-writer> ( 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-reader> ( byte-array encoding -- stream )
     [ B{ } like 0 byte-reader boa ] dip <decoder> ;
 

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." ;

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"

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
+[ 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

basis/locals/locals.factor

@@ -9,19 +9,13 @@ IN: locals
     scan locals get [ :>-outside-lambda-error ] unless*
     [ make-local ] bind <def> parsed ; parsing
 
-: [| parse-lambda parsed-lambda ; parsing
+: [| parse-lambda over push-all ; parsing
 
-: [let
-    "|" expect "|" parse-bindings
-    \ ] (parse-lambda) <let> parsed-lambda ; parsing
+: [let parse-let over push-all ; parsing
 
-: [let*
-    "|" expect "|" parse-bindings*
-    \ ] (parse-lambda) <let*> parsed-lambda ; parsing
+: [let* parse-let* over push-all ; parsing
 
-: [wlet
-    "|" expect "|" parse-wbindings
-    \ ] (parse-lambda) <wlet> 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"

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 [
         <local-reader>
@@ -20,28 +25,33 @@ IN: locals.parser
     [ <local-word> [ 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) <lambda> ;
+    (parse-lambda) <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) <let> ?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) <let*> ?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) <wlet> ?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) <lambda>
+: parse-locals-definition ( word reader -- word quot )
+    [ parse-locals ] dip
+    ((parse-lambda)) <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 ;

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* ;
 

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
+[ ] [ "hi" blah-generic ] unit-test

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

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" } "." ;
 

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 ;"
+    <string-reader> "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 ;"
+    <string-reader> "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 ;"
+    <string-reader> "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

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 ( -- ) ;"
+    <string-reader> "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 >>"
+    <string-reader> "was-once-a-word-test" parse-stream
+] unit-test
+
+[ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test

core/parser/parser.factor

@@ -113,12 +113,16 @@ ERROR: staging-violation word ;
 : parse-until ( end -- vec )
     100 <vector> 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 "reading" word-prop ] [ f ] }
+            { [ dup "writing" word-prop ] [ f ] }
+            [ t ]
+        } cond nip
+    ] filter ;
 
 : removed-definitions ( -- assoc1 assoc2 )
     new-definitions old-definitions

core/syntax/syntax.factor

@@ -94,7 +94,7 @@ IN: bootstrap.syntax
         lexer get skip-blank parse-string <pathname> 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

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

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