Merge remote-tracking branch 'origin/master' into modern-harvey2
Doug Coleman
commit
f5853bda82
|
|
@ -11,6 +11,7 @@ branches:
|
|||
- master
|
||||
sudo: required
|
||||
dist: trusty
|
||||
group: deprecated-2017Q4
|
||||
services:
|
||||
- postgresql
|
||||
- redis-server
|
||||
|
|
|
|||
12
README.md
12
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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
cocoa.classes cocoa.messages cocoa.runtime combinators
|
||||
core-foundation.strings kernel locals namespaces sequences words ;
|
||||
USING: alien.c-types cocoa cocoa.classes cocoa.messages
|
||||
cocoa.runtime combinators core-foundation.strings kernel locals
|
||||
;
|
||||
IN: cocoa.touchbar
|
||||
|
||||
! ui.backend.cocoa.views creates buttons for each of these actions
|
||||
ENUM: default-touchbar refresh-all-action auto-use-action ;
|
||||
|
||||
: enum>CFStringArray ( seq -- alien )
|
||||
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: ]
|
||||
: make-touchbar ( seq self -- touchbar )
|
||||
[ NSTouchBar -> alloc -> init dup ] dip -> setDelegate: {
|
||||
[ swap <CFStringArray> { void { id SEL id } } ?-> setDefaultItemIdentifiers: ]
|
||||
[ swap <CFStringArray> { void { id SEL id } } ?-> setCustomizationAllowedItemIdentifiers: ]
|
||||
[ nip ]
|
||||
} 2cleave ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;"
|
||||
"\"hello\" \"127.0.0.1\" 9000 <inet4> \"logger\" <remote-thread> send"
|
||||
"USING: io.servers concurrency.distributed ; FROM: concurrency.messaging => 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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\""
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } }
|
||||
{ $description "A combinator that calls a quotation on a sequence of SQL statements to their results query results." } ;
|
||||
{ "result-set" result-set } { "quot" quotation } }
|
||||
{ $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 }
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ gdk_pixbuf_get_width ] [ gdk_pixbuf_get_height ] bi 2array
|
||||
] bi =
|
||||
[
|
||||
open-png-image [ dim>> ] [
|
||||
image>GdkPixbuf &g_object_unref
|
||||
[ 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
|
||||
] [ g-error? ] recover
|
||||
[
|
||||
open-png-image image>GdkPixbuf &g_object_unref
|
||||
"frob" GdkPixbuf>byte-array
|
||||
] [ g-error? ] recover
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
[ dup [ 1sequence ] curry { } map-as dup ] [ 1 - ] bi* [
|
||||
cartesian-product concat [ concat ] map
|
||||
] with times ;
|
||||
:: next-selection ( seq n -- )
|
||||
1 seq length 1 - [
|
||||
dup 0 >= [ over 0 = ] [ t ] if
|
||||
] [
|
||||
[ 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>
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
{ { +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
|
||||
! XXX: disabling to get linux32 binary
|
||||
! HACK: bug in factor or in vmware?
|
||||
! TODO: fix this test on linux32 vmware
|
||||
! { { +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
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
USING: accessors alien alien.c-types alien.data alien.syntax
|
||||
arrays byte-arrays classes.struct destructors fry io
|
||||
io.encodings.string io.encodings.utf16n kernel literals locals
|
||||
math sequences strings system tools.ps
|
||||
windows.errors windows.handles windows.kernel32 windows.ntdll
|
||||
windows.types ;
|
||||
arrays byte-arrays classes.struct combinators.short-circuit
|
||||
continuations destructors fry io io.encodings.string
|
||||
io.encodings.utf16n kernel literals locals math sequences
|
||||
strings system tools.ps windows.errors windows.handles
|
||||
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 ]
|
||||
[ szExeFile>> [ 0 = ] trim-tail >string or ] tri 2array
|
||||
] map
|
||||
[
|
||||
[ th32ProcessID>> ]
|
||||
[ th32ProcessID>> open-process-read dup [ read-args ] when ]
|
||||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.types
|
||||
cocoa.views combinators core-foundation.strings core-graphics
|
||||
core-graphics.types core-text io.encodings.utf8 kernel literals
|
||||
locals math math.rectangles namespaces opengl sequences threads
|
||||
ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
|
||||
ui.private ;
|
||||
arrays assocs classes cocoa cocoa.application cocoa.classes
|
||||
cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.touchbar
|
||||
cocoa.types cocoa.views combinators core-foundation.strings
|
||||
core-graphics core-graphics.types core-text io.encodings.utf8
|
||||
kernel literals locals math math.order math.parser
|
||||
math.rectangles namespaces opengl sequences splitting threads
|
||||
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* ] ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
ui.gadgets ui.gadgets.debug ui.gadgets.panes ui.gadgets.panes.private ;
|
||||
kernel literals math models namespaces prettyprint see sequences
|
||||
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" }
|
||||
{ size 12 }
|
||||
{ name $[ default-sans-serif-font-name ] }
|
||||
{ size $[ default-font-size ] }
|
||||
{ foreground
|
||||
T{ rgba
|
||||
{ red 0.0 }
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
8
build.sh
8
build.sh
|
|
@ -670,8 +670,8 @@ make_boot_image() {
|
|||
check_ret factor
|
||||
}
|
||||
|
||||
install_deps_apt_get() {
|
||||
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++
|
||||
install_deps_apt() {
|
||||
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 ;;
|
||||
|
|
|
|||
|
|
@ -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 } "." } ;
|
||||
|
|
@ -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
|
||||
images.normalization images.viewer kernel math math.vectors
|
||||
models namespaces opengl opengl.gl sequences ui ui.gadgets
|
||||
ui.gadgets.worlds ;
|
||||
USING: accessors byte-arrays images images.normalization
|
||||
images.viewer kernel math namespaces opengl opengl.gl sequences
|
||||
ui ui.backend 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
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Creating and displaying screenshots of 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" ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue