Merge commit 'origin/master' into emacs

basis/help/help-tests.factor

@@ -3,3 +3,4 @@ USING: tools.test help kernel ;
 
 [ 3 throw ] must-fail
 [ ] [ :help ] unit-test
+[ ] [ f print-topic ] unit-test

basis/help/help.factor

@@ -112,6 +112,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
     ] with-style nl ;
 
 : print-topic ( topic -- )
+    >link
     last-element off dup $title
     article-content print-content nl ;
 

basis/http/server/cgi/cgi.factor

@@ -58,6 +58,8 @@ IN: http.server.cgi
         ] with-stream
     ] >>body ;
 
+SLOT: special
+
 : enable-cgi ( responder -- responder )
     [ serve-cgi ] "application/x-cgi-script"
     pick special>> set-at ;

basis/io/files/info/unix/linux/linux.factor

@@ -3,7 +3,7 @@
 USING: accessors alien.c-types alien.syntax combinators csv
 io.backend io.encodings.utf8 io.files io.files.info io.streams.string
 io.files.unix kernel math.order namespaces sequences sorting
-system unix unix.statfs.linux unix.statvfs.linux io.files.links.unix
+system unix unix.statfs.linux unix.statvfs.linux io.files.links
 specialized-arrays.direct.uint arrays io.files.info.unix assocs
 io.pathnames ;
 IN: io.files.info.unix.linux

basis/io/files/links/links-docs.factor

@@ -13,8 +13,6 @@ HELP: copy-link
 { $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } }
 { $description "Copies a symbolic link without following the link." } ;
 
-{ make-link read-link copy-link } related-words
-
 HELP: follow-link
 { $values
      { "path" "a pathname string" }
@@ -29,6 +27,8 @@ HELP: follow-links
 }
 { $description "Follows a chain of symlinks up to " { $link symlink-depth } "." } ;
 
+{ read-link follow-link follow-links } related-words
+
 HELP: symlink-depth
 { $values
      { "value" integer }

basis/io/files/links/links-tests.factor

@@ -1,5 +1,6 @@
-USING: io.directories io.files.links tools.test
+USING: io.directories io.files.links tools.test sequences
-io.files.unique tools.files ;
+io.files.unique tools.files fry math kernel math.parser
+io.pathnames namespaces ;
 IN: io.files.links.tests
 
 : make-test-links ( n path -- )

basis/io/files/links/links.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.backend io.files.info
+USING: accessors io.backend io.files.info io.files.types
-io.files.links.private io.files.types io.pathnames kernel math
+io.pathnames kernel math namespaces system vocabs.loader ;
-namespaces system unix vocabs.loader ;
 IN: io.files.links
 
 HOOK: make-link os ( target symlink -- )
@@ -15,7 +14,7 @@ HOOK: read-link os ( symlink -- path )
 os unix? [ "io.files.links.unix" require ] when
 
 : follow-link ( path -- path' )
-    [ parent-directory ] [ read-symbolic-link ] bi append-path ;
+    [ parent-directory ] [ read-link ] bi append-path ;
 
 SYMBOL: symlink-depth
 10 symlink-depth set-global

basis/models/compose/compose-tests.factor

@@ -1,5 +1,5 @@
 USING: arrays generic kernel math models namespaces sequences assocs
-tools.test models.compose accessors ;
+tools.test models.compose accessors locals ;
 IN: models.compose.tests
 
 ! Test compose
@@ -22,3 +22,25 @@ IN: models.compose.tests
 [ { 4 5 } ] [ "c" get value>> ] unit-test
 
 [ ] [ "c" get deactivate-model ] unit-test
+
+TUPLE: an-observer { i integer } ;
+
+M: an-observer model-changed nip [ 1+ ] change-i drop ;
+
+[ 1 0 ] [
+    [let* | m1 [ 1 <model> ]
+            m2 [ 2 <model> ]
+            c [ { m1 m2 } <compose> ]
+            o1 [ an-observer new ]
+            o2 [ an-observer new ] |
+        
+        o1 m1 add-connection
+        o2 m2 add-connection
+
+        c activate-model
+    
+        "OH HAI" m1 set-model
+        o1 i>>
+        o2 i>>
+    ]
+] unit-test

basis/models/compose/compose.factor

@@ -18,7 +18,8 @@ TUPLE: compose < model ;
 
 M: compose model-changed
     nip
-    [ [ value>> ] composed-value ] keep set-model ;
+    dup [ value>> ] composed-value >>value
+    notify-connections ;
 
 M: compose model-activated dup model-changed ;
 

basis/struct-arrays/struct-arrays-tests.factor

@@ -1,6 +1,7 @@
 IN: struct-arrays.tests
 USING: struct-arrays tools.test kernel math sequences
-alien.syntax alien.c-types destructors libc accessors ;
+alien.syntax alien.c-types destructors libc accessors
+destructors ;
 
 C-STRUCT: test-struct
 { "int" "x" }
@@ -27,3 +28,12 @@ C-STRUCT: test-struct
         0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
     ] with-destructors
 ] unit-test
+
+[ ] [ ALIEN: 123 10 "test-struct" <direct-struct-array> drop ] unit-test
+
+[ ] [
+    [
+        10 "test-struct" malloc-struct-array
+        underlying>> &free drop
+    ] with-destructors
+] unit-test

basis/struct-arrays/struct-arrays.factor

@@ -32,9 +32,9 @@ ERROR: bad-byte-array-length byte-array ;
     ] keep struct-array boa ; inline
 
 : <direct-struct-array> ( alien length c-type -- struct-array )
-    struct-array boa ; inline
+    heap-size struct-array boa ; inline
 
 : malloc-struct-array ( length c-type -- struct-array )
-    heap-size [ calloc ] 2keep <direct-struct-array> ;
+    [ heap-size calloc ] 2keep <direct-struct-array> ;
 
 INSTANCE: struct-array sequence

basis/ui/gadgets/borders/borders.factor

@@ -16,6 +16,9 @@ TUPLE: border < gadget
     swap border new-border
         swap dup 2array >>size ;
 
+: <filled-border> ( child gap -- border )
+    <border> { 1 1 } >>fill ;
+
 M: border pref-dim*
     [ size>> 2 v*n ] keep
     gadget-child pref-dim v+ ;

basis/ui/gadgets/editors/editors.factor

