Merge remote-tracking branch 'origin/master' into modern-harvey2

.travis.yml

@@ -11,6 +11,7 @@ branches:
     - master
 sudo: required
 dist: trusty
+group: deprecated-2017Q4
 services:
   - postgresql
   - redis-server

README.md

@@ -6,7 +6,7 @@ features](https://concatenative.org/wiki/view/Factor/Features/The%20language)
 including dynamic types, extensible syntax, macros, and garbage collection.
 On a practical side, Factor has a [full-featured
 library](https://docs.factorcode.org/content/article-vocab-index.html),
-supports many different platforms, and has been extensively documented. 
+supports many different platforms, and has been extensively documented.
 
 The implementation is [fully
 compiled](https://concatenative.org/wiki/view/Factor/Optimizing%20compiler)
@@ -31,11 +31,19 @@ To check out Factor:
 * `git clone git://factorcode.org/git/factor.git`
 * `cd factor`
 
-To build the latest complete Factor system from git:
+To build the latest complete Factor system from git, either use the
+build script:
 
 * Windows: `build.cmd`
 * Unix: `./build.sh update`
 
+or download the correct boot image for your system from
+http://downloads.factorcode.org/images/master/, put it in the factor
+directory and run:
+
+* Unix: `make` and then `./factor -i=boot.unix-x86.64.image`
+* Windows: `nmake /f Nmakefile x86-64` and then `factor.com -i=boot.windows-x86.64.image`
+
 Now you should have a complete Factor system ready to run.
 
 More information on [building factor](https://concatenative.org/wiki/view/Factor/Building%20Factor)

basis/cocoa/touchbar/touchbar.factor

@@ -1,22 +1,14 @@
 ! Copyright (C) 2017 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.enums alien.syntax cocoa
+USING: alien.c-types cocoa cocoa.classes cocoa.messages
-cocoa.classes cocoa.messages cocoa.runtime combinators
+cocoa.runtime combinators core-foundation.strings kernel locals
-core-foundation.strings kernel locals namespaces sequences words ;
+;
 IN: cocoa.touchbar
 
-! ui.backend.cocoa.views creates buttons for each of these actions
+: make-touchbar ( seq self -- touchbar )
-ENUM: default-touchbar refresh-all-action auto-use-action ;
+    [ NSTouchBar -> alloc -> init dup ] dip -> setDelegate: {
-
+        [ swap <CFStringArray> { void { id SEL id } } ?-> setDefaultItemIdentifiers: ]
-: enum>CFStringArray ( seq -- alien )
+        [ swap <CFStringArray> { void { id SEL id } } ?-> setCustomizationAllowedItemIdentifiers: ]
-    enum>keys
-    NSArray send: alloc
-        swap <CFStringArray> send: \initWithArray: ;
-
-: make-touchbar ( enum self -- touchbar )
-    [ NSTouchBar send: alloc send: init dup ] dip send: \setDelegate: {
-        [ swap enum>CFStringArray { void { id SEL id } } ?send: \setDefaultItemIdentifiers: ]
-        [ swap enum>CFStringArray { void { id SEL id } } ?send: \setCustomizationAllowedItemIdentifiers: ]
         [ nip ]
     } 2cleave ;
 

basis/concurrency/distributed/distributed-docs.factor

@@ -14,22 +14,22 @@ ARTICLE: "concurrency.distributed.example" "Distributed Concurrency Example"
 "The code to run the server is:"
 { $code
   "USING: io.servers ;"
-  "9000 local-server <node-server> start-server drop"
+  "9000 local-server start-node"
 }
 "The code to start the thread is:"
 { $code
     "USING: concurrency.messaging threads ;"
     ": log-message ( -- ) receive . flush log-message ;"
-    "[ log-message ] \"logger\" spawn dup name>> register-remote-thread"
+    "[ log-message ] \"logger\" [ spawn ] keep register-remote-thread"
 }
 "This spawns a thread that waits for the messages and prints them. It registers "
 "the thread as remotely accessible with " { $link register-remote-thread } "."
 $nl
-"The second Factor instance, the one associated with port 9001, can send "
+"The second Factor instance can send "
 "messages to the 'logger' thread by name:"
 { $code
-    "USING: io.sockets ; FROM: concurrency.messaging => send ;"
+    "USING: io.servers concurrency.distributed ; FROM: concurrency.messaging => send ;"
-    "\"hello\" \"127.0.0.1\" 9000 <inet4> \"logger\" <remote-thread> send"
+    "\"hello\" 9000 local-server \"logger\" <remote-thread> send"
 }
 "The " { $link send } " word is used to send messages to threads. If an "
 "instance of " { $link remote-thread } " is provided, then "
@@ -43,7 +43,9 @@ $nl
 "response to a distributed message. When an instance of " { $link thread } " "
 "is marshalled, it is converted into an instance of " { $link remote-thread }
 ". The receiver of this can use it as the target of a " { $link send }
-", " { $link send-synchronous } " or " { $link reply-synchronous } " call." ;
+", " { $link send-synchronous } " or " { $link reply-synchronous } " call."
+$nl
+"Note: " { $link send-synchronous } " can only work if " { $link local-node } " is assigned (use " { $link start-node } "), because there must be a server for the remote instance to send its reply to." ;
 
 ARTICLE: "concurrency.distributed" "Distributed message passing"
 "The " { $vocab-link "concurrency.distributed" } " implements transparent distributed message passing, inspired by Erlang and Termite." $nl

basis/concurrency/distributed/distributed-tests.factor

@@ -1,4 +1,4 @@
-USING: arrays calendar concurrency.distributed
+USING: accessors arrays calendar concurrency.distributed
 concurrency.messaging io.sockets kernel math namespaces
 sequences threads tools.test ;
 FROM: concurrency.messaging => receive send ;
@@ -6,6 +6,7 @@ IN: concurrency.distributed.tests
 
 CONSTANT: test-ip "127.0.0.1"
 CONSTANT: test-port 57234
+CONSTANT: test-port2 57235
 
 [ 8 ] [
     local-node get
@@ -23,3 +24,17 @@ CONSTANT: test-port 57234
         stop-node
     ] with-variable
 ] unit-test
+
+[ 15 ] [
+    local-node get
+    test-ip test-port2 <inet4> start-node
+    local-node get swap local-node set-global
+    local-node [
+        [
+            receive dup data>> 3 * swap reply-synchronous
+            "thread-s" unregister-remote-thread
+        ] "Thread S" spawn "thread-s" register-remote-thread
+        5 test-ip test-port2 <inet4> "thread-s" <remote-thread> send-synchronous
+        stop-node
+    ] with-variable
+] unit-test

basis/concurrency/messaging/messaging-docs.factor

@@ -8,7 +8,7 @@ HELP: send
 { $values { "message" object }
           { "thread" thread }
 }
-{ $description "Send the message to the thread by placing it in the thread's mailbox. This is an asynchronous operation and will return immediately. The receiving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." }
+{ $description "Send the message to the thread by placing it in the thread's mailbox. This is an asynchronous operation and will return immediately. The receiving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word). The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." }
 { $see-also receive receive-if } ;
 
 HELP: receive
@@ -24,6 +24,12 @@ HELP: receive-if
 { $description "Return the first message from the current thread's mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." }
 { $see-also send receive } ;
 
+HELP: handle-synchronous
+{ $values { "quot" "a " { $link quotation } " with stack effect " { $snippet "( ... message -- ... reply )" } }
+}
+{ $description "Receive a message that was sent with " { $link send-synchronous } ", call " { $snippet "quot" } " to transform it into a response and use " { $link reply-synchronous } " to reply."
+} ;
+
 HELP: spawn-linked
 { $values { "quot" quotation }
           { "name" string }
@@ -52,13 +58,13 @@ ARTICLE: "concurrency-synchronous-sends" "Synchronous sends"
 "The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:"
 { $subsections send-synchronous }
 "To reply to a synchronous message:"
-{ $subsections reply-synchronous }
+{ $subsections reply-synchronous handle-synchronous }
 "An example:"
 { $example
     "USING: concurrency.messaging threads ;"
     "IN: scratchpad"
     ": pong-server ( -- )"
-    "    receive [ \"pong\" ] dip reply-synchronous ;"
+    "    [ drop \"pong\" ] handle-synchronous ;"
     "[ pong-server t ] \"pong-server\" spawn-server"
     "\"ping\" swap send-synchronous ."
     "\"pong\""

basis/concurrency/messaging/messaging.factor

@@ -66,7 +66,7 @@ M: cannot-send-synchronous-to-self summary
 : reply-synchronous ( message synchronous -- )
     [ <reply> ] keep sender>> send ;
 
-: handle-synchronous ( quot -- )
+: handle-synchronous ( quot: ( ... message -- ... reply ) -- )
     receive [
         data>> swap call
     ] keep reply-synchronous ; inline

basis/db/db-docs.factor

@@ -14,7 +14,7 @@ HELP: new-db-connection
 
 HELP: db-open
 { $values { "db" "a database configuration object" } { "db-connection" db-connection } }
-{ $description "Opens a database using the configuration data stored in a " { $snippet "database configuration object" } "tuple. The database object now references a database handle that must be cleaned up. Therefore, it is better to use the " { $link with-db } " combinator than calling this word directly." } ;
+{ $description "Opens a database using the configuration data stored in a " { $snippet "database configuration object" } " tuple. The database object now references a database handle that must be cleaned up. Therefore, it is better to use the " { $link with-db } " combinator than calling this word directly." } ;
 
 HELP: db-close
 { $values { "handle" alien } }
@@ -81,7 +81,7 @@ HELP: query-results
 { $values { "query" object }
     { "result-set" result-set }
 }
-{ $description "Returns a " { $link result-set } " object representing the results of a SQL query. See " { $link "db-result-sets" } "." } ;
+{ $description "Returns a " { $link result-set } " object representing the results of an SQL query. See " { $link "db-result-sets" } "." } ;
 
 HELP: #rows
 { $values { "result-set" result-set } { "n" integer } }
@@ -128,14 +128,14 @@ HELP: in-transaction?
 
 HELP: query-each
 { $values
-     { "statement" statement } { "quot" quotation } }
+     { "result-set" result-set } { "quot" quotation } }
-{ $description "A combinator that calls a quotation on a sequence of SQL statements to their results query results." } ;
+{ $description "Applies the quotation to each row of the " { $link result-set } " in order." } ;
 
 HELP: query-map
 { $values
-     { "statement" statement } { "quot" quotation }
+     { "result-set" result-set } { "quot" quotation }
      { "seq" sequence } }
-{ $description "A combinator that maps a sequence of SQL statements to their results query results." } ;
+{ $description "Applies the quotation to each row of the " { $link result-set } " in order." } ;
 
 HELP: rollback-transaction
 { $description "Rolls back a transaction; no data is committed to the database. User code should make use of the " { $link with-transaction } " combinator." } ;
@@ -143,13 +143,13 @@ HELP: rollback-transaction
 HELP: sql-command
 { $values
      { "sql" string } }
-{ $description "Executes a SQL string using the database in the " { $link db-connection } " symbol." } ;
+{ $description "Executes an SQL string using the database in the " { $link db-connection } " symbol." } ;
 
 HELP: sql-query
 { $values
      { "sql" string }
      { "rows" "an array of arrays of strings" } }
-{ $description "Runs a SQL query of raw text in the database in the " { $link db-connection } " symbol. Each row is returned as an array of strings; no type-conversions are done on the resulting data." } ;
+{ $description "Runs an SQL query of raw text in the database in the " { $link db-connection } " symbol. Each row is returned as an array of strings; no type-conversions are done on the resulting data." } ;
 
 { sql-command sql-query } related-words
 
@@ -217,7 +217,7 @@ $nl
 } ;
 
 ARTICLE: "db-result-sets" "Result sets"
-"Result sets are the encapsulated, database-specific results from a SQL query."
+"Result sets are the encapsulated, database-specific results from an SQL query."
 $nl
 "Two possible protocols for iterating over result sets exist:"
 { $subsections
@@ -266,7 +266,7 @@ ARTICLE: "db-protocol" "Low-level database protocol"
 
 ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
 "Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "." $nl
-"Executing a SQL command:"
+"Executing an SQL command:"
 { $subsections sql-command }
 "Executing a query directly:"
 { $subsections sql-query }

basis/db/db.factor

@@ -105,14 +105,14 @@ M: object execute-statement* ( statement type -- )
 : sql-row-typed ( result-set -- seq )
     dup #columns [ row-column-typed ] with { } map-integers ;
 
-: query-each ( statement quot: ( statement -- ) -- )
+: query-each ( result-set quot: ( row -- ) -- )
     over more-rows? [
         [ call ] 2keep over advance-row query-each
     ] [
         2drop
     ] if ; inline recursive
 
-: query-map ( statement quot -- seq )
+: query-map ( result-set quot: ( row -- row' ) -- seq )
     collector [ query-each ] dip { } like ; inline
 
 : with-db ( db quot -- )

basis/db/tuples/tuples-docs.factor

@@ -64,7 +64,7 @@ HELP: <update-tuple-statement>
 HELP: define-persistent
 { $values
      { "class" class } { "table" string } { "columns" "an array of slot specifiers" } }
-{ $description "Defines a relation from a Factor " { $snippet "tuple class" } " to a SQL database table name. The format for the slot specifiers is as follows:"
+{ $description "Defines a relation from a Factor " { $snippet "tuple class" } " to an SQL database table name. The format for the slot specifiers is as follows:"
 { $list
     { "a slot name from the " { $snippet "tuple class" } }
     { "the name of a database column that maps to the slot" }
@@ -84,17 +84,17 @@ HELP: define-persistent
 HELP: create-table
 { $values
      { "class" class } }
-{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the database will likely throw an error." } ;
+{ $description "Creates an SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the database will likely throw an error." } ;
 
 HELP: ensure-table
 { $values
      { "class" class } }
-{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the error is silently ignored." } ;
+{ $description "Creates an SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the error is silently ignored." } ;
 
 HELP: ensure-tables
 { $values
      { "classes" "a sequence of classes" } }
-{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If a table already exists, the error is silently ignored." } ;
+{ $description "Creates an SQL table from a mapping defined by " { $link define-persistent } ". If a table already exists, the error is silently ignored." } ;
 
 HELP: recreate-table
 { $values
@@ -125,7 +125,7 @@ HELP: update-tuple
 HELP: delete-tuples
 { $values
      { "tuple" tuple } }
-{ $description "Uses the " { $snippet "tuple" } " as an exemplar object and deletes any objects that have the same slots set. If a slot is not " { $link f } ", then it is used to generate a SQL statement that deletes tuples." }
+{ $description "Uses the " { $snippet "tuple" } " as an exemplar object and deletes any objects that have the same slots set. If a slot is not " { $link f } ", then it is used to generate an SQL statement that deletes tuples." }
 { $warning "This word will delete your data." } ;
 
 { insert-tuple update-tuple delete-tuples } related-words

basis/db/types/types-docs.factor

@@ -121,24 +121,24 @@ HELP: find-primary-key
 HELP: no-sql-type
 { $values
      { "type" "a SQL type" } }
-{ $description "Throws an error containing a SQL type that is unsupported or the result of a typo." } ;
+{ $description "Throws an error containing an SQL type that is unsupported or the result of a typo." } ;
 
 HELP: normalize-spec
 { $values
      { "spec" "a SQL spec" } }
-{ $description "Normalizes a SQL spec." } ;
+{ $description "Normalizes an SQL spec." } ;
 
 HELP: primary-key?
 { $values
      { "spec" "a SQL spec" }
      { "?" boolean } }
-{ $description "Returns true if a SQL spec is a primary key." } ;
+{ $description "Returns true if an SQL spec is a primary key." } ;
 
 HELP: relation?
 { $values
      { "spec" "a SQL spec" }
      { "?" boolean } }
-{ $description "Returns true if a SQL spec is a relation." } ;
+{ $description "Returns true if an SQL spec is a relation." } ;
 
 HELP: unknown-modifier
 { $values { "modifier" string } }

basis/images/loader/gtk/gtk-tests.factor

@@ -1,21 +1,25 @@
 USING: accessors arrays continuations gdk.pixbuf.ffi glib.ffi gobject.ffi
 images.loader images.loader.gtk images.loader.gtk.private io
-io.encodings.binary io.files kernel tools.test ;
+io.encodings.binary io.files kernel tools.test destructors ;
 IN: images.loader.gtk.tests
 
 : open-png-image ( -- image )
     "vocab:images/testing/png/basi0g01.png" load-image ;
 
 { t } [
-    open-png-image [ dim>> ] [
+    [
-        image>GdkPixbuf &g_object_unref
+        open-png-image [ dim>> ] [
-        [ gdk_pixbuf_get_width ] [ gdk_pixbuf_get_height ] bi 2array
+            image>GdkPixbuf &g_object_unref
-    ] bi =
+            [ gdk_pixbuf_get_width ] [ gdk_pixbuf_get_height ] bi 2array
+        ] bi =
+    ] with-destructors
 ] unit-test
 
 { t } [
     [
-        open-png-image image>GdkPixbuf &g_object_unref
+        [
-        "frob" GdkPixbuf>byte-array
+            open-png-image image>GdkPixbuf &g_object_unref
-    ] [ g-error? ] recover
+            "frob" GdkPixbuf>byte-array
+        ] [ g-error? ] recover
+    ] with-destructors
 ] unit-test

basis/io/directories/directories-docs.factor

@@ -47,7 +47,7 @@ HELP: directory-entries
 
 HELP: qualified-directory-entries
 { $values { "path" "a pathname string" } { "seq" "a sequence of " { $link directory-entry } " objects" } }
-{ $description "Outputs the contents of a directory named by " { $snippet "path" } ". using absolute file paths." } ;
+{ $description "Outputs the contents of a directory named by " { $snippet "path" } " using absolute file paths." } ;
 
 HELP: directory-files
 { $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } }

basis/io/servers/servers-docs.factor

@@ -81,7 +81,7 @@ ARTICLE: "io.servers" "Threaded servers"
     insecure-addr
 }
 "Additionally, the " { $link local-address } " and "
-{ $subsections remote-address } " variables are set, as in " { $link with-client } "." ;
+{ $link remote-address } " variables are set, as in " { $link with-client } "." ;
 
 ABOUT: "io.servers"
 

basis/math/combinatorics/combinatorics.factor

@@ -3,7 +3,7 @@
 
 USING: accessors arrays assocs binary-search classes.tuple
 combinators fry hints kernel kernel.private locals math
-math.order math.ranges memoize namespaces sequences
+math.functions math.order math.ranges namespaces sequences
 sequences.private sorting strings vectors ;
 IN: math.combinatorics
 
@@ -28,7 +28,7 @@ M: object nths-unsafe (nths-unsafe) ;
 
 PRIVATE>
 
-MEMO: factorial ( n -- n! )
+: factorial ( n -- n! )
     dup 1 > [ [1,b] product ] [ drop 1 ] if ;
 
 : nPk ( n k -- nPk )
@@ -251,10 +251,20 @@ PRIVATE>
 
 <PRIVATE
 
-: (selections) ( seq n -- selections )
+:: next-selection ( seq n -- )
-    [ dup [ 1sequence ] curry { } map-as dup ] [ 1 - ] bi* [
+    1 seq length 1 - [
-        cartesian-product concat [ concat ] map
+        dup 0 >= [ over 0 = ] [ t ] if
-    ] with times ;
+    ] [
+        [ seq [ + n /mod ] change-nth-unsafe ] keep 1 -
+    ] do until 2drop ; inline
+
+:: (selections) ( seq n -- selections )
+    seq length :> len
+    n 0 <array> :> idx
+    len n ^ [
+        idx seq nths-unsafe
+        idx len next-selection
+    ] replicate ;
 
 PRIVATE>
 

basis/math/functions/functions-tests.factor

@@ -196,10 +196,13 @@ CONSTANT: log10-factorial-1000 0x1.40f3593ed6f8ep11
 { t } [ 0.3 round double>bits 0.0 double>bits = ] unit-test
 
 ! A signaling NaN should raise an exception
-{ { +fp-invalid-operation+ } } [ [ nan: 4000000000000 truncate drop ] collect-fp-exceptions ] unit-test
+! XXX: disabling to get linux32 binary
-{ { +fp-invalid-operation+ } } [ [ nan: 4000000000000 round drop ] collect-fp-exceptions ] unit-test
+! HACK: bug in factor or in vmware?
-{ { +fp-invalid-operation+ } } [ [ nan: 4000000000000 ceiling drop ] collect-fp-exceptions ] unit-test
+! TODO: fix this test on linux32 vmware
-{ { +fp-invalid-operation+ } } [ [ nan: 4000000000000 floor drop ] collect-fp-exceptions ] unit-test
+!  { { +fp-invalid-operation+ } } [ [ NAN: 4000000000000 truncate drop ] collect-fp-exceptions ] unit-test
+{ { +fp-invalid-operation+ } } [ [ NAN: 4000000000000 round drop ] collect-fp-exceptions ] unit-test
+{ { +fp-invalid-operation+ } } [ [ NAN: 4000000000000 ceiling drop ] collect-fp-exceptions ] unit-test
+{ { +fp-invalid-operation+ } } [ [ NAN: 4000000000000 floor drop ] collect-fp-exceptions ] unit-test
 
 { -5 } [ -4-3/5 round-to-even ] unit-test
 { -4 } [ -4-1/2 round-to-even ] unit-test

basis/tools/ps/windows/windows.factor

@@ -1,9 +1,9 @@
 USING: accessors alien alien.c-types alien.data alien.syntax
-arrays byte-arrays classes.struct destructors fry io
+arrays byte-arrays classes.struct combinators.short-circuit
-io.encodings.string io.encodings.utf16n kernel literals locals
+continuations destructors fry io io.encodings.string
-math sequences strings system tools.ps
+io.encodings.utf16n kernel literals locals math sequences
-windows.errors windows.handles windows.kernel32 windows.ntdll
+strings system tools.ps windows.errors windows.handles
-windows.types ;
+windows.kernel32 windows.ntdll windows.types ;
 IN: tools.ps.windows
 
 : do-snapshot ( snapshot-type -- handle )
@@ -83,10 +83,16 @@ IN: tools.ps.windows
         [ first-process ]
         [ '[ drop _ next-process ] follow ] tri
         [
-            [ th32ProcessID>> ]
+            [
-            [ th32ProcessID>> open-process-read dup [ read-args ] when ]
+                [ th32ProcessID>> ]
-            [ szExeFile>> [ 0 = ] trim-tail >string or ] tri 2array
+                [ th32ProcessID>> open-process-read dup [ read-args ] when ]
-        ] map
+                [ szExeFile>> [ 0 = ] trim-tail >string or ] tri 2array
+            ] [
+                ! Reading the arguments can fail
+                ! Win32 error 0x12b: Only part of a ReadProcessMemory or WriteProcessMemory request was completed.
+                dup { [ windows-error? ] [ n>> 0x12b = ] } 1&& [ 2drop f ] [ rethrow ] if
+            ] recover
+        ] map sift
     ] with-destructors ;
 
 M: windows ps ( -- assoc ) process-list ;

basis/ui/backend/cocoa/views/views.factor

@@ -1,13 +1,14 @@
 ! Copyright (C) 2006, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.data alien.strings
-arrays assocs cocoa cocoa.application cocoa.classes
+arrays assocs classes cocoa cocoa.application cocoa.classes
-cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.types
+cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.touchbar
-cocoa.views combinators core-foundation.strings core-graphics
+cocoa.types cocoa.views combinators core-foundation.strings
-core-graphics.types core-text io.encodings.utf8 kernel literals
+core-graphics core-graphics.types core-text io.encodings.utf8
-locals math math.rectangles namespaces opengl sequences threads
+kernel literals locals math math.order math.parser
-ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
+math.rectangles namespaces opengl sequences splitting threads
-ui.private ;
+ui.commands ui.gadgets ui.gadgets.private ui.gadgets.worlds
+ui.gestures ui.private words ;
 IN: ui.backend.cocoa.views
 
 : send-mouse-moved ( view event -- )
@@ -160,6 +161,18 @@ CONSTANT: selector>action H{
     selector>action at
     [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
 
+: touchbar-commands ( -- commands/f gadget )
+    world get [
+        children>> [
+            class-of "commands" word-prop
+            "touchbar" of dup [ commands>> ] when
+        ] map-find
+    ] [ f f ] if* ;
+
+: touchbar-invoke-command ( n -- )
+    [ touchbar-commands ] dip over
+    [ rot nth second invoke-command ] [ 3drop ] if ;
+
 <CLASS: FactorView < NSOpenGLView
     COCOA-PROTOCOL: NSTextInput
 
@@ -182,6 +195,30 @@ CONSTANT: selector>action H{
         ] when
     ] ;
 
+    ! TouchBar
+    METHOD: void touchBarCommand0 [ 0 touchbar-invoke-command ] ;
+    METHOD: void touchBarCommand1 [ 1 touchbar-invoke-command ] ;
+    METHOD: void touchBarCommand2 [ 2 touchbar-invoke-command ] ;
+    METHOD: void touchBarCommand3 [ 3 touchbar-invoke-command ] ;
+    METHOD: void touchBarCommand4 [ 4 touchbar-invoke-command ] ;
+    METHOD: void touchBarCommand5 [ 5 touchbar-invoke-command ] ;
+    METHOD: void touchBarCommand6 [ 6 touchbar-invoke-command ] ;
+    METHOD: void touchBarCommand7 [ 7 touchbar-invoke-command ] ;
+
+    METHOD: Class makeTouchBar [
+        touchbar-commands drop [
+            length 8 min <iota> [ number>string ] map
+        ] [ { } ] if* self make-touchbar
+    ] ;
+
+    METHOD: Class touchBar: Class touchbar makeItemForIdentifier: Class string [
+        touchbar-commands drop [
+            [ self string CF>string dup string>number ] dip nth
+            second name>> "com-" ?head drop over
+            "touchBarCommand" prepend make-NSTouchBar-button
+        ] [ f ] if*
+    ] ;
+
     ! Rendering
     METHOD: void drawRect: NSRect rect [ self window [ draw-world ] when* ] ;
 

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

@@ -1,7 +1,8 @@
 USING: accessors colors fonts fry help help.markup help.stylesheet
 help.syntax help.topics inspector io io.streams.string io.styles
-kernel math models namespaces prettyprint see sequences tools.test
+kernel literals math models namespaces prettyprint see sequences
-ui.gadgets ui.gadgets.debug ui.gadgets.panes ui.gadgets.panes.private ;
+tools.test ui.gadgets ui.gadgets.debug ui.gadgets.panes
+ui.gadgets.panes.private ;
 IN: ui.gadgets.panes.tests
 
 : #children ( -- n ) "pane" get children>> length ;
@@ -126,11 +127,11 @@ ARTICLE: "test-article-2" "This is a test article"
 { t } [ <test-pane> dup last-line>> child? ] unit-test
 
 ! smash-line
-{
+${
     ""
     T{ font
-       { name "sans-serif" }
+       { name $[ default-sans-serif-font-name ] }
-       { size 12 }
+       { size $[ default-font-size ] }
        { foreground
          T{ rgba
             { red 0.0 }

basis/ui/tools/browser/browser.factor

@@ -225,6 +225,12 @@ browser-gadget "multi-touch" f {
     { right-action com-forward }
 } define-command-map
 
+browser-gadget "touchbar" f {
+    { f com-home }
+    { f browser-help }
+    { f glossary }
+} define-command-map
+
 browser-gadget "scrolling"
 "The browser's scroller can be scrolled from the keyboard."
 {

basis/ui/tools/listener/listener.factor

@@ -466,6 +466,12 @@ listener-gadget "multi-touch" f {
     { up-action refresh-all }
 } define-command-map
 
+listener-gadget "touchbar" f {
+    { f refresh-all }
+    { f com-auto-use }
+    { f com-help }
+} define-command-map
+
 M: listener-gadget graft*
     [ call-next-method ] [ restart-listener ] bi ;
 

build.sh

@@ -670,8 +670,8 @@ make_boot_image() {
     check_ret factor
 }
 
-install_deps_apt_get() {
+install_deps_apt() {
-    sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev libgtk2.0-dev gtk2-engines-pixbuf libgtkglext1-dev wget git git-doc rlwrap clang gcc make screen tmux libssl-dev g++
+    sudo apt install --yes libc6-dev libpango1.0-dev libx11-dev xorg-dev libgtk2.0-dev gtk2-engines-pixbuf libgtkglext1-dev wget git git-doc rlwrap clang gcc make screen tmux libssl-dev g++
     check_ret sudo
 }
 
@@ -702,7 +702,7 @@ install_deps_macosx() {
 usage() {
     $ECHO "usage: $0 command [optional-target]"
     $ECHO "  install - git clone, compile, bootstrap"
-    $ECHO "  deps-apt-get - install required packages for Factor on Linux using apt-get"
+    $ECHO "  deps-apt - install required packages for Factor on Linux using apt"
     $ECHO "  deps-pacman - install required packages for Factor on Linux using pacman"
     $ECHO "  deps-dnf - install required packages for Factor on Linux using dnf"
     $ECHO "  deps-macosx - install git on MacOSX using port"
@@ -733,7 +733,7 @@ set_delete
 
 case "$1" in
     install) install ;;
-    deps-apt-get) install_deps_apt_get ;;
+    deps-apt) install_deps_apt ;;
     deps-pacman) install_deps_pacman ;;
     deps-macosx) install_deps_macosx ;;
     deps-dnf) install_deps_dnf ;;

extra/cap/cap-docs.factor

@@ -0,0 +1,15 @@
+USING: cap help.markup help.syntax images opengl ui.gadgets.worlds ;
+IN: cap
+
+HELP: screenshot.
+  { $values { "window" world } }
+  { $description
+    "Opens a window with a screenshot of the currently active window."
+  } ;
+
+HELP: screenshot
+  { $values { "window" world } { "bitmap" image } }
+  { $description
+    "Creates a bitmap image of a UI window."
+  }
+  { $notes "If the current " { $link gl-scale-factor } " is " { $snippet "2.0" } ", then the " { $snippet "2x" } " slot in the resulting " { $link image } " will be " { $link t } "." } ;

extra/cap/cap.factor

@@ -1,16 +1,18 @@
 ! Copyright (C) 2008 Doug Coleman, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.syntax arrays byte-arrays fry images
+USING: accessors byte-arrays images images.normalization
-images.normalization images.viewer kernel math math.vectors
+images.viewer kernel math namespaces opengl opengl.gl sequences
-models namespaces opengl opengl.gl sequences ui ui.gadgets
+ui ui.backend ui.gadgets.worlds ;
-ui.gadgets.worlds ;
 IN: cap
 
+<PRIVATE
+
 : screenshot-array ( world -- byte-array )
     dim>> [ first 4 * ] [ second ] bi
     [ gl-scale ] bi@ * >fixnum <byte-array> ;
 
 : gl-screenshot ( gadget -- byte-array )
+    [ find-world handle>> select-gl-context ]
     [
         [
             GL_BACK glReadBuffer
@@ -20,11 +22,15 @@ IN: cap
         dim>> first2 [ gl-scale >fixnum ] bi@
         GL_RGBA GL_UNSIGNED_BYTE
     ]
-    [ screenshot-array ] bi
+    [ screenshot-array ] tri
     [ glReadPixels ] keep ;
 
+PRIVATE>
+
 : screenshot ( window -- bitmap )
-    [ <image> t >>2x? ] dip
+    [ <image>
+        gl-scale-factor get-global [ 2.0 = >>2x? ] when*
+    ] dip
     [ gl-screenshot >>bitmap ]
     [ dim>> [ gl-scale >fixnum ] map >>dim ] bi
     ubyte-components >>component-type

extra/cap/summary.txt

@@ -0,0 +1 @@
+Creating and displaying screenshots of Factor

extra/mason/child/child.factor

@@ -19,7 +19,7 @@ M: unix compile-factor-command ( -- array )
 ! Windows has separate 32/64 bit shells, so assuming the cell bits here is fine
 ! because it won't find the right toolchain otherwise.
 M: windows compile-factor-command ( -- array )
-    { "nmake" "/f" "NMakefile" } cell-bits 64 = "x86-64" "x86-32" ? suffix ;
+    { "nmake" "/f" "NMakefile" } cell-bits 64 = "x86-64-vista" "x86-32-vista" ? suffix ;
 
 HOOK: factor-path os ( -- path )
 M: unix factor-path "./factor" ;