@@ -107,7 +107,7 @@ M: editor ungraft*
     editor-font* "" string-height ;
 
 : y>line ( y editor -- line# )
-    line-height / >fixnum ;
+    line-height /i ;
 
 :: point>loc ( point editor -- loc )
     point second editor y>line {

basis/ui/gadgets/menus/menus.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: locals accessors arrays ui.commands ui.gadgets
+USING: locals accessors arrays ui.commands ui.operations ui.gadgets
 ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic
 hashtables kernel math models namespaces opengl sequences
 math.vectors ui.gadgets.theme ui.gadgets.packs
@@ -54,3 +54,9 @@ M: menu-glass layout* gadget-child prefer ;
 
 : show-commands-menu ( target commands -- )
     [ dup [ ] ] dip <commands-menu> show-menu ;
+
+: <operations-menu> ( target hook -- menu )
+    over object-operations <commands-menu> ;
+
+: show-operations-menu ( gadget target -- )
+    [ ] <operations-menu> show-menu ;

basis/ui/gadgets/presentations/presentations-docs.factor

@@ -35,8 +35,6 @@ HELP: <presentation>
 
 { <button> <bevel-button> <command-button> <roll-button> <presentation> } related-words
 
-{ <commands-menu> <toolbar> operations-menu show-menu } related-words
-
 { <status-bar> show-mouse-help show-status show-summary hide-status } related-words
 
 HELP: show-mouse-help

basis/ui/gadgets/presentations/presentations.factor

@@ -11,8 +11,8 @@ IN: ui.gadgets.presentations
 TUPLE: presentation < button object hook ;
 
 : invoke-presentation ( presentation command -- )
-    over dup hook>> call
+    [ [ dup hook>> call ] [ object>> ] bi ] dip
-    [ object>> ] dip invoke-command ;
+    invoke-command ;
 
 : invoke-primary ( presentation -- )
     dup object>> primary-operation
@@ -23,7 +23,7 @@ TUPLE: presentation < button object hook ;
     invoke-presentation ;
 
 : show-mouse-help ( presentation -- )
-    dup object>> over show-summary button-update ;
+    [ [ object>> ] keep show-summary ] [ button-update ] bi ;
 
 : <presentation> ( label object -- button )
     swap [ invoke-primary ] presentation new-button
@@ -35,18 +35,13 @@ M: presentation ungraft*
     dup hand-gadget get-global child? [ dup hide-status ] when
     call-next-method ;
 
-: <operations-menu> ( presentation -- menu )
+: show-operations-menu ( presentation -- )
-    [ object>> ]
+    [ ] [ object>> ] [ dup hook>> curry ] tri
-    [ dup hook>> curry ]
+    <operations-menu> show-menu ;
-    [ object>> object-operations ]
-    tri <commands-menu> ;
-
-: operations-menu ( presentation -- )
-    dup <operations-menu> show-menu ;
 
 presentation H{
-    { T{ button-down f f 3 } [ operations-menu ] }
+    { T{ button-down f f 3 } [ show-operations-menu ] }
-    { T{ mouse-leave } [ dup hide-status button-update ] }
+    { T{ mouse-leave } [ [ hide-status ] [ button-update ] bi ] }
     { T{ mouse-enter } [ show-mouse-help ] }
     ! Responding to motion too allows nested presentations to
     ! display status help properly, when the mouse leaves a

basis/ui/gadgets/tracks/tracks-tests.factor

@@ -21,3 +21,20 @@ IN: ui.gadgets.tracks.tests
         <gadget> { 10 10 } >>dim 0 track-add
     pref-dim
 ] unit-test
+
+[ { 10 30 } ] [
+    { 0 1 } <track>
+        <gadget> { 10 10 } >>dim f track-add
+        <gadget> { 10 10 } >>dim f track-add
+        <gadget> { 10 10 } >>dim f track-add
+    pref-dim
+] unit-test
+
+[ { 10 40 } ] [
+    { 0 1 } <track>
+        { 5 5 } >>gap
+        <gadget> { 10 10 } >>dim f track-add
+        <gadget> { 10 10 } >>dim f track-add
+        <gadget> { 10 10 } >>dim f track-add
+    pref-dim
+] unit-test

basis/ui/gadgets/tracks/tracks.factor

@@ -27,10 +27,15 @@ TUPLE: track < pack sizes ;
     [ children>> ] [ sizes>> ] bi { 0 0 }
     [ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
 
-: available-dim ( track -- dim ) [ dim>> ] [ alloted-dim ] bi v- ;
+: gap-dim ( track -- dim )
+    [ gap>> ] [ children>> length 1 [-] ] bi v*n ;
+
+: available-dim ( track -- dim )
+    [ dim>> ] [ alloted-dim ] bi v- ;
 
 : track-layout ( track -- sizes )
-    [ available-dim ] [ children>> ] [ normalized-sizes ] tri
+    [ [ available-dim ] [ gap-dim ] bi v- ]
+    [ children>> ] [ normalized-sizes ] tri
     [ [ over n*v ] [ pref-dim ] ?if ] 2map nip ;
 
 M: track layout* ( track -- ) dup track-layout pack-layout ;
@@ -41,11 +46,9 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;
 : track-pref-dims-2 ( track -- dim )
     [
         [ children>> pref-dims ] [ normalized-sizes ] bi
-        [ dup { 0 f } memq? [ drop ] [ v/n ] if ] 2map
+        [ dup { 0 f } member? [ 2drop { 0 0 } ] [ v/n ] if ] 2map
         max-dim [ >fixnum ] map
-    ]
+    ] [ gap-dim ] bi v+ ;
-    [ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi
-    v+ ;
 
 M: track pref-dim* ( gadget -- dim )
     [ track-pref-dims-1 ]

basis/ui/tools/tools-tests.factor

@@ -2,7 +2,7 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
 ui.tools.search ui.tools.workspace kernel models namespaces
 sequences tools.test ui.gadgets ui.gadgets.buttons
 ui.gadgets.labelled ui.gadgets.presentations
-ui.gadgets.scrollers vocabs tools.test.ui ui accessors ;
+ui.gadgets.menus ui.gadgets.scrollers vocabs tools.test.ui ui accessors ;
 IN: ui.tools.tests
 
 [ f ]
@@ -40,7 +40,10 @@ IN: ui.tools.tests
 
     [ t ] [ "p" get presentation? ] unit-test
 
-    [ ] [ "p" get <operations-menu> gadget-child gadget-child "c" set ] unit-test
+    [ ] [
+        "p" get [ object>> ] [ dup hook>> curry ] bi
+        <operations-menu> gadget-child gadget-child "c" set
+    ] unit-test
 
     [ ] [ notify-queued ] unit-test
 

basis/xml/tests/test.factor

@@ -61,3 +61,4 @@ SYMBOL: xml-file
 [ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo >" string>xml-chunk second ] unit-test
 [ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk second ] unit-test
 [ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo   SYSTEM \"blah.dtd\"   >" string>xml-chunk second ] unit-test
+[ t ] [ "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.1//EN' 'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd' >" dup string>xml-chunk [ write-xml-chunk ] with-string-writer = ] unit-test

basis/xml/writer/writer.factor

@@ -112,7 +112,7 @@ M: system-id write-xml-chunk
 M: public-id write-xml-chunk
     "PUBLIC '" write
     [ pubid-literal>> write "' '" write ]
-    [ system-literal>> write "'>" write ] bi ;
+    [ system-literal>> write "'" write ] bi ;
 
 M: doctype-decl write-xml-chunk
     "<!DOCTYPE " write