" } " and " { $snippet "<link>" } " must appear inside the " { $snippet "<head>" } " tag, even though those tags are usually precisely those that the child template will want to set." -{ $subsection set-title } -{ $subsection write-title } -{ $subsection add-style } -{ $subsection write-style } -{ $subsection add-atom-feed } -{ $subsection write-atom-feeds } +{ $subsections + set-title + write-title + add-style + write-style + add-atom-feed + write-atom-feeds +} "Processing a master template with a child:" -{ $subsection with-boilerplate } -{ $subsection call-next-template } ; +{ $subsections + with-boilerplate + call-next-template +} ; ARTICLE: "html.templates" "HTML template interface" "The " { $vocab-link "html.templates" } " vocabulary implements an abstract interface to HTML templating engines. The " { $vocab-link "html.templates.fhtml" } " and " { $vocab-link "html.templates.chloe" } " vocabularies are two implementations of this." $nl "An HTML template is an instance of a mixin:" -{ $subsection template } +{ $subsections template } "HTML templates must also implement a method on a generic word:" -{ $subsection call-template* } +{ $subsections call-template* } "Calling an HTML template:" -{ $subsection call-template } +{ $subsections call-template } "Usually HTML templates are invoked dynamically by the Furnace web framework and HTTP server. They can also be used in static HTML generation tools:" -{ $subsection template-convert } -{ $subsection "html.templates.boilerplate" } ; +{ $subsections + template-convert + "html.templates.boilerplate" +} ; ABOUT: "html.templates" diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 890518aa2a..330db4467b 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -61,16 +61,22 @@ HELP: with-http-request ARTICLE: "http.client.get" "GET requests with the HTTP client" "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:" -{ $subsection http-get } +{ $subsections http-get } "Utilities to retrieve a " { $link url } " and save the contents to a file:" -{ $subsection download } -{ $subsection download-to } +{ $subsections + download + download-to +} "Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:" -{ $subsection <get-request> } -{ $subsection http-request } +{ $subsections + <get-request> + http-request +} "The " { $link http-get } " and " { $link http-request } " words output sequences. This is undesirable if the response data may be large. Another pair of words take a quotation instead, and pass the quotation chunks of data incrementally:" -{ $subsection with-http-get } -{ $subsection with-http-request } ; +{ $subsections + with-http-get + with-http-request +} ; ARTICLE: "http.client.post-data" "HTTP client post data" "HTTP POST and PUT request words take a post data parameter, which can be one of the following:" @@ -88,20 +94,20 @@ ARTICLE: "http.client.post-data" "HTTP client post data" "[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal" } "An internal word used to convert objects to " { $link post-data } " instances:" -{ $subsection >post-data } ; +{ $subsections >post-data } ; ARTICLE: "http.client.post" "POST requests with the HTTP client" "Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:" -{ $subsection http-post } +{ $subsections http-post } "Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:" -{ $subsection <post-request> } +{ $subsections <post-request> } "Both words take a post data parameter; see " { $link "http.client.post-data" } "." ; ARTICLE: "http.client.put" "PUT requests with the HTTP client" "Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:" -{ $subsection http-post } +{ $subsections http-post } "Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:" -{ $subsection <post-request> } +{ $subsections <post-request> } "Both words take a post data parameter; see " { $link "http.client.post-data" } "." ; ARTICLE: "http.client.encoding" "Character encodings and the HTTP client" @@ -115,8 +121,10 @@ $nl ARTICLE: "http.client.errors" "HTTP client errors" "HTTP operations may fail for one of two reasons. The first is an I/O error resulting from a network problem; a name server lookup failure, or a refused connection. The second is a protocol-level error returned by the server. There are two such errors:" -{ $subsection download-failed } -{ $subsection too-many-redirects } ; +{ $subsections + download-failed + too-many-redirects +} ; ARTICLE: "http.client" "HTTP client" "The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "." @@ -124,14 +132,18 @@ $nl "For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't need HTTPS support, don't load " { $vocab-link "urls.secure" } "; this will reduce the size of images generated by " { $vocab-link "tools.deploy" } "." $nl "There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:" -{ $subsection "http.client.get" } -{ $subsection "http.client.post" } -{ $subsection "http.client.put" } +{ $subsections + "http.client.get" + "http.client.post" + "http.client.put" +} "Submission data for POST and PUT requests:" -{ $subsection "http.client.post-data" } +{ $subsections "http.client.post-data" } "More esoteric use-cases, for example HTTP methods other than the above, are accomodated by constructing an empty request object with " { $link <request> } " and filling everything in by hand." -{ $subsection "http.client.encoding" } -{ $subsection "http.client.errors" } +{ $subsections + "http.client.encoding" + "http.client.errors" +} { $see-also "urls" } ; ABOUT: "http.client" diff --git a/basis/http/http-docs.factor b/basis/http/http-docs.factor index e7ff38ac42..0dca26fd32 100644 --- a/basis/http/http-docs.factor +++ b/basis/http/http-docs.factor @@ -126,48 +126,64 @@ $nl "The " { $vocab-link "furnace.sessions" } " vocabulary implements session management using cookies, thus the most common use case can be taken care of without working with cookies directly." $nl "The class of cookies:" -{ $subsection cookie } +{ $subsections cookie } "Creating cookies:" -{ $subsection <cookie> } +{ $subsections <cookie> } "Getting, adding, and deleting cookies in " { $link request } " and " { $link response } " objects:" -{ $subsection get-cookie } -{ $subsection put-cookie } -{ $subsection delete-cookie } ; +{ $subsections + get-cookie + put-cookie + delete-cookie +} ; ARTICLE: "http.headers" "HTTP headers" "Every " { $link request } " and " { $link response } " has a set of HTTP headers stored in the " { $slot "header" } " slot. Header names are normalized to lower-case when a request or response is being parsed." -{ $subsection header } -{ $subsection set-header } ; +{ $subsections + header + set-header +} ; ARTICLE: "http.post-data" "HTTP post data" "Every " { $link request } " where the " { $slot "method" } " slot is " { $snippet "POST" } " can contain post data." -{ $subsection post-data } -{ $subsection <post-data> } ; +{ $subsections + post-data + <post-data> +} ; ARTICLE: "http.requests" "HTTP requests" "HTTP requests:" -{ $subsection request } -{ $subsection <request> } +{ $subsections + request + <request> +} "Requests can contain form submissions:" -{ $subsection "http.post-data" } ; +{ $subsections "http.post-data" } ; ARTICLE: "http.responses" "HTTP responses" "HTTP responses:" -{ $subsection response } -{ $subsection <response> } +{ $subsections + response + <response> +} "Raw responses only contain a status line, with no header. They are used by webapps which need full control over the HTTP response, for example " { $vocab-link "http.server.cgi" } ":" -{ $subsection raw-response } -{ $subsection <raw-response> } ; +{ $subsections + raw-response + <raw-response> +} ; ARTICLE: "http" "HTTP protocol objects" "The " { $vocab-link "http" } " vocabulary contains data types shared by " { $vocab-link "http.client" } " and " { $vocab-link "http.server" } "." $nl "The HTTP client sends an HTTP request to the server and receives an HTTP response back. The HTTP server receives HTTP requests from clients and sends HTTP responses back." -{ $subsection "http.requests" } -{ $subsection "http.responses" } +{ $subsections + "http.requests" + "http.responses" +} "Both requests and responses support some common functionality:" -{ $subsection "http.headers" } -{ $subsection "http.cookies" } +{ $subsections + "http.headers" + "http.cookies" +} { $see-also "urls" } ; ABOUT: "http" diff --git a/basis/http/server/cgi/cgi-docs.factor b/basis/http/server/cgi/cgi-docs.factor index e4ce71f626..001fa163e1 100644 --- a/basis/http/server/cgi/cgi-docs.factor +++ b/basis/http/server/cgi/cgi-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax http.server.static multiline ; +USING: help.markup help.syntax http.server.static ; IN: http.server.cgi HELP: enable-cgi @@ -6,12 +6,12 @@ HELP: enable-cgi { $description "Enables the responder to serve " { $snippet ".cgi" } " scripts by executing them as per the CGI specification." } { $examples { $code - <" <dispatcher> - "/var/www/cgi/" <static> enable-cgi "cgi-bin" add-responder" "> + """<dispatcher> + "/var/www/cgi/" <static> enable-cgi "cgi-bin" add-responder""" } } { $side-effects "responder" } ; ARTICLE: "http.server.cgi" "Serving CGI scripts" "The " { $vocab-link "http.server.cgi" } " implements CGI support. It is used in conjunction with a " { $link <static> } " responder." -{ $subsection enable-cgi } ; +{ $subsections enable-cgi } ; diff --git a/basis/http/server/dispatchers/dispatchers-docs.factor b/basis/http/server/dispatchers/dispatchers-docs.factor index e0f7f20e69..d4de6b6de4 100644 --- a/basis/http/server/dispatchers/dispatchers-docs.factor +++ b/basis/http/server/dispatchers/dispatchers-docs.factor @@ -1,7 +1,6 @@ -! Copyright (C) 2008 Your name. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes help.markup help.syntax io.streams.string -multiline ; +USING: classes help.markup help.syntax io.streams.string ; IN: http.server.dispatchers HELP: new-dispatcher @@ -32,28 +31,28 @@ HELP: add-responder ARTICLE: "http.server.dispatchers.example" "HTTP dispatcher examples" { $heading "Simple pathname dispatcher" } { $code - <" <dispatcher> + """<dispatcher> <new-action> "new" add-responder <edit-action> "edit" add-responder <delete-action> "delete" add-responder <list-action> "" add-responder -main-responder set-global"> +main-responder set-global""" } "In the above example, visiting any URL other than " { $snippet "/new" } ", " { $snippet "/edit" } ", " { $snippet "/delete" } ", or " { $snippet "/" } " will result in a 404 error." { $heading "Another pathname dispatcher" } "On the other hand, suppose we wanted to route all unrecognized paths to a âviewâ action:" { $code - <" <dispatcher> + """<dispatcher> <new-action> "new" add-responder <edit-action> "edit" add-responder <delete-action> "delete" add-responder <view-action> >>default -main-responder set-global"> +main-responder set-global""" } "The " { $slot "default" } " slot holds a responder to which all unrecognized paths are sent to." { $heading "Dispatcher subclassing example" } { $code - <" TUPLE: golf-courses < dispatcher ; + """TUPLE: golf-courses < dispatcher ; : <golf-courses> ( -- golf-courses ) golf-courses new-dispatcher ; @@ -63,29 +62,33 @@ main-responder set-global"> <edit-action> "edit" add-responder <delete-action> "delete" add-responder <list-action> "" add-responder -main-responder set-global"> +main-responder set-global""" } "The action templates can now emit links to responder-relative URLs prefixed by " { $snippet "$golf-courses/" } "." { $heading "Virtual hosting example" } { $code - <" <vhost-dispatcher> + """<vhost-dispatcher> <casino> "concatenative-casino.com" add-responder <dating> "raptor-dating.com" add-responder -main-responder set-global"> +main-responder set-global""" } "Note that the virtual host dispatcher strips off a " { $snippet "www." } " prefix, so " { $snippet "www.concatenative-casino.com" } " would be routed to the " { $snippet "<casino>" } " responder instead of receiving a 404." ; ARTICLE: "http.server.dispatchers" "HTTP dispatchers and virtual hosting" "The " { $vocab-link "http.server.dispatchers" } " vocabulary implements two responders which route HTTP requests to one or more child responders." -{ $subsection "http.server.dispatchers.example" } +{ $subsections "http.server.dispatchers.example" } "Pathname dispatchers implement a directory hierarchy where each subdirectory is its own responder:" -{ $subsection dispatcher } -{ $subsection <dispatcher> } +{ $subsections + dispatcher + <dispatcher> +} "Virtual host dispatchers dispatch each virtual host to a different responder:" -{ $subsection vhost-dispatcher } -{ $subsection <vhost-dispatcher> } +{ $subsections + vhost-dispatcher + <vhost-dispatcher> +} "Adding responders to dispatchers:" -{ $subsection add-responder } +{ $subsections add-responder } "The " { $slot "default" } " slot holds a responder which receives all unrecognized URLs. By default, it responds with 404 messages." ; ABOUT: "http.server.dispatchers" diff --git a/basis/http/server/filters/filters-docs.factor b/basis/http/server/filters/filters-docs.factor index 8130fccf66..d05971a39f 100644 --- a/basis/http/server/filters/filters-docs.factor +++ b/basis/http/server/filters/filters-docs.factor @@ -6,7 +6,7 @@ HELP: filter-responder ARTICLE: "http.server.filters" "HTTP responder filters" "The " { $vocab-link "http.server.filters" } " vocabulary implements the common pattern where one responder wraps another, doing some processing before calling the wrapped responder." -{ $subsection filter-responder } +{ $subsections filter-responder } "To use it, simply subclass " { $link filter-responder } ", and call " { $link POSTPONE: call-next-method } " from your " { $link call-responder* } " method to pass control to the wrapped responder." ; ABOUT: "http.server.filters" diff --git a/basis/http/server/redirection/redirection-docs.factor b/basis/http/server/redirection/redirection-docs.factor index 83b420e73a..01d909cc37 100644 --- a/basis/http/server/redirection/redirection-docs.factor +++ b/basis/http/server/redirection/redirection-docs.factor @@ -17,10 +17,12 @@ HELP: <temporary-redirect> ARTICLE: "http.server.redirection" "HTTP responder redirection" "The " { $vocab-link "http.server.redirection" } " defines some " { $link response } " types which redirect the user's client to a new page." -{ $subsection <permanent-redirect> } -{ $subsection <temporary-redirect> } +{ $subsections + <permanent-redirect> + <temporary-redirect> +} "A utility used by the above:" -{ $subsection relative-to-request } +{ $subsections relative-to-request } "The " { $vocab-link "furnace.redirection" } " vocabulary provides a higher-level implementation of this. The " { $vocab-link "furnace.conversations" } " vocabulary allows state to be maintained between redirects." ; ABOUT: "http.server.redirection" diff --git a/basis/http/server/remapping/remapping-docs.factor b/basis/http/server/remapping/remapping-docs.factor index aa38087766..7531dbef85 100644 --- a/basis/http/server/remapping/remapping-docs.factor +++ b/basis/http/server/remapping/remapping-docs.factor @@ -15,7 +15,7 @@ ARTICLE: "http.server.remapping" "HTTP server port remapping" "However, the HTTP server is unaware of the forwarding, and still believes that it is listening on port 8080 and 8443, respectively. This can be a problem if a responder wishes to redirect the user to a secure page; they will be sent to port 8443 and not 443 as one would expect." $nl "The " { $vocab-link "http.server.remapping" } " vocabulary defines a variable which may store an assoc of port mappings:" -{ $subsection port-remapping } +{ $subsections port-remapping } "For example, with the above setup, we would set it as follows:" { $code "{ { 8080 80 } { 8443 443 } } port-remapping set-global" diff --git a/basis/http/server/responses/responses-docs.factor b/basis/http/server/responses/responses-docs.factor index 5e93c4c1f3..dd2867817e 100644 --- a/basis/http/server/responses/responses-docs.factor +++ b/basis/http/server/responses/responses-docs.factor @@ -18,12 +18,14 @@ HELP: <trivial-response> ARTICLE: "http.server.responses" "Canned HTTP responses" "The " { $vocab-link "http.server.responses" } " vocabulary provides constructors for a few useful " { $link response } " objects." -{ $subsection <content> } -{ $subsection <304> } -{ $subsection <403> } -{ $subsection <400> } -{ $subsection <404> } +{ $subsections + <content> + <304> + <403> + <400> + <404> +} "New error responses like the above can be created for other error codes too:" -{ $subsection <trivial-response> } ; +{ $subsections <trivial-response> } ; ABOUT: "http.server.responses" diff --git a/basis/http/server/rewrite/rewrite-docs.factor b/basis/http/server/rewrite/rewrite-docs.factor index 9ded10bded..2834e17d50 100644 --- a/basis/http/server/rewrite/rewrite-docs.factor +++ b/basis/http/server/rewrite/rewrite-docs.factor @@ -61,12 +61,16 @@ $nl ARTICLE: "http.server.rewrite" "URL rewrite responders" "The " { $vocab-link "http.server.rewrite" } " vocabulary defines two responder types which can help make website URLs more human-friendly." -{ $subsection "http.server.rewrite.overview" } +{ $subsections "http.server.rewrite.overview" } "Directory rewrite responders:" -{ $subsection rewrite } -{ $subsection <rewrite> } +{ $subsections + rewrite + <rewrite> +} "Virtual host rewrite responders -- these chop off the value in the " { $snippet "suffix" } " slot from the tail of the host name, and use the rest as the parameter value:" -{ $subsection vhost-rewrite } -{ $subsection <vhost-rewrite> } ; +{ $subsections + vhost-rewrite + <vhost-rewrite> +} ; ABOUT: "http.server.rewrite" \ No newline at end of file diff --git a/basis/http/server/server-docs.factor b/basis/http/server/server-docs.factor index e6d5c63ac1..96e48f83bf 100644 --- a/basis/http/server/server-docs.factor +++ b/basis/http/server/server-docs.factor @@ -71,53 +71,71 @@ HELP: params ARTICLE: "http.server.requests" "HTTP request variables" "The following variables are set by the HTTP server at the beginning of a request." -{ $subsection request } -{ $subsection url } -{ $subsection post-request? } -{ $subsection responder-nesting } -{ $subsection params } +{ $subsections + request + url + post-request? + responder-nesting + params +} "Utility words:" -{ $subsection param } -{ $subsection set-param } -{ $subsection request-params } +{ $subsections + param + set-param + request-params +} "Additional vocabularies may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ; ARTICLE: "http.server.responders" "HTTP server responders" "The HTTP server dispatches requests to a main responder:" -{ $subsection main-responder } +{ $subsections main-responder } "The main responder may in turn dispatch it a subordinate dispatcher, and so on." $nl "Responders process requests and output " { $link "http.responses" } "; concretely are instances of classes which implement a generic word:" -{ $subsection call-responder* } +{ $subsections call-responder* } "To actually call a subordinate responder, use the following word instead:" -{ $subsection call-responder } +{ $subsections call-responder } "A simple implementation of a responder which always outputs the same response:" -{ $subsection trivial-responder } -{ $subsection <trivial-responder> } +{ $subsections + trivial-responder + <trivial-responder> +} { $vocab-subsection "Furnace actions" "furnace.actions" } "In particular, writing new responders by hand is rarely necessary, because in most cases it is easier to use " { $vocab-link "furnace.actions" } " instead." ; ARTICLE: "http.server.variables" "HTTP server variables" "The following global variables control the behavior of the HTTP server. Both are off by default." -{ $subsection development? } -{ $subsection benchmark? } ; +{ $subsections + development? + benchmark? +} ; ARTICLE: "http.server" "HTTP server" "The " { $vocab-link "http.server" } " vocabulary implements an HTTP and HTTPS server on top of " { $vocab-link "io.servers.connection" } "." -{ $subsection "http.server.responders" } -{ $subsection "http.server.requests" } +{ $subsections + "http.server.responders" + "http.server.requests" +} "Various types of responders are defined in other vocabularies:" -{ $subsection "http.server.dispatchers" } -{ $subsection "http.server.filters" } +{ $subsections + "http.server.dispatchers" + "http.server.filters" +} "Useful canned responses:" -{ $subsection "http.server.responses" } -{ $subsection "http.server.redirection" } +{ $subsections + "http.server.responses" + "http.server.redirection" +} "Configuration:" -{ $subsection "http.server.variables" } -{ $subsection "http.server.remapping" } +{ $subsections + "http.server.variables" + "http.server.remapping" +} "Features:" -{ $subsection "http.server.static" } -{ $subsection "http.server.cgi" } +{ $subsections + "http.server.static" + "http.server.cgi" +} "The " { $vocab-link "furnace" } " framework implements high-level abstractions which make developing web applications much easier than writing responders by hand." ; ABOUT: "http.server" diff --git a/basis/http/server/static/static-docs.factor b/basis/http/server/static/static-docs.factor index b453e7ff10..943ef769d6 100644 --- a/basis/http/server/static/static-docs.factor +++ b/basis/http/server/static/static-docs.factor @@ -23,16 +23,16 @@ ARTICLE: "http.server.static.extend" "Hooks for dynamic content" "The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- response )" } "." $nl "A utility word uses the above feature to enable server-side " { $snippet ".fhtml" } " scripts, allowing a development style much like PHP:" -{ $subsection enable-fhtml } +{ $subsections enable-fhtml } "This feature is also used by " { $vocab-link "http.server.cgi" } " to run " { $snippet ".cgi" } " files." $nl "It is also possible to override the hook used when serving static files to the client:" -{ $subsection <file-responder> } +{ $subsections <file-responder> } "The default just sends the file's contents with the request; " { $vocab-link "xmode.code2html.responder" } " provides an alternate hook which sends a syntax-highlighted version of the file." ; ARTICLE: "http.server.static" "Serving static content" "The " { $vocab-link "http.server.static" } " vocabulary implements a responder for serving static files." -{ $subsection <static> } +{ $subsections <static> } "The static responder does not serve directory listings by default, as a security measure. Directory listings can be enabled by storing a true value in the " { $slot "allow-listings" } " slot." $nl "If all you want to do is serve files from a directory, the following phrase does the trick:" @@ -41,6 +41,6 @@ $nl "\"/var/www/mysite.com/\" <static> main-responder set" "8080 httpd" } -{ $subsection "http.server.static.extend" } ; +{ $subsections "http.server.static.extend" } ; ABOUT: "http.server.static" diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor index 950fd0b3a6..cebbe2f510 100644 --- a/basis/images/bitmap/bitmap-tests.factor +++ b/basis/images/bitmap/bitmap-tests.factor @@ -1,43 +1,11 @@ -USING: images.bitmap images.viewer io.encodings.binary -io.files io.files.unique kernel tools.test images.loader -literals sequences checksums.md5 checksums ; +USING: images.bitmap images.bitmap.loading images.testing kernel ; IN: images.bitmap.tests -CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp" +! "vocab:images/testing/bmp/1bit.bmp" decode-test +! "vocab:images/testing/bmp/rgb_4bit.bmp" decode-test -CONSTANT: test-bitmap8 "vocab:images/test-images/rgb8bit.bmp" +"vocab:images/testing/bmp/rgb_8bit.bmp" +[ decode-test ] [ bmp-image encode-test ] bi -CONSTANT: test-bitmap4 "vocab:images/test-images/rgb4bit.bmp" - -CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp" - -CONSTANT: test-40 "vocab:images/test-images/40red24bit.bmp" -CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp" -CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp" -CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" - -${ - test-bitmap8 - test-bitmap24 - "vocab:ui/render/test/reference.bmp" -} [ [ ] swap [ load-image drop ] curry unit-test ] each - - -: test-bitmap-save ( path -- ? ) - [ md5 checksum-file ] - [ load-image ] bi - "bitmap-save-test" ".bmp" make-unique-file - [ save-bitmap ] - [ md5 checksum-file ] bi = ; - -[ - t -] [ - ${ - test-40 - test-41 - test-42 - test-43 - test-bitmap24 - } [ test-bitmap-save ] all? -] unit-test +"vocab:images/testing/bmp/42red_24bit.bmp" +[ decode-test ] [ bmp-image encode-test ] bi diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 8580a766b3..f14dd3290c 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -2,57 +2,67 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types arrays byte-arrays columns combinators compression.run-length endian fry grouping images -images.bitmap.loading images.loader io io.binary +images.loader images.normalization io io.binary io.encodings.binary io.encodings.string io.files io.streams.limited kernel locals macros math math.bitwise math.functions namespaces sequences specialized-arrays -strings summary ; -SPECIALIZED-ARRAY: uint -SPECIALIZED-ARRAY: ushort +specialized-arrays.instances.uint +specialized-arrays.instances.ushort strings summary ; IN: images.bitmap +SINGLETON: bmp-image +"bmp" bmp-image register-image-class + : write2 ( n -- ) 2 >le write ; : write4 ( n -- ) 4 >le write ; -: save-bitmap ( image path -- ) - binary [ - B{ CHAR: B CHAR: M } write - [ - bitmap>> length 14 + 40 + write4 - 0 write4 - 54 write4 - 40 write4 - ] [ - { - ! width height - [ dim>> first2 [ write4 ] bi@ ] +: output-width-and-height ( image -- ) + [ dim>> first write4 ] + [ + [ dim>> second ] [ upside-down?>> ] bi + [ neg ] unless write4 + ] bi ; + +: output-bmp ( image -- ) + B{ CHAR: B CHAR: M } write + [ + bitmap>> length 14 + 40 + write4 + 0 write4 + 54 write4 + 40 write4 + ] [ + { + [ output-width-and-height ] + + ! planes + [ drop 1 write2 ] + + ! bit-count + [ drop 24 write2 ] - ! planes - [ drop 1 write2 ] + ! compression + [ drop 0 write4 ] - ! bit-count - [ drop 24 write2 ] + ! image-size + [ bitmap>> length write4 ] - ! compression - [ drop 0 write4 ] + ! x-pels + [ drop 0 write4 ] - ! image-size - [ bitmap>> length write4 ] + ! y-pels + [ drop 0 write4 ] - ! x-pels - [ drop 0 write4 ] + ! color-used + [ drop 0 write4 ] - ! y-pels - [ drop 0 write4 ] + ! color-important + [ drop 0 write4 ] - ! color-used - [ drop 0 write4 ] + ! color-palette + [ bitmap>> write ] + } cleave + ] bi ; - ! color-important - [ drop 0 write4 ] +M: bmp-image image>stream + drop BGR reorder-components output-bmp ; - ! color-palette - [ bitmap>> write ] - } cleave - ] bi - ] with-file-writer ; diff --git a/basis/images/bitmap/loading/loading.factor b/basis/images/bitmap/loading/loading.factor index 823cfcd03a..50926666f6 100644 --- a/basis/images/bitmap/loading/loading.factor +++ b/basis/images/bitmap/loading/loading.factor @@ -1,17 +1,14 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays byte-arrays combinators +USING: accessors alien.c-types arrays byte-arrays combinators compression.run-length fry grouping images images.loader io io.binary io.encodings.8-bit io.encodings.binary io.encodings.string io.streams.limited kernel math math.bitwise -sequences specialized-arrays summary ; +sequences specialized-arrays summary images.bitmap ; QUALIFIED-WITH: bitstreams b SPECIALIZED-ARRAY: ushort IN: images.bitmap.loading -SINGLETON: bitmap-image -"bmp" bitmap-image register-image-class - ! http://www.fileformat.info/format/bmp/egff.htm ! http://www.digicamsoft.com/bmp/bmp.html @@ -364,7 +361,7 @@ ERROR: unsupported-bitmap-file magic ; : loading-bitmap>bytes ( loading-bitmap -- byte-array ) uncompress-bitmap bitmap>bytes ; -M: bitmap-image stream>image ( stream bitmap-image -- bitmap ) +M: bmp-image stream>image ( stream bmp-image -- bitmap ) drop load-bitmap [ image new ] dip { diff --git a/basis/images/http/authors.txt b/basis/images/http/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/basis/images/http/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/basis/images/http/http.factor b/basis/images/http/http.factor deleted file mode 100644 index 51f8b1ce55..0000000000 --- a/basis/images/http/http.factor +++ /dev/null @@ -1,7 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: http.client images.loader images.loader.private kernel ; -IN: images.http - -: load-http-image ( path -- image ) - [ http-get nip ] [ image-class new ] bi load-image* ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index f0280e46de..6e45dd1ce8 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -11,7 +11,9 @@ IN: images.jpeg QUALIFIED-WITH: bitstreams bs -TUPLE: jpeg-image < image +SINGLETON: jpeg-image + +TUPLE: loading-jpeg < image { headers } { bitstream } { color-info initial: { f f f f } } @@ -24,8 +26,8 @@ TUPLE: jpeg-image < image <PRIVATE -: <jpeg-image> ( headers bitstream -- image ) - jpeg-image new swap >>bitstream swap >>headers ; +: <loading-jpeg> ( headers bitstream -- image ) + loading-jpeg new swap >>bitstream swap >>headers ; SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP APP JPG COM TEM RES ; @@ -357,15 +359,20 @@ SINGLETONS: YUV420 YUV444 Y MAGIC! ; ERROR: not-a-jpeg-image ; -PRIVATE> - -M: jpeg-image stream>image ( stream jpeg-image -- bitmap ) - drop [ - parse-marker { SOI } = [ not-a-jpeg-image ] unless - parse-headers - contents <jpeg-image> - ] with-input-stream +: loading-jpeg>image ( loading-jpeg -- image ) dup jpeg-image [ baseline-parse baseline-decompress ] with-variable ; + +: load-jpeg ( stream -- loading-jpeg ) + [ + parse-marker { SOI } = [ not-a-jpeg-image ] unless + parse-headers + unlimited-input contents <loading-jpeg> + ] with-input-stream ; + +PRIVATE> + +M: jpeg-image stream>image ( stream jpeg-image -- bitmap ) + drop load-jpeg loading-jpeg>image ; diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 8c458b0c9f..8617a8d442 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs byte-arrays combinators images -io.encodings.binary io.pathnames io.streams.byte-array -io.streams.limited kernel namespaces splitting strings -unicode.case ; +io.encodings.binary io.files io.pathnames io.streams.byte-array +io.streams.limited kernel namespaces sequences splitting +strings unicode.case ; IN: images.loader ERROR: unknown-image-extension extension ; @@ -22,6 +22,8 @@ types [ H{ } clone ] initialize PRIVATE> +! Image Decode + GENERIC# load-image* 1 ( obj class -- image ) GENERIC: stream>image ( stream class -- image ) @@ -33,10 +35,22 @@ GENERIC: stream>image ( stream class -- image ) [ open-image-file ] [ image-class ] bi load-image* ; M: byte-array load-image* - [ binary <byte-reader> ] dip stream>image ; + [ + [ binary <byte-reader> ] + [ length stream-throws <limited-stream> ] bi + ] dip stream>image ; M: limited-stream load-image* stream>image ; M: string load-image* [ open-image-file ] dip stream>image ; M: pathname load-image* [ open-image-file ] dip stream>image ; + +! Image Encode + +GENERIC: image>stream ( image class -- ) + +: save-graphic-image ( image path -- ) + [ image-class ] [ ] bi + binary [ image>stream ] with-file-writer ; + diff --git a/basis/images/png/png-tests.factor b/basis/images/png/png-tests.factor index 0effa3c3d1..858718e63f 100755 --- a/basis/images/png/png-tests.factor +++ b/basis/images/png/png-tests.factor @@ -1,7 +1,183 @@ -! Copyright (C) 2009 Doug Coleman. +! Copyright (C) 2009 Doug Coleman, Keith Lazuka ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test images.png ; +USING: images.testing io.directories ; IN: images.png.tests -: png-test-path ( -- path ) - "vocab:images/test-images/rgb.png" ; \ No newline at end of file +! Test files from PngSuite (http://www.libpng.org/pub/png/pngsuite.html) + +! The subset of the suite that should work given the current implementation. +"vocab:images/testing/png" [ + "basn2c08.png" decode-test + "basn6a08.png" decode-test + "f00n2c08.png" decode-test + "f01n2c08.png" decode-test + "f02n2c08.png" decode-test + "f03n2c08.png" decode-test + "f04n2c08.png" decode-test + "z00n2c08.png" decode-test + "z03n2c08.png" decode-test + "z06n2c08.png" decode-test + "z09n2c08.png" decode-test +] with-directory + +! The current PNG decoder implementation is very limited, +! so the entire test suite is not currently enabled. +! "vocab:images/testing/png/suite" [ +! "basi0g01.png" decode-test +! "basi0g02.png" decode-test +! "basi0g04.png" decode-test +! "basi0g08.png" decode-test +! "basi0g16.png" decode-test +! "basi2c08.png" decode-test +! "basi2c16.png" decode-test +! "basi3p01.png" decode-test +! "basi3p02.png" decode-test +! "basi3p04.png" decode-test +! "basi3p08.png" decode-test +! "basi4a08.png" decode-test +! "basi4a16.png" decode-test +! "basi6a08.png" decode-test +! "basi6a16.png" decode-test +! "basn0g01.png" decode-test +! "basn0g02.png" decode-test +! "basn0g04.png" decode-test +! "basn0g08.png" decode-test +! "basn0g16.png" decode-test +! "basn2c08.png" decode-test +! "basn2c16.png" decode-test +! "basn3p01.png" decode-test +! "basn3p02.png" decode-test +! "basn3p04.png" decode-test +! "basn3p08.png" decode-test +! "basn4a08.png" decode-test +! "basn4a16.png" decode-test +! "basn6a08.png" decode-test +! "basn6a16.png" decode-test +! "bgai4a08.png" decode-test +! "bgai4a16.png" decode-test +! "bgan6a08.png" decode-test +! "bgan6a16.png" decode-test +! "bgbn4a08.png" decode-test +! "bggn4a16.png" decode-test +! "bgwn6a08.png" decode-test +! "bgyn6a16.png" decode-test +! "ccwn2c08.png" decode-test +! "ccwn3p08.png" decode-test +! "cdfn2c08.png" decode-test +! "cdhn2c08.png" decode-test +! "cdsn2c08.png" decode-test +! "cdun2c08.png" decode-test +! "ch1n3p04.png" decode-test +! "ch2n3p08.png" decode-test +! "cm0n0g04.png" decode-test +! "cm7n0g04.png" decode-test +! "cm9n0g04.png" decode-test +! "cs3n2c16.png" decode-test +! "cs3n3p08.png" decode-test +! "cs5n2c08.png" decode-test +! "cs5n3p08.png" decode-test +! "cs8n2c08.png" decode-test +! "cs8n3p08.png" decode-test +! "ct0n0g04.png" decode-test +! "ct1n0g04.png" decode-test +! "ctzn0g04.png" decode-test +! "f00n0g08.png" decode-test +! "f00n2c08.png" decode-test +! "f01n0g08.png" decode-test +! "f01n2c08.png" decode-test +! "f02n0g08.png" decode-test +! "f02n2c08.png" decode-test +! "f03n0g08.png" decode-test +! "f03n2c08.png" decode-test +! "f04n0g08.png" decode-test +! "f04n2c08.png" decode-test +! "g03n0g16.png" decode-test +! "g03n2c08.png" decode-test +! "g03n3p04.png" decode-test +! "g04n0g16.png" decode-test +! "g04n2c08.png" decode-test +! "g04n3p04.png" decode-test +! "g05n0g16.png" decode-test +! "g05n2c08.png" decode-test +! "g05n3p04.png" decode-test +! "g07n0g16.png" decode-test +! "g07n2c08.png" decode-test +! "g07n3p04.png" decode-test +! "g10n0g16.png" decode-test +! "g10n2c08.png" decode-test +! "g10n3p04.png" decode-test +! "g25n0g16.png" decode-test +! "g25n2c08.png" decode-test +! "g25n3p04.png" decode-test +! "oi1n0g16.png" decode-test +! "oi1n2c16.png" decode-test +! "oi2n0g16.png" decode-test +! "oi2n2c16.png" decode-test +! "oi4n0g16.png" decode-test +! "oi4n2c16.png" decode-test +! "oi9n0g16.png" decode-test +! "oi9n2c16.png" decode-test +! "pngsuite_logo.png" decode-test +! "pp0n2c16.png" decode-test +! "pp0n6a08.png" decode-test +! "ps1n0g08.png" decode-test +! "ps1n2c16.png" decode-test +! "ps2n0g08.png" decode-test +! "ps2n2c16.png" decode-test +! "s01i3p01.png" decode-test +! "s01n3p01.png" decode-test +! "s02i3p01.png" decode-test +! "s02n3p01.png" decode-test +! "s03i3p01.png" decode-test +! "s03n3p01.png" decode-test +! "s04i3p01.png" decode-test +! "s04n3p01.png" decode-test +! "s05i3p02.png" decode-test +! "s05n3p02.png" decode-test +! "s06i3p02.png" decode-test +! "s06n3p02.png" decode-test +! "s07i3p02.png" decode-test +! "s07n3p02.png" decode-test +! "s08i3p02.png" decode-test +! "s08n3p02.png" decode-test +! "s09i3p02.png" decode-test +! "s09n3p02.png" decode-test +! "s32i3p04.png" decode-test +! "s32n3p04.png" decode-test +! "s33i3p04.png" decode-test +! "s33n3p04.png" decode-test +! "s34i3p04.png" decode-test +! "s34n3p04.png" decode-test +! "s35i3p04.png" decode-test +! "s35n3p04.png" decode-test +! "s36i3p04.png" decode-test +! "s36n3p04.png" decode-test +! "s37i3p04.png" decode-test +! "s37n3p04.png" decode-test +! "s38i3p04.png" decode-test +! "s38n3p04.png" decode-test +! "s39i3p04.png" decode-test +! "s39n3p04.png" decode-test +! "s40i3p04.png" decode-test +! "s40n3p04.png" decode-test +! "tbbn1g04.png" decode-test +! "tbbn2c16.png" decode-test +! "tbbn3p08.png" decode-test +! "tbgn2c16.png" decode-test +! "tbgn3p08.png" decode-test +! "tbrn2c08.png" decode-test +! "tbwn1g16.png" decode-test +! "tbwn3p08.png" decode-test +! "tbyn3p08.png" decode-test +! "tp0n1g08.png" decode-test +! "tp0n2c08.png" decode-test +! "tp0n3p08.png" decode-test +! "tp1n3p08.png" decode-test +! "x00n0g01.png" decode-test +! "xcrn0g04.png" decode-test +! "xlfn0g04.png" decode-test +! "z00n2c08.png" decode-test +! "z03n2c08.png" decode-test +! "z06n2c08.png" decode-test +! "z09n2c08.png" decode-test +! ] with-directory diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index cdb59953f9..cb9a347de1 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors images io io.binary io.encodings.ascii -io.encodings.binary io.encodings.string io.files io.files.info kernel -sequences io.streams.limited fry combinators arrays math checksums -checksums.crc32 compression.inflate grouping byte-arrays images.loader ; +USING: accessors arrays checksums checksums.crc32 combinators +compression.inflate fry grouping images images.loader io +io.binary io.encodings.ascii io.encodings.string kernel locals +math math.bitwise math.ranges sequences sorting assocs +math.functions math.order byte-arrays ; +QUALIFIED-WITH: bitstreams bs IN: images.png SINGLETON: png-image @@ -14,6 +16,28 @@ TUPLE: loading-png width height bit-depth color-type compression-method filter-method interlace-method uncompressed ; +CONSTANT: filter-none 0 +CONSTANT: filter-sub 1 +CONSTANT: filter-up 2 +CONSTANT: filter-average 3 +CONSTANT: filter-paeth 4 + +CONSTANT: greyscale 0 +CONSTANT: truecolor 2 +CONSTANT: indexed-color 3 +CONSTANT: greyscale-alpha 4 +CONSTANT: truecolor-alpha 6 + +CONSTANT: interlace-none 0 +CONSTANT: interlace-adam7 1 + +CONSTANT: starting-row { 0 0 4 0 2 0 1 } +CONSTANT: starting-col { 0 4 0 2 0 1 0 } +CONSTANT: row-increment { 8 8 8 4 4 2 2 } +CONSTANT: col-increment { 8 8 4 4 2 2 1 } +CONSTANT: block-height { 8 8 4 4 2 2 1 } +CONSTANT: block-width { 8 4 4 2 2 1 1 } + : <loading-png> ( -- image ) loading-png new V{ } clone >>chunks ; @@ -42,13 +66,16 @@ ERROR: bad-checksum ; 4 read = [ bad-checksum ] unless 4 cut-slice [ ascii decode >>type ] [ B{ } like >>data ] bi* - [ over chunks>> push ] + [ over chunks>> push ] [ type>> ] bi "IEND" = [ read-png-chunks ] unless ; : find-chunk ( loading-png string -- chunk ) [ chunks>> ] dip '[ type>> _ = ] find nip ; +: find-chunks ( loading-png string -- chunk ) + [ chunks>> ] dip '[ type>> _ = ] filter ; + : parse-ihdr-chunk ( loading-png -- loading-png ) dup "IHDR" find-chunk data>> { [ [ 0 4 ] dip subseq be> >>width ] @@ -61,61 +88,242 @@ ERROR: bad-checksum ; } cleave ; : find-compressed-bytes ( loading-png -- bytes ) - chunks>> [ type>> "IDAT" = ] filter - [ data>> ] map concat ; - - -: zlib-data ( loading-png -- bytes ) - chunks>> [ type>> "IDAT" = ] find nip data>> ; + "IDAT" find-chunks [ data>> ] map concat ; ERROR: unknown-color-type n ; ERROR: unimplemented-color-type image ; : inflate-data ( loading-png -- bytes ) - zlib-data zlib-inflate ; + find-compressed-bytes zlib-inflate ; -: decode-greyscale ( loading-png -- loading-png ) - unimplemented-color-type ; +: png-components-per-pixel ( loading-png -- n ) + color-type>> { + { greyscale [ 1 ] } + { truecolor [ 3 ] } + { greyscale-alpha [ 2 ] } + { indexed-color [ 1 ] } + { truecolor-alpha [ 4 ] } + [ unknown-color-type ] + } case ; inline -: png-image-bytes ( loading-png -- byte-array ) - [ inflate-data ] [ width>> 3 * 1 + ] bi group - reverse-png-filter ; +: png-group-width ( loading-png -- n ) + ! 1 + is for the filter type, 1 byte preceding each line + [ [ png-components-per-pixel ] [ bit-depth>> ] bi * ] + [ width>> ] bi * 1 + ; -: decode-truecolor ( loading-png -- loading-png ) - [ <image> ] dip { - [ png-image-bytes >>bitmap ] - [ [ width>> ] [ height>> ] bi 2array >>dim ] - [ drop RGB >>component-order ubyte-components >>component-type ] - } cleave ; - -: decode-indexed-color ( loading-png -- loading-png ) - unimplemented-color-type ; +:: paeth ( a b c -- p ) + a b + c - { a b c } [ [ - abs ] keep 2array ] with map + sort-keys first second ; -: decode-greyscale-alpha ( loading-png -- loading-png ) - unimplemented-color-type ; +:: png-unfilter-line ( width prev curr filter -- curr' ) + prev :> c + prev width tail-slice :> b + curr :> a + curr width tail-slice :> x + x length [0,b) + filter { + { filter-none [ drop ] } + { filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] } + { filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] } + { filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] } + { filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] } + } case + curr width tail ; -: decode-truecolor-alpha ( loading-png -- loading-png ) - [ <image> ] dip { - [ png-image-bytes >>bitmap ] - [ [ width>> ] [ height>> ] bi 2array >>dim ] - [ drop RGBA >>component-order ubyte-components >>component-type ] - } cleave ; +:: reverse-png-filter ( lines n -- byte-array ) + lines dup first length 0 <array> prefix + [ n 1 - 0 <array> prepend ] map + 2 clump [ + n swap first2 + [ ] + [ n 1 - swap nth ] + [ [ 0 n 1 - ] dip set-nth ] tri + png-unfilter-line + ] map B{ } concat-as ; + +:: visit ( row col height width pixel image -- ) + row image nth :> irow + pixel col irow set-nth ; + +ERROR: bad-filter n ; + +:: reverse-interlace-none ( byte-array loading-png -- array ) + byte-array bs:<msb0-bit-reader> :> bs + loading-png width>> :> width + loading-png height>> :> height + loading-png png-components-per-pixel :> #components + loading-png bit-depth>> :> bit-depth + bit-depth :> depth! + #components width * :> count! + + ! Only read up to 8 bits at a time + bit-depth 16 = [ + 8 depth! + count 2 * count! + ] when + + height [ + 8 bs bs:read dup 0 4 between? [ bad-filter ] unless + count [ depth bs bs:read ] replicate swap prefix + 8 bs bs:align + ] replicate + #components bit-depth 16 = [ 2 * ] when reverse-png-filter ; + +:: reverse-interlace-adam7 ( byte-array loading-png -- byte-array ) + byte-array bs:<msb0-bit-reader> :> bs + loading-png height>> :> height + loading-png width>> :> width + loading-png bit-depth>> :> bit-depth + loading-png png-components-per-pixel :> #bytes + width height #bytes * * <byte-array> width <sliced-groups> :> image + + 0 :> row! + 0 :> col! + + 0 :> pass! + [ pass 7 < ] [ + pass starting-row nth row! + [ + row height < + ] [ + pass starting-col nth col! + [ + col width < + ] [ + row + col + + pass block-height nth + height row - min + + pass block-width nth + width col - min + + bit-depth bs bs:read + image + visit + + col pass col-increment nth + col! + ] while + row pass row-increment nth + row! + ] while + pass 1 + pass! + ] while + bit-depth 16 = [ + image { } concat-as + [ 2 >be ] map B{ } concat-as + ] [ + image B{ } concat-as + ] if ; + +ERROR: unimplemented-interlace ; + +: uncompress-bytes ( loading-png -- bitstream ) + [ inflate-data ] [ ] [ interlace-method>> ] tri { + { interlace-none [ reverse-interlace-none ] } + { interlace-adam7 [ "adam7 is broken" throw reverse-interlace-adam7 ] } + [ unimplemented-interlace ] + } case ; + +ERROR: unknown-component-type n ; + +: png-component ( loading-png -- obj ) + bit-depth>> { + { 1 [ ubyte-components ] } + { 2 [ ubyte-components ] } + { 4 [ ubyte-components ] } + { 8 [ ubyte-components ] } + { 16 [ ushort-components ] } + [ unknown-component-type ] + } case ; + +: scale-factor ( n -- n' ) + { + { 1 [ 255 ] } + { 2 [ 127 ] } + { 4 [ 17 ] } + } case ; + +: scale-greyscale ( byte-array loading-png -- byte-array' ) + bit-depth>> { + { 8 [ ] } + { 16 [ 2 group [ swap ] assoc-map B{ } concat-as ] } + [ scale-factor '[ _ * ] B{ } map-as ] + } case ; + +: decode-greyscale ( loading-png -- byte-array ) + [ uncompress-bytes ] keep scale-greyscale ; + +: decode-greyscale-alpha ( loading-image -- byte-array ) + [ uncompress-bytes ] [ bit-depth>> ] bi 16 = [ + 4 group [ first4 [ swap ] 2dip 4array ] map B{ } concat-as + ] when ; + +ERROR: invalid-PLTE array ; + +: verify-PLTE ( seq -- seq ) + dup length 3 divisor? [ invalid-PLTE ] unless ; + +: decode-indexed-color ( loading-image -- byte-array ) + [ uncompress-bytes ] keep + "PLTE" find-chunk data>> verify-PLTE + 3 group '[ _ nth ] { } map-as B{ } concat-as ; -: decode-png ( loading-png -- loading-png ) +ERROR: invalid-color-type/bit-depth loading-png ; + +: validate-bit-depth ( loading-png seq -- loading-png ) + [ dup bit-depth>> ] dip member? + [ invalid-color-type/bit-depth ] unless ; + +: validate-greyscale ( loading-png -- loading-png ) + { 1 2 4 8 16 } validate-bit-depth ; + +: validate-truecolor ( loading-png -- loading-png ) + { 8 16 } validate-bit-depth ; + +: validate-indexed-color ( loading-png -- loading-png ) + { 1 2 4 8 } validate-bit-depth ; + +: validate-greyscale-alpha ( loading-png -- loading-png ) + { 8 16 } validate-bit-depth ; + +: validate-truecolor-alpha ( loading-png -- loading-png ) + { 8 16 } validate-bit-depth ; + +: loading-png>bitmap ( loading-png -- bytes component-order ) dup color-type>> { - { 0 [ decode-greyscale ] } - { 2 [ decode-truecolor ] } - { 3 [ decode-indexed-color ] } - { 4 [ decode-greyscale-alpha ] } - { 6 [ decode-truecolor-alpha ] } + { greyscale [ + validate-greyscale decode-greyscale L + ] } + { truecolor [ + validate-truecolor uncompress-bytes RGB + ] } + { indexed-color [ + validate-indexed-color decode-indexed-color RGB + ] } + { greyscale-alpha [ + validate-greyscale-alpha decode-greyscale-alpha LA + ] } + { truecolor-alpha [ + validate-truecolor-alpha uncompress-bytes RGBA + ] } [ unknown-color-type ] } case ; -M: png-image stream>image - drop [ +: loading-png>image ( loading-png -- image ) + [ image new ] dip { + [ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ] + [ [ width>> ] [ height>> ] bi 2array >>dim ] + [ png-component >>component-type ] + } cleave ; + +: load-png ( stream -- loading-png ) + [ <loading-png> read-png-header read-png-chunks parse-ihdr-chunk - decode-png ] with-input-stream ; + +M: png-image stream>image + drop load-png loading-png>image ; diff --git a/basis/images/test-images/1bit.bmp b/basis/images/test-images/1bit.bmp deleted file mode 100644 index 2f244c1d05..0000000000 Binary files a/basis/images/test-images/1bit.bmp and /dev/null differ diff --git a/basis/images/test-images/40red24bit.bmp b/basis/images/test-images/40red24bit.bmp deleted file mode 100644 index 5e694559c6..0000000000 Binary files a/basis/images/test-images/40red24bit.bmp and /dev/null differ diff --git a/basis/images/test-images/41red24bit.bmp b/basis/images/test-images/41red24bit.bmp deleted file mode 100644 index 6599dcc107..0000000000 Binary files a/basis/images/test-images/41red24bit.bmp and /dev/null differ diff --git a/basis/images/test-images/42red24bit.bmp b/basis/images/test-images/42red24bit.bmp deleted file mode 100644 index e95a4f75f5..0000000000 Binary files a/basis/images/test-images/42red24bit.bmp and /dev/null differ diff --git a/basis/images/test-images/43red24bit.bmp b/basis/images/test-images/43red24bit.bmp deleted file mode 100644 index d88f2d4c32..0000000000 Binary files a/basis/images/test-images/43red24bit.bmp and /dev/null differ diff --git a/basis/images/test-images/elephants.tiff b/basis/images/test-images/elephants.tiff deleted file mode 100644 index f462a0c043..0000000000 Binary files a/basis/images/test-images/elephants.tiff and /dev/null differ diff --git a/basis/images/test-images/octagon.tiff b/basis/images/test-images/octagon.tiff deleted file mode 100644 index 2b4ba3950d..0000000000 Binary files a/basis/images/test-images/octagon.tiff and /dev/null differ diff --git a/basis/images/test-images/rgb.png b/basis/images/test-images/rgb.png deleted file mode 100755 index d34914a5ec..0000000000 Binary files a/basis/images/test-images/rgb.png and /dev/null differ diff --git a/basis/images/test-images/rgb.tiff b/basis/images/test-images/rgb.tiff deleted file mode 100755 index 71cbaa9d6e..0000000000 Binary files a/basis/images/test-images/rgb.tiff and /dev/null differ diff --git a/basis/images/test-images/rgb4bit.bmp b/basis/images/test-images/rgb4bit.bmp deleted file mode 100644 index 0c6f00d06c..0000000000 Binary files a/basis/images/test-images/rgb4bit.bmp and /dev/null differ diff --git a/basis/images/test-images/rgb8bit.bmp b/basis/images/test-images/rgb8bit.bmp deleted file mode 100644 index bc95c0f94e..0000000000 Binary files a/basis/images/test-images/rgb8bit.bmp and /dev/null differ diff --git a/basis/images/test-images/thiswayup24.bmp b/basis/images/test-images/thiswayup24.bmp deleted file mode 100644 index 202fb15371..0000000000 Binary files a/basis/images/test-images/thiswayup24.bmp and /dev/null differ diff --git a/basis/images/testing/bmp/1bit.bmp b/basis/images/testing/bmp/1bit.bmp new file mode 100644 index 0000000000..2f244c1d05 Binary files /dev/null and b/basis/images/testing/bmp/1bit.bmp differ diff --git a/basis/images/testing/bmp/42red_24bit.bmp b/basis/images/testing/bmp/42red_24bit.bmp new file mode 100644 index 0000000000..e95a4f75f5 Binary files /dev/null and b/basis/images/testing/bmp/42red_24bit.bmp differ diff --git a/basis/images/testing/bmp/42red_24bit.fig b/basis/images/testing/bmp/42red_24bit.fig new file mode 100644 index 0000000000..9c2ce17edb Binary files /dev/null and b/basis/images/testing/bmp/42red_24bit.fig differ diff --git a/basis/images/testing/bmp/rgb_4bit.bmp b/basis/images/testing/bmp/rgb_4bit.bmp new file mode 100644 index 0000000000..0c6f00d06c Binary files /dev/null and b/basis/images/testing/bmp/rgb_4bit.bmp differ diff --git a/basis/images/testing/bmp/rgb_8bit.bmp b/basis/images/testing/bmp/rgb_8bit.bmp new file mode 100644 index 0000000000..bc95c0f94e Binary files /dev/null and b/basis/images/testing/bmp/rgb_8bit.bmp differ diff --git a/basis/images/testing/bmp/rgb_8bit.fig b/basis/images/testing/bmp/rgb_8bit.fig new file mode 100644 index 0000000000..4b75a10dc0 Binary files /dev/null and b/basis/images/testing/bmp/rgb_8bit.fig differ diff --git a/basis/images/testing/gif/alpha.fig b/basis/images/testing/gif/alpha.fig new file mode 100644 index 0000000000..b36a8f6666 Binary files /dev/null and b/basis/images/testing/gif/alpha.fig differ diff --git a/basis/images/testing/gif/alpha.gif b/basis/images/testing/gif/alpha.gif new file mode 100644 index 0000000000..c4c38bdaf0 Binary files /dev/null and b/basis/images/testing/gif/alpha.gif differ diff --git a/basis/images/testing/gif/astronaut_animation.fig b/basis/images/testing/gif/astronaut_animation.fig new file mode 100644 index 0000000000..905da6d827 Binary files /dev/null and b/basis/images/testing/gif/astronaut_animation.fig differ diff --git a/basis/images/testing/gif/astronaut_animation.gif b/basis/images/testing/gif/astronaut_animation.gif new file mode 100644 index 0000000000..8c768480fe Binary files /dev/null and b/basis/images/testing/gif/astronaut_animation.gif differ diff --git a/basis/images/testing/gif/checkmark.fig b/basis/images/testing/gif/checkmark.fig new file mode 100644 index 0000000000..c177d89250 Binary files /dev/null and b/basis/images/testing/gif/checkmark.fig differ diff --git a/basis/images/testing/gif/checkmark.gif b/basis/images/testing/gif/checkmark.gif new file mode 100644 index 0000000000..df83efaf55 Binary files /dev/null and b/basis/images/testing/gif/checkmark.gif differ diff --git a/basis/images/testing/gif/circle.fig b/basis/images/testing/gif/circle.fig new file mode 100644 index 0000000000..330397f7d7 Binary files /dev/null and b/basis/images/testing/gif/circle.fig differ diff --git a/basis/images/testing/gif/circle.gif b/basis/images/testing/gif/circle.gif new file mode 100644 index 0000000000..101a48a880 Binary files /dev/null and b/basis/images/testing/gif/circle.gif differ diff --git a/basis/images/testing/gif/monochrome.fig b/basis/images/testing/gif/monochrome.fig new file mode 100644 index 0000000000..69de84564e Binary files /dev/null and b/basis/images/testing/gif/monochrome.fig differ diff --git a/basis/images/testing/gif/monochrome.gif b/basis/images/testing/gif/monochrome.gif new file mode 100644 index 0000000000..b0875faa61 Binary files /dev/null and b/basis/images/testing/gif/monochrome.gif differ diff --git a/basis/images/testing/gif/noise.fig b/basis/images/testing/gif/noise.fig new file mode 100644 index 0000000000..a2650e971f Binary files /dev/null and b/basis/images/testing/gif/noise.fig differ diff --git a/basis/images/testing/gif/noise.gif b/basis/images/testing/gif/noise.gif new file mode 100644 index 0000000000..31dffae42b Binary files /dev/null and b/basis/images/testing/gif/noise.gif differ diff --git a/basis/images/testing/png/basn2c08.fig b/basis/images/testing/png/basn2c08.fig new file mode 100644 index 0000000000..84f8c97b93 Binary files /dev/null and b/basis/images/testing/png/basn2c08.fig differ diff --git a/basis/images/testing/png/basn2c08.png b/basis/images/testing/png/basn2c08.png new file mode 100644 index 0000000000..db5ad15865 Binary files /dev/null and b/basis/images/testing/png/basn2c08.png differ diff --git a/basis/images/testing/png/basn6a08.fig b/basis/images/testing/png/basn6a08.fig new file mode 100644 index 0000000000..f188879876 Binary files /dev/null and b/basis/images/testing/png/basn6a08.fig differ diff --git a/basis/images/testing/png/basn6a08.png b/basis/images/testing/png/basn6a08.png new file mode 100644 index 0000000000..e608738763 Binary files /dev/null and b/basis/images/testing/png/basn6a08.png differ diff --git a/basis/images/testing/png/f00n2c08.fig b/basis/images/testing/png/f00n2c08.fig new file mode 100644 index 0000000000..6a6aef9b0f Binary files /dev/null and b/basis/images/testing/png/f00n2c08.fig differ diff --git a/basis/images/testing/png/f00n2c08.png b/basis/images/testing/png/f00n2c08.png new file mode 100644 index 0000000000..d6a1ffff62 Binary files /dev/null and b/basis/images/testing/png/f00n2c08.png differ diff --git a/basis/images/testing/png/f01n2c08.fig b/basis/images/testing/png/f01n2c08.fig new file mode 100644 index 0000000000..f08c0bbee3 Binary files /dev/null and b/basis/images/testing/png/f01n2c08.fig differ diff --git a/basis/images/testing/png/f01n2c08.png b/basis/images/testing/png/f01n2c08.png new file mode 100644 index 0000000000..26fee958ce Binary files /dev/null and b/basis/images/testing/png/f01n2c08.png differ diff --git a/basis/images/testing/png/f02n2c08.fig b/basis/images/testing/png/f02n2c08.fig new file mode 100644 index 0000000000..722f02a5ff Binary files /dev/null and b/basis/images/testing/png/f02n2c08.fig differ diff --git a/basis/images/testing/png/f02n2c08.png b/basis/images/testing/png/f02n2c08.png new file mode 100644 index 0000000000..e590f12348 Binary files /dev/null and b/basis/images/testing/png/f02n2c08.png differ diff --git a/basis/images/testing/png/f03n2c08.fig b/basis/images/testing/png/f03n2c08.fig new file mode 100644 index 0000000000..2a37fe6c7b Binary files /dev/null and b/basis/images/testing/png/f03n2c08.fig differ diff --git a/basis/images/testing/png/f03n2c08.png b/basis/images/testing/png/f03n2c08.png new file mode 100644 index 0000000000..758115059d Binary files /dev/null and b/basis/images/testing/png/f03n2c08.png differ diff --git a/basis/images/testing/png/f04n2c08.fig b/basis/images/testing/png/f04n2c08.fig new file mode 100644 index 0000000000..c0db771fa4 Binary files /dev/null and b/basis/images/testing/png/f04n2c08.fig differ diff --git a/basis/images/testing/png/f04n2c08.png b/basis/images/testing/png/f04n2c08.png new file mode 100644 index 0000000000..3c8b5116e7 Binary files /dev/null and b/basis/images/testing/png/f04n2c08.png differ diff --git a/basis/images/testing/png/suite/basi0g01.png b/basis/images/testing/png/suite/basi0g01.png new file mode 100644 index 0000000000..556fa72704 Binary files /dev/null and b/basis/images/testing/png/suite/basi0g01.png differ diff --git a/basis/images/testing/png/suite/basi0g02.png b/basis/images/testing/png/suite/basi0g02.png new file mode 100644 index 0000000000..ce09821ef1 Binary files /dev/null and b/basis/images/testing/png/suite/basi0g02.png differ diff --git a/basis/images/testing/png/suite/basi0g04.png b/basis/images/testing/png/suite/basi0g04.png new file mode 100644 index 0000000000..3853273f93 Binary files /dev/null and b/basis/images/testing/png/suite/basi0g04.png differ diff --git a/basis/images/testing/png/suite/basi0g08.png b/basis/images/testing/png/suite/basi0g08.png new file mode 100644 index 0000000000..faed8bec44 Binary files /dev/null and b/basis/images/testing/png/suite/basi0g08.png differ diff --git a/basis/images/testing/png/suite/basi0g16.png b/basis/images/testing/png/suite/basi0g16.png new file mode 100644 index 0000000000..a9f28165ef Binary files /dev/null and b/basis/images/testing/png/suite/basi0g16.png differ diff --git a/basis/images/testing/png/suite/basi2c08.png b/basis/images/testing/png/suite/basi2c08.png new file mode 100644 index 0000000000..2aab44d42b Binary files /dev/null and b/basis/images/testing/png/suite/basi2c08.png differ diff --git a/basis/images/testing/png/suite/basi2c16.png b/basis/images/testing/png/suite/basi2c16.png new file mode 100644 index 0000000000..cd7e50f914 Binary files /dev/null and b/basis/images/testing/png/suite/basi2c16.png differ diff --git a/basis/images/testing/png/suite/basi3p01.png b/basis/images/testing/png/suite/basi3p01.png new file mode 100644 index 0000000000..00a7cea6c2 Binary files /dev/null and b/basis/images/testing/png/suite/basi3p01.png differ diff --git a/basis/images/testing/png/suite/basi3p02.png b/basis/images/testing/png/suite/basi3p02.png new file mode 100644 index 0000000000..bb16b44b30 Binary files /dev/null and b/basis/images/testing/png/suite/basi3p02.png differ diff --git a/basis/images/testing/png/suite/basi3p04.png b/basis/images/testing/png/suite/basi3p04.png new file mode 100644 index 0000000000..b4e888e247 Binary files /dev/null and b/basis/images/testing/png/suite/basi3p04.png differ diff --git a/basis/images/testing/png/suite/basi3p08.png b/basis/images/testing/png/suite/basi3p08.png new file mode 100644 index 0000000000..50a6d1cac7 Binary files /dev/null and b/basis/images/testing/png/suite/basi3p08.png differ diff --git a/basis/images/testing/png/suite/basi4a08.png b/basis/images/testing/png/suite/basi4a08.png new file mode 100644 index 0000000000..398132be5f Binary files /dev/null and b/basis/images/testing/png/suite/basi4a08.png differ diff --git a/basis/images/testing/png/suite/basi4a16.png b/basis/images/testing/png/suite/basi4a16.png new file mode 100644 index 0000000000..51192e7311 Binary files /dev/null and b/basis/images/testing/png/suite/basi4a16.png differ diff --git a/basis/images/testing/png/suite/basi6a08.png b/basis/images/testing/png/suite/basi6a08.png new file mode 100644 index 0000000000..aecb32e0d9 Binary files /dev/null and b/basis/images/testing/png/suite/basi6a08.png differ diff --git a/basis/images/testing/png/suite/basi6a16.png b/basis/images/testing/png/suite/basi6a16.png new file mode 100644 index 0000000000..4181533ad8 Binary files /dev/null and b/basis/images/testing/png/suite/basi6a16.png differ diff --git a/basis/images/testing/png/suite/basn0g01.png b/basis/images/testing/png/suite/basn0g01.png new file mode 100644 index 0000000000..1d722423aa Binary files /dev/null and b/basis/images/testing/png/suite/basn0g01.png differ diff --git a/basis/images/testing/png/suite/basn0g02.png b/basis/images/testing/png/suite/basn0g02.png new file mode 100644 index 0000000000..508332418f Binary files /dev/null and b/basis/images/testing/png/suite/basn0g02.png differ diff --git a/basis/images/testing/png/suite/basn0g04.png b/basis/images/testing/png/suite/basn0g04.png new file mode 100644 index 0000000000..0bf3687863 Binary files /dev/null and b/basis/images/testing/png/suite/basn0g04.png differ diff --git a/basis/images/testing/png/suite/basn0g08.png b/basis/images/testing/png/suite/basn0g08.png new file mode 100644 index 0000000000..23c82379a2 Binary files /dev/null and b/basis/images/testing/png/suite/basn0g08.png differ diff --git a/basis/images/testing/png/suite/basn0g16.png b/basis/images/testing/png/suite/basn0g16.png new file mode 100644 index 0000000000..e7c82f78eb Binary files /dev/null and b/basis/images/testing/png/suite/basn0g16.png differ diff --git a/basis/images/testing/png/suite/basn2c08.png b/basis/images/testing/png/suite/basn2c08.png new file mode 100644 index 0000000000..db5ad15865 Binary files /dev/null and b/basis/images/testing/png/suite/basn2c08.png differ diff --git a/basis/images/testing/png/suite/basn2c16.png b/basis/images/testing/png/suite/basn2c16.png new file mode 100644 index 0000000000..50c1cb91a0 Binary files /dev/null and b/basis/images/testing/png/suite/basn2c16.png differ diff --git a/basis/images/testing/png/suite/basn3p01.png b/basis/images/testing/png/suite/basn3p01.png new file mode 100644 index 0000000000..b145c2b8ef Binary files /dev/null and b/basis/images/testing/png/suite/basn3p01.png differ diff --git a/basis/images/testing/png/suite/basn3p02.png b/basis/images/testing/png/suite/basn3p02.png new file mode 100644 index 0000000000..8985b3d818 Binary files /dev/null and b/basis/images/testing/png/suite/basn3p02.png differ diff --git a/basis/images/testing/png/suite/basn3p04.png b/basis/images/testing/png/suite/basn3p04.png new file mode 100644 index 0000000000..0fbf9e827b Binary files /dev/null and b/basis/images/testing/png/suite/basn3p04.png differ diff --git a/basis/images/testing/png/suite/basn3p08.png b/basis/images/testing/png/suite/basn3p08.png new file mode 100644 index 0000000000..0ddad07e5f Binary files /dev/null and b/basis/images/testing/png/suite/basn3p08.png differ diff --git a/basis/images/testing/png/suite/basn4a08.png b/basis/images/testing/png/suite/basn4a08.png new file mode 100644 index 0000000000..3e13052201 Binary files /dev/null and b/basis/images/testing/png/suite/basn4a08.png differ diff --git a/basis/images/testing/png/suite/basn4a16.png b/basis/images/testing/png/suite/basn4a16.png new file mode 100644 index 0000000000..8243644d07 Binary files /dev/null and b/basis/images/testing/png/suite/basn4a16.png differ diff --git a/basis/images/testing/png/suite/basn6a08.png b/basis/images/testing/png/suite/basn6a08.png new file mode 100644 index 0000000000..e608738763 Binary files /dev/null and b/basis/images/testing/png/suite/basn6a08.png differ diff --git a/basis/images/testing/png/suite/basn6a16.png b/basis/images/testing/png/suite/basn6a16.png new file mode 100644 index 0000000000..984a99525f Binary files /dev/null and b/basis/images/testing/png/suite/basn6a16.png differ diff --git a/basis/images/testing/png/suite/bgai4a08.png b/basis/images/testing/png/suite/bgai4a08.png new file mode 100644 index 0000000000..398132be5f Binary files /dev/null and b/basis/images/testing/png/suite/bgai4a08.png differ diff --git a/basis/images/testing/png/suite/bgai4a16.png b/basis/images/testing/png/suite/bgai4a16.png new file mode 100644 index 0000000000..51192e7311 Binary files /dev/null and b/basis/images/testing/png/suite/bgai4a16.png differ diff --git a/basis/images/testing/png/suite/bgan6a08.png b/basis/images/testing/png/suite/bgan6a08.png new file mode 100644 index 0000000000..e608738763 Binary files /dev/null and b/basis/images/testing/png/suite/bgan6a08.png differ diff --git a/basis/images/testing/png/suite/bgan6a16.png b/basis/images/testing/png/suite/bgan6a16.png new file mode 100644 index 0000000000..984a99525f Binary files /dev/null and b/basis/images/testing/png/suite/bgan6a16.png differ diff --git a/basis/images/testing/png/suite/bgbn4a08.png b/basis/images/testing/png/suite/bgbn4a08.png new file mode 100644 index 0000000000..7cbefc3bff Binary files /dev/null and b/basis/images/testing/png/suite/bgbn4a08.png differ diff --git a/basis/images/testing/png/suite/bggn4a16.png b/basis/images/testing/png/suite/bggn4a16.png new file mode 100644 index 0000000000..13fd85ba19 Binary files /dev/null and b/basis/images/testing/png/suite/bggn4a16.png differ diff --git a/basis/images/testing/png/suite/bgwn6a08.png b/basis/images/testing/png/suite/bgwn6a08.png new file mode 100644 index 0000000000..a67ff205bb Binary files /dev/null and b/basis/images/testing/png/suite/bgwn6a08.png differ diff --git a/basis/images/testing/png/suite/bgyn6a16.png b/basis/images/testing/png/suite/bgyn6a16.png new file mode 100644 index 0000000000..ae3e9be58a Binary files /dev/null and b/basis/images/testing/png/suite/bgyn6a16.png differ diff --git a/basis/images/testing/png/suite/ccwn2c08.png b/basis/images/testing/png/suite/ccwn2c08.png new file mode 100644 index 0000000000..47c24817b7 Binary files /dev/null and b/basis/images/testing/png/suite/ccwn2c08.png differ diff --git a/basis/images/testing/png/suite/ccwn3p08.png b/basis/images/testing/png/suite/ccwn3p08.png new file mode 100644 index 0000000000..8bb2c10981 Binary files /dev/null and b/basis/images/testing/png/suite/ccwn3p08.png differ diff --git a/basis/images/testing/png/suite/cdfn2c08.png b/basis/images/testing/png/suite/cdfn2c08.png new file mode 100644 index 0000000000..559e5261e7 Binary files /dev/null and b/basis/images/testing/png/suite/cdfn2c08.png differ diff --git a/basis/images/testing/png/suite/cdhn2c08.png b/basis/images/testing/png/suite/cdhn2c08.png new file mode 100644 index 0000000000..3e07e8ecbd Binary files /dev/null and b/basis/images/testing/png/suite/cdhn2c08.png differ diff --git a/basis/images/testing/png/suite/cdsn2c08.png b/basis/images/testing/png/suite/cdsn2c08.png new file mode 100644 index 0000000000..076c32cc08 Binary files /dev/null and b/basis/images/testing/png/suite/cdsn2c08.png differ diff --git a/basis/images/testing/png/suite/cdun2c08.png b/basis/images/testing/png/suite/cdun2c08.png new file mode 100644 index 0000000000..846033be6b Binary files /dev/null and b/basis/images/testing/png/suite/cdun2c08.png differ diff --git a/basis/images/testing/png/suite/ch1n3p04.png b/basis/images/testing/png/suite/ch1n3p04.png new file mode 100644 index 0000000000..17cd12dfc9 Binary files /dev/null and b/basis/images/testing/png/suite/ch1n3p04.png differ diff --git a/basis/images/testing/png/suite/ch2n3p08.png b/basis/images/testing/png/suite/ch2n3p08.png new file mode 100644 index 0000000000..25c17987a7 Binary files /dev/null and b/basis/images/testing/png/suite/ch2n3p08.png differ diff --git a/basis/images/testing/png/suite/cm0n0g04.png b/basis/images/testing/png/suite/cm0n0g04.png new file mode 100644 index 0000000000..9fba5db3b8 Binary files /dev/null and b/basis/images/testing/png/suite/cm0n0g04.png differ diff --git a/basis/images/testing/png/suite/cm7n0g04.png b/basis/images/testing/png/suite/cm7n0g04.png new file mode 100644 index 0000000000..f7dc46e685 Binary files /dev/null and b/basis/images/testing/png/suite/cm7n0g04.png differ diff --git a/basis/images/testing/png/suite/cm9n0g04.png b/basis/images/testing/png/suite/cm9n0g04.png new file mode 100644 index 0000000000..dd70911adc Binary files /dev/null and b/basis/images/testing/png/suite/cm9n0g04.png differ diff --git a/basis/images/testing/png/suite/cs3n2c16.png b/basis/images/testing/png/suite/cs3n2c16.png new file mode 100644 index 0000000000..bf5fd20a20 Binary files /dev/null and b/basis/images/testing/png/suite/cs3n2c16.png differ diff --git a/basis/images/testing/png/suite/cs3n3p08.png b/basis/images/testing/png/suite/cs3n3p08.png new file mode 100644 index 0000000000..f4a66237bf Binary files /dev/null and b/basis/images/testing/png/suite/cs3n3p08.png differ diff --git a/basis/images/testing/png/suite/cs5n2c08.png b/basis/images/testing/png/suite/cs5n2c08.png new file mode 100644 index 0000000000..40f947c33e Binary files /dev/null and b/basis/images/testing/png/suite/cs5n2c08.png differ diff --git a/basis/images/testing/png/suite/cs5n3p08.png b/basis/images/testing/png/suite/cs5n3p08.png new file mode 100644 index 0000000000..dfd6e6e6ec Binary files /dev/null and b/basis/images/testing/png/suite/cs5n3p08.png differ diff --git a/basis/images/testing/png/suite/cs8n2c08.png b/basis/images/testing/png/suite/cs8n2c08.png new file mode 100644 index 0000000000..8e01d3294f Binary files /dev/null and b/basis/images/testing/png/suite/cs8n2c08.png differ diff --git a/basis/images/testing/png/suite/cs8n3p08.png b/basis/images/testing/png/suite/cs8n3p08.png new file mode 100644 index 0000000000..a44066eb6e Binary files /dev/null and b/basis/images/testing/png/suite/cs8n3p08.png differ diff --git a/basis/images/testing/png/suite/ct0n0g04.png b/basis/images/testing/png/suite/ct0n0g04.png new file mode 100644 index 0000000000..40d1e062f8 Binary files /dev/null and b/basis/images/testing/png/suite/ct0n0g04.png differ diff --git a/basis/images/testing/png/suite/ct1n0g04.png b/basis/images/testing/png/suite/ct1n0g04.png new file mode 100644 index 0000000000..3ba110aa76 Binary files /dev/null and b/basis/images/testing/png/suite/ct1n0g04.png differ diff --git a/basis/images/testing/png/suite/ctzn0g04.png b/basis/images/testing/png/suite/ctzn0g04.png new file mode 100644 index 0000000000..b4401c9cfc Binary files /dev/null and b/basis/images/testing/png/suite/ctzn0g04.png differ diff --git a/basis/images/testing/png/suite/f00n0g08.png b/basis/images/testing/png/suite/f00n0g08.png new file mode 100644 index 0000000000..45a0075967 Binary files /dev/null and b/basis/images/testing/png/suite/f00n0g08.png differ diff --git a/basis/images/testing/png/suite/f00n2c08.png b/basis/images/testing/png/suite/f00n2c08.png new file mode 100644 index 0000000000..d6a1ffff62 Binary files /dev/null and b/basis/images/testing/png/suite/f00n2c08.png differ diff --git a/basis/images/testing/png/suite/f01n0g08.png b/basis/images/testing/png/suite/f01n0g08.png new file mode 100644 index 0000000000..4a1107b463 Binary files /dev/null and b/basis/images/testing/png/suite/f01n0g08.png differ diff --git a/basis/images/testing/png/suite/f01n2c08.png b/basis/images/testing/png/suite/f01n2c08.png new file mode 100644 index 0000000000..26fee958ce Binary files /dev/null and b/basis/images/testing/png/suite/f01n2c08.png differ diff --git a/basis/images/testing/png/suite/f02n0g08.png b/basis/images/testing/png/suite/f02n0g08.png new file mode 100644 index 0000000000..bfe410c5e7 Binary files /dev/null and b/basis/images/testing/png/suite/f02n0g08.png differ diff --git a/basis/images/testing/png/suite/f02n2c08.png b/basis/images/testing/png/suite/f02n2c08.png new file mode 100644 index 0000000000..e590f12348 Binary files /dev/null and b/basis/images/testing/png/suite/f02n2c08.png differ diff --git a/basis/images/testing/png/suite/f03n0g08.png b/basis/images/testing/png/suite/f03n0g08.png new file mode 100644 index 0000000000..ed01e2923c Binary files /dev/null and b/basis/images/testing/png/suite/f03n0g08.png differ diff --git a/basis/images/testing/png/suite/f03n2c08.png b/basis/images/testing/png/suite/f03n2c08.png new file mode 100644 index 0000000000..758115059d Binary files /dev/null and b/basis/images/testing/png/suite/f03n2c08.png differ diff --git a/basis/images/testing/png/suite/f04n0g08.png b/basis/images/testing/png/suite/f04n0g08.png new file mode 100644 index 0000000000..663fdae3e7 Binary files /dev/null and b/basis/images/testing/png/suite/f04n0g08.png differ diff --git a/basis/images/testing/png/suite/f04n2c08.png b/basis/images/testing/png/suite/f04n2c08.png new file mode 100644 index 0000000000..3c8b5116e7 Binary files /dev/null and b/basis/images/testing/png/suite/f04n2c08.png differ diff --git a/basis/images/testing/png/suite/g03n0g16.png b/basis/images/testing/png/suite/g03n0g16.png new file mode 100644 index 0000000000..41083ca80f Binary files /dev/null and b/basis/images/testing/png/suite/g03n0g16.png differ diff --git a/basis/images/testing/png/suite/g03n2c08.png b/basis/images/testing/png/suite/g03n2c08.png new file mode 100644 index 0000000000..a9354dbee6 Binary files /dev/null and b/basis/images/testing/png/suite/g03n2c08.png differ diff --git a/basis/images/testing/png/suite/g03n3p04.png b/basis/images/testing/png/suite/g03n3p04.png new file mode 100644 index 0000000000..60396c95af Binary files /dev/null and b/basis/images/testing/png/suite/g03n3p04.png differ diff --git a/basis/images/testing/png/suite/g04n0g16.png b/basis/images/testing/png/suite/g04n0g16.png new file mode 100644 index 0000000000..32395b76c9 Binary files /dev/null and b/basis/images/testing/png/suite/g04n0g16.png differ diff --git a/basis/images/testing/png/suite/g04n2c08.png b/basis/images/testing/png/suite/g04n2c08.png new file mode 100644 index 0000000000..a652b0ce87 Binary files /dev/null and b/basis/images/testing/png/suite/g04n2c08.png differ diff --git a/basis/images/testing/png/suite/g04n3p04.png b/basis/images/testing/png/suite/g04n3p04.png new file mode 100644 index 0000000000..5661cc3131 Binary files /dev/null and b/basis/images/testing/png/suite/g04n3p04.png differ diff --git a/basis/images/testing/png/suite/g05n0g16.png b/basis/images/testing/png/suite/g05n0g16.png new file mode 100644 index 0000000000..70b37f01e2 Binary files /dev/null and b/basis/images/testing/png/suite/g05n0g16.png differ diff --git a/basis/images/testing/png/suite/g05n2c08.png b/basis/images/testing/png/suite/g05n2c08.png new file mode 100644 index 0000000000..932c136536 Binary files /dev/null and b/basis/images/testing/png/suite/g05n2c08.png differ diff --git a/basis/images/testing/png/suite/g05n3p04.png b/basis/images/testing/png/suite/g05n3p04.png new file mode 100644 index 0000000000..9619930585 Binary files /dev/null and b/basis/images/testing/png/suite/g05n3p04.png differ diff --git a/basis/images/testing/png/suite/g07n0g16.png b/basis/images/testing/png/suite/g07n0g16.png new file mode 100644 index 0000000000..d6a47c2d57 Binary files /dev/null and b/basis/images/testing/png/suite/g07n0g16.png differ diff --git a/basis/images/testing/png/suite/g07n2c08.png b/basis/images/testing/png/suite/g07n2c08.png new file mode 100644 index 0000000000..597346460f Binary files /dev/null and b/basis/images/testing/png/suite/g07n2c08.png differ diff --git a/basis/images/testing/png/suite/g07n3p04.png b/basis/images/testing/png/suite/g07n3p04.png new file mode 100644 index 0000000000..c73fb61365 Binary files /dev/null and b/basis/images/testing/png/suite/g07n3p04.png differ diff --git a/basis/images/testing/png/suite/g10n0g16.png b/basis/images/testing/png/suite/g10n0g16.png new file mode 100644 index 0000000000..85f2c958e9 Binary files /dev/null and b/basis/images/testing/png/suite/g10n0g16.png differ diff --git a/basis/images/testing/png/suite/g10n2c08.png b/basis/images/testing/png/suite/g10n2c08.png new file mode 100644 index 0000000000..b3039970c1 Binary files /dev/null and b/basis/images/testing/png/suite/g10n2c08.png differ diff --git a/basis/images/testing/png/suite/g10n3p04.png b/basis/images/testing/png/suite/g10n3p04.png new file mode 100644 index 0000000000..1b6a6be2ca Binary files /dev/null and b/basis/images/testing/png/suite/g10n3p04.png differ diff --git a/basis/images/testing/png/suite/g25n0g16.png b/basis/images/testing/png/suite/g25n0g16.png new file mode 100644 index 0000000000..a9f6787c7a Binary files /dev/null and b/basis/images/testing/png/suite/g25n0g16.png differ diff --git a/basis/images/testing/png/suite/g25n2c08.png b/basis/images/testing/png/suite/g25n2c08.png new file mode 100644 index 0000000000..03f505a64b Binary files /dev/null and b/basis/images/testing/png/suite/g25n2c08.png differ diff --git a/basis/images/testing/png/suite/g25n3p04.png b/basis/images/testing/png/suite/g25n3p04.png new file mode 100644 index 0000000000..4f943c6175 Binary files /dev/null and b/basis/images/testing/png/suite/g25n3p04.png differ diff --git a/basis/images/testing/png/suite/oi1n0g16.png b/basis/images/testing/png/suite/oi1n0g16.png new file mode 100644 index 0000000000..e7c82f78eb Binary files /dev/null and b/basis/images/testing/png/suite/oi1n0g16.png differ diff --git a/basis/images/testing/png/suite/oi1n2c16.png b/basis/images/testing/png/suite/oi1n2c16.png new file mode 100644 index 0000000000..50c1cb91a0 Binary files /dev/null and b/basis/images/testing/png/suite/oi1n2c16.png differ diff --git a/basis/images/testing/png/suite/oi2n0g16.png b/basis/images/testing/png/suite/oi2n0g16.png new file mode 100644 index 0000000000..14d64c583d Binary files /dev/null and b/basis/images/testing/png/suite/oi2n0g16.png differ diff --git a/basis/images/testing/png/suite/oi2n2c16.png b/basis/images/testing/png/suite/oi2n2c16.png new file mode 100644 index 0000000000..4c2e3e3352 Binary files /dev/null and b/basis/images/testing/png/suite/oi2n2c16.png differ diff --git a/basis/images/testing/png/suite/oi4n0g16.png b/basis/images/testing/png/suite/oi4n0g16.png new file mode 100644 index 0000000000..69e73ede31 Binary files /dev/null and b/basis/images/testing/png/suite/oi4n0g16.png differ diff --git a/basis/images/testing/png/suite/oi4n2c16.png b/basis/images/testing/png/suite/oi4n2c16.png new file mode 100644 index 0000000000..93691e373a Binary files /dev/null and b/basis/images/testing/png/suite/oi4n2c16.png differ diff --git a/basis/images/testing/png/suite/oi9n0g16.png b/basis/images/testing/png/suite/oi9n0g16.png new file mode 100644 index 0000000000..9248413576 Binary files /dev/null and b/basis/images/testing/png/suite/oi9n0g16.png differ diff --git a/basis/images/testing/png/suite/oi9n2c16.png b/basis/images/testing/png/suite/oi9n2c16.png new file mode 100644 index 0000000000..f0512e49f2 Binary files /dev/null and b/basis/images/testing/png/suite/oi9n2c16.png differ diff --git a/basis/images/testing/png/suite/pngsuite.doc b/basis/images/testing/png/suite/pngsuite.doc new file mode 100644 index 0000000000..7da918b4e9 --- /dev/null +++ b/basis/images/testing/png/suite/pngsuite.doc @@ -0,0 +1,520 @@ + PNGSUITE +---------------- + + testset for PNG-(de)coders + created by Willem van Schaik +------------------------------------ + +This is a collection of graphics images created to test the png applications +like viewers, converters and editors. All (as far as that is possible) +formats supported by the PNG standard are represented. + + +1. INTRODUCTION +-------------------- + +1.1 PNG capabilities +------------------------ + +Supported color-types are: + + - grayscale + - grayscale + alpha-channel + - color palettes + - rgb + - rgb + alpha-channel + +Allowed bitdepths are depending on the color-type, but are in the range +of 1-bit (grayscale, which is b&w) upto 16-bits. + +Special features are: + + - interlacing (Adam-7) + - gamma-support + - transparency (a poor-man's alpha solution) + + +1.2 File naming +------------------- + +Where possible, the testfiles are 32x32 bits icons. This results in a still +reasonable size of the suite even with a large number of tests. The name +of each test-file reflects thetype in the following way: + + g04i2c08.png + || |||+---- bit-depth + || ||+----- color-type (descriptive) + || |+------ color-type (numerical) + || +------- interlaced or non-interlaced + |+--------- parameter of test (in this case gamma-value) + +---------- test feature (in this case gamma) + + +1.3 PNG formats +------------------- + +color-type: + 0g - grayscale + 2c - rgb color + 3p - paletted + 4a - grayscale + alpha channel + 6a - rgb color + alpha channel + +bit-depth: + 01 - with color-type 0, 3 + 02 - with color-type 0, 3 + 04 - with color-type 0, 3 + 08 - with color-type 0, 2, 3, 4, 6 + 16 - with color-type 0, 2, 4, 6 + +interlacing: + n - non-interlaced + i - interlaced + + +2. THE TESTS +----------------- + +2.1 Sizes +------------- + +These tests are there to check if your software handles pictures well, with +picture sizes that are not a multiple of 8. This is particularly important +with Adam-7 type interlacing. In the same way these tests check if pictures +size 1x1 and similar are ok. + + s01 - 1x1 pixel picture + s02 - 2x2 pixel picture + s03 - 3x3 pixel picture + s04 - 4x4 pixel picture + s05 - 5x5 pixel picture + s06 - 6x6 pixel picture + s07 - 7x7 pixel picture + s08 - 8x8 pixel picture + s09 - 9x9 pixel picture + s32 - 32x32 pixel picture + s33 - 33x33 pixel picture + s34 - 34x34 pixel picture + s35 - 35x35 pixel picture + s36 - 36x36 pixel picture + s37 - 37x37 pixel picture + s38 - 38x38 pixel picture + s39 - 39x39 pixel picture + s40 - 40x40 pixel picture + + +2.2 Background +------------------ + +When the PNG file contains a background chunck, this should be used for +pictures with alpha-channel or pictures with a transparency chunck. For +pictures without this background-chunk, but with alpha, this testset +assumes a black background. + +For the images in this test, the left-side should be 100% the background +color, where moving to the right the color should gradually become the +image pattern. + + bga - alpha + no background + bgw - alpha + white background + bgg - alpha + gray background + bgb - alpha + black background + bgy - alpha + yellow background + + +2.3 Transparency +-------------------- + +Transparency should be used together with a background chunk. To test the +combination of the two the latter 4 tests are there. How to handle pictures +with transparancy, but without a background, opinions can differ. Here we +use black, but especially in the case of paletted images, the normal color +would maybe even be better. + + tp0 - not transparent for reference + tp1 - transparent, but no background chunk + tbw - transparent + white background + tbg - transparent + gray background + tbb - transparent + black background + tby - transparent + yellow background + + +2.4 Gamma +------------- + +To test if your viewer handles gamma-correction, 6 testfiles are available. +They contain corrected color-ramps and a corresponding gamma-chunk with the +file-gamma value. These are created in such a way that when the viewer does +the gamma correction right, all 6 should be displayed identical. + +If they are different, probably the gamma correction is omitted. In that +case, have a look at the two right coloumns in the 6 pictures. The image +where those two look the same (when looked from far) reflects the gamma of +your system. However, because of the limited size of the image, you should +do more elaborate tests to determine your display gamma. + + g03 - file-gamma = 0.35, for display with gamma = 2.8 + g04 - file-gamma = 0.45, for display with gamma = 2.2 (PC) + g05 - file-gamma = 0.55, for display with gamma = 1.8 (Mac) + g07 - file-gamma = 0.70, for display with gamma = 1.4 + g10 - file-gamma = 1.00, for display with gamma = 1.0 (NeXT) + g25 - file-gamma = 2.50, for display with gamma = 0.4 + + +2.5 Filtering +----------------- + +PNG uses file-filtering, for optimal compression. Normally the type is of +filtering is adjusted to the contents of the picture, but here each file +has the same picture, with a different filtering. + + f0 - no filtering + f1 - sub filtering + f2 - up filtering + f3 - average filtering + f4 - paeth filtering + + +2.6 Additional palettes +--------------------------- + +Besides the normal use of paletted images, palette chunks can in combination +with true-color (and other) images also be used to select color lookup-tables +when the video system is of limited capabilities. The suggested palette chunk +is specially created for this purpose. + + pp - normal palette chunk + ps - suggested palette chunk + + +2.7 Ancillary chunks (under construction) +------------------------ + +To test the correct decoding of ancillary chunks, these test-files contain +one or more examples of these chunkcs. Depending on the type of chunk, a +number of typical values are selected to test. Unluckily, the testset can +not contain all combinations, because that would be an endless set. + +The significant bits are used in files with the next higher bit-depth. They +indicate howmany bits are valid. + + cs3 - 3 significant bits + cs5 - 5 significant bits + cs8 - 8 significant bits (reference) + cs3 - 13 significant bits + +For the physical pixel dimensions, the result of each decoding should be +a sqare picture. The first (cdf) image is an example of flat (horizontal) +pixels, where the pHYS chunk (x is 1 per unit, y = 4 per unit) must take +care of the correction. The second is just the other way round. The last +example uses the unit specifier, for 1000 pixels per meter. This should +result in a picture of 3.2 cm square. + + cdf - physical pixel dimensions, 8x32 flat pixels + cdh - physical pixel dimensions, 32x8 high pixels + cds - physical pixel dimensions, 8x8 square pixels + cdu - physical pixel dimensions, with unit-specifier + + ccw - primary chromaticities and white point + + ch1 - histogram 15 colors + ch2 - histogram 256 colors + + cm7 - modification time, 01-jan-1970 + cm9 - modification time, 31-dec-1999 + cm0 - modification time, 01-jan-2000 + +In the textual chunk, a number of the standard, and some non-standard +text items are included. + + ct0 - no textual data + ct1 - with textual data + ctz - with compressed textual data + + +2.8 Chunk ordering (still under construction) +---------------------- + +These testfiles will test the obligatory ordering relations between various +chunk types (not yet) as well as the number of data chunks used for the image. + + oi1 - mother image with 1 idat-chunk + oi2 - image with 2 idat-chunks + oi4 - image with 4 unequal sized idat-chunks + oi9 - all idat-chunks of length one + + +2.9 Compression level +------------------------- + +Here you will find a set of images compressed by zlib, ranging from level 0 +for no compression at maximum speed upto level 9 for maximum compression. + + z00 - zlib compression level 0 - none + z03 - zlib compression level 3 + z06 - zlib compression level 6 - default + z09 - zlib compression level 9 - maximum + + +2.10 Corrupted files (under construction) +----------------------- + +All these files are illegal. When decoding they should generate appropriate +error-messages. + + x00 - empty IDAT chunk + xcr - added cr bytes + xlf - added lf bytes + xc0 - color type 0 + xc9 - color type 9 + xd0 - bit-depth 0 + xd3 - bit-depth 3 + xd9 - bit-depth 99 + xcs - incorrect IDAT checksum + + +3. TEST FILES +------------------ + +For each of the tests listed above, one or more test-files are created. A +selection is made (for each test) for the color-type and bitdepth to be used +for the tests. Further for a number of tests, both a non-interlaced as well +as an interlaced version is available. + + +3.1 Basic format test files (non-interlaced) +------------------------------------------------ + + basn0g01 - black & white + basn0g02 - 2 bit (4 level) grayscale + basn0g04 - 4 bit (16 level) grayscale + basn0g08 - 8 bit (256 level) grayscale + basn0g16 - 16 bit (64k level) grayscale + basn2c08 - 3x8 bits rgb color + basn2c16 - 3x16 bits rgb color + basn3p01 - 1 bit (2 color) paletted + basn3p02 - 2 bit (4 color) paletted + basn3p04 - 4 bit (16 color) paletted + basn3p08 - 8 bit (256 color) paletted + basn4a08 - 8 bit grayscale + 8 bit alpha-channel + basn4a16 - 16 bit grayscale + 16 bit alpha-channel + basn6a08 - 3x8 bits rgb color + 8 bit alpha-channel + basn6a16 - 3x16 bits rgb color + 16 bit alpha-channel + + +3.2 Basic format test files (Adam-7 interlaced) +--------------------------------------------------- + + basi0g01 - black & white + basi0g02 - 2 bit (4 level) grayscale + basi0g04 - 4 bit (16 level) grayscale + basi0g08 - 8 bit (256 level) grayscale + basi0g16 - 16 bit (64k level) grayscale + basi2c08 - 3x8 bits rgb color + basi2c16 - 3x16 bits rgb color + basi3p01 - 1 bit (2 color) paletted + basi3p02 - 2 bit (4 color) paletted + basi3p04 - 4 bit (16 color) paletted + basi3p08 - 8 bit (256 color) paletted + basi4a08 - 8 bit grayscale + 8 bit alpha-channel + basi4a16 - 16 bit grayscale + 16 bit alpha-channel + basi6a08 - 3x8 bits rgb color + 8 bit alpha-channel + basi6a16 - 3x16 bits rgb color + 16 bit alpha-channel + + +3.3 Sizes test files +----------------------- + + s01n3p01 - 1x1 paletted file, no interlacing + s02n3p01 - 2x2 paletted file, no interlacing + s03n3p01 - 3x3 paletted file, no interlacing + s04n3p01 - 4x4 paletted file, no interlacing + s05n3p02 - 5x5 paletted file, no interlacing + s06n3p02 - 6x6 paletted file, no interlacing + s07n3p02 - 7x7 paletted file, no interlacing + s08n3p02 - 8x8 paletted file, no interlacing + s09n3p02 - 9x9 paletted file, no interlacing + s32n3p04 - 32x32 paletted file, no interlacing + s33n3p04 - 33x33 paletted file, no interlacing + s34n3p04 - 34x34 paletted file, no interlacing + s35n3p04 - 35x35 paletted file, no interlacing + s36n3p04 - 36x36 paletted file, no interlacing + s37n3p04 - 37x37 paletted file, no interlacing + s38n3p04 - 38x38 paletted file, no interlacing + s39n3p04 - 39x39 paletted file, no interlacing + s40n3p04 - 40x40 paletted file, no interlacing + + s01i3p01 - 1x1 paletted file, interlaced + s02i3p01 - 2x2 paletted file, interlaced + s03i3p01 - 3x3 paletted file, interlaced + s04i3p01 - 4x4 paletted file, interlaced + s05i3p02 - 5x5 paletted file, interlaced + s06i3p02 - 6x6 paletted file, interlaced + s07i3p02 - 7x7 paletted file, interlaced + s08i3p02 - 8x8 paletted file, interlaced + s09i3p02 - 9x9 paletted file, interlaced + s32i3p04 - 32x32 paletted file, interlaced + s33i3p04 - 33x33 paletted file, interlaced + s34i3p04 - 34x34 paletted file, interlaced + s35i3p04 - 35x35 paletted file, interlaced + s36i3p04 - 36x36 paletted file, interlaced + s37i3p04 - 37x37 paletted file, interlaced + s38i3p04 - 38x38 paletted file, interlaced + s39i3p04 - 39x39 paletted file, interlaced + s40i3p04 - 40x40 paletted file, interlaced + + +3.4 Background test files (with alpha) +------------------------------------------ + + bgai4a08 - 8 bit grayscale, alpha, no background chunk, interlaced + bgai4a16 - 16 bit grayscale, alpha, no background chunk, interlaced + bgan6a08 - 3x8 bits rgb color, alpha, no background chunk + bgan6a16 - 3x16 bits rgb color, alpha, no background chunk + + bgbn4a08 - 8 bit grayscale, alpha, black background chunk + bggn4a16 - 16 bit grayscale, alpha, gray background chunk + bgwn6a08 - 3x8 bits rgb color, alpha, white background chunk + bgyn6a16 - 3x16 bits rgb color, alpha, yellow background chunk + + +3.5 Transparency (and background) test files +------------------------------------------------ + + tp0n1g08 - not transparent for reference (logo on gray) + tbbn1g04 - transparent, black background chunk + tbwn1g16 - transparent, white background chunk + tp0n2c08 - not transparent for reference (logo on gray) + tbrn2c08 - transparent, red background chunk + tbgn2c16 - transparent, green background chunk + tbbn2c16 - transparent, blue background chunk + tp0n3p08 - not transparent for reference (logo on gray) + tp1n3p08 - transparent, but no background chunk + tbbn3p08 - transparent, black background chunk + tbgn3p08 - transparent, light-gray background chunk + tbwn3p08 - transparent, white background chunk + tbyn3p08 - transparent, yellow background chunk + + +3.6 Gamma test files +------------------------ + + g03n0g16 - grayscale, file-gamma = 0.35 + g04n0g16 - grayscale, file-gamma = 0.45 + g05n0g16 - grayscale, file-gamma = 0.55 + g07n0g16 - grayscale, file-gamma = 0.70 + g10n0g16 - grayscale, file-gamma = 1.00 + g25n0g16 - grayscale, file-gamma = 2.50 + g03n2c08 - color, file-gamma = 0.35 + g04n2c08 - color, file-gamma = 0.45 + g05n2c08 - color, file-gamma = 0.55 + g07n2c08 - color, file-gamma = 0.70 + g10n2c08 - color, file-gamma = 1.00 + g25n2c08 - color, file-gamma = 2.50 + g03n3p04 - paletted, file-gamma = 0.35 + g04n3p04 - paletted, file-gamma = 0.45 + g05n3p04 - paletted, file-gamma = 0.55 + g07n3p04 - paletted, file-gamma = 0.70 + g10n3p04 - paletted, file-gamma = 1.00 + g25n3p04 - paletted, file-gamma = 2.50 + + +3.7 Filtering test files +---------------------------- + + f00n0g08 - grayscale, no interlacing, filter-type 0 + f01n0g08 - grayscale, no interlacing, filter-type 1 + f02n0g08 - grayscale, no interlacing, filter-type 2 + f03n0g08 - grayscale, no interlacing, filter-type 3 + f04n0g08 - grayscale, no interlacing, filter-type 4 + f00n2c08 - color, no interlacing, filter-type 0 + f01n2c08 - color, no interlacing, filter-type 1 + f02n2c08 - color, no interlacing, filter-type 2 + f03n2c08 - color, no interlacing, filter-type 3 + f04n2c08 - color, no interlacing, filter-type 4 + + +3.8 Additional palette chunk test files +------------------------------------------- + + pp0n2c16 - six-cube palette-chunk in true-color image + pp0n6a08 - six-cube palette-chunk in true-color+alpha image + ps1n0g08 - six-cube suggested palette (1 byte) in grayscale image + ps1n2c16 - six-cube suggested palette (1 byte) in true-color image + ps2n0g08 - six-cube suggested palette (2 bytes) in grayscale image + ps2n2c16 - six-cube suggested palette (2 bytes) in true-color image + + +3.9 Ancillary chunks test files +----------------------------------- + + cs5n2c08 - color, 5 significant bits + cs8n2c08 - color, 8 significant bits (reference) + cs3n2c16 - color, 13 significant bits + cs3n3p08 - paletted, 3 significant bits + cs5n3p08 - paletted, 5 significant bits + cs8n3p08 - paletted, 8 significant bits (reference) + + cdfn2c08 - physical pixel dimensions, 8x32 flat pixels + cdhn2c08 - physical pixel dimensions, 32x8 high pixels + cdsn2c08 - physical pixel dimensions, 8x8 square pixels + cdun2c08 - physical pixel dimensions, 1000 pixels per 1 meter + + ccwn2c08 - chroma chunk w:0.3127,0.3290 r:0.64,0.33 g:0.30,0.60 b:0.15,0.06 + ccwn3p08 - chroma chunk w:0.3127,0.3290 r:0.64,0.33 g:0.30,0.60 b:0.15,0.06 + + ch1n3p04 - histogram 15 colors + ch2n3p08 - histogram 256 colors + + cm7n0g04 - modification time, 01-jan-1970 00:00:00 + cm9n0g04 - modification time, 31-dec-1999 23:59:59 + cm0n0g04 - modification time, 01-jan-2000 12:34:56 + + ct0n0g04 - no textual data + ct1n0g04 - with textual data + ctzn0g04 - with compressed textual data + + + +3.10 Chunk ordering +---------------------- + + oi1n0g16 - grayscale mother image with 1 idat-chunk + oi2n0g16 - grayscale image with 2 idat-chunks + oi4n0g16 - grayscale image with 4 unequal sized idat-chunks + oi9n0g16 - grayscale image with all idat-chunks length one + oi1n2c16 - color mother image with 1 idat-chunk + oi2n2c16 - color image with 2 idat-chunks + oi4n2c16 - color image with 4 unequal sized idat-chunks + oi9n2c16 - color image with all idat-chunks length one + + + +3.11 Compression level +------------------------- + + z00n2c08 - color, no interlacing, compression level 0 (none) + z03n2c08 - color, no interlacing, compression level 3 + z06n2c08 - color, no interlacing, compression level 6 (default) + z09n2c08 - color, no interlacing, compression level 9 (maximum) + + + +3.12 Currupted files +----------------------- + + x00n0g01 - empty 0x0 grayscale file + xcrn0g04 - added cr bytes + xlfn0g04 - added lf bytes + xc0n0c08 - color type 0 + xc9n0c08 - color type 9 + xd0n2c00 - bit-depth 0 + xd3n2c03 - bit-depth 3 + xd9n2c99 - bit-depth 99 + xcsn2c08 - incorrect IDAT checksum + + +-------- + (c) Willem van Schaik + willem@schaik.com + Singapore, October 1996 diff --git a/basis/images/testing/png/suite/pngsuite_logo.png b/basis/images/testing/png/suite/pngsuite_logo.png new file mode 100644 index 0000000000..205460d828 Binary files /dev/null and b/basis/images/testing/png/suite/pngsuite_logo.png differ diff --git a/basis/images/testing/png/suite/pp0n2c16.png b/basis/images/testing/png/suite/pp0n2c16.png new file mode 100644 index 0000000000..8f2aad7335 Binary files /dev/null and b/basis/images/testing/png/suite/pp0n2c16.png differ diff --git a/basis/images/testing/png/suite/pp0n6a08.png b/basis/images/testing/png/suite/pp0n6a08.png new file mode 100644 index 0000000000..4ed7a30e4d Binary files /dev/null and b/basis/images/testing/png/suite/pp0n6a08.png differ diff --git a/basis/images/testing/png/suite/ps1n0g08.png b/basis/images/testing/png/suite/ps1n0g08.png new file mode 100644 index 0000000000..2053df2ba3 Binary files /dev/null and b/basis/images/testing/png/suite/ps1n0g08.png differ diff --git a/basis/images/testing/png/suite/ps1n2c16.png b/basis/images/testing/png/suite/ps1n2c16.png new file mode 100644 index 0000000000..b03ecfc669 Binary files /dev/null and b/basis/images/testing/png/suite/ps1n2c16.png differ diff --git a/basis/images/testing/png/suite/ps2n0g08.png b/basis/images/testing/png/suite/ps2n0g08.png new file mode 100644 index 0000000000..beeab8ff3d Binary files /dev/null and b/basis/images/testing/png/suite/ps2n0g08.png differ diff --git a/basis/images/testing/png/suite/ps2n2c16.png b/basis/images/testing/png/suite/ps2n2c16.png new file mode 100644 index 0000000000..c256f9091b Binary files /dev/null and b/basis/images/testing/png/suite/ps2n2c16.png differ diff --git a/basis/images/testing/png/suite/s01i3p01.png b/basis/images/testing/png/suite/s01i3p01.png new file mode 100644 index 0000000000..6c0fad1fc9 Binary files /dev/null and b/basis/images/testing/png/suite/s01i3p01.png differ diff --git a/basis/images/testing/png/suite/s01n3p01.png b/basis/images/testing/png/suite/s01n3p01.png new file mode 100644 index 0000000000..cb2c8c7826 Binary files /dev/null and b/basis/images/testing/png/suite/s01n3p01.png differ diff --git a/basis/images/testing/png/suite/s02i3p01.png b/basis/images/testing/png/suite/s02i3p01.png new file mode 100644 index 0000000000..2defaed911 Binary files /dev/null and b/basis/images/testing/png/suite/s02i3p01.png differ diff --git a/basis/images/testing/png/suite/s02n3p01.png b/basis/images/testing/png/suite/s02n3p01.png new file mode 100644 index 0000000000..2b1b669643 Binary files /dev/null and b/basis/images/testing/png/suite/s02n3p01.png differ diff --git a/basis/images/testing/png/suite/s03i3p01.png b/basis/images/testing/png/suite/s03i3p01.png new file mode 100644 index 0000000000..c23fdc4631 Binary files /dev/null and b/basis/images/testing/png/suite/s03i3p01.png differ diff --git a/basis/images/testing/png/suite/s03n3p01.png b/basis/images/testing/png/suite/s03n3p01.png new file mode 100644 index 0000000000..6d96ee4f87 Binary files /dev/null and b/basis/images/testing/png/suite/s03n3p01.png differ diff --git a/basis/images/testing/png/suite/s04i3p01.png b/basis/images/testing/png/suite/s04i3p01.png new file mode 100644 index 0000000000..0e710c2c39 Binary files /dev/null and b/basis/images/testing/png/suite/s04i3p01.png differ diff --git a/basis/images/testing/png/suite/s04n3p01.png b/basis/images/testing/png/suite/s04n3p01.png new file mode 100644 index 0000000000..956396c45b Binary files /dev/null and b/basis/images/testing/png/suite/s04n3p01.png differ diff --git a/basis/images/testing/png/suite/s05i3p02.png b/basis/images/testing/png/suite/s05i3p02.png new file mode 100644 index 0000000000..d14cbd351a Binary files /dev/null and b/basis/images/testing/png/suite/s05i3p02.png differ diff --git a/basis/images/testing/png/suite/s05n3p02.png b/basis/images/testing/png/suite/s05n3p02.png new file mode 100644 index 0000000000..bf940f0576 Binary files /dev/null and b/basis/images/testing/png/suite/s05n3p02.png differ diff --git a/basis/images/testing/png/suite/s06i3p02.png b/basis/images/testing/png/suite/s06i3p02.png new file mode 100644 index 0000000000..456ada3200 Binary files /dev/null and b/basis/images/testing/png/suite/s06i3p02.png differ diff --git a/basis/images/testing/png/suite/s06n3p02.png b/basis/images/testing/png/suite/s06n3p02.png new file mode 100644 index 0000000000..501064dc25 Binary files /dev/null and b/basis/images/testing/png/suite/s06n3p02.png differ diff --git a/basis/images/testing/png/suite/s07i3p02.png b/basis/images/testing/png/suite/s07i3p02.png new file mode 100644 index 0000000000..44b66bab9e Binary files /dev/null and b/basis/images/testing/png/suite/s07i3p02.png differ diff --git a/basis/images/testing/png/suite/s07n3p02.png b/basis/images/testing/png/suite/s07n3p02.png new file mode 100644 index 0000000000..6a582593d6 Binary files /dev/null and b/basis/images/testing/png/suite/s07n3p02.png differ diff --git a/basis/images/testing/png/suite/s08i3p02.png b/basis/images/testing/png/suite/s08i3p02.png new file mode 100644 index 0000000000..acf74f3fc4 Binary files /dev/null and b/basis/images/testing/png/suite/s08i3p02.png differ diff --git a/basis/images/testing/png/suite/s08n3p02.png b/basis/images/testing/png/suite/s08n3p02.png new file mode 100644 index 0000000000..b7094e1b4f Binary files /dev/null and b/basis/images/testing/png/suite/s08n3p02.png differ diff --git a/basis/images/testing/png/suite/s09i3p02.png b/basis/images/testing/png/suite/s09i3p02.png new file mode 100644 index 0000000000..0bfae8e456 Binary files /dev/null and b/basis/images/testing/png/suite/s09i3p02.png differ diff --git a/basis/images/testing/png/suite/s09n3p02.png b/basis/images/testing/png/suite/s09n3p02.png new file mode 100644 index 0000000000..711ab82451 Binary files /dev/null and b/basis/images/testing/png/suite/s09n3p02.png differ diff --git a/basis/images/testing/png/suite/s32i3p04.png b/basis/images/testing/png/suite/s32i3p04.png new file mode 100644 index 0000000000..0841910b72 Binary files /dev/null and b/basis/images/testing/png/suite/s32i3p04.png differ diff --git a/basis/images/testing/png/suite/s32n3p04.png b/basis/images/testing/png/suite/s32n3p04.png new file mode 100644 index 0000000000..fa58e3e3f6 Binary files /dev/null and b/basis/images/testing/png/suite/s32n3p04.png differ diff --git a/basis/images/testing/png/suite/s33i3p04.png b/basis/images/testing/png/suite/s33i3p04.png new file mode 100644 index 0000000000..ab0dc14aba Binary files /dev/null and b/basis/images/testing/png/suite/s33i3p04.png differ diff --git a/basis/images/testing/png/suite/s33n3p04.png b/basis/images/testing/png/suite/s33n3p04.png new file mode 100644 index 0000000000..764f1a3dc7 Binary files /dev/null and b/basis/images/testing/png/suite/s33n3p04.png differ diff --git a/basis/images/testing/png/suite/s34i3p04.png b/basis/images/testing/png/suite/s34i3p04.png new file mode 100644 index 0000000000..bd99039be4 Binary files /dev/null and b/basis/images/testing/png/suite/s34i3p04.png differ diff --git a/basis/images/testing/png/suite/s34n3p04.png b/basis/images/testing/png/suite/s34n3p04.png new file mode 100644 index 0000000000..9cbc68b3b9 Binary files /dev/null and b/basis/images/testing/png/suite/s34n3p04.png differ diff --git a/basis/images/testing/png/suite/s35i3p04.png b/basis/images/testing/png/suite/s35i3p04.png new file mode 100644 index 0000000000..e2a5e0a659 Binary files /dev/null and b/basis/images/testing/png/suite/s35i3p04.png differ diff --git a/basis/images/testing/png/suite/s35n3p04.png b/basis/images/testing/png/suite/s35n3p04.png new file mode 100644 index 0000000000..90b892ebaf Binary files /dev/null and b/basis/images/testing/png/suite/s35n3p04.png differ diff --git a/basis/images/testing/png/suite/s36i3p04.png b/basis/images/testing/png/suite/s36i3p04.png new file mode 100644 index 0000000000..eb61b6f9a3 Binary files /dev/null and b/basis/images/testing/png/suite/s36i3p04.png differ diff --git a/basis/images/testing/png/suite/s36n3p04.png b/basis/images/testing/png/suite/s36n3p04.png new file mode 100644 index 0000000000..b38d179774 Binary files /dev/null and b/basis/images/testing/png/suite/s36n3p04.png differ diff --git a/basis/images/testing/png/suite/s37i3p04.png b/basis/images/testing/png/suite/s37i3p04.png new file mode 100644 index 0000000000..6e2b1e9b79 Binary files /dev/null and b/basis/images/testing/png/suite/s37i3p04.png differ diff --git a/basis/images/testing/png/suite/s37n3p04.png b/basis/images/testing/png/suite/s37n3p04.png new file mode 100644 index 0000000000..4d3054da51 Binary files /dev/null and b/basis/images/testing/png/suite/s37n3p04.png differ diff --git a/basis/images/testing/png/suite/s38i3p04.png b/basis/images/testing/png/suite/s38i3p04.png new file mode 100644 index 0000000000..a0a8a140ad Binary files /dev/null and b/basis/images/testing/png/suite/s38i3p04.png differ diff --git a/basis/images/testing/png/suite/s38n3p04.png b/basis/images/testing/png/suite/s38n3p04.png new file mode 100644 index 0000000000..1233ed048e Binary files /dev/null and b/basis/images/testing/png/suite/s38n3p04.png differ diff --git a/basis/images/testing/png/suite/s39i3p04.png b/basis/images/testing/png/suite/s39i3p04.png new file mode 100644 index 0000000000..04fee93eae Binary files /dev/null and b/basis/images/testing/png/suite/s39i3p04.png differ diff --git a/basis/images/testing/png/suite/s39n3p04.png b/basis/images/testing/png/suite/s39n3p04.png new file mode 100644 index 0000000000..c750100d55 Binary files /dev/null and b/basis/images/testing/png/suite/s39n3p04.png differ diff --git a/basis/images/testing/png/suite/s40i3p04.png b/basis/images/testing/png/suite/s40i3p04.png new file mode 100644 index 0000000000..68f358b822 Binary files /dev/null and b/basis/images/testing/png/suite/s40i3p04.png differ diff --git a/basis/images/testing/png/suite/s40n3p04.png b/basis/images/testing/png/suite/s40n3p04.png new file mode 100644 index 0000000000..864b6b9673 Binary files /dev/null and b/basis/images/testing/png/suite/s40n3p04.png differ diff --git a/basis/images/testing/png/suite/tbbn1g04.png b/basis/images/testing/png/suite/tbbn1g04.png new file mode 100644 index 0000000000..fc8002053a Binary files /dev/null and b/basis/images/testing/png/suite/tbbn1g04.png differ diff --git a/basis/images/testing/png/suite/tbbn2c16.png b/basis/images/testing/png/suite/tbbn2c16.png new file mode 100644 index 0000000000..5abfbbb3a2 Binary files /dev/null and b/basis/images/testing/png/suite/tbbn2c16.png differ diff --git a/basis/images/testing/png/suite/tbbn3p08.png b/basis/images/testing/png/suite/tbbn3p08.png new file mode 100644 index 0000000000..4210d16832 Binary files /dev/null and b/basis/images/testing/png/suite/tbbn3p08.png differ diff --git a/basis/images/testing/png/suite/tbgn2c16.png b/basis/images/testing/png/suite/tbgn2c16.png new file mode 100644 index 0000000000..236c81dcf3 Binary files /dev/null and b/basis/images/testing/png/suite/tbgn2c16.png differ diff --git a/basis/images/testing/png/suite/tbgn3p08.png b/basis/images/testing/png/suite/tbgn3p08.png new file mode 100644 index 0000000000..42db2325b1 Binary files /dev/null and b/basis/images/testing/png/suite/tbgn3p08.png differ diff --git a/basis/images/testing/png/suite/tbrn2c08.png b/basis/images/testing/png/suite/tbrn2c08.png new file mode 100644 index 0000000000..8c214746d5 Binary files /dev/null and b/basis/images/testing/png/suite/tbrn2c08.png differ diff --git a/basis/images/testing/png/suite/tbwn1g16.png b/basis/images/testing/png/suite/tbwn1g16.png new file mode 100644 index 0000000000..dba2cbb6c3 Binary files /dev/null and b/basis/images/testing/png/suite/tbwn1g16.png differ diff --git a/basis/images/testing/png/suite/tbwn3p08.png b/basis/images/testing/png/suite/tbwn3p08.png new file mode 100644 index 0000000000..7922135aa7 Binary files /dev/null and b/basis/images/testing/png/suite/tbwn3p08.png differ diff --git a/basis/images/testing/png/suite/tbyn3p08.png b/basis/images/testing/png/suite/tbyn3p08.png new file mode 100644 index 0000000000..5b2c6cbbaa Binary files /dev/null and b/basis/images/testing/png/suite/tbyn3p08.png differ diff --git a/basis/images/testing/png/suite/tp0n1g08.png b/basis/images/testing/png/suite/tp0n1g08.png new file mode 100644 index 0000000000..caad31deae Binary files /dev/null and b/basis/images/testing/png/suite/tp0n1g08.png differ diff --git a/basis/images/testing/png/suite/tp0n2c08.png b/basis/images/testing/png/suite/tp0n2c08.png new file mode 100644 index 0000000000..f26be44679 Binary files /dev/null and b/basis/images/testing/png/suite/tp0n2c08.png differ diff --git a/basis/images/testing/png/suite/tp0n3p08.png b/basis/images/testing/png/suite/tp0n3p08.png new file mode 100644 index 0000000000..4d6cf9e44c Binary files /dev/null and b/basis/images/testing/png/suite/tp0n3p08.png differ diff --git a/basis/images/testing/png/suite/tp1n3p08.png b/basis/images/testing/png/suite/tp1n3p08.png new file mode 100644 index 0000000000..6c5fd6ec32 Binary files /dev/null and b/basis/images/testing/png/suite/tp1n3p08.png differ diff --git a/basis/images/testing/png/suite/x00n0g01.png b/basis/images/testing/png/suite/x00n0g01.png new file mode 100644 index 0000000000..db3a5fda7e Binary files /dev/null and b/basis/images/testing/png/suite/x00n0g01.png differ diff --git a/basis/images/testing/png/suite/xcrn0g04.png b/basis/images/testing/png/suite/xcrn0g04.png new file mode 100644 index 0000000000..5bce9f3ada Binary files /dev/null and b/basis/images/testing/png/suite/xcrn0g04.png differ diff --git a/basis/images/testing/png/suite/xlfn0g04.png b/basis/images/testing/png/suite/xlfn0g04.png new file mode 100644 index 0000000000..1fd104ba61 --- /dev/null +++ b/basis/images/testing/png/suite/xlfn0g04.png @@ -0,0 +1,13 @@ +PNG + + + + + +IHDR áÈ)ÈIDATx]ÑÁ +Â0P*@ð¡#° + +#TâÈ10lPF`Ø F=ÄIQâ*çÅuí`%qk +Hñ©ñ´m÷Íüµàß Ñ=,¸fìOK + +ç ÐtÀ(Èïä×¦íF;èPº¯¾{xpç]9/p*$(ì*éyìÕ ×þÚéçè@÷C¼ cÔqNÛU#)11·.räðfä0°ägh(¥týÙÂEøÿkIEND®B` \ No newline at end of file diff --git a/basis/images/testing/png/suite/z00n2c08.png b/basis/images/testing/png/suite/z00n2c08.png new file mode 100644 index 0000000000..7669eb8385 Binary files /dev/null and b/basis/images/testing/png/suite/z00n2c08.png differ diff --git a/basis/images/testing/png/suite/z03n2c08.png b/basis/images/testing/png/suite/z03n2c08.png new file mode 100644 index 0000000000..bfb10de8de Binary files /dev/null and b/basis/images/testing/png/suite/z03n2c08.png differ diff --git a/basis/images/testing/png/suite/z06n2c08.png b/basis/images/testing/png/suite/z06n2c08.png new file mode 100644 index 0000000000..b90ebc10f5 Binary files /dev/null and b/basis/images/testing/png/suite/z06n2c08.png differ diff --git a/basis/images/testing/png/suite/z09n2c08.png b/basis/images/testing/png/suite/z09n2c08.png new file mode 100644 index 0000000000..5f191a78ee Binary files /dev/null and b/basis/images/testing/png/suite/z09n2c08.png differ diff --git a/basis/images/testing/png/z00n2c08.fig b/basis/images/testing/png/z00n2c08.fig new file mode 100644 index 0000000000..9d171e68b7 Binary files /dev/null and b/basis/images/testing/png/z00n2c08.fig differ diff --git a/basis/images/testing/png/z00n2c08.png b/basis/images/testing/png/z00n2c08.png new file mode 100644 index 0000000000..7669eb8385 Binary files /dev/null and b/basis/images/testing/png/z00n2c08.png differ diff --git a/basis/images/testing/png/z03n2c08.fig b/basis/images/testing/png/z03n2c08.fig new file mode 100644 index 0000000000..9d171e68b7 Binary files /dev/null and b/basis/images/testing/png/z03n2c08.fig differ diff --git a/basis/images/testing/png/z03n2c08.png b/basis/images/testing/png/z03n2c08.png new file mode 100644 index 0000000000..bfb10de8de Binary files /dev/null and b/basis/images/testing/png/z03n2c08.png differ diff --git a/basis/images/testing/png/z06n2c08.fig b/basis/images/testing/png/z06n2c08.fig new file mode 100644 index 0000000000..9d171e68b7 Binary files /dev/null and b/basis/images/testing/png/z06n2c08.fig differ diff --git a/basis/images/testing/png/z06n2c08.png b/basis/images/testing/png/z06n2c08.png new file mode 100644 index 0000000000..b90ebc10f5 Binary files /dev/null and b/basis/images/testing/png/z06n2c08.png differ diff --git a/basis/images/testing/png/z09n2c08.fig b/basis/images/testing/png/z09n2c08.fig new file mode 100644 index 0000000000..9d171e68b7 Binary files /dev/null and b/basis/images/testing/png/z09n2c08.fig differ diff --git a/basis/images/testing/png/z09n2c08.png b/basis/images/testing/png/z09n2c08.png new file mode 100644 index 0000000000..5f191a78ee Binary files /dev/null and b/basis/images/testing/png/z09n2c08.png differ diff --git a/basis/images/testing/testing-docs.factor b/basis/images/testing/testing-docs.factor new file mode 100644 index 0000000000..6b90b634b9 --- /dev/null +++ b/basis/images/testing/testing-docs.factor @@ -0,0 +1,98 @@ +! Copyright (C) 2009 Keith Lazuka. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax images images.viewer kernel +quotations strings ; +IN: images.testing + +HELP: decode-test +{ $values + { "path" "a pathname string" } +} +{ $description "Runs a unit-test on the image at " { $snippet "path" } " to test the image decoder. The image is decoded and compared against its corresponding " { $link { "images" "testing" "reference" } } "." } ; + +HELP: encode-test +{ $values + { "path" "a pathname string" } { "image-class" object } +} +{ $description "Runs a unit-test on the image at " { $snippet "path" } " to test the image encoder. The image is decoded, encoded, and then decoded again to verify that the final decoded output matches the original decoded output. Before comparison for equality, the images are normalized in order to accomodate differences in representation between the two potential encoders." } +{ $warning "This test assumes that the image decoder is working correctly. If the image fails both the " { $link decode-test } " and the " { $link encode-test } ", then you should first debug the decoder. Once the decoder is working correctly, proceed with testing the encoder." } ; + +HELP: images. +{ $values + { "dirpath" "a pathname string" } { "extension" string } +} +{ $description "Renders each image at " { $snippet "dirpath" } " directly to the Listener tool." } ; +{ images. image. } related-words + +HELP: load-reference-image +{ $values + { "path" "a pathname string" } + { "image" image } +} +{ $description "Loads the " { $link { "images" "testing" "reference" } } " that corresponds to the original image at " { $snippet "path" } " into memory." } ; + +HELP: ls +{ $values + { "dirpath" "a pathname string" } { "extension" object } +} +{ $description "Prints out the name of each file surrounded in double quotes so that you can easily copy and paste into your unit test." } ; + +HELP: save-all-as-reference-images +{ $values + { "dirpath" "a pathname string" } { "extension" object } +} +{ $description "Saves a " { $link { "images" "testing" "reference" } } " for each image in " { $snippet "dirpath" } " with file extension " { $snippet "extension" } "." } +{ $warning "You should only call this word after you have manually verified that every image in " { $snippet "dirpath" } " decodes and renders correctly!" } ; + +HELP: save-as-reference-image +{ $values + { "path" "a pathname string" } +} +{ $description "Saves a " { $link { "images" "testing" "reference" } } " for the image at " { $snippet "path" } "." } +{ $warning "You should only call this word after you have manually verified that the image at " { $snippet "path" } " decodes and renders correctly!" } ; + +HELP: with-matching-files +{ $values + { "dirpath" "a pathname string" } { "extension" string } { "quot" quotation } +} +{ $description "Perform an operation on each file in " { $snippet "dirpath" } " with file extension " { $snippet "extension" } "." } ; + +ARTICLE: { "images" "testing" "reference" } "Reference image" +"For the purposes of the " { $vocab-link "images.testing" } " vocab, a reference image is an " { $link image } " which has been serialized to disk by the " { $vocab-link "serialize" } " vocab. The file on disk has a " { $snippet ".fig" } " extension." +$nl +"Reference images are used by " { $link decode-test } " to compare the decoder's output against a saved image that is known to be correct." +$nl +"You can create your own reference image after you verify that the image has been correctly decoded:" +{ $subsections + save-as-reference-image + save-all-as-reference-images +} +"A reference image can be loaded by the path of the original image:" +{ $subsections load-reference-image } +; + +ARTICLE: "images.testing" "Testing image encoders and decoders" +"The " { $vocab-link "images.testing" } " vocab facilitates writing unit tests for image encoders and decoders by providing common functionality" +$nl +"Creating a unit test:" +{ $subsections + decode-test + encode-test +} +"Establishing a " { $link { "images" "testing" "reference" } } ":" +{ $subsections save-as-reference-image } +"You should only create a reference image after you manually verify that your decoder is generating a valid " { $link image } " object and that it renders correctly to the screen. The following words are useful for manual verification:" +{ $subsections + image. + images. +} +"Helpful words for writing potentially tedious unit tests for each image file under test:" +{ $subsections + save-all-as-reference-images + ls + with-matching-files +} +{ $notes "This vocabulary is only intended for implementors of image encoders and image decoders. If you are an end-user, you are in the wrong place :-)" } +; + +ABOUT: "images.testing" diff --git a/basis/images/testing/testing.factor b/basis/images/testing/testing.factor new file mode 100644 index 0000000000..538f098df5 --- /dev/null +++ b/basis/images/testing/testing.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2009 Keith Lazuka. +! See http://factorcode.org/license.txt for BSD license. +USING: fry images.loader images.normalization images.viewer io +io.directories io.encodings.binary io.files io.pathnames +io.streams.byte-array kernel locals namespaces quotations +sequences serialize tools.test ; +IN: images.testing + +<PRIVATE + +: fig-name ( path -- newpath ) + [ parent-directory canonicalize-path ] + [ file-stem ".fig" append ] bi + append-path ; + +PRIVATE> + +:: with-matching-files ( dirpath extension quot -- ) + dirpath [ + [ + dup file-extension extension = quot [ drop ] if + ] each + ] with-directory-files ; inline + +: images. ( dirpath extension -- ) + [ image. ] with-matching-files ; + +: ls ( dirpath extension -- ) + [ "\"" dup surround print ] with-matching-files ; + +: save-as-reference-image ( path -- ) + [ load-image ] [ fig-name ] bi + binary [ serialize ] with-file-writer ; + +: save-all-as-reference-images ( dirpath extension -- ) + [ save-as-reference-image ] with-matching-files ; + +: load-reference-image ( path -- image ) + fig-name binary [ deserialize ] with-file-reader ; + +:: encode-test ( path image-class -- ) + f verbose-tests? [ + path load-image dup clone normalize-image 1quotation swap + '[ + binary [ _ image-class image>stream ] with-byte-writer + image-class load-image* normalize-image + ] unit-test + ] with-variable ; + +: decode-test ( path -- ) + f verbose-tests? [ + [ load-image 1quotation ] + [ '[ _ load-reference-image ] ] bi + unit-test + ] with-variable ; diff --git a/basis/images/testing/tiff/alpha.fig b/basis/images/testing/tiff/alpha.fig new file mode 100644 index 0000000000..b36a8f6666 Binary files /dev/null and b/basis/images/testing/tiff/alpha.fig differ diff --git a/basis/images/testing/tiff/alpha.tiff b/basis/images/testing/tiff/alpha.tiff new file mode 100644 index 0000000000..27215d6f0f Binary files /dev/null and b/basis/images/testing/tiff/alpha.tiff differ diff --git a/basis/images/testing/tiff/color_spectrum.fig b/basis/images/testing/tiff/color_spectrum.fig new file mode 100644 index 0000000000..7050c13f6c Binary files /dev/null and b/basis/images/testing/tiff/color_spectrum.fig differ diff --git a/basis/images/testing/tiff/color_spectrum.tiff b/basis/images/testing/tiff/color_spectrum.tiff new file mode 100644 index 0000000000..f596deb0f2 Binary files /dev/null and b/basis/images/testing/tiff/color_spectrum.tiff differ diff --git a/basis/images/testing/tiff/elephants.tiff b/basis/images/testing/tiff/elephants.tiff new file mode 100644 index 0000000000..f462a0c043 Binary files /dev/null and b/basis/images/testing/tiff/elephants.tiff differ diff --git a/basis/images/testing/tiff/noise.fig b/basis/images/testing/tiff/noise.fig new file mode 100644 index 0000000000..dd582aaef3 Binary files /dev/null and b/basis/images/testing/tiff/noise.fig differ diff --git a/basis/images/testing/tiff/noise.tiff b/basis/images/testing/tiff/noise.tiff new file mode 100644 index 0000000000..2958b0b838 Binary files /dev/null and b/basis/images/testing/tiff/noise.tiff differ diff --git a/basis/images/testing/tiff/octagon.fig b/basis/images/testing/tiff/octagon.fig new file mode 100644 index 0000000000..0b66c62662 Binary files /dev/null and b/basis/images/testing/tiff/octagon.fig differ diff --git a/basis/images/testing/tiff/octagon.tiff b/basis/images/testing/tiff/octagon.tiff new file mode 100644 index 0000000000..2b4ba3950d Binary files /dev/null and b/basis/images/testing/tiff/octagon.tiff differ diff --git a/basis/images/testing/tiff/rgb.fig b/basis/images/testing/tiff/rgb.fig new file mode 100644 index 0000000000..c09b1cd10e Binary files /dev/null and b/basis/images/testing/tiff/rgb.fig differ diff --git a/basis/images/testing/tiff/rgb.tiff b/basis/images/testing/tiff/rgb.tiff new file mode 100755 index 0000000000..71cbaa9d6e Binary files /dev/null and b/basis/images/testing/tiff/rgb.tiff differ diff --git a/basis/images/tiff/tiff-tests.factor b/basis/images/tiff/tiff-tests.factor index 9905e7ad79..b0a036ae49 100755 --- a/basis/images/tiff/tiff-tests.factor +++ b/basis/images/tiff/tiff-tests.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test images.tiff ; +USING: images.testing ; IN: images.tiff.tests -: tiff-test-path ( -- path ) - "resource:extra/images/test-images/rgb.tiff" ; - -: tiff-test-path2 ( -- path ) - "resource:extra/images/test-images/octagon.tiff" ; +"vocab:images/testing/tiff/octagon.tiff" decode-test +! "vocab:images/testing/tiff/elephants.tiff" decode-test +"vocab:images/testing/tiff/noise.tiff" decode-test +"vocab:images/testing/tiff/alpha.tiff" decode-test +"vocab:images/testing/tiff/color_spectrum.tiff" decode-test +"vocab:images/testing/tiff/rgb.tiff" decode-test diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index c589349dff..4a82545d79 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -7,6 +7,7 @@ io.encodings.string io.encodings.utf8 io.files kernel math math.bitwise math.order math.parser pack prettyprint sequences strings math.vectors specialized-arrays locals images.loader ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: images.tiff @@ -437,7 +438,7 @@ ERROR: unhandled-compression compression ; : (uncompress-strips) ( strips compression -- uncompressed-strips ) { { compression-none [ ] } - { compression-lzw [ [ lzw-uncompress ] map ] } + { compression-lzw [ [ tiff-lzw-uncompress ] map ] } [ unhandled-compression ] } case ; @@ -555,7 +556,7 @@ ERROR: unknown-component-order ifd ; : process-tif-ifds ( loading-tiff -- ) ifds>> [ process-ifd ] each ; -: load-tiff ( path -- loading-tiff ) +: load-tiff ( stream -- loading-tiff ) [ load-tiff-ifds dup ] [ [ [ 0 seek-absolute ] dip stream-seek ] diff --git a/basis/inspector/inspector-docs.factor b/basis/inspector/inspector-docs.factor index 60a1fb274b..c3e9482020 100644 --- a/basis/inspector/inspector-docs.factor +++ b/basis/inspector/inspector-docs.factor @@ -6,19 +6,21 @@ ARTICLE: "inspector" "The inspector" "The inspector displays a tabular view of an object and adds navigation and editing features. Inspector words are found in the " { $vocab-link "inspector" } " vocabulary." $nl "Starting the inspector:" -{ $subsection inspect } +{ $subsections inspect } "The inspector supports a number of commands which operate on the most recently inspected object:" -{ $subsection &push } -{ $subsection &back } -{ $subsection &at } -{ $subsection &put } -{ $subsection &add } -{ $subsection &rename } -{ $subsection &delete } +{ $subsections + &push + &back + &at + &put + &add + &rename + &delete +} "A variable holding the current object:" -{ $subsection me } +{ $subsections me } "A description of an object can be printed without starting the inspector:" -{ $subsection describe } ; +{ $subsections describe } ; ABOUT: "inspector" diff --git a/basis/inspector/inspector-tests.factor b/basis/inspector/inspector-tests.factor index 3f3e7f13df..9be32a2240 100644 --- a/basis/inspector/inspector-tests.factor +++ b/basis/inspector/inspector-tests.factor @@ -8,7 +8,7 @@ f describe H{ } describe H{ } describe -[ "fixnum instance\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test +[ "fixnum\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test [ ] [ H{ } clone inspect ] unit-test diff --git a/basis/interval-maps/interval-maps-docs.factor b/basis/interval-maps/interval-maps-docs.factor index 0d5e471bff..64fc40d4b9 100644 --- a/basis/interval-maps/interval-maps-docs.factor +++ b/basis/interval-maps/interval-maps-docs.factor @@ -31,12 +31,16 @@ ARTICLE: "interval-maps" "Interval maps" "The " { $vocab-link "interval-maps" } " vocabulary implements a data structure, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between." $nl "The following operations are used to query interval maps:" -{ $subsection interval-at* } -{ $subsection interval-at } -{ $subsection interval-key? } -{ $subsection interval-values } +{ $subsections + interval-at* + interval-at + interval-key? + interval-values +} "Use the following to construct interval maps" -{ $subsection <interval-map> } -{ $subsection coalesce } ; +{ $subsections + <interval-map> + coalesce +} ; ABOUT: "interval-maps" diff --git a/basis/inverse/inverse-docs.factor b/basis/inverse/inverse-docs.factor index 6b575d6d08..961409a11d 100644 --- a/basis/inverse/inverse-docs.factor +++ b/basis/inverse/inverse-docs.factor @@ -50,14 +50,18 @@ HELP: switch ARTICLE: { "inverse" "intro" } "Invertible quotations" "The inverse vocab defines a way to 'undo' quotations, and builds a pattern matching framework on that basis. A quotation can be inverted by reversing it and inverting each word. To define the inverse for particular word, use" -{ $subsection define-inverse } -{ $subsection define-pop-inverse } +{ $subsections + define-inverse + define-pop-inverse +} "To build an inverse quotation" -{ $subsection [undo] } +{ $subsections [undo] } "To use the inverse quotation for pattern matching" -{ $subsection undo } -{ $subsection matches? } -{ $subsection switch } ; +{ $subsections + undo + matches? + switch +} ; IN: inverse ABOUT: { "inverse" "intro" } diff --git a/basis/io/backend/unix/multiplexers/authors.txt b/basis/io/backend/unix/multiplexers/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/basis/io/backend/unix/multiplexers/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/backend/unix/multiplexers/tags.txt b/basis/io/backend/unix/multiplexers/tags.txt new file mode 100755 index 0000000000..6abe115b12 --- /dev/null +++ b/basis/io/backend/unix/multiplexers/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 4b7ef4b40f..ebb8f1ec05 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -49,6 +49,9 @@ M: fd cancel-operation ( fd -- ) 2bi ] if ; +M: unix tell-handle ( handle -- n ) + fd>> 0 SEEK_CUR lseek [ io-error ] [ ] bi ; + M: unix seek-handle ( n seek-type handle -- ) swap { { io:seek-absolute [ SEEK_SET ] } diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 217ce7b31e..452dc4a409 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -91,6 +91,8 @@ ERROR: seek-before-start n ; : set-seek-ptr ( n handle -- ) [ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ; +M: winnt tell-handle ( handle -- n ) ptr>> ; + M: winnt seek-handle ( n seek-type handle -- ) swap { { seek-absolute [ set-seek-ptr ] } diff --git a/basis/io/buffers/buffers-docs.factor b/basis/io/buffers/buffers-docs.factor index 5ab25b9c31..8a233337f0 100644 --- a/basis/io/buffers/buffers-docs.factor +++ b/basis/io/buffers/buffers-docs.factor @@ -9,24 +9,32 @@ $nl "Buffers are used to implement native I/O backends." $nl "Buffer words are found in the " { $vocab-link "io.buffers" } " vocabulary." -{ $subsection buffer } -{ $subsection <buffer> } +{ $subsections + buffer + <buffer> +} "Buffers must be manually deallocated by calling " { $link dispose } "." $nl "Buffer operations:" -{ $subsection buffer-reset } -{ $subsection buffer-length } -{ $subsection buffer-empty? } -{ $subsection buffer-capacity } -{ $subsection buffer@ } +{ $subsections + buffer-reset + buffer-length + buffer-empty? + buffer-capacity + buffer@ +} "Reading from the buffer:" -{ $subsection buffer-peek } -{ $subsection buffer-pop } -{ $subsection buffer-read } +{ $subsections + buffer-peek + buffer-pop + buffer-read +} "Writing to the buffer:" -{ $subsection byte>buffer } -{ $subsection >buffer } -{ $subsection n>buffer } ; +{ $subsections + byte>buffer + >buffer + n>buffer +} ; ABOUT: "buffers" diff --git a/basis/io/directories/directories-docs.factor b/basis/io/directories/directories-docs.factor index 7318df9cac..36b46e19ee 100644 --- a/basis/io/directories/directories-docs.factor +++ b/basis/io/directories/directories-docs.factor @@ -112,26 +112,34 @@ HELP: copy-files-into ARTICLE: "current-directory" "Current working directory" "File system I/O operations use the value of a variable to resolve relative pathnames:" -{ $subsection current-directory } +{ $subsections current-directory } "This variable can be changed with a pair of words:" -{ $subsection set-current-directory } -{ $subsection with-directory } +{ $subsections + set-current-directory + with-directory +} "This variable is independent of the operating system notion of âcurrent working directoryâ. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:" -{ $subsection (normalize-path) } +{ $subsections (normalize-path) } "The second is to change the working directory of the current process:" -{ $subsection cd } -{ $subsection cwd } ; +{ $subsections + cd + cwd +} ; ARTICLE: "io.directories.listing" "Directory listing" "Directory listing:" -{ $subsection directory-entries } -{ $subsection directory-files } -{ $subsection with-directory-entries } -{ $subsection with-directory-files } ; +{ $subsections + directory-entries + directory-files + with-directory-entries + with-directory-files +} ; ARTICLE: "io.directories.create" "Creating directories" -{ $subsection make-directory } -{ $subsection make-directories } ; +{ $subsections + make-directory + make-directories +} ; ARTICLE: "delete-move-copy" "Deleting, moving, and copying files" "Operations for deleting and copying files come in two forms:" @@ -148,25 +156,33 @@ ARTICLE: "delete-move-copy" "Deleting, moving, and copying files" "Since both of the above lists apply to copying files, that this means that there are a total of six variations on copying a file." $nl "Deleting files:" -{ $subsection delete-file } -{ $subsection delete-directory } +{ $subsections + delete-file + delete-directory +} "Moving files:" -{ $subsection move-file } -{ $subsection move-file-into } -{ $subsection move-files-into } +{ $subsections + move-file + move-file-into + move-files-into +} "Copying files:" -{ $subsection copy-file } -{ $subsection copy-file-into } -{ $subsection copy-files-into } +{ $subsections + copy-file + copy-file-into + copy-files-into +} "On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ; ARTICLE: "io.directories" "Directory manipulation" "The " { $vocab-link "io.directories" } " vocabulary defines words for inspecting and manipulating directory trees." -{ $subsection home } -{ $subsection "current-directory" } -{ $subsection "io.directories.listing" } -{ $subsection "io.directories.create" } -{ $subsection "delete-move-copy" } -{ $subsection "io.directories.hierarchy" } ; +{ $subsections + home + "current-directory" + "io.directories.listing" + "io.directories.create" + "delete-move-copy" + "io.directories.hierarchy" +} ; ABOUT: "io.directories" diff --git a/basis/io/directories/hierarchy/hierarchy-docs.factor b/basis/io/directories/hierarchy/hierarchy-docs.factor index 8b3ca7391d..741adbb3dd 100644 --- a/basis/io/directories/hierarchy/hierarchy-docs.factor +++ b/basis/io/directories/hierarchy/hierarchy-docs.factor @@ -27,10 +27,12 @@ ARTICLE: "io.directories.hierarchy" "Directory hierarchy manipulation" "The " { $vocab-link "io.directories.hierarchy" } " vocabulary defines words for operating on directory hierarchies recursively." $nl "Deleting directory trees recursively:" -{ $subsection delete-tree } +{ $subsections delete-tree } "Copying directory trees recursively:" -{ $subsection copy-tree } -{ $subsection copy-tree-into } -{ $subsection copy-trees-into } ; +{ $subsections + copy-tree + copy-tree-into + copy-trees-into +} ; ABOUT: "io.directories.hierarchy" diff --git a/basis/io/directories/search/search-docs.factor b/basis/io/directories/search/search-docs.factor index 6bfaa07227..4f7e0ba212 100644 --- a/basis/io/directories/search/search-docs.factor +++ b/basis/io/directories/search/search-docs.factor @@ -88,16 +88,22 @@ HELP: find-by-extensions ARTICLE: "io.directories.search" "Searching directories" "The " { $vocab-link "io.directories.search" } " vocabulary contains words used for recursively iterating over a directory and for finding files in a directory tree." $nl "Traversing directories:" -{ $subsection recursive-directory-files } -{ $subsection recursive-directory-entries } -{ $subsection each-file } +{ $subsections + recursive-directory-files + recursive-directory-entries + each-file +} "Finding files by name:" -{ $subsection find-file } -{ $subsection find-all-files } -{ $subsection find-in-directories } -{ $subsection find-all-in-directories } +{ $subsections + find-file + find-all-files + find-in-directories + find-all-in-directories +} "Finding files by extension:" -{ $subsection find-by-extension } -{ $subsection find-by-extensions } ; +{ $subsections + find-by-extension + find-by-extensions +} ; ABOUT: "io.directories.search" diff --git a/basis/io/encodings/8-bit/8-bit-docs.factor b/basis/io/encodings/8-bit/8-bit-docs.factor index 9ba4fcf44d..203d7c187f 100644 --- a/basis/io/encodings/8-bit/8-bit-docs.factor +++ b/basis/io/encodings/8-bit/8-bit-docs.factor @@ -6,25 +6,27 @@ IN: io.encodings.8-bit ARTICLE: "io.encodings.8-bit" "Legacy 8-bit encodings" "Many encodings are a simple mapping of bytes onto characters. The " { $vocab-link "io.encodings.8-bit" } " vocabulary implements these generically using existing resource files. These encodings should be used with extreme caution, as fully general Unicode encodings like UTF-8 are nearly always more appropriate. The following 8-bit encodings are already defined:" -{ $subsection latin1 } -{ $subsection latin2 } -{ $subsection latin3 } -{ $subsection latin4 } -{ $subsection latin/cyrillic } -{ $subsection latin/arabic } -{ $subsection latin/greek } -{ $subsection latin/hebrew } -{ $subsection latin5 } -{ $subsection latin6 } -{ $subsection latin/thai } -{ $subsection latin7 } -{ $subsection latin8 } -{ $subsection latin9 } -{ $subsection latin10 } -{ $subsection koi8-r } -{ $subsection windows-1252 } -{ $subsection ebcdic } -{ $subsection mac-roman } ; +{ $subsections + latin1 + latin2 + latin3 + latin4 + latin/cyrillic + latin/arabic + latin/greek + latin/hebrew + latin5 + latin6 + latin/thai + latin7 + latin8 + latin9 + latin10 + koi8-r + windows-1252 + ebcdic + mac-roman +} ; ABOUT: "io.encodings.8-bit" diff --git a/basis/io/encodings/ascii/ascii-docs.factor b/basis/io/encodings/ascii/ascii-docs.factor index e0ab11f1a4..0d7237b1fc 100644 --- a/basis/io/encodings/ascii/ascii-docs.factor +++ b/basis/io/encodings/ascii/ascii-docs.factor @@ -6,6 +6,6 @@ HELP: ascii ARTICLE: "io.encodings.ascii" "ASCII encoding" "By default, if there's a non-ASCII character in an input stream, it will be replaced with a replacement character (U+FFFD), and if a non-ASCII character is used in output, an exception is thrown." -{ $subsection ascii } ; +{ $subsections ascii } ; ABOUT: "io.encodings.ascii" diff --git a/basis/io/encodings/binary/binary-docs.factor b/basis/io/encodings/binary/binary-docs.factor index 4da1e0811f..14908c3903 100644 --- a/basis/io/encodings/binary/binary-docs.factor +++ b/basis/io/encodings/binary/binary-docs.factor @@ -6,6 +6,6 @@ HELP: binary ARTICLE: "io.encodings.binary" "Binary encoding" "Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." -{ $subsection binary } ; +{ $subsections binary } ; ABOUT: "io.encodings.binary" diff --git a/basis/io/encodings/euc-kr/euc-kr-docs.factor b/basis/io/encodings/euc-kr/euc-kr-docs.factor index 60cd41ac57..2abe804a56 100644 --- a/basis/io/encodings/euc-kr/euc-kr-docs.factor +++ b/basis/io/encodings/euc-kr/euc-kr-docs.factor @@ -8,6 +8,6 @@ HELP: euc-kr { $see-also "encodings-introduction" } ; ARTICLE: "io.encodings.euc-kr" "EUC-KR encoding" -{ $subsection euc-kr } ; +{ $subsections euc-kr } ; ABOUT: "io.encodings.euc-kr" \ No newline at end of file diff --git a/basis/io/encodings/gb18030/gb18030-docs.factor b/basis/io/encodings/gb18030/gb18030-docs.factor index 3f5a7618f4..83202ebdc0 100644 --- a/basis/io/encodings/gb18030/gb18030-docs.factor +++ b/basis/io/encodings/gb18030/gb18030-docs.factor @@ -5,7 +5,7 @@ IN: io.encodings.gb18030 ARTICLE: "io.encodings.gb18030" "GB 18030" "The " { $vocab-link "io.encodings.gb18030" } " vocabulary implements GB18030, a commonly used encoding for Chinese text besides the standard UTF encodings for Unicode strings." -{ $subsection gb18030 } ; +{ $subsections gb18030 } ; ABOUT: "io.encodings.gb18030" diff --git a/basis/io/encodings/iana/iana-docs.factor b/basis/io/encodings/iana/iana-docs.factor index 628bceac62..d6ce4fb2fb 100644 --- a/basis/io/encodings/iana/iana-docs.factor +++ b/basis/io/encodings/iana/iana-docs.factor @@ -6,10 +6,12 @@ ABOUT: "io.encodings.iana" ARTICLE: "io.encodings.iana" "IANA-registered encoding names" "The " { $vocab-link "io.encodings.iana" } " vocabulary provides words for accessing the names of encodings and the encoding descriptors corresponding to names." $nl "Most text encodings in common use have been registered with IANA. There is a standard set of names for each encoding. Simple conversion functions:" -{ $subsection name>encoding } -{ $subsection encoding>name } +{ $subsections + name>encoding + encoding>name +} "To let a new encoding be used with the above words, use the following:" -{ $subsection register-encoding } ; +{ $subsections register-encoding } ; HELP: name>encoding { $values { "name" "an encoding name" } { "encoding" "an encoding descriptor" } } diff --git a/basis/io/encodings/iso2022/iso2022-docs.factor b/basis/io/encodings/iso2022/iso2022-docs.factor index 7e21dd6e50..4655f7b037 100644 --- a/basis/io/encodings/iso2022/iso2022-docs.factor +++ b/basis/io/encodings/iso2022/iso2022-docs.factor @@ -8,6 +8,6 @@ HELP: iso2022 { $see-also "encodings-introduction" } ; ARTICLE: "io.encodings.iso2022" "ISO 2022-JP-1 encoding" -{ $subsection iso2022 } ; +{ $subsections iso2022 } ; ABOUT: "io.encodings.iso2022" diff --git a/basis/io/encodings/johab/johab-docs.factor b/basis/io/encodings/johab/johab-docs.factor index d2eac30b25..c94f464354 100644 --- a/basis/io/encodings/johab/johab-docs.factor +++ b/basis/io/encodings/johab/johab-docs.factor @@ -7,6 +7,6 @@ HELP: johab { $class-description "Korean Johab encoding (KSC5601-1992). This encoding is not commonly used anymore." } ; ARTICLE: "io.encodings.johab" "Korean Johab encoding" -{ $subsection johab } ; +{ $subsections johab } ; ABOUT: "io.encodings.johab" \ No newline at end of file diff --git a/basis/io/encodings/shift-jis/shift-jis-docs.factor b/basis/io/encodings/shift-jis/shift-jis-docs.factor index 938e3a18df..b8f5603200 100644 --- a/basis/io/encodings/shift-jis/shift-jis-docs.factor +++ b/basis/io/encodings/shift-jis/shift-jis-docs.factor @@ -5,8 +5,10 @@ IN: io.encodings.shift-jis ARTICLE: "io.encodings.shift-jis" "Shift JIS" "Shift JIS is a text encoding for Japanese. There are multiple versions, depending on whether the offical standard or the modified Microsoft version is required." -{ $subsection shift-jis } -{ $subsection windows-31j } ; +{ $subsections + shift-jis + windows-31j +} ; ABOUT: "io.encodings.shift-jis" diff --git a/basis/io/encodings/string/string-docs.factor b/basis/io/encodings/string/string-docs.factor index dc0f547301..0fbd753266 100644 --- a/basis/io/encodings/string/string-docs.factor +++ b/basis/io/encodings/string/string-docs.factor @@ -6,8 +6,10 @@ IN: io.encodings.string ARTICLE: "io.encodings.string" "Encoding and decoding strings" "Strings can be encoded or decoded to and from byte arrays through an encoding by passing " { $link "encodings-descriptors" } " to the following words:" -{ $subsection encode } -{ $subsection decode } ; +{ $subsections + encode + decode +} ; HELP: decode { $values { "byte-array" byte-array } { "encoding" "an encoding descriptor" } diff --git a/basis/io/encodings/utf32/utf32-docs.factor b/basis/io/encodings/utf32/utf32-docs.factor index 8cdb2ef1e5..933218012d 100644 --- a/basis/io/encodings/utf32/utf32-docs.factor +++ b/basis/io/encodings/utf32/utf32-docs.factor @@ -5,9 +5,11 @@ IN: io.encodings.utf32 ARTICLE: "io.encodings.utf32" "UTF-32 encoding" "The UTF-32 encoding is a fixed-width encoding. Unicode code points are encoded as 4 byte sequences. There are three encoding descriptor classes for working with UTF-32, depending on endianness or the presence of a BOM:" -{ $subsection utf32 } -{ $subsection utf32le } -{ $subsection utf32be } ; +{ $subsections + utf32 + utf32le + utf32be +} ; ABOUT: "io.encodings.utf32" diff --git a/basis/io/files/info/info-docs.factor b/basis/io/files/info/info-docs.factor index 8db780f976..aaeb92d9c2 100644 --- a/basis/io/files/info/info-docs.factor +++ b/basis/io/files/info/info-docs.factor @@ -28,14 +28,18 @@ HELP: file-system-info ARTICLE: "io.files.info" "File system meta-data" "File meta-data:" -{ $subsection file-info } -{ $subsection link-info } -{ $subsection exists? } -{ $subsection directory? } +{ $subsections + file-info + link-info + exists? + directory? +} "File types:" -{ $subsection "file-types" } +{ $subsections "file-types" } "File system meta-data:" -{ $subsection file-system-info } -{ $subsection file-systems } ; +{ $subsections + file-system-info + file-systems +} ; ABOUT: "io.files.info" diff --git a/basis/io/files/info/unix/unix-docs.factor b/basis/io/files/info/unix/unix-docs.factor index a6ee2b9597..62837dae7e 100644 --- a/basis/io/files/info/unix/unix-docs.factor +++ b/basis/io/files/info/unix/unix-docs.factor @@ -215,63 +215,73 @@ HELP: user-write? ARTICLE: "unix-file-permissions" "Unix file permissions" "Reading all file permissions:" -{ $subsection file-permissions } +{ $subsections file-permissions } "Reading individual file permissions:" -{ $subsection uid? } -{ $subsection gid? } -{ $subsection sticky? } -{ $subsection user-read? } -{ $subsection user-write? } -{ $subsection user-execute? } -{ $subsection group-read? } -{ $subsection group-write? } -{ $subsection group-execute? } -{ $subsection other-read? } -{ $subsection other-write? } -{ $subsection other-execute? } +{ $subsections + uid? + gid? + sticky? + user-read? + user-write? + user-execute? + group-read? + group-write? + group-execute? + other-read? + other-write? + other-execute? +} "Writing all file permissions:" -{ $subsection set-file-permissions } +{ $subsections set-file-permissions } "Writing individual file permissions:" -{ $subsection set-uid } -{ $subsection set-gid } -{ $subsection set-sticky } -{ $subsection set-user-read } -{ $subsection set-user-write } -{ $subsection set-user-execute } -{ $subsection set-group-read } -{ $subsection set-group-write } -{ $subsection set-group-execute } -{ $subsection set-other-read } -{ $subsection set-other-write } -{ $subsection set-other-execute } ; +{ $subsections + set-uid + set-gid + set-sticky + set-user-read + set-user-write + set-user-execute + set-group-read + set-group-write + set-group-execute + set-other-read + set-other-write + set-other-execute +} ; ARTICLE: "unix-file-timestamps" "Unix file timestamps" "To read file times, use the accessors on the object returned by the " { $link file-info } " word." $nl "Setting multiple file times:" -{ $subsection set-file-times } +{ $subsections set-file-times } "Setting just the last access time:" -{ $subsection set-file-access-time } +{ $subsections set-file-access-time } "Setting just the last modified time:" -{ $subsection set-file-modified-time } ; +{ $subsections set-file-modified-time } ; ARTICLE: "unix-file-ids" "Unix file user and group ids" "Reading file user data:" -{ $subsection file-user-id } -{ $subsection file-user-name } +{ $subsections + file-user-id + file-user-name +} "Setting file user data:" -{ $subsection set-file-user } +{ $subsections set-file-user } "Reading file group data:" -{ $subsection file-group-id } -{ $subsection file-group-name } +{ $subsections + file-group-id + file-group-name +} "Setting file group data:" -{ $subsection set-file-group } ; +{ $subsections set-file-group } ; ARTICLE: "io.files.info.unix" "Unix file attributes" "The " { $vocab-link "io.files.info.unix" } " vocabulary implements a high-level way to set Unix-specific permissions, timestamps, and user and group IDs for files." -{ $subsection "unix-file-permissions" } -{ $subsection "unix-file-timestamps" } -{ $subsection "unix-file-ids" } ; +{ $subsections + "unix-file-permissions" + "unix-file-timestamps" + "unix-file-ids" +} ; ABOUT: "io.files.info.unix" diff --git a/basis/io/files/links/links-docs.factor b/basis/io/files/links/links-docs.factor index bf1bedaa08..4590fe5c35 100644 --- a/basis/io/files/links/links-docs.factor +++ b/basis/io/files/links/links-docs.factor @@ -47,13 +47,15 @@ HELP: too-many-symlinks ARTICLE: "io.files.links" "Symbolic links" "Reading links:" -{ $subsection read-link } -{ $subsection follow-link } -{ $subsection follow-links } +{ $subsections + read-link + follow-link + follow-links +} "Creating links:" -{ $subsection make-link } +{ $subsections make-link } "Copying links:" -{ $subsection copy-link } +{ $subsections copy-link } "Not all operating systems support symbolic links." { $see-also link-info } ; diff --git a/basis/io/files/temp/temp-docs.factor b/basis/io/files/temp/temp-docs.factor index e9f49283de..f67788fa3e 100644 --- a/basis/io/files/temp/temp-docs.factor +++ b/basis/io/files/temp/temp-docs.factor @@ -3,7 +3,9 @@ IN: io.files.temp ARTICLE: "io.files.temp" "Temporary files" "Pathnames relative to Factor's temporary files directory:" -{ $subsection temp-directory } -{ $subsection temp-file } ; +{ $subsections + temp-directory + temp-file +} ; ABOUT: "io.files.temp" diff --git a/basis/io/files/types/types-docs.factor b/basis/io/files/types/types-docs.factor index a6402851ea..384d587aae 100644 --- a/basis/io/files/types/types-docs.factor +++ b/basis/io/files/types/types-docs.factor @@ -27,14 +27,18 @@ HELP: +unknown+ ARTICLE: "file-types" "File types" "Platform-independent types:" -{ $subsection +regular-file+ } -{ $subsection +directory+ } +{ $subsections + +regular-file+ + +directory+ +} "Platform-specific types:" -{ $subsection +character-device+ } -{ $subsection +block-device+ } -{ $subsection +fifo+ } -{ $subsection +symbolic-link+ } -{ $subsection +socket+ } -{ $subsection +unknown+ } ; +{ $subsections + +character-device+ + +block-device+ + +fifo+ + +symbolic-link+ + +socket+ + +unknown+ +} ; ABOUT: "file-types" diff --git a/basis/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor index 6a7be47813..11511732b0 100644 --- a/basis/io/files/unique/unique-docs.factor +++ b/basis/io/files/unique/unique-docs.factor @@ -76,16 +76,20 @@ HELP: with-temporary-directory ARTICLE: "io.files.unique" "Unique files" "The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform unique file creation in temporary directories in a high-level and secure way." $nl "Changing the temporary path:" -{ $subsection current-temporary-directory } +{ $subsections current-temporary-directory } "Creating unique files:" -{ $subsection unique-file } -{ $subsection cleanup-unique-file } -{ $subsection make-unique-file } +{ $subsections + unique-file + cleanup-unique-file + make-unique-file +} "Creating unique directories:" -{ $subsection unique-directory } -{ $subsection with-unique-directory } -{ $subsection cleanup-unique-directory } +{ $subsections + unique-directory + with-unique-directory + cleanup-unique-directory +} "Default temporary directory:" -{ $subsection default-temporary-directory } ; +{ $subsections default-temporary-directory } ; ABOUT: "io.files.unique" diff --git a/basis/io/launcher/launcher-docs.factor b/basis/io/launcher/launcher-docs.factor index f20e65dc27..cf74113506 100644 --- a/basis/io/launcher/launcher-docs.factor +++ b/basis/io/launcher/launcher-docs.factor @@ -9,15 +9,17 @@ ARTICLE: "io.launcher.command" "Specifying a command" ARTICLE: "io.launcher.detached" "Running processes in the background" "By default, " { $link run-process } " waits for the process to complete. To run a process without waiting for it to finish, set the " { $snippet "detached" } " slot of a " { $link process } ", or use the following word:" -{ $subsection run-detached } ; +{ $subsections run-detached } ; ARTICLE: "io.launcher.environment" "Setting environment variables" "The " { $snippet "environment" } " slot of a " { $link process } " contains an association mapping environment variable names to values. The interpretation of environment variables is operating system-specific." $nl "The " { $snippet "environment-mode" } " slot controls how the environment of the current Factor instance is composed with the value of the " { $snippet "environment" } " slot:" -{ $subsection +prepend-environment+ } -{ $subsection +replace-environment+ } -{ $subsection +append-environment+ } +{ $subsections + +prepend-environment+ + +replace-environment+ + +append-environment+ +} "The default value is " { $link +append-environment+ } "." ; ARTICLE: "io.launcher.redirection" "Input/output redirection" @@ -195,30 +197,38 @@ $nl ARTICLE: "io.launcher.lifecycle" "The process lifecycle" "A freshly instantiated " { $link process } " represents a set of launch parameters." -{ $subsection process } -{ $subsection <process> } +{ $subsections + process + <process> +} "Words for launching processes take a fresh process which has never been started before as input, and output a copy as output." -{ $subsection process-started? } +{ $subsections process-started? } "The " { $link process } " instance output by launching words contains all original slot values in addition to the " { $snippet "handle" } " slot, which indicates the process is currently running." -{ $subsection process-running? } +{ $subsections process-running? } "It is possible to wait for a process to exit:" -{ $subsection wait-for-process } +{ $subsections wait-for-process } "A running process can also be killed:" -{ $subsection kill-process } ; +{ $subsections kill-process } ; ARTICLE: "io.launcher.launch" "Launching processes" "Launching processes:" -{ $subsection run-process } -{ $subsection try-process } -{ $subsection run-detached } +{ $subsections + run-process + try-process + run-detached +} "Redirecting standard input and output to a pipe:" -{ $subsection <process-reader> } -{ $subsection <process-writer> } -{ $subsection <process-stream> } +{ $subsections + <process-reader> + <process-writer> + <process-stream> +} "Combinators built on top of the above:" -{ $subsection with-process-reader } -{ $subsection with-process-writer } -{ $subsection with-process-stream } ; +{ $subsections + with-process-reader + with-process-writer + with-process-stream +} ; ARTICLE: "io.launcher.examples" "Launcher examples" "Starting a command and waiting for it to finish:" @@ -260,16 +270,20 @@ ARTICLE: "io.launcher.examples" "Launcher examples" ARTICLE: "io.launcher" "Operating system processes" "The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching." -{ $subsection "io.launcher.examples" } -{ $subsection "io.launcher.descriptors" } -{ $subsection "io.launcher.launch" } +{ $subsections + "io.launcher.examples" + "io.launcher.descriptors" + "io.launcher.launch" +} "Advanced topics:" -{ $subsection "io.launcher.lifecycle" } -{ $subsection "io.launcher.command" } -{ $subsection "io.launcher.detached" } -{ $subsection "io.launcher.environment" } -{ $subsection "io.launcher.redirection" } -{ $subsection "io.launcher.priority" } -{ $subsection "io.launcher.timeouts" } ; +{ $subsections + "io.launcher.lifecycle" + "io.launcher.command" + "io.launcher.detached" + "io.launcher.environment" + "io.launcher.redirection" + "io.launcher.priority" + "io.launcher.timeouts" +} ; ABOUT: "io.launcher" diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index 1da82e42e2..fe16e08467 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -1,5 +1,6 @@ -USING: help.markup help.syntax alien math continuations -destructors ; +USING: alien alien.c-types continuations destructors +help.markup help.syntax kernel math quotations +specialized-arrays ; IN: io.mmap HELP: mapped-file @@ -25,7 +26,7 @@ HELP: with-mapped-file HELP: with-mapped-file-reader { $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } { $contract "Opens a file for read-only access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } -{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." } +{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. See " { $link "io.mmap.arrays" } " for a discussion of how to access data in a mapped file." } { $errors "Throws an error if a memory mapping could not be established." } ; HELP: close-mapped-file @@ -33,51 +34,81 @@ HELP: close-mapped-file { $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." } { $errors "Throws an error if a memory mapping could not be established." } ; -ARTICLE: "io.mmap.arrays" "Memory-mapped arrays" -"Mapped file can be viewed as a sequence using the words in sub-vocabularies of " { $vocab-link "io.mmap" } ". For each primitive C type " { $snippet "T" } ", a set of words are defined in the vocabulary named " { $snippet "io.mmap.T" } ":" -{ $table - { { $snippet "<mapped-T-array>" } { "Wraps a " { $link mapped-file } " in a sequence; stack effect " { $snippet "( mapped-file -- direct-array )" } } } - { { $snippet "with-mapped-T-file" } { "Maps a file into memory and wraps it in a sequence by combining " { $link with-mapped-file } " and " { $snippet "<mapped-T-array>" } "; stack effect " { $snippet "( path quot -- )" } } } +HELP: <mapped-file-reader> +{ $values { "path" "a pathname string" } { "mmap" mapped-file } } +{ $contract "Opens a file for reading only and maps its contents into memory. The length is permitted to exceed the length of the file on disk, in which case the remaining space is padded with zero bytes." } +{ $notes "You must call " { $link dispose } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." } +{ $errors "Throws an error if a memory mapping could not be established." } ; + +HELP: with-mapped-array +{ $values + { "path" "a pathname string" } { "c-type" c-type } { "quot" quotation } } -"The primitive C types for which mapped arrays exist:" -{ $list - { $snippet "char" } - { $snippet "uchar" } - { $snippet "short" } - { $snippet "ushort" } - { $snippet "int" } - { $snippet "uint" } - { $snippet "long" } - { $snippet "ulong" } - { $snippet "longlong" } - { $snippet "ulonglong" } - { $snippet "float" } - { $snippet "double" } - { $snippet "void*" } - { $snippet "bool" } -} ; +{ $description "Memory-maps a file for reading and writing as a mapped-array of the given c-type. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $examples + { $unchecked-example + "USING: alien.c-types io.mmap prettyprint specialized-arrays ;" + "SPECIALIZED-ARRAY: uint" +""""resource:license.txt" uint [ + [ . ] each +] with-mapped-array""" + "" + } +} +{ $errors "Throws an error if a memory mapping could not be established." } ; + +HELP: with-mapped-array-reader +{ $values + { "path" "a pathname string" } { "c-type" c-type } { "quot" quotation } +} +{ $description "Memory-maps a file for reading as a mapped-array of the given c-type. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $errors "Throws an error if a memory mapping could not be established." } ; -ARTICLE: "io.mmap.low-level" "Reading and writing mapped files directly" -"Data can be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. See " { $link "reading-writing-memory" } "." ; +ARTICLE: "io.mmap.arrays" "Working with memory-mapped data" +"The " { $link <mapped-file> } " word returns an instance of " { $link mapped-file } ", which doesn't directly support the sequence protocol. Instead, it needs to be wrapped in a specialized array of the appropriate C type:" +{ $subsections <mapped-array> } +"Additionally, files may be opened with two combinators which take a c-type as input:" +{ $subsections with-mapped-array } +{ $subsections with-mapped-array-reader } +"The appropriate specialized array type must first be generated with " { $link POSTPONE: SPECIALIZED-ARRAY: } "." +$nl +"Data can also be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. This approach is not recommended, though, since in most cases the compiler will generate efficient code for specialized array usage. See " { $link "reading-writing-memory" } " for a description of low-level memory access primitives." ; -ARTICLE: "io.mmap.examples" "Memory-mapped file example" +ARTICLE: "io.mmap.examples" "Memory-mapped file examples" "Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" { $code - "USING: accessors grouping io.files io.mmap.char kernel sequences ;" - "\"mydata.dat\" [" - " 4 <sliced-groups> [ reverse-here ] change-each" - "] with-mapped-char-file" + "USING: alien.c-types grouping io.mmap sequences" "specialized-arrays ;" + "SPECIALIZED-ARRAY: char" + "" + "\"mydata.dat\" char [" + " 4 <sliced-groups>" + " [ reverse-here ] change-each" + "] with-mapped-array" +} +"Normalize a file containing packed quadrupes of floats:" +{ $code + "USING: kernel io.mmap math.vectors math.vectors.simd" "sequences specialized-arrays ;" + "SIMD: float" + "SPECIALIZED-ARRAY: float-4" + "" + "\"mydata.dat\" float-4 [" + " [ normalize ] change-each" + "] with-mapped-array" } ; ARTICLE: "io.mmap" "Memory-mapped files" "The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files." -{ $subsection <mapped-file> } -"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." -{ $subsection "io.mmap.examples" } -"A utility combinator which wraps the above:" -{ $subsection with-mapped-file } +{ $subsections <mapped-file> } +"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." $nl +"Utility combinators which wrap the above:" +{ $subsections with-mapped-file } +{ $subsections with-mapped-file-reader } +{ $subsections with-mapped-array } +{ $subsections with-mapped-array-reader } "Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:" -{ $subsection "io.mmap.arrays" } -{ $subsection "io.mmap.low-level" } ; +{ $subsections + "io.mmap.arrays" + "io.mmap.examples" +} ; ABOUT: "io.mmap" diff --git a/basis/io/mmap/mmap-tests.factor b/basis/io/mmap/mmap-tests.factor index 4847b0701c..94f8c77883 100644 --- a/basis/io/mmap/mmap-tests.factor +++ b/basis/io/mmap/mmap-tests.factor @@ -1,14 +1,28 @@ -USING: io io.mmap io.files io.files.temp -io.directories kernel tools.test continuations sequences -io.encodings.ascii accessors math ; +USING: alien.c-types alien.data compiler.tree.debugger +continuations io.directories io.encodings.ascii io.files +io.files.temp io.mmap kernel math sequences sequences.private +specialized-arrays specialized-arrays.instances.uint tools.test ; IN: io.mmap.tests [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors [ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test -[ ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test -[ 5 ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> length ] with-mapped-file ] unit-test -[ 5 ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> length ] with-mapped-file-reader ] unit-test +[ ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test +[ 5 ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> length ] with-mapped-file ] unit-test +[ 5 ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> length ] with-mapped-file-reader ] unit-test [ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test + +SPECIALIZED-ARRAY: uint + +[ t ] [ + "mmap-test-file.txt" temp-file uint [ sum ] with-mapped-array + integer? +] unit-test + +[ t ] [ + "mmap-test-file.txt" temp-file uint [ sum ] with-mapped-array-reader + integer? +] unit-test + [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors @@ -20,3 +34,8 @@ IN: io.mmap.tests drop ] with-mapped-file ] [ bad-mmap-size? ] must-fail-with + +[ t ] [ + [ "test.txt" <mapped-file> void* <c-direct-array> first-unsafe ] + { nth-unsafe } inlined? +] unit-test diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index a866232760..5f35278b05 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -8,13 +8,13 @@ IN: io.mmap TUPLE: mapped-file < disposable address handle length ; -HOOK: (mapped-file-reader) os ( path length -- address handle ) -HOOK: (mapped-file-r/w) os ( path length -- address handle ) - ERROR: bad-mmap-size n ; <PRIVATE +HOOK: (mapped-file-reader) os ( path length -- address handle ) +HOOK: (mapped-file-r/w) os ( path length -- address handle ) + : prepare-mapped-file ( path quot -- mapped-file path' length ) [ [ normalize-path ] [ file-info size>> ] bi @@ -25,10 +25,10 @@ ERROR: bad-mmap-size n ; PRIVATE> : <mapped-file-reader> ( path -- mmap ) - [ (mapped-file-reader) ] prepare-mapped-file ; + [ (mapped-file-reader) ] prepare-mapped-file ; inline : <mapped-file> ( path -- mmap ) - [ (mapped-file-r/w) ] prepare-mapped-file ; + [ (mapped-file-r/w) ] prepare-mapped-file ; inline : <mapped-array> ( mmap c-type -- direct-array ) [ [ address>> ] [ length>> ] bi ] dip @@ -45,6 +45,19 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ; : with-mapped-file-reader ( path quot -- ) [ <mapped-file-reader> ] dip with-disposal ; inline +<PRIVATE + +: (with-mapped-array) ( c-type quot -- ) + [ [ <mapped-array> ] curry ] dip compose with-disposal ; inline + +PRIVATE> + +: with-mapped-array ( path c-type quot -- ) + [ <mapped-file> ] 2dip (with-mapped-array) ; inline + +: with-mapped-array-reader ( path c-type quot -- ) + [ <mapped-file-reader> ] 2dip (with-mapped-array) ; inline + { { [ os unix? ] [ "io.mmap.unix" require ] } { [ os winnt? ] [ "io.mmap.windows" require ] } diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index 7d12d52361..559417d2b9 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien io io.files kernel math math.bitwise system unix -io.backend.unix io.ports io.mmap destructors locals accessors ; +USING: accessors destructors io.backend.unix io.mmap +io.mmap.private kernel locals math.bitwise system unix ; IN: io.mmap.unix :: mmap-open ( path length prot flags open-mode -- alien fd ) diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index 8fdc7fefd9..a2c1f972a6 100644 --- a/basis/io/mmap/windows/windows.factor +++ b/basis/io/mmap/windows/windows.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types arrays destructors generic io.mmap io.ports io.backend.windows io.files.windows io.backend.windows.privileges -kernel libc math math.bitwise namespaces quotations sequences +io.mmap.private kernel libc math math.bitwise namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system accessors locals windows.errors ; IN: io.mmap.windows diff --git a/basis/io/monitors/monitors-docs.factor b/basis/io/monitors/monitors-docs.factor index c5f266de56..4649b85668 100644 --- a/basis/io/monitors/monitors-docs.factor +++ b/basis/io/monitors/monitors-docs.factor @@ -50,14 +50,16 @@ HELP: +rename-file+ ARTICLE: "io.monitors.descriptors" "File system change descriptors" "The " { $link next-change } " word outputs instances of a class:" -{ $subsection file-change } +{ $subsections file-change } "The " { $slot "changed" } " slot holds a sequence which may contain any of the following symbols:" -{ $subsection +add-file+ } -{ $subsection +remove-file+ } -{ $subsection +modify-file+ } -{ $subsection +rename-file-old+ } -{ $subsection +rename-file-new+ } -{ $subsection +rename-file+ } ; +{ $subsections + +add-file+ + +remove-file+ + +modify-file+ + +rename-file-old+ + +rename-file-new+ + +rename-file+ +} ; ARTICLE: "io.monitors.platforms" "Monitors on different platforms" "Whether the " { $slot "path" } " slot of a " { $link file-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is unspecified, and may even vary on the same platform. User code should not assume either case." @@ -96,16 +98,20 @@ ARTICLE: "io.monitors" "File system change monitors" "File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." $nl "Monitoring operations must be wrapped in a combinator:" -{ $subsection with-monitors } +{ $subsections with-monitors } "Creating a file system change monitor and listening for changes:" -{ $subsection <monitor> } -{ $subsection next-change } +{ $subsections + <monitor> + next-change +} "An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:" -{ $subsection (monitor) } -{ $subsection "io.monitors.descriptors" } -{ $subsection "io.monitors.platforms" } +{ $subsections + (monitor) + "io.monitors.descriptors" + "io.monitors.platforms" +} "Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:" -{ $subsection with-monitor } +{ $subsections with-monitor } "Monitors support the " { $link "io.timeouts" } "." $nl "An example which watches a directory for changes:" diff --git a/basis/io/pipes/pipes-docs.factor b/basis/io/pipes/pipes-docs.factor index 1ba3c05a6a..e016f1bfc3 100644 --- a/basis/io/pipes/pipes-docs.factor +++ b/basis/io/pipes/pipes-docs.factor @@ -37,11 +37,13 @@ ARTICLE: "io.pipes" "Pipes" "A " { $emphasis "pipe" } " is a unidirectional channel for transfer of bytes. Data written to one end of the pipe can be read from the other. Pipes can be used to pass data between processes; they can also be used within a single process to implement communication between coroutines." $nl "Low-level pipes:" -{ $subsection pipe } -{ $subsection (pipe) } +{ $subsections + pipe + (pipe) +} "High-level pipe streams:" -{ $subsection <pipe> } +{ $subsections <pipe> } "Pipelines of coroutines and processes:" -{ $subsection run-pipeline } ; +{ $subsections run-pipeline } ; ABOUT: "io.pipes" diff --git a/basis/io/pipes/unix/unix.factor b/basis/io/pipes/unix/unix.factor index 7319ad1db8..8493f14d26 100644 --- a/basis/io/pipes/unix/unix.factor +++ b/basis/io/pipes/unix/unix.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system kernel unix math sequences +USING: alien.c-types system kernel unix math sequences io.backend.unix io.ports specialized-arrays accessors ; QUALIFIED: io.pipes SPECIALIZED-ARRAY: int diff --git a/basis/io/pools/pools-docs.factor b/basis/io/pools/pools-docs.factor index 36f437dd09..80c8b2d925 100644 --- a/basis/io/pools/pools-docs.factor +++ b/basis/io/pools/pools-docs.factor @@ -43,19 +43,23 @@ ARTICLE: "io.pools" "Connection pools" "Connection pools are implemented in the " { $snippet "io.pools" } " vocabulary. They are used to reuse sockets and connections which may be potentially expensive to create and destroy." $nl "The class of connection pools:" -{ $subsection pool } +{ $subsections pool } "Creating connection pools:" -{ $subsection <pool> } +{ $subsections <pool> } "A utility combinator:" -{ $subsection with-pool } +{ $subsections with-pool } "Acquiring and returning connections, and a utility combinator:" -{ $subsection acquire-connection } -{ $subsection return-connection } -{ $subsection with-pooled-connection } +{ $subsections + acquire-connection + return-connection + with-pooled-connection +} "Pools are not created directly, instead one uses subclasses which implement a generic word:" -{ $subsection make-connection } +{ $subsections make-connection } "One example is a datagram socket pool:" -{ $subsection datagram-pool } -{ $subsection <datagram-pool> } ; +{ $subsections + datagram-pool + <datagram-pool> +} ; ABOUT: "io.pools" diff --git a/basis/io/ports/ports-docs.factor b/basis/io/ports/ports-docs.factor index 47485193cf..2eb9280444 100644 --- a/basis/io/ports/ports-docs.factor +++ b/basis/io/ports/ports-docs.factor @@ -7,23 +7,33 @@ ARTICLE: "io.ports" "Non-blocking I/O implementation" "On Windows and Unix, Factor implements blocking file and network streams on top of a non-blocking I/O substrate, ensuring that Factor threads will yield when performing I/O. This substrate is implemented in the " { $vocab-link "io.ports" } " vocabulary." $nl "A " { $emphasis "port" } " is a stream using non-blocking I/O substrate:" -{ $subsection port } -{ $subsection <port> } -{ $subsection <buffered-port> } +{ $subsections + port + <port> + <buffered-port> +} "Input ports:" -{ $subsection input-port } -{ $subsection <input-port> } +{ $subsections + input-port + <input-port> +} "Output ports:" -{ $subsection output-port } -{ $subsection <output-port> } +{ $subsections + output-port + <output-port> +} "Global native I/O protocol:" -{ $subsection io-backend } -{ $subsection init-io } -{ $subsection init-stdio } -{ $subsection io-multiplex } +{ $subsections + io-backend + init-io + init-stdio + io-multiplex +} "Per-port native I/O protocol:" -{ $subsection (wait-to-read) } -{ $subsection (wait-to-write) } +{ $subsections + (wait-to-read) + (wait-to-write) +} "Additionally, the I/O backend must provide an implementation of the " { $link dispose } " generic word." ; ABOUT: "io.ports" diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 49f6166e00..8cdd1d97bd 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -124,8 +124,14 @@ M: output-port stream-write HOOK: (wait-to-write) io-backend ( port -- ) +HOOK: tell-handle os ( handle -- n ) HOOK: seek-handle os ( n seek-type handle -- ) +M: buffered-port stream-tell ( stream -- n ) + [ check-disposed ] + [ handle>> tell-handle ] + [ [ buffer>> size>> - 0 max ] [ buffer>> pos>> ] bi + ] tri ; + M: input-port stream-seek ( n seek-type stream -- ) [ check-disposed ] [ buffer>> 0 swap buffer-reset ] diff --git a/basis/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor index 0e8a8576fb..fa5acbd054 100644 --- a/basis/io/servers/connection/connection-docs.factor +++ b/basis/io/servers/connection/connection-docs.factor @@ -4,11 +4,13 @@ io.sockets.secure concurrency.semaphores calendar classes math ; ARTICLE: "server-config" "Threaded server configuration" "The " { $link threaded-server } " tuple has a variety of slots which can be set before starting the server with " { $link start-server } " or " { $link start-server* } "." -{ $subsection "server-config-logging" } -{ $subsection "server-config-listen" } -{ $subsection "server-config-limit" } -{ $subsection "server-config-stream" } -{ $subsection "server-config-handler" } ; +{ $subsections + "server-config-logging" + "server-config-listen" + "server-config-limit" + "server-config-stream" + "server-config-handler" +} ; ARTICLE: "server-config-logging" "Logging connections" "The " { $snippet "name" } " slot of a threaded server instance should be set to a string naming the logging service name to use. See " { $link "logging" } " for details." ; @@ -19,8 +21,10 @@ $nl "The " { $snippet "secure" } " slot of a threaded server instance is interpreted in the same manner as the " { $snippet "insecure" } " slot, except that secure encrypted connections are then allowed. If this slot is set, the " { $snippet "secure-config" } " slot should also be set to a " { $link secure-config } " instance containing SSL server configuration. See " { $link "ssl-config" } " for details." $nl "Two utility words for producing address specifiers:" -{ $subsection local-server } -{ $subsection internet-server } ; +{ $subsections + local-server + internet-server +} ; ARTICLE: "server-config-limit" "Limiting connections" "The " { $snippet "max-connections" } " slot is initially set to " { $link f } ", which disables connection limiting, but can be set to an integer specifying the maximum number of simultaneous connections." @@ -50,27 +54,33 @@ ARTICLE: "server-examples" "Threaded server examples" ARTICLE: "io.servers.connection" "Threaded servers" "The " { $vocab-link "io.servers.connection" } " vocabulary implements a generic server abstraction for " { $link "network-connection" } ". A set of threads listen for connections, and additional threads are spawned for each client connection. In addition to this basic functionality, it provides some advanced features such as logging, connection limits and secure socket support." -{ $subsection "server-examples" } +{ $subsections "server-examples" } "Creating threaded servers with client handler quotations:" -{ $subsection <threaded-server> } +{ $subsections <threaded-server> } "Client handlers can also be implemented by subclassing a threaded server; see " { $link "server-config-handler" } " for details:" -{ $subsection threaded-server } -{ $subsection new-threaded-server } -{ $subsection handle-client* } +{ $subsections + threaded-server + new-threaded-server + handle-client* +} "The server must be configured before it can be started." -{ $subsection "server-config" } +{ $subsections "server-config" } "Starting the server:" -{ $subsection start-server } -{ $subsection start-server* } -{ $subsection wait-for-server } +{ $subsections + start-server + start-server* + wait-for-server +} "Stopping the server:" -{ $subsection stop-server } +{ $subsections stop-server } "From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:" -{ $subsection stop-this-server } -{ $subsection secure-port } -{ $subsection insecure-port } +{ $subsections + stop-this-server + secure-port + insecure-port +} "Additionally, the " { $link local-address } " and " -{ $subsection remote-address } " variables are set, as in " { $link with-client } "." ; +{ $subsections remote-address } " variables are set, as in " { $link with-client } "." ; ABOUT: "io.servers.connection" diff --git a/basis/io/sockets/secure/secure-docs.factor b/basis/io/sockets/secure/secure-docs.factor index 5dd4fe6b40..ffc1c04ec9 100644 --- a/basis/io/sockets/secure/secure-docs.factor +++ b/basis/io/sockets/secure/secure-docs.factor @@ -26,10 +26,12 @@ $nl ARTICLE: "ssl-methods" "SSL/TLS methods" "The " { $snippet "method" } " slot of a " { $link secure-config } " can be set to one of the following values:" -{ $subsection SSLv2 } -{ $subsection SSLv23 } -{ $subsection SSLv3 } -{ $subsection TLSv1 } +{ $subsections + SSLv2 + SSLv23 + SSLv3 + TLSv1 +} "The default value is " { $link SSLv23 } "." ; HELP: secure-config @@ -61,15 +63,17 @@ $nl ARTICLE: "ssl-config" "Secure socket configuration" "Secure sockets require some configuration, particularly for server sockets. A class represents secure socket configuration parameters:" -{ $subsection secure-config } +{ $subsections secure-config } "Creating new instances:" -{ $subsection <secure-config> } +{ $subsections <secure-config> } "Configuration parameters:" -{ $subsection "ssl-methods" } -{ $subsection "ssl-key-file" } -{ $subsection "ssl-ca-file" } -{ $subsection "ssl-dh-file" } -{ $subsection "ssl-ephemeral-rsa" } ; +{ $subsections + "ssl-methods" + "ssl-key-file" + "ssl-ca-file" + "ssl-dh-file" + "ssl-ephemeral-rsa" +} ; HELP: <secure-context> { $values { "config" secure-config } { "context" secure-context } } @@ -81,7 +85,7 @@ HELP: with-secure-context ARTICLE: "ssl-contexts" "Secure socket contexts" "All secure socket operations must be performed in a secure socket context. A context is created from a secure socket configuration. An implicit context with the default configuration is always available, however server sockets require a certificate to be set together with other parameters, and the default configuration is insufficient, so a context must be explicitly created in that case." -{ $subsection with-secure-context } ; +{ $subsections with-secure-context } ; HELP: secure { $class-description "The class of secure socket addresses." } ; @@ -94,9 +98,9 @@ ARTICLE: "ssl-addresses" "Secure socket addresses" "Secure socket connections are established by passing a secure socket address to " { $link <client> } " or " { $link <server> } "." $nl "Secure socket addresses form a class:" -{ $subsection secure } +{ $subsections secure } "Constructing secure socket addresses:" -{ $subsection <secure> } +{ $subsections <secure> } "Instances of this class can wrap an " { $link inet } ", " { $link inet4 } " or an " { $link inet6 } ", although note that certificate validation is only performed for instances of " { $link inet } " since otherwise the host name is not available." ; HELP: send-secure-handshake @@ -112,9 +116,9 @@ ARTICLE: "ssl-upgrade" "Upgrading existing connections" "Some protocols, such as HTTPS, require that the connection be established as an SSL/TLS connection. Others, such as secure SMTP and POP3 require that the client and server initiate an SSL/TLS handshake upon the client sending a plain-text request. The latter use-case is accomodated by a pair of words." $nl "Upgrading a connection to a secure socket by initiating an SSL/TLS handshake with the server:" -{ $subsection send-secure-handshake } +{ $subsections send-secure-handshake } "Upgrading a connection to a secure socket by waiting for an SSL/TLS handshake from the client:" -{ $subsection accept-secure-handshake } ; +{ $subsections accept-secure-handshake } ; HELP: premature-close { $error-description "Thrown if an SSL connection is closed without the proper " { $snippet "close_notify" } " sequence. This error is never reported for " { $link SSLv2 } " connections because there is no distinction between expected and unexpected connection closure in that case." } ; @@ -134,12 +138,16 @@ HELP: upgrade-buffers-full ARTICLE: "ssl-errors" "Secure socket errors" "Secure sockets can throw one of several errors in addition to the usual I/O errors:" -{ $subsection premature-close } -{ $subsection certificate-verify-error } -{ $subsection common-name-verify-error } +{ $subsections + premature-close + certificate-verify-error + common-name-verify-error +} "The " { $link send-secure-handshake } " word can throw one of two errors:" -{ $subsection upgrade-on-non-socket } -{ $subsection upgrade-buffers-full } ; +{ $subsections + upgrade-on-non-socket + upgrade-buffers-full +} ; ARTICLE: "io.sockets.secure" "Secure sockets (SSL, TLS)" "The " { $vocab-link "io.sockets.secure" } " vocabulary implements secure, encrypted sockets using the OpenSSL library." @@ -147,10 +155,12 @@ $nl "At present, this vocabulary only works on Unix, and not on Windows." $nl "This product includes software developed by the OpenSSL Project for use in the OpenSSL Toolkit (" { $url "http://www.openssl.org/" } "), cryptographic software written by Eric Young (eay@cryptsoft.com) and software written by Tim Hudson (tjh@cryptsoft.com)." -{ $subsection "ssl-config" } -{ $subsection "ssl-contexts" } -{ $subsection "ssl-addresses" } -{ $subsection "ssl-upgrade" } -{ $subsection "ssl-errors" } ; +{ $subsections + "ssl-config" + "ssl-contexts" + "ssl-addresses" + "ssl-upgrade" + "ssl-errors" +} ; ABOUT: "io.sockets.secure" diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor index 970aa34ea6..fb8332dffb 100644 --- a/basis/io/sockets/sockets-docs.factor +++ b/basis/io/sockets/sockets-docs.factor @@ -6,27 +6,39 @@ ARTICLE: "network-addressing" "Address specifiers" "The networking words are quite general and work with " { $emphasis "address specifiers" } " rather than concrete concepts such as host names. There are four types of address specifiers." $nl "Unix domain sockets:" -{ $subsection local } -{ $subsection <local> } +{ $subsections + local + <local> +} "Internet host name/port number pairs; the host name is resolved to an IPv4 or IPv6 address using the operating system's resolver:" -{ $subsection inet } -{ $subsection <inet> } +{ $subsections + inet + <inet> +} "IPv4 addresses, with no host name resolution:" -{ $subsection inet4 } -{ $subsection <inet4> } +{ $subsections + inet4 + <inet4> +} "IPv6 addresses, with no host name resolution:" -{ $subsection inet6 } -{ $subsection <inet6> } +{ $subsections + inet6 + <inet6> +} "While the " { $link inet } " addressing specifier is capable of performing name lookups when passed to " { $link <client> } ", sometimes it is necessary to look up a host name without making a connection:" -{ $subsection resolve-host } ; +{ $subsections resolve-host } ; ARTICLE: "network-connection" "Connection-oriented networking" "Network connections can be established with this word:" -{ $subsection <client> } -{ $subsection with-client } +{ $subsections + <client> + with-client +} "Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:" -{ $subsection <server> } -{ $subsection accept } +{ $subsections + <server> + accept +} "Server sockets are closed by calling " { $link dispose } "." $nl "Address specifiers have the following interpretation with connection-oriented networking words:" @@ -42,10 +54,12 @@ $nl ARTICLE: "network-packet" "Packet-oriented networking" "A packet-oriented socket can be opened with this word:" -{ $subsection <datagram> } +{ $subsections <datagram> } "Packets can be sent and received with a pair of words:" -{ $subsection send } -{ $subsection receive } +{ $subsections + send + receive +} "Packet-oriented sockets are closed by calling " { $link dispose } "." $nl "Address specifiers have the following interpretation with packet-oriented networking words:" @@ -72,10 +86,12 @@ ARTICLE: "network-streams" "Networking" "TCP/IP and UDP/IP, over IPv4 and IPv6" "Unix domain sockets (Unix only)" } -{ $subsection "network-examples" } -{ $subsection "network-addressing" } -{ $subsection "network-connection" } -{ $subsection "network-packet" } +{ $subsections + "network-examples" + "network-addressing" + "network-connection" + "network-packet" +} { $vocab-subsection "Secure sockets (SSL, TLS)" "io.sockets.secure" } { $see-also "io.pipes" } ; diff --git a/basis/io/streams/duplex/duplex-docs.factor b/basis/io/streams/duplex/duplex-docs.factor index 5bf33e9002..f9f26e060a 100644 --- a/basis/io/streams/duplex/duplex-docs.factor +++ b/basis/io/streams/duplex/duplex-docs.factor @@ -3,11 +3,15 @@ IN: io.streams.duplex ARTICLE: "io.streams.duplex" "Duplex streams" "Duplex streams combine an input stream and an output stream into a bidirectional stream." -{ $subsection duplex-stream } -{ $subsection <duplex-stream> } +{ $subsections + duplex-stream + <duplex-stream> +} "A pair of combinators for rebinding both default streams at once:" -{ $subsection with-stream } -{ $subsection with-stream* } ; +{ $subsections + with-stream + with-stream* +} ; ABOUT: "io.streams.duplex" diff --git a/basis/io/streams/duplex/duplex.factor b/basis/io/streams/duplex/duplex.factor index 4903195abc..0e4d1fd195 100644 --- a/basis/io/streams/duplex/duplex.factor +++ b/basis/io/streams/duplex/duplex.factor @@ -44,4 +44,3 @@ M: duplex-stream underlying-handle >duplex-stream< [ underlying-handle ] bi@ [ = [ invalid-duplex-stream ] when ] keep ; - diff --git a/basis/io/streams/limited/limited-docs.factor b/basis/io/streams/limited/limited-docs.factor index 130c7ba3a9..6c1806ff38 100755 --- a/basis/io/streams/limited/limited-docs.factor +++ b/basis/io/streams/limited/limited-docs.factor @@ -24,7 +24,22 @@ HELP: limit " \"123456\" <string-reader> 3 stream-throws limit" " 100 swap stream-read ." "] [ ] recover ." - "T{ limit-exceeded }" +"""T{ limit-exceeded + { n 1 } + { stream + T{ limited-stream + { stream + T{ string-reader + { underlying "123456" } + { i 3 } + } + } + { mode stream-throws } + { count 4 } + { limit 3 } + } + } +}""" } "Returning " { $link f } " on exhaustion:" { $example @@ -73,18 +88,18 @@ HELP: stream-throws { stream-eofs stream-throws } related-words ARTICLE: "io.streams.limited" "Limited input streams" -"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end." $nl +"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end. Limiting a non-seekable stream keeps a byte count and triggers the end-of-stream behavior when this byte count has been reached. However, limiting a seekable stream creates a window of bytes that supports seeking and re-reading of bytes in that window." $nl "Wrap a stream in a limited stream:" -{ $subsection limit } +{ $subsections limit } "Wrap the current " { $link input-stream } " in a limited stream:" -{ $subsection limit-input } +{ $subsections limit-input } "Unlimits a limited stream:" -{ $subsection unlimited } +{ $subsections unlimited } "Unlimits the current " { $link input-stream } ":" -{ $subsection unlimited-input } +{ $subsections unlimited-input } "Make a limited stream throw an exception on exhaustion:" -{ $subsection stream-throws } +{ $subsections stream-throws } "Make a limited stream return " { $link f } " on exhaustion:" -{ $subsection stream-eofs } ; +{ $subsections stream-eofs } ; ABOUT: "io.streams.limited" diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor index 86d652d17c..022d20eb5e 100644 --- a/basis/io/streams/limited/limited-tests.factor +++ b/basis/io/streams/limited/limited-tests.factor @@ -1,7 +1,8 @@ -USING: io io.streams.limited io.encodings io.encodings.string -io.encodings.ascii io.encodings.binary io.streams.byte-array -namespaces tools.test strings kernel io.streams.string accessors -io.encodings.utf8 io.files destructors ; +USING: accessors continuations destructors io io.encodings +io.encodings.8-bit io.encodings.ascii io.encodings.binary +io.encodings.string io.encodings.utf8 io.files io.pipes +io.streams.byte-array io.streams.limited io.streams.string +kernel namespaces strings tools.test system ; IN: io.streams.limited.tests [ ] [ @@ -81,4 +82,135 @@ IN: io.streams.limited.tests "HELLO" [ f stream-throws limit-input 4 read ] with-string-reader -] unit-test \ No newline at end of file +] unit-test + + +[ "asdf" ] [ + "asdf" <string-reader> 2 stream-eofs <limited-stream> [ + unlimited-input contents + ] with-input-stream +] unit-test + +[ 4 ] [ + "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [ + 4 seek-relative seek-input tell-input + ] with-input-stream +] unit-test + +[ + "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [ + 4 seek-relative seek-input + 4 read + ] with-input-stream +] [ + limit-exceeded? +] must-fail-with + +[ + "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [ + 4 seek-relative seek-input + -2 seek-relative + 2 read + ] with-input-stream +] [ + limit-exceeded? +] must-fail-with + +[ + "abcdefgh" <string-reader> [ + 4 seek-relative seek-input + 2 stream-throws limit-input + -2 seek-relative seek-input + 2 read + ] with-input-stream +] [ + limit-exceeded? +] must-fail-with + +[ "ef" ] [ + "abcdefgh" <string-reader> [ + 4 seek-relative seek-input + 2 stream-throws limit-input + 4 seek-absolute seek-input + 2 read + ] with-input-stream +] unit-test + +[ "ef" ] [ + "abcdefgh" <string-reader> [ + 4 seek-absolute seek-input + 2 stream-throws limit-input + 2 seek-absolute seek-input + 4 seek-absolute seek-input + 2 read + ] with-input-stream +] unit-test + +! stream-throws, pipes are duplex and not seekable +[ "as" ] [ + latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in + "asdf" over stream-write dup stream-flush + 2 swap stream-read +] unit-test + +[ + latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in + "asdf" over stream-write dup stream-flush + 3 swap stream-read +] [ + limit-exceeded? +] must-fail-with + +! stream-eofs, pipes are duplex and not seekable +[ "as" ] [ + latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in + "asdf" over stream-write dup stream-flush + 2 swap stream-read +] unit-test + +[ "as" ] [ + latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in + "asdf" over stream-write dup stream-flush + 3 swap stream-read +] unit-test + +! test seeking on limited unseekable streams +[ "as" ] [ + latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in + "asdf" over stream-write dup stream-flush + 2 swap stream-read +] unit-test + +[ "as" ] [ + latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in + "asdf" over stream-write dup stream-flush + 3 swap stream-read +] unit-test + +[ + latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in + 2 seek-absolute rot in>> stream-seek +] must-fail + +[ + "as" +] [ + latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in + "asdf" over stream-write dup stream-flush + [ 2 seek-absolute rot in>> stream-seek ] [ drop ] recover + 2 swap stream-read +] unit-test + +[ 7 ] [ + image binary stream-throws <limited-file-reader> [ + 7 read drop + tell-input + ] with-input-stream +] unit-test + +[ 70000 ] [ + image binary stream-throws <limited-file-reader> [ + 70000 read drop + tell-input + ] with-input-stream +] unit-test diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index 1b0e155762..403643ed73 100755 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -2,11 +2,14 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors byte-vectors combinators destructors fry io -io.encodings io.files io.files.info kernel math namespaces -sequences ; +io.encodings io.files io.files.info kernel locals math +namespaces sequences ; IN: io.streams.limited -TUPLE: limited-stream stream count limit mode stack ; +TUPLE: limited-stream + stream mode + count limit + current start stop ; SINGLETONS: stream-throws stream-eofs ; @@ -37,7 +40,7 @@ M: decoder unlimited ( stream -- stream' ) [ stream>> ] change-stream ; M: object unlimited ( stream -- stream' ) - stream>> stream>> ; + stream>> ; : limit-input ( limit mode -- ) [ input-stream ] 2dip '[ _ _ limit ] change ; @@ -51,13 +54,27 @@ M: object unlimited ( stream -- stream' ) : with-limited-stream ( stream limit mode quot -- ) [ limit ] dip call ; inline -ERROR: limit-exceeded ; +ERROR: limit-exceeded n stream ; ERROR: bad-stream-mode mode ; <PRIVATE -: adjust-limit ( n stream -- n' stream ) +: adjust-current-limit ( n stream -- n' stream ) + 2dup [ + ] change-current + [ current>> ] [ stop>> ] bi > + [ + dup mode>> { + { stream-throws [ limit-exceeded ] } + { stream-eofs [ + dup [ current>> ] [ stop>> ] bi - + '[ _ - ] dip + ] } + [ bad-stream-mode ] + } case + ] when ; inline + +: adjust-count-limit ( n stream -- n' stream ) 2dup [ + ] change-count [ count>> ] [ limit>> ] bi > [ @@ -66,13 +83,29 @@ ERROR: bad-stream-mode mode ; { stream-eofs [ dup [ count>> ] [ limit>> ] bi - '[ _ - ] dip + dup limit>> >>count ] } [ bad-stream-mode ] } case ] when ; inline +: check-count-bounds ( n stream -- n stream ) + dup [ count>> ] [ limit>> ] bi > + [ limit-exceeded ] when ; + +: check-current-bounds ( n stream -- n stream ) + dup [ current>> ] [ start>> ] bi < + [ limit-exceeded ] when ; + +: adjust-limited-read ( n stream -- n stream ) + dup start>> [ + check-current-bounds adjust-current-limit + ] [ + check-count-bounds adjust-count-limit + ] if ; + : maybe-read ( n limited-stream quot: ( n stream -- seq/f ) -- seq/f ) - [ adjust-limit ] dip + [ adjust-limited-read ] dip pick 0 <= [ 3drop f ] [ [ stream>> ] dip call ] if ; inline PRIVATE> @@ -93,13 +126,35 @@ M: limited-stream stream-read-partial 3dup [ [ stream-read1 dup ] dip memq? ] dip swap [ drop ] [ push (read-until) ] if ; +:: limited-stream-seek ( n seek-type stream -- ) + seek-type { + { seek-absolute [ n stream (>>current) ] } + { seek-relative [ stream [ n + ] change-current drop ] } + { seek-end [ stream stop>> n - stream (>>current) ] } + [ bad-seek-type ] + } case ; + +: >limited-seek ( stream -- stream' ) + dup start>> [ + dup stream-tell >>current + dup [ current>> ] [ count>> ] bi - >>start + dup [ start>> ] [ limit>> ] bi + >>stop + ] unless ; + PRIVATE> M: limited-stream stream-read-until swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ; +M: limited-stream stream-tell + stream>> stream-tell ; + M: limited-stream stream-seek - stream>> stream-seek ; + >limited-seek + [ stream>> stream-seek ] + [ limited-stream-seek ] 3bi ; + +M: limited-stream dispose stream>> dispose ; -M: limited-stream dispose - stream>> dispose ; +M: limited-stream stream-element-type + stream>> stream-element-type ; diff --git a/basis/io/streams/null/null-docs.factor b/basis/io/streams/null/null-docs.factor index 19bf8251c2..e78f3df28d 100644 --- a/basis/io/streams/null/null-docs.factor +++ b/basis/io/streams/null/null-docs.factor @@ -19,10 +19,14 @@ ARTICLE: "io.streams.null" "Null streams" "The " { $vocab-link "io.streams.null" } " vocabulary implements a pair of streams which are useful for testing. The null reader always yields EOF and the null writer ignores all output. Conceptually, they are similar to " { $snippet "/dev/null" } " on a Unix system." $nl "Null readers:" -{ $subsection null-reader } -{ $subsection with-null-writer } +{ $subsections + null-reader + with-null-writer +} "Null writers:" -{ $subsection null-writer } -{ $subsection with-null-reader } ; +{ $subsections + null-writer + with-null-reader +} ; ABOUT: "io.streams.null" \ No newline at end of file diff --git a/basis/io/streams/string/string-docs.factor b/basis/io/streams/string/string-docs.factor index b87e5ca591..59a167b72f 100644 --- a/basis/io/streams/string/string-docs.factor +++ b/basis/io/streams/string/string-docs.factor @@ -3,11 +3,15 @@ IN: io.streams.string ARTICLE: "io.streams.string" "String streams" "String streams:" -{ $subsection <string-reader> } -{ $subsection <string-writer> } +{ $subsections + <string-reader> + <string-writer> +} "Utility combinators:" -{ $subsection with-string-reader } -{ $subsection with-string-writer } ; +{ $subsections + with-string-reader + with-string-writer +} ; ABOUT: "io.streams.string" diff --git a/basis/io/streams/string/string.factor b/basis/io/streams/string/string.factor index 85cb3022f5..be9016d1f2 100644 --- a/basis/io/streams/string/string.factor +++ b/basis/io/streams/string/string.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors io kernel math namespaces sequences sbufs strings generic splitting continuations destructors sequences.private -io.streams.plain io.encodings math.order growable io.streams.sequence ; +io.streams.plain io.encodings math.order growable io.streams.sequence +io.private ; IN: io.streams.string ! Readers @@ -13,6 +14,8 @@ M: string-reader stream-read-partial stream-read ; M: string-reader stream-read sequence-read ; M: string-reader stream-read1 sequence-read1 ; M: string-reader stream-read-until sequence-read-until ; +M: string-reader stream-tell i>> ; +M: string-reader stream-seek (stream-seek) ; M: string-reader dispose drop ; <PRIVATE @@ -35,4 +38,4 @@ M: sbuf stream-element-type drop +character+ ; : with-string-writer ( quot -- str ) <string-writer> [ swap with-output-stream* - ] keep >string ; inline \ No newline at end of file + ] keep >string ; inline diff --git a/basis/io/styles/styles-docs.factor b/basis/io/styles/styles-docs.factor index 8d29cffb04..ed2f0c425f 100755 --- a/basis/io/styles/styles-docs.factor +++ b/basis/io/styles/styles-docs.factor @@ -92,24 +92,30 @@ $io-error ; ARTICLE: "formatted-stream-protocol" "Formatted stream protocol" "The " { $vocab-link "io.styles" } " vocabulary defines a protocol for output streams that support rich text." -{ $subsection stream-format } -{ $subsection make-span-stream } -{ $subsection make-block-stream } -{ $subsection make-cell-stream } -{ $subsection stream-write-table } ; +{ $subsections + stream-format + make-span-stream + make-block-stream + make-cell-stream + stream-write-table +} ; ARTICLE: "formatted-stdout" "Formatted output on the default stream" "The below words perform formatted output on " { $link output-stream } "." $nl "Formatted output:" -{ $subsection format } -{ $subsection with-style } -{ $subsection with-nesting } +{ $subsections + format + with-style + with-nesting +} "Tabular output:" -{ $subsection tabular-output } -{ $subsection with-row } -{ $subsection with-cell } -{ $subsection write-cell } ; +{ $subsections + tabular-output + with-row + with-cell + write-cell +} ; HELP: href { $description "Character style. A URL string that the text links to." } ; @@ -119,28 +125,36 @@ HELP: image ARTICLE: "character-styles" "Character styles" "Character styles for " { $link stream-format } " and " { $link with-style } ":" -{ $subsection foreground } -{ $subsection background } -{ $subsection font-name } -{ $subsection font-size } -{ $subsection font-style } +{ $subsections + foreground + background + font-name + font-size + font-style +} "Special styles:" -{ $subsection href } -{ $subsection image } +{ $subsections + href + image +} { $see-also "presentations" } ; ARTICLE: "paragraph-styles" "Paragraph styles" "Paragraph styles for " { $link with-nesting } ":" -{ $subsection page-color } -{ $subsection border-color } -{ $subsection inset } -{ $subsection wrap-margin } -{ $subsection presented } ; +{ $subsections + page-color + border-color + inset + wrap-margin + presented +} ; ARTICLE: "table-styles" "Table styles" "Table styles for " { $link tabular-output } ":" -{ $subsection table-gap } -{ $subsection table-border } ; +{ $subsections + table-gap + table-border +} ; HELP: write-object { $values { "str" string } { "obj" "an object" } } @@ -149,24 +163,28 @@ $io-error ; ARTICLE: "presentations" "Presentations" "A special style for " { $link format } " and " { $link with-nesting } ":" -{ $subsection presented } +{ $subsections presented } "The " { $link presented } " style can be used to emit clickable objects. A utility word for outputting this style:" -{ $subsection write-object } ; +{ $subsections write-object } ; ARTICLE: "styles" "Text styles" "The " { $link stream-format } ", " { $link with-style } ", " { $link with-nesting } " and " { $link tabular-output } " words take a hashtable of style attributes. Output stream implementations are free to ignore style information." $nl "Style hashtables are keyed by symbols from the " { $vocab-link "io.styles" } " vocabulary." -{ $subsection "character-styles" } -{ $subsection "paragraph-styles" } -{ $subsection "table-styles" } -{ $subsection "presentations" } ; +{ $subsections + "character-styles" + "paragraph-styles" + "table-styles" + "presentations" +} ; ARTICLE: "io.styles" "Formatted output" "The " { $vocab-link "io.styles" } " vocabulary defines a protocol for formatted output. This is used by the prettyprinter, help system, and various developer tools. Implementations include " { $vocab-link "ui.gadgets.panes" } ", " { $vocab-link "html.streams" } ", and " { $vocab-link "io.streams.plain" } "." -{ $subsection "formatted-stream-protocol" } -{ $subsection "formatted-stdout" } -{ $subsection "styles" } ; +{ $subsections + "formatted-stream-protocol" + "formatted-stdout" + "styles" +} ; ABOUT: "io.styles" @@ -284,4 +302,4 @@ ARTICLE: "io.streams.plain" "Plain writer streams" { $link make-span-stream } ", " { $link make-block-stream } " and " { $link make-cell-stream } "." -{ $subsection plain-writer } ; \ No newline at end of file +{ $subsections plain-writer } ; \ No newline at end of file diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index b141d8d2f7..ae493be849 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables io io.streams.plain io.streams.string -colors summary make accessors splitting math.order -kernel namespaces assocs destructors strings sequences -present fry strings.tables delegate delegate.protocols ; +USING: accessors assocs colors colors.constants delegate +delegate.protocols destructors fry hashtables io +io.streams.plain io.streams.string kernel make math.order +namespaces present sequences splitting strings strings.tables +summary ; IN: io.styles GENERIC: stream-format ( str style stream -- ) @@ -162,3 +163,9 @@ M: input summary : write-object ( str obj -- ) presented associate format ; : write-image ( image -- ) [ "" ] dip image associate format ; + +SYMBOL: stack-effect-style +H{ + { foreground COLOR: FactorDarkGreen } + { font-style plain } +} stack-effect-style set-global diff --git a/basis/io/timeouts/timeouts-docs.factor b/basis/io/timeouts/timeouts-docs.factor index 5d72bde0f5..3ae3b62c5d 100644 --- a/basis/io/timeouts/timeouts-docs.factor +++ b/basis/io/timeouts/timeouts-docs.factor @@ -19,12 +19,14 @@ HELP: with-timeout ARTICLE: "io.timeouts" "I/O timeout protocol" "Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed." -{ $subsection timeout } -{ $subsection set-timeout } +{ $subsections + timeout + set-timeout +} "The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations." -{ $subsection cancel-operation } +{ $subsections cancel-operation } "A combinator to be used in operations which can time out:" -{ $subsection with-timeout } +{ $subsections with-timeout } { $see-also "stream-protocol" "io.launcher" "io.monitors" } ; ABOUT: "io.timeouts" diff --git a/basis/iokit/hid/hid.factor b/basis/iokit/hid/hid.factor index a1a4b942b7..b3894d7b49 100644 --- a/basis/iokit/hid/hid.factor +++ b/basis/iokit/hid/hid.factor @@ -1,6 +1,7 @@ -USING: iokit alien alien.syntax alien.c-types kernel -system core-foundation core-foundation.data -core-foundation.dictionaries ; +USING: iokit alien alien.syntax alien.c-types kernel system +core-foundation core-foundation.arrays core-foundation.data +core-foundation.dictionaries core-foundation.run-loop +core-foundation.strings core-foundation.time ; IN: iokit.hid CONSTANT: kIOHIDDeviceKey "IOHIDDevice" diff --git a/basis/json/json-docs.factor b/basis/json/json-docs.factor index 816e7236ac..24c66f6985 100644 --- a/basis/json/json-docs.factor +++ b/basis/json/json-docs.factor @@ -2,7 +2,9 @@ IN: json USING: help.markup help.syntax ; ARTICLE: "json" "JSON serialization" -{ $subsection "json.reader" } -{ $subsection "json.writer" } ; +{ $subsections + "json.reader" + "json.writer" +} ; ABOUT: "json" diff --git a/basis/json/reader/reader-docs.factor b/basis/json/reader/reader-docs.factor index 4446c385d3..2ffe24247d 100644 --- a/basis/json/reader/reader-docs.factor +++ b/basis/json/reader/reader-docs.factor @@ -9,6 +9,6 @@ HELP: json> ARTICLE: "json.reader" "JSON reader" "The " { $vocab-link "json.reader" } " vocabulary defines a word for parsing strings in JSON format." -{ $subsection json> } ; +{ $subsections json> } ; ABOUT: "json.reader" diff --git a/basis/json/reader/reader-tests.factor b/basis/json/reader/reader-tests.factor index 14a54b89c0..79a0e4b5af 100644 --- a/basis/json/reader/reader-tests.factor +++ b/basis/json/reader/reader-tests.factor @@ -1,4 +1,4 @@ -USING: arrays json.reader kernel multiline strings tools.test +USING: arrays json.reader kernel strings tools.test hashtables json ; IN: json.reader.tests @@ -26,26 +26,26 @@ IN: json.reader.tests ! feature to get { -0.0 } [ "-0.0" json> ] unit-test -{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test -{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test +{ " fuzzy pickles " } [ """ " fuzzy pickles " """ json> ] unit-test +{ "while 1:\n\tpass" } [ """ "while 1:\n\tpass" """ json> ] unit-test ! unicode is allowed in json -{ "ÃâÂ¬ÆËâ" } [ <" "ÃâÂ¬ÆËâ""> json> ] unit-test -{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test -{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test +{ "ÃâÂ¬ÆËâ" } [ """ "ÃâÂ¬ÆËâ"""" json> ] unit-test +{ 8 9 10 12 13 34 47 92 } >string 1array [ """ "\\b\\t\\n\\f\\r\\"\\/\\\\" """ json> ] unit-test +{ HEX: abcd } >string 1array [ """ "\\uaBCd" """ json> ] unit-test { H{ { "a" { } } { "b" 123 } } } [ "{\"a\":[],\"b\":123}" json> ] unit-test { { } } [ "[]" json> ] unit-test -{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test +{ { 1 "two" 3.0 } } [ """ [1, "two", 3.0] """ json> ] unit-test { H{ } } [ "{}" json> ] unit-test ! the returned hashtable should be different every time { H{ } } [ "key" "value" "{}" json> ?set-at "{}" json> nip ] unit-test -{ H{ { "US$" 1.0 } { "EUâ¬" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test +{ H{ { "US$" 1.0 } { "EUâ¬" 1.5 } } } [ """ { "US$":1.00, "EU\\u20AC":1.50 } """ json> ] unit-test { H{ { "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } } { "prime" { 2 3 5 7 11 13 } } -} } [ <" { +} } [ """ { "fib": [1, 1, 2, 3, 5, 8, { "etc":"etc" } ], "prime": @@ -53,7 +53,7 @@ IN: json.reader.tests 11, 13 ] } -"> json> ] unit-test +""" json> ] unit-test { 0 } [ " 0" json> ] unit-test { 0 } [ "0 " json> ] unit-test diff --git a/basis/json/writer/writer-docs.factor b/basis/json/writer/writer-docs.factor index 8512d80384..9a6ba5f2b1 100644 --- a/basis/json/writer/writer-docs.factor +++ b/basis/json/writer/writer-docs.factor @@ -15,7 +15,9 @@ HELP: json-print ARTICLE: "json.writer" "JSON writer" "The " { $vocab-link "json.writer" } " vocabulary defines words for converting objects to JSON format." -{ $subsection >json } -{ $subsection json-print } ; +{ $subsections + >json + json-print +} ; ABOUT: "json.writer" diff --git a/basis/json/writer/writer-tests.factor b/basis/json/writer/writer-tests.factor index 6b6118c443..692a264d0a 100644 --- a/basis/json/writer/writer-tests.factor +++ b/basis/json/writer/writer-tests.factor @@ -1,4 +1,4 @@ -USING: json.writer tools.test multiline json.reader json ; +USING: json.writer tools.test json.reader json ; IN: json.writer.tests { "false" } [ f >json ] unit-test @@ -11,10 +11,10 @@ IN: json.writer.tests { "102.5" } [ 102.5 >json ] unit-test { "[1,\"two\",3.0]" } [ { 1 "two" 3.0 } >json ] unit-test -{ <" {"US$":1.0,"EUâ¬":1.5}"> } [ H{ { "US$" 1.0 } { "EUâ¬" 1.5 } } >json ] unit-test +{ """{"US$":1.0,"EUâ¬":1.5}""" } [ H{ { "US$" 1.0 } { "EUâ¬" 1.5 } } >json ] unit-test ! Random symbols are written simply as strings SYMBOL: testSymbol -{ <" "testSymbol""> } [ testSymbol >json ] unit-test +{ """"testSymbol"""" } [ testSymbol >json ] unit-test -[ { 0.5 } ] [ { 1/2 } >json json> ] unit-test \ No newline at end of file +[ { 0.5 } ] [ { 1/2 } >json json> ] unit-test diff --git a/basis/lcs/lcs-docs.factor b/basis/lcs/lcs-docs.factor index 0ca84edaea..d2c4e01bf8 100644 --- a/basis/lcs/lcs-docs.factor +++ b/basis/lcs/lcs-docs.factor @@ -24,12 +24,16 @@ HELP: insert ARTICLE: "lcs" "LCS, diffing and distance" "This vocabulary provides words for three apparently unrelated but in fact very similar problems: finding a longest common subsequence between two sequences, getting a minimal edit script (diff) between two sequences, and calculating the Levenshtein distance between two sequences. The implementations of these algorithms are very closely related, and all running times are O(nm), where n and m are the lengths of the input sequences." -{ $subsection lcs } -{ $subsection diff } -{ $subsection levenshtein } +{ $subsections + lcs + diff + levenshtein +} "The " { $link diff } " word returns a sequence of tuples of the following classes. They all hold their contents in the 'item' slot." -{ $subsection insert } -{ $subsection delete } -{ $subsection retain } ; +{ $subsections + insert + delete + retain +} ; ABOUT: "lcs" diff --git a/basis/linked-assocs/linked-assocs-docs.factor b/basis/linked-assocs/linked-assocs-docs.factor index 6fd42954aa..f8455cce9f 100644 --- a/basis/linked-assocs/linked-assocs-docs.factor +++ b/basis/linked-assocs/linked-assocs-docs.factor @@ -16,8 +16,10 @@ ARTICLE: "linked-assocs" "Linked assocs" "A " { $emphasis "linked assoc" } " is an assoc which combines an underlying assoc with a dlist to form a structure which has the insertion and retrieval characteristics of the underlying assoc (typically a hashtable), but with the ability to get the entries in insertion order by calling " { $link >alist } "." $nl "Linked assocs are implemented in the " { $vocab-link "linked-assocs" } " vocabulary." -{ $subsection linked-assoc } -{ $subsection <linked-hash> } -{ $subsection <linked-assoc> } ; +{ $subsections + linked-assoc + <linked-hash> + <linked-assoc> +} ; ABOUT: "linked-assocs" \ No newline at end of file diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor index 7470ef9daa..c6a2d0c050 100644 --- a/basis/listener/listener-docs.factor +++ b/basis/listener/listener-docs.factor @@ -3,15 +3,19 @@ IN: listener ARTICLE: "listener-watch" "Watching variables in the listener" "The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:" -{ $subsection visible-vars } +{ $subsections visible-vars } "To add or remove a single variable:" -{ $subsection show-var } -{ $subsection hide-var } +{ $subsections + show-var + hide-var +} "To add and remove multiple variables:" -{ $subsection show-vars } -{ $subsection hide-vars } +{ $subsections + show-vars + hide-vars +} "Hiding all visible variables:" -{ $subsection hide-all-vars } ; +{ $subsections hide-all-vars } ; HELP: only-use-vocabs { $values { "vocabs" "a sequence of vocabulary specifiers" } } @@ -44,13 +48,13 @@ $nl "Multi-line expressions are supported:" { $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" } "The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them." -{ $subsection "listener-watch" } +{ $subsections "listener-watch" } "To start a nested listener:" -{ $subsection listener } +{ $subsections listener } "To exit the listener, invoke the " { $link return } " word." $nl "Multi-line quotations can be read independently of the rest of the listener:" -{ $subsection read-quot } ; +{ $subsections read-quot } ; ABOUT: "listener" diff --git a/basis/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor index e7401d6af1..3b23e1186e 100644 --- a/basis/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -7,45 +7,55 @@ ABOUT: "lists.lazy" ARTICLE: "lists.lazy" "Lazy lists" "The " { $vocab-link "lists.lazy" } " vocabulary implements lazy lists and standard operations to manipulate them." -{ $subsection { "lists.lazy" "construction" } } -{ $subsection { "lists.lazy" "manipulation" } } -{ $subsection { "lists.lazy" "combinators" } } -{ $subsection { "lists.lazy" "io" } } ; +{ $subsections + { "lists.lazy" "construction" } + { "lists.lazy" "manipulation" } + { "lists.lazy" "combinators" } + { "lists.lazy" "io" } +} ; ARTICLE: { "lists.lazy" "combinators" } "Combinators for manipulating lazy lists" "The following combinators create lazy lists from other lazy lists:" -{ $subsection lazy-map } -{ $subsection lfilter } -{ $subsection luntil } -{ $subsection lwhile } -{ $subsection lfrom-by } -{ $subsection lcomp } -{ $subsection lcomp* } ; +{ $subsections + lazy-map + lfilter + luntil + lwhile + lfrom-by + lcomp + lcomp* +} ; ARTICLE: { "lists.lazy" "io" } "Lazy list I/O" "Input from a stream can be read through a lazy list, using the following words:" -{ $subsection lcontents } -{ $subsection llines } ; +{ $subsections + lcontents + llines +} ; ARTICLE: { "lists.lazy" "construction" } "Constructing lazy lists" "Words for constructing lazy lists:" -{ $subsection lazy-cons } -{ $subsection 1lazy-list } -{ $subsection 2lazy-list } -{ $subsection 3lazy-list } -{ $subsection sequence-tail>list } -{ $subsection >list } -{ $subsection lfrom } ; +{ $subsections + lazy-cons + 1lazy-list + 2lazy-list + 3lazy-list + sequence-tail>list + >list + lfrom +} ; ARTICLE: { "lists.lazy" "manipulation" } "Manipulating lazy lists" "To make new lazy lists from old ones:" -{ $subsection <memoized-cons> } -{ $subsection lappend } -{ $subsection lconcat } -{ $subsection lcartesian-product } -{ $subsection lcartesian-product* } -{ $subsection lmerge } -{ $subsection ltake } ; +{ $subsections + <memoized-cons> + lappend + lconcat + lcartesian-product + lcartesian-product* + lmerge + ltake +} ; HELP: lazy-cons { $values { "car" { $quotation "( -- elt )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } } diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor index 1fdce5d51d..f70b6ff4a1 100644 --- a/basis/lists/lists-docs.factor +++ b/basis/lists/lists-docs.factor @@ -7,49 +7,61 @@ ABOUT: "lists" ARTICLE: "lists" "Lists" "The " { $vocab-link "lists" } " vocabulary implements linked lists. There are simple strict linked lists, but a generic list protocol allows the implementation of lazy lists as well." -{ $subsection { "lists" "protocol" } } -{ $subsection { "lists" "strict" } } -{ $subsection { "lists" "manipulation" } } -{ $subsection { "lists" "combinators" } } +{ $subsections + { "lists" "protocol" } + { "lists" "strict" } + { "lists" "manipulation" } + { "lists" "combinators" } +} { $vocab-subsection "Lazy lists" "lists.lazy" } ; ARTICLE: { "lists" "protocol" } "The list protocol" "Lists are instances of a mixin class:" -{ $subsection list } +{ $subsections list } "Instances of the mixin must implement the following words:" -{ $subsection car } -{ $subsection cdr } -{ $subsection nil? } ; +{ $subsections + car + cdr + nil? +} ; ARTICLE: { "lists" "strict" } "Constructing strict lists" "Strict lists are simply cons cells where the car and cdr have already been evaluated. These are the lists of Lisp. To construct a strict list, the following words are provided:" -{ $subsection cons } -{ $subsection swons } -{ $subsection sequence>list } -{ $subsection 1list } -{ $subsection 2list } -{ $subsection 3list } ; +{ $subsections + cons + swons + sequence>list + 1list + 2list + 3list +} ; ARTICLE: { "lists" "combinators" } "Combinators for lists" "Several combinators exist for list traversal." -{ $subsection leach } -{ $subsection lmap } -{ $subsection foldl } -{ $subsection foldr } -{ $subsection lmap>array } -{ $subsection traverse } ; +{ $subsections + leach + lmap + foldl + foldr + lmap>array + traverse +} ; ARTICLE: { "lists" "manipulation" } "Manipulating lists" "To get at the contents of a list:" -{ $subsection uncons } -{ $subsection unswons } -{ $subsection lnth } -{ $subsection cadr } -{ $subsection llength } +{ $subsections + uncons + unswons + lnth + cadr + llength +} "To get a new list from an old one:" -{ $subsection lreverse } -{ $subsection lappend } -{ $subsection lcut } ; +{ $subsections + lreverse + lappend + lcut +} ; HELP: cons { $values { "car" "the head of the list cell" } { "cdr" "the tail of the list cell" } { "cons" list } } diff --git a/basis/literals/literals-docs.factor b/basis/literals/literals-docs.factor index 1caa4b746f..a464d75b22 100644 --- a/basis/literals/literals-docs.factor +++ b/basis/literals/literals-docs.factor @@ -9,21 +9,21 @@ HELP: $ { $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } { $examples - { $example <" + { $example """ USING: kernel literals prettyprint ; IN: scratchpad CONSTANT: five 5 { $ five } . - "> "{ 5 }" } + """ "{ 5 }" } - { $example <" + { $example """ USING: kernel literals prettyprint ; IN: scratchpad : seven-eleven ( -- a b ) 7 11 ; { $ seven-eleven } . - "> "{ 7 11 }" } + """ "{ 7 11 }" } } ; @@ -33,13 +33,13 @@ HELP: $[ { $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." } { $examples - { $example <" + { $example """ USING: kernel literals math prettyprint ; IN: scratchpad << CONSTANT: five 5 >> { $[ five dup 1 + dup 2 + ] } . - "> "{ 5 6 8 }" } + """ "{ 5 6 8 }" } } ; @@ -49,14 +49,14 @@ HELP: ${ { $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } { $examples - { $example <" + { $example """ USING: kernel literals math prettyprint ; IN: scratchpad CONSTANT: five 5 CONSTANT: six 6 ${ five six 7 } . - "> "{ 5 6 7 }" + """ "{ 5 6 7 }" } } ; @@ -64,16 +64,17 @@ ${ five six 7 } . ARTICLE: "literals" "Interpolating code results into literal values" "The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values." -{ $example <" +{ $example """ USE: literals IN: scratchpad CONSTANT: five 5 { $ five $[ five dup 1 + dup 2 + ] } . - "> "{ 5 5 6 8 }" } -{ $subsection POSTPONE: $ } -{ $subsection POSTPONE: $[ } -{ $subsection POSTPONE: ${ } -; + """ "{ 5 5 6 8 }" } +{ $subsections + POSTPONE: $ + POSTPONE: $[ + POSTPONE: ${ +} ; ABOUT: "literals" diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index 0f94e0591a..c9c5e7330e 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -251,23 +251,29 @@ $nl "Compile-time transformation is used to compile local variables to efficient code; prettyprinter extensions are defined so that " { $link see } " can display original word definitions with local variables and not the closure-converted concatenative code which results." $nl "Applicative word definitions where the inputs are named local variables:" -{ $subsection POSTPONE: :: } -{ $subsection POSTPONE: M:: } -{ $subsection POSTPONE: MEMO:: } -{ $subsection POSTPONE: MACRO:: } +{ $subsections + POSTPONE: :: + POSTPONE: M:: + POSTPONE: MEMO:: + POSTPONE: MACRO:: +} "Lexical binding forms:" -{ $subsection POSTPONE: [let } -{ $subsection POSTPONE: [let* } -{ $subsection POSTPONE: [wlet } +{ $subsections + POSTPONE: [let + POSTPONE: [let* + POSTPONE: [wlet +} "Lambda abstractions:" -{ $subsection POSTPONE: [| } +{ $subsections POSTPONE: [| } "Lightweight binding form:" -{ $subsection POSTPONE: :> } +{ $subsections POSTPONE: :> } "Additional topics:" -{ $subsection "locals-literals" } -{ $subsection "locals-mutable" } -{ $subsection "locals-fry" } -{ $subsection "locals-limitations" } +{ $subsections + "locals-literals" + "locals-mutable" + "locals-fry" + "locals-limitations" +} "Locals complement dynamically scoped variables implemented in the " { $vocab-link "namespaces" } " vocabulary." ; ABOUT: "locals" diff --git a/basis/logging/analysis/analysis-docs.factor b/basis/logging/analysis/analysis-docs.factor index 98ad28e4f6..23d6c5d4f0 100644 --- a/basis/logging/analysis/analysis-docs.factor +++ b/basis/logging/analysis/analysis-docs.factor @@ -23,9 +23,11 @@ ARTICLE: "logging.analysis" "Log analysis" "The " { $vocab-link "logging.analysis" } " vocabulary builds on the " { $vocab-link "logging.parser" } " vocabulary. It parses log files and produces formatted summary reports. It is used by the " { $vocab-link "logging.insomniac" } " vocabulary to e-mail daily reports." $nl "Print log file summary:" -{ $subsection analyze-log } +{ $subsections analyze-log } "Factors:" -{ $subsection analyze-entries } -{ $subsection analysis. } ; +{ $subsections + analyze-entries + analysis. +} ; ABOUT: "logging.analysis" diff --git a/basis/logging/insomniac/insomniac-docs.factor b/basis/logging/insomniac/insomniac-docs.factor index c86a675698..ccec5e50cf 100644 --- a/basis/logging/insomniac/insomniac-docs.factor +++ b/basis/logging/insomniac/insomniac-docs.factor @@ -25,11 +25,13 @@ ARTICLE: "logging.insomniac" "Automated log analysis" "The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary." $nl "Required configuration parameters:" -{ $subsection insomniac-sender } -{ $subsection insomniac-recipients } +{ $subsections + insomniac-sender + insomniac-recipients +} "E-mailing a one-off report:" -{ $subsection email-log-report } +{ $subsections email-log-report } "E-mailing reports and rotating logs on a daily basis:" -{ $subsection schedule-insomniac } ; +{ $subsections schedule-insomniac } ; ABOUT: "logging.insomniac" diff --git a/basis/logging/logging-docs.factor b/basis/logging/logging-docs.factor index a4b3f3f019..2dc5918bda 100644 --- a/basis/logging/logging-docs.factor +++ b/basis/logging/logging-docs.factor @@ -19,23 +19,27 @@ HELP: CRITICAL ARTICLE: "logging.levels" "Log levels" "Several log levels are supported, from lowest to highest:" -{ $subsection DEBUG } -{ $subsection NOTICE } -{ $subsection WARNING } -{ $subsection ERROR } -{ $subsection CRITICAL } ; +{ $subsections + DEBUG + NOTICE + WARNING + ERROR + CRITICAL +} ; ARTICLE: "logging.files" "Log files" "Each application that wishes to use logging must choose a log service name; the following combinator should wrap the top level of the application:" -{ $subsection with-logging } +{ $subsections with-logging } "Log messages are written to " { $snippet "log-root/service/1.log" } ", where" { $list { { $snippet "log-root" } " is the Factor source directory by default, but can be overriden with the " { $link log-root } " variable" } { { $snippet "service" } " is the service name" } } "You can get the log path for a service:" -{ $subsection log-path } -{ $subsection log# } +{ $subsections + log-path + log# +} "New log entries are always sent to " { $snippet "1.log" } " but " { $link "logging.rotation" } " moves " { $snippet "1.log" } " to " { $snippet "2.log" } ", " { $snippet "2.log" } " to " { $snippet "3.log" } ", and so on." ; HELP: log-message @@ -77,15 +81,19 @@ HELP: LOG: ARTICLE: "logging.messages" "Logging messages" "Logging messages explicitly:" -{ $subsection log-message } -{ $subsection log-error } -{ $subsection log-critical } +{ $subsections + log-message + log-error + log-critical +} "A utility for defining words which just log and do nothing else:" -{ $subsection POSTPONE: LOG: } +{ $subsections POSTPONE: LOG: } "Annotating words to log; this uses the " { $link "tools.annotations" } " feature:" -{ $subsection add-input-logging } -{ $subsection add-output-logging } -{ $subsection add-error-logging } ; +{ $subsections + add-input-logging + add-output-logging + add-error-logging +} ; HELP: rotate-logs { $description "Rotates all logs. The highest numbered log file in each log directory is deleted, and each file is renamed so that its number increments by one. Subsequent logging calls will create a new #1 log file. This keeps log files from getting too large and makes them easier to search." } ; @@ -99,28 +107,32 @@ HELP: with-logging ARTICLE: "logging.rotation" "Log rotation" "Log files should be rotated periodically to prevent unbounded growth." -{ $subsection rotate-logs } -{ $subsection close-logs } +{ $subsections + rotate-logs + close-logs +} "The " { $vocab-link "logging.insomniac" } " vocabulary automates log rotation." ; ARTICLE: "logging.server" "Log implementation" "The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency.messaging" } ". User code never interacts with the server directly, instead it uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion." $nl "The " { $link log-message } " word sends a message to the server which results in the server executing an internal word:" -{ $subsection (log-message) } +{ $subsections (log-message) } "The " { $link rotate-logs } " word sends a message to the server which results in the server executing an internal word:" -{ $subsection (rotate-logs) } +{ $subsections (rotate-logs) } "The " { $link close-logs } " word sends a message to the server which results in the server executing an internal word:" -{ $subsection (close-logs) } ; +{ $subsections (close-logs) } ; ARTICLE: "logging" "Logging framework" "The " { $vocab-link "logging" } " vocabulary implements a comprehensive logging framework suitable for server-side production applications." -{ $subsection "logging.files" } -{ $subsection "logging.levels" } -{ $subsection "logging.messages" } -{ $subsection "logging.rotation" } -{ $subsection "logging.parser" } -{ $subsection "logging.analysis" } -{ $subsection "logging.server" } ; +{ $subsections + "logging.files" + "logging.levels" + "logging.messages" + "logging.rotation" + "logging.parser" + "logging.analysis" + "logging.server" +} ; ABOUT: "logging" diff --git a/basis/logging/parser/parser-docs.factor b/basis/logging/parser/parser-docs.factor index 7ab1ad3883..3a03fa3e78 100644 --- a/basis/logging/parser/parser-docs.factor +++ b/basis/logging/parser/parser-docs.factor @@ -16,6 +16,6 @@ ARTICLE: "logging.parser" "Log file parser" "The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $vocab-link "logging.insomniac" } " to analyze logs." $nl "There is only one primary entry point:" -{ $subsection parse-log } ; +{ $subsections parse-log } ; ABOUT: "logging.parser" diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor index 6a4672bea0..102bc79c7e 100755 --- a/basis/macros/macros-docs.factor +++ b/basis/macros/macros-docs.factor @@ -46,9 +46,9 @@ $nl "Factor macros are similar to Lisp macros; they are not like C preprocessor macros." $nl "Defining new macros:" -{ $subsection POSTPONE: MACRO: } +{ $subsections POSTPONE: MACRO: } "A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion." -{ $subsection define-transform } +{ $subsections define-transform } "An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." { $see-also "generalizations" "fry" } ; diff --git a/basis/match/match-docs.factor b/basis/match/match-docs.factor index 2e23721e93..8d840bc047 100644 --- a/basis/match/match-docs.factor +++ b/basis/match/match-docs.factor @@ -54,12 +54,12 @@ ARTICLE: "match" "Pattern matching" "The " { $vocab-link "match" } " vocabulary implements ML-style pattern matching." $nl "Variables used for pattern matching must be explicitly defined first:" -{ $subsection POSTPONE: MATCH-VARS: } +{ $subsections POSTPONE: MATCH-VARS: } "A basic pattern match:" -{ $subsection match } +{ $subsections match } "A conditional form analogous to " { $link cond } ":" -{ $subsection match-cond } +{ $subsections match-cond } "Pattern replacement:" -{ $subsection match-replace } ; +{ $subsections match-replace } ; ABOUT: "match" diff --git a/basis/math/bits/bits-docs.factor b/basis/math/bits/bits-docs.factor index 9e69823906..62ae38c828 100644 --- a/basis/math/bits/bits-docs.factor +++ b/basis/math/bits/bits-docs.factor @@ -7,9 +7,11 @@ ABOUT: "math.bits" ARTICLE: "math.bits" "Number bits virtual sequence" "The " { $vocab-link "math.bits" } " vocabulary implements a virtual sequence which presents an integer as a sequence of bits, with the first element of the sequence being the least significant bit of the integer." -{ $subsection bits } -{ $subsection <bits> } -{ $subsection make-bits } ; +{ $subsections + bits + <bits> + make-bits +} ; HELP: bits { $class-description "Virtual sequence class of bits of a number. The first bit is the least significant bit. This can be constructed with " { $link <bits> } " or " { $link make-bits } "." } ; diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor index 38bccd1dca..5dce9646f4 100755 --- a/basis/math/bitwise/bitwise-docs.factor +++ b/basis/math/bitwise/bitwise-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs help.markup help.syntax math sequences ; +USING: assocs help.markup help.syntax math sequences kernel ; IN: math.bitwise HELP: bitfield @@ -67,17 +67,21 @@ HELP: bit-clear? HELP: bit-count { $values - { "x" integer } + { "obj" object } { "n" integer } } -{ $description "Returns the number of set bits as an integer." } +{ $description "Returns the number of set bits as an object. This word only works on non-negative integers or objects that can be represented as a byte-array." } { $examples { $example "USING: math.bitwise prettyprint ;" "HEX: f0 bit-count ." "4" } { $example "USING: math.bitwise prettyprint ;" - "-7 bit-count ." + "-1 32 bits bit-count ." + "32" + } + { $example "USING: math.bitwise prettyprint ;" + "B{ 1 0 1 } bit-count ." "2" } } ; @@ -132,9 +136,7 @@ HELP: clear-bit } ; HELP: flags -{ $values - { "values" sequence } -} +{ $values { "values" sequence } } { $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at compile-time, which makes this word as efficient as using a literal integer." } { $examples { $example "USING: math.bitwise kernel prettyprint ;" @@ -208,6 +210,20 @@ HELP: mask? } } ; +HELP: even-parity? +{ $values + { "obj" object } + { "?" boolean } +} +{ $description "Returns true if the number of set bits in an object is even." } ; + +HELP: odd-parity? +{ $values + { "obj" object } + { "?" boolean } +} +{ $description "Returns true if the number of set bits in an object is odd." } ; + HELP: on-bits { $values { "n" integer } @@ -344,38 +360,52 @@ HELP: wrap ARTICLE: "math-bitfields" "Constructing bit fields" "Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:" -{ $subsection bitfield } ; +{ $subsections bitfield } ; ARTICLE: "math.bitwise" "Additional bitwise arithmetic" "The " { $vocab-link "math.bitwise" } " vocabulary provides bitwise arithmetic words extending " { $link "bitwise-arithmetic" } ". They are useful for efficiency, low-level programming, and interfacing with C libraries." $nl "Setting and clearing bits:" -{ $subsection set-bit } -{ $subsection clear-bit } +{ $subsections + set-bit + clear-bit +} "Testing if bits are set or clear:" -{ $subsection bit? } -{ $subsection bit-clear? } +{ $subsections + bit? + bit-clear? +} "Operations with bitmasks:" -{ $subsection mask } -{ $subsection unmask } -{ $subsection mask? } -{ $subsection unmask? } +{ $subsections + mask + unmask + mask? + unmask? +} "Generating an integer with n set bits:" -{ $subsection on-bits } +{ $subsections on-bits } "Counting the number of set bits:" -{ $subsection bit-count } +{ $subsections bit-count } +"Testing the parity of an object:" +{ $subsections even-parity? odd-parity? } "More efficient modding by powers of two:" -{ $subsection wrap } +{ $subsections wrap } "Bit-rolling:" -{ $subsection bitroll } -{ $subsection bitroll-32 } -{ $subsection bitroll-64 } +{ $subsections + bitroll + bitroll-32 + bitroll-64 +} "32-bit arithmetic:" -{ $subsection w+ } -{ $subsection w- } -{ $subsection w* } +{ $subsections + w+ + w- + w* +} "Bitfields:" -{ $subsection flags } -{ $subsection "math-bitfields" } ; +{ $subsections + flags + "math-bitfields" +} ; ABOUT: "math.bitwise" diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor index d1e6c11b6c..d10e4ccc87 100644 --- a/basis/math/bitwise/bitwise-tests.factor +++ b/basis/math/bitwise/bitwise-tests.factor @@ -1,4 +1,7 @@ -USING: accessors math math.bitwise tools.test kernel words ; +USING: accessors math math.bitwise tools.test kernel words +specialized-arrays alien.c-types math.vectors.simd +sequences destructors libc ; +SPECIALIZED-ARRAY: int IN: math.bitwise.tests [ 0 ] [ 1 0 0 bitroll ] unit-test @@ -37,3 +40,23 @@ CONSTANT: b 2 [ 4 ] [ BIN: 1010101 bit-count ] unit-test [ 0 ] [ BIN: 0 bit-count ] unit-test [ 1 ] [ BIN: 1 bit-count ] unit-test + +SIMD: uint +SPECIALIZED-ARRAY: uint +SPECIALIZED-ARRAY: uint-4 + +[ 1 ] [ uint-4{ 1 0 0 0 } bit-count ] unit-test + +[ 1 ] [ + [ + 2 malloc-int-array &free 1 0 pick set-nth bit-count + ] with-destructors +] unit-test + +[ 1 ] [ B{ 1 0 0 } bit-count ] unit-test +[ 3 ] [ B{ 1 1 1 } bit-count ] unit-test + +[ t ] [ BIN: 0 even-parity? ] unit-test +[ f ] [ BIN: 1 even-parity? ] unit-test +[ f ] [ BIN: 0 odd-parity? ] unit-test +[ t ] [ BIN: 1 odd-parity? ] unit-test diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index bed065a800..204f295944 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -1,7 +1,9 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs combinators combinators.smart fry kernel -macros math math.bits sequences sequences.private words ; +macros math math.bits sequences sequences.private words +byte-arrays alien alien.c-types specialized-arrays ; +SPECIALIZED-ARRAY: uchar IN: math.bitwise ! utilities @@ -84,24 +86,36 @@ DEFER: byte-bit-count GENERIC: (bit-count) ( x -- n ) M: fixnum (bit-count) - [ - { - [ byte-bit-count ] - [ -8 shift byte-bit-count ] - [ -16 shift byte-bit-count ] - [ -24 shift byte-bit-count ] - } cleave - ] sum-outputs ; + 0 swap [ + dup 0 > + ] [ + [ 8 bits byte-bit-count ] [ -8 shift ] bi + [ + ] dip + ] while drop ; M: bignum (bit-count) dup 0 = [ drop 0 ] [ [ byte-bit-count ] [ -8 shift (bit-count) ] bi + ] if ; +: byte-array-bit-count ( byte-array -- n ) + 0 [ byte-bit-count + ] reduce ; + PRIVATE> -: bit-count ( x -- n ) - dup 0 < [ bitnot ] when (bit-count) ; inline +ERROR: invalid-bit-count-target object ; + +GENERIC: bit-count ( obj -- n ) + +M: integer bit-count + dup 0 < [ invalid-bit-count-target ] when (bit-count) ; inline + +M: byte-array bit-count + byte-array-bit-count ; + +M: object bit-count + [ >c-ptr ] [ byte-length ] bi <direct-uchar-array> + byte-array-bit-count ; : >signed ( x n -- y ) 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ; @@ -113,3 +127,7 @@ PRIVATE> : next-even ( m -- n ) >even 2 + ; foldable : next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable + +: even-parity? ( obj -- ? ) bit-count even? ; + +: odd-parity? ( obj -- ? ) bit-count odd? ; diff --git a/basis/math/blas/config/config-docs.factor b/basis/math/blas/config/config-docs.factor index 60eaff25c2..5c6cef83b8 100644 --- a/basis/math/blas/config/config-docs.factor +++ b/basis/math/blas/config/config-docs.factor @@ -1,16 +1,18 @@ -USING: alien.fortran help.markup help.syntax math.blas.config multiline ; +USING: alien.fortran help.markup help.syntax math.blas.config ; IN: math.blas.config ARTICLE: "math.blas.config" "Configuring the BLAS interface" "The " { $link "math.blas-summary" } " chooses the underlying BLAS interface to use based on the values of the following global variables:" -{ $subsection blas-library } -{ $subsection blas-fortran-abi } +{ $subsections + blas-library + blas-fortran-abi +} "The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:" -{ $code <" +{ $code """ USING: math.blas.config namespaces ; "X:\\path\\to\\acml.dll" blas-library set-global intel-windows-abi blas-fortran-abi set-global -"> } +""" } "To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded." ; diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor index 5662cd9905..6993c79bdb 100644 --- a/basis/math/blas/matrices/matrices-docs.factor +++ b/basis/math/blas/matrices/matrices-docs.factor @@ -1,84 +1,106 @@ -USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings multiline ; +USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ; IN: math.blas.matrices ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface" "Factor provides an interface to high-performance vector and matrix math routines available in implementations of the BLAS math library. A set of specialized types are provided for handling packed, unboxed vector data:" -{ $subsection "math.blas-types" } +{ $subsections "math.blas-types" } "Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:" -{ $subsection "math.blas.vectors" } +{ $subsections "math.blas.vectors" } "Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:" -{ $subsection "math.blas.matrices" } +{ $subsections "math.blas.matrices" } "The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary. The BLAS interface can be configured to use different underlying BLAS implementations:" -{ $subsection "math.blas.config" } ; +{ $subsections "math.blas.config" } ; ARTICLE: "math.blas-types" "BLAS interface types" "BLAS vectors come in single- and double-precision, real and complex flavors:" -{ $subsection float-blas-vector } -{ $subsection double-blas-vector } -{ $subsection complex-float-blas-vector } -{ $subsection complex-double-blas-vector } +{ $subsections + float-blas-vector + double-blas-vector + complex-float-blas-vector + complex-double-blas-vector +} "These vector types all follow the " { $link sequence } " protocol. In addition, there are corresponding types for matrix data:" -{ $subsection float-blas-matrix } -{ $subsection double-blas-matrix } -{ $subsection complex-float-blas-matrix } -{ $subsection complex-double-blas-matrix } +{ $subsections + float-blas-matrix + double-blas-matrix + complex-float-blas-matrix + complex-double-blas-matrix +} "There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:" -{ $subsection <float-blas-vector> } -{ $subsection <double-blas-vector> } -{ $subsection <complex-float-blas-vector> } -{ $subsection <complex-double-blas-vector> } -{ $subsection <float-blas-matrix> } -{ $subsection <double-blas-matrix> } -{ $subsection <complex-float-blas-matrix> } -{ $subsection <complex-double-blas-matrix> } +{ $subsections + <float-blas-vector> + <double-blas-vector> + <complex-float-blas-vector> + <complex-double-blas-vector> + <float-blas-matrix> + <double-blas-matrix> + <complex-float-blas-matrix> + <complex-double-blas-matrix> +} "For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:" -{ $subsection <empty-vector> } -{ $subsection <empty-matrix> } +{ $subsections + <empty-vector> + <empty-matrix> +} "BLAS vectors and matrices can also be constructed from other Factor sequences:" -{ $subsection >float-blas-vector } -{ $subsection >double-blas-vector } -{ $subsection >complex-float-blas-vector } -{ $subsection >complex-double-blas-vector } -{ $subsection >float-blas-matrix } -{ $subsection >double-blas-matrix } -{ $subsection >complex-float-blas-matrix } -{ $subsection >complex-double-blas-matrix } ; +{ $subsections + >float-blas-vector + >double-blas-vector + >complex-float-blas-vector + >complex-double-blas-vector + >float-blas-matrix + >double-blas-matrix + >complex-float-blas-matrix + >complex-double-blas-matrix +} ; ARTICLE: "math.blas.matrices" "BLAS interface matrix operations" "Transposing and slicing matrices:" -{ $subsection Mtranspose } -{ $subsection Mrows } -{ $subsection Mcols } -{ $subsection Msub } +{ $subsections + Mtranspose + Mrows + Mcols + Msub +} "Matrix-vector products:" -{ $subsection n*M.V+n*V! } -{ $subsection n*M.V+n*V } -{ $subsection n*M.V } -{ $subsection M.V } +{ $subsections + n*M.V+n*V! + n*M.V+n*V + n*M.V + M.V +} "Vector outer products:" -{ $subsection n*V(*)V+M! } -{ $subsection n*V(*)Vconj+M! } -{ $subsection n*V(*)V+M } -{ $subsection n*V(*)Vconj+M } -{ $subsection n*V(*)V } -{ $subsection n*V(*)Vconj } -{ $subsection V(*) } -{ $subsection V(*)conj } +{ $subsections + n*V(*)V+M! + n*V(*)Vconj+M! + n*V(*)V+M + n*V(*)Vconj+M + n*V(*)V + n*V(*)Vconj + V(*) + V(*)conj +} "Matrix products:" -{ $subsection n*M.M+n*M! } -{ $subsection n*M.M+n*M } -{ $subsection n*M.M } -{ $subsection M. } +{ $subsections + n*M.M+n*M! + n*M.M+n*M + n*M.M + M. +} "Scalar-matrix products:" -{ $subsection n*M! } -{ $subsection n*M } -{ $subsection M*n } -{ $subsection M/n } +{ $subsections + n*M! + n*M + M*n + M/n +} "Literal syntax:" -{ $subsection POSTPONE: smatrix{ } -{ $subsection POSTPONE: dmatrix{ } -{ $subsection POSTPONE: cmatrix{ } -{ $subsection POSTPONE: zmatrix{ } ; +{ $subsections + POSTPONE: smatrix{ + POSTPONE: dmatrix{ + POSTPONE: cmatrix{ + POSTPONE: zmatrix{ +} ; ABOUT: "math.blas.matrices" @@ -249,39 +271,39 @@ HELP: <empty-vector> { $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ; HELP: smatrix{ -{ $syntax <" smatrix{ +{ $syntax """smatrix{ { 1.0 0.0 0.0 1.0 } { 0.0 1.0 0.0 2.0 } { 0.0 0.0 1.0 3.0 } { 0.0 0.0 0.0 1.0 } -} "> } +}""" } { $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; HELP: dmatrix{ -{ $syntax <" dmatrix{ +{ $syntax """dmatrix{ { 1.0 0.0 0.0 1.0 } { 0.0 1.0 0.0 2.0 } { 0.0 0.0 1.0 3.0 } { 0.0 0.0 0.0 1.0 } -} "> } +}""" } { $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; HELP: cmatrix{ -{ $syntax <" cmatrix{ +{ $syntax """cmatrix{ { 1.0 0.0 0.0 1.0 } { 0.0 C{ 0.0 1.0 } 0.0 2.0 } { 0.0 0.0 -1.0 3.0 } { 0.0 0.0 0.0 C{ 0.0 -1.0 } } -} "> } +}""" } { $description "Construct a literal " { $link complex-float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; HELP: zmatrix{ -{ $syntax <" zmatrix{ +{ $syntax """zmatrix{ { 1.0 0.0 0.0 1.0 } { 0.0 C{ 0.0 1.0 } 0.0 2.0 } { 0.0 0.0 -1.0 3.0 } { 0.0 0.0 0.0 C{ 0.0 -1.0 } } -} "> } +}""" } { $description "Construct a literal " { $link complex-double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; { diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index aa9681bb2e..0a6fc147ad 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -1,10 +1,11 @@ -USING: accessors alien alien.c-types alien.data arrays -byte-arrays combinators combinators.short-circuit fry -kernel locals macros math math.blas.ffi math.blas.vectors -math.blas.vectors.private math.complex math.functions -math.order functors words sequences sequences.merged -sequences.private shuffle parser prettyprint.backend -prettyprint.custom ascii specialized-arrays ; +USING: accessors alien alien.c-types alien.complex +alien.data arrays byte-arrays combinators +combinators.short-circuit fry kernel locals macros math +math.blas.ffi math.blas.vectors math.blas.vectors.private +math.complex math.functions math.order functors words +sequences sequences.merged sequences.private shuffle +parser prettyprint.backend prettyprint.custom ascii +specialized-arrays ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: double diff --git a/basis/math/blas/vectors/vectors-docs.factor b/basis/math/blas/vectors/vectors-docs.factor index badc317189..aa8faa4bce 100644 --- a/basis/math/blas/vectors/vectors-docs.factor +++ b/basis/math/blas/vectors/vectors-docs.factor @@ -3,32 +3,42 @@ IN: math.blas.vectors ARTICLE: "math.blas.vectors" "BLAS interface vector operations" "Slicing vectors:" -{ $subsection Vsub } +{ $subsections Vsub } "Taking the norm (magnitude) of a vector:" -{ $subsection Vnorm } +{ $subsections Vnorm } "Summing and taking the maximum of elements:" -{ $subsection Vasum } -{ $subsection Viamax } -{ $subsection Vamax } +{ $subsections + Vasum + Viamax + Vamax +} "Scalar-vector products:" -{ $subsection n*V! } -{ $subsection n*V } -{ $subsection V*n } -{ $subsection V/n } -{ $subsection Vneg } +{ $subsections + n*V! + n*V + V*n + V/n + Vneg +} "Vector addition:" -{ $subsection n*V+V! } -{ $subsection n*V+V } -{ $subsection V+ } -{ $subsection V- } +{ $subsections + n*V+V! + n*V+V + V+ + V- +} "Vector inner products:" -{ $subsection V. } -{ $subsection V.conj } +{ $subsections + V. + V.conj +} "Literal syntax:" -{ $subsection POSTPONE: svector{ } -{ $subsection POSTPONE: dvector{ } -{ $subsection POSTPONE: cvector{ } -{ $subsection POSTPONE: zvector{ } ; +{ $subsections + POSTPONE: svector{ + POSTPONE: dvector{ + POSTPONE: cvector{ + POSTPONE: zvector{ +} ; ABOUT: "math.blas.vectors" diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 20ee7925b0..8d057de720 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -1,8 +1,8 @@ -USING: accessors alien alien.c-types arrays ascii byte-arrays combinators -combinators.short-circuit fry kernel math math.blas.ffi -math.complex math.functions math.order sequences sequences.private -functors words locals parser prettyprint.backend prettyprint.custom -specialized-arrays ; +USING: accessors alien alien.c-types alien.complex arrays ascii +byte-arrays combinators combinators.short-circuit fry kernel +math math.blas.ffi math.complex math.functions math.order +sequences sequences.private functors words locals parser +prettyprint.backend prettyprint.custom specialized-arrays ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: double diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 0e0b7ae167..10584f2004 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax kernel math math.order multiline sequences ; +USING: help.markup help.syntax kernel math math.order sequences ; IN: math.combinatorics HELP: factorial @@ -76,14 +76,14 @@ HELP: all-combinations { $examples { $example "USING: math.combinatorics prettyprint ;" "{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ." -<" { +"""{ { "a" "b" } { "a" "c" } { "a" "d" } { "b" "c" } { "b" "d" } { "c" "d" } -}"> } } ; +}""" } } ; HELP: each-combination { $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } } diff --git a/basis/math/complex/complex-docs.factor b/basis/math/complex/complex-docs.factor index 9cb80447e5..0bb86b6c28 100644 --- a/basis/math/complex/complex-docs.factor +++ b/basis/math/complex/complex-docs.factor @@ -10,16 +10,20 @@ ARTICLE: "complex-numbers-zero" "Embedding of real numbers in complex numbers" "Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." ; ARTICLE: "complex-numbers" "Complex numbers" -{ $subsection complex } +{ $subsections complex } "Complex numbers arise as solutions to quadratic equations whose graph does not intersect the " { $emphasis "x" } " axis. Their literal syntax is covered in " { $link "syntax-complex-numbers" } "." $nl "Complex numbers can be taken apart:" -{ $subsection real-part } -{ $subsection imaginary-part } -{ $subsection >rect } +{ $subsections + real-part + imaginary-part + >rect +} "Complex numbers can be constructed from real numbers:" -{ $subsection rect> } -{ $subsection "complex-numbers-zero" } +{ $subsections + rect> + "complex-numbers-zero" +} { $see-also "syntax-complex-numbers" } ; HELP: complex { $class-description "The class of complex numbers with non-zero imaginary part." } ; diff --git a/basis/math/constants/constants-docs.factor b/basis/math/constants/constants-docs.factor index 117cd70c67..e8462fccc4 100644 --- a/basis/math/constants/constants-docs.factor +++ b/basis/math/constants/constants-docs.factor @@ -3,12 +3,14 @@ IN: math.constants ARTICLE: "math-constants" "Constants" "Standard mathematical constants:" -{ $subsection e } -{ $subsection euler } -{ $subsection phi } -{ $subsection pi } -{ $subsection epsilon } -{ $subsection single-epsilon } ; +{ $subsections + e + euler + phi + pi + epsilon + single-epsilon +} ; ABOUT: "math-constants" diff --git a/basis/math/floats/env/env-docs.factor b/basis/math/floats/env/env-docs.factor index 0fc781713c..be0e87fde0 100644 --- a/basis/math/floats/env/env-docs.factor +++ b/basis/math/floats/env/env-docs.factor @@ -117,21 +117,29 @@ ARTICLE: "math.floats.env" "Controlling the floating-point environment" "The " { $vocab-link "math.floats.env" } " vocabulary contains words for querying and controlling the floating-point environment." $nl "Querying and setting exception flags:" -{ $subsection fp-exception-flags } -{ $subsection set-fp-exception-flags } -{ $subsection clear-fp-exception-flags } -{ $subsection collect-fp-exceptions } +{ $subsections + fp-exception-flags + set-fp-exception-flags + clear-fp-exception-flags + collect-fp-exceptions +} "Querying and controlling processor traps for floating-point exceptions:" -{ $subsection fp-traps } -{ $subsection with-fp-traps } -{ $subsection without-fp-traps } +{ $subsections + fp-traps + with-fp-traps + without-fp-traps +} "Getting the floating-point exception state from errors raised by enabled traps:" -{ $subsection vm-error>exception-flags } -{ $subsection vm-error-exception-flag? } +{ $subsections + vm-error>exception-flags + vm-error-exception-flag? +} "Querying and controlling the rounding mode and treatment of denormals:" -{ $subsection rounding-mode } -{ $subsection with-rounding-mode } -{ $subsection denormal-mode } -{ $subsection with-denormal-mode } ; +{ $subsections + rounding-mode + with-rounding-mode + denormal-mode + with-denormal-mode +} ; ABOUT: "math.floats.env" diff --git a/basis/math/floats/env/env-tests.factor b/basis/math/floats/env/env-tests.factor index 7f5a20efd0..3c21b0cf3e 100644 --- a/basis/math/floats/env/env-tests.factor +++ b/basis/math/floats/env/env-tests.factor @@ -29,6 +29,7 @@ set-default-fp-env [ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test [ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test [ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test +[ t ] +fp-invalid-operation+ [ 2.0 0/0. 1.0e-9 ] [ ~ ] test-fp-exception-compiled unit-test ! No underflow on Linux with this test, just inexact. Reported as an Ubuntu bug: ! https://bugs.launchpad.net/ubuntu/+source/glibc/+bug/429113 @@ -109,72 +110,77 @@ os linux? cpu x86.64? and [ -1.0 3.0 /f double>bits ] unit-test -: test-traps ( traps inputs quot -- quot' ) - append '[ _ _ with-fp-traps ] ; - -: test-traps-compiled ( traps inputs quot -- quot' ) - swapd '[ @ [ _ _ with-fp-traps ] compile-call ] ; - -{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail -{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail -{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail -{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail -{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail - -{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail -{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail -{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail -{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail -{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail - -! Ensure ordered comparisons raise traps -:: test-comparison-quot ( word -- quot ) - [ - { float float } declare - { +fp-invalid-operation+ } [ word execute ] with-fp-traps - ] ; - -: test-comparison ( inputs word -- quot ) - test-comparison-quot append ; - -: test-comparison-compiled ( inputs word -- quot ) - test-comparison-quot '[ @ _ compile-call ] ; - -\ float< "intrinsic" word-prop [ - [ 0/0. -15.0 ] \ < test-comparison must-fail - [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail - [ -15.0 0/0. ] \ < test-comparison must-fail - [ -15.0 0/0. ] \ < test-comparison-compiled must-fail - [ 0/0. -15.0 ] \ <= test-comparison must-fail - [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail - [ -15.0 0/0. ] \ <= test-comparison must-fail - [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail - [ 0/0. -15.0 ] \ > test-comparison must-fail - [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail - [ -15.0 0/0. ] \ > test-comparison must-fail - [ -15.0 0/0. ] \ > test-comparison-compiled must-fail - [ 0/0. -15.0 ] \ >= test-comparison must-fail - [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail - [ -15.0 0/0. ] \ >= test-comparison must-fail - [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail - - [ f ] [ 0/0. -15.0 ] \ u< test-comparison unit-test - [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled unit-test - [ f ] [ -15.0 0/0. ] \ u< test-comparison unit-test - [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled unit-test - [ f ] [ 0/0. -15.0 ] \ u<= test-comparison unit-test - [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled unit-test - [ f ] [ -15.0 0/0. ] \ u<= test-comparison unit-test - [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled unit-test - [ f ] [ 0/0. -15.0 ] \ u> test-comparison unit-test - [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled unit-test - [ f ] [ -15.0 0/0. ] \ u> test-comparison unit-test - [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled unit-test - [ f ] [ 0/0. -15.0 ] \ u>= test-comparison unit-test - [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled unit-test - [ f ] [ -15.0 0/0. ] \ u>= test-comparison unit-test - [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled unit-test -] when +! FP traps cause a kernel panic on OpenBSD 4.5 i386 +os openbsd eq? cpu x86.32 eq? and [ + + : test-traps ( traps inputs quot -- quot' ) + append '[ _ _ with-fp-traps ] ; + + : test-traps-compiled ( traps inputs quot -- quot' ) + swapd '[ @ [ _ _ with-fp-traps ] compile-call ] ; + + { +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail + { +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail + { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail + { +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail + { +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail + + { +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail + { +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail + { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail + { +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail + { +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail + + ! Ensure ordered comparisons raise traps + :: test-comparison-quot ( word -- quot ) + [ + { float float } declare + { +fp-invalid-operation+ } [ word execute ] with-fp-traps + ] ; + + : test-comparison ( inputs word -- quot ) + test-comparison-quot append ; + + : test-comparison-compiled ( inputs word -- quot ) + test-comparison-quot '[ @ _ compile-call ] ; + + \ float< "intrinsic" word-prop [ + [ 0/0. -15.0 ] \ < test-comparison must-fail + [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail + [ -15.0 0/0. ] \ < test-comparison must-fail + [ -15.0 0/0. ] \ < test-comparison-compiled must-fail + [ 0/0. -15.0 ] \ <= test-comparison must-fail + [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail + [ -15.0 0/0. ] \ <= test-comparison must-fail + [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail + [ 0/0. -15.0 ] \ > test-comparison must-fail + [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail + [ -15.0 0/0. ] \ > test-comparison must-fail + [ -15.0 0/0. ] \ > test-comparison-compiled must-fail + [ 0/0. -15.0 ] \ >= test-comparison must-fail + [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail + [ -15.0 0/0. ] \ >= test-comparison must-fail + [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail + + [ f ] [ 0/0. -15.0 ] \ u< test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u< test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled unit-test + [ f ] [ 0/0. -15.0 ] \ u<= test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u<= test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled unit-test + [ f ] [ 0/0. -15.0 ] \ u> test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u> test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled unit-test + [ f ] [ 0/0. -15.0 ] \ u>= test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u>= test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled unit-test + ] when + +] unless ! Ensure traps get cleared [ 1/0. ] [ 1.0 0.0 /f ] unit-test diff --git a/basis/math/floats/env/ppc/ppc.factor b/basis/math/floats/env/ppc/ppc.factor index d6a6ae6834..f635a2a0f1 100644 --- a/basis/math/floats/env/ppc/ppc.factor +++ b/basis/math/floats/env/ppc/ppc.factor @@ -1,6 +1,6 @@ -USING: accessors alien.syntax arrays assocs biassocs -classes.struct combinators kernel literals math math.bitwise -math.floats.env math.floats.env.private system ; +USING: accessors alien.c-types alien.syntax arrays assocs +biassocs classes.struct combinators kernel literals math +math.bitwise math.floats.env math.floats.env.private system ; IN: math.floats.env.ppc STRUCT: ppc-fpu-env diff --git a/basis/math/floats/env/x86/x86.factor b/basis/math/floats/env/x86/x86.factor index e91fc4eda9..2b73628b4c 100644 --- a/basis/math/floats/env/x86/x86.factor +++ b/basis/math/floats/env/x86/x86.factor @@ -1,7 +1,7 @@ -USING: accessors alien.syntax arrays assocs biassocs -classes.struct combinators cpu.x86.features kernel literals -math math.bitwise math.floats.env math.floats.env.private -system ; +USING: accessors alien.c-types alien.syntax arrays assocs +biassocs classes.struct combinators cpu.x86.features kernel +literals math math.bitwise math.floats.env +math.floats.env.private system ; IN: math.floats.env.x86 STRUCT: sse-env @@ -31,9 +31,7 @@ M: x87-env (set-fp-env-register) set_x87_env ; M: x86 (fp-env-registers) - sse-version 20 >= - [ <sse-env> <x87-env> 2array ] - [ <x87-env> 1array ] if ; + sse2? [ <sse-env> <x87-env> 2array ] [ <x87-env> 1array ] if ; CONSTANT: sse-exception-flag-bits HEX: 3f CONSTANT: sse-exception-flag>bit diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index fb392191d4..5b1920f572 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -3,103 +3,91 @@ sequences quotations math.functions.private ; IN: math.functions ARTICLE: "integer-functions" "Integer functions" -{ $subsection align } -{ $subsection gcd } -{ $subsection log2 } -{ $subsection next-power-of-2 } +{ $subsections + align + gcd + log2 + next-power-of-2 +} "Modular exponentiation:" -{ $subsection ^mod } -{ $subsection mod-inv } +{ $subsections ^mod mod-inv } "Tests:" -{ $subsection power-of-2? } -{ $subsection even? } -{ $subsection odd? } -{ $subsection divisor? } ; +{ $subsections + power-of-2? + even? + odd? + divisor? +} ; ARTICLE: "arithmetic-functions" "Arithmetic functions" "Computing additive and multiplicative inverses:" -{ $subsection neg } -{ $subsection recip } +{ $subsections neg recip } "Complex conjugation:" -{ $subsection conjugate } +{ $subsections conjugate } "Tests:" -{ $subsection zero? } -{ $subsection between? } +{ $subsections zero? between? } "Control flow:" -{ $subsection if-zero } -{ $subsection when-zero } -{ $subsection unless-zero } +{ $subsections + if-zero + when-zero + unless-zero +} "Sign:" -{ $subsection sgn } +{ $subsections sgn } "Rounding:" -{ $subsection ceiling } -{ $subsection floor } -{ $subsection truncate } -{ $subsection round } +{ $subsections + ceiling + floor + truncate + round +} "Inexact comparison:" -{ $subsection ~ } +{ $subsections ~ } "Numbers implement the " { $link "math.order" } ", therefore operations such as " { $link min } " and " { $link max } " can be used with numbers." ; ARTICLE: "power-functions" "Powers and logarithms" "Squares:" -{ $subsection sq } -{ $subsection sqrt } +{ $subsections sq sqrt } "Exponential and natural logarithm:" -{ $subsection exp } -{ $subsection cis } -{ $subsection log } +{ $subsections exp cis log } "Other logarithms:" -{ $subsection log1+ } -{ $subsection log10 } +{ $subsections log1+ log10 } "Raising a number to a power:" -{ $subsection ^ } -{ $subsection 10^ } +{ $subsections ^ 10^ } "Converting between rectangular and polar form:" -{ $subsection abs } -{ $subsection absq } -{ $subsection arg } -{ $subsection >polar } -{ $subsection polar> } ; +{ $subsections + abs + absq + arg + >polar + polar> +} ; ARTICLE: "trig-hyp-functions" "Trigonometric and hyperbolic functions" "Trigonometric functions:" -{ $subsection cos } -{ $subsection sin } -{ $subsection tan } +{ $subsections cos sin tan } "Reciprocals:" -{ $subsection sec } -{ $subsection cosec } -{ $subsection cot } +{ $subsections sec cosec cot } "Inverses:" -{ $subsection acos } -{ $subsection asin } -{ $subsection atan } +{ $subsections acos asin atan } "Inverse reciprocals:" -{ $subsection asec } -{ $subsection acosec } -{ $subsection acot } +{ $subsections asec acosec acot } "Hyperbolic functions:" -{ $subsection cosh } -{ $subsection sinh } -{ $subsection tanh } +{ $subsections cosh sinh tanh } "Reciprocals:" -{ $subsection sech } -{ $subsection cosech } -{ $subsection coth } +{ $subsections sech cosech coth } "Inverses:" -{ $subsection acosh } -{ $subsection asinh } -{ $subsection atanh } +{ $subsections acosh asinh atanh } "Inverse reciprocals:" -{ $subsection asech } -{ $subsection acosech } -{ $subsection acoth } ; +{ $subsections asech acosech acoth } ; ARTICLE: "math-functions" "Mathematical functions" -{ $subsection "integer-functions" } -{ $subsection "arithmetic-functions" } -{ $subsection "power-functions" } -{ $subsection "trig-hyp-functions" } ; +{ $subsections + "integer-functions" + "arithmetic-functions" + "power-functions" + "trig-hyp-functions" +} ; ABOUT: "math-functions" diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 4502e993a3..1914bae008 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -44,8 +44,14 @@ IN: math.functions.tests [ 4.0 ] [ 10000.0 log10 ] unit-test [ t ] [ 1 exp e 1.e-10 ~ ] unit-test +[ f ] [ 1 exp 0/0. 1.e-10 ~ ] unit-test +[ f ] [ 0/0. 1 exp 1.e-10 ~ ] unit-test [ t ] [ 1.0 exp e 1.e-10 ~ ] unit-test [ t ] [ -1 exp e * 1.0 1.e-10 ~ ] unit-test +[ f ] [ 1/0. 1/0. 1.e-10 ~ ] unit-test +[ f ] [ 1/0. -1/0. 1.e-10 ~ ] unit-test +[ f ] [ 1/0. 0/0. 1.e-10 ~ ] unit-test +[ f ] [ 0/0. -1/0. 1.e-10 ~ ] unit-test [ 1.0 ] [ 0 cosh ] unit-test [ 1.0 ] [ 0.0 cosh ] unit-test diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index a31b6ee7cc..a9ad003411 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -141,7 +141,6 @@ M: real absq sq ; inline : ~ ( x y epsilon -- ? ) { - { [ 2over [ fp-nan? ] either? ] [ 3drop f ] } { [ dup zero? ] [ drop number= ] } { [ dup 0 < ] [ neg ~rel ] } [ ~abs ] diff --git a/basis/math/intervals/intervals-docs.factor b/basis/math/intervals/intervals-docs.factor index 0c0f95b48c..7e0a9a3b51 100644 --- a/basis/math/intervals/intervals-docs.factor +++ b/basis/math/intervals/intervals-docs.factor @@ -3,67 +3,81 @@ IN: math.intervals ARTICLE: "math-intervals-new" "Creating intervals" "Standard constructors:" -{ $subsection [a,b] } -{ $subsection (a,b) } -{ $subsection [a,b) } -{ $subsection (a,b] } +{ $subsections + [a,b] + (a,b) + [a,b) + (a,b] +} "One-point interval constructor:" -{ $subsection [a,a] } +{ $subsections [a,a] } "Open-ended interval constructors:" -{ $subsection [-inf,a] } -{ $subsection [-inf,a) } -{ $subsection [a,inf] } -{ $subsection (a,inf] } +{ $subsections + [-inf,a] + [-inf,a) + [a,inf] + (a,inf] +} "The set of all real numbers with infinities:" -{ $subsection [-inf,inf] } +{ $subsections [-inf,inf] } "The empty set:" -{ $subsection empty-interval } +{ $subsections empty-interval } "Another constructor:" -{ $subsection points>interval } ; +{ $subsections points>interval } ; ARTICLE: "math-intervals-arithmetic" "Interval arithmetic" "Binary operations on intervals:" -{ $subsection interval+ } -{ $subsection interval- } -{ $subsection interval* } -{ $subsection interval/ } -{ $subsection interval/i } -{ $subsection interval-mod } -{ $subsection interval-rem } -{ $subsection interval-min } -{ $subsection interval-max } +{ $subsections + interval+ + interval- + interval* + interval/ + interval/i + interval-mod + interval-rem + interval-min + interval-max +} "Bitwise operations on intervals:" -{ $subsection interval-shift } -{ $subsection interval-bitand } -{ $subsection interval-bitor } -{ $subsection interval-bitxor } +{ $subsections + interval-shift + interval-bitand + interval-bitor + interval-bitxor +} "Unary operations on intervals:" -{ $subsection interval-1+ } -{ $subsection interval-1- } -{ $subsection interval-neg } -{ $subsection interval-bitnot } -{ $subsection interval-recip } -{ $subsection interval-2/ } -{ $subsection interval-abs } -{ $subsection interval-log2 } ; +{ $subsections + interval-1+ + interval-1- + interval-neg + interval-bitnot + interval-recip + interval-2/ + interval-abs + interval-log2 +} ; ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals" -{ $subsection interval-contains? } -{ $subsection interval-subset? } -{ $subsection interval-intersect } -{ $subsection interval-union } -{ $subsection interval-closure } -{ $subsection integral-closure } ; +{ $subsections + interval-contains? + interval-subset? + interval-intersect + interval-union + interval-closure + integral-closure +} ; ARTICLE: "math-intervals-compare" "Comparing intervals" -{ $subsection interval< } -{ $subsection interval<= } -{ $subsection interval> } -{ $subsection interval>= } -{ $subsection assume< } -{ $subsection assume<= } -{ $subsection assume> } -{ $subsection assume>= } ; +{ $subsections + interval< + interval<= + interval> + interval>= + assume< + assume<= + assume> + assume>= +} ; ARTICLE: "math-interval-properties" "Properties of interval arithmetic" "For some operations, interval arithmetic yields inaccurate results, either because the result of lifting some operations to intervals does not result in intervals (bitwise operations, for example) or for the sake of simplicity of implementation." @@ -74,15 +88,19 @@ $nl ARTICLE: "math-intervals" "Intervals" "Interval arithmetic is performed on ranges of real numbers, rather than exact values. It is used by the Factor compiler to convert arbitrary-precision arithmetic to machine arithmetic, by inferring bounds for integer calculations." -{ $subsection "math-interval-properties" } +{ $subsections "math-interval-properties" } "The class of intervals:" -{ $subsection interval } -{ $subsection interval? } +{ $subsections + interval + interval? +} "Interval operations:" -{ $subsection "math-intervals-new" } -{ $subsection "math-intervals-arithmetic" } -{ $subsection "math-intervals-sets" } -{ $subsection "math-intervals-compare" } ; +{ $subsections + "math-intervals-new" + "math-intervals-arithmetic" + "math-intervals-sets" + "math-intervals-compare" +} ; ABOUT: "math-intervals" diff --git a/basis/math/libm/libm-docs.factor b/basis/math/libm/libm-docs.factor index 64f6026f0b..9de6e7d127 100644 --- a/basis/math/libm/libm-docs.factor +++ b/basis/math/libm/libm-docs.factor @@ -8,22 +8,30 @@ ARTICLE: "math.libm" "C standard library math functions" { $example "USE: math.functions" "2.0 acos ." "C{ 0.0 1.316957896924817 }" } { $unchecked-example "USE: math.libm" "2.0 facos ." "0/0." } } "Trigonometric functions:" -{ $subsection fcos } -{ $subsection fsin } -{ $subsection facos } -{ $subsection fasin } -{ $subsection fatan } -{ $subsection fatan2 } +{ $subsections + fcos + fsin + facos + fasin + fatan + fatan2 +} "Hyperbolic functions:" -{ $subsection fcosh } -{ $subsection fsinh } +{ $subsections + fcosh + fsinh +} "Exponentials and logarithms:" -{ $subsection fexp } -{ $subsection flog } -{ $subsection flog10 } +{ $subsections + fexp + flog + flog10 +} "Powers:" -{ $subsection fpow } -{ $subsection fsqrt } ; +{ $subsections + fpow + fsqrt +} ; ABOUT: "math.libm" diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 4ba8e1d3d9..4a76a20598 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -104,6 +104,8 @@ IN: math.matrices : m.v ( m v -- v ) [ v. ] curry map ; : m. ( m m -- m ) flip [ swap m.v ] curry map ; +: m~ ( m m epsilon -- ? ) [ v~ ] curry 2all? ; + : mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ; : mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; : mnorm ( m -- n ) dup mmax abs m/n ; @@ -139,4 +141,4 @@ PRIVATE> : m^n ( m n -- n ) make-bits over first length identity-matrix - [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ; \ No newline at end of file + [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ; diff --git a/basis/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor index 6617556270..cb2d2a6058 100644 --- a/basis/math/polynomials/polynomials-docs.factor +++ b/basis/math/polynomials/polynomials-docs.factor @@ -5,20 +5,22 @@ ARTICLE: "polynomials" "Polynomials" "A polynomial is a vector with the highest powers on the right:" { $code "{ 1 1 0 1 } -> 1 + x + x^3" "{ } -> 0" } "Numerous words are defined to help with polynomial arithmetic:" -{ $subsection p= } -{ $subsection p+ } -{ $subsection p- } -{ $subsection p* } -{ $subsection p-sq } -{ $subsection powers } -{ $subsection n*p } -{ $subsection p/mod } -{ $subsection pgcd } -{ $subsection polyval } -{ $subsection pdiff } -{ $subsection pextend-conv } -{ $subsection ptrim } -{ $subsection 2ptrim } ; +{ $subsections + p= + p+ + p- + p* + p-sq + powers + n*p + p/mod + pgcd + polyval + pdiff + pextend-conv + ptrim + 2ptrim +} ; ABOUT: "polynomials" diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor index 582b59b69a..3ba507b4fc 100644 --- a/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor +++ b/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor @@ -20,6 +20,6 @@ HELP: lucas-lehmer ARTICLE: "math.primes.lucas-lehmer" "Lucas-Lehmer Mersenne Primality test" "The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary tests numbers of the form " { $snippet "(2 ^ p) - 1" } " for primality, where " { $snippet "p" } " is prime." $nl "Run the Lucas-Lehmer test:" -{ $subsection lucas-lehmer } ; +{ $subsections lucas-lehmer } ; ABOUT: "math.primes.lucas-lehmer" diff --git a/basis/math/primes/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor index 2d19d51e06..c374821dd6 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-docs.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-docs.factor @@ -22,7 +22,9 @@ HELP: miller-rabin* ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test" "The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl "The Miller-Rabin probabilistic primality test:" -{ $subsection miller-rabin } -{ $subsection miller-rabin* } ; +{ $subsections + miller-rabin + miller-rabin* +} ; ABOUT: "math.primes.miller-rabin" diff --git a/basis/math/primes/primes-docs.factor b/basis/math/primes/primes-docs.factor index 71bf3ac2c8..7f525debfe 100644 --- a/basis/math/primes/primes-docs.factor +++ b/basis/math/primes/primes-docs.factor @@ -52,16 +52,20 @@ HELP: unique-primes ARTICLE: "math.primes" "Prime numbers" "The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers. Serveral useful vocabularies exist for testing primality. The Sieve of Eratosthenes in " { $vocab-link "math.primes.erato" } " is useful for testing primality below five million. For larger integers, " { $vocab-link "math.primes.miller-rabin" } " is a fast probabilstic primality test. The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary implements an algorithm for finding huge Mersenne prime numbers." $nl "Testing if a number is prime:" -{ $subsection prime? } +{ $subsections prime? } "Generating prime numbers:" -{ $subsection next-prime } -{ $subsection primes-upto } -{ $subsection primes-between } -{ $subsection random-prime } +{ $subsections + next-prime + primes-upto + primes-between + random-prime +} "Generating relative prime numbers:" -{ $subsection find-relative-prime } -{ $subsection find-relative-prime* } +{ $subsections + find-relative-prime + find-relative-prime* +} "Make a sequence of random prime numbers:" -{ $subsection unique-primes } ; +{ $subsections unique-primes } ; ABOUT: "math.primes" diff --git a/basis/math/primes/safe/safe-docs.factor b/basis/math/primes/safe/safe-docs.factor index 861fc4e4ed..21f84c4e3c 100644 --- a/basis/math/primes/safe/safe-docs.factor +++ b/basis/math/primes/safe/safe-docs.factor @@ -30,9 +30,11 @@ ARTICLE: "math.primes.safe" "Safe prime numbers" "The " { $vocab-link "math.primes.safe" } " vocabulary implements words to calculate safe prime numbers. Safe primes are of the form p = 2q + 1, where p,q are prime. Safe primes have desirable qualities for cryptographic applications." $nl "Testing if a number is a safe prime:" -{ $subsection safe-prime? } +{ $subsections safe-prime? } "Generating safe prime numbers:" -{ $subsection next-safe-prime } -{ $subsection random-safe-prime } ; +{ $subsections + next-safe-prime + random-safe-prime +} ; ABOUT: "math.primes.safe" diff --git a/basis/math/ranges/ranges-docs.factor b/basis/math/ranges/ranges-docs.factor index 59053a4c02..584bb3115b 100644 --- a/basis/math/ranges/ranges-docs.factor +++ b/basis/math/ranges/ranges-docs.factor @@ -6,17 +6,19 @@ ARTICLE: "math.ranges" "Numeric ranges" "ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } ". Ascending as well as descending ranges are supported." $nl "The class of ranges:" -{ $subsection range } +{ $subsections range } "Creating ranges with integer end-points. The standard mathematical convention is used, where " { $snippet "(" } " or " { $snippet ")" } " denotes that the end-point itself " { $emphasis "is not" } " part of the range; " { $snippet "[" } " or " { $snippet "]" } " denotes that the end-point " { $emphasis "is" } " part of the range:" -{ $subsection [a,b] } -{ $subsection (a,b] } -{ $subsection [a,b) } -{ $subsection (a,b) } -{ $subsection [0,b] } -{ $subsection [1,b] } -{ $subsection [0,b) } +{ $subsections + [a,b] + (a,b] + [a,b) + (a,b) + [0,b] + [1,b] + [0,b) +} "Creating general ranges:" -{ $subsection <range> } +{ $subsections <range> } "Ranges are most frequently used with sequence combinators as a means of iterating over integers. For example," { $code "3 10 [a,b] [ sqrt ] map" } "Computing the factorial of 100 with a descending range:" diff --git a/basis/math/ratios/ratios-docs.factor b/basis/math/ratios/ratios-docs.factor index 2e51fa1870..6c3fca6061 100644 --- a/basis/math/ratios/ratios-docs.factor +++ b/basis/math/ratios/ratios-docs.factor @@ -3,7 +3,7 @@ math.ratios.private math.functions ; IN: math.ratios ARTICLE: "rationals" "Rational numbers" -{ $subsection ratio } +{ $subsections ratio } "When we add, subtract or multiply any two integers, the result is always an integer. However, dividing a numerator by a denominator that is not an integral divisor of the denominator yields a ratio:" { $example "1210 11 / ." "110" } { $example "100 330 / ." "10/33" } @@ -14,9 +14,11 @@ $nl { $example "1/2 1/3 + ." "5/6" } { $example "100 6 / 3 * ." "50" } "Ratios can be taken apart:" -{ $subsection numerator } -{ $subsection denominator } -{ $subsection >fraction } +{ $subsections + numerator + denominator + >fraction +} { $see-also "syntax-ratios" } ; ABOUT: "rationals" diff --git a/basis/math/rectangles/rectangles-docs.factor b/basis/math/rectangles/rectangles-docs.factor index 1d5c32d7d0..1ca6c2e584 100644 --- a/basis/math/rectangles/rectangles-docs.factor +++ b/basis/math/rectangles/rectangles-docs.factor @@ -52,20 +52,26 @@ HELP: <zero-rect> ARTICLE: "math.rectangles" "Rectangles" "The " { $vocab-link "math.rectangles" } " vocabulary defines a rectangle data type and operations on them." -{ $subsection rect } +{ $subsections rect } "Rectangles can be taken apart:" -{ $subsection rect-bounds } -{ $subsection rect-extent } +{ $subsections + rect-bounds + rect-extent +} "New rectangles can be created:" -{ $subsection <zero-rect> } -{ $subsection <rect> } -{ $subsection <extent-rect> } +{ $subsections + <zero-rect> + <rect> + <extent-rect> +} "Set-theoretic operations on rectangles:" -{ $subsection rect-intersect } -{ $subsection rect-union } -{ $subsection contains-rect? } -{ $subsection contains-point? } +{ $subsections + rect-intersect + rect-union + contains-rect? + contains-point? +} "A utility word:" -{ $subsection offset-rect } ; +{ $subsections offset-rect } ; ABOUT: "math.rectangles" diff --git a/basis/math/vectors/conversion/authors.txt b/basis/math/vectors/conversion/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/math/vectors/conversion/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/math/vectors/conversion/backend/backend.factor b/basis/math/vectors/conversion/backend/backend.factor new file mode 100644 index 0000000000..d47fab1b0e --- /dev/null +++ b/basis/math/vectors/conversion/backend/backend.factor @@ -0,0 +1,21 @@ +! (c)Joe Groff bsd license +USING: accessors alien.c-types arrays assocs classes combinators +cords fry kernel math math.vectors sequences ; +IN: math.vectors.conversion.backend + +: saturate-map-as ( v quot result -- w ) + [ element-type '[ @ _ c-type-clamp ] ] keep map-as ; inline + +: (v>float) ( i to-type -- f ) + [ >float ] swap new map-as ; +: (v>integer) ( f to-type -- i ) + [ >integer ] swap new map-as ; +: (vpack-signed) ( a b to-type -- ab ) + [ cord-append [ ] ] dip new saturate-map-as ; +: (vpack-unsigned) ( a b to-type -- ab ) + [ cord-append [ ] ] dip new saturate-map-as ; +: (vunpack-head) ( ab to-type -- a ) + [ dup length 2 /i head-slice ] dip new like ; +: (vunpack-tail) ( ab to-type -- b ) + [ dup length 2 /i tail-slice ] dip new like ; + diff --git a/basis/math/vectors/conversion/conversion-tests.factor b/basis/math/vectors/conversion/conversion-tests.factor new file mode 100644 index 0000000000..d6c16c8518 --- /dev/null +++ b/basis/math/vectors/conversion/conversion-tests.factor @@ -0,0 +1,149 @@ +! (c)Joe Groff bsd license +USING: accessors arrays compiler continuations generalizations +kernel kernel.private locals math.vectors.conversion math.vectors.simd +sequences stack-checker tools.test ; +FROM: alien.c-types => char uchar short ushort int uint longlong ulonglong float double ; +SIMD: uchar +SIMD: char +SIMD: ushort +SIMD: short +SIMD: uint +SIMD: int +SIMD: ulonglong +SIMD: longlong +SIMD: float +SIMD: double +IN: math.vectors.conversion.tests + +ERROR: optimized-vconvert-inconsistent + unoptimized-result + optimized-result ; + +MACRO:: test-vconvert ( from-type to-type -- ) + [ from-type to-type vconvert ] :> quot + quot infer :> effect + effect in>> length :> inputs + effect out>> length :> outputs + + inputs from-type <array> :> declaration + + [ + inputs narray + [ quot with-datastack ] + [ [ [ declaration declare quot call ] compile-call ] with-datastack ] bi + 2dup = [ optimized-vconvert-inconsistent ] unless + drop outputs firstn + ] ; + +[ uint-4{ 5 1 2 6 } int-4 float-4 vconvert ] +[ bad-vconvert-input? ] must-fail-with + +[ int-4{ 1 2 3 4 } uint-4{ 5 1 2 6 } int-4 short-8 vconvert ] +[ bad-vconvert-input? ] must-fail-with + +[ uint-4{ 1 2 3 4 } int-4{ 5 1 2 6 } int-4 short-8 vconvert ] +[ bad-vconvert-input? ] must-fail-with + +[ uint-4{ 5 1 2 6 } int-4 longlong-2 vconvert ] +[ bad-vconvert-input? ] must-fail-with + +[ float-4{ -5.0 1.0 2.0 6.0 } ] +[ int-4{ -5 1 2 6 } int-4 float-4 test-vconvert ] unit-test + +[ int-4{ -5 1 2 6 } ] +[ float-4{ -5.0 1.0 2.0 6.0 } float-4 int-4 test-vconvert ] unit-test + +[ int-4{ -5 1 2 6 } ] +[ float-4{ -5.0 1.0 2.3 6.7 } float-4 int-4 test-vconvert ] unit-test + +[ double-2{ -5.0 1.0 } ] +[ longlong-2{ -5 1 } longlong-2 double-2 test-vconvert ] unit-test + +[ longlong-4{ -5 1 2 6 } ] +[ double-4{ -5.0 1.0 2.3 6.7 } double-4 longlong-4 test-vconvert ] unit-test + +! TODO we should be able to do double->int pack +! [ int-8{ -5 1 2 6 12 34 -56 78 } ] +[ double-4{ -5.0 1.0 2.0 6.0 } double-4{ 12.0 34.0 -56.0 78.0 } double-4 int-8 test-vconvert ] +[ error>> bad-vconvert? ] must-fail-with + +[ float-4{ -1.25 2.0 3.0 -4.0 } ] +[ double-2{ -1.25 2.0 } double-2{ 3.0 -4.0 } double-2 float-4 test-vconvert ] unit-test + +[ int-4{ -1 2 3 -4 } ] +[ longlong-2{ -1 2 } longlong-2{ 3 -4 } longlong-2 int-4 test-vconvert ] unit-test + +[ short-8{ -1 2 3 -32768 5 32767 -7 32767 } ] +[ int-4{ -1 2 3 -40000 } int-4{ 5 60000 -7 80000 } int-4 short-8 test-vconvert ] unit-test + +[ short-16{ -1 2 3 -32768 3 2 1 0 5 32767 -7 32767 7 6 5 4 } ] +[ + int-8{ -1 2 3 -40000 3 2 1 0 } + int-8{ 5 60000 -7 80000 7 6 5 4 } int-8 short-16 test-vconvert +] unit-test + +[ ushort-8{ 0 2 3 0 5 60000 0 65535 } ] +[ int-4{ -1 2 3 -40000 } int-4{ 5 60000 -7 80000 } int-4 ushort-8 test-vconvert ] unit-test + +[ ushort-8{ 65535 2 3 65535 5 60000 65535 65535 } ] +[ uint-4{ -1 2 3 -40000 } uint-4{ 5 60000 -7 80000 } uint-4 ushort-8 test-vconvert ] unit-test + +[ uint-4{ -1 2 3 -40000 } uint-4{ 5 60000 -7 80000 } uint-4 short-8 test-vconvert ] +[ error>> bad-vconvert? ] must-fail-with + +! TODO we should be able to do 256->128 pack +! [ float-4{ -1.25 2.0 3.0 -4.0 } ] +[ double-4{ -1.25 2.0 3.0 -4.0 } double-4 float-4 test-vconvert ] +[ error>> bad-vconvert? ] must-fail-with + +! [ int-4{ -1 2 3 -4 } ] +[ longlong-4{ -1 2 3 -4 } longlong-4 int-4 test-vconvert ] +[ error>> bad-vconvert? ] must-fail-with + +[ double-2{ -1.25 2.0 } double-2{ 3.0 -4.0 } ] +[ float-4{ -1.25 2.0 3.0 -4.0 } float-4 double-2 test-vconvert ] unit-test + +[ int-4{ -1 2 3 -4 } ] +[ int-4{ -1 2 3 -4 } int-4 int-4 test-vconvert ] unit-test + +[ longlong-2{ -1 2 } longlong-2{ 3 -4 } ] +[ int-4{ -1 2 3 -4 } int-4 longlong-2 test-vconvert ] unit-test + +[ int-4{ -1 2 3 -4 } int-4 ulonglong-2 test-vconvert ] +[ error>> bad-vconvert? ] must-fail-with + +[ ulonglong-2{ 1 2 } ulonglong-2{ 3 4 } ] +[ uint-4{ 1 2 3 4 } uint-4 ulonglong-2 test-vconvert ] unit-test + +[ longlong-4{ 1 2 3 4 } longlong-4{ 3 4 5 6 } ] +[ uint-8{ 1 2 3 4 3 4 5 6 } uint-8 longlong-4 test-vconvert ] unit-test + +[ int-4{ 1 2 -3 -4 } int-4{ 5 -6 7 -8 } ] +[ short-8{ 1 2 -3 -4 5 -6 7 -8 } short-8 int-4 test-vconvert ] unit-test + +[ uint-4{ 1 2 3 4 } uint-4{ 5 6 7 8 } ] +[ ushort-8{ 1 2 3 4 5 6 7 8 } ushort-8 uint-4 test-vconvert ] unit-test + +[ longlong-4{ 1 2 3 4 } longlong-4{ 3 4 5 6 } ] +[ uint-8{ 1 2 3 4 3 4 5 6 } uint-8 longlong-4 test-vconvert ] unit-test + +! TODO we should be able to do 128->256 unpack +! [ longlong-4{ 1 2 3 4 } ] +[ uint-4{ 1 2 3 4 } uint-4 longlong-4 test-vconvert ] +[ error>> bad-vconvert? ] must-fail-with + +! TODO we should be able to do multi-tier pack/unpack +! [ longlong-2{ 1 2 } longlong-2{ 3 4 } longlong-2{ 5 6 } longlong-2{ 7 8 } ] +[ ushort-8{ 1 2 3 4 5 6 7 8 } ushort-8 longlong-2 test-vconvert ] +[ error>> bad-vconvert? ] must-fail-with + +! [ ushort-8{ 1 2 3 4 5 6 7 8 } ] +[ + longlong-2{ 1 2 } + longlong-2{ 3 4 } + longlong-2{ 5 6 } + longlong-2{ 7 8 } + longlong-2 ushort-8 test-vconvert +] +[ error>> bad-vconvert? ] must-fail-with + diff --git a/basis/math/vectors/conversion/conversion.factor b/basis/math/vectors/conversion/conversion.factor new file mode 100644 index 0000000000..f70dfc9b27 --- /dev/null +++ b/basis/math/vectors/conversion/conversion.factor @@ -0,0 +1,96 @@ +! (c)Joe Groff bsd license +USING: accessors alien.c-types arrays assocs classes combinators +combinators.short-circuit cords fry kernel locals math +math.vectors math.vectors.conversion.backend sequences ; +FROM: alien.c-types => char uchar short ushort int uint longlong ulonglong float double ; +IN: math.vectors.conversion + +ERROR: bad-vconvert from-type to-type ; +ERROR: bad-vconvert-input value expected-type ; + +<PRIVATE + +: float-type? ( c-type -- ? ) + { float double } memq? ; +: unsigned-type? ( c-type -- ? ) + { uchar ushort uint ulonglong } memq? ; + +: check-vconvert-type ( value expected-type -- value ) + 2dup instance? [ drop ] [ bad-vconvert-input ] if ; inline + +:: [vconvert] ( from-element to-element from-size to-size from-type to-type -- quot ) + { + { + [ from-element to-element eq? ] + [ [ ] ] + } + { + [ from-element to-element [ float-type? not ] both? ] + [ [ underlying>> to-type boa ] ] + } + { + [ from-element float-type? ] + [ [ to-type (v>integer) ] ] + } + { + [ to-element float-type? ] + [ [ to-type (v>float) ] ] + } + } cond + [ from-type check-vconvert-type ] prepose ; + +:: check-vpack ( from-element to-element from-type to-type steps -- ) + { + [ steps 1 = not ] + [ from-element to-element [ float-type? ] bi@ xor ] + [ from-element unsigned-type? to-element unsigned-type? not and ] + } 0|| [ from-type to-type bad-vconvert ] when ; + +:: [[vpack-unsigned]] ( from-type to-type -- quot ) + [ [ from-type check-vconvert-type ] bi@ to-type (vpack-unsigned) ] ; + +:: [[vpack-signed]] ( from-type to-type -- quot ) + [ [ from-type check-vconvert-type ] bi@ to-type (vpack-signed) ] ; + +:: [vpack] ( from-element to-element from-size to-size from-type to-type -- quot ) + from-size to-size /i log2 :> steps + + from-element to-element from-type to-type steps check-vpack + + from-type to-type to-element unsigned-type? + [ [[vpack-unsigned]] ] [ [[vpack-signed]] ] if ; + +:: check-vunpack ( from-element to-element from-type to-type steps -- ) + { + [ steps 1 = not ] + [ from-element to-element [ float-type? ] bi@ xor ] + [ from-element unsigned-type? not to-element unsigned-type? and ] + } 0|| [ from-type to-type bad-vconvert ] when ; + +:: [[vunpack]] ( from-type to-type -- quot ) + [ + from-type check-vconvert-type + [ to-type (vunpack-head) ] [ to-type (vunpack-tail) ] bi + ] ; + +:: [vunpack] ( from-element to-element from-size to-size from-type to-type -- quot ) + to-size from-size /i log2 :> steps + from-element to-element from-type to-type steps check-vunpack + from-type to-type [[vunpack]] ; + +PRIVATE> + +MACRO:: vconvert ( from-type to-type -- ) + from-type new [ element-type ] [ byte-length ] bi :> from-length :> from-element + to-type new [ element-type ] [ byte-length ] bi :> to-length :> to-element + from-element heap-size :> from-size + to-element heap-size :> to-size + + from-length to-length = [ from-type to-type bad-vconvert ] unless + + from-element to-element from-size to-size from-type to-type { + { [ from-size to-size < ] [ [vunpack] ] } + { [ from-size to-size = ] [ [vconvert] ] } + { [ from-size to-size > ] [ [vpack] ] } + } cond ; + diff --git a/basis/math/vectors/conversion/summary.txt b/basis/math/vectors/conversion/summary.txt new file mode 100644 index 0000000000..15f4f0d396 --- /dev/null +++ b/basis/math/vectors/conversion/summary.txt @@ -0,0 +1 @@ +Conversion, packing, and unpacking of SIMD vectors diff --git a/basis/math/vectors/simd/alien/alien-tests.factor b/basis/math/vectors/simd/alien/alien-tests.factor deleted file mode 100644 index 87540dd9a5..0000000000 --- a/basis/math/vectors/simd/alien/alien-tests.factor +++ /dev/null @@ -1,70 +0,0 @@ -USING: cpu.architecture math.vectors.simd -math.vectors.simd.intrinsics accessors math.vectors.simd.alien -kernel classes.struct tools.test compiler sequences byte-arrays -alien math kernel.private specialized-arrays combinators ; -SPECIALIZED-ARRAY: float -IN: math.vectors.simd.alien.tests - -! Vector alien intrinsics -[ float-4{ 1 2 3 4 } ] [ - [ - float-4{ 1 2 3 4 } - underlying>> 0 float-4-rep alien-vector - ] compile-call float-4 boa -] unit-test - -[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [ - 16 [ 1 ] B{ } replicate-as 16 <byte-array> - [ - 0 [ - { byte-array c-ptr fixnum } declare - float-4-rep set-alien-vector - ] compile-call - ] keep -] unit-test - -[ float-array{ 1 2 3 4 } ] [ - [ - float-array{ 1 2 3 4 } underlying>> - float-array{ 4 3 2 1 } clone - [ underlying>> 0 float-4-rep set-alien-vector ] keep - ] compile-call -] unit-test - -STRUCT: simd-struct -{ x float-4 } -{ y double-2 } -{ z double-4 } -{ w float-8 } ; - -[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test - -[ - float-4{ 1 2 3 4 } - double-2{ 2 1 } - double-4{ 4 3 2 1 } - float-8{ 1 2 3 4 5 6 7 8 } -] [ - simd-struct <struct> - float-4{ 1 2 3 4 } >>x - double-2{ 2 1 } >>y - double-4{ 4 3 2 1 } >>z - float-8{ 1 2 3 4 5 6 7 8 } >>w - { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave -] unit-test - -[ - float-4{ 1 2 3 4 } - double-2{ 2 1 } - double-4{ 4 3 2 1 } - float-8{ 1 2 3 4 5 6 7 8 } -] [ - [ - simd-struct <struct> - float-4{ 1 2 3 4 } >>x - double-2{ 2 1 } >>y - double-4{ 4 3 2 1 } >>z - float-8{ 1 2 3 4 5 6 7 8 } >>w - { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave - ] compile-call -] unit-test diff --git a/basis/math/vectors/simd/alien/alien.factor b/basis/math/vectors/simd/alien/alien.factor deleted file mode 100644 index 1486f6d0af..0000000000 --- a/basis/math/vectors/simd/alien/alien.factor +++ /dev/null @@ -1,42 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien accessors alien.c-types byte-arrays compiler.units -cpu.architecture locals kernel math math.vectors.simd -math.vectors.simd.intrinsics ; -IN: math.vectors.simd.alien - -:: define-simd-128-type ( class rep -- ) - <c-type> - byte-array >>class - class >>boxed-class - [ rep alien-vector class boa ] >>getter - [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter - 16 >>size - 8 >>align - rep >>rep - class name>> typedef ; - -:: define-simd-256-type ( class rep -- ) - <c-type> - class >>class - class >>boxed-class - [ - [ rep alien-vector ] - [ 16 + >fixnum rep alien-vector ] 2bi - class boa - ] >>getter - [ - [ [ underlying1>> ] 2dip rep set-alien-vector ] - [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ] - 3bi - ] >>setter - 32 >>size - 8 >>align - rep >>rep - class name>> typedef ; -[ - float-4 float-4-rep define-simd-128-type - double-2 double-2-rep define-simd-128-type - float-8 float-4-rep define-simd-256-type - double-4 double-2-rep define-simd-256-type -] with-compilation-unit diff --git a/basis/math/vectors/simd/alien/authors.txt b/basis/math/vectors/simd/alien/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/math/vectors/simd/alien/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/math/vectors/simd/functor/functor.factor b/basis/math/vectors/simd/functor/functor.factor index 641585a5d7..2ddaf2b8a5 100644 --- a/basis/math/vectors/simd/functor/functor.factor +++ b/basis/math/vectors/simd/functor/functor.factor @@ -1,55 +1,219 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types byte-arrays classes functors -kernel math parser prettyprint.custom sequences -sequences.private literals ; +USING: accessors assocs byte-arrays classes classes.algebra effects fry +functors generalizations kernel literals locals math math.functions +math.vectors math.vectors.private math.vectors.simd.intrinsics +math.vectors.conversion.backend +math.vectors.specialization parser prettyprint.custom sequences +sequences.private strings words definitions macros cpu.architecture +namespaces arrays quotations combinators combinators.short-circuit sets +layouts ; +QUALIFIED-WITH: alien.c-types c +QUALIFIED: math.private IN: math.vectors.simd.functor ERROR: bad-length got expected ; -FUNCTOR: define-simd-128 ( T -- ) +: vector-true-value ( class -- value ) + { + { [ dup integer class<= ] [ drop -1 ] } + { [ dup float class<= ] [ drop -1 bits>double ] } + } cond ; foldable + +: vector-false-value ( class -- value ) + { + { [ dup integer class<= ] [ drop 0 ] } + { [ dup float class<= ] [ drop 0.0 ] } + } cond ; foldable + +: boolean>element ( bool/elt class -- elt ) + swap { + { t [ vector-true-value ] } + { f [ vector-false-value ] } + [ nip ] + } case ; inline + +MACRO: simd-boa ( rep class -- simd-array ) + [ rep-components ] [ new ] bi* '[ _ _ nsequence ] ; + +: can-be-unboxed? ( type -- ? ) + { + { c:float [ \ math.private:float+ "intrinsic" word-prop ] } + { c:double [ \ math.private:float+ "intrinsic" word-prop ] } + [ c:heap-size cell < ] + } case ; + +: simd-boa-fast? ( rep -- ? ) + [ dup rep-gather-word supported-simd-op? ] + [ rep-component-type can-be-unboxed? ] + bi and ; + +:: define-boa-custom-inlining ( word rep class -- ) + word [ + drop + rep simd-boa-fast? [ + [ rep (simd-boa) class boa ] + ] [ word def>> ] if + ] "custom-inlining" set-word-prop ; + +: simd-with ( rep class x -- simd-array ) + [ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline + +: simd-with/nth-fast? ( rep -- ? ) + [ \ (simd-vshuffle-elements) supported-simd-op? ] + [ rep-component-type can-be-unboxed? ] + bi and ; + +:: define-with-custom-inlining ( word rep class -- ) + word [ + drop + rep simd-with/nth-fast? [ + [ rep rep-coerce rep (simd-with) class boa ] + ] [ word def>> ] if + ] "custom-inlining" set-word-prop ; + +: simd-nth-fast ( rep -- quot ) + [ rep-components ] keep + '[ swap _ '[ _ _ (simd-select) ] 2array ] map-index + '[ swap >fixnum _ case ] ; + +: simd-nth-slow ( rep -- quot ) + rep-component-type dup c:c-type-getter-boxer c:array-accessor ; + +MACRO: simd-nth ( rep -- x ) + dup simd-with/nth-fast? [ simd-nth-fast ] [ simd-nth-slow ] if ; + +: boa-effect ( rep n -- effect ) + [ rep-components ] dip * + [ CHAR: a + 1string ] map + { "simd-vector" } <effect> ; + +: supported-simd-ops ( assoc rep -- assoc' ) + [ simd-ops get ] dip + '[ nip _ swap supported-simd-op? ] assoc-filter + '[ drop _ key? ] assoc-filter ; + +ERROR: bad-schema op schema ; + +:: op-wrapper ( op specials schemas -- wrapper ) + op { + [ specials at ] + [ word-schema schemas at ] + [ dup word-schema bad-schema ] + } 1|| ; + +: low-level-ops ( simd-ops specials schemas -- alist ) + '[ 1quotation over _ _ op-wrapper [ ] 2sequence ] assoc-map ; + +:: high-level-ops ( ctor elt-class -- assoc ) + ! Some SIMD operations are defined in terms of others. + { + { vbroadcast [ swap nth ctor execute ] } + { n+v [ [ ctor execute ] dip v+ ] } + { v+n [ ctor execute v+ ] } + { n-v [ [ ctor execute ] dip v- ] } + { v-n [ ctor execute v- ] } + { n*v [ [ ctor execute ] dip v* ] } + { v*n [ ctor execute v* ] } + { n/v [ [ ctor execute ] dip v/ ] } + { v/n [ ctor execute v/ ] } + { norm-sq [ dup v. assert-positive ] } + { norm [ norm-sq sqrt ] } + { normalize [ dup norm v/n ] } + } + ! To compute dot product and distance with integer vectors, we + ! have to do things less efficiently, with integer overflow checks, + ! in the general case. + elt-class float = [ { distance [ v- norm ] } suffix ] when ; + +TUPLE: simd class elt-class ops special-wrappers schema-wrappers ctor rep ; + +: define-simd ( simd -- ) + dup rep>> rep-component-type c:c-type-boxed-class >>elt-class + { + [ class>> ] + [ elt-class>> ] + [ [ ops>> ] [ special-wrappers>> ] [ schema-wrappers>> ] tri low-level-ops ] + [ rep>> supported-simd-ops ] + [ [ ctor>> ] [ elt-class>> ] bi high-level-ops assoc-union ] + } cleave + specialize-vector-words ; + +:: define-simd-128-type ( class rep -- ) + c:<c-type> + byte-array >>class + class >>boxed-class + [ rep alien-vector class boa ] >>getter + [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter + 16 >>size + 8 >>align + rep >>rep + class c:typedef ; + +: (define-simd-128) ( simd -- ) + simd-ops get >>ops + [ define-simd ] + [ [ class>> ] [ rep>> ] bi define-simd-128-type ] bi ; -T-TYPE IS ${T} +FUNCTOR: define-simd-128 ( T -- ) -N [ 16 T-TYPE heap-size /i ] +N [ 16 T c:heap-size /i ] A DEFINES-CLASS ${T}-${N} +A-boa DEFINES ${A}-boa +A-with DEFINES ${A}-with +A-cast DEFINES ${A}-cast >A DEFINES >${A} A{ DEFINES ${A}{ -NTH [ T-TYPE dup c-type-getter-boxer array-accessor ] -SET-NTH [ T-TYPE dup c-setter array-accessor ] +SET-NTH [ T dup c:c-setter c:array-accessor ] -A-rep IS ${A}-rep +A-rep [ A name>> "-rep" append "cpu.architecture" lookup ] A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op +A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op +A-vv->n-op DEFINES-PRIVATE ${A}-vv->n-op +A-v->v-op DEFINES-PRIVATE ${A}-v->v-op A-v->n-op DEFINES-PRIVATE ${A}-v->n-op +A-v-conversion-op DEFINES-PRIVATE ${A}-v-conversion-op +A-vv-conversion-op DEFINES-PRIVATE ${A}-vv-conversion-op + +A-element-class [ A-rep rep-component-type c:c-type-boxed-class ] WHERE TUPLE: A { underlying byte-array read-only initial: $[ 16 <byte-array> ] } ; +INSTANCE: A simd-128 + M: A clone underlying>> clone \ A boa ; inline M: A length drop N ; inline -M: A nth-unsafe underlying>> NTH call ; inline +M: A equal? + over \ A instance? [ v= vall? ] [ 2drop f ] if ; + +M: A nth-unsafe underlying>> A-rep simd-nth ; inline -M: A set-nth-unsafe underlying>> SET-NTH call ; inline +M: A set-nth-unsafe + [ A-element-class boolean>element ] 2dip + underlying>> SET-NTH call ; inline : >A ( seq -- simd-array ) \ A new clone-like ; M: A like drop dup \ A instance? [ >A ] unless ; inline +M: A new-underlying drop \ A boa ; inline + M: A new-sequence drop dup N = [ drop 16 <byte-array> \ A boa ] [ N bad-length ] if ; inline -M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ; +M: A c:byte-length underlying>> length ; inline -M: A byte-length underlying>> length ; inline +M: A element-type drop A-rep rep-component-type ; M: A pprint-delims drop \ A{ \ } ; @@ -59,6 +223,19 @@ M: A pprint* pprint-object ; SYNTAX: A{ \ } [ >A ] parse-literal ; +: A-with ( x -- simd-array ) [ A-rep A ] dip simd-with ; + +\ A-with \ A-rep \ A define-with-custom-inlining + +\ A-boa [ \ A-rep \ A simd-boa ] \ A-rep 1 boa-effect define-declared + +\ A-rep rep-gather-word [ + \ A-boa \ A-rep \ A define-boa-custom-inlining +] when + +: A-cast ( simd-array -- simd-array' ) + underlying>> \ A boa ; inline + INSTANCE: A sequence <PRIVATE @@ -66,32 +243,117 @@ INSTANCE: A sequence : A-vv->v-op ( v1 v2 quot -- v3 ) [ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline +: A-vn->v-op ( v1 v2 quot -- v3 ) + [ [ underlying>> ] dip A-rep ] dip call \ A boa ; inline + +: A-vv->n-op ( v1 v2 quot -- n ) + [ [ underlying>> ] bi@ A-rep ] dip call ; inline + +: A-v->v-op ( v1 quot -- v2 ) + [ underlying>> A-rep ] dip call \ A boa ; inline + : A-v->n-op ( v quot -- n ) [ underlying>> A-rep ] dip call ; inline +: A-v-conversion-op ( v1 to-type quot -- v2 ) + swap [ underlying>> A-rep ] [ call ] [ '[ _ boa ] call( u -- v ) ] tri* ; inline + +: A-vv-conversion-op ( v1 v2 to-type quot -- v2 ) + swap { + [ underlying>> ] + [ underlying>> A-rep ] + [ call ] + [ '[ _ boa ] call( u -- v ) ] + } spread ; inline + +simd new + \ A >>class + \ A-with >>ctor + \ A-rep >>rep + { + { (v>float) A-v-conversion-op } + { (v>integer) A-v-conversion-op } + { (vpack-signed) A-vv-conversion-op } + { (vpack-unsigned) A-vv-conversion-op } + { (vunpack-head) A-v-conversion-op } + { (vunpack-tail) A-v-conversion-op } + } >>special-wrappers + { + { { +vector+ +vector+ -> +vector+ } A-vv->v-op } + { { +vector+ +scalar+ -> +vector+ } A-vn->v-op } + { { +vector+ +literal+ -> +vector+ } A-vn->v-op } + { { +vector+ +vector+ -> +scalar+ } A-vv->n-op } + { { +vector+ -> +vector+ } A-v->v-op } + { { +vector+ -> +scalar+ } A-v->n-op } + { { +vector+ -> +nonnegative+ } A-v->n-op } + } >>schema-wrappers +(define-simd-128) + PRIVATE> ;FUNCTOR ! Synthesize 256-bit vectors from a pair of 128-bit vectors -FUNCTOR: define-simd-256 ( T -- ) +SLOT: underlying1 +SLOT: underlying2 -T-TYPE IS ${T} +:: define-simd-256-type ( class rep -- ) + c:<c-type> + class >>class + class >>boxed-class + [ + [ rep alien-vector ] + [ 16 + >fixnum rep alien-vector ] 2bi + class boa + ] >>getter + [ + [ [ underlying1>> ] 2dip rep set-alien-vector ] + [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ] + 3bi + ] >>setter + 32 >>size + 8 >>align + rep >>rep + class c:typedef ; + +: (define-simd-256) ( simd -- ) + simd-ops get { vshuffle-elements vshuffle-bytes hlshift hrshift } unique assoc-diff >>ops + [ define-simd ] + [ [ class>> ] [ rep>> ] bi define-simd-256-type ] bi ; -N [ 32 T-TYPE heap-size /i ] +FUNCTOR: define-simd-256 ( T -- ) + +N [ 32 T c:heap-size /i ] N/2 [ N 2 / ] A/2 IS ${T}-${N/2} +A/2-boa IS ${A/2}-boa +A/2-with IS ${A/2}-with A DEFINES-CLASS ${T}-${N} +A-boa DEFINES ${A}-boa +A-with DEFINES ${A}-with +A-cast DEFINES ${A}-cast >A DEFINES >${A} A{ DEFINES ${A}{ A-deref DEFINES-PRIVATE ${A}-deref -A-rep IS ${A/2}-rep +A-rep [ A/2 name>> "-rep" append "cpu.architecture" lookup ] A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op -A-v->n-op DEFINES-PRIVATE ${A}-v->n-op +A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op +A-v->v-op DEFINES-PRIVATE ${A}-v->v-op +A-v.-op DEFINES-PRIVATE ${A}-v.-op +(A-v->n-op) DEFINES-PRIVATE (${A}-v->v-op) +A-sum-op DEFINES-PRIVATE ${A}-sum-op +A-vany-op DEFINES-PRIVATE ${A}-vany-op +A-vall-op DEFINES-PRIVATE ${A}-vall-op +A-vmerge-head-op DEFINES-PRIVATE ${A}-vmerge-head-op +A-vmerge-tail-op DEFINES-PRIVATE ${A}-vmerge-tail-op +A-v-conversion-op DEFINES-PRIVATE ${A}-v-conversion-op +A-vpack-op DEFINES-PRIVATE ${A}-vpack-op +A-vunpack-head-op DEFINES-PRIVATE ${A}-vunpack-head-op +A-vunpack-tail-op DEFINES-PRIVATE ${A}-vunpack-tail-op WHERE @@ -102,12 +364,17 @@ TUPLE: A { underlying1 byte-array initial: $[ 16 <byte-array> ] read-only } { underlying2 byte-array initial: $[ 16 <byte-array> ] read-only } ; +INSTANCE: A simd-256 + M: A clone [ underlying1>> clone ] [ underlying2>> clone ] bi \ A boa ; inline M: A length drop N ; inline +M: A equal? + over \ A instance? [ v= vall? ] [ 2drop f ] if ; + : A-deref ( n seq -- n' seq' ) over N/2 < [ underlying1>> ] [ [ N/2 - ] dip underlying2>> ] if \ A/2 boa ; inline @@ -125,9 +392,9 @@ M: A new-sequence [ N bad-length ] if ; inline -M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ; +M: A c:byte-length drop 32 ; inline -M: A byte-length drop 32 ; inline +M: A element-type drop A-rep rep-component-type ; SYNTAX: A{ \ } [ >A ] parse-literal ; @@ -137,6 +404,19 @@ M: A >pprint-sequence ; M: A pprint* pprint-object ; +: A-with ( x -- simd-array ) + [ A/2-with ] [ A/2-with ] bi [ underlying>> ] bi@ + \ A boa ; inline + +: A-boa ( ... -- simd-array ) + [ A/2-boa ] N/2 ndip A/2-boa [ underlying>> ] bi@ + \ A boa ; inline + +\ A-rep 2 boa-effect \ A-boa set-stack-effect + +: A-cast ( simd-array -- simd-array' ) + [ underlying1>> ] [ underlying2>> ] bi \ A boa ; inline + INSTANCE: A sequence : A-vv->v-op ( v1 v2 quot -- v3 ) @@ -144,8 +424,96 @@ INSTANCE: A sequence [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi \ A boa ; inline -: A-v->n-op ( v1 combine-quot reduce-quot -- v2 ) - [ [ [ underlying1>> ] [ underlying2>> ] bi A-rep ] dip call A-rep ] - dip call ; inline +: A-vn->v-op ( v1 v2 quot -- v3 ) + [ [ [ underlying1>> ] dip A-rep ] dip call ] + [ [ [ underlying2>> ] dip A-rep ] dip call ] 3bi + \ A boa ; inline + +: A-v->v-op ( v1 combine-quot -- v2 ) + [ [ underlying1>> A-rep ] dip call ] + [ [ underlying2>> A-rep ] dip call ] 2bi + \ A boa ; inline + +: A-v.-op ( v1 v2 quot -- n ) + [ [ [ underlying1>> ] bi@ A-rep ] dip call ] + [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi + + ; inline + +: (A-v->n-op) ( v1 quot reduce-quot -- n ) + '[ [ underlying1>> ] [ underlying2>> ] bi A-rep @ A-rep ] dip call ; inline + +: A-sum-op ( v1 quot -- n ) + [ (simd-v+) ] (A-v->n-op) ; inline + +: A-vany-op ( v1 quot -- n ) + [ (simd-vbitor) ] (A-v->n-op) ; inline +: A-vall-op ( v1 quot -- n ) + [ (simd-vbitand) ] (A-v->n-op) ; inline + +: A-vmerge-head-op ( v1 v2 quot -- v ) + drop + [ underlying1>> ] bi@ + [ A-rep (simd-(vmerge-head)) ] + [ A-rep (simd-(vmerge-tail)) ] 2bi + \ A boa ; inline + +: A-vmerge-tail-op ( v1 v2 quot -- v ) + drop + [ underlying2>> ] bi@ + [ A-rep (simd-(vmerge-head)) ] + [ A-rep (simd-(vmerge-tail)) ] 2bi + \ A boa ; inline + +: A-v-conversion-op ( v1 to-type quot -- v ) + swap [ + [ [ underlying1>> A-rep ] dip call ] + [ [ underlying2>> A-rep ] dip call ] 2bi + ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline + +: A-vpack-op ( v1 v2 to-type quot -- v ) + swap [ + '[ [ underlying1>> ] [ underlying2>> ] bi A-rep @ ] bi* + ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline + +: A-vunpack-head-op ( v1 to-type quot -- v ) + '[ + underlying1>> + [ A-rep @ ] + [ A-rep (simd-(vunpack-tail)) ] bi + ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline + +: A-vunpack-tail-op ( v1 to-type quot -- v ) + '[ + underlying2>> + [ A-rep (simd-(vunpack-head)) ] + [ A-rep @ ] bi + ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline + +simd new + \ A >>class + \ A-with >>ctor + \ A-rep >>rep + { + { v. A-v.-op } + { sum A-sum-op } + { vnone? A-vany-op } + { vany? A-vany-op } + { vall? A-vall-op } + { (vmerge-head) A-vmerge-head-op } + { (vmerge-tail) A-vmerge-tail-op } + { (v>integer) A-v-conversion-op } + { (v>float) A-v-conversion-op } + { (vpack-signed) A-vpack-op } + { (vpack-unsigned) A-vpack-op } + { (vunpack-head) A-vunpack-head-op } + { (vunpack-tail) A-vunpack-tail-op } + } >>special-wrappers + { + { { +vector+ +vector+ -> +vector+ } A-vv->v-op } + { { +vector+ +scalar+ -> +vector+ } A-vn->v-op } + { { +vector+ +literal+ -> +vector+ } A-vn->v-op } + { { +vector+ -> +vector+ } A-v->v-op } + } >>schema-wrappers +(define-simd-256) ;FUNCTOR diff --git a/basis/math/vectors/simd/intrinsics/intrinsics-tests.factor b/basis/math/vectors/simd/intrinsics/intrinsics-tests.factor new file mode 100644 index 0000000000..84eee935a0 --- /dev/null +++ b/basis/math/vectors/simd/intrinsics/intrinsics-tests.factor @@ -0,0 +1,18 @@ +IN: math.vectors.simd.intrinsics.tests +USING: math.vectors.simd.intrinsics cpu.architecture tools.test ; + +[ 16 ] [ uchar-16-rep rep-components ] unit-test +[ 16 ] [ char-16-rep rep-components ] unit-test +[ 8 ] [ ushort-8-rep rep-components ] unit-test +[ 8 ] [ short-8-rep rep-components ] unit-test +[ 4 ] [ uint-4-rep rep-components ] unit-test +[ 4 ] [ int-4-rep rep-components ] unit-test +[ 4 ] [ float-4-rep rep-components ] unit-test +[ 2 ] [ double-2-rep rep-components ] unit-test + +{ 4 1 } [ uint-4-rep (simd-boa) ] must-infer-as +{ 4 1 } [ int-4-rep (simd-boa) ] must-infer-as +{ 4 1 } [ float-4-rep (simd-boa) ] must-infer-as +{ 2 1 } [ double-2-rep (simd-boa) ] must-infer-as + + diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor index 914d1ef169..fab55949b4 100644 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor @@ -1,21 +1,98 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel alien alien.data cpu.architecture libc ; +USING: alien alien.c-types alien.data assocs combinators +cpu.architecture compiler.cfg.comparisons fry generalizations +kernel libc macros math +math.vectors.conversion.backend +sequences sets effects accessors namespaces +lexer parser vocabs.parser words arrays math.vectors ; IN: math.vectors.simd.intrinsics ERROR: bad-simd-call ; -: (simd-v+) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-v-) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-v*) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-v/) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-vmin) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-vmax) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-vsqrt) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-sum) ( v1 rep -- v2 ) bad-simd-call ; -: (simd-broadcast) ( x rep -- v ) bad-simd-call ; +<< + +: simd-effect ( word -- effect ) + stack-effect [ in>> "rep" suffix ] [ out>> ] bi <effect> ; +: simd-conversion-effect ( word -- effect ) + stack-effect [ in>> but-last "rep" suffix ] [ out>> ] bi <effect> ; + +SYMBOL: simd-ops + +V{ } clone simd-ops set-global + +: (SIMD-OP:) ( accum quot -- accum ) + [ + scan-word dup name>> "(simd-" ")" surround create-in + [ nip [ bad-simd-call ] define ] + ] dip + '[ _ dip set-stack-effect ] + [ 2array simd-ops get push ] + 2tri ; inline + +SYNTAX: SIMD-OP: + [ simd-effect ] (SIMD-OP:) ; + +SYNTAX: SIMD-CONVERSION-OP: + [ simd-conversion-effect ] (SIMD-OP:) ; + +>> + +SIMD-OP: v+ +SIMD-OP: v- +SIMD-OP: vneg +SIMD-OP: v+- +SIMD-OP: vs+ +SIMD-OP: vs- +SIMD-OP: vs* +SIMD-OP: v* +SIMD-OP: v/ +SIMD-OP: vmin +SIMD-OP: vmax +SIMD-OP: v. +SIMD-OP: vsqrt +SIMD-OP: sum +SIMD-OP: vabs +SIMD-OP: vbitand +SIMD-OP: vbitandn +SIMD-OP: vbitor +SIMD-OP: vbitxor +SIMD-OP: vbitnot +SIMD-OP: vand +SIMD-OP: vandn +SIMD-OP: vor +SIMD-OP: vxor +SIMD-OP: vnot +SIMD-OP: vlshift +SIMD-OP: vrshift +SIMD-OP: hlshift +SIMD-OP: hrshift +SIMD-OP: vshuffle-elements +SIMD-OP: vshuffle-bytes +SIMD-OP: (vmerge-head) +SIMD-OP: (vmerge-tail) +SIMD-OP: v<= +SIMD-OP: v< +SIMD-OP: v= +SIMD-OP: v> +SIMD-OP: v>= +SIMD-OP: vunordered? +SIMD-OP: vany? +SIMD-OP: vall? +SIMD-OP: vnone? + +SIMD-CONVERSION-OP: (v>float) +SIMD-CONVERSION-OP: (v>integer) +SIMD-CONVERSION-OP: (vpack-signed) +SIMD-CONVERSION-OP: (vpack-unsigned) +SIMD-CONVERSION-OP: (vunpack-head) +SIMD-CONVERSION-OP: (vunpack-tail) + +: (simd-with) ( x rep -- v ) bad-simd-call ; : (simd-gather-2) ( a b rep -- v ) bad-simd-call ; : (simd-gather-4) ( a b c d rep -- v ) bad-simd-call ; +: (simd-select) ( v n rep -- x ) bad-simd-call ; + : assert-positive ( x -- y ) ; : alien-vector ( c-ptr n rep -- value ) @@ -26,3 +103,105 @@ ERROR: bad-simd-call ; ! Inefficient version for when intrinsics are missing [ swap <displaced-alien> swap ] dip rep-size memcpy ; +<< + +: rep-components ( rep -- n ) + 16 swap rep-component-type heap-size /i ; foldable + +: rep-coercer ( rep -- quot ) + { + { [ dup int-vector-rep? ] [ [ >fixnum ] ] } + { [ dup float-vector-rep? ] [ [ >float ] ] } + } cond nip ; foldable + +: rep-coerce ( value rep -- value' ) + rep-coercer call( value -- value' ) ; inline + +CONSTANT: rep-gather-words + { + { 2 (simd-gather-2) } + { 4 (simd-gather-4) } + } + +: rep-gather-word ( rep -- word ) + rep-components rep-gather-words at ; + +>> + +MACRO: (simd-boa) ( rep -- quot ) + { + [ rep-coercer ] + [ rep-components ] + [ ] + [ rep-gather-word ] + } cleave + '[ _ _ napply _ _ execute ] ; + +GENERIC# supported-simd-op? 1 ( rep intrinsic -- ? ) + +: (%unpack-reps) ( -- reps ) + %merge-vector-reps [ int-vector-rep? ] filter + %unpack-vector-head-reps union ; + +: (%abs-reps) ( -- reps ) + cc> %compare-vector-reps [ int-vector-rep? ] filter + %xor-vector-reps [ float-vector-rep? ] filter + union + { uchar-16-rep ushort-8-rep uint-4-rep ulonglong-2-rep } union ; + +: (%shuffle-imm-reps) ( -- reps ) + %shuffle-vector-reps %shuffle-vector-imm-reps union ; + +M: vector-rep supported-simd-op? + { + { \ (simd-v+) [ %add-vector-reps ] } + { \ (simd-vs+) [ %saturated-add-vector-reps ] } + { \ (simd-v+-) [ %add-sub-vector-reps ] } + { \ (simd-v-) [ %sub-vector-reps ] } + { \ (simd-vs-) [ %saturated-sub-vector-reps ] } + { \ (simd-vneg) [ %sub-vector-reps ] } + { \ (simd-v*) [ %mul-vector-reps ] } + { \ (simd-vs*) [ %saturated-mul-vector-reps ] } + { \ (simd-v/) [ %div-vector-reps ] } + { \ (simd-vmin) [ %min-vector-reps ] } + { \ (simd-vmax) [ %max-vector-reps ] } + { \ (simd-v.) [ %dot-vector-reps ] } + { \ (simd-vsqrt) [ %sqrt-vector-reps ] } + { \ (simd-sum) [ %horizontal-add-vector-reps ] } + { \ (simd-vabs) [ (%abs-reps) ] } + { \ (simd-vbitand) [ %and-vector-reps ] } + { \ (simd-vbitandn) [ %andn-vector-reps ] } + { \ (simd-vbitor) [ %or-vector-reps ] } + { \ (simd-vbitxor) [ %xor-vector-reps ] } + { \ (simd-vbitnot) [ %xor-vector-reps ] } + { \ (simd-vand) [ %and-vector-reps ] } + { \ (simd-vandn) [ %andn-vector-reps ] } + { \ (simd-vor) [ %or-vector-reps ] } + { \ (simd-vxor) [ %xor-vector-reps ] } + { \ (simd-vnot) [ %xor-vector-reps ] } + { \ (simd-vlshift) [ %shl-vector-reps ] } + { \ (simd-vrshift) [ %shr-vector-reps ] } + { \ (simd-hlshift) [ %horizontal-shl-vector-reps ] } + { \ (simd-hrshift) [ %horizontal-shr-vector-reps ] } + { \ (simd-vshuffle-elements) [ (%shuffle-imm-reps) ] } + { \ (simd-vshuffle-bytes) [ %shuffle-vector-reps ] } + { \ (simd-(vmerge-head)) [ %merge-vector-reps ] } + { \ (simd-(vmerge-tail)) [ %merge-vector-reps ] } + { \ (simd-(v>float)) [ %integer>float-vector-reps ] } + { \ (simd-(v>integer)) [ %float>integer-vector-reps ] } + { \ (simd-(vpack-signed)) [ %signed-pack-vector-reps ] } + { \ (simd-(vpack-unsigned)) [ %unsigned-pack-vector-reps ] } + { \ (simd-(vunpack-head)) [ (%unpack-reps) ] } + { \ (simd-(vunpack-tail)) [ (%unpack-reps) ] } + { \ (simd-v<=) [ cc<= %compare-vector-reps ] } + { \ (simd-v<) [ cc< %compare-vector-reps ] } + { \ (simd-v=) [ cc= %compare-vector-reps ] } + { \ (simd-v>) [ cc> %compare-vector-reps ] } + { \ (simd-v>=) [ cc>= %compare-vector-reps ] } + { \ (simd-vunordered?) [ cc/<>= %compare-vector-reps ] } + { \ (simd-gather-2) [ %gather-vector-2-reps ] } + { \ (simd-gather-4) [ %gather-vector-4-reps ] } + { \ (simd-vany?) [ %test-vector-reps ] } + { \ (simd-vall?) [ %test-vector-reps ] } + { \ (simd-vnone?) [ %test-vector-reps ] } + } case member? ; diff --git a/basis/math/vectors/simd/simd-docs.factor b/basis/math/vectors/simd/simd-docs.factor index b110de1de8..97ff99cd28 100644 --- a/basis/math/vectors/simd/simd-docs.factor +++ b/basis/math/vectors/simd/simd-docs.factor @@ -1,6 +1,6 @@ -USING: help.markup help.syntax sequences math math.vectors -multiline kernel.private classes.tuple.private -math.vectors.simd.intrinsics cpu.architecture ; +USING: classes.tuple.private cpu.architecture help.markup +help.syntax kernel.private math math.vectors +math.vectors.simd.intrinsics sequences ; IN: math.vectors.simd ARTICLE: "math.vectors.simd.intro" "Introduction to SIMD support" @@ -17,48 +17,64 @@ $nl "There should never be any reason to use " { $link "math.vectors.simd.intrinsics" } " directly, but they too have a straightforward, but lower-level, interface." ; ARTICLE: "math.vectors.simd.support" "Supported SIMD instruction sets and operations" -"At present, the SIMD support makes use of SSE2 and a few SSE3 instructions on x86 CPUs." +"At present, the SIMD support makes use of a subset of SSE up to SSE4.1. The subset used depends on the current CPU type." $nl -"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } ". If SSE3 is not available, software fallbacks are used for " { $link sum } " and related words, decreasing performance." +"SSE1 only supports single-precision SIMD (" { $snippet "float-4" } " and " { $snippet "float-8" } ")." $nl -"On PowerPC, or older x86 chips without SSE2, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance." +"SSE2 introduces double-precision SIMD (" { $snippet "double-2" } " and " { $snippet "double-4" } ") and integer SIMD (all types). Integer SIMD is missing a few features, in particular the " { $link vmin } " and " { $link vmax } " operations only work on " { $snippet "uchar-16" } " and " { $snippet "short-8" } "." +$nl +"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } "." +$nl +"SSSE3 introduces " { $link vabs } " for " { $snippet "char-16" } ", " { $snippet "short-8" } " and " { $snippet "int-4" } "." +$nl +"SSE4.1 introduces " { $link vmin } " and " { $link vmax } " for all remaining integer types, a faster instruction for " { $link v. } ", and a few other things." +$nl +"On PowerPC, or older x86 chips without SSE, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance." $nl "The primities in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary do not have software fallbacks, but they should not be called directly in any case." ; ARTICLE: "math.vectors.simd.types" "SIMD vector types" -"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type such as " { $snippet "float" } " or " { $snippet "double" } ", and " { $snippet "count" } " is a vector dimension, such as 2, 4, or 8." -$nl -"The following vector types are defined:" -{ $subsection float-4 } -{ $subsection double-2 } -{ $subsection float-8 } -{ $subsection double-4 } -"For each vector type, several words are defined:" +"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type and " { $snippet "count" } " is a vector dimension." +$nl +"To use a SIMD vector type, a parsing word is used to generate the relevant code and bring it into the vocabulary search path; this is the same idea as with " { $link "specialized-arrays" } ":" +{ $subsections + POSTPONE: SIMD: + POSTPONE: SIMDS: +} +"The following vector types are supported:" +{ $code + "char-16" + "uchar-16" + "char-32" + "uchar-32" + "short-8" + "ushort-8" + "short-16" + "ushort-16" + "int-4" + "uint-4" + "int-8" + "uint-8" + "longlong-2" + "ulonglong-2" + "longlong-4" + "ulonglong-4" + "float-4" + "float-8" + "double-2" + "double-4" +} ; + +ARTICLE: "math.vectors.simd.words" "SIMD vector words" +"For each SIMD vector type, several words are defined, where " { $snippet "type" } " is the type in question:" { $table { "Word" "Stack effect" "Description" } { { $snippet "type-with" } { $snippet "( x -- simd-array )" } "creates a new instance where all components are set to a single scalar" } { { $snippet "type-boa" } { $snippet "( ... -- simd-array )" } "creates a new instance where components are read from the stack" } + { { $snippet "type-cast" } { $snippet "( simd-array -- simd-array' )" } "creates a new SIMD array where the underlying data is taken from another SIMD array, with no format conversion" } { { $snippet ">type" } { $snippet "( seq -- simd-array )" } "creates a new instance initialized with the elements of an existing sequence, which must have the correct length" } { { $snippet "type{" } { $snippet "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" } } -"The " { $link float-4 } " and " { $link double-2 } " types correspond to 128-bit vector registers. The " { $link float-8 } " and " { $link double-4 } " types are not directly supported in hardware, and instead unbox to a pair of 128-bit vector registers." -$nl -"Operations on " { $link float-4 } " instances:" -{ $subsection float-4-with } -{ $subsection float-4-boa } -{ $subsection POSTPONE: float-4{ } -"Operations on " { $link double-2 } " instances:" -{ $subsection double-2-with } -{ $subsection double-2-boa } -{ $subsection POSTPONE: double-2{ } -"Operations on " { $link float-8 } " instances:" -{ $subsection float-8-with } -{ $subsection float-8-boa } -{ $subsection POSTPONE: float-8{ } -"Operations on " { $link double-4 } " instances:" -{ $subsection double-4-with } -{ $subsection double-4-boa } -{ $subsection POSTPONE: double-4{ } "To actually perform vector arithmetic on SIMD vectors, use " { $link "math-vectors" } " words." { $see-also "c-types-specs" } ; @@ -71,7 +87,7 @@ $nl $nl "For example, in the following, no SIMD operations are used at all, because the compiler's propagation pass does not consider dynamic variable usage:" { $code -<" USING: compiler.tree.debugger math.vectors +"""USING: compiler.tree.debugger math.vectors math.vectors.simd ; SYMBOLS: x y ; @@ -79,37 +95,42 @@ SYMBOLS: x y ; double-4{ 1.5 2.0 3.7 0.4 } x set double-4{ 1.5 2.0 3.7 0.4 } y set x get y get v+ -] optimizer-report."> } +] optimizer-report.""" } "The following word benefits from SIMD optimization, because it begins with an unsafe declaration:" { $code -<" USING: compiler.tree.debugger kernel.private +"""USING: compiler.tree.debugger kernel.private math.vectors math.vectors.simd ; +SIMD: float +IN: simd-demo : interpolate ( v a b -- w ) { float-4 float-4 float-4 } declare [ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ; -\ interpolate optimizer-report. "> } +\ interpolate optimizer-report.""" } "Note that using " { $link declare } " is not recommended. Safer ways of getting type information for the input parameters to a word include defining methods on a generic word (the value being dispatched upon has a statically known type in the method body), as well as using " { $link "hints" } " and " { $link POSTPONE: inline } " declarations." $nl "Here is a better version of the " { $snippet "interpolate" } " words above that uses hints:" { $code -<" USING: compiler.tree.debugger hints +"""USING: compiler.tree.debugger hints math.vectors math.vectors.simd ; +SIMD: float +IN: simd-demo : interpolate ( v a b -- w ) [ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ; HINTS: interpolate float-4 float-4 float-4 ; -\ interpolate optimizer-report. "> } +\ interpolate optimizer-report. """ } "This time, the optimizer report lists calls to both SIMD primitives and high-level vector words, because hints cause two code paths to be generated. The " { $snippet "optimized." } " word can be used to make sure that the fast code path consists entirely of calls to primitives." $nl "If the " { $snippet "interpolate" } " word was to be used in several places with different types of vectors, it would be best to declare it " { $link POSTPONE: inline } "." $nl "In the " { $snippet "interpolate" } " word, there is still a call to the " { $link <tuple-boa> } " primitive, because the return value at the end is being boxed on the heap. In the next example, no memory allocation occurs at all because the SIMD vectors are stored inside a struct class (see " { $link "classes.struct" } "); also note the use of inlining:" { $code -<" USING: compiler.tree.debugger math.vectors math.vectors.simd ; +"""USING: compiler.tree.debugger math.vectors math.vectors.simd ; +SIMD: float IN: simd-demo STRUCT: actor @@ -132,13 +153,13 @@ M: actor advance ( dt actor -- ) [ >float ] dip [ update-velocity ] [ update-position ] 2bi ; -M\ actor advance optimized."> +M\ actor advance optimized.""" } "The " { $vocab-link "compiler.cfg.debugger" } " vocabulary can give a lower-level picture of the generated code, that includes register assignments and other low-level details. To look at low-level optimizer output, call " { $snippet "test-mr mr." } " on a word or quotation:" { $code -<" USE: compiler.tree.debugger +"""USE: compiler.tree.debugger -M\ actor advance test-mr mr."> } +M\ actor advance test-mr mr.""" } "An example of a high-performance algorithm that uses SIMD primitives can be found in the " { $vocab-link "benchmark.nbody-simd" } " vocabulary." ; ARTICLE: "math.vectors.simd.intrinsics" "Low-level SIMD primitives" @@ -150,106 +171,48 @@ ARTICLE: "math.vectors.simd.intrinsics" "Low-level SIMD primitives" } "The compiler converts " { $link "math-vectors" } " into SIMD primitives automatically in cases where it is safe; this means that the input types are known to be SIMD vectors, and the CPU supports SIMD." $nl -"It is best to avoid calling these primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "." -{ $subsection (simd-v+) } -{ $subsection (simd-v-) } -{ $subsection (simd-v/) } -{ $subsection (simd-vmin) } -{ $subsection (simd-vmax) } -{ $subsection (simd-vsqrt) } -{ $subsection (simd-sum) } -{ $subsection (simd-broadcast) } -{ $subsection (simd-gather-2) } -{ $subsection (simd-gather-4) } +"It is best to avoid calling SIMD primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "." +$nl "There are two primitives which are used to implement accessing SIMD vector fields of " { $link "classes.struct" } ":" -{ $subsection alien-vector } -{ $subsection set-alien-vector } +{ $subsections + alien-vector + set-alien-vector +} "For the most part, the above primitives correspond directly to vector arithmetic words. They take a representation parameter, which is one of the singleton members of the " { $link vector-rep } " union in the " { $vocab-link "cpu.architecture" } " vocabulary." ; ARTICLE: "math.vectors.simd.alien" "SIMD data in struct classes" -"Struct classes may contain fields which store SIMD data; use one of the following C type names:" -{ $code -<" float-4 -double-2 -float-8 -double-4"> } -"Passing SIMD data as function parameters is not yet supported." ; +"Struct classes may contain fields which store SIMD data; for each SIMD vector type listed in " { $snippet "math.vectors.simd.types" } " there is a C type with the same name." +$nl +"Only SIMD struct fields are allowed at the moment; passing SIMD data as function parameters is not yet supported." ; + +ARTICLE: "math.vectors.simd.accuracy" "Numerical accuracy of SIMD primitives" +"No guarantees are made that " { $vocab-link "math.vectors.simd" } " words will give identical results on different SSE versions, or between the hardware intrinsics and the software fallbacks." +$nl +"In particular, horizontal operations on " { $snippet "float-4" } " and " { $snippet "float-8" } " are affected by this. They are computed with lower precision in intrinsics than the software fallback. Horizontal operations include anything involving adding together the components of a vector, such as " { $link sum } " or " { $link normalize } "." ; ARTICLE: "math.vectors.simd" "Hardware vector arithmetic (SIMD)" "The " { $vocab-link "math.vectors.simd" } " vocabulary extends the " { $vocab-link "math.vectors" } " vocabulary to support efficient vector arithmetic on small, fixed-size vectors." -{ $subsection "math.vectors.simd.intro" } -{ $subsection "math.vectors.simd.types" } -{ $subsection "math.vectors.simd.support" } -{ $subsection "math.vectors.simd.efficiency" } -{ $subsection "math.vectors.simd.alien" } -{ $subsection "math.vectors.simd.intrinsics" } ; - -! ! ! float-4 - -HELP: float-4 -{ $class-description "A sequence of four single-precision floating point values. New instances can be created with " { $link float-4-with } " or " { $link float-4-boa } "." } ; - -HELP: float-4-with -{ $values { "x" float } { "simd-array" float-4 } } -{ $description "Creates a new vector with all four components equal to a scalar." } ; - -HELP: float-4-boa -{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" float-4 } } -{ $description "Creates a new vector from four scalar components." } ; - -HELP: float-4{ -{ $syntax "float-4{ a b c d }" } -{ $description "Literal syntax for a " { $link float-4 } "." } ; - -! ! ! double-2 - -HELP: double-2 -{ $class-description "A sequence of two double-precision floating point values. New instances can be created with " { $link double-2-with } " or " { $link double-2-boa } "." } ; - -HELP: double-2-with -{ $values { "x" float } { "simd-array" double-2 } } -{ $description "Creates a new vector with both components equal to a scalar." } ; - -HELP: double-2-boa -{ $values { "a" float } { "b" float } { "simd-array" double-2 } } -{ $description "Creates a new vector from two scalar components." } ; - -HELP: double-2{ -{ $syntax "double-2{ a b }" } -{ $description "Literal syntax for a " { $link double-2 } "." } ; - -! ! ! float-8 - -HELP: float-8 -{ $class-description "A sequence of eight single-precision floating point values. New instances can be created with " { $link float-8-with } " or " { $link float-8-boa } "." } ; - -HELP: float-8-with -{ $values { "x" float } { "simd-array" float-8 } } -{ $description "Creates a new vector with all eight components equal to a scalar." } ; - -HELP: float-8-boa -{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "e" float } { "f" float } { "g" float } { "h" float } { "simd-array" float-8 } } -{ $description "Creates a new vector from eight scalar components." } ; - -HELP: float-8{ -{ $syntax "float-8{ a b c d e f g h }" } -{ $description "Literal syntax for a " { $link float-8 } "." } ; - -! ! ! double-4 - -HELP: double-4 -{ $class-description "A sequence of four double-precision floating point values. New instances can be created with " { $link double-4-with } " or " { $link double-4-boa } "." } ; - -HELP: double-4-with -{ $values { "x" float } { "simd-array" double-4 } } -{ $description "Creates a new vector with all four components equal to a scalar." } ; - -HELP: double-4-boa -{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" double-4 } } -{ $description "Creates a new vector from four scalar components." } ; - -HELP: double-4{ -{ $syntax "double-4{ a b c d }" } -{ $description "Literal syntax for a " { $link double-4 } "." } ; +{ $subsections + "math.vectors.simd.intro" + "math.vectors.simd.types" + "math.vectors.simd.words" + "math.vectors.simd.support" + "math.vectors.simd.accuracy" + "math.vectors.simd.efficiency" + "math.vectors.simd.alien" + "math.vectors.simd.intrinsics" +} ; + +HELP: SIMD: +{ $syntax "SIMD: type" } +{ $values { "type" "a scalar C type" } } +{ $description "Defines 128-bit and 256-bit SIMD arrays for holding elements of " { $snippet "type" } " into the vocabulary search path. The possible type/length combinations are listed in " { $link "math.vectors.simd.types" } " and the generated words are documented in " { $link "math.vectors.simd.words" } "." } ; + +HELP: SIMDS: +{ $syntax "SIMDS: type type type ... ;" } +{ $values { "type" "a scalar C type" } } +{ $description "Defines 128-bit and 256-bit SIMD arrays for holding elements of each " { $snippet "type" } " into the vocabulary search path. The possible type/length combinations are listed in " { $link "math.vectors.simd.types" } " and the generated words are documented in " { $link "math.vectors.simd.words" } "." } ; + +{ POSTPONE: SIMD: POSTPONE: SIMDS: } related-words ABOUT: "math.vectors.simd" diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor index f5318c341f..8766056a96 100644 --- a/basis/math/vectors/simd/simd-tests.factor +++ b/basis/math/vectors/simd/simd-tests.factor @@ -1,364 +1,593 @@ +USING: accessors arrays classes compiler compiler.tree.debugger +effects fry io kernel kernel.private math math.functions +math.private math.vectors math.vectors.simd +math.vectors.simd.private prettyprint random sequences system +tools.test vocabs assocs compiler.cfg.debugger words +locals math.vectors.specialization combinators cpu.architecture +math.vectors.conversion.backend +math.vectors.simd.intrinsics namespaces byte-arrays alien +specialized-arrays classes.struct eval classes.algebra sets +quotations math.constants compiler.units ; +QUALIFIED-WITH: alien.c-types c +SPECIALIZED-ARRAY: c:float +SIMD: c:char +SIMDS: c:uchar c:short c:ushort c:int c:uint c:longlong c:ulonglong c:float c:double ; IN: math.vectors.simd.tests -USING: math math.vectors.simd math.vectors.simd.private -math.vectors math.functions math.private kernel.private compiler -sequences tools.test compiler.tree.debugger accessors kernel -system ; -[ float-4{ 0 0 0 0 } ] [ float-4 new ] unit-test +! Make sure the functor doesn't generate bogus vocabularies +2 [ [ "USE: math.vectors.simd SIMD: rubinius" eval( -- ) ] must-fail ] times -[ float-4{ 0 0 0 0 } ] [ [ float-4 new ] compile-call ] unit-test +[ f ] [ "math.vectors.simd.instances.rubinius" vocab ] unit-test +! Test type propagation [ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test [ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test -[ float-4{ 12 12 12 12 } ] [ - 12 [ float-4-with ] compile-call -] unit-test +[ V{ float-4 } ] [ [ { float-4 } declare normalize ] final-classes ] unit-test -[ float-4{ 1 2 3 4 } ] [ - 1 2 3 4 [ float-4-boa ] compile-call -] unit-test +[ V{ float-4 } ] [ [ { float-4 float-4 } declare v+ ] final-classes ] unit-test -[ float-4{ 11 22 33 44 } ] [ - float-4{ 1 2 3 4 } float-4{ 10 20 30 40 } - [ { float-4 float-4 } declare v+ ] compile-call -] unit-test +[ V{ float } ] [ [ { float-4 } declare second ] final-classes ] unit-test -[ float-4{ -9 -18 -27 -36 } ] [ - float-4{ 1 2 3 4 } float-4{ 10 20 30 40 } - [ { float-4 float-4 } declare v- ] compile-call -] unit-test +[ V{ int-4 } ] [ [ { int-4 int-4 } declare v+ ] final-classes ] unit-test -[ float-4{ 10 40 90 160 } ] [ - float-4{ 1 2 3 4 } float-4{ 10 20 30 40 } - [ { float-4 float-4 } declare v* ] compile-call -] unit-test +[ t ] [ [ { int-4 } declare second ] final-classes first integer class<= ] unit-test -[ float-4{ 10 100 1000 10000 } ] [ - float-4{ 100 2000 30000 400000 } float-4{ 10 20 30 40 } - [ { float-4 float-4 } declare v/ ] compile-call -] unit-test +[ V{ longlong-2 } ] [ [ { longlong-2 longlong-2 } declare v+ ] final-classes ] unit-test -[ float-4{ -10 -20 -30 -40 } ] [ - float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 } - [ { float-4 float-4 } declare vmin ] compile-call -] unit-test +[ V{ integer } ] [ [ { longlong-2 } declare second ] final-classes ] unit-test -[ float-4{ 10 20 30 40 } ] [ - float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 } - [ { float-4 float-4 } declare vmax ] compile-call -] unit-test +[ V{ int-8 } ] [ [ { int-8 int-8 } declare v+ ] final-classes ] unit-test -[ 10.0 ] [ - float-4{ 1 2 3 4 } - [ { float-4 } declare sum ] compile-call -] unit-test - -[ 13.0 ] [ - float-4{ 1 2 3 4 } - [ { float-4 } declare sum 3.0 + ] compile-call -] unit-test - -[ 8.0 ] [ - float-4{ 1 2 3 4 } float-4{ 2 0 2 0 } - [ { float-4 float-4 } declare v. ] compile-call -] unit-test +[ t ] [ [ { int-8 } declare second ] final-classes first integer class<= ] unit-test -[ float-4{ 5 10 15 20 } ] [ - 5.0 float-4{ 1 2 3 4 } - [ { float float-4 } declare n*v ] compile-call -] unit-test - -[ float-4{ 5 10 15 20 } ] [ - float-4{ 1 2 3 4 } 5.0 - [ { float float-4 } declare v*n ] compile-call -] unit-test - -[ float-4{ 10 5 2 5 } ] [ - 10.0 float-4{ 1 2 5 2 } - [ { float float-4 } declare n/v ] compile-call -] unit-test - -[ float-4{ 0.5 1 1.5 2 } ] [ - float-4{ 1 2 3 4 } 2 - [ { float float-4 } declare v/n ] compile-call -] unit-test - -[ float-4{ 1 0 0 0 } ] [ - float-4{ 10 0 0 0 } - [ { float-4 } declare normalize ] compile-call -] unit-test - -[ 30.0 ] [ - float-4{ 1 2 3 4 } - [ { float-4 } declare norm-sq ] compile-call -] unit-test - -[ t ] [ - float-4{ 1 0 0 0 } - float-4{ 0 1 0 0 } - [ { float-4 float-4 } declare distance ] compile-call - 2 sqrt 1.0e-6 ~ -] unit-test - -[ double-2{ 12 12 } ] [ - 12 [ double-2-with ] compile-call -] unit-test - -[ double-2{ 1 2 } ] [ - 1 2 [ double-2-boa ] compile-call -] unit-test - -[ double-2{ 11 22 } ] [ - double-2{ 1 2 } double-2{ 10 20 } - [ { double-2 double-2 } declare v+ ] compile-call -] unit-test - -[ double-2{ -9 -18 } ] [ - double-2{ 1 2 } double-2{ 10 20 } - [ { double-2 double-2 } declare v- ] compile-call -] unit-test - -[ double-2{ 10 40 } ] [ - double-2{ 1 2 } double-2{ 10 20 } - [ { double-2 double-2 } declare v* ] compile-call -] unit-test - -[ double-2{ 10 100 } ] [ - double-2{ 100 2000 } double-2{ 10 20 } - [ { double-2 double-2 } declare v/ ] compile-call -] unit-test - -[ double-2{ -10 -20 } ] [ - double-2{ -10 20 } double-2{ 10 -20 } - [ { double-2 double-2 } declare vmin ] compile-call -] unit-test - -[ double-2{ 10 20 } ] [ - double-2{ -10 20 } double-2{ 10 -20 } - [ { double-2 double-2 } declare vmax ] compile-call -] unit-test - -[ 3.0 ] [ - double-2{ 1 2 } - [ { double-2 } declare sum ] compile-call -] unit-test - -[ 7.0 ] [ - double-2{ 1 2 } - [ { double-2 } declare sum 4.0 + ] compile-call -] unit-test - -[ 16.0 ] [ - double-2{ 1 2 } double-2{ 2 7 } - [ { double-2 double-2 } declare v. ] compile-call -] unit-test - -[ double-2{ 5 10 } ] [ - 5.0 double-2{ 1 2 } - [ { float double-2 } declare n*v ] compile-call -] unit-test - -[ double-2{ 5 10 } ] [ - double-2{ 1 2 } 5.0 - [ { float double-2 } declare v*n ] compile-call -] unit-test - -[ double-2{ 10 5 } ] [ - 10.0 double-2{ 1 2 } - [ { float double-2 } declare n/v ] compile-call -] unit-test - -[ double-2{ 0.5 1 } ] [ - double-2{ 1 2 } 2 - [ { float double-2 } declare v/n ] compile-call -] unit-test - -[ double-2{ 0 0 } ] [ double-2 new ] unit-test +! Test puns; only on x86 +cpu x86? [ + [ double-2{ 4 1024 } ] [ + float-4{ 0 1 0 2 } + [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call + ] unit-test + + [ 33.0 ] [ + double-2{ 1 2 } double-2{ 10 20 } + [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call + ] unit-test +] when -[ double-2{ 1 0 } ] [ - double-2{ 10 0 } - [ { double-2 } declare normalize ] compile-call -] unit-test +! Fuzz testing +CONSTANT: simd-classes + { + char-16 + uchar-16 + char-32 + uchar-32 + short-8 + ushort-8 + short-16 + ushort-16 + int-4 + uint-4 + int-8 + uint-8 + longlong-2 + ulonglong-2 + longlong-4 + ulonglong-4 + float-4 + float-8 + double-2 + double-4 + } + +: with-ctors ( -- seq ) + simd-classes [ [ name>> "-with" append ] [ vocabulary>> ] bi lookup ] map ; + +: boa-ctors ( -- seq ) + simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup ] map ; + +: check-optimizer ( seq quot eq-quot -- failures ) + '[ + @ + [ dup [ class ] { } map-as ] dip '[ _ declare @ ] + { + [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ] + [ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ] + [ [ call ] dip call ] + [ [ call ] dip compile-call ] + } 2cleave + @ not + ] filter ; inline + +"== Checking -new constructors" print + +[ { } ] [ + simd-classes [ [ [ ] ] dip '[ _ new ] ] [ = ] check-optimizer +] unit-test + +[ { } ] [ + simd-classes [ '[ _ new ] compile-call [ zero? ] all? not ] filter +] unit-test + +"== Checking -with constructors" print + +[ { } ] [ + with-ctors [ + [ 1000 random '[ _ ] ] dip '[ _ execute ] + ] [ = ] check-optimizer +] unit-test + +[ HEX: ffffffff ] [ HEX: ffffffff uint-4-with first ] unit-test + +[ HEX: ffffffff ] [ HEX: ffffffff [ uint-4-with ] compile-call first ] unit-test + +[ HEX: ffffffff ] [ [ HEX: ffffffff uint-4-with ] compile-call first ] unit-test + +"== Checking -boa constructors" print + +[ { } ] [ + boa-ctors [ + [ stack-effect in>> length [ 1000 random ] [ ] replicate-as ] keep + '[ _ execute ] + ] [ = ] check-optimizer +] unit-test + +[ HEX: ffffffff ] [ HEX: ffffffff 2 3 4 [ uint-4-boa ] compile-call first ] unit-test + +"== Checking vector operations" print + +: random-int-vector ( class -- vec ) + new [ drop 1,000 random ] map ; +: random-float-vector ( class -- vec ) + new [ + drop + 1000 random + 10 swap <array> 0/0. suffix random + ] map ; + +: random-vector ( class elt-class -- vec ) + float = + [ random-float-vector ] + [ random-int-vector ] if ; + +:: check-vector-op ( word inputs class elt-class -- inputs quot ) + inputs [ + { + { +vector+ [ class elt-class random-vector ] } + { +scalar+ [ 1000 random elt-class float = [ >float ] when ] } + } case + ] [ ] map-as + word '[ _ execute ] ; + +: remove-float-words ( alist -- alist' ) + { vsqrt n/v v/n v/ normalize } unique assoc-diff ; + +: remove-integer-words ( alist -- alist' ) + { vlshift vrshift } unique assoc-diff ; + +: boolean-ops ( -- words ) + { vand vandn vor vxor vnot } ; + +: remove-boolean-words ( alist -- alist' ) + boolean-ops unique assoc-diff ; + +: remove-special-words ( alist -- alist' ) + ! These have their own tests later + { + hlshift hrshift vshuffle-bytes vshuffle-elements vbroadcast + vany? vall? vnone? + (v>float) (v>integer) + (vpack-signed) (vpack-unsigned) + (vunpack-head) (vunpack-tail) + } unique assoc-diff ; + +: ops-to-check ( elt-class -- alist ) + [ vector-words >alist ] dip + float = [ remove-integer-words ] [ remove-float-words ] if + remove-boolean-words + remove-special-words ; + +: check-vector-ops ( class elt-class compare-quot -- ) + [ + [ nip ops-to-check ] 2keep + '[ first2 inputs _ _ check-vector-op ] + ] dip check-optimizer ; inline + +: approx= ( x y -- ? ) + { + { [ 2dup [ fp-nan? ] both? ] [ 2drop t ] } + { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] } + { [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] } + { [ 2dup [ sequence? ] both? ] [ + [ + { + { [ 2dup [ fp-nan? ] both? ] [ 2drop t ] } + { [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] } + { [ 2dup [ fp-nan? ] either? not ] [ -1.e8 ~ ] } + } cond + ] 2all? + ] } + } cond ; + +: exact= ( x y -- ? ) + { + { [ 2dup [ float? ] both? ] [ fp-bitwise= ] } + { [ 2dup [ sequence? ] both? ] [ [ fp-bitwise= ] 2all? ] } + } cond ; -[ 5.0 ] [ - double-2{ 1 2 } - [ { double-2 } declare norm-sq ] compile-call -] unit-test +: simd-classes&reps ( -- alist ) + simd-classes [ + { + { [ dup name>> "float" head? ] [ float [ approx= ] ] } + { [ dup name>> "double" head? ] [ float [ exact= ] ] } + [ fixnum [ = ] ] + } cond 3array + ] map ; + +simd-classes&reps [ + [ [ { } ] ] dip first3 '[ _ _ _ check-vector-ops ] unit-test +] each + +"== Checking boolean operations" print + +: random-boolean-vector ( class -- vec ) + new [ drop 2 random zero? ] map ; + +:: check-boolean-op ( word inputs class elt-class -- inputs quot ) + inputs [ + { + { +vector+ [ class random-boolean-vector ] } + { +scalar+ [ 1000 random elt-class float = [ >float ] when ] } + } case + ] [ ] map-as + word '[ _ execute ] ; + +: check-boolean-ops ( class elt-class compare-quot -- ) + [ + [ boolean-ops [ dup word-schema ] { } map>assoc ] 2dip + '[ first2 inputs _ _ check-boolean-op ] + ] dip check-optimizer ; inline + +simd-classes&reps [ + [ [ { } ] ] dip first3 '[ _ _ _ check-boolean-ops ] unit-test +] each + +"== Checking vector blend" print + +[ char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } ] +[ + char-16{ t t f f t t t f t f f f t f t t } + char-16{ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 } + char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 } v? +] unit-test + +[ char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } ] +[ + char-16{ t t f f t t t f t f f f t f t t } + char-16{ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 } + char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 } + [ { char-16 char-16 char-16 } declare v? ] compile-call +] unit-test + +[ int-4{ 1 22 33 4 } ] +[ int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 } v? ] unit-test + +[ int-4{ 1 22 33 4 } ] +[ + int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 } + [ { int-4 int-4 int-4 } declare v? ] compile-call +] unit-test + +[ float-4{ 1.0 22.0 33.0 4.0 } ] +[ float-4{ t f f t } float-4{ 1.0 2.0 3.0 4.0 } float-4{ 11.0 22.0 33.0 44.0 } v? ] unit-test + +[ float-4{ 1.0 22.0 33.0 4.0 } ] +[ + float-4{ t f f t } float-4{ 1.0 2.0 3.0 4.0 } float-4{ 11.0 22.0 33.0 44.0 } + [ { float-4 float-4 float-4 } declare v? ] compile-call +] unit-test + +"== Checking shifts and permutations" print + +[ int-4{ 256 512 1024 2048 } ] +[ int-4{ 1 2 4 8 } 1 hlshift ] unit-test + +[ int-4{ 256 512 1024 2048 } ] +[ int-4{ 1 2 4 8 } [ { int-4 } declare 1 hlshift ] compile-call ] unit-test + +[ int-4{ 256 512 1024 2048 } ] +[ int-4{ 1 2 4 8 } 1 [ { int-4 fixnum } declare hlshift ] compile-call ] unit-test + +[ int-4{ 1 2 4 8 } ] +[ int-4{ 256 512 1024 2048 } 1 hrshift ] unit-test + +[ int-4{ 1 2 4 8 } ] +[ int-4{ 256 512 1024 2048 } [ { int-4 } declare 1 hrshift ] compile-call ] unit-test + +[ int-4{ 1 2 4 8 } ] +[ int-4{ 256 512 1024 2048 } 1 [ { int-4 fixnum } declare hrshift ] compile-call ] unit-test + +! Invalid inputs should not cause the compiler to throw errors +[ ] [ + [ [ { int-4 } declare t hrshift ] (( a -- b )) define-temp drop ] with-compilation-unit +] unit-test + +[ ] [ + [ [ { int-4 } declare { 3 2 1 } vshuffle ] (( a -- b )) define-temp drop ] with-compilation-unit +] unit-test + +! Shuffles +: shuffles-for ( n -- shuffles ) + { + { 2 [ + { + { 0 1 } + { 1 1 } + { 1 0 } + { 0 0 } + } + ] } + { 4 [ + { + { 1 2 3 0 } + { 0 1 2 3 } + { 1 1 2 2 } + { 0 0 1 1 } + { 2 2 3 3 } + { 0 1 0 1 } + { 2 3 2 3 } + { 0 0 2 2 } + { 1 1 3 3 } + { 0 1 0 1 } + { 2 2 3 3 } + } + ] } + { 8 [ + 4 shuffles-for + 4 shuffles-for + [ [ 4 + ] map ] map + [ append ] 2map + ] } + [ dup '[ _ random ] replicate 1array ] + } case ; + +simd-classes [ + [ [ { } ] ] dip + [ new length shuffles-for ] keep + '[ + _ [ [ _ new [ length iota ] keep like 1quotation ] dip '[ _ vshuffle ] ] + [ = ] check-optimizer + ] unit-test +] each -[ t ] [ - double-2{ 1 0 } - double-2{ 0 1 } - [ { double-2 double-2 } declare distance ] compile-call - 2 sqrt 1.0e-6 ~ -] unit-test +"== Checking variable shuffles" print -[ double-4{ 0 0 0 0 } ] [ double-4 new ] unit-test +: random-shift-vector ( class -- vec ) + new [ drop 16 random ] map ; -[ double-4{ 1 2 3 4 } ] [ - 1 2 3 4 double-4-boa -] unit-test +:: test-shift-vector ( class -- ? ) + class random-int-vector :> src + char-16 random-shift-vector :> perm + { class char-16 } :> decl -[ double-4{ 1 1 1 1 } ] [ - 1 double-4-with -] unit-test + src perm vshuffle + src perm [ decl declare vshuffle ] compile-call + = ; inline -[ double-4{ 0 1 2 3 } ] [ - 1 double-4-with [ * ] map-index -] unit-test +{ char-16 uchar-16 short-8 ushort-8 int-4 uint-4 longlong-2 ulonglong-2 } +[ 10 swap '[ [ t ] [ _ test-shift-vector ] unit-test ] times ] each -[ V{ float } ] [ [ { double-4 } declare norm-sq ] final-classes ] unit-test +"== Checking vector tests" print -[ V{ float } ] [ [ { double-4 } declare norm ] final-classes ] unit-test +:: test-vector-tests-bool ( vector declaration -- none? any? all? ) + vector + [ [ declaration declare vnone? ] compile-call ] + [ [ declaration declare vany? ] compile-call ] + [ [ declaration declare vall? ] compile-call ] tri ; inline -[ double-4{ 12 12 12 12 } ] [ - 12 [ double-4-with ] compile-call -] unit-test +: yes ( -- x ) t ; +: no ( -- x ) f ; -[ double-4{ 1 2 3 4 } ] [ - 1 2 3 4 [ double-4-boa ] compile-call -] unit-test +:: test-vector-tests-branch ( vector declaration -- none? any? all? ) + vector + [ [ declaration declare vnone? [ yes ] [ no ] if ] compile-call ] + [ [ declaration declare vany? [ yes ] [ no ] if ] compile-call ] + [ [ declaration declare vall? [ yes ] [ no ] if ] compile-call ] tri ; inline -[ double-4{ 11 22 33 44 } ] [ - double-4{ 1 2 3 4 } double-4{ 10 20 30 40 } - [ { double-4 double-4 } declare v+ ] compile-call -] unit-test +SYMBOL: !!inconsistent!! -[ double-4{ -9 -18 -27 -36 } ] [ - double-4{ 1 2 3 4 } double-4{ 10 20 30 40 } - [ { double-4 double-4 } declare v- ] compile-call -] unit-test +: ?inconsistent ( a b -- ab/inconsistent ) + 2dup = [ drop ] [ 2drop !!inconsistent!! ] if ; -[ double-4{ 10 40 90 160 } ] [ - double-4{ 1 2 3 4 } double-4{ 10 20 30 40 } - [ { double-4 double-4 } declare v* ] compile-call -] unit-test +:: test-vector-tests ( vector decl -- none? any? all? ) + vector decl test-vector-tests-bool :> bool-all :> bool-any :> bool-none + vector decl test-vector-tests-branch :> branch-all :> branch-any :> branch-none + + bool-none branch-none ?inconsistent + bool-any branch-any ?inconsistent + bool-all branch-all ?inconsistent ; inline + +[ f t t ] +[ float-4{ t t t t } { float-4 } test-vector-tests ] unit-test +[ f t f ] +[ float-4{ f t t t } { float-4 } test-vector-tests ] unit-test +[ t f f ] +[ float-4{ f f f f } { float-4 } test-vector-tests ] unit-test + +[ f t t ] +[ double-2{ t t } { double-2 } test-vector-tests ] unit-test +[ f t f ] +[ double-2{ f t } { double-2 } test-vector-tests ] unit-test +[ t f f ] +[ double-2{ f f } { double-2 } test-vector-tests ] unit-test + +[ f t t ] +[ int-4{ t t t t } { int-4 } test-vector-tests ] unit-test +[ f t f ] +[ int-4{ f t t t } { int-4 } test-vector-tests ] unit-test +[ t f f ] +[ int-4{ f f f f } { int-4 } test-vector-tests ] unit-test + +[ f t t ] +[ float-8{ t t t t t t t t } { float-8 } test-vector-tests ] unit-test +[ f t f ] +[ float-8{ f t t t t f t t } { float-8 } test-vector-tests ] unit-test +[ t f f ] +[ float-8{ f f f f f f f f } { float-8 } test-vector-tests ] unit-test + +[ f t t ] +[ double-4{ t t t t } { double-4 } test-vector-tests ] unit-test +[ f t f ] +[ double-4{ f t t f } { double-4 } test-vector-tests ] unit-test +[ t f f ] +[ double-4{ f f f f } { double-4 } test-vector-tests ] unit-test + +[ f t t ] +[ int-8{ t t t t t t t t } { int-8 } test-vector-tests ] unit-test +[ f t f ] +[ int-8{ f t t t t f f f } { int-8 } test-vector-tests ] unit-test +[ t f f ] +[ int-8{ f f f f f f f f } { int-8 } test-vector-tests ] unit-test + +"== Checking element access" print + +! Test element access -- it should box bignums for int-4 on x86 +: test-accesses ( seq -- failures ) + [ length >array ] keep + '[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline + +[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test +[ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-accesses ] unit-test +[ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-accesses ] unit-test + +[ HEX: 7fffffff ] [ int-4{ HEX: 7fffffff 3 4 -8 } first ] unit-test +[ -8 ] [ int-4{ HEX: 7fffffff 3 4 -8 } last ] unit-test +[ HEX: ffffffff ] [ uint-4{ HEX: ffffffff 2 3 4 } first ] unit-test + +[ { } ] [ double-2{ 1.0 2.0 } test-accesses ] unit-test +[ { } ] [ longlong-2{ 1 2 } test-accesses ] unit-test +[ { } ] [ ulonglong-2{ 1 2 } test-accesses ] unit-test + +[ { } ] [ float-8{ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 } test-accesses ] unit-test +[ { } ] [ int-8{ 1 2 3 4 5 6 7 8 } test-accesses ] unit-test +[ { } ] [ uint-8{ 1 2 3 4 5 6 7 8 } test-accesses ] unit-test + +[ { } ] [ double-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test +[ { } ] [ longlong-4{ 1 2 3 4 } test-accesses ] unit-test +[ { } ] [ ulonglong-4{ 1 2 3 4 } test-accesses ] unit-test + +"== Checking broadcast" print +: test-broadcast ( seq -- failures ) + [ length >array ] keep + '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ; inline + +[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test +[ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-broadcast ] unit-test +[ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-broadcast ] unit-test + +[ { } ] [ double-2{ 1.0 2.0 } test-broadcast ] unit-test +[ { } ] [ longlong-2{ 1 2 } test-broadcast ] unit-test +[ { } ] [ ulonglong-2{ 1 2 } test-broadcast ] unit-test + +[ { } ] [ float-8{ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 } test-broadcast ] unit-test +[ { } ] [ int-8{ 1 2 3 4 5 6 7 8 } test-broadcast ] unit-test +[ { } ] [ uint-8{ 1 2 3 4 5 6 7 8 } test-broadcast ] unit-test + +[ { } ] [ double-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test +[ { } ] [ longlong-4{ 1 2 3 4 } test-broadcast ] unit-test +[ { } ] [ ulonglong-4{ 1 2 3 4 } test-broadcast ] unit-test + +! Make sure we use the fallback in the correct situations +[ int-4{ 3 3 3 3 } ] [ int-4{ 12 34 3 17 } 2 [ { int-4 fixnum } declare vbroadcast ] compile-call ] unit-test + +"== Checking alien operations" print -[ double-4{ 10 100 1000 10000 } ] [ - double-4{ 100 2000 30000 400000 } double-4{ 10 20 30 40 } - [ { double-4 double-4 } declare v/ ] compile-call +[ float-4{ 1 2 3 4 } ] [ + [ + float-4{ 1 2 3 4 } + underlying>> 0 float-4-rep alien-vector + ] compile-call float-4 boa ] unit-test -[ double-4{ -10 -20 -30 -40 } ] [ - double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 } - [ { double-4 double-4 } declare vmin ] compile-call +[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [ + 16 [ 1 ] B{ } replicate-as 16 <byte-array> + [ + 0 [ + { byte-array c-ptr fixnum } declare + float-4-rep set-alien-vector + ] compile-call + ] keep ] unit-test -[ double-4{ 10 20 30 40 } ] [ - double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 } - [ { double-4 double-4 } declare vmax ] compile-call +[ float-array{ 1 2 3 4 } ] [ + [ + float-array{ 1 2 3 4 } underlying>> + float-array{ 4 3 2 1 } clone + [ underlying>> 0 float-4-rep set-alien-vector ] keep + ] compile-call ] unit-test -[ 10.0 ] [ - double-4{ 1 2 3 4 } - [ { double-4 } declare sum ] compile-call -] unit-test +STRUCT: simd-struct +{ x float-4 } +{ y longlong-2 } +{ z double-4 } +{ w int-8 } ; -[ 13.0 ] [ - double-4{ 1 2 3 4 } - [ { double-4 } declare sum 3.0 + ] compile-call -] unit-test +[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test -[ 8.0 ] [ - double-4{ 1 2 3 4 } double-4{ 2 0 2 0 } - [ { double-4 double-4 } declare v. ] compile-call +[ + float-4{ 1 2 3 4 } + longlong-2{ 2 1 } + double-4{ 4 3 2 1 } + int-8{ 1 2 3 4 5 6 7 8 } +] [ + simd-struct <struct> + float-4{ 1 2 3 4 } >>x + longlong-2{ 2 1 } >>y + double-4{ 4 3 2 1 } >>z + int-8{ 1 2 3 4 5 6 7 8 } >>w + { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave +] unit-test + +[ + float-4{ 1 2 3 4 } + longlong-2{ 2 1 } + double-4{ 4 3 2 1 } + int-8{ 1 2 3 4 5 6 7 8 } +] [ + [ + simd-struct <struct> + float-4{ 1 2 3 4 } >>x + longlong-2{ 2 1 } >>y + double-4{ 4 3 2 1 } >>z + int-8{ 1 2 3 4 5 6 7 8 } >>w + { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave + ] compile-call ] unit-test -[ double-4{ 5 10 15 20 } ] [ - 5.0 double-4{ 1 2 3 4 } - [ { float double-4 } declare n*v ] compile-call -] unit-test +"== Misc tests" print -[ double-4{ 5 10 15 20 } ] [ - double-4{ 1 2 3 4 } 5.0 - [ { float double-4 } declare v*n ] compile-call -] unit-test +[ ] [ char-16 new 1array stack. ] unit-test -[ double-4{ 10 5 2 5 } ] [ - 10.0 double-4{ 1 2 5 2 } - [ { float double-4 } declare n/v ] compile-call +! CSSA bug +[ 8000000 ] [ + int-8{ 1000 1000 1000 1000 1000 1000 1000 1000 } + [ { int-8 } declare dup [ * ] [ + ] 2map-reduce ] compile-call ] unit-test -[ double-4{ 0.5 1 1.5 2 } ] [ - double-4{ 1 2 3 4 } 2 - [ { float double-4 } declare v/n ] compile-call -] unit-test +! Coalescing was too aggressive +:: broken ( axis theta -- a b c ) + axis { float-4 } declare drop + theta { float } declare drop -[ double-4{ 1 0 0 0 } ] [ - double-4{ 10 0 0 0 } - [ { double-4 } declare normalize ] compile-call -] unit-test + theta cos float-4-with :> cc + theta sin float-4-with :> ss + + axis cc v+ :> diagonal -[ 30.0 ] [ - double-4{ 1 2 3 4 } - [ { double-4 } declare norm-sq ] compile-call -] unit-test + diagonal cc ss ; inline [ t ] [ - double-4{ 1 0 0 0 } - double-4{ 0 1 0 0 } - [ { double-4 double-4 } declare distance ] compile-call - 2 sqrt 1.0e-6 ~ -] unit-test - -[ float-8{ 0 0 0 0 0 0 0 0 } ] [ float-8 new ] unit-test - -[ float-8{ 0 0 0 0 0 0 0 0 } ] [ [ float-8 new ] compile-call ] unit-test - -[ float-8{ 1 1 1 1 1 1 1 1 } ] [ 1 float-8-with ] unit-test - -[ float-8{ 1 1 1 1 1 1 1 1 } ] [ [ 1 float-8-with ] compile-call ] unit-test - -[ float-8{ 1 2 3 4 5 6 7 8 } ] [ 1 2 3 4 5 6 7 8 float-8-boa ] unit-test - -[ float-8{ 1 2 3 4 5 6 7 8 } ] [ [ 1 2 3 4 5 6 7 8 float-8-boa ] compile-call ] unit-test - -[ float-8{ 3 6 9 12 15 18 21 24 } ] [ - float-8{ 1 2 3 4 5 6 7 8 } - float-8{ 2 4 6 8 10 12 14 16 } - [ { float-8 float-8 } declare v+ ] compile-call -] unit-test - -[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [ - float-8{ 1 2 3 4 5 6 7 8 } - float-8{ 2 4 6 8 10 12 14 16 } - [ { float-8 float-8 } declare v- ] compile-call -] unit-test - -[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [ - -0.5 - float-8{ 2 4 6 8 10 12 14 16 } - [ { float float-8 } declare n*v ] compile-call -] unit-test - -[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [ - float-8{ 2 4 6 8 10 12 14 16 } - -0.5 - [ { float-8 float } declare v*n ] compile-call -] unit-test - -[ float-8{ 256 128 64 32 16 8 4 2 } ] [ - 256.0 - float-8{ 1 2 4 8 16 32 64 128 } - [ { float float-8 } declare n/v ] compile-call -] unit-test - -[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [ - float-8{ 2 4 6 8 10 12 14 16 } - -2.0 - [ { float-8 float } declare v/n ] compile-call + float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ] + [ compile-call ] [ call ] 3bi = ] unit-test - -! Test puns; only on x86 -cpu x86? [ - [ double-2{ 4 1024 } ] [ - float-4{ 0 1 0 2 } - [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call - ] unit-test - - [ 33.0 ] [ - double-2{ 1 2 } double-2{ 10 20 } - [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call - ] unit-test -] when diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index a3c99ae217..ffa6b5ba18 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -1,185 +1,42 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types byte-arrays cpu.architecture -kernel math math.functions math.vectors -math.vectors.simd.functor math.vectors.simd.intrinsics -math.vectors.specialization parser prettyprint.custom sequences -sequences.private locals assocs words fry ; -FROM: alien.c-types => float ; -QUALIFIED-WITH: math m +USING: alien.c-types combinators fry kernel parser math math.parser +math.vectors.simd.functor sequences splitting vocabs.generated +vocabs.loader vocabs.parser words accessors vocabs compiler.units +definitions ; +QUALIFIED-WITH: alien.c-types c IN: math.vectors.simd -<< - -DEFER: float-4 -DEFER: double-2 -DEFER: float-8 -DEFER: double-4 - -"double" define-simd-128 -"float" define-simd-128 -"double" define-simd-256 -"float" define-simd-256 - ->> - -: float-4-with ( x -- simd-array ) - [ 4 ] dip >float '[ _ ] \ float-4 new replicate-as ; - -: float-4-boa ( a b c d -- simd-array ) - \ float-4 new 4sequence ; - -: double-2-with ( x -- simd-array ) - [ 2 ] dip >float '[ _ ] \ double-2 new replicate-as ; - -: double-2-boa ( a b -- simd-array ) - \ double-2 new 2sequence ; - -! More efficient expansions for the above, used when SIMD is -! actually available. - -<< - -\ float-4-with [ - drop - \ (simd-broadcast) "intrinsic" word-prop [ - [ >float float-4-rep (simd-broadcast) \ float-4 boa ] - ] [ \ float-4-with def>> ] if -] "custom-inlining" set-word-prop - -\ float-4-boa [ - drop - \ (simd-gather-4) "intrinsic" word-prop [ - [| a b c d | - a >float b >float c >float d >float - float-4-rep (simd-gather-4) \ float-4 boa - ] - ] [ \ float-4-boa def>> ] if -] "custom-inlining" set-word-prop - -\ double-2-with [ - drop - \ (simd-broadcast) "intrinsic" word-prop [ - [ >float double-2-rep (simd-broadcast) \ double-2 boa ] - ] [ \ double-2-with def>> ] if -] "custom-inlining" set-word-prop - -\ double-2-boa [ - drop - \ (simd-gather-4) "intrinsic" word-prop [ - [ [ >float ] bi@ double-2-rep (simd-gather-2) \ double-2 boa ] - ] [ \ double-2-boa def>> ] if -] "custom-inlining" set-word-prop - ->> - -: float-8-with ( x -- simd-array ) - [ float-4-with ] [ float-4-with ] bi [ underlying>> ] bi@ - \ float-8 boa ; inline - -:: float-8-boa ( a b c d e f g h -- simd-array ) - a b c d float-4-boa - e f g h float-4-boa - [ underlying>> ] bi@ - \ float-8 boa ; inline - -: double-4-with ( x -- simd-array ) - [ double-2-with ] [ double-2-with ] bi [ underlying>> ] bi@ - \ double-4 boa ; inline - -:: double-4-boa ( a b c d -- simd-array ) - a b double-2-boa - c d double-2-boa - [ underlying>> ] bi@ - \ double-4 boa ; inline - -<< +ERROR: bad-base-type type ; <PRIVATE -! Filter out operations that are not available, eg horizontal adds -! on SSE2. Fallback code in math.vectors is used in that case. - -: supported-simd-ops ( assoc -- assoc' ) - { - { v+ (simd-v+) } - { v- (simd-v-) } - { v* (simd-v*) } - { v/ (simd-v/) } - { vmin (simd-vmin) } - { vmax (simd-vmax) } - { sum (simd-sum) } - } [ nip "intrinsic" word-prop ] assoc-filter - '[ drop _ key? ] assoc-filter ; - -! Some SIMD operations are defined in terms of others. +: simd-vocab ( base-type -- vocab ) + name>> "math.vectors.simd.instances." prepend ; -:: high-level-ops ( ctor -- assoc ) - { - { vneg [ [ dup v- ] keep v- ] } - { v. [ v* sum ] } - { n+v [ [ ctor execute ] dip v+ ] } - { v+n [ ctor execute v+ ] } - { n-v [ [ ctor execute ] dip v- ] } - { v-n [ ctor execute v- ] } - { n*v [ [ ctor execute ] dip v* ] } - { v*n [ ctor execute v* ] } - { n/v [ [ ctor execute ] dip v/ ] } - { v/n [ ctor execute v/ ] } - { norm-sq [ dup v. assert-positive ] } - { norm [ norm-sq sqrt ] } - { normalize [ dup norm v/n ] } - { distance [ v- norm ] } - } ; +: parse-base-type ( c-type -- c-type ) + dup { c:char c:uchar c:short c:ushort c:int c:uint c:longlong c:ulonglong c:float c:double } memq? + [ bad-base-type ] unless ; -:: simd-vector-words ( class ctor elt-type assoc -- ) - class elt-type assoc supported-simd-ops ctor high-level-ops assoc-union - specialize-vector-words ; +: forget-instances ( -- ) + [ + "math.vectors.simd.instances" child-vocabs + [ forget-vocab ] each + ] with-compilation-unit ; PRIVATE> -\ float-4 \ float-4-with m:float H{ - { v+ [ [ (simd-v+) ] float-4-vv->v-op ] } - { v- [ [ (simd-v-) ] float-4-vv->v-op ] } - { v* [ [ (simd-v*) ] float-4-vv->v-op ] } - { v/ [ [ (simd-v/) ] float-4-vv->v-op ] } - { vmin [ [ (simd-vmin) ] float-4-vv->v-op ] } - { vmax [ [ (simd-vmax) ] float-4-vv->v-op ] } - { sum [ [ (simd-sum) ] float-4-v->n-op ] } -} simd-vector-words - -\ double-2 \ double-2-with m:float H{ - { v+ [ [ (simd-v+) ] double-2-vv->v-op ] } - { v- [ [ (simd-v-) ] double-2-vv->v-op ] } - { v* [ [ (simd-v*) ] double-2-vv->v-op ] } - { v/ [ [ (simd-v/) ] double-2-vv->v-op ] } - { vmin [ [ (simd-vmin) ] double-2-vv->v-op ] } - { vmax [ [ (simd-vmax) ] double-2-vv->v-op ] } - { sum [ [ (simd-sum) ] double-2-v->n-op ] } -} simd-vector-words - -\ float-8 \ float-8-with m:float H{ - { v+ [ [ (simd-v+) ] float-8-vv->v-op ] } - { v- [ [ (simd-v-) ] float-8-vv->v-op ] } - { v* [ [ (simd-v*) ] float-8-vv->v-op ] } - { v/ [ [ (simd-v/) ] float-8-vv->v-op ] } - { vmin [ [ (simd-vmin) ] float-8-vv->v-op ] } - { vmax [ [ (simd-vmax) ] float-8-vv->v-op ] } - { sum [ [ (simd-sum) ] [ + ] float-8-v->n-op ] } -} simd-vector-words - -\ double-4 \ double-4-with m:float H{ - { v+ [ [ (simd-v+) ] double-4-vv->v-op ] } - { v- [ [ (simd-v-) ] double-4-vv->v-op ] } - { v* [ [ (simd-v*) ] double-4-vv->v-op ] } - { v/ [ [ (simd-v/) ] double-4-vv->v-op ] } - { vmin [ [ (simd-vmin) ] double-4-vv->v-op ] } - { vmax [ [ (simd-vmax) ] double-4-vv->v-op ] } - { sum [ [ (simd-v+) ] [ (simd-sum) ] double-4-v->n-op ] } -} simd-vector-words +: define-simd-vocab ( type -- vocab ) + parse-base-type + [ simd-vocab ] keep '[ + _ + [ define-simd-128 ] + [ define-simd-256 ] bi + ] generate-vocab ; ->> +SYNTAX: SIMD: + scan-word define-simd-vocab use-vocab ; -USE: vocabs.loader +SYNTAX: SIMDS: + \ ; parse-until [ define-simd-vocab use-vocab ] each ; -"math.vectors.simd.alien" require diff --git a/basis/math/vectors/simd/summary.txt b/basis/math/vectors/simd/summary.txt new file mode 100644 index 0000000000..22593f1286 --- /dev/null +++ b/basis/math/vectors/simd/summary.txt @@ -0,0 +1 @@ +Single-instruction-multiple-data parallel vector operations diff --git a/basis/math/vectors/specialization/specialization-tests.factor b/basis/math/vectors/specialization/specialization-tests.factor index f9f241bb6f..f4d4fd93e8 100644 --- a/basis/math/vectors/specialization/specialization-tests.factor +++ b/basis/math/vectors/specialization/specialization-tests.factor @@ -1,9 +1,11 @@ IN: math.vectors.specialization.tests USING: compiler.tree.debugger math.vectors tools.test kernel kernel.private math specialized-arrays ; -SPECIALIZED-ARRAY: double -SPECIALIZED-ARRAY: complex-float -SPECIALIZED-ARRAY: float +QUALIFIED-WITH: alien.c-types c +QUALIFIED-WITH: alien.complex c +SPECIALIZED-ARRAY: c:double +SPECIALIZED-ARRAY: c:complex-float +SPECIALIZED-ARRAY: c:float [ V{ t } ] [ [ { double-array double-array } declare distance 0.0 < not ] final-literals @@ -13,10 +15,14 @@ SPECIALIZED-ARRAY: float [ { float-array float } declare v*n norm ] final-classes ] unit-test -[ V{ number } ] [ +[ V{ complex } ] [ [ { complex-float-array complex-float-array } declare v. ] final-classes ] unit-test -[ V{ real } ] [ +[ V{ float } ] [ + [ { float-array float } declare v*n norm ] final-classes +] unit-test + +[ V{ float } ] [ [ { complex-float-array complex } declare v*n norm ] final-classes ] unit-test \ No newline at end of file diff --git a/basis/math/vectors/specialization/specialization.factor b/basis/math/vectors/specialization/specialization.factor index 21ec9f64f3..e51d8c4553 100644 --- a/basis/math/vectors/specialization/specialization.factor +++ b/basis/math/vectors/specialization/specialization.factor @@ -1,12 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types words kernel make sequences effects -kernel.private accessors combinators math math.intervals -math.vectors namespaces assocs fry splitting classes.algebra -generalizations locals compiler.tree.propagation.info ; +USING: words kernel make sequences effects sets kernel.private +accessors combinators math math.intervals math.vectors +math.vectors.conversion.backend +namespaces assocs fry splitting classes.algebra generalizations +locals compiler.tree.propagation.info ; IN: math.vectors.specialization -SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ; +SYMBOLS: -> +vector+ +scalar+ +nonnegative+ +literal+ ; : signature-for-schema ( array-type elt-type schema -- signature ) [ @@ -14,6 +15,7 @@ SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ; { +vector+ [ drop ] } { +scalar+ [ nip ] } { +nonnegative+ [ nip ] } + { +literal+ [ 2drop f ] } } case ] with with map ; @@ -30,7 +32,14 @@ SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ; { { +vector+ [ drop <class-info> ] } { +scalar+ [ nip <class-info> ] } - { +nonnegative+ [ nip real class-and [0,inf] <class/interval-info> ] } + { + +nonnegative+ + [ + nip + dup complex class<= [ drop float ] when + [0,inf] <class/interval-info> + ] + } } case ] with with map ; @@ -53,10 +62,15 @@ H{ { norm-sq { +vector+ -> +nonnegative+ } } { normalize { +vector+ -> +vector+ } } { v* { +vector+ +vector+ -> +vector+ } } + { vs* { +vector+ +vector+ -> +vector+ } } { v*n { +vector+ +scalar+ -> +vector+ } } { v+ { +vector+ +vector+ -> +vector+ } } + { vs+ { +vector+ +vector+ -> +vector+ } } + { v+- { +vector+ +vector+ -> +vector+ } } { v+n { +vector+ +scalar+ -> +vector+ } } { v- { +vector+ +vector+ -> +vector+ } } + { vneg { +vector+ -> +vector+ } } + { vs- { +vector+ +vector+ -> +vector+ } } { v-n { +vector+ +scalar+ -> +vector+ } } { v. { +vector+ +vector+ -> +scalar+ } } { v/ { +vector+ +vector+ -> +vector+ } } @@ -68,6 +82,42 @@ H{ { vneg { +vector+ -> +vector+ } } { vtruncate { +vector+ -> +vector+ } } { sum { +vector+ -> +scalar+ } } + { vabs { +vector+ -> +vector+ } } + { vsqrt { +vector+ -> +vector+ } } + { vbitand { +vector+ +vector+ -> +vector+ } } + { vbitandn { +vector+ +vector+ -> +vector+ } } + { vbitor { +vector+ +vector+ -> +vector+ } } + { vbitxor { +vector+ +vector+ -> +vector+ } } + { vbitnot { +vector+ -> +vector+ } } + { vand { +vector+ +vector+ -> +vector+ } } + { vandn { +vector+ +vector+ -> +vector+ } } + { vor { +vector+ +vector+ -> +vector+ } } + { vxor { +vector+ +vector+ -> +vector+ } } + { vnot { +vector+ -> +vector+ } } + { vlshift { +vector+ +scalar+ -> +vector+ } } + { vrshift { +vector+ +scalar+ -> +vector+ } } + { hlshift { +vector+ +literal+ -> +vector+ } } + { hrshift { +vector+ +literal+ -> +vector+ } } + { vshuffle-elements { +vector+ +literal+ -> +vector+ } } + { vshuffle-bytes { +vector+ +vector+ -> +vector+ } } + { vbroadcast { +vector+ +literal+ -> +vector+ } } + { (vmerge-head) { +vector+ +vector+ -> +vector+ } } + { (vmerge-tail) { +vector+ +vector+ -> +vector+ } } + { (v>float) { +vector+ +literal+ -> +vector+ } } + { (v>integer) { +vector+ +literal+ -> +vector+ } } + { (vpack-signed) { +vector+ +vector+ +literal+ -> +vector+ } } + { (vpack-unsigned) { +vector+ +vector+ +literal+ -> +vector+ } } + { (vunpack-head) { +vector+ +literal+ -> +vector+ } } + { (vunpack-tail) { +vector+ +literal+ -> +vector+ } } + { v<= { +vector+ +vector+ -> +vector+ } } + { v< { +vector+ +vector+ -> +vector+ } } + { v= { +vector+ +vector+ -> +vector+ } } + { v> { +vector+ +vector+ -> +vector+ } } + { v>= { +vector+ +vector+ -> +vector+ } } + { vunordered? { +vector+ +vector+ -> +vector+ } } + { vany? { +vector+ -> +scalar+ } } + { vall? { +vector+ -> +scalar+ } } + { vnone? { +vector+ -> +scalar+ } } } PREDICATE: vector-word < word vector-words key? ; @@ -81,7 +131,10 @@ M: vector-word subwords specializations values [ word? ] filter ; : add-specialization ( new-word signature word -- ) specializations set-at ; -: word-schema ( word -- schema ) vector-words at ; +ERROR: bad-vector-word word ; + +: word-schema ( word -- schema ) + vector-words ?at [ bad-vector-word ] unless ; : inputs ( schema -- seq ) { -> } split first ; @@ -98,26 +151,46 @@ M: vector-word subwords specializations values [ word? ] filter ; :: input-signature ( word array-type elt-type -- signature ) array-type elt-type word word-schema inputs signature-for-schema ; +: vector-words-for-type ( elt-type -- words ) + { + ! Can't do shifts on floats + { [ dup float class<= ] [ vector-words keys { vlshift vrshift } diff ] } + ! Can't divide integers + { [ dup integer class<= ] [ vector-words keys { vsqrt n/v v/n v/ normalize } diff ] } + ! Can't compute square root of complex numbers (vsqrt uses fsqrt not sqrt) + { [ dup complex class<= ] [ vector-words keys { vsqrt } diff ] } + [ { } ] + } cond + ! Don't specialize horizontal shifts, shuffles, and conversions at all, they're only for SIMD + { + hlshift hrshift vshuffle-elements vshuffle-bytes vbroadcast + (v>integer) (v>float) + (vpack-signed) (vpack-unsigned) + (vunpack-head) (vunpack-tail) + } diff + nip ; + :: specialize-vector-words ( array-type elt-type simd -- ) - elt-type number class<= [ - vector-words keys [ - [ array-type elt-type simd specialize-vector-word ] - [ array-type elt-type input-signature ] - [ ] - tri add-specialization - ] each - ] when ; + elt-type vector-words-for-type simd keys union [ + [ array-type elt-type simd specialize-vector-word ] + [ array-type elt-type input-signature ] + [ ] + tri add-specialization + ] each ; + +: specialization-matches? ( value-infos signature -- ? ) + [ [ [ class>> ] dip class<= ] [ literal?>> ] if* ] 2all? ; : find-specialization ( classes word -- word/f ) specializations - [ first [ class<= ] 2all? ] with find + [ first specialization-matches? ] with find swap [ second ] when ; : vector-word-custom-inlining ( #call -- word/f ) - [ in-d>> [ value-info class>> ] map ] [ word>> ] bi + [ in-d>> [ value-info ] map ] [ word>> ] bi find-specialization ; vector-words keys [ [ vector-word-custom-inlining ] "custom-inlining" set-word-prop -] each \ No newline at end of file +] each diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor index 7456597278..7a9aff49b6 100644 --- a/basis/math/vectors/vectors-docs.factor +++ b/basis/math/vectors/vectors-docs.factor @@ -1,31 +1,188 @@ -USING: help.markup help.syntax math sequences ; +USING: help.markup help.syntax math math.functions sequences ; IN: math.vectors -ARTICLE: "math-vectors" "Vector arithmetic" -"Any Factor sequence can be used to represent a mathematical vector, however for best performance, the sequences defined by the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "math.vectors.simd" } " vocabularies should be used." -$nl -"Acting on vectors by a scalar:" -{ $subsection vneg } -{ $subsection v*n } -{ $subsection n*v } -{ $subsection v/n } -{ $subsection n/v } -{ $subsection v+n } -{ $subsection n+v } -{ $subsection v-n } -{ $subsection n-v } -"Combining two vectors to form another vector with " { $link 2map } ":" -{ $subsection v+ } -{ $subsection v- } -{ $subsection v* } -{ $subsection v/ } -{ $subsection vmax } -{ $subsection vmin } +ARTICLE: "math-vectors-arithmetic" "Vector arithmetic" +"Vector/vector binary operations:" +{ $subsections + v+ + v- + v+- + v* + v/ +} +"Vector unary operations:" +{ $subsections + vneg + vabs + vsqrt + vfloor + vceiling + vtruncate +} +"Vector/scalar and scalar/vector binary operations:" +{ $subsections + vneg + v*n + n*v + v/n + n/v + v+n + n+v + v-n + n-v +} +"Saturated arithmetic (only on " { $link "specialized-arrays" } "):" +{ $subsections + vs+ + vs- + vs* +} "Inner product and norm:" -{ $subsection v. } -{ $subsection norm } -{ $subsection norm-sq } -{ $subsection normalize } ; +{ $subsections + v. + norm + norm-sq + normalize +} +"Comparing entire vectors:" +{ $subsections + distance + v~ +} ; + +ARTICLE: "math-vectors-shuffle" "Vector shuffling, packing, and unpacking" +{ $notes +"These operations are primarily meant to be used with " { $vocab-link "math.vectors.simd" } " types. The software fallbacks for types not supported by hardware will not perform well." +} +$nl +{ $subsection vshuffle } +{ $subsection vbroadcast } +{ $subsection hlshift } +{ $subsection hrshift } +{ $subsection vmerge } +{ $subsection (vmerge) } ; + +ARTICLE: "math-vectors-logic" "Vector component- and bit-wise logic" +{ $notes +"See " { $link "math-vectors-simd-logic" } " for notes about using comparison and logical operations with SIMD vector types." +} +$nl +"Element comparisons:" +{ $subsections + v< + v<= + v= + v>= + v> + vunordered? + vmax + vmin + vsupremum + vinfimum +} +"Bitwise operations:" +{ $subsections + vbitand + vbitandn + vbitor + vbitxor + vbitnot + vlshift + vrshift +} +"Element logical operations:" +{ $subsections + vand + vandn + vor + vxor + vnot + v? +} +"Entire vector tests:" +{ $subsections + vall? + vany? + vnone? +} +"Element shuffling:" +{ $subsections vshuffle } ; + +ARTICLE: "math-vectors-misc" "Miscellaneous vector functions" +{ $subsections + trilerp + bilerp + vlerp + vnlerp + vbilerp +} ; + +ARTICLE: "math-vectors-simd-logic" "Componentwise logic with SIMD vectors" +"Processor SIMD units supported by the " { $vocab-link "math.vectors.simd" } " vocabulary represent boolean values as bitmasks, where a true result's binary representation is all ones and a false representation is all zeroes. This is the format in which results from comparison words such as " { $link v= } " return their results and in which logic and test words such as " { $link vand } " and " { $link vall? } " take their inputs when working with SIMD types. For a float vector, false will manifest itself as " { $snippet "0.0" } " and true as a " { $link POSTPONE: NAN: } " literal with a string of set bits in its payload:" +{ $example +"""USING: math.vectors math.vectors.simd prettyprint ; +FROM: alien.c-types => float ; +SIMD: float + +float-4{ 1.0 2.0 3.0 0/0. } float-4{ 1.0 -2.0 3.0 0/0. } v= .""" +"""float-4{ NAN: fffffe0000000 0.0 NAN: fffffe0000000 0.0 }""" +} +"For an integer vector, false will manifest as " { $snippet "0" } " and true as " { $snippet "-1" } " (for signed vectors) or the largest representable value of the element type (for unsigned vectors):" +{ $example +"""USING: math.vectors math.vectors.simd prettyprint alien.c-types ; +SIMD: int +SIMD: uchar + +int-4{ 1 2 3 0 } int-4{ 1 -2 3 4 } v= +uchar-16{ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 } +uchar-16{ 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 } v< +[ . ] bi@""" +"""int-4{ -1 0 -1 0 } +uchar-16{ 255 255 255 255 255 255 255 255 0 0 0 0 0 0 0 0 }""" +} +"This differs from Factor's native representation of boolean values, where " { $link f } " is false and every other value (including " { $snippet "0" } " and " { $snippet "0.0" } ") is true. To make it easy to construct literal SIMD masks, " { $link t } " and " { $link f } " are accepted inside SIMD literal syntax and expand to the proper true or false representation for the underlying type:" +{ $example +"""USING: math.vectors math.vectors.simd prettyprint alien.c-types ; +SIMD: int + +int-4{ f f t f } .""" +"""int-4{ 0 0 -1 0 }""" } +"However, extracting an element from a boolean SIMD vector with " { $link nth } " will not yield a valid Factor boolean. This is not generally a problem, since the results of vector comparisons are meant to be consumed by subsequent vector logical and test operations, which will accept SIMD values in the native boolean format." +$nl +"Providing a SIMD boolean vector with element values other than the proper true and false representations as an input to the vector logical or test operations is undefined. Do not count on operations such as " { $link vall? } " or " { $link v? } " using bitwise operations to construct their results." +$nl +"This applies to the output of the following element comparison words: " +{ $list +{ $link v< } +{ $link v<= } +{ $link v= } +{ $link v>= } +{ $link v> } +{ $link vunordered? } +} +"This likewise applies to the " { $snippet "mask" } " argument of " { $link v? } " and to the inputs and outputs of the following element logic words:" +{ $list +{ $link vand } +{ $link vandn } +{ $link vor } +{ $link vxor } +{ $link vnot } +} +"Finally, this applies to the inputs of these vector test words:" +{ $list +{ $link vall? } +{ $link vany? } +{ $link vnone? } +} ; + +ARTICLE: "math-vectors" "Vector operations" +"Any Factor sequence can be used to represent a mathematical vector, however for best performance, the sequences defined by the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "math.vectors.simd" } " vocabularies should be used." +{ $subsections + "math-vectors-arithmetic" + "math-vectors-logic" + "math-vectors-shuffle" + "math-vectors-misc" +} ; ABOUT: "math-vectors" @@ -33,6 +190,43 @@ HELP: vneg { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } { $description "Negates each element of " { $snippet "u" } "." } ; +HELP: vabs +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of non-negative real numbers" } } +{ $description "Takes the absolute value of each element of " { $snippet "u" } "." } ; + +HELP: vsqrt +{ $values { "u" "a sequence of non-negative real numbers" } { "v" "a sequence of non-negative real numbers" } } +{ $description "Takes the square root of each element of " { $snippet "u" } "." } +{ $warning "For performance reasons, this does not work with negative inputs, unlike " { $link sqrt } "." } ; + +HELP: vfloor +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } } +{ $description "Takes the " { $link floor } " of each element of " { $snippet "u" } "." } ; + +HELP: vceiling +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } } +{ $description "Takes the " { $link ceiling } " of each element of " { $snippet "u" } "." } ; + +HELP: vtruncate +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } } +{ $description "Truncates each element of " { $snippet "u" } "." } ; + +HELP: n+v +{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } +{ $description "Adds " { $snippet "n" } " to each element of " { $snippet "u" } "." } ; + +HELP: v+n +{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } } +{ $description "Adds " { $snippet "n" } " to each element of " { $snippet "u" } "." } ; + +HELP: n-v +{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } +{ $description "Subtracts each element of " { $snippet "u" } " from " { $snippet "n" } "." } ; + +HELP: v-n +{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } } +{ $description "Subtracts " { $snippet "n" } " from each element of " { $snippet "u" } "." } ; + HELP: n*v { $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } { $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ; @@ -43,11 +237,13 @@ HELP: v*n HELP: n/v { $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } -{ $description "Divides " { $snippet "n" } " by each element of " { $snippet "u" } "." } ; +{ $description "Divides " { $snippet "n" } " by each element of " { $snippet "u" } "." } +{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ; HELP: v/n { $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } } -{ $description "Divides each element of " { $snippet "u" } " by " { $snippet "n" } "." } ; +{ $description "Divides each element of " { $snippet "u" } " by " { $snippet "n" } "." } +{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ; HELP: v+ { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } @@ -57,6 +253,17 @@ HELP: v- { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } { $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise." } ; +HELP: v+- +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Adds and subtracts alternate elements of " { $snippet "v" } " and " { $snippet "u" } " component-wise." } +{ $examples + { $example + "USING: math.vectors prettyprint ;" + "{ 1 2 3 } { 2 3 2 } v+- ." + "{ -1 5 1 }" + } +} ; + HELP: [v-] { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } { $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise; any components which become negative are set to zero." } ; @@ -68,24 +275,156 @@ HELP: v* HELP: v/ { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } { $description "Divides " { $snippet "u" } " by " { $snippet "v" } " component-wise." } -{ $errors "Throws an error if an integer division by zero occurs." } ; +{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ; HELP: vmax { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } -{ $description "Creates a sequence where each element is the maximum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." } +{ $description "Creates a sequence where each element is the maximum of the corresponding elements from " { $snippet "u" } " and " { $snippet "v" } "." } { $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmax ." "{ 1 6 5 }" } } ; HELP: vmin { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } -{ $description "Creates a sequence where each element is the minimum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." } +{ $description "Creates a sequence where each element is the minimum of the corresponding elements from " { $snippet "u" } " and " { $snippet "v" } "." } { $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmin ." "{ -7 2 3 }" } } ; HELP: v. { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "x" "a real number" } } -{ $description "Computes the real-valued dot product." } -{ $notes - "This word can also take complex number sequences as input, however mathematically it will compute the wrong result. The complex-valued dot product is defined differently:" - { $snippet "0 [ conjugate * + ] 2reduce" } +{ $description "Computes the dot product of two vectors." } ; + +HELP: vs+ +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Adds " { $snippet "u" } " and " { $snippet "v" } " component-wise with saturation." } +{ $examples + "With saturation:" + { $example + "USING: alien.c-types math.vectors prettyprint specialized-arrays ;" + "SPECIALIZED-ARRAY: uchar" + "uchar-array{ 100 200 150 } uchar-array{ 70 70 70 } vs+ ." + "uchar-array{ 170 255 220 }" + } + "Without saturation:" + { $example + "USING: alien.c-types math.vectors prettyprint specialized-arrays ;" + "SPECIALIZED-ARRAY: uchar" + "uchar-array{ 100 200 150 } uchar-array{ 70 70 70 } v+ ." + "uchar-array{ 170 14 220 }" + } +} ; + +HELP: vs- +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise with saturation." } ; + +HELP: vs* +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Multiplies " { $snippet "u" } " and " { $snippet "v" } " component-wise with saturation." } ; + +HELP: vbitand +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } +{ $description "Takes the bitwise and of " { $snippet "u" } " and " { $snippet "v" } " component-wise." } +{ $notes "Unlike " { $link bitand } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ; + +HELP: vbitandn +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } +{ $description "Takes the bitwise and-not of " { $snippet "u" } " and " { $snippet "v" } " component-wise, where " { $snippet "x and-not y" } " is defined as " { $snippet "not(x) and y" } "." } +{ $notes "This word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ; + +HELP: vbitor +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } +{ $description "Takes the bitwise or of " { $snippet "u" } " and " { $snippet "v" } " component-wise." } +{ $notes "Unlike " { $link bitor } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ; + +HELP: vbitxor +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } +{ $description "Takes the bitwise exclusive or of " { $snippet "u" } " and " { $snippet "v" } " component-wise." } +{ $notes "Unlike " { $link bitxor } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ; + +HELP: vlshift +{ $values { "u" "a sequence of integers" } { "n" "a non-negative integer" } { "w" "a sequence of integers" } } +{ $description "Shifts each element of " { $snippet "u" } " to the left by " { $snippet "n" } " bits." } +{ $notes "Undefined behavior will result if " { $snippet "n" } " is negative." } ; + +HELP: vrshift +{ $values { "u" "a sequence of integers" } { "n" "a non-negative integer" } { "w" "a sequence of integers" } } +{ $description "Shifts each element of " { $snippet "u" } " to the right by " { $snippet "n" } " bits." } +{ $notes "Undefined behavior will result if " { $snippet "n" } " is negative." } ; + +HELP: hlshift +{ $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "w" "a SIMD array" } } +{ $description "Shifts the entire SIMD array to the left by " { $snippet "n" } " bytes, filling the vacated right-hand bits with zeroes. This word may only be used in a context where the compiler can statically infer that the input is a SIMD array." } ; + +HELP: hrshift +{ $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "w" "a SIMD array" } } +{ $description "Shifts the entire SIMD array to the right by " { $snippet "n" } " bytes, filling the vacated left-hand bits with zeroes. This word may only be used in a context where the compiler can statically infer that the input is a SIMD array." } ; + +HELP: vmerge +{ $values { "u" "a sequence" } { "v" "a sequence" } { "w" "a sequence" } } +{ $description "Creates a new sequence of the same type as and twice the length of " { $snippet "u" } " and " { $snippet "v" } " by interleaving the elements of " { $snippet "u" } " and " { $snippet "v" } "." } +{ $examples +{ $example """USING: kernel math.vectors prettyprint ; + +{ "A" "B" "C" "D" } { "1" "2" "3" "4" } vmerge .""" +"""{ "A" "1" "B" "2" "C" "3" "D" "4" }""" +} } ; + +HELP: (vmerge) +{ $values { "u" "a sequence" } { "v" "a sequence" } { "h" "a sequence" } { "t" "a sequence" } } +{ $description "Creates two new sequences of the same type and size as " { $snippet "u" } " and " { $snippet "v" } " by interleaving the elements of " { $snippet "u" } " and " { $snippet "v" } "." } +{ $notes "For hardware-supported SIMD vector types this word compiles to a single instruction per output value." } +{ $examples +{ $example """USING: kernel math.vectors prettyprint ; + +{ "A" "B" "C" "D" } { "1" "2" "3" "4" } (vmerge) [ . ] bi@""" +"""{ "A" "1" "B" "2" } +{ "C" "3" "D" "4" }""" +} } ; + +HELP: (vmerge-head) +{ $values { "u" "a sequence" } { "v" "a sequence" } { "h" "a sequence" } } +{ $description "Creates a new sequence of the same type and size as " { $snippet "u" } " and " { $snippet "v" } " by interleaving the elements from the first half of " { $snippet "u" } " and " { $snippet "v" } "." } +{ $notes "For hardware-supported SIMD vector types this word compiles to a single instruction." } +{ $examples +{ $example """USING: kernel math.vectors prettyprint ; + +{ "A" "B" "C" "D" } { "1" "2" "3" "4" } (vmerge-head) .""" +"""{ "A" "1" "B" "2" }""" +} } ; + +HELP: (vmerge-tail) +{ $values { "u" "a sequence" } { "v" "a sequence" } { "t" "a sequence" } } +{ $description "Creates a new sequence of the same type and size as " { $snippet "u" } " and " { $snippet "v" } " by interleaving the elements from the tail half of " { $snippet "u" } " and " { $snippet "v" } "." } +{ $notes "For hardware-supported SIMD vector types this word compiles to a single instruction." } +{ $examples +{ $example """USING: kernel math.vectors prettyprint ; + +{ "A" "B" "C" "D" } { "1" "2" "3" "4" } (vmerge-tail) .""" +"""{ "C" "3" "D" "4" }""" +} } ; + +{ vmerge (vmerge) (vmerge-head) (vmerge-tail) } related-words + +HELP: vbroadcast +{ $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "v" "a SIMD array" } } +{ $description "Outputs a new SIMD array of the same type as " { $snippet "u" } " where every element is equal to the " { $snippet "n" } "th element of " { $snippet "u" } "." } +{ $examples + { $example + "USING: alien.c-types math.vectors math.vectors.simd" "prettyprint ;" + "SIMD: int" + "int-4{ 69 42 911 13 } 2 vbroadcast ." + "int-4{ 911 911 911 911 }" + } +} ; + +HELP: vshuffle +{ $values { "u" "a SIMD array" } { "perm" "an array of integers" } { "v" "a SIMD array" } } +{ $description "Permutes the elements of a SIMD array. Duplicate entries are allowed in the permutation." } +{ $examples + { $example + "USING: alien.c-types math.vectors math.vectors.simd" "prettyprint ;" + "SIMD: int" + "int-4{ 69 42 911 13 } { 1 3 2 3 } vshuffle ." + "int-4{ 42 13 911 13 }" + } } ; HELP: norm-sq @@ -100,11 +439,96 @@ HELP: normalize { $values { "u" "a sequence of numbers, not all zero" } { "v" "a sequence of numbers" } } { $description "Outputs a vector with the same direction as " { $snippet "u" } " but length 1." } ; +HELP: distance +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "x" "a non-negative real number" } } +{ $description "Outputs the Euclidean distance between two vectors." } ; + HELP: set-axis { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "axis" "a sequence of 0/1" } { "w" "a sequence of numbers" } } { $description "Using " { $snippet "w" } " as a template, creates a new sequence containing corresponding elements from " { $snippet "u" } " in place of 0, and corresponding elements from " { $snippet "v" } " in place of 1." } { $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 3 } { 4 5 6 } { 0 1 0 } set-axis ." "{ 1 5 3 }" } } ; +HELP: v< +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } } +{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when the former is less than the latter or " { $link f } " otherwise." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean results when using SIMD types." } ; + +HELP: v<= +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } } +{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when the former is less than or equal to the latter or " { $link f } " otherwise." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean results when using SIMD types." } ; + +HELP: v= +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } } +{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when they are equal or " { $link f } " otherwise." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean results when using SIMD types." } ; + +HELP: v> +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } } +{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when the former is greater than the latter or " { $link f } " otherwise." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean results when using SIMD types." } ; + +HELP: v>= +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } } +{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when the former is greater than or equal to the latter or " { $link f } " otherwise." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean results when using SIMD types." } ; + +HELP: vunordered? +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } } +{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when either value is Not-a-Number or " { $link f } " otherwise." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean results when using SIMD types." } ; + +HELP: vand +{ $values { "u" "a sequence of booleans" } { "v" "a sequence of booleans" } { "w" "a sequence of booleans" } } +{ $description "Takes the logical AND of each corresponding element of " { $snippet "u" } " and " { $snippet "v" } "." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ; + +HELP: vandn +{ $values { "u" "a sequence of booleans" } { "v" "a sequence of booleans" } { "w" "a sequence of booleans" } } +{ $description "Takes the logical AND-NOT of each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", where " { $snippet "x AND-NOT y" } " is defined as " { $snippet "NOT(x) AND y" } "." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ; + +HELP: vor +{ $values { "u" "a sequence of booleans" } { "v" "a sequence of booleans" } { "w" "a sequence of booleans" } } +{ $description "Takes the logical OR of each corresponding element of " { $snippet "u" } " and " { $snippet "v" } "." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ; + +HELP: vxor +{ $values { "u" "a sequence of booleans" } { "v" "a sequence of booleans" } { "w" "a sequence of booleans" } } +{ $description "Takes the logical XOR of each corresponding element of " { $snippet "u" } " and " { $snippet "v" } "." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ; + +HELP: vnot +{ $values { "u" "a sequence of booleans" } { "w" "a sequence of booleans" } } +{ $description "Takes the logical NOT of each element of " { $snippet "u" } "." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ; + +HELP: v? +{ $values { "mask" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Creates a new sequence by selecting elements from the " { $snippet "true" } " and " { $snippet "false" } " sequences based on whether the corresponding bits of the " { $snippet "mask" } " sequence are set or not." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ; + +HELP: vany? +{ $values { "v" "a sequence of booleans" } { "?" "a boolean" } } +{ $description "Returns true if any element of " { $snippet "v" } " is true." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs when using SIMD types." } ; + +HELP: vall? +{ $values { "v" "a sequence of booleans" } { "?" "a boolean" } } +{ $description "Returns true if every element of " { $snippet "v" } " is true." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs when using SIMD types." } ; + +HELP: vnone? +{ $values { "v" "a sequence of booleans" } { "?" "a boolean" } } +{ $description "Returns true if every element of " { $snippet "v" } " is false." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs when using SIMD types." } ; + { 2map v+ v- v* v/ } related-words { 2reduce v. } related-words + +{ vs+ vs- vs* } related-words + +{ v< v<= v= v> v>= vunordered? vand vor vxor vnot vany? vall? vnone? v? } related-words + +{ vbitand vbitandn vbitor vbitxor vbitnot } related-words diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor index 3e56644d3e..54ffc92481 100644 --- a/basis/math/vectors/vectors-tests.factor +++ b/basis/math/vectors/vectors-tests.factor @@ -1,5 +1,7 @@ IN: math.vectors.tests -USING: math.vectors tools.test ; +USING: math.vectors tools.test kernel specialized-arrays compiler +kernel.private alien.c-types ; +SPECIALIZED-ARRAY: int [ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test [ { 1 2 3 } ] [ { 2 4 6 } 1/2 v*n ] unit-test @@ -17,4 +19,8 @@ USING: math.vectors tools.test ; [ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test -[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test \ No newline at end of file +[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test + +[ { 0 3 2 5 4 } ] [ { 1 2 3 4 5 } { 1 1 1 1 1 } v+- ] unit-test + +[ 1 ] [ { C{ 0 1 } } dup v. ] unit-test diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index dd48525b53..0a984ba2e7 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -1,9 +1,17 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel sequences math math.functions hints -math.order ; +USING: arrays alien.c-types assocs kernel sequences math math.functions +hints math.order math.libm fry combinators byte-arrays accessors +locals ; +QUALIFIED-WITH: alien.c-types c IN: math.vectors +MIXIN: simd-128 +MIXIN: simd-256 + +GENERIC: element-type ( obj -- c-type ) +M: object element-type drop f ; inline + : vneg ( u -- v ) [ neg ] map ; : v+n ( u n -- v ) [ + ] curry map ; @@ -24,14 +32,119 @@ IN: math.vectors : vmax ( u v -- w ) [ max ] 2map ; : vmin ( u v -- w ) [ min ] 2map ; -: vfloor ( v -- _v_ ) [ floor ] map ; -: vceiling ( v -- ^v^ ) [ ceiling ] map ; -: vtruncate ( v -- -v- ) [ truncate ] map ; +: v+- ( u v -- w ) + [ t ] 2dip + [ [ not ] 2dip pick [ + ] [ - ] if ] 2map + nip ; + +<PRIVATE + +: 2saturate-map ( u v quot -- w ) + pick element-type '[ @ _ c-type-clamp ] 2map ; inline + +PRIVATE> + +: vs+ ( u v -- w ) [ + ] 2saturate-map ; +: vs- ( u v -- w ) [ - ] 2saturate-map ; +: vs* ( u v -- w ) [ * ] 2saturate-map ; + +: vabs ( u -- v ) [ abs ] map ; +: vsqrt ( u -- v ) [ >float fsqrt ] map ; + +<PRIVATE + +: fp-bitwise-op ( x y seq quot -- z ) + swap element-type { + { c:double [ [ [ double>bits ] bi@ ] dip call bits>double ] } + { c:float [ [ [ float>bits ] bi@ ] dip call bits>float ] } + [ drop call ] + } case ; inline + +: fp-bitwise-unary ( x seq quot -- z ) + swap element-type { + { c:double [ [ double>bits ] dip call bits>double ] } + { c:float [ [ float>bits ] dip call bits>float ] } + [ drop call ] + } case ; inline + +: element>bool ( x seq -- ? ) + element-type [ [ f ] when-zero ] when ; inline + +: bitandn ( x y -- z ) [ bitnot ] dip bitand ; inline + +GENERIC: new-underlying ( underlying seq -- seq' ) + +: change-underlying ( seq quot -- seq' ) + '[ underlying>> @ ] keep new-underlying ; inline + +PRIVATE> + +: vbitand ( u v -- w ) over '[ _ [ bitand ] fp-bitwise-op ] 2map ; +: vbitandn ( u v -- w ) over '[ _ [ bitandn ] fp-bitwise-op ] 2map ; +: vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ; +: vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ; +: vbitnot ( u -- w ) dup '[ _ [ bitnot ] fp-bitwise-unary ] map ; + +:: vbroadcast ( u n -- v ) u length n u nth <repetition> u like ; + +: vshuffle-elements ( u perm -- v ) + swap [ '[ _ nth ] ] keep map-as ; + +: vshuffle-bytes ( u perm -- v ) + underlying>> [ + swap [ '[ _ nth ] ] keep map-as + ] curry change-underlying ; + +GENERIC: vshuffle ( u perm -- v ) +M: array vshuffle ( u perm -- v ) + vshuffle-elements ; inline +M: simd-128 vshuffle ( u perm -- v ) + vshuffle-bytes ; inline + +: vlshift ( u n -- w ) '[ _ shift ] map ; +: vrshift ( u n -- w ) neg '[ _ shift ] map ; + +: hlshift ( u n -- w ) '[ _ <byte-array> prepend 16 head ] change-underlying ; +: hrshift ( u n -- w ) '[ _ <byte-array> append 16 tail* ] change-underlying ; + +: (vmerge-head) ( u v -- h ) + over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ; +: (vmerge-tail) ( u v -- t ) + over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ; + +: (vmerge) ( u v -- h t ) + [ (vmerge-head) ] [ (vmerge-tail) ] 2bi ; inline + +: vmerge ( u v -- w ) [ zip ] keep concat-as ; + +: vand ( u v -- w ) over '[ [ _ element>bool ] bi@ and ] 2map ; +: vandn ( u v -- w ) over '[ [ _ element>bool ] bi@ [ not ] dip and ] 2map ; +: vor ( u v -- w ) over '[ [ _ element>bool ] bi@ or ] 2map ; +: vxor ( u v -- w ) over '[ [ _ element>bool ] bi@ xor ] 2map ; +: vnot ( u -- w ) dup '[ _ element>bool not ] map ; + +: vall? ( v -- ? ) dup '[ _ element>bool ] all? ; +: vany? ( v -- ? ) dup '[ _ element>bool ] any? ; +: vnone? ( v -- ? ) dup '[ _ element>bool not ] all? ; + +: v< ( u v -- w ) [ < ] 2map ; +: v<= ( u v -- w ) [ <= ] 2map ; +: v>= ( u v -- w ) [ >= ] 2map ; +: v> ( u v -- w ) [ > ] 2map ; +: vunordered? ( u v -- w ) [ unordered? ] 2map ; +: v= ( u v -- w ) [ = ] 2map ; + +: v? ( mask true false -- w ) + [ vand ] [ vandn ] bi-curry* bi vor ; inline + +: vfloor ( u -- v ) [ floor ] map ; +: vceiling ( u -- v ) [ ceiling ] map ; +: vtruncate ( u -- v ) [ truncate ] map ; : vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; -: v. ( u v -- x ) [ * ] [ + ] 2map-reduce ; +: v. ( u v -- x ) [ conjugate * ] [ + ] 2map-reduce ; : norm-sq ( v -- x ) [ absq ] [ + ] map-reduce ; : norm ( v -- x ) norm-sq sqrt ; : normalize ( u -- v ) dup norm v/n ; diff --git a/basis/memoize/memoize-docs.factor b/basis/memoize/memoize-docs.factor index a551272f43..58ba60af7c 100644 --- a/basis/memoize/memoize-docs.factor +++ b/basis/memoize/memoize-docs.factor @@ -9,22 +9,20 @@ $nl "Memoization is useful in situations where the set of possible inputs is small, but the results are expensive to compute and should be cached. Memoized words should not have any side effects." $nl "Defining a memoized word at parse time:" -{ $subsection POSTPONE: MEMO: } +{ $subsections POSTPONE: MEMO: } "Defining a memoized word at run time:" -{ $subsection define-memoized } +{ $subsections define-memoized } "Clearing memoized results:" -{ $subsection reset-memoized } ; +{ $subsections reset-memoized } ; ABOUT: "memoize" HELP: define-memoized { $values { "word" word } { "quot" quotation } { "effect" effect } } -{ $description "defines the given word at runtime as one which memoizes its output given a particular input" } -{ $notes "A maximum of four input and four output arguments can be used" } -{ $see-also POSTPONE: MEMO: } ; +{ $description "Defines the given word at run time as one which memoizes its outputs given a particular input." } ; HELP: MEMO: { $syntax "MEMO: word ( stack -- effect ) definition ;" } -{ $description "defines the given word at parsetime as one which memoizes its output given a particular input. The stack effect is mandatory." } -{ $notes "A maximum of four input and four output arguments can be used" } -{ $see-also define-memoized } ; +{ $description "Defines the given word at parse time as one which memoizes its output given a particular input. The stack effect is mandatory." } ; + +{ define-memoized POSTPONE: MEMO: } related-words diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 771c11c130..11dfd705c2 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -7,9 +7,18 @@ IN: memoize.tests MEMO: fib ( m -- n ) dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; +MEMO: x ( a b c d e -- f g h i j ) + [ 1 + ] 4 ndip ; + [ 89 ] [ 10 fib ] unit-test -[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1 + ] 4 ndip ;" eval( -- ) ] must-fail +[ + 1 0 0 0 0 + 1 0 0 0 0 +] [ + 0 0 0 0 0 x + 0 0 0 0 0 x +] unit-test MEMO: see-test ( a -- b ) reverse ; diff --git a/basis/memoize/memoize.factor b/basis/memoize/memoize.factor index 74ca07cda3..c949c34684 100644 --- a/basis/memoize/memoize.factor +++ b/basis/memoize/memoize.factor @@ -1,22 +1,36 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel hashtables sequences arrays words namespaces make -parser math assocs effects definitions quotations summary -accessors fry ; +USING: kernel hashtables sequences sequences.private arrays +words namespaces make parser math assocs effects definitions +quotations summary accessors fry ; IN: memoize -ERROR: too-many-arguments ; +<PRIVATE -M: too-many-arguments summary - drop "There must be no more than 4 input and 4 output arguments" ; +! We can't use n*quot, narray and firstn from generalizations because +! they're macros, and macros use memoize! +: (n*quot) ( n quot -- quotquot ) + <repetition> concat >quotation ; -<PRIVATE +: [nsequence] ( length exemplar -- quot ) + [ [ [ 1 - ] keep ] dip '[ _ _ _ new-sequence ] ] + [ drop [ [ set-nth-unsafe ] 2keep [ 1 - ] dip ] (n*quot) ] 2bi + [ nip ] 3append ; + +: [firstn] ( length -- quot ) + [ 0 swap ] swap + [ [ nth-unsafe ] 2keep [ 1 + ] dip ] (n*quot) + [ 2drop ] 3append ; : packer ( seq -- quot ) - length { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ; + length dup 4 <= + [ { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ] + [ { } [nsequence] ] if ; : unpacker ( seq -- quot ) - length { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ; + length dup 4 <= + [ { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ] + [ [firstn] ] if ; : pack/unpack ( quot effect -- newquot ) [ in>> packer ] [ out>> unpacker ] bi surround ; @@ -24,11 +38,7 @@ M: too-many-arguments summary : unpack/pack ( quot effect -- newquot ) [ in>> unpacker ] [ out>> packer ] bi surround ; -: check-memoized ( effect -- ) - [ in>> ] [ out>> ] bi [ length 4 > ] either? [ too-many-arguments ] when ; - : make-memoizer ( table quot effect -- quot ) - [ check-memoized ] keep [ unpack/pack '[ _ _ cache ] ] keep pack/unpack ; @@ -62,4 +72,4 @@ M: memoized reset-word : invalidate-memoized ( inputs... word -- ) [ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ; -\ invalidate-memoized t "no-compile" set-word-prop \ No newline at end of file +\ invalidate-memoized t "no-compile" set-word-prop diff --git a/basis/mime/types/types-docs.factor b/basis/mime/types/types-docs.factor index fc14227e2d..4368207c85 100644 --- a/basis/mime/types/types-docs.factor +++ b/basis/mime/types/types-docs.factor @@ -30,6 +30,6 @@ HELP: nonstandard-mime-types ARTICLE: "mime.types" "MIME types" "The " { $vocab-link "mime.types" } " vocabulary loads a file of MIME types and provides a word to look up the MIME type based on a file extension." $nl "Looking up a MIME type:" -{ $subsection mime-type } ; +{ $subsections mime-type } ; ABOUT: "mime.types" diff --git a/basis/mirrors/mirrors-docs.factor b/basis/mirrors/mirrors-docs.factor index e498919f11..13f0d8bb49 100644 --- a/basis/mirrors/mirrors-docs.factor +++ b/basis/mirrors/mirrors-docs.factor @@ -5,10 +5,12 @@ ARTICLE: "mirrors" "Mirrors" "The " { $vocab-link "mirrors" } " vocabulary defines data types which present an object's slots and slot values as an associative structure. This enables idioms such as iteration over all slots in a tuple, or editing of tuples, sequences and assocs in a generic fashion. This functionality is used by developer tools and meta-programming utilities." $nl "A mirror provides such a view of a tuple:" -{ $subsection mirror } -{ $subsection <mirror> } +{ $subsections + mirror + <mirror> +} "Utility word used by developer tools which inspect objects:" -{ $subsection make-mirror } +{ $subsections make-mirror } { $see-also "slots" } ; ABOUT: "mirrors" diff --git a/basis/mirrors/mirrors.factor b/basis/mirrors/mirrors.factor index 25486d127d..6ec6a9fbb2 100644 --- a/basis/mirrors/mirrors.factor +++ b/basis/mirrors/mirrors.factor @@ -3,7 +3,7 @@ USING: assocs hashtables kernel sequences generic words arrays classes slots slots.private classes.tuple classes.tuple.private math vectors quotations accessors -combinators ; +combinators byte-arrays specialized-arrays ; IN: mirrors TUPLE: mirror { object read-only } ; @@ -48,10 +48,15 @@ M: mirror assoc-size object>> layout-of second ; INSTANCE: mirror assoc +MIXIN: enumerated-sequence +INSTANCE: array enumerated-sequence +INSTANCE: vector enumerated-sequence +INSTANCE: callable enumerated-sequence +INSTANCE: byte-array enumerated-sequence +INSTANCE: specialized-array enumerated-sequence + GENERIC: make-mirror ( obj -- assoc ) M: hashtable make-mirror ; M: integer make-mirror drop f ; -M: array make-mirror <enum> ; -M: vector make-mirror <enum> ; -M: quotation make-mirror <enum> ; +M: enumerated-sequence make-mirror <enum> ; M: object make-mirror <mirror> ; diff --git a/basis/models/arrow/arrow-docs.factor b/basis/models/arrow/arrow-docs.factor index 91b292f350..9bd6c4438d 100644 --- a/basis/models/arrow/arrow-docs.factor +++ b/basis/models/arrow/arrow-docs.factor @@ -21,7 +21,9 @@ HELP: <arrow> ARTICLE: "models.arrow" "Arrow models" "Arrow model values are computed by applying a quotation to the value of another model." -{ $subsection arrow } -{ $subsection <arrow> } ; +{ $subsections + arrow + <arrow> +} ; ABOUT: "models.arrow" diff --git a/basis/models/arrow/smart/smart-docs.factor b/basis/models/arrow/smart/smart-docs.factor index 3cc22d8d40..b6d0ff4349 100644 --- a/basis/models/arrow/smart/smart-docs.factor +++ b/basis/models/arrow/smart/smart-docs.factor @@ -16,6 +16,6 @@ HELP: <smart-arrow> ARTICLE: "models.arrow.smart" "Smart arrow models" "The " { $vocab-link "models.arrow.smart" } " vocabulary generalizes arrows to arbitrary input arity. They're called âsmartâ because they resemble " { $link "combinators.smart" } "." -{ $subsection <smart-arrow> } ; +{ $subsections <smart-arrow> } ; ABOUT: "models.arrow.smart" \ No newline at end of file diff --git a/basis/models/delay/delay-docs.factor b/basis/models/delay/delay-docs.factor index be3a2b3b59..742b6bf7e8 100644 --- a/basis/models/delay/delay-docs.factor +++ b/basis/models/delay/delay-docs.factor @@ -27,7 +27,9 @@ HELP: <delay> ARTICLE: "models-delay" "Delay models" "Delay models are used to implement delayed updating of gadgets in response to user input." -{ $subsection delay } -{ $subsection <delay> } ; +{ $subsections + delay + <delay> +} ; ABOUT: "models-delay" diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor index 8f40a8adbe..3eb7a79639 100644 --- a/basis/models/models-docs.factor +++ b/basis/models/models-docs.factor @@ -119,29 +119,33 @@ ARTICLE: "models" "Models" "The " { $vocab-link "models" } " vocabulary provides basic support for dataflow programming. A model is an observable value. Changing a model's value notifies other objects which depend on the model automatically, and models may depend on each other's values." $nl "The class of models:" -{ $subsection model } +{ $subsections model } "Creating models:" -{ $subsection <model> } +{ $subsections <model> } "Adding and removing connections:" -{ $subsection add-connection } -{ $subsection remove-connection } +{ $subsections + add-connection + remove-connection +} "Generic word called on model connections when the model value changes:" -{ $subsection model-changed } +{ $subsections model-changed } "When using models which are not associated with controls (or when unit testing controls), you must activate and deactivate models manually:" -{ $subsection activate-model } -{ $subsection deactivate-model } -{ $subsection "models-impl" } -{ $subsection "models.arrow" } -{ $subsection "models.product" } -{ $subsection "models-range" } -{ $subsection "models-delay" } ; +{ $subsections + activate-model + deactivate-model + "models-impl" + "models.arrow" + "models.product" + "models-range" + "models-delay" +} ; ARTICLE: "models-impl" "Implementing models" "New types of models can be defined, for example see " { $vocab-link "models.arrow" } "." $nl "Models can execute hooks when activated:" -{ $subsection model-activated } +{ $subsections model-activated } "Models can override requests to change their value, for example to perform validation:" -{ $subsection set-model } ; +{ $subsections set-model } ; ABOUT: "models" diff --git a/basis/models/product/product-docs.factor b/basis/models/product/product-docs.factor index a74f30f889..b4288891e0 100644 --- a/basis/models/product/product-docs.factor +++ b/basis/models/product/product-docs.factor @@ -30,7 +30,9 @@ HELP: <product> ARTICLE: "models.product" "Product models" "Product model values are computed by collecting the values from a sequence of underlying models into a new sequence." -{ $subsection product } -{ $subsection <product> } ; +{ $subsections + product + <product> +} ; ABOUT: "models.product" diff --git a/basis/models/range/range-docs.factor b/basis/models/range/range-docs.factor index 5f5b2f4405..7e205157f2 100644 --- a/basis/models/range/range-docs.factor +++ b/basis/models/range/range-docs.factor @@ -42,21 +42,25 @@ HELP: move-by-page ARTICLE: "models-range" "Range models" "Range models ensure their value is a real number within a fixed range." -{ $subsection range } -{ $subsection <range> } +{ $subsections + range + <range> +} "Range models conform to a protocol for getting and setting the current value, as well as the endpoints of the range." -{ $subsection "range-model-protocol" } ; +{ $subsections "range-model-protocol" } ; ARTICLE: "range-model-protocol" "Range model protocol" "The range model protocol is implemented by the " { $link range } " and " { $link compose } " classes. User-defined models may implement it too." -{ $subsection range-value } -{ $subsection range-page-value } -{ $subsection range-min-value } -{ $subsection range-max-value } -{ $subsection range-max-value* } -{ $subsection set-range-value } -{ $subsection set-range-page-value } -{ $subsection set-range-min-value } -{ $subsection set-range-max-value } ; +{ $subsections + range-value + range-page-value + range-min-value + range-max-value + range-max-value* + set-range-value + set-range-page-value + set-range-min-value + set-range-max-value +} ; ABOUT: "models-range" diff --git a/basis/multiline/multiline-docs.factor b/basis/multiline/multiline-docs.factor index 3616c0976c..9e7c28e89f 100644 --- a/basis/multiline/multiline-docs.factor +++ b/basis/multiline/multiline-docs.factor @@ -5,10 +5,6 @@ HELP: STRING: { $syntax "STRING: name\nfoo\n;" } { $description "Forms a multiline string literal, or 'here document' stored in the word called name. A semicolon is used to signify the end, and that semicolon must be on a line by itself, not preceeded or followed by any whitespace. The string will have newlines in between lines but not at the end, unless there is a blank line before the semicolon." } ; -HELP: <" -{ $syntax "<\" text \">" } -{ $description "This forms a multiline string literal ending in \">. Unlike the " { $link POSTPONE: STRING: } " form, you can end it in the middle of a line. This construct is non-nesting. In the example above, the string would be parsed as \"text\"." } ; - HELP: /* { $syntax "/* comment */" } { $description "Provides C-like comments that can span multiple lines. One caveat is that " { $snippet "/*" } " and " { $snippet "*/" } " are still tokens and must not abut the comment text itself." } @@ -47,23 +43,22 @@ HELP: DELIMITED: } } ; -{ POSTPONE: <" POSTPONE: STRING: } related-words - HELP: parse-multiline-string { $values { "end-text" "a string delineating the end" } { "str" "the parsed string" } } { $description "Parses the input stream until the " { $snippet "end-text" } " is reached and returns the parsed text as a string." } -{ $notes "Used to implement " { $link POSTPONE: /* } " and " { $link POSTPONE: <" } "." } ; +{ $notes "Used to implement " { $link POSTPONE: /* } "." } ; ARTICLE: "multiline" "Multiline" "Multiline strings:" -{ $subsection POSTPONE: STRING: } -{ $subsection POSTPONE: <" } -{ $subsection POSTPONE: HEREDOC: } -{ $subsection POSTPONE: DELIMITED: } +{ $subsections + POSTPONE: STRING: + POSTPONE: HEREDOC: + POSTPONE: DELIMITED: +} "Multiline comments:" -{ $subsection POSTPONE: /* } +{ $subsections POSTPONE: /* } "Writing new multiline parsing words:" -{ $subsection parse-multiline-string } +{ $subsections parse-multiline-string } ; ABOUT: "multiline" diff --git a/basis/multiline/multiline-tests.factor b/basis/multiline/multiline-tests.factor index 25610ed660..ad624dd917 100644 --- a/basis/multiline/multiline-tests.factor +++ b/basis/multiline/multiline-tests.factor @@ -8,17 +8,6 @@ bar ; [ "foo\nbar\n" ] [ test-it ] unit-test -[ "foo\nbar\n" ] [ <" foo -bar -"> ] unit-test - -[ "hello\nworld" ] [ <" hello -world"> ] unit-test - -[ "hello" "world" ] [ <" hello"> <" world"> ] unit-test - -[ "\nhi" ] [ <" -hi"> ] unit-test ! HEREDOC: diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index 4eaafe1f18..e28537066b 100644 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -75,18 +75,6 @@ PRIVATE> : parse-multiline-string ( end-text -- str ) 1 (parse-multiline-string) ; -SYNTAX: <" - "\">" parse-multiline-string parsed ; - -SYNTAX: <' - "'>" parse-multiline-string parsed ; - -SYNTAX: {' - "'}" parse-multiline-string parsed ; - -SYNTAX: {" - "\"}" parse-multiline-string parsed ; - SYNTAX: /* "*/" parse-multiline-string drop ; SYNTAX: HEREDOC: diff --git a/basis/opengl/annotations/annotations-docs.factor b/basis/opengl/annotations/annotations-docs.factor index 7ed7ac2840..c05ee17c47 100644 --- a/basis/opengl/annotations/annotations-docs.factor +++ b/basis/opengl/annotations/annotations-docs.factor @@ -33,9 +33,11 @@ HELP: reset-gl-functions ARTICLE: "opengl.annotations" "OpenGL error reporting" "The " { $vocab-link "opengl.annotations" } " vocabulary provides some tools for tracking down GL errors:" -{ $subsection throw-gl-errors } -{ $subsection log-gl-errors } -{ $subsection clear-gl-error-log } -{ $subsection reset-gl-functions } ; +{ $subsections + throw-gl-errors + log-gl-errors + clear-gl-error-log + reset-gl-functions +} ; ABOUT: "opengl.annotations" \ No newline at end of file diff --git a/basis/opengl/capabilities/capabilities-docs.factor b/basis/opengl/capabilities/capabilities-docs.factor index 959b222671..8b43c56f6d 100644 --- a/basis/opengl/capabilities/capabilities-docs.factor +++ b/basis/opengl/capabilities/capabilities-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io kernel math quotations -opengl.gl multiline assocs ; +opengl.gl assocs ; IN: opengl.capabilities HELP: gl-version @@ -42,10 +42,10 @@ HELP: has-gl-extensions? { $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } } { $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } ". Elements of " { $snippet "extensions" } " can be sequences, in which case true will be returned if any one of the extensions in the subsequence are available." } { $examples "Testing for framebuffer object and pixel buffer support:" - { $code <" { + { $code """{ { "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" } "GL_ARB_pixel_buffer_object" -} has-gl-extensions? "> } +} has-gl-extensions?""" } } ; HELP: has-gl-version-or-extensions? diff --git a/basis/opengl/debug/debug-docs.factor b/basis/opengl/debug/debug-docs.factor index 7cb8f9b246..dfc0d1993b 100644 --- a/basis/opengl/debug/debug-docs.factor +++ b/basis/opengl/debug/debug-docs.factor @@ -1,15 +1,14 @@ ! (c)2009 Joe Groff bsd license -USING: help.markup help.syntax multiline tools.continuations ; +USING: help.markup help.syntax tools.continuations ; IN: opengl.debug HELP: G { $description "Makes the OpenGL context associated with " { $link G-world } " active for subsequent OpenGL calls. This is intended to be used from the listener, where interactively entered OpenGL calls can be directed to any window. Note that the Factor UI resets the OpenGL context every time a window is updated, so every code snippet entered in the listener must be prefixed with " { $snippet "G" } " in this use case." } -{ $examples { $code <" USING: opengl.debug ui ; +{ $examples { $code """USING: opengl.debug ui ; [ drop t ] find-window G-world set G 0.0 0.0 1.0 1.0 glClearColor -G GL_COLOR_BUFFER_BIT glClear -"> } } ; +G GL_COLOR_BUFFER_BIT glClear""" } } ; HELP: F { $description "Flushes the OpenGL context associated with " { $link G-world } ", thereby committing any outstanding drawing operations." } ; @@ -27,10 +26,12 @@ HELP: gl-break ARTICLE: "opengl.debug" "Interactive debugging of OpenGL applications" "The " { $vocab-link "opengl.debug" } " vocabulary provides words to assist with interactive debugging of OpenGL applications in the Factor UI." -{ $subsection G-world } -{ $subsection G } -{ $subsection F } -{ $subsection GB } -{ $subsection gl-break } ; +{ $subsections + G-world + G + F + GB + gl-break +} ; ABOUT: "opengl.debug" diff --git a/basis/opengl/gl/gl-docs.factor b/basis/opengl/gl/gl-docs.factor index 83331decee..019b29ef54 100644 --- a/basis/opengl/gl/gl-docs.factor +++ b/basis/opengl/gl/gl-docs.factor @@ -4,36 +4,40 @@ USING: help.syntax help.markup ; IN: opengl.gl ARTICLE: "opengl-low-level" "OpenGL binding" - { $subsection "opengl-specifying-vertices" } - { $subsection "opengl-geometric-primitives" } - { $subsection "opengl-modeling-transformations" } ; +{ $subsections + "opengl-specifying-vertices" + "opengl-geometric-primitives" + "opengl-modeling-transformations" +} ; ARTICLE: "opengl-specifying-vertices" "Specifying vertices" +{ $subsections + glVertex2d + glVertex2f + glVertex2i + glVertex2s + glVertex3d + glVertex3f + glVertex3i + glVertex3s + glVertex4d + glVertex4f + glVertex4i + glVertex4s + glVertex2dv + glVertex2fv + glVertex2iv + glVertex2sv + glVertex3dv + glVertex3fv + glVertex3iv + glVertex3sv + glVertex4dv + glVertex4fv + glVertex4iv + glVertex4sv +} ; - { $subsection glVertex2d } - { $subsection glVertex2f } - { $subsection glVertex2i } - { $subsection glVertex2s } - { $subsection glVertex3d } - { $subsection glVertex3f } - { $subsection glVertex3i } - { $subsection glVertex3s } - { $subsection glVertex4d } - { $subsection glVertex4f } - { $subsection glVertex4i } - { $subsection glVertex4s } - { $subsection glVertex2dv } - { $subsection glVertex2fv } - { $subsection glVertex2iv } - { $subsection glVertex2sv } - { $subsection glVertex3dv } - { $subsection glVertex3fv } - { $subsection glVertex3iv } - { $subsection glVertex3sv } - { $subsection glVertex4dv } - { $subsection glVertex4fv } - { $subsection glVertex4iv } - { $subsection glVertex4sv } ; ARTICLE: "opengl-geometric-primitives" "OpenGL geometric primitives" @@ -71,12 +75,14 @@ HELP: glPolygonMode { $link GL_FILL } } } } } ; ARTICLE: "opengl-modeling-transformations" "Modeling transformations" - { $subsection glTranslatef } - { $subsection glTranslated } - { $subsection glRotatef } - { $subsection glRotated } - { $subsection glScalef } - { $subsection glScaled } ; +{ $subsections + glTranslatef + glTranslated + glRotatef + glRotated + glScalef + glScaled +} ; { glTranslatef glTranslated glRotatef glRotated glScalef glScaled } diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index 32c3ca4b82..412405c852 100644 --- a/basis/opengl/gl/gl.factor +++ b/basis/opengl/gl/gl.factor @@ -3,9 +3,9 @@ ! This file is based on the gl.h that comes with xorg-x11 6.8.2 -USING: alien alien.syntax combinators kernel parser sequences -system words opengl.gl.extensions ; - +USING: alien alien.c-types alien.syntax combinators kernel parser +sequences system words opengl.gl.extensions ; +FROM: alien.c-types => short ; IN: opengl.gl TYPEDEF: uint GLenum diff --git a/basis/opengl/gl/windows/windows.factor b/basis/opengl/gl/windows/windows.factor old mode 100644 new mode 100755 index c8a179edf5..5821e3f212 --- a/basis/opengl/gl/windows/windows.factor +++ b/basis/opengl/gl/windows/windows.factor @@ -1,4 +1,4 @@ -USING: alien.syntax kernel windows.types ; +USING: alien.c-types alien.syntax kernel windows.types ; IN: opengl.gl.windows LIBRARY: gl diff --git a/basis/opengl/opengl-docs.factor b/basis/opengl/opengl-docs.factor index 4b9890e428..821885b4e8 100644 --- a/basis/opengl/opengl-docs.factor +++ b/basis/opengl/opengl-docs.factor @@ -72,23 +72,28 @@ ARTICLE: "gl-utilities" "OpenGL utility words" "The " { $vocab-link "opengl" } " vocabulary implements some utility words to give OpenGL a more Factor-like feel." $nl "The " { $vocab-link "opengl.gl" } " and " { $vocab-link "opengl.glu" } " vocabularies have the actual OpenGL bindings." -{ $subsection "opengl-low-level" } +{ $subsections "opengl-low-level" } "Error reporting:" -{ $subsection gl-error } +{ $subsections gl-error } "Wrappers:" -{ $subsection gl-color } -{ $subsection gl-translate } -{ $subsection bind-texture-unit } +{ $subsections + gl-color + gl-translate + bind-texture-unit +} "Combinators:" -{ $subsection do-enabled } -{ $subsection do-attribs } -{ $subsection do-matrix } -{ $subsection with-translation } -{ $subsection make-dlist } +{ $subsections + do-enabled + do-attribs + do-matrix + with-translation + make-dlist +} "Rendering geometric shapes:" -{ $subsection gl-line } -{ $subsection gl-fill-rect } -{ $subsection gl-rect } -; +{ $subsections + gl-line + gl-fill-rect + gl-rect +} ; ABOUT: "gl-utilities" diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 28d920d8d6..d846afe3a9 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -5,6 +5,7 @@ kernel opengl opengl.gl opengl.capabilities combinators images images.tesselation grouping sequences math math.vectors math.matrices generalizations fry arrays namespaces system locals literals specialized-arrays ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: opengl.textures diff --git a/basis/openssl/libcrypto/libcrypto.factor b/basis/openssl/libcrypto/libcrypto.factor index df9955a53c..dbc5b9e43c 100644 --- a/basis/openssl/libcrypto/libcrypto.factor +++ b/basis/openssl/libcrypto/libcrypto.factor @@ -103,15 +103,15 @@ FUNCTION: void* BIO_f_buffer ( ) ; CONSTANT: EVP_MAX_MD_SIZE 64 +TYPEDEF: void* EVP_MD* +C-TYPE: ENGINE + STRUCT: EVP_MD_CTX { digest EVP_MD* } { engine ENGINE* } { flags ulong } { md_data void* } ; -TYPEDEF: void* EVP_MD* -TYPEDEF: void* ENGINE* - ! Initialize ciphers and digest tables FUNCTION: void OpenSSL_add_all_ciphers ( ) ; diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index 520c7175c6..225d4b3da1 100644 --- a/basis/openssl/libssl/libssl.factor +++ b/basis/openssl/libssl/libssl.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007 Elie CHAFTARI ! Portions copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax combinators kernel system namespaces -assocs parser lexer sequences words quotations math.bitwise -alien.libraries ; +USING: alien alien.c-types alien.syntax combinators kernel +system namespaces assocs parser lexer sequences words +quotations math.bitwise alien.libraries ; IN: openssl.libssl @@ -91,10 +91,21 @@ CONSTANT: SSL_ERROR_WANT_ACCEPT 8 TYPEDEF: void* ssl-method TYPEDEF: void* SSL_CTX* TYPEDEF: void* SSL_SESSION* -TYPEDEF: void* SSL* +C-TYPE: SSL LIBRARY: libssl +! =============================================== +! x509.h +! =============================================== + +TYPEDEF: void* X509_NAME* + +C-TYPE: X509 + +FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ; +FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ; + ! =============================================== ! ssl.h ! =============================================== @@ -258,17 +269,6 @@ CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200 : SSL_SESS_CACHE_NO_INTERNAL ( -- n ) { SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline -! =============================================== -! x509.h -! =============================================== - -TYPEDEF: void* X509_NAME* - -TYPEDEF: void* X509* - -FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ; -FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ; - ! =============================================== ! x509_vfy.h ! =============================================== diff --git a/basis/pango/cairo/cairo.factor b/basis/pango/cairo/cairo.factor index 45b7a9cb31..6fd8d57893 100644 --- a/basis/pango/cairo/cairo.factor +++ b/basis/pango/cairo/cairo.factor @@ -3,8 +3,12 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! pangocairo bindings, from pango/pangocairo.h -USING: alien alien.syntax combinators system cairo.ffi -alien.libraries ; +USING: arrays sequences alien alien.c-types alien.destructors +alien.libraries alien.syntax math math.functions math.vectors +destructors combinators colors fonts accessors assocs namespaces +kernel pango pango.fonts pango.layouts glib unicode.data images +cache init system math.rectangles fry memoize io.encodings.utf8 +classes.struct cairo cairo.ffi ; IN: pango.cairo << { @@ -15,6 +19,9 @@ IN: pango.cairo LIBRARY: pangocairo +C-TYPE: PangoCairoFontMap +C-TYPE: PangoCairoFont + FUNCTION: PangoFontMap* pango_cairo_font_map_new ( ) ; @@ -87,3 +94,150 @@ pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ; FUNCTION: void pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ; + +TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ; + +SYMBOL: dpi + +72 dpi set-global + +: set-layout-font ( font layout -- ) + swap cache-font-description pango_layout_set_font_description ; + +: set-layout-text ( str layout -- ) + #! Replace nulls with something else since Pango uses null-terminated + #! strings + swap -1 pango_layout_set_text ; + +: layout-extents ( layout -- ink-rect logical-rect ) + PangoRectangle <struct> + PangoRectangle <struct> + [ pango_layout_get_extents ] 2keep + [ PangoRectangle>rect ] bi@ ; + +: layout-baseline ( layout -- baseline ) + pango_layout_get_iter &pango_layout_iter_free + pango_layout_iter_get_baseline + pango>float ; + +: set-foreground ( cr font -- ) + foreground>> set-source-color ; + +: fill-background ( cr font dim -- ) + [ background>> set-source-color ] + [ [ { 0 0 } ] dip <rect> fill-rect ] bi-curry* bi ; + +: rect-translate-x ( rect x -- rect' ) + '[ _ 0 2array v- ] change-loc ; + +: first-line ( layout -- line ) + layout>> 0 pango_layout_get_line_readonly ; + +: line-offset>x ( layout n -- x ) + #! n is an index into the UTF8 encoding of the text + [ drop first-line ] [ swap string>> >utf8-index ] 2bi + 0 0 <int> [ pango_layout_line_index_to_x ] keep + *int pango>float ; + +: x>line-offset ( layout x -- n ) + #! n is an index into the UTF8 encoding of the text + [ + [ first-line ] dip + float>pango 0 <int> 0 <int> + [ pango_layout_line_x_to_index drop ] 2keep + [ *int ] bi@ swap + ] [ drop string>> ] 2bi utf8-index> + ; + +: selection-start/end ( selection -- start end ) + selection>> [ start>> ] [ end>> ] bi ; + +: selection-rect ( layout -- rect ) + [ ink-rect>> dim>> ] [ ] [ selection-start/end ] tri [ line-offset>x ] bi-curry@ bi + [ drop nip 0 2array ] [ swap - swap second 2array ] 3bi <rect> ; + +: fill-selection-background ( cr layout -- ) + dup selection>> [ + [ selection>> color>> set-source-color ] + [ + [ selection-rect ] [ ink-rect>> loc>> first ] bi + rect-translate-x + fill-rect + ] 2bi + ] [ 2drop ] if ; + +: text-position ( layout -- loc ) + [ logical-rect>> ] [ ink-rect>> ] bi [ loc>> ] bi@ v- ; + +: set-text-position ( cr loc -- ) + first2 cairo_move_to ; + +: draw-layout ( layout -- image ) + dup ink-rect>> dim>> [ >fixnum ] map [ + swap { + [ layout>> pango_cairo_update_layout ] + [ [ font>> ] [ ink-rect>> dim>> ] bi fill-background ] + [ fill-selection-background ] + [ text-position set-text-position ] + [ font>> set-foreground ] + [ layout>> pango_cairo_show_layout ] + } 2cleave + ] make-bitmap-image ; + +: escape-nulls ( str -- str' ) + { { 0 CHAR: zero-width-no-break-space } } substitute ; + +: unpack-selection ( layout string/selection -- layout ) + dup selection? [ + [ string>> escape-nulls >>string ] [ >>selection ] bi + ] [ escape-nulls >>string ] if ; inline + +: set-layout-resolution ( layout -- ) + pango_layout_get_context dpi get pango_cairo_context_set_resolution ; + +: <PangoLayout> ( text font -- layout ) + dummy-cairo pango_cairo_create_layout |g_object_unref + [ set-layout-resolution ] keep + [ set-layout-font ] keep + [ set-layout-text ] keep ; + +: glyph-height ( font string -- y ) + swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ; + +MEMO: missing-font-metrics ( font -- metrics ) + #! Pango doesn't provide x-height and cap-height but Core Text does, so we + #! simulate them on Pango. + [ + [ metrics new ] dip + [ "x" glyph-height >>x-height ] + [ "Y" glyph-height >>cap-height ] bi + ] with-destructors ; + +: layout-metrics ( layout -- metrics ) + dup font>> missing-font-metrics clone + swap + [ layout>> layout-baseline >>ascent ] + [ logical-rect>> dim>> [ first >>width ] [ second >>height ] bi ] bi + dup [ height>> ] [ ascent>> ] bi - >>descent ; + +: <layout> ( font string -- line ) + [ + layout new-disposable + swap unpack-selection + swap >>font + dup [ string>> ] [ font>> ] bi <PangoLayout> >>layout + dup layout>> layout-extents [ >>ink-rect ] [ >>logical-rect ] bi* + dup layout-metrics >>metrics + dup draw-layout >>image + ] with-destructors ; + +M: layout dispose* layout>> g_object_unref ; + +SYMBOL: cached-layouts + +: cached-layout ( font string -- layout ) + cached-layouts get [ <layout> ] 2cache ; + +: cached-line ( font string -- line ) + cached-layout layout>> first-line ; + +[ <cache-assoc> cached-layouts set-global ] "pango.cairo" add-init-hook diff --git a/basis/pango/fonts/fonts.factor b/basis/pango/fonts/fonts.factor index abfc086820..280ddd20d6 100644 --- a/basis/pango/fonts/fonts.factor +++ b/basis/pango/fonts/fonts.factor @@ -15,6 +15,15 @@ PANGO_STYLE_OBLIQUE PANGO_STYLE_ITALIC ; TYPEDEF: int PangoWeight +C-TYPE: PangoFont +C-TYPE: PangoFontFamily +C-TYPE: PangoFontFace +C-TYPE: PangoFontMap +C-TYPE: PangoFontMetrics +C-TYPE: PangoFontDescription +C-TYPE: PangoGlyphString +C-TYPE: PangoLanguage + CONSTANT: PANGO_WEIGHT_THIN 100 CONSTANT: PANGO_WEIGHT_ULTRALIGHT 200 CONSTANT: PANGO_WEIGHT_LIGHT 300 @@ -102,4 +111,4 @@ MEMO: (cache-font-description) ( font -- description ) : cache-font-description ( font -- description ) strip-font-colors (cache-font-description) ; -[ \ (cache-font-description) reset-memoized ] "pango.fonts" add-init-hook \ No newline at end of file +[ \ (cache-font-description) reset-memoized ] "pango.fonts" add-init-hook diff --git a/basis/pango/layouts/layouts-tests.factor b/basis/pango/layouts/layouts-tests.factor index 5959eddb07..a4a83f79a8 100644 --- a/basis/pango/layouts/layouts-tests.factor +++ b/basis/pango/layouts/layouts-tests.factor @@ -1,5 +1,5 @@ IN: pango.layouts.tests -USING: pango.layouts tools.test glib fonts accessors +USING: pango.layouts pango.cairo tools.test glib fonts accessors sequences combinators.short-circuit math destructors ; [ t ] [ diff --git a/basis/pango/layouts/layouts.factor b/basis/pango/layouts/layouts.factor index 7a7bd86aea..74b6d0b0c3 100644 --- a/basis/pango/layouts/layouts.factor +++ b/basis/pango/layouts/layouts.factor @@ -4,12 +4,16 @@ USING: arrays sequences alien alien.c-types alien.destructors alien.syntax math math.functions math.vectors destructors combinators colors fonts accessors assocs namespaces kernel pango pango.fonts -pango.cairo cairo cairo.ffi glib unicode.data images cache init +glib unicode.data images cache init math.rectangles fry memoize io.encodings.utf8 classes.struct ; IN: pango.layouts LIBRARY: pango +C-TYPE: PangoLayout +C-TYPE: PangoLayoutIter +C-TYPE: PangoLayoutLine + FUNCTION: PangoLayout* pango_layout_new ( PangoContext* context ) ; @@ -60,149 +64,3 @@ pango_layout_iter_free ( PangoLayoutIter* iter ) ; DESTRUCTOR: pango_layout_iter_free -TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ; - -SYMBOL: dpi - -72 dpi set-global - -: set-layout-font ( font layout -- ) - swap cache-font-description pango_layout_set_font_description ; - -: set-layout-text ( str layout -- ) - #! Replace nulls with something else since Pango uses null-terminated - #! strings - swap -1 pango_layout_set_text ; - -: set-layout-resolution ( layout -- ) - pango_layout_get_context dpi get pango_cairo_context_set_resolution ; - -: <PangoLayout> ( text font -- layout ) - dummy-cairo pango_cairo_create_layout |g_object_unref - [ set-layout-resolution ] keep - [ set-layout-font ] keep - [ set-layout-text ] keep ; - -: layout-extents ( layout -- ink-rect logical-rect ) - PangoRectangle <struct> - PangoRectangle <struct> - [ pango_layout_get_extents ] 2keep - [ PangoRectangle>rect ] bi@ ; - -: glyph-height ( font string -- y ) - swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ; - -MEMO: missing-font-metrics ( font -- metrics ) - #! Pango doesn't provide x-height and cap-height but Core Text does, so we - #! simulate them on Pango. - [ - [ metrics new ] dip - [ "x" glyph-height >>x-height ] - [ "Y" glyph-height >>cap-height ] bi - ] with-destructors ; - -: layout-baseline ( layout -- baseline ) - pango_layout_get_iter &pango_layout_iter_free - pango_layout_iter_get_baseline - pango>float ; - -: set-foreground ( cr font -- ) - foreground>> set-source-color ; - -: fill-background ( cr font dim -- ) - [ background>> set-source-color ] - [ [ { 0 0 } ] dip <rect> fill-rect ] bi-curry* bi ; - -: rect-translate-x ( rect x -- rect' ) - '[ _ 0 2array v- ] change-loc ; - -: first-line ( layout -- line ) - layout>> 0 pango_layout_get_line_readonly ; - -: line-offset>x ( layout n -- x ) - #! n is an index into the UTF8 encoding of the text - [ drop first-line ] [ swap string>> >utf8-index ] 2bi - 0 0 <int> [ pango_layout_line_index_to_x ] keep - *int pango>float ; - -: x>line-offset ( layout x -- n ) - #! n is an index into the UTF8 encoding of the text - [ - [ first-line ] dip - float>pango 0 <int> 0 <int> - [ pango_layout_line_x_to_index drop ] 2keep - [ *int ] bi@ swap - ] [ drop string>> ] 2bi utf8-index> + ; - -: selection-start/end ( selection -- start end ) - selection>> [ start>> ] [ end>> ] bi ; - -: selection-rect ( layout -- rect ) - [ ink-rect>> dim>> ] [ ] [ selection-start/end ] tri [ line-offset>x ] bi-curry@ bi - [ drop nip 0 2array ] [ swap - swap second 2array ] 3bi <rect> ; - -: fill-selection-background ( cr layout -- ) - dup selection>> [ - [ selection>> color>> set-source-color ] - [ - [ selection-rect ] [ ink-rect>> loc>> first ] bi - rect-translate-x - fill-rect - ] 2bi - ] [ 2drop ] if ; - -: text-position ( layout -- loc ) - [ logical-rect>> ] [ ink-rect>> ] bi [ loc>> ] bi@ v- ; - -: set-text-position ( cr loc -- ) - first2 cairo_move_to ; - -: layout-metrics ( layout -- metrics ) - dup font>> missing-font-metrics clone - swap - [ layout>> layout-baseline >>ascent ] - [ logical-rect>> dim>> [ first >>width ] [ second >>height ] bi ] bi - dup [ height>> ] [ ascent>> ] bi - >>descent ; - -: draw-layout ( layout -- image ) - dup ink-rect>> dim>> [ >fixnum ] map [ - swap { - [ layout>> pango_cairo_update_layout ] - [ [ font>> ] [ ink-rect>> dim>> ] bi fill-background ] - [ fill-selection-background ] - [ text-position set-text-position ] - [ font>> set-foreground ] - [ layout>> pango_cairo_show_layout ] - } 2cleave - ] make-bitmap-image ; - -: escape-nulls ( str -- str' ) - { { 0 CHAR: zero-width-no-break-space } } substitute ; - -: unpack-selection ( layout string/selection -- layout ) - dup selection? [ - [ string>> escape-nulls >>string ] [ >>selection ] bi - ] [ escape-nulls >>string ] if ; inline - -: <layout> ( font string -- line ) - [ - layout new-disposable - swap unpack-selection - swap >>font - dup [ string>> ] [ font>> ] bi <PangoLayout> >>layout - dup layout>> layout-extents [ >>ink-rect ] [ >>logical-rect ] bi* - dup layout-metrics >>metrics - dup draw-layout >>image - ] with-destructors ; - -M: layout dispose* layout>> g_object_unref ; - -SYMBOL: cached-layouts - -: cached-layout ( font string -- layout ) - cached-layouts get [ <layout> ] 2cache ; - -: cached-line ( font string -- line ) - cached-layout layout>> first-line ; - -[ <cache-assoc> cached-layouts set-global ] "pango.layouts" add-init-hook diff --git a/basis/pango/pango.factor b/basis/pango/pango.factor index 11e15ae951..6dc48e39fe 100644 --- a/basis/pango/pango.factor +++ b/basis/pango/pango.factor @@ -23,8 +23,9 @@ CONSTANT: PANGO_SCALE 1024 : pango>float ( n -- x ) PANGO_SCALE /f ; inline : float>pango ( x -- n ) PANGO_SCALE * >integer ; inline -FUNCTION: PangoContext* -pango_context_new ( ) ; +C-TYPE: PangoContext + +FUNCTION: PangoContext* pango_context_new ( ) ; STRUCT: PangoRectangle { x int } diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor index 329156d733..bcd881c03d 100644 --- a/basis/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -521,10 +521,10 @@ Tok = Spaces (Number | Special ) [ "USE: peg.ebnf [EBNF EBNF]" eval( -- ) ] must-fail -[ <" USE: peg.ebnf [EBNF +[ """USE: peg.ebnf [EBNF lol = a lol = b - EBNF] "> eval( -- ) + EBNF]""" eval( -- ) ] [ error>> [ redefined-rule? ] [ name>> "lol" = ] bi and ] must-fail-with diff --git a/basis/persistent/deques/deques-docs.factor b/basis/persistent/deques/deques-docs.factor index f1027d107b..1c8dad8b2e 100644 --- a/basis/persistent/deques/deques-docs.factor +++ b/basis/persistent/deques/deques-docs.factor @@ -9,18 +9,22 @@ $nl "This vocabulary provides a deque implementation which is persistent and purely functional: old versions of deques are not modified by operations. Instead, each push and pop operation creates a new deque based off the old one." $nl "The class of persistent deques:" -{ $subsection deque } +{ $subsections deque } "To create a deque:" -{ $subsection <deque> } -{ $subsection sequence>deque } +{ $subsections + <deque> + sequence>deque +} "To test if a deque is empty:" -{ $subsection deque-empty? } +{ $subsections deque-empty? } "To manipulate deques:" -{ $subsection push-front } -{ $subsection push-back } -{ $subsection pop-front } -{ $subsection pop-back } -{ $subsection deque>sequence } ; +{ $subsections + push-front + push-back + pop-front + pop-back + deque>sequence +} ; HELP: deque { $class-description "This is the class of persistent (functional) double-ended queues. All deque operations can be done in O(1) amortized time for single-threaded access while maintaining the old version. For more information, see " { $link "persistent.deques" } "." } ; diff --git a/basis/persistent/heaps/heaps-docs.factor b/basis/persistent/heaps/heaps-docs.factor index a56022a039..49852bac4d 100644 --- a/basis/persistent/heaps/heaps-docs.factor +++ b/basis/persistent/heaps/heaps-docs.factor @@ -43,16 +43,20 @@ HELP: pheap>values ARTICLE: "persistent-heaps" "Persistent heaps" "This vocabulary implements persistent minheaps, aka priority queues. They are purely functional and support efficient O(log n) operations of pushing and popping, with O(1) time access to the minimum element. To create heaps, use the following words:" -{ $subsection <persistent-heap> } -{ $subsection <singleton-heap> } +{ $subsections + <persistent-heap> + <singleton-heap> +} "To manipulate them:" -{ $subsection pheap-peek } -{ $subsection pheap-push } -{ $subsection pheap-pop } -{ $subsection pheap-pop* } -{ $subsection pheap-empty? } -{ $subsection assoc>pheap } -{ $subsection pheap>alist } -{ $subsection pheap>values } ; +{ $subsections + pheap-peek + pheap-push + pheap-pop + pheap-pop* + pheap-empty? + assoc>pheap + pheap>alist + pheap>values +} ; ABOUT: "persistent-heaps" diff --git a/basis/persistent/sequences/sequences-docs.factor b/basis/persistent/sequences/sequences-docs.factor index 6928d03f55..d908072d9c 100644 --- a/basis/persistent/sequences/sequences-docs.factor +++ b/basis/persistent/sequences/sequences-docs.factor @@ -15,9 +15,11 @@ HELP: ppop ARTICLE: "persistent.sequences" "Persistent sequence protocol" "The persistent sequence protocol consists of the non-mutating sequence protocol words, such as " { $link length } " and " { $link nth } ", together with the following operations:" -{ $subsection new-nth } -{ $subsection ppush } -{ $subsection ppop } +{ $subsections + new-nth + ppush + ppop +} "The default implementations of the above run in " { $snippet "O(n)" } " time; the " { $vocab-link "persistent.vectors" } " vocabulary provides an implementation of these operations in " { $snippet "O(1)" } " time." ; ABOUT: "persistent.sequences" diff --git a/basis/persistent/vectors/vectors-docs.factor b/basis/persistent/vectors/vectors-docs.factor index aa817edf52..297e520d73 100644 --- a/basis/persistent/vectors/vectors-docs.factor +++ b/basis/persistent/vectors/vectors-docs.factor @@ -16,11 +16,11 @@ ARTICLE: "persistent.vectors" "Persistent vectors" "A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time." $nl "The class of persistent vectors:" -{ $subsection persistent-vector } +{ $subsections persistent-vector } "Converting a sequence into a persistent vector:" -{ $subsection >persistent-vector } +{ $subsections >persistent-vector } "Persistent vectors have a literal syntax:" -{ $subsection POSTPONE: PV{ } +{ $subsections POSTPONE: PV{ } "The empty persistent vector, written " { $snippet "PV{ }" } ", is used for building up all other persistent vectors." $nl "This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ; diff --git a/basis/porter-stemmer/porter-stemmer-docs.factor b/basis/porter-stemmer/porter-stemmer-docs.factor index e16190f861..537dfe79ce 100644 --- a/basis/porter-stemmer/porter-stemmer-docs.factor +++ b/basis/porter-stemmer/porter-stemmer-docs.factor @@ -61,14 +61,16 @@ $nl "A detailed description of the algorithm, along with implementations in various languages, can be at in " { $url "http://www.tartarus.org/~martin/PorterStemmer" } "." $nl "The main word of the algorithm takes an English word as input and outputs its stem:" -{ $subsection stem } +{ $subsections stem } "The algorithm consists of a number of steps:" -{ $subsection step1a } -{ $subsection step1b } -{ $subsection step1c } -{ $subsection step2 } -{ $subsection step3 } -{ $subsection step4 } -{ $subsection step5 } ; +{ $subsections + step1a + step1b + step1c + step2 + step3 + step4 + step5 +} ; ABOUT: "porter-stemmer" diff --git a/basis/present/present-docs.factor b/basis/present/present-docs.factor index 0428235c2a..795874adfa 100644 --- a/basis/present/present-docs.factor +++ b/basis/present/present-docs.factor @@ -3,7 +3,7 @@ USING: help.markup help.syntax kernel strings ; ARTICLE: "present" "Converting objects to human-readable strings" "A word for converting an object into a human-readable string:" -{ $subsection present } ; +{ $subsections present } ; HELP: present { $values { "object" object } { "string" string } } diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index cba40bbff1..f919573ea9 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -169,7 +169,7 @@ M: tuple pprint* : do-length-limit ( seq -- trimmed n/f ) length-limit get dup [ over length over [-] - dup zero? [ 2drop f ] [ [ head ] dip ] if + dup zero? [ 2drop f ] [ [ head-slice ] dip ] if ] when ; : pprint-elements ( seq -- ) diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index 1560b208ab..e17e14f323 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -6,32 +6,38 @@ IN: prettyprint ARTICLE: "prettyprint-numbers" "Prettyprinting numbers" "The " { $link . } " word prints numbers in decimal. A set of words in the " { $vocab-link "prettyprint" } " vocabulary is provided to print integers using another base." -{ $subsection .b } -{ $subsection .o } -{ $subsection .h } ; +{ $subsections + .b + .o + .h +} ; ARTICLE: "prettyprint-stacks" "Prettyprinting stacks" "Prettyprinting the current data, retain, call stacks:" -{ $subsection .s } -{ $subsection .r } -{ $subsection .c } +{ $subsections + .s + .r + .c +} "Prettyprinting any stack:" -{ $subsection stack. } +{ $subsections stack. } "Prettyprinting any call stack:" -{ $subsection callstack. } +{ $subsections callstack. } "Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "." ; ARTICLE: "prettyprint-variables" "Prettyprint control variables" "The following variables affect the " { $link . } " and " { $link pprint } " words if set in the current dynamic scope:" -{ $subsection tab-size } -{ $subsection margin } -{ $subsection nesting-limit } -{ $subsection length-limit } -{ $subsection line-limit } -{ $subsection number-base } -{ $subsection string-limit? } -{ $subsection boa-tuples? } -{ $subsection c-object-pointers? } +{ $subsections + tab-size + margin + nesting-limit + length-limit + line-limit + number-base + string-limit? + boa-tuples? + c-object-pointers? +} "Note that the " { $link short. } " and " { $link pprint-short } " variables override some of these variables." { $warning "Treat the global variables as essentially being constants. Only ever rebind them in a nested scope." @@ -56,44 +62,56 @@ ARTICLE: "prettyprint-section-protocol" "Prettyprinter section protocol" "Prettyprinter sections must subclass " { $link section } ", and they must also obey a protocol." $nl "Layout queries:" -{ $subsection section-fits? } -{ $subsection indent-section? } -{ $subsection unindent-first-line? } -{ $subsection newline-after? } -{ $subsection short-section? } +{ $subsections + section-fits? + indent-section? + unindent-first-line? + newline-after? + short-section? +} "Printing sections:" -{ $subsection short-section } -{ $subsection long-section } +{ $subsections + short-section + long-section +} "Utilities to use when implementing sections:" -{ $subsection new-section } -{ $subsection new-block } -{ $subsection add-section } ; +{ $subsections + new-section + new-block + add-section +} ; ARTICLE: "prettyprint-sections" "Prettyprinter sections" "The prettyprinter's formatting engine can be used directly:" -{ $subsection with-pprint } +{ $subsections with-pprint } "Code in a " { $link with-pprint } " block or a method on " { $link pprint* } " can build up a tree of " { $emphasis "sections" } ". A section is either a text node or a " { $emphasis "block" } " which itself consists of sections." $nl "Once the output sections have been generated, the tree of sections is traversed and intelligent decisions are made about indentation and line breaks. Finally, text is output." -{ $subsection section } +{ $subsections section } "Adding leaf sections:" -{ $subsection line-break } -{ $subsection text } -{ $subsection styled-text } +{ $subsections + line-break + text + styled-text +} "Nesting and denesting sections:" -{ $subsection <object } -{ $subsection <block } -{ $subsection <inset } -{ $subsection <flow } -{ $subsection <colon } -{ $subsection block> } +{ $subsections + <object + <block + <inset + <flow + <colon + block> +} "New types of sections can be defined." -{ $subsection "prettyprint-section-protocol" } ; +{ $subsections "prettyprint-section-protocol" } ; ARTICLE: "prettyprint-literal" "Literal prettyprinting protocol" "Most custom data types have a literal syntax which resembles a sequence. An easy way to define such a syntax is to add a method to the " { $link pprint* } " generic word which calls " { $link pprint-object } ", and then to provide methods on two other generic words:" -{ $subsection pprint-delims } -{ $subsection >pprint-sequence } +{ $subsections + pprint-delims + >pprint-sequence +} "For example, consider the following data type, together with a parsing word for creating literals:" { $code "TUPLE: rect w h ;" @@ -120,21 +138,25 @@ ARTICLE: "prettyprint-literal" "Literal prettyprinting protocol" ARTICLE: "prettyprint-literal-more" "Prettyprinting more complex literals" "If the " { $link "prettyprint-literal" } " is insufficient, a method can be defined to control prettyprinting directly:" -{ $subsection pprint* } +{ $subsections pprint* } "Some utilities which can be called from methods on " { $link pprint* } ":" -{ $subsection pprint-object } -{ $subsection pprint-word } -{ $subsection pprint-elements } -{ $subsection pprint-string } -{ $subsection pprint-prefix } +{ $subsections + pprint-object + pprint-word + pprint-elements + pprint-string + pprint-prefix +} "Custom methods defined on " { $link pprint* } " do not perform I/O directly, instead they call prettyprinter words to construct " { $emphasis "sections" } " of output. See " { $link "prettyprint-sections" } "." ; ARTICLE: "prettyprint-extension" "Extending the prettyprinter" "One can define literal syntax for a new class using the " { $link "parser" } " together with corresponding prettyprinting methods which print instances of the class using this syntax." -{ $subsection "prettyprint-literal" } -{ $subsection "prettyprint-literal-more" } +{ $subsections + "prettyprint-literal" + "prettyprint-literal-more" +} "The prettyprinter actually exposes a general source code output engine and is not limited to printing object structure." -{ $subsection "prettyprint-sections" } ; +{ $subsections "prettyprint-sections" } ; ARTICLE: "prettyprint" "The prettyprinter" "One of Factor's key features is the ability to print almost any object as a valid source literal expression. This greatly aids debugging and provides the building blocks for light-weight object serialization facilities." @@ -142,23 +164,31 @@ $nl "Prettyprinter words are found in the " { $vocab-link "prettyprint" } " vocabulary." $nl "The key words to print an object to " { $link output-stream } "; the first two emit a trailing newline, the second two do not:" -{ $subsection . } -{ $subsection short. } -{ $subsection pprint } -{ $subsection pprint-short } -{ $subsection pprint-use } +{ $subsections + . + short. + pprint + pprint-short + pprint-use +} "The string representation of an object can be requested:" -{ $subsection unparse } -{ $subsection unparse-use } +{ $subsections + unparse + unparse-use +} "Utility for tabular output:" -{ $subsection pprint-cell } +{ $subsections pprint-cell } "More prettyprinter usage:" -{ $subsection "prettyprint-numbers" } -{ $subsection "prettyprint-stacks" } +{ $subsections + "prettyprint-numbers" + "prettyprint-stacks" +} "Prettyprinter customization:" -{ $subsection "prettyprint-variables" } -{ $subsection "prettyprint-extension" } -{ $subsection "prettyprint-limitations" } +{ $subsections + "prettyprint-variables" + "prettyprint-extension" + "prettyprint-limitations" +} { $see-also "number-strings" "see" } ; ABOUT: "prettyprint" diff --git a/basis/prettyprint/stylesheet/stylesheet-docs.factor b/basis/prettyprint/stylesheet/stylesheet-docs.factor index 4f7a7f2141..60014514af 100644 --- a/basis/prettyprint/stylesheet/stylesheet-docs.factor +++ b/basis/prettyprint/stylesheet/stylesheet-docs.factor @@ -35,10 +35,12 @@ ARTICLE: "prettyprint.stylesheet" "Prettyprinter Formatted Output" { $vocab-link "prettyprint.stylesheet" } $nl "Control the way that the prettyprinter formats output based on object type. These hooks form a basic \"syntax\" highlighting system." -{ $subsection word-style } -{ $subsection string-style } -{ $subsection vocab-style } -{ $subsection effect-style } +{ $subsections + word-style + string-style + vocab-style + effect-style +} ; ABOUT: "prettyprint.stylesheet" diff --git a/basis/prettyprint/stylesheet/stylesheet.factor b/basis/prettyprint/stylesheet/stylesheet.factor index a593f23d99..42a701d60f 100644 --- a/basis/prettyprint/stylesheet/stylesheet.factor +++ b/basis/prettyprint/stylesheet/stylesheet.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Keith Lazuka. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs colors.constants combinators +USING: assocs colors colors.constants combinators combinators.short-circuit hashtables io.styles kernel literals namespaces sequences words words.symbol ; IN: prettyprint.stylesheet @@ -43,4 +43,4 @@ PRIVATE> dim-color colored-presentation-style ; : effect-style ( effect -- style ) - COLOR: DarkGreen colored-presentation-style ; + presented associate stack-effect-style get assoc-union ; diff --git a/basis/quoted-printable/quoted-printable-docs.factor b/basis/quoted-printable/quoted-printable-docs.factor index 81219a3f84..bbed5458ce 100644 --- a/basis/quoted-printable/quoted-printable-docs.factor +++ b/basis/quoted-printable/quoted-printable-docs.factor @@ -7,9 +7,11 @@ ABOUT: "quoted-printable" ARTICLE: "quoted-printable" "Quoted printable encoding" "The " { $vocab-link "quoted-printable" } " vocabulary implements RFC 2045 part 6.7, providing words for reading and generating quotable printed text." -{ $subsection >quoted } -{ $subsection >quoted-lines } -{ $subsection quoted> } ; +{ $subsections + >quoted + >quoted-lines + quoted> +} ; HELP: >quoted { $values { "byte-array" byte-array } { "string" string } } diff --git a/basis/quoted-printable/quoted-printable-tests.factor b/basis/quoted-printable/quoted-printable-tests.factor index abaff9e222..e258cb9a96 100644 --- a/basis/quoted-printable/quoted-printable-tests.factor +++ b/basis/quoted-printable/quoted-printable-tests.factor @@ -1,24 +1,24 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test quoted-printable multiline io.encodings.string +USING: tools.test quoted-printable io.encodings.string sequences io.encodings.8-bit splitting kernel ; IN: quoted-printable.tests -[ <" JosÃ© was the +[ """JosÃ© was the person who knew how to write the letters: Å and Ã¼ -and we didn't know hÃ³w tÃ¶ do thÃ¢t"> ] -[ <" Jos=E9 was the +and we didn't know hÃ³w tÃ¶ do thÃ¢t""" ] +[ """Jos=E9 was the person who knew how to write the letters: =F5 and =FC=20 and w= -e didn't know h=F3w t=F6 do th=E2t"> quoted> latin2 decode ] unit-test +e didn't know h=F3w t=F6 do th=E2t""" quoted> latin2 decode ] unit-test -[ <" Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t"> ] -[ <" JosÃ© was the +[ """Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t""" ] +[ """JosÃ© was the person who knew how to write the letters: Å and Ã¼ -and we didn't know hÃ³w tÃ¶ do thÃ¢t"> latin2 encode >quoted ] unit-test +and we didn't know hÃ³w tÃ¶ do thÃ¢t""" latin2 encode >quoted ] unit-test : message ( -- str ) 55 [ "hello" ] replicate concat ; diff --git a/basis/random/dummy/dummy-tests.factor b/basis/random/dummy/dummy-tests.factor new file mode 100644 index 0000000000..5d4b4b5473 --- /dev/null +++ b/basis/random/dummy/dummy-tests.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: random random.dummy tools.test ; +IN: random.dummy.tests + +[ 10 ] [ 10 <random-dummy> random-32* ] unit-test +[ 100 ] [ 10 <random-dummy> 100 seed-random random-32* ] unit-test diff --git a/basis/random/dummy/dummy.factor b/basis/random/dummy/dummy.factor index e6661dc078..988bd015d0 100644 --- a/basis/random/dummy/dummy.factor +++ b/basis/random/dummy/dummy.factor @@ -4,8 +4,8 @@ IN: random.dummy TUPLE: random-dummy i ; C: <random-dummy> random-dummy -M: random-dummy seed-random ( seed obj -- ) - (>>i) ; +M: random-dummy seed-random ( obj seed -- obj ) + >>i ; M: random-dummy random-32* ( obj -- r ) [ dup 1 + ] change-i drop ; diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor index 651e43ef5b..b877af6f79 100644 --- a/basis/random/mersenne-twister/mersenne-twister-tests.factor +++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor @@ -27,3 +27,9 @@ IN: random.mersenne-twister.tests [ 3 ] [ 101 [ 3 random-bytes length ] test-rng ] unit-test [ 33 ] [ 101 [ 33 random-bytes length ] test-rng ] unit-test [ t ] [ 101 [ 100 random-bits log2 90 > ] test-rng ] unit-test + +[ t ] +[ + 1234 <mersenne-twister> + [ random-32* ] [ 1234 seed-random random-32* ] bi = +] unit-test diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 3a44066caf..a0e40e5c38 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! mersenne twister based on ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c -USING: kernel math namespaces sequences sequences.private system -init accessors math.ranges random math.bitwise combinators -specialized-arrays fry ; +USING: alien.c-types kernel math namespaces sequences +sequences.private system init accessors math.ranges random +math.bitwise combinators specialized-arrays fry ; SPECIALIZED-ARRAY: uint IN: random.mersenne-twister @@ -62,15 +62,22 @@ PRIVATE> init-mt-seq 0 mersenne-twister boa dup mt-generate ; -M: mersenne-twister seed-random ( mt seed -- ) - init-mt-seq >>seq drop ; +M: mersenne-twister seed-random ( mt seed -- mt' ) + init-mt-seq >>seq + [ mt-generate ] + [ 0 >>i drop ] + [ ] tri ; M: mersenne-twister random-32* ( mt -- r ) [ next-index ] [ seq>> nth-unsafe mt-temper ] [ [ 1 + ] change-i drop ] tri ; -[ +: default-mersenne-twister ( -- mersenne-twister ) [ 32 random-bits ] with-system-random - <mersenne-twister> random-generator set-global + <mersenne-twister> ; + +[ + default-mersenne-twister random-generator set-global ] "bootstrap.random" add-init-hook + diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index 222ecaf935..59df4f6e27 100755 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -2,8 +2,12 @@ USING: help.markup help.syntax math kernel sequences ; IN: random HELP: seed-random -{ $values { "tuple" "a random number generator" } { "seed" "an integer between 0 and 2^32-1" } } -{ $description "Seed the random number generator." } +{ $values + { "tuple" "a random number generator" } + { "seed" "a seed specific to the random number generator" } + { "tuple'" "a random number generator" } +} +{ $description "Seed the random number generator. Repeatedly seeding the random number generator should provide the same sequence of random numbers." } { $notes "Not supported on all random number generators." } ; HELP: random-32* @@ -29,6 +33,10 @@ HELP: random "heads" } } ; +HELP: random-32 +{ $values { "n" "a 32-bit random integer" } } +{ $description "Outputs 32 random bits. This word is more efficient than calling " { $link random } " because no scaling is done on the output." } ; + HELP: random-bytes { $values { "n" "an integer" } { "byte-array" "a random integer" } } { $description "Outputs an integer with n bytes worth of bits." } @@ -72,6 +80,18 @@ HELP: randomize } { $description "Randomizes a sequence in-place with the Fisher-Yates algorithm and returns the sequence." } ; +HELP: sample +{ $values + { "seq" sequence } { "n" integer } + { "seq'" sequence } +} +{ $description "Takes " { $snippet "n" } " samples at random without replacement from a sequence. Throws an error if " { $snippet "n" } " is longer than the sequence." } +{ $examples + { $unchecked-example "USING: random prettyprint ; { 1 2 3 } 2 sample ." + "{ 3 2 }" + } +} ; + HELP: delete-random { $values { "seq" sequence } @@ -80,10 +100,12 @@ HELP: delete-random ARTICLE: "random-protocol" "Random protocol" "A random number generator must implement one of these two words:" -{ $subsection random-32* } -{ $subsection random-bytes* } +{ $subsections + random-32* + random-bytes* +} "Optional, to seed a random number generator:" -{ $subsection seed-random } ; +{ $subsections seed-random } ; ARTICLE: "random" "Generating random integers" "The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers." @@ -91,19 +113,27 @@ $nl "The âMersenne Twisterâ pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "." $nl "Generate a random object:" -{ $subsection random } +{ $subsections random } +"Efficient 32-bit random numbers:" +{ $subsections random-32 } "Combinators to change the random number generator:" -{ $subsection with-random } -{ $subsection with-system-random } -{ $subsection with-secure-random } +{ $subsections + with-random + with-system-random + with-secure-random +} "Implementation:" -{ $subsection "random-protocol" } +{ $subsections "random-protocol" } "Randomizing a sequence:" -{ $subsection randomize } +{ $subsections randomize } +"Sampling a sequences:" +{ $subsections sample } "Deleting a random element from a sequence:" -{ $subsection delete-random } +{ $subsections delete-random } "Random numbers with " { $snippet "n" } " bits:" -{ $subsection random-bits } -{ $subsection random-bits* } ; +{ $subsections + random-bits + random-bits* +} ; ABOUT: "random" diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index 2b6ac9b1b8..96dc8cc783 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -25,3 +25,11 @@ IN: random.tests [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test [ 49 ] [ 50 random-bits* log2 ] unit-test + +[ { 1 2 } 3 sample ] [ too-many-samples? ] must-fail-with + +[ 3 ] [ { 1 2 3 4 } 3 sample prune length ] unit-test +[ 99 ] [ 100 99 sample prune length ] unit-test + +[ ] +[ [ 100 random-bytes ] with-system-random drop ] unit-test diff --git a/basis/random/random.factor b/basis/random/random.factor index 4c94e87928..197c232404 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -1,16 +1,16 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel math namespaces sequences -io.backend io.binary combinators system vocabs.loader -summary math.bitwise byte-vectors fry byte-arrays -math.ranges math.constants math.functions accessors ; +USING: accessors alien.c-types assocs byte-arrays byte-vectors +combinators fry io.backend io.binary kernel locals math +math.bitwise math.constants math.functions math.ranges +namespaces sequences sets summary system vocabs.loader ; IN: random SYMBOL: system-random-generator SYMBOL: secure-random-generator SYMBOL: random-generator -GENERIC: seed-random ( tuple seed -- ) +GENERIC# seed-random 1 ( tuple seed -- tuple' ) GENERIC: random-32* ( tuple -- r ) GENERIC: random-bytes* ( n tuple -- byte-array ) @@ -22,7 +22,7 @@ M: object random-bytes* ( n tuple -- byte-array ) [ 2drop ] [ random-32* 4 >le swap head over push-all ] if ] bi-curry bi* ; -M: object random-32* ( tuple -- r ) 4 random-bytes* le> ; +M: object random-32* ( tuple -- r ) 4 swap random-bytes* le> ; ERROR: no-random-number-generator ; @@ -55,11 +55,32 @@ PRIVATE> [ length random-integer ] keep nth ] if-empty ; +: random-32 ( -- n ) random-generator get random-32* ; + : randomize ( seq -- seq ) dup length [ dup 1 > ] [ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ] while drop ; +ERROR: too-many-samples seq n ; + +<PRIVATE + +:: next-sample ( length n seq hashtable -- elt ) + n hashtable key? [ + length n 1 + length mod seq hashtable next-sample + ] [ + n hashtable conjoin + n seq nth + ] if ; + +PRIVATE> + +: sample ( seq n -- seq' ) + 2dup [ length ] dip < [ too-many-samples ] when + swap [ length ] [ ] bi H{ } clone + '[ _ dup random _ _ next-sample ] replicate ; + : delete-random ( seq -- elt ) [ length random-integer ] keep [ nth ] 2keep delete-nth ; diff --git a/basis/random/sfmt/authors.txt b/basis/random/sfmt/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/random/sfmt/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/random/sfmt/sfmt-tests.factor b/basis/random/sfmt/sfmt-tests.factor new file mode 100644 index 0000000000..f7b75c3f13 --- /dev/null +++ b/basis/random/sfmt/sfmt-tests.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel random random.sfmt random.sfmt.private +sequences tools.test ; +IN: random.sfmt.tests + +! Period certified by virtue of seed +[ ] [ 5 <sfmt-19937> drop ] unit-test + +[ 1331696015 ] +[ 5 <sfmt-19937> dup generate dup generate uint-array>> first ] unit-test + +[ 1432875926 ] +[ 5 <sfmt-19937> random-32* ] unit-test + + +! Period certified by flipping a bit +[ ] [ 7 <sfmt-19937> drop ] unit-test + +[ 1674111379 ] +[ 7 <sfmt-19937> dup generate dup generate uint-array>> first ] unit-test + +[ 489955657 ] +[ 7 <sfmt-19937> random-32* ] unit-test + + +! Test re-seeding SFMT +[ t ] +[ + 100 <sfmt-19937> + [ random-32* ] + [ 100 seed-random random-32* ] bi = +] unit-test diff --git a/basis/random/sfmt/sfmt.factor b/basis/random/sfmt/sfmt.factor new file mode 100644 index 0000000000..28883838ce --- /dev/null +++ b/basis/random/sfmt/sfmt.factor @@ -0,0 +1,157 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types kernel locals math math.ranges +math.bitwise math.vectors math.vectors.simd random +sequences specialized-arrays sequences.private classes.struct +combinators.short-circuit fry ; +SIMD: uint +SPECIALIZED-ARRAY: uint +SPECIALIZED-ARRAY: uint-4 +IN: random.sfmt + +<PRIVATE + +CONSTANT: state-multiplier 1812433253 + +STRUCT: sfmt-state + { seed uint } + { n uint } + { m uint } + { index uint } + { mask uint-4 } + { parity uint-4 } + { r1 uint-4 } + { r2 uint-4 } ; + +TUPLE: sfmt + { state sfmt-state } + { uint-array uint-array } + { uint-4-array uint-4-array } ; + +: wA ( w -- wA ) + dup 1 hlshift vbitxor ; inline + +: wB ( w mask -- wB ) + [ 11 vrshift ] dip vbitand ; inline + +: wC ( w -- wC ) + 1 hrshift ; inline + +: wD ( w -- wD ) + 18 vlshift ; inline + +: formula ( a b mask c d -- r ) + [ wC ] dip wD vbitxor + [ wB ] dip vbitxor + [ wA ] dip vbitxor ; inline + +GENERIC: generate ( sfmt -- ) + +M:: sfmt generate ( sfmt -- ) + sfmt state>> :> state + sfmt uint-4-array>> :> array + state n>> 2 - array nth state (>>r1) + state n>> 1 - array nth state (>>r2) + state m>> :> m + state n>> :> n + state mask>> :> mask + + n m - >fixnum iota [| i | + i array nth-unsafe + i m + array nth-unsafe + mask state r1>> state r2>> formula :> r + + r i array set-nth-unsafe + state r2>> state (>>r1) + r state (>>r2) + ] each + + ! n m - 1 + n [a,b) [ + m 1 - iota [ + n m - 1 + + >fixnum :> i + i array nth-unsafe + m n - i + array nth-unsafe + mask state r1>> state r2>> formula :> r + + r i array set-nth-unsafe + state r2>> state (>>r1) + r state (>>r2) + ] each + + 0 state (>>index) ; + +: period-certified? ( sfmt -- ? ) + [ uint-4-array>> first ] + [ state>> parity>> ] bi vbitand odd-parity? ; + +: first-set-bit ( x -- n ) + 0 swap [ + dup { [ 0 > ] [ 1 bitand 0 = ] } 1&& + ] [ + [ 1 + ] [ -1 shift ] bi* + ] while drop ; + +: correct-period ( sfmt -- ) + [ drop 0 ] + [ state>> parity>> first first-set-bit ] + [ uint-array>> swap '[ _ toggle-bit ] change-nth ] tri ; + +: certify-period ( sfmt -- sfmt ) + dup period-certified? [ dup correct-period ] unless ; + +: <sfmt-array> ( sfmt -- uint-array uint-4-array ) + state>> + [ n>> 4 * 1 swap [a,b] >uint-array ] [ seed>> ] bi + [ + [ + [ -30 shift ] [ ] bi bitxor + state-multiplier * 32 bits + ] dip + 32 bits + ] uint-array{ } accumulate-as nip + dup underlying>> byte-array>uint-4-array ; + +: <sfmt-state> ( seed n m mask parity -- sfmt ) + sfmt-state <struct> + swap >>parity + swap >>mask + swap >>m + swap >>n + swap >>seed + 0 >>index ; + +: init-sfmt ( sfmt -- sfmt' ) + dup <sfmt-array> [ >>uint-array ] [ >>uint-4-array ] bi* + certify-period [ generate ] keep ; inline + +: <sfmt> ( seed n m mask parity -- sfmt ) + <sfmt-state> + sfmt new + swap >>state + init-sfmt ; inline + +: refill-sfmt? ( sfmt -- ? ) + state>> [ index>> ] [ n>> 4 * ] bi >= ; inline + +: next-index ( sfmt -- index ) + state>> [ dup 1 + ] change-index drop ; inline + +: next ( sfmt -- n ) + [ next-index ] [ uint-array>> ] bi nth-unsafe ; inline + +PRIVATE> + +M: sfmt random-32* ( sfmt -- n ) + dup refill-sfmt? [ dup generate ] when next ; inline + +M: sfmt seed-random ( sfmt seed -- sfmt ) + [ [ state>> ] dip >>seed drop ] + [ drop init-sfmt ] 2bi ; + +: <sfmt-19937> ( seed -- sfmt ) + 156 122 + uint-4{ HEX: dfffffef HEX: ddfecb7f HEX: bffaffff HEX: bffffff6 } + uint-4{ HEX: 1 HEX: 0 HEX: 0 HEX: 13c9e684 } + <sfmt> ; inline + +: default-sfmt ( -- sfmt ) + [ random-32 ] with-secure-random <sfmt-19937> ; diff --git a/basis/refs/refs-docs.factor b/basis/refs/refs-docs.factor index 9971a1d4fa..8fe7797627 100755 --- a/basis/refs/refs-docs.factor +++ b/basis/refs/refs-docs.factor @@ -5,47 +5,63 @@ IN: refs ARTICLE: "refs" "References" "References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing a protocol." -{ $subsection "refs-protocol" } -{ $subsection "refs-impls" } -{ $subsection "refs-utils" } +{ $subsections + "refs-protocol" + "refs-impls" + "refs-utils" +} "References are used by the " { $link "ui-inspector" } "." ; ABOUT: "refs" ARTICLE: "refs-impls" "Reference implementations" "References to objects:" -{ $subsection obj-ref } -{ $subsection <obj-ref> } +{ $subsections + obj-ref + <obj-ref> +} "References to assoc keys:" -{ $subsection key-ref } -{ $subsection <key-ref> } +{ $subsections + key-ref + <key-ref> +} "References to assoc values:" -{ $subsection value-ref } -{ $subsection <value-ref> } +{ $subsections + value-ref + <value-ref> +} "References to variables:" -{ $subsection var-ref } -{ $subsection <var-ref> } -{ $subsection global-var-ref } -{ $subsection <global-var-ref> } +{ $subsections + var-ref + <var-ref> + global-var-ref + <global-var-ref> +} "References to tuple slots:" -{ $subsection slot-ref } -{ $subsection <slot-ref> } +{ $subsections + slot-ref + <slot-ref> +} "Using boxes as references:" -{ $subsection "box-refs" } ; +{ $subsections "box-refs" } ; ARTICLE: "refs-utils" "Reference utilities" -{ $subsection ref-on } -{ $subsection ref-off } -{ $subsection ref-inc } -{ $subsection ref-dec } -{ $subsection set-ref* } ; +{ $subsections + ref-on + ref-off + ref-inc + ref-dec + set-ref* +} ; ARTICLE: "refs-protocol" "Reference protocol" "To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:" -{ $subsection get-ref } -{ $subsection set-ref } +{ $subsections + get-ref + set-ref +} "References may also implement:" -{ $subsection delete-ref } ; +{ $subsections delete-ref } ; ARTICLE: "box-refs" "Boxes as references" { $link "boxes" } " are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ; diff --git a/basis/regexp/combinators/combinators-docs.factor b/basis/regexp/combinators/combinators-docs.factor index a49b16b585..20d5624025 100644 --- a/basis/regexp/combinators/combinators-docs.factor +++ b/basis/regexp/combinators/combinators-docs.factor @@ -18,20 +18,21 @@ ARTICLE: "regexp.combinators.intro" "Regular expression combinator rationale" ARTICLE: "regexp.combinators" "Regular expression combinators" "The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This complements the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary." -{ $subsection "regexp.combinators.intro" } +{ $subsections "regexp.combinators.intro" } "Basic combinators:" -{ $subsection <literal> } -{ $subsection <nothing> } +{ $subsections <literal> <nothing> } "Higher-order combinators for building new regular expressions from existing ones:" -{ $subsection <or> } -{ $subsection <and> } -{ $subsection <not> } -{ $subsection <sequence> } -{ $subsection <zero-or-more> } +{ $subsections + <or> + <and> + <not> + <sequence> + <zero-or-more> +} "Derived combinators implemented in terms of the above:" -{ $subsection <one-or-more> } +{ $subsections <one-or-more> } "Setting options:" -{ $subsection <option> } ; +{ $subsections <option> } ; HELP: <literal> { $values { "string" string } { "regexp" regexp } } diff --git a/basis/regexp/regexp-docs.factor b/basis/regexp/regexp-docs.factor index 3eb4e8a9bf..45b61821a4 100644 --- a/basis/regexp/regexp-docs.factor +++ b/basis/regexp/regexp-docs.factor @@ -1,25 +1,29 @@ ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel strings help.markup help.syntax math regexp.parser -regexp.ast multiline ; +regexp.ast ; IN: regexp ABOUT: "regexp" ARTICLE: "regexp" "Regular expressions" "The " { $vocab-link "regexp" } " vocabulary provides word for creating and using regular expressions." -{ $subsection { "regexp" "intro" } } +{ $subsections { "regexp" "intro" } } "The class of regular expressions:" -{ $subsection regexp } +{ $subsections regexp } "Basic usage:" -{ $subsection { "regexp" "syntax" } } -{ $subsection { "regexp" "options" } } -{ $subsection { "regexp" "construction" } } -{ $subsection { "regexp" "operations" } } +{ $subsections + { "regexp" "syntax" } + { "regexp" "options" } + { "regexp" "construction" } + { "regexp" "operations" } +} "Advanced topics:" { $vocab-subsection "Regular expression combinators" "regexp.combinators" } -{ $subsection { "regexp" "theory" } } -{ $subsection { "regexp" "deploy" } } ; +{ $subsections + { "regexp" "theory" } + { "regexp" "deploy" } +} ; ARTICLE: { "regexp" "intro" } "A quick introduction to regular expressions" "Regular expressions are a terse way to do certain simple string processing tasks. For example, to replace all instances of " { $snippet "foo" } " in one string with " { $snippet "bar" } ", the following can be used:" @@ -29,17 +33,16 @@ ARTICLE: { "regexp" "intro" } "A quick introduction to regular expressions" "The " { $snippet "+" } " operator matches one or more occurrences of the previous expression; in this case " { $snippet "o" } ". Another useful feature is alternation. Say we want to do this replacement with fooooo or boooo. Then we could use the code" { $code "R/ (f|b)oo+/ \"bar\" re-replace" } "To search a file for all lines that match a given regular expression, you could use code like this:" -{ $code <" "file.txt" ascii file-lines [ R/ (f|b)oo+/ re-contains? ] filter "> } +{ $code """"file.txt" ascii file-lines [ R/ (f|b)oo+/ re-contains? ] filter""" } "To test if a string in its entirety matches a regular expression, the following can be used:" -{ $example <" USE: regexp "fooo" R/ (b|f)oo+/ matches? . "> "t" } +{ $example """USE: regexp "fooo" R/ (b|f)oo+/ matches? .""" "t" } "Regular expressions can't be used for all parsing tasks. For example, they are not powerful enough to match balancing parentheses." ; ARTICLE: { "regexp" "construction" } "Constructing regular expressions" "Most of the time, regular expressions are literals and the parsing word should be used, to construct them at parse time. This ensures that they are only compiled once, and gives parse time syntax checking." -{ $subsection POSTPONE: R/ } +{ $subsections POSTPONE: R/ } "Sometimes, regular expressions need to be constructed at run time instead; for example, in a text editor, the user might input a regular expression to search for in a document." -{ $subsection <regexp> } -{ $subsection <optioned-regexp> } +{ $subsections <regexp> <optioned-regexp> } "Another approach is to use " { $vocab-link "regexp.combinators" } "." ; ARTICLE: { "regexp" "syntax" } "Regular expression syntax" @@ -167,18 +170,19 @@ ARTICLE: { "regexp" "theory" } "The theory of regular expressions" ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions" "Testing if a string matches a regular expression:" -{ $subsection matches? } +{ $subsections matches? } "Finding a match inside a string:" -{ $subsection re-contains? } -{ $subsection first-match } +{ $subsections re-contains? first-match } "Finding all matches inside a string:" -{ $subsection count-matches } -{ $subsection all-matching-slices } -{ $subsection all-matching-subseqs } +{ $subsections + count-matches + all-matching-slices + all-matching-subseqs +} "Splitting a string into tokens delimited by a regular expression:" -{ $subsection re-split } +{ $subsections re-split } "Replacing occurrences of a regular expression with a string:" -{ $subsection re-replace } ; +{ $subsections re-replace } ; ARTICLE: { "regexp" "deploy" } "Regular expressions and the deploy tool" "The " { $link "tools.deploy" } " tool has the option to strip out the optimizing compiler from the resulting image. Since regular expressions compile to Factor code, this creates a minor performance-related caveat." diff --git a/basis/roman/roman-docs.factor b/basis/roman/roman-docs.factor index bef0ab90fc..50a057d7f4 100644 --- a/basis/roman/roman-docs.factor +++ b/basis/roman/roman-docs.factor @@ -104,17 +104,21 @@ HELP: ROMAN: ARTICLE: "roman" "Roman numerals" "The " { $vocab-link "roman" } " vocabulary can convert numbers to and from the Roman numeral system and can perform arithmetic given Roman numerals as input." $nl "A parsing word for literal Roman numerals:" -{ $subsection POSTPONE: ROMAN: } +{ $subsections POSTPONE: ROMAN: } "Converting to Roman numerals:" -{ $subsection >roman } -{ $subsection >ROMAN } +{ $subsections + >roman + >ROMAN +} "Converting Roman numerals to integers:" -{ $subsection roman> } +{ $subsections roman> } "Roman numeral arithmetic:" -{ $subsection roman+ } -{ $subsection roman- } -{ $subsection roman* } -{ $subsection roman/i } -{ $subsection roman/mod } ; +{ $subsections + roman+ + roman- + roman* + roman/i + roman/mod +} ; ABOUT: "roman" diff --git a/basis/search-deques/search-deques-docs.factor b/basis/search-deques/search-deques-docs.factor index c20e67d13c..1d50e99c7e 100644 --- a/basis/search-deques/search-deques-docs.factor +++ b/basis/search-deques/search-deques-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "search-deques" "Search deques" "A search deque is a data structure with constant-time insertion and removal of elements at both ends, and constant-time membership tests. Inserting an element more than once has no effect. Search deques implement all deque operations in terms of an underlying deque, and membership testing with " { $link deque-member? } " is implemented with an underlying assoc. Search deques are defined in the " { $vocab-link "search-deques" } " vocabulary." $nl "Creating a search deque:" -{ $subsection <search-deque> } ; +{ $subsections <search-deque> } ; ABOUT: "search-deques" diff --git a/basis/see/see-docs.factor b/basis/see/see-docs.factor index 1674c9a747..d872be0ca6 100644 --- a/basis/see/see-docs.factor +++ b/basis/see/see-docs.factor @@ -53,11 +53,13 @@ ARTICLE: "see" "Printing definitions" "The " { $vocab-link "see" } " vocabulary implements support for printing out " { $link "definitions" } " in the image." $nl "Printing a definition:" -{ $subsection see } +{ $subsections see } "Printing the methods defined on a generic word or class (see " { $link "objects" } "):" -{ $subsection see-methods } +{ $subsections see-methods } "Definition specifiers implementing the " { $link "definition-protocol" } " should also implement the " { $emphasis "see protocol" } ":" -{ $subsection see* } -{ $subsection synopsis* } ; +{ $subsections + see* + synopsis* +} ; ABOUT: "see" \ No newline at end of file diff --git a/basis/sequences/complex-components/complex-components-docs.factor b/basis/sequences/complex-components/complex-components-docs.factor index 386735aa7d..427279d8f3 100644 --- a/basis/sequences/complex-components/complex-components-docs.factor +++ b/basis/sequences/complex-components/complex-components-docs.factor @@ -1,35 +1,34 @@ -USING: help.markup help.syntax math multiline +USING: help.markup help.syntax math sequences sequences.complex-components ; IN: sequences.complex-components ARTICLE: "sequences.complex-components" "Complex component virtual sequences" "The " { $link complex-components } " class wraps a sequence of " { $link complex } " number values, presenting a sequence of " { $link real } " values made by interleaving the real and imaginary parts of the complex values in the original sequence." -{ $subsection complex-components } -{ $subsection <complex-components> } ; +{ $subsections + complex-components + <complex-components> +} ; ABOUT: "sequences.complex-components" HELP: complex-components { $class-description "Sequence wrapper class that transforms a sequence of " { $link complex } " number values into a sequence of " { $link real } " values, interleaving the real and imaginary parts of the complex values in the original sequence." } -{ $examples { $example <" -USING: prettyprint sequences arrays sequences.complex-components ; -{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> >array . -"> "{ 1.0 -1.0 -2.0 0 3.0 1.0 }" } } ; +{ $examples { $example """USING: prettyprint sequences arrays sequences.complex-components ; +{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> >array .""" +"{ 1.0 -1.0 -2.0 0 3.0 1.0 }" } } ; HELP: <complex-components> { $values { "sequence" sequence } { "complex-components" complex-components } } { $description "Wraps " { $snippet "sequence" } " in a " { $link complex-components } " wrapper." } { $examples -{ $example <" -USING: prettyprint sequences arrays +{ $example """USING: prettyprint sequences arrays sequences.complex-components ; -{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> third . -"> "-2.0" } -{ $example <" -USING: prettyprint sequences arrays +{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> third .""" +"-2.0" } +{ $example """USING: prettyprint sequences arrays sequences.complex-components ; -{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> fourth . -"> "0" } +{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> fourth .""" +"0" } } ; { complex-components <complex-components> } related-words diff --git a/basis/sequences/complex/complex-docs.factor b/basis/sequences/complex/complex-docs.factor index 699fd5c4d9..f92d2aa113 100644 --- a/basis/sequences/complex/complex-docs.factor +++ b/basis/sequences/complex/complex-docs.factor @@ -1,31 +1,31 @@ -USING: help.markup help.syntax math multiline -sequences sequences.complex ; +USING: help.markup help.syntax math sequences +sequences.complex ; IN: sequences.complex ARTICLE: "sequences.complex" "Complex virtual sequences" "The " { $link complex-sequence } " class wraps a sequence of " { $link real } " number values, presenting a sequence of " { $link complex } " values made by treating the underlying sequence as pairs of alternating real and imaginary values." -{ $subsection complex-sequence } -{ $subsection <complex-sequence> } ; +{ $subsections + complex-sequence + <complex-sequence> +} ; ABOUT: "sequences.complex" HELP: complex-sequence { $class-description "Sequence wrapper class that transforms a sequence of " { $link real } " number values into a sequence of " { $link complex } " values, treating the underlying sequence as pairs of alternating real and imaginary values." } -{ $examples { $example <" -USING: prettyprint specialized-arrays -sequences.complex sequences arrays ; +{ $examples { $example """USING: prettyprint specialized-arrays +sequences.complex sequences alien.c-types arrays ; SPECIALIZED-ARRAY: double -double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array . -"> "{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ; +double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array .""" +"{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ; HELP: <complex-sequence> { $values { "sequence" sequence } { "complex-sequence" complex-sequence } } { $description "Wraps " { $snippet "sequence" } " in a " { $link complex-sequence } "." } -{ $examples { $example <" -USING: prettyprint specialized-arrays -sequences.complex sequences arrays ; +{ $examples { $example """USING: prettyprint specialized-arrays +sequences.complex sequences alien.c-types arrays ; SPECIALIZED-ARRAY: double -double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second . -"> "C{ -2.0 2.0 }" } } ; +double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second .""" +"C{ -2.0 2.0 }" } } ; { complex-sequence <complex-sequence> } related-words diff --git a/basis/sequences/complex/complex-tests.factor b/basis/sequences/complex/complex-tests.factor index 04a80c6bee..0cb0b41a78 100644 --- a/basis/sequences/complex/complex-tests.factor +++ b/basis/sequences/complex/complex-tests.factor @@ -1,6 +1,7 @@ USING: specialized-arrays sequences.complex kernel sequences tools.test arrays accessors ; -SPECIALIZED-ARRAY: float +QUALIFIED-WITH: alien.c-types c +SPECIALIZED-ARRAY: c:float IN: sequences.complex.tests : test-array ( -- x ) diff --git a/basis/sequences/deep/deep-docs.factor b/basis/sequences/deep/deep-docs.factor index 6193c7a7e8..ae9d67e29c 100755 --- a/basis/sequences/deep/deep-docs.factor +++ b/basis/sequences/deep/deep-docs.factor @@ -37,13 +37,15 @@ HELP: deep-change-each ARTICLE: "sequences.deep" "Deep sequence combinators" "The combinators in the " { $vocab-link "sequences.deep" } " vocabulary are variants of standard sequence combinators which traverse nested subsequences." -{ $subsection deep-each } -{ $subsection deep-map } -{ $subsection deep-filter } -{ $subsection deep-find } -{ $subsection deep-any? } -{ $subsection deep-change-each } +{ $subsections + deep-each + deep-map + deep-filter + deep-find + deep-any? + deep-change-each +} "A utility word to collapse nested subsequences:" -{ $subsection flatten } ; +{ $subsections flatten } ; ABOUT: "sequences.deep" diff --git a/basis/serialize/serialize-docs.factor b/basis/serialize/serialize-docs.factor index 34922a5eae..7ba57d819d 100644 --- a/basis/serialize/serialize-docs.factor +++ b/basis/serialize/serialize-docs.factor @@ -25,10 +25,14 @@ ARTICLE: "serialize" "Binary object serialization" "The " { $vocab-link "serialize" } " vocabulary implements binary serialization for all Factor data types except for continuations. Unlike the prettyprinter, shared structure and circularity is preserved." $nl "Storing objects on streams:" -{ $subsection serialize } -{ $subsection deserialize } +{ $subsections + serialize + deserialize +} "Storing objects as byte arrays:" -{ $subsection object>bytes } -{ $subsection bytes>object } ; +{ $subsections + object>bytes + bytes>object +} ; ABOUT: "serialize" diff --git a/basis/serialize/serialize-tests.factor b/basis/serialize/serialize-tests.factor index 99c8adefb6..cebf69595f 100644 --- a/basis/serialize/serialize-tests.factor +++ b/basis/serialize/serialize-tests.factor @@ -4,7 +4,7 @@ USING: tools.test kernel serialize io io.streams.byte-array alien arrays byte-arrays bit-arrays specialized-arrays sequences math prettyprint parser classes math.constants -io.encodings.binary random assocs serialize.private ; +io.encodings.binary random assocs serialize.private alien.c-types ; SPECIALIZED-ARRAY: double IN: serialize.tests diff --git a/basis/simple-flat-file/simple-flat-file-docs.factor b/basis/simple-flat-file/simple-flat-file-docs.factor index 0223d94af9..49dc079803 100644 --- a/basis/simple-flat-file/simple-flat-file-docs.factor +++ b/basis/simple-flat-file/simple-flat-file-docs.factor @@ -7,9 +7,11 @@ ABOUT: "simple-flat-file" ARTICLE: "simple-flat-file" "Parsing simple flat files" "The " { $vocab-link "simple-flat-file" } " vocabulary provides words for loading and parsing simple flat files in a particular format which is common for encoding and Unicode tasks." -{ $subsection flat-file>biassoc } -{ $subsection load-interval-file } -{ $subsection data } ; +{ $subsections + flat-file>biassoc + load-interval-file + data +} ; HELP: load-interval-file { $values { "filename" string } { "table" "an interval map" } } diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor index 0b13113427..d079b8aaf7 100644 --- a/basis/smtp/smtp-docs.factor +++ b/basis/smtp/smtp-docs.factor @@ -93,20 +93,26 @@ ARTICLE: "smtp" "SMTP client library" "The " { $vocab-link "smtp" } " vocabulary sends e-mail via an SMTP server." $nl "This library is configured by a set of dynamically-scoped variables:" -{ $subsection smtp-server } -{ $subsection smtp-tls? } -{ $subsection smtp-read-timeout } -{ $subsection smtp-domain } -{ $subsection smtp-auth } +{ $subsections + smtp-server + smtp-tls? + smtp-read-timeout + smtp-domain + smtp-auth +} "The latter is set to an instance of one of the following:" -{ $subsection no-auth } -{ $subsection plain-auth } +{ $subsections + no-auth + plain-auth +} "Constructing an e-mail:" -{ $subsection email } -{ $subsection <email> } +{ $subsections + email + <email> +} "Sending an email:" -{ $subsection send-email } +{ $subsections send-email } "More topics:" -{ $subsection "smtp-gmail" } ; +{ $subsections "smtp-gmail" } ; ABOUT: "smtp" diff --git a/basis/sorting/human/human-docs.factor b/basis/sorting/human/human-docs.factor index 4bb62b1313..0f0bf169e6 100644 --- a/basis/sorting/human/human-docs.factor +++ b/basis/sorting/human/human-docs.factor @@ -28,9 +28,11 @@ HELP: human>=< ARTICLE: "sorting.human" "Human-friendly sorting" "The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl "Comparing two objects:" -{ $subsection human<=> } -{ $subsection human>=< } +{ $subsections + human<=> + human>=< +} "Splitting a string into substrings and integers:" -{ $subsection find-numbers } ; +{ $subsections find-numbers } ; ABOUT: "sorting.human" diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index beb378d4bd..7c9288631c 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -37,10 +37,12 @@ HELP: sort-by ARTICLE: "sorting.slots" "Sorting by slots" "The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl "Comparing two objects by a sequence of slots:" -{ $subsection compare-slots } +{ $subsections compare-slots } "Sorting a sequence of tuples by a slot/comparator pairs:" -{ $subsection sort-by } -{ $subsection sort-keys-by } -{ $subsection sort-values-by } ; +{ $subsections + sort-by + sort-keys-by + sort-values-by +} ; ABOUT: "sorting.slots" diff --git a/basis/specialized-arrays/specialized-arrays-docs.factor b/basis/specialized-arrays/specialized-arrays-docs.factor index bb5c7d38d6..50e94b65e9 100755 --- a/basis/specialized-arrays/specialized-arrays-docs.factor +++ b/basis/specialized-arrays/specialized-arrays-docs.factor @@ -6,8 +6,15 @@ HELP: SPECIALIZED-ARRAY: { $values { "type" "a C type" } } { $description "Brings a specialized array for holding values of " { $snippet "type" } " into the vocabulary search path. The generated words are documented in " { $link "specialized-array-words" } "." } ; +HELP: SPECIALIZED-ARRAYS: +{ $syntax "SPECIALIZED-ARRAYS: type type type ... ;" } +{ $values { "type" "a C type" } } +{ $description "Brings a set of specialized arrays for holding values of each " { $snippet "type" } " into the vocabulary search path. The generated words are documented in " { $link "specialized-array-words" } "." } ; + +{ POSTPONE: SPECIALIZED-ARRAY: POSTPONE: SPECIALIZED-ARRAYS: } related-words + ARTICLE: "specialized-array-words" "Specialized array words" -"The " { $link POSTPONE: SPECIALIZED-ARRAY: } " parsing word generates the specialized array type if it hasn't been generated already, and adds the following words to the vocabulary search path, where " { $snippet "T" } " is the C type in question:" +"The " { $link POSTPONE: SPECIALIZED-ARRAY: } " and " { $link POSTPONE: SPECIALIZED-ARRAYS: } " parsing words generate specialized array types if they haven't been generated already and add the following words to the vocabulary search path, where " { $snippet "T" } " is the C type in question:" { $table { { $snippet "T-array" } { "The class of arrays with elements of type " { $snippet "T" } } } { { $snippet "<T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( len -- array )" } } } @@ -18,9 +25,48 @@ ARTICLE: "specialized-array-words" "Specialized array words" { { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } } { { $snippet "T-array{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } } } -"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-arrays.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-ARRAY: } ". This ensures that the vocabulary can get generated the first time it is needed." ; +"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-arrays.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-ARRAY: } " or " { $link POSTPONE: SPECIALIZED-ARRAYS: } ". This ensures that the vocabulary can get generated the first time it is needed." ; ARTICLE: "specialized-array-c" "Passing specialized arrays to C functions" +"If a C function is declared as taking a parameter with a pointer or an array type (for example, " { $snippet "float*" } " or " { $snippet "int[3]" } "), instances of the relevant specialized array can be passed in." +$nl +"C type specifiers for array types are documented in " { $link "c-types-specs" } "." +$nl +"Here is an example; as is common with C functions, the array length is passed in separately, since C does not offer a runtime facility to determine the array length of a base pointer:" +{ $code + "USING: alien.syntax specialized-arrays ;" + "SPECIALIZED-ARRAY: int" + "FUNCTION: void process_data ( int* data, int len ) ;" + "int-array{ 10 20 30 } dup length process_data" +} +"Literal specialized arrays, as well as specialized arrays created with " { $snippet "<T-array>" } " and " { $snippet ">T-array" } " are backed by a " { $link byte-array } " in the Factor heap, and can move as a result of garbage collection. If this is unsuitable, the array can be allocated in unmanaged memory instead." +$nl +"In the following example, it is presumed that the C library holds on to a pointer to the array's data after the " { $snippet "init_with_data()" } " call returns; this is one situation where unmanaged memory has to be used instead. Note the use of destructors to ensure the memory is deallocated after the block ends:" +{ $code + "USING: alien.syntax specialized-arrays ;" + "SPECIALIZED-ARRAY: float" + "FUNCTION: void init_with_data ( float* data, int len ) ;" + "FUNCTION: float compute_result ( ) ;" + "[" + " 100 malloc-float-array &free" + " dup length init_with_data" + " compute_result" + "] with-destructors" +} +"Finally, sometimes a C library returns a pointer to an array in unmanaged memory, together with a length. In this case, a specialized array can be constructed to view this memory using " { $snippet "<direct-T-array>" } ":" +{ $code + "USING: alien.c-types classes.struct ;" + "" + "STRUCT: device_info" + " { id int }" + " { name char* } ;" + "" + "FUNCTION: void get_device_info ( int* length ) ;" + "" + "0 <int> [ get_device_info ] keep <direct-int-array> ." +} +"For a full discussion of Factor heap allocation versus unmanaged memory allocation, see " { $link "byte-arrays-gc" } "." +$nl "Each specialized array has a " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized array as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized array." ; ARTICLE: "specialized-array-math" "Vector arithmetic with specialized arrays" @@ -41,12 +87,17 @@ ARTICLE: "specialized-arrays" "Specialized arrays" "The " { $vocab-link "specialized-arrays" } " vocabulary implements fixed-length sequence types for storing machine values in a space-efficient manner without boxing." $nl "A specialized array type needs to be generated for each element type. This is done with a parsing word:" -{ $subsection POSTPONE: SPECIALIZED-ARRAY: } -"This parsing word adds new words to the search path:" -{ $subsection "specialized-array-words" } -{ $subsection "specialized-array-c" } -{ $subsection "specialized-array-math" } -{ $subsection "specialized-array-examples" } +{ $subsections + POSTPONE: SPECIALIZED-ARRAY: + POSTPONE: SPECIALIZED-ARRAYS: +} +"This parsing word adds new words to the search path, documented in the next section." +{ $subsections + "specialized-array-words" + "specialized-array-c" + "specialized-array-math" + "specialized-array-examples" +} "The " { $vocab-link "specialized-vectors" } " vocabulary provides a resizable version of this abstraction." ; ABOUT: "specialized-arrays" diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 5d88f42d50..07a457db5c 100755 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -4,15 +4,13 @@ specialized-arrays.private sequences alien.c-types accessors kernel arrays combinators compiler compiler.units classes.struct combinators.smart compiler.tree.debugger math libc destructors sequences.private multiline eval words vocabs namespaces -assocs prettyprint alien.data ; +assocs prettyprint alien.data math.vectors ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: int -SPECIALIZED-ARRAY: bool -SPECIALIZED-ARRAY: ushort -SPECIALIZED-ARRAY: char -SPECIALIZED-ARRAY: uint -SPECIALIZED-ARRAY: float +SPECIALIZED-ARRAYS: bool ushort char uint float ulonglong ; + +[ ulonglong ] [ ulonglong-array{ } element-type ] unit-test [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test @@ -125,22 +123,22 @@ SPECIALIZED-ARRAY: fixed-string ] unit-test [ - <" + """ IN: specialized-arrays.tests USING: specialized-arrays ; -SPECIALIZED-ARRAY: __does_not_exist__ "> eval( -- ) +SPECIALIZED-ARRAY: __does_not_exist__ """ eval( -- ) ] must-fail [ ] [ - <" + """ IN: specialized-arrays.tests -USING: classes.struct specialized-arrays ; +USING: alien.c-types classes.struct specialized-arrays ; STRUCT: __does_not_exist__ { x int } ; SPECIALIZED-ARRAY: __does_not_exist__ -"> eval( -- ) +""" eval( -- ) ] unit-test [ f ] [ diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index 6931c83677..c5de95b5b5 100755 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types alien.data alien.parser assocs -byte-arrays classes compiler.units functors kernel lexer libc math -math.vectors.specialization namespaces parser prettyprint.custom -sequences sequences.private strings summary vocabs vocabs.loader -vocabs.parser words fry combinators ; +USING: accessors alien alien.c-types alien.data alien.parser +assocs byte-arrays classes compiler.units functors kernel lexer +libc math math.vectors math.vectors.private +math.vectors.specialization namespaces +parser prettyprint.custom sequences sequences.private strings +summary vocabs vocabs.loader vocabs.parser vocabs.generated +words fry combinators present ; IN: specialized-arrays MIXIN: specialized-array @@ -53,16 +55,22 @@ TUPLE: A : <direct-A> ( alien len -- specialized-array ) A boa ; inline -: <A> ( n -- specialized-array ) [ T <underlying> ] keep <direct-A> ; inline +: <A> ( n -- specialized-array ) + [ \ T <underlying> ] keep <direct-A> ; inline -: (A) ( n -- specialized-array ) [ T (underlying) ] keep <direct-A> ; inline +: (A) ( n -- specialized-array ) + [ \ T (underlying) ] keep <direct-A> ; inline -: malloc-A ( len -- specialized-array ) [ T heap-size calloc ] keep <direct-A> ; inline +: malloc-A ( len -- specialized-array ) + [ \ T heap-size calloc ] keep <direct-A> ; inline : byte-array>A ( byte-array -- specialized-array ) - dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless + >c-ptr dup length \ T heap-size /mod 0 = + [ drop \ T bad-byte-array-length ] unless <direct-A> ; inline +M: A new-underlying drop byte-array>A ; + M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline M: A length length>> ; inline @@ -81,12 +89,14 @@ M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ; M: A resize [ - [ T heap-size * ] [ underlying>> ] bi* + [ \ T heap-size * ] [ underlying>> ] bi* resize-byte-array ] [ drop ] 2bi <direct-A> ; inline -M: A byte-length length T heap-size * ; inline +M: A byte-length length \ T heap-size * ; inline + +M: A element-type drop \ T ; inline M: A direct-array-syntax drop \ A@ ; @@ -116,24 +126,15 @@ M: word (underlying-type) "c-type" word-prop ; } cond ; : underlying-type-name ( c-type -- name ) - underlying-type dup word? [ name>> ] when ; + underlying-type present ; : specialized-array-vocab ( c-type -- vocab ) - "specialized-arrays.instances." prepend ; + present "specialized-arrays.instances." prepend ; PRIVATE> -: generate-vocab ( vocab-name quot -- vocab ) - [ dup vocab [ ] ] dip '[ - [ - [ - _ with-current-vocab - ] with-compilation-unit - ] keep - ] ?if ; inline - : define-array-vocab ( type -- vocab ) - underlying-type-name + underlying-type [ specialized-array-vocab ] [ '[ _ define-array ] ] bi generate-vocab ; @@ -156,6 +157,9 @@ M: c-type-name c-direct-array-constructor dup [ "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable +SYNTAX: SPECIALIZED-ARRAYS: + ";" parse-tokens [ parse-c-type define-array-vocab use-vocab ] each ; + SYNTAX: SPECIALIZED-ARRAY: scan-c-type define-array-vocab use-vocab ; diff --git a/basis/specialized-vectors/specialized-vectors-docs.factor b/basis/specialized-vectors/specialized-vectors-docs.factor index 9c575fe73a..6b53885e13 100644 --- a/basis/specialized-vectors/specialized-vectors-docs.factor +++ b/basis/specialized-vectors/specialized-vectors-docs.factor @@ -16,13 +16,15 @@ ARTICLE: "specialized-vector-words" "Specialized vector words" } "Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-vectors.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-VECTOR: } ". This ensures that the vocabulary can get generated the first time it is needed." ; -ARTICLE: "specialized-vector-c" "Passing specialized arrays to C functions" -"Each specialized array has a " { $slot "underlying" } " slot holding a specialized array, which in turn has an " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized vector as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized vector." ; +ARTICLE: "specialized-vector-c" "Passing specialized vectors to C functions" +"Each specialized vector has a " { $slot "underlying" } " slot holding a specialized array, which in turn has an " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized vector as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized vector." ; ARTICLE: "specialized-vectors" "Specialized vectors" "The " { $vocab-link "specialized-vectors" } " vocabulary implements resizable sequence types for storing machine values in a space-efficient manner without boxing." -{ $subsection "specialized-vector-words" } -{ $subsection "specialized-vector-c" } +{ $subsections + "specialized-vector-words" + "specialized-vector-c" +} "The " { $vocab-link "specialized-arrays" } " vocabulary provides a fixed-length version of this abstraction." ; ABOUT: "specialized-vectors" diff --git a/basis/specialized-vectors/specialized-vectors-tests.factor b/basis/specialized-vectors/specialized-vectors-tests.factor index edff828b13..c7a045a7e1 100644 --- a/basis/specialized-vectors/specialized-vectors-tests.factor +++ b/basis/specialized-vectors/specialized-vectors-tests.factor @@ -1,6 +1,6 @@ IN: specialized-vectors.tests USING: specialized-arrays specialized-vectors -tools.test kernel sequences ; +tools.test kernel sequences alien.c-types ; SPECIALIZED-ARRAY: float SPECIALIZED-VECTOR: float SPECIALIZED-VECTOR: double diff --git a/basis/specialized-vectors/specialized-vectors.factor b/basis/specialized-vectors/specialized-vectors.factor index 58fb97764b..7cda026cb3 100644 --- a/basis/specialized-vectors/specialized-vectors.factor +++ b/basis/specialized-vectors/specialized-vectors.factor @@ -3,7 +3,7 @@ USING: accessors alien.c-types assocs compiler.units functors growable kernel lexer namespaces parser prettyprint.custom sequences specialized-arrays specialized-arrays.private strings -vocabs vocabs.parser fry ; +vocabs vocabs.parser vocabs.generated fry ; QUALIFIED: vectors.functor IN: specialized-vectors diff --git a/basis/splitting/monotonic/monotonic-docs.factor b/basis/splitting/monotonic/monotonic-docs.factor index 983c5b0dea..298c12e1ed 100644 --- a/basis/splitting/monotonic/monotonic-docs.factor +++ b/basis/splitting/monotonic/monotonic-docs.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel quotations classes sequences -multiline ; +USING: help.markup help.syntax kernel quotations classes sequences ; IN: splitting.monotonic HELP: monotonic-slice @@ -14,7 +13,7 @@ HELP: monotonic-slice { $example "USING: splitting.monotonic math prettyprint ;" "{ 1 2 3 2 3 4 } [ < ] upward-slice monotonic-slice ." - <" { + """{ T{ upward-slice { from 0 } { to 3 } @@ -25,7 +24,7 @@ HELP: monotonic-slice { to 6 } { seq { 1 2 3 2 3 4 } } } -}"> +}""" } } ; @@ -74,7 +73,7 @@ HELP: trends { $example "USING: splitting.monotonic math prettyprint ;" "{ 1 2 3 3 2 1 } trends ." - <" { + """{ T{ upward-slice { from 0 } { to 3 } @@ -90,20 +89,22 @@ HELP: trends { to 6 } { seq { 1 2 3 3 2 1 } } } -}"> +}""" } } ; ARTICLE: "splitting.monotonic" "Splitting trending sequences" "The " { $vocab-link "splitting.monotonic" } " vocabulary splits sequences that are trending downwards, upwards, or stably." $nl "Splitting into sequences:" -{ $subsection monotonic-split } +{ $subsections monotonic-split } "Splitting into slices:" -{ $subsection monotonic-slice } +{ $subsections monotonic-slice } "Trending:" -{ $subsection downward-slices } -{ $subsection stable-slices } -{ $subsection upward-slices } -{ $subsection trends } ; +{ $subsections + downward-slices + stable-slices + upward-slices + trends +} ; ABOUT: "splitting.monotonic" diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index e451c53c71..5da5197700 100755 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -119,21 +119,27 @@ ARTICLE: "inference-errors" "Stack checker errors" { "The " { $link "compiler" } " reports them via " { $link "tools.errors" } } } "Errors thrown when insufficient information is available to calculate the stack effect of a call to a combinator or macro (see " { $link "inference-combinators" } "):" -{ $subsection do-not-compile } -{ $subsection literal-expected } +{ $subsections + do-not-compile + literal-expected +} "Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:" -{ $subsection effect-error } +{ $subsections effect-error } "Error thrown when branches have incompatible stack effects (see " { $link "inference-branches" } "):" -{ $subsection unbalanced-branches-error } +{ $subsections unbalanced-branches-error } "Inference errors for inline recursive words (see " { $link "inference-recursive-combinators" } "):" -{ $subsection undeclared-recursion-error } -{ $subsection diverging-recursion-error } -{ $subsection unbalanced-recursion-error } -{ $subsection inconsistent-recursive-call-error } +{ $subsections + undeclared-recursion-error + diverging-recursion-error + unbalanced-recursion-error + inconsistent-recursive-call-error +} "More obscure errors that are unlikely to arise in ordinary code:" -{ $subsection recursive-quotation-error } -{ $subsection too-many->r } -{ $subsection too-many-r> } -{ $subsection missing-effect } ; +{ $subsections + recursive-quotation-error + too-many->r + too-many-r> + missing-effect +} ; ABOUT: "inference-errors" diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 0de957b785..e5d8f6231c 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -1,18 +1,18 @@ ! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: fry accessors alien alien.accessors arrays byte-arrays classes -continuations.private effects generic hashtables +USING: fry accessors alien alien.accessors arrays byte-arrays +classes continuations.private effects generic hashtables hashtables.private io io.backend io.files io.files.private io.streams.c kernel kernel.private math math.private math.parser.private memory memory.private namespaces namespaces.private parser quotations quotations.private sbufs sbufs.private sequences sequences.private slots.private strings strings.private system threads.private classes.tuple -classes.tuple.private vectors vectors.private words definitions assocs -summary compiler.units system.private combinators -combinators.short-circuit locals locals.backend locals.types -combinators.private stack-checker.values -generic.single generic.single.private +classes.tuple.private vectors vectors.private words +words.private definitions assocs summary compiler.units +system.private combinators combinators.short-circuit locals +locals.backend locals.types combinators.private +stack-checker.values generic.single generic.single.private alien.libraries stack-checker.alien stack-checker.state @@ -482,8 +482,8 @@ M: bad-executable summary \ float-u>= { float float } { object } define-primitive \ float-u>= make-foldable -\ <word> { object object } { word } define-primitive -\ <word> make-flushable +\ (word) { object object object } { word } define-primitive +\ (word) make-flushable \ word-xt { word } { integer integer } define-primitive \ word-xt make-flushable diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index afdaccc896..5f202b1781 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -93,19 +93,25 @@ $nl ARTICLE: "tools.inference" "Stack effect tools" { $link "inference" } " can be used interactively to print stack effects of quotations without running them. It can also be used from " { $link "combinators.smart" } "." -{ $subsection infer } -{ $subsection infer. } +{ $subsections + infer + infer. +} "There are also some words for working with " { $link effect } " instances. Getting a word's declared stack effect:" -{ $subsection stack-effect } +{ $subsections stack-effect } "Converting a stack effect to a string form:" -{ $subsection effect>string } +{ $subsections effect>string } "Comparing effects:" -{ $subsection effect-height } -{ $subsection effect<= } -{ $subsection effect= } +{ $subsections + effect-height + effect<= + effect= +} "The class of stack effects:" -{ $subsection effect } -{ $subsection effect? } ; +{ $subsections + effect + effect? +} ; ARTICLE: "inference-escape" "Stack effect checking escape hatches" "In a static checking regime, sometimes it is necessary to step outside the boundaries and run some code which cannot be statically checked; perhaps this code is constructed at run-time. There are two ways to get around the static stack checker." @@ -113,7 +119,7 @@ $nl "If the stack effect of a word or quotation is known, but the word or quotation itself is not, " { $link POSTPONE: execute( } " or " { $link POSTPONE: call( } " can be used. See " { $link "call" } " for details." $nl "If the stack effect is not known, the code being called cannot manipulate the datastack directly. Instead, it must reflect the datastack into an array:" -{ $subsection with-datastack } +{ $subsections with-datastack } "The surrounding code has a static stack effect since " { $link with-datastack } " has one. However, the array passed in as input may be transformed arbitrarily by calling this combinator." ; ARTICLE: "inference" "Stack effect checking" @@ -124,14 +130,16 @@ $nl "If a word's stack effect cannot be inferred, a compile error is reported. See " { $link "compiler-errors" } "." $nl "The following articles describe how different control structures are handled by the stack checker." -{ $subsection "inference-simple" } -{ $subsection "inference-combinators" } -{ $subsection "inference-recursive-combinators" } -{ $subsection "inference-branches" } +{ $subsections + "inference-simple" + "inference-combinators" + "inference-recursive-combinators" + "inference-branches" +} "Stack checking catches several classes of errors." -{ $subsection "inference-errors" } +{ $subsections "inference-errors" } "Sometimes code with a dynamic stack effect has to be run." -{ $subsection "inference-escape" } +{ $subsections "inference-escape" } { $see-also "effects" "tools.inference" "tools.errors" } ; ABOUT: "inference" diff --git a/basis/suffix-arrays/suffix-arrays-docs.factor b/basis/suffix-arrays/suffix-arrays-docs.factor index 87df27281e..75f963387b 100755 --- a/basis/suffix-arrays/suffix-arrays-docs.factor +++ b/basis/suffix-arrays/suffix-arrays-docs.factor @@ -36,10 +36,10 @@ ARTICLE: "suffix-arrays" "Suffix arrays" "The " { $vocab-link "suffix-arrays" } " vocabulary implements the suffix array data structure for efficient lookup of subsequences. This suffix array implementation is a sorted array of suffixes. Querying it for matches uses binary search for efficiency." $nl "Creating new suffix arrays:" -{ $subsection >suffix-array } +{ $subsections >suffix-array } "Literal suffix arrays:" -{ $subsection POSTPONE: SA{ } +{ $subsections POSTPONE: SA{ } "Querying suffix arrays:" -{ $subsection query } ; +{ $subsections query } ; ABOUT: "suffix-arrays" diff --git a/basis/summary/summary-docs.factor b/basis/summary/summary-docs.factor index 7822857bbb..a5b12ecd73 100644 --- a/basis/summary/summary-docs.factor +++ b/basis/summary/summary-docs.factor @@ -3,7 +3,7 @@ USING: kernel strings help.markup help.syntax ; ARTICLE: "summary" "Converting objects to summary strings" "A word for getting very brief descriptions of words and general objects:" -{ $subsection summary } ; +{ $subsections summary } ; HELP: summary { $values { "object" object } { "string" string } } diff --git a/basis/summary/summary.factor b/basis/summary/summary.factor index 44e5374dc5..2737ecec6c 100644 --- a/basis/summary/summary.factor +++ b/basis/summary/summary.factor @@ -7,7 +7,7 @@ IN: summary GENERIC: summary ( object -- string ) : object-summary ( object -- string ) - class name>> " instance" append ; + class name>> ; M: object summary object-summary ; diff --git a/basis/syndication/syndication-docs.factor b/basis/syndication/syndication-docs.factor index bc9612f55c..741edc9adc 100644 --- a/basis/syndication/syndication-docs.factor +++ b/basis/syndication/syndication-docs.factor @@ -52,16 +52,20 @@ ARTICLE: "syndication" "Atom and RSS feed syndication" "The " { $vocab-link "syndication" } " vocabulary implements support for reading Atom and RSS feeds, and writing Atom feeds." $nl "Data types:" -{ $subsection feed } -{ $subsection <feed> } -{ $subsection entry } -{ $subsection <entry> } +{ $subsections + feed + <feed> + entry + <entry> +} "Reading feeds:" -{ $subsection download-feed } -{ $subsection parse-feed } -{ $subsection xml>feed } +{ $subsections + download-feed + parse-feed + xml>feed +} "Writing feeds:" -{ $subsection feed>xml } +{ $subsections feed>xml } "The " { $vocab-link "furnace.syndication" } " vocabulary builds on top of this vocabulary to enable easy generation of Atom feeds from web applications. The " { $vocab-link "webapps.planet" } " vocabulary is a complete example of a web application which reads and exports feeds." { $see-also "urls" } ; diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index dbdb69b3e9..8956051b25 100644 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -5,47 +5,57 @@ IN: threads ARTICLE: "threads-start/stop" "Starting and stopping threads" "Spawning new threads:" -{ $subsection spawn } -{ $subsection spawn-server } +{ $subsections + spawn + spawn-server +} "Creating and spawning a thread can be factored out into two separate steps:" -{ $subsection <thread> } -{ $subsection (spawn) } +{ $subsections + <thread> + (spawn) +} "Threads stop either when the quotation given to " { $link spawn } " returns, or when the following word is called:" -{ $subsection stop } +{ $subsections stop } "If the image is saved and started again, all runnable threads are stopped. Vocabularies wishing to have a background thread always running should use " { $link add-init-hook } "." ; ARTICLE: "threads-yield" "Yielding and suspending threads" "Yielding to other threads:" -{ $subsection yield } +{ $subsections yield } "Sleeping for a period of time:" -{ $subsection sleep } +{ $subsections sleep } "Interrupting sleep:" -{ $subsection interrupt } +{ $subsections interrupt } "Threads can be suspended and woken up at some point in the future when a condition is satisfied:" -{ $subsection suspend } -{ $subsection resume } -{ $subsection resume-with } ; +{ $subsections + suspend + resume + resume-with +} ; ARTICLE: "thread-state" "Thread-local state and variables" "Threads form a class of objects:" -{ $subsection thread } +{ $subsections thread } "The current thread:" -{ $subsection self } +{ $subsections self } "Thread-local variables:" -{ $subsection tnamespace } -{ $subsection tget } -{ $subsection tset } -{ $subsection tchange } +{ $subsections + tnamespace + tget + tset + tchange +} "Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set." $nl "Global hashtable of all threads, keyed by " { $snippet "id" } ":" -{ $subsection threads } +{ $subsections threads } "Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ; ARTICLE: "thread-impl" "Thread implementation" "Thread implementation:" -{ $subsection run-queue } -{ $subsection sleep-queue } ; +{ $subsections + run-queue + sleep-queue +} ; ARTICLE: "threads" "Lightweight co-operative threads" "Factor supports lightweight co-operative threads implemented on top of " { $link "continuations" } ". A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested." @@ -53,10 +63,12 @@ $nl "Factor threads are very lightweight. Each thread can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple threads." $nl "Words for working with threads are in the " { $vocab-link "threads" } " vocabulary." -{ $subsection "threads-start/stop" } -{ $subsection "threads-yield" } -{ $subsection "thread-state" } -{ $subsection "thread-impl" } ; +{ $subsections + "threads-start/stop" + "threads-yield" + "thread-state" + "thread-impl" +} ; ABOUT: "threads" diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index 17743610bc..fc046c6ae2 100644 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -6,14 +6,18 @@ ARTICLE: "tools.annotations" "Word annotations" "The word annotation feature modifies word definitions to add debugging code. You can restore the old definition by calling " { $link reset } " on the word in question." $nl "Printing messages when a word is called or returns:" -{ $subsection watch } -{ $subsection watch-vars } +{ $subsections + watch + watch-vars +} "Timing words:" -{ $subsection reset-word-timing } -{ $subsection add-timing } -{ $subsection word-timing. } +{ $subsections + reset-word-timing + add-timing + word-timing. +} "All of the above words are implemented using a single combinator which applies a quotation to a word definition to yield a new definition:" -{ $subsection annotate } +{ $subsections annotate } { $warning "Certain internal words, such as words in the " { $vocab-link "math" } ", " { $vocab-link "sequences" } " and UI vocabularies, cannot be annotated, since the annotated code may end up recursively invoking the word in question. This may crash or hang Factor. It is safest to only define annotations on your own words." } ; diff --git a/basis/tools/completion/completion-docs.factor b/basis/tools/completion/completion-docs.factor index 4d7154fb2d..7d5ebf8910 100644 --- a/basis/tools/completion/completion-docs.factor +++ b/basis/tools/completion/completion-docs.factor @@ -6,13 +6,15 @@ ARTICLE: "tools.completion" "Fuzzy completion" "Various developer tools make use of a general-purpose fuzzy completion algorithm." $nl "The main entry point:" -{ $subsection completions } +{ $subsections completions } "The words used to implement the algorithm can be called as well, for finer control over fuzzy matching:" -{ $subsection fuzzy } -{ $subsection runs } -{ $subsection score } -{ $subsection complete } -{ $subsection rank-completions } ; +{ $subsections + fuzzy + runs + score + complete + rank-completions +} ; ABOUT: "tools.completion" diff --git a/basis/tools/crossref/crossref-docs.factor b/basis/tools/crossref/crossref-docs.factor index 9108777554..e8c45ee4a0 100644 --- a/basis/tools/crossref/crossref-docs.factor +++ b/basis/tools/crossref/crossref-docs.factor @@ -4,16 +4,20 @@ IN: tools.crossref ARTICLE: "tools.crossref" "Definition cross referencing" "Definitions can answer a sequence of definitions they directly depend on:" -{ $subsection uses } +{ $subsections uses } "An inverted index of the above:" -{ $subsection get-crossref } +{ $subsections get-crossref } "Words to access it:" -{ $subsection usage } -{ $subsection smart-usage } +{ $subsections + usage + smart-usage +} "Tools for interactive use:" -{ $subsection usage. } -{ $subsection vocab-uses. } -{ $subsection vocab-usage. } +{ $subsections + usage. + vocab-uses. + vocab-usage. +} { $see-also "definitions" "words" "see" } ; ABOUT: "tools.crossref" diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index 6082933bcb..beaf1c0673 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -50,7 +50,7 @@ M: callable uses ( quot -- assoc ) M: word uses def>> uses ; -M: link uses { $subsection $link $see-also } article-links ; +M: link uses { $subsection $subsections $link $see-also } article-links ; M: pathname uses string>> source-file top-level-form>> [ uses ] [ { } ] if* ; @@ -105,7 +105,8 @@ M: f smart-usage drop \ f smart-usage ; synopsis-alist sort-keys definitions. ; : usage. ( word -- ) - smart-usage sorted-definitions. ; + smart-usage + [ "No usages." print ] [ sorted-definitions. ] if-empty ; : vocab-xref ( vocab quot -- vocabs ) [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index ba82276927..bd58c7505b 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -53,9 +53,7 @@ CONSTANT: theme-path "basis/ui/gadgets/theme/" ] { } make ; : staging-image-name ( profile -- name ) - "staging." - swap strip-word-names? [ "strip" suffix ] when - "-" join ".image" 3append temp-file ; + "-" join "staging." ".image" surround temp-file ; DEFER: ?make-staging-image @@ -72,7 +70,6 @@ DEFER: ?make-staging-image ] if "-output-image=" over staging-image-name append , "-include=" swap " " join append , - strip-word-names? [ "-no-stack-traces" , ] when "-no-user-init" , ] { } make ; @@ -102,7 +99,6 @@ DEFER: ?make-staging-image [ "-deploy-vocab=" prepend , ] [ make-deploy-config "-deploy-config=" prepend , ] bi "-output-image=" prepend , - strip-word-names? [ "-no-stack-traces" , ] when ] { } make ] bind ; diff --git a/basis/tools/deploy/config/config-docs.factor b/basis/tools/deploy/config/config-docs.factor index 12016168fb..1df76856ba 100644 --- a/basis/tools/deploy/config/config-docs.factor +++ b/basis/tools/deploy/config/config-docs.factor @@ -4,15 +4,19 @@ IN: tools.deploy.config ARTICLE: "deploy-flags" "Deployment flags" "There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:" -{ $subsection deploy-math? } -{ $subsection deploy-unicode? } -{ $subsection deploy-threads? } -{ $subsection deploy-ui? } +{ $subsections + deploy-math? + deploy-unicode? + deploy-threads? + deploy-ui? +} "The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:" -{ $subsection deploy-io } -{ $subsection deploy-reflection } -{ $subsection deploy-word-props? } -{ $subsection deploy-c-types? } ; +{ $subsections + deploy-io + deploy-reflection + deploy-word-props? + deploy-c-types? +} ; ABOUT: "deploy-flags" diff --git a/basis/tools/deploy/config/editor/editor-docs.factor b/basis/tools/deploy/config/editor/editor-docs.factor index b677d37f95..9de593758e 100644 --- a/basis/tools/deploy/config/editor/editor-docs.factor +++ b/basis/tools/deploy/config/editor/editor-docs.factor @@ -4,12 +4,14 @@ IN: tools.deploy.config.editor ARTICLE: "deploy-config" "Deployment configuration" "The deployment configuration is a key/value mapping stored in the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If this file does not exist, the default deployment configuration is used:" -{ $subsection default-config } +{ $subsections default-config } "The deployment configuration can be read and written with a pair of words:" -{ $subsection deploy-config } -{ $subsection set-deploy-config } +{ $subsections + deploy-config + set-deploy-config +} "A utility word is provided to load the configuration, change a flag, and store it back to disk:" -{ $subsection set-deploy-flag } +{ $subsections set-deploy-flag } "The " { $link "ui.tools.deploy" } " provides a graphical way of editing the configuration." ; HELP: deploy-config diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor index 71701b6a56..948db1c833 100644 --- a/basis/tools/deploy/deploy-docs.factor +++ b/basis/tools/deploy/deploy-docs.factor @@ -4,12 +4,14 @@ IN: tools.deploy ARTICLE: "prepare-deploy" "Preparing to deploy an application" "In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created." -{ $subsection "deploy-config" } -{ $subsection "deploy-flags" } ; +{ $subsections + "deploy-config" + "deploy-flags" +} ; ARTICLE: "tools.deploy.usage" "Deploy tool usage" "Once the necessary deployment flags have been set, the application can be deployed:" -{ $subsection deploy } +{ $subsections deploy } "For example, you can deploy the " { $vocab-link "hello-ui" } " demo which comes with Factor. Note that this demo already has a deployment configuration, so nothing needs to be configured:" { $code "\"hello-ui\" deploy" } { $list @@ -42,10 +44,12 @@ $nl "Most of the time, the words in the " { $vocab-link "tools.deploy" } " vocabulary should not be used directly; instead, use " { $link "ui.tools.deploy" } "." $nl "You must explicitly specify major subsystems which are required, as well as the level of reflection support needed. This is done by modifying the deployment configuration prior to deployment." -{ $subsection "prepare-deploy" } -{ $subsection "tools.deploy.usage" } -{ $subsection "tools.deploy.impl" } -{ $subsection "tools.deploy.caveats" } ; +{ $subsections + "prepare-deploy" + "tools.deploy.usage" + "tools.deploy.impl" + "tools.deploy.caveats" +} ; ABOUT: "tools.deploy" diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 36045a6b22..6a1f949b0b 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -1,9 +1,9 @@ +USING: tools.test system io io.encodings.ascii io.pathnames +io.files io.files.info io.files.temp kernel tools.deploy.config +tools.deploy.config.editor tools.deploy.backend math sequences +io.launcher arrays namespaces continuations layouts accessors +urls math.parser io.directories tools.deploy.test ; IN: tools.deploy.tests -USING: tools.test system io.pathnames io.files io.files.info -io.files.temp kernel tools.deploy.config tools.deploy.config.editor -tools.deploy.backend math sequences io.launcher arrays namespaces -continuations layouts accessors io.encodings.ascii urls math.parser -io.directories tools.deploy.test ; [ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test @@ -11,7 +11,7 @@ io.directories tools.deploy.test ; [ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test -[ "staging.math-threads-compiler-ui-strip.image" ] [ +[ "staging.math-threads-compiler-ui.image" ] [ "hello-ui" deploy-config [ bootstrap-profile staging-image-name file-name ] bind ] unit-test @@ -105,4 +105,11 @@ os windows? os macosx? or [ os macosx? [ [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test -] when \ No newline at end of file +] when + +[ { "a" "b" "c" } ] [ + "tools.deploy.test.15" shake-and-bake deploy-test-command + { "a" "b" "c" } append + ascii [ lines ] with-process-reader + rest +] unit-test \ No newline at end of file diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 42d1ee2a9f..994073b149 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -7,9 +7,8 @@ words memory kernel.private continuations io vocabs.loader system strings sets vectors quotations byte-arrays sorting compiler.units definitions generic generic.standard generic.single tools.deploy.config combinators classes -classes.builtin slots.private grouping ; +classes.builtin slots.private grouping command-line ; QUALIFIED: bootstrap.stage2 -QUALIFIED: command-line QUALIFIED: compiler.errors QUALIFIED: continuations QUALIFIED: definitions @@ -22,11 +21,14 @@ IN: tools.deploy.shaker ! This file is some hairy shit. +: add-command-line-hook ( -- ) + [ (command-line) command-line set-global ] "command-line" + init-hooks get set-at ; + : strip-init-hooks ( -- ) "Stripping startup hooks" show { "alien.strings" - "command-line" "cpu.x86" "destructors" "environment" @@ -196,13 +198,17 @@ IN: tools.deploy.shaker "word-style" } % ] when + + deploy-c-types? get [ + { "c-type" "struct-slots" "struct-align" } % + ] unless ] { } make ; : strip-words ( props -- ) [ word? ] instances deploy-word-props? get [ 2dup strip-word-props ] unless deploy-word-defs? get [ dup strip-word-defs ] unless - strip-word-names? [ dup strip-word-names ] when + strip-word-names? [ dup strip-word-names strip-stack-traces ] when 2drop ; : compiler-classes ( -- seq ) @@ -324,7 +330,7 @@ IN: tools.deploy.shaker classes-intersect-cache implementors-map update-map - command-line:main-vocab-hook + main-vocab-hook compiled-crossref compiled-generic-crossref compiler-impl @@ -345,6 +351,8 @@ IN: tools.deploy.shaker { } { "math.partial-dispatch" } strip-vocab-globals % + { } { "math.vectors.simd" } strip-vocab-globals % + { } { "peg" } strip-vocab-globals % ] when @@ -497,6 +505,7 @@ SYMBOL: deploy-vocab strip-debugger compute-next-methods strip-init-hooks + add-command-line-hook strip-c-io strip-default-methods strip-compiler-classes diff --git a/basis/tools/deploy/test/15/15.factor b/basis/tools/deploy/test/15/15.factor new file mode 100644 index 0000000000..a64c3ca81e --- /dev/null +++ b/basis/tools/deploy/test/15/15.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: command-line io namespaces sequences ; +IN: tools.deploy.test.15 + +: main ( -- ) command-line get [ print ] each ; + +MAIN: main diff --git a/basis/tools/deploy/test/8/8.factor b/basis/tools/deploy/test/8/8.factor index ddf08d3654..6bbb85f9fc 100644 --- a/basis/tools/deploy/test/8/8.factor +++ b/basis/tools/deploy/test/8/8.factor @@ -1,4 +1,4 @@ -USING: calendar game-input threads ui ui.gadgets.worlds kernel +USING: calendar game.input threads ui ui.gadgets.worlds kernel method-chains system ; IN: tools.deploy.test.8 @@ -18,4 +18,4 @@ AFTER: my-world end-world drop close-game-input ; 0 exit ] with-ui ; -MAIN: test-game-input \ No newline at end of file +MAIN: test-game-input diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor index 6a6f9cf8fd..908540254a 100755 --- a/basis/tools/deploy/test/test.factor +++ b/basis/tools/deploy/test/test.factor @@ -19,7 +19,10 @@ IN: tools.deploy.test ] bi* <= ; -: run-temp-image ( -- ) +: deploy-test-command ( -- args ) os macosx? "resource:Factor.app/Contents/MacOS/factor" normalize-path vm ? - "-i=" "test.image" temp-file append 2array try-output-process ; \ No newline at end of file + "-i=" "test.image" temp-file append 2array ; + +: run-temp-image ( -- ) + deploy-test-command try-output-process ; \ No newline at end of file diff --git a/basis/tools/deprecation/deprecation-docs.factor b/basis/tools/deprecation/deprecation-docs.factor index 28d771c170..fb3df736f4 100644 --- a/basis/tools/deprecation/deprecation-docs.factor +++ b/basis/tools/deprecation/deprecation-docs.factor @@ -7,7 +7,9 @@ HELP: :deprecations ARTICLE: "tools.deprecation" "Deprecation tracking" "Factor's core syntax defines a " { $link POSTPONE: deprecated } " word that can be applied to words to mark them as deprecated. When the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, notes will be collected and reported by the " { $link "tools.errors" } " mechanism when deprecated words are used to define other words." -{ $subsection POSTPONE: deprecated } -{ $subsection :deprecations } ; +{ $subsections + POSTPONE: deprecated + :deprecations +} ; ABOUT: "tools.deprecation" diff --git a/basis/tools/destructors/destructors-docs.factor b/basis/tools/destructors/destructors-docs.factor index e01c61db00..3491caf462 100644 --- a/basis/tools/destructors/destructors-docs.factor +++ b/basis/tools/destructors/destructors-docs.factor @@ -16,9 +16,11 @@ TIP: "Use the " { $link leaks } " combinator to track down resource leaks." ; ARTICLE: "tools.destructors" "Destructor tools" "The " { $vocab-link "tools.destructors" } " vocabulary provides words for tracking down resource leaks." -{ $subsection debug-leaks? } -{ $subsection disposables. } -{ $subsection leaks } +{ $subsections + debug-leaks? + disposables. + leaks +} { $see-also "destructors" } ; ABOUT: "tools.destructors" diff --git a/basis/tools/disassembler/disassembler-docs.factor b/basis/tools/disassembler/disassembler-docs.factor index 7d193d0aac..8ee5ff48bd 100644 --- a/basis/tools/disassembler/disassembler-docs.factor +++ b/basis/tools/disassembler/disassembler-docs.factor @@ -8,6 +8,6 @@ HELP: disassemble ARTICLE: "tools.disassembler" "Disassembling words" "The " { $vocab-link "tools.disassembler" } " vocabulary provides support for disassembling compiled word definitions. It uses the " { $snippet "libudis86" } " library on x86-32 and x86-64, and " { $snippet "gdb" } " on PowerPC." -{ $subsection disassemble } ; +{ $subsections disassemble } ; ABOUT: "tools.disassembler" diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor index 16408c0eb8..4aec909e88 100755 --- a/basis/tools/disassembler/disassembler.factor +++ b/basis/tools/disassembler/disassembler.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays byte-arrays combinators -destructors generic io kernel libc math sequences system tr -vocabs.loader words alien.data ; +USING: alien alien.data arrays byte-arrays compiler.units destructors +io kernel libc math quotations sequences stack-checker system tr +vocabs.loader words ; IN: tools.disassembler GENERIC: disassemble ( obj -- ) @@ -24,6 +24,8 @@ M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ; M: word disassemble word-xt 2array disassemble ; +M: quotation disassemble [ dup infer define-temp ] with-compilation-unit disassemble ; + cpu x86? "tools.disassembler.udis" "tools.disassembler.gdb" ? diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index 89bd5f726c..effb2d6f0e 100755 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -31,7 +31,7 @@ STRUCT: ud { inp_hook void* } { inp_curr uchar } { inp_fill uchar } - { inp_file FILE* } + { inp_file void* } { inp_ctr uchar } { inp_buff uchar* } { inp_buff_end uchar* } @@ -68,7 +68,7 @@ STRUCT: ud { c3 uchar } { inp_cache uchar[256] } { inp_sess uchar[64] } - { itab_entry ud_itab_entry* } ; + { itab_entry void* } ; FUNCTION: void ud_translate_intel ( ud* u ) ; FUNCTION: void ud_translate_att ( ud* u ) ; diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor index 4eb9115d05..be3efd3849 100644 --- a/basis/tools/errors/errors-docs.factor +++ b/basis/tools/errors/errors-docs.factor @@ -10,8 +10,10 @@ ARTICLE: "compiler-errors" "Compiler errors" "This indicates that some words did not pass the stack checker. Stack checker error conditions are documented in " { $link "inference-errors" } ", and the stack checker itself in " { $link "inference" } "." $nl "Words to view errors:" -{ $subsection :errors } -{ $subsection :linkage } +{ $subsections + :errors + :linkage +} "Compiler errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ; HELP: compiler-error @@ -38,11 +40,11 @@ ARTICLE: "tools.errors" "Batch error reporting" "Some tools, such as the " { $link "compiler" } ", " { $link "tools.test" } " and " { $link "help.lint" } " need to report multiple errors at a time. Each error is associated with a source file, line number, and optionally, a definition. " { $link "errors" } " cannot be used for this purpose, so the " { $vocab-link "source-files.errors" } " vocabulary provides an alternative mechanism. Note that the words in this vocabulary are used for implementation only; to actually list errors, consult the documentation for the relevant tools." $nl "Source file errors inherit from a class:" -{ $subsection source-file-error } +{ $subsections source-file-error } "Printing an error summary:" -{ $subsection error-summary } +{ $subsections error-summary } "Printing a list of errors:" -{ $subsection errors. } +{ $subsections errors. } "Batch errors are reported in the " { $link "ui.tools.error-list" } "." ; ABOUT: "tools.errors" \ No newline at end of file diff --git a/basis/tools/files/files-docs.factor b/basis/tools/files/files-docs.factor index c5c5b44c1b..9e689bc592 100644 --- a/basis/tools/files/files-docs.factor +++ b/basis/tools/files/files-docs.factor @@ -12,6 +12,6 @@ HELP: directory. ARTICLE: "tools.files" "Files tools" "The " { $vocab-link "tools.files" } " vocabulary implements directory files and file-systems listing in a cross-platform way." $nl "Listing a directory:" -{ $subsection directory. } ; +{ $subsections directory. } ; ABOUT: "tools.files" diff --git a/basis/tools/hexdump/hexdump-docs.factor b/basis/tools/hexdump/hexdump-docs.factor index 612195d997..a501c2fed7 100644 --- a/basis/tools/hexdump/hexdump-docs.factor +++ b/basis/tools/hexdump/hexdump-docs.factor @@ -16,8 +16,8 @@ HELP: hexdump ARTICLE: "tools.hexdump" "Hexdump" "The " { $vocab-link "tools.hexdump" } " vocabulary provides a traditional hexdump view of a sequence." $nl "Write hexdump to string:" -{ $subsection hexdump } +{ $subsections hexdump } "Write the hexdump to the output stream:" -{ $subsection hexdump. } ; +{ $subsections hexdump. } ; ABOUT: "tools.hexdump" diff --git a/basis/tools/memory/memory-docs.factor b/basis/tools/memory/memory-docs.factor index 821a6ca7f5..7ecbf402ab 100644 --- a/basis/tools/memory/memory-docs.factor +++ b/basis/tools/memory/memory-docs.factor @@ -3,19 +3,25 @@ IN: tools.memory ARTICLE: "tools.memory" "Object memory tools" "You can print object heap status information:" -{ $subsection room. } -{ $subsection heap-stats. } -{ $subsection heap-stats } +{ $subsections + room. + heap-stats. + heap-stats +} "You can query memory status:" -{ $subsection data-room } -{ $subsection code-room } +{ $subsections + data-room + code-room +} "There are a pair of combinators, analogous to " { $link each } " and " { $link filter } ", which operate on the entire collection of objects in the object heap:" -{ $subsection each-object } -{ $subsection instances } +{ $subsections + each-object + instances +} "You can check an object's the heap memory usage:" -{ $subsection size } +{ $subsections size } "The garbage collector can be invoked manually:" -{ $subsection gc } +{ $subsections gc } { $see-also "images" } ; ABOUT: "tools.memory" diff --git a/basis/tools/profiler/profiler-docs.factor b/basis/tools/profiler/profiler-docs.factor index efd2e164a3..0fda4a65e5 100644 --- a/basis/tools/profiler/profiler-docs.factor +++ b/basis/tools/profiler/profiler-docs.factor @@ -15,14 +15,16 @@ ARTICLE: "profiling" "Profiling code" "The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler." $nl "Quotations can be passed to a combinator which calls them with the profiler enabled:" -{ $subsection profile } +{ $subsections profile } "After a quotation has been profiled, call counts can be presented in various ways:" -{ $subsection profile. } -{ $subsection vocab-profile. } -{ $subsection usage-profile. } -{ $subsection vocabs-profile. } -{ $subsection method-profile. } -{ $subsection "profiler-limitations" } +{ $subsections + profile. + vocab-profile. + usage-profile. + vocabs-profile. + method-profile. + "profiler-limitations" +} { $see-also "ui.tools.profiler" } ; ABOUT: "profiling" diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor index d2e605ecdc..dda531faee 100644 --- a/basis/tools/profiler/profiler-tests.factor +++ b/basis/tools/profiler/profiler-tests.factor @@ -59,3 +59,8 @@ words ; [ ] [ [ [ ] compile-call ] profile ] unit-test [ [ gensym execute ] profile ] [ T{ undefined } = ] must-fail-with + +: crash-bug-1 ( -- x ) "hi" "bye" <word> ; +: crash-bug-2 ( -- ) 100000 [ crash-bug-1 drop ] times ; + +[ ] [ [ crash-bug-2 ] profile ] unit-test diff --git a/basis/tools/scaffold/scaffold-docs.factor b/basis/tools/scaffold/scaffold-docs.factor index 621933bfa8..f4200f8cb2 100644 --- a/basis/tools/scaffold/scaffold-docs.factor +++ b/basis/tools/scaffold/scaffold-docs.factor @@ -48,19 +48,23 @@ HELP: using ARTICLE: "tools.scaffold" "Scaffold tool" "Scaffold setup:" -{ $subsection developer-name } +{ $subsections developer-name } "Generate new vocabs:" -{ $subsection scaffold-vocab } +{ $subsections scaffold-vocab } "Generate help scaffolding:" -{ $subsection scaffold-help } -{ $subsection scaffold-undocumented } -{ $subsection help. } +{ $subsections + scaffold-help + scaffold-undocumented + help. +} "Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead." $nl "Scaffolding a configuration file:" -{ $subsection scaffold-rc } -{ $subsection scaffold-factor-boot-rc } -{ $subsection scaffold-factor-rc } -{ $subsection scaffold-emacs } +{ $subsections + scaffold-rc + scaffold-factor-boot-rc + scaffold-factor-rc + scaffold-emacs +} ; ABOUT: "tools.scaffold" diff --git a/basis/tools/scaffold/scaffold-tests.factor b/basis/tools/scaffold/scaffold-tests.factor index 4c8698c114..43f62a04e6 100644 --- a/basis/tools/scaffold/scaffold-tests.factor +++ b/basis/tools/scaffold/scaffold-tests.factor @@ -1,20 +1,20 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test tools.scaffold unicode.case kernel -multiline tools.scaffold.private io.streams.string ; +tools.scaffold.private io.streams.string ; IN: tools.scaffold.tests : undocumented-word ( obj1 obj2 -- obj3 obj4 ) [ >lower ] [ >upper ] bi* ; [ -<" HELP: undocumented-word +"""HELP: undocumented-word { $values { "obj1" object } { "obj2" object } { "obj3" object } { "obj4" object } } { $description "" } ; -"> +""" ] [ [ \ undocumented-word (help.) ] with-string-writer diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor index ac7b33d41e..5aaaa24dc6 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -3,26 +3,34 @@ IN: tools.test ARTICLE: "tools.test.write" "Writing unit tests" "Assert that a quotation outputs a specific set of values:" -{ $subsection POSTPONE: unit-test } +{ $subsections POSTPONE: unit-test } "Assert that a quotation throws an error:" -{ $subsection POSTPONE: must-fail } -{ $subsection POSTPONE: must-fail-with } +{ $subsections + POSTPONE: must-fail + POSTPONE: must-fail-with +} "Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):" -{ $subsection POSTPONE: must-infer } -{ $subsection POSTPONE: must-infer-as } +{ $subsections + POSTPONE: must-infer + POSTPONE: must-infer-as +} "All of the above are used like ordinary words but are actually parsing words. This ensures that parse-time state, namely the line number, can be associated with the test in question, and reported in test failures." ; ARTICLE: "tools.test.run" "Running unit tests" "The following words run test harness files; any test failures are collected and printed at the end:" -{ $subsection test } -{ $subsection test-all } +{ $subsections + test + test-all +} "The following word prints failures:" -{ $subsection :test-failures } +{ $subsections :test-failures } "Test failures are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." $nl "Unit test failures are instances of a class, and are stored in a global variable:" -{ $subsection test-failure } -{ $subsection test-failures } ; +{ $subsections + test-failure + test-failures +} ; ARTICLE: "tools.test" "Unit testing" "A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract." @@ -37,8 +45,10 @@ $nl "The latter is used for vocabularies with more extensive test suites." $nl "If the test harness needs to define words, they should be placed in a vocabulary named " { $snippet { $emphasis "vocab" } ".tests" } " where " { $emphasis "vocab" } " is the vocab being tested." -{ $subsection "tools.test.write" } -{ $subsection "tools.test.run" } ; +{ $subsections + "tools.test.write" + "tools.test.run" +} ; ABOUT: "tools.test" diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 2692c5a8b6..097460837b 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -27,6 +27,9 @@ T{ error-type { quot [ test-failures get ] } } define-error-type +SYMBOL: verbose-tests? +t verbose-tests? set-global + <PRIVATE : <test-failure> ( error experiment file line# -- triple ) @@ -80,7 +83,8 @@ MACRO: <experiment> ( word -- ) '[ _ ndup _ narray _ prefix ] ; : experiment. ( seq -- ) - [ first write ": " write ] [ rest . flush ] bi ; + [ first write ": " write ] + [ rest verbose-tests? get [ . ] [ short. ] if flush ] bi ; :: experiment ( word: ( -- error ? ) line# -- ) word <experiment> :> e diff --git a/basis/tools/threads/threads-docs.factor b/basis/tools/threads/threads-docs.factor index c60255b377..9645cb4f64 100644 --- a/basis/tools/threads/threads-docs.factor +++ b/basis/tools/threads/threads-docs.factor @@ -12,6 +12,6 @@ HELP: threads. ARTICLE: "tools.threads" "Listing threads" "Printing a list of running threads:" -{ $subsection threads. } ; +{ $subsections threads. } ; ABOUT: "tools.threads" diff --git a/basis/tools/time/time-docs.factor b/basis/tools/time/time-docs.factor index d8dba04486..408592d0c6 100644 --- a/basis/tools/time/time-docs.factor +++ b/basis/tools/time/time-docs.factor @@ -3,12 +3,14 @@ IN: tools.time ARTICLE: "timing" "Timing code" "You can time the execution of a quotation in the listener:" -{ $subsection time } +{ $subsections time } "A lower-level word puts timings on the stack, intead of printing:" -{ $subsection benchmark } +{ $subsections benchmark } "You can also read the system clock and garbage collection statistics directly:" -{ $subsection micros } -{ $subsection gc-stats } +{ $subsections + micros + gc-stats +} { $see-also "profiling" } ; ABOUT: "timing" diff --git a/basis/tools/walker/walker-docs.factor b/basis/tools/walker/walker-docs.factor index 5a78e0cfc2..bbfb9cbd9f 100644 --- a/basis/tools/walker/walker-docs.factor +++ b/basis/tools/walker/walker-docs.factor @@ -16,11 +16,15 @@ ARTICLE: "breakpoints" "Setting breakpoints" "In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words using words in the " { $vocab-link "tools.walker" } " vocabulary." $nl "Annotating a word with a breakpoint (see " { $link "tools.annotations" } "):" -{ $subsection breakpoint } -{ $subsection breakpoint-if } +{ $subsections + breakpoint + breakpoint-if +} "Breakpoints can be inserted directly into code:" -{ $subsection break } -{ $subsection POSTPONE: B } +{ $subsections + break + POSTPONE: B +} "Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link + } " will hang the UI." ; ABOUT: "breakpoints" diff --git a/basis/tuple-arrays/tuple-arrays-docs.factor b/basis/tuple-arrays/tuple-arrays-docs.factor index cedf900698..5e70e15aa7 100644 --- a/basis/tuple-arrays/tuple-arrays-docs.factor +++ b/basis/tuple-arrays/tuple-arrays-docs.factor @@ -11,7 +11,7 @@ $nl "Since value semantics differ from reference semantics, it is best to use tuple arrays with tuples where all slots are declared " { $link read-only } "." $nl "Tuple arrays should not be used with inheritance; storing an instance of a subclass in a tuple array will slice off the subclass slots, and getting the same value out again will yield an instance of the superclass. Also, tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays." -{ $subsection POSTPONE: TUPLE-ARRAY: } +{ $subsections POSTPONE: TUPLE-ARRAY: } "An example:" { $example "USE: tuple-arrays" diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 111e20aea2..0213b8433c 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -7,7 +7,7 @@ cocoa.views cocoa.windows combinators command-line core-foundation core-foundation.run-loop core-graphics core-graphics.types destructors fry generalizations io.thread kernel libc literals locals math math.bitwise math.rectangles memory -namespaces sequences threads ui +namespaces sequences threads ui colors ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private ui.private words.symbol ; @@ -117,14 +117,21 @@ CONSTANT: window-control>styleMask { resize-handles $ NSResizableWindowMask } { small-title-bar $[ NSTitledWindowMask NSUtilityWindowMask bitor ] } { normal-title-bar $ NSTitledWindowMask } + { textured-background $ NSTexturedBackgroundWindowMask } } : world>styleMask ( world -- n ) window-controls>> window-control>styleMask symbols>flags ; +: make-context-transparent ( view -- ) + -> openGLContext + 0 <int> NSOpenGLCPSurfaceOpacity -> setValues:forParameter: ; + M:: cocoa-ui-backend (open-window) ( world -- ) world [ [ dim>> ] dip <FactorView> ] with-world-pixel-format :> view + world window-controls>> textured-background swap memq? + [ view make-context-transparent ] when view world [ world>NSRect ] [ world>styleMask ] bi <ViewWindow> :> window view -> release world view register-window diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index a49d22735d..9577696314 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -399,6 +399,12 @@ CLASS: { ] } +{ "isOpaque" "char" { "id" "SEL" } + [ + 2drop 0 + ] +} + { "dealloc" "void" { "id" "SEL" } [ drop diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 1e01f889dc..0e07ff6611 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -5,14 +5,14 @@ USING: alien alien.c-types alien.strings arrays assocs ui ui.private ui.gadgets ui.gadgets.private ui.backend ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io kernel math math.vectors namespaces make sequences strings -vectors words windows.kernel32 windows.gdi32 windows.user32 -windows.opengl32 windows.messages windows.types -windows.offscreen windows.nt threads libc combinators fry -combinators.short-circuit continuations command-line shuffle +vectors words windows.dwmapi system-info.windows windows.kernel32 +windows.gdi32 windows.user32 windows.opengl32 windows.messages +windows.types windows.offscreen windows.nt threads libc combinators +fry combinators.short-circuit continuations command-line shuffle opengl ui.render math.bitwise locals accessors math.rectangles math.order calendar ascii sets io.encodings.utf16n windows.errors literals ui.pixel-formats -ui.pixel-formats.private memoize classes +ui.pixel-formats.private memoize classes colors specialized-arrays classes.struct alien.data ; SPECIALIZED-ARRAY: POINT IN: ui.backend.windows @@ -230,6 +230,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; CONSTANT: window-control>style H{ { close-button 0 } + { textured-background 0 } { minimize-button $ WS_MINIMIZEBOX } { maximize-button $ WS_MAXIMIZEBOX } { resize-handles $ WS_THICKFRAME } @@ -240,6 +241,7 @@ CONSTANT: window-control>style CONSTANT: window-control>ex-style H{ { close-button 0 } + { textured-background 0 } { minimize-button 0 } { maximize-button 0 } { resize-handles $ WS_EX_WINDOWEDGE } @@ -531,6 +533,21 @@ SYMBOL: nc-buttons #! message sent if mouse leaves main application 4drop forget-rollover ; +: system-background-color ( -- color ) + COLOR_BTNFACE GetSysColor RGB>color ; + +: ?make-glass ( world hwnd -- ) + over window-controls>> textured-background swap memq? [ + composition-enabled? [ + full-window-margins DwmExtendFrameIntoClientArea drop + T{ rgba f 0.0 0.0 0.0 0.0 } + ] [ drop system-background-color ] if >>background-color + drop + ] [ 2drop ] if ; + +: handle-wm-dwmcompositionchanged ( hWnd uMsg wParam lParam -- ) + 3drop [ window ] keep ?make-glass ; + SYMBOL: wm-handlers H{ } clone wm-handlers set-global @@ -560,6 +577,7 @@ H{ } clone wm-handlers set-global [ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler [ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler [ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler +[ handle-wm-dwmcompositionchanged 0 ] WM_DWMCOMPOSITIONCHANGED add-wm-handler [ 4dup handle-wm-ncbutton DefWindowProc ] { WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN @@ -688,8 +706,9 @@ M: windows-ui-backend (open-window) ( world -- ) [ dup [ ] [ world>style ] [ world>ex-style ] tri create-window + [ ?make-glass ] [ ?disable-close-button ] - [ [ f f ] dip f f <win> >>handle setup-gl ] 2bi + [ [ f f ] dip f f <win> >>handle setup-gl ] 2tri ] [ dup handle>> hWnd>> register-window ] [ handle>> hWnd>> show-window ] tri ; diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index aab7fd4c34..4c977f17a4 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types arrays ascii assocs +USING: accessors alien.c-types arrays ascii assocs colors classes.struct combinators io.encodings.ascii io.encodings.string io.encodings.utf8 kernel literals math namespaces sequences strings ui ui.backend ui.clipboards ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats ui.pixel-formats.private ui.private x11 x11.clipboard x11.constants x11.events x11.glx -x11.io x11.windows x11.xim x11.xlib environment command-line ; +x11.io x11.windows x11.xim x11.xlib environment command-line +combinators.short-circuit ; IN: ui.backend.x11 SINGLETON: x11-ui-backend @@ -107,9 +108,9 @@ CONSTANT: key-codes : valid-input? ( string gesture -- ? ) over empty? [ 2drop f ] [ mods>> { f { S+ } } member? [ - [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all? + [ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all? ] [ - [ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all? + [ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all? ] if ] if ; diff --git a/basis/ui/clipboards/clipboards-docs.factor b/basis/ui/clipboards/clipboards-docs.factor index 1b8121c505..de6a5ac97c 100644 --- a/basis/ui/clipboards/clipboards-docs.factor +++ b/basis/ui/clipboards/clipboards-docs.factor @@ -18,16 +18,22 @@ HELP: selection ARTICLE: "clipboard-protocol" "Clipboard protocol" "Custom gadgets that wish to interact with the clipboard must use the following two generic words to read and write clipboard contents:" -{ $subsection paste-clipboard } -{ $subsection copy-clipboard } +{ $subsections + paste-clipboard + copy-clipboard +} "UI backends can either implement the above two words in the case of an asynchronous clipboard model (for example, X11). If direct access to the clipboard is provided (Windows, Mac OS X), the following two generic words may be implemented instead:" -{ $subsection clipboard-contents } -{ $subsection set-clipboard-contents } +{ $subsections + clipboard-contents + set-clipboard-contents +} "However, gadgets should not call these words, since they will fail if only the asynchronous method of clipboard access is supported by the backend in use." $nl "Access to two clipboards is provided:" -{ $subsection clipboard } -{ $subsection selection } +{ $subsections + clipboard + selection +} "These variables may contain clipboard protocol implementations which transfer data to and from the native system clipboard. However an UI backend may leave one or both of these variables in their default state, which is a trivial clipboard implementation internal to the Factor UI." ; ABOUT: "clipboard-protocol" diff --git a/basis/ui/commands/commands-docs.factor b/basis/ui/commands/commands-docs.factor index b576f173b6..03dcb4afd1 100644 --- a/basis/ui/commands/commands-docs.factor +++ b/basis/ui/commands/commands-docs.factor @@ -106,32 +106,23 @@ HELP: define-command } } ; -HELP: command-string -{ $values { "gesture" "a gesture" } { "command" "a command" } { "string" string } } -{ $description "Outputs a string containing the command name followed by the gesture." } -{ $examples - { $unchecked-example - "USING: io ui.commands ui.gestures ;" - "IN: scratchpad" - ": com-my-command ;" - "T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write" - "My Command (C+s)" - } -} ; - ARTICLE: "ui-commands" "Commands" "Commands are an abstraction layered on top of gestures. Their main advantage is that they are identified by words and can be organized into " { $emphasis "command maps" } ". This allows easy construction of buttons and tool bars for invoking commands." -{ $subsection define-command } +{ $subsections define-command } "Command groups are defined on gadget classes:" -{ $subsection define-command-map } +{ $subsections define-command-map } "Commands can be introspected and invoked:" -{ $subsection commands } -{ $subsection command-map } -{ $subsection invoke-command } +{ $subsections + commands + command-map + invoke-command +} "Gadgets for invoking commands are documented in " { $link "ui.gadgets.buttons" } "." $nl "When documenting gadgets, command documentation can be automatically generated:" -{ $subsection $command-map } -{ $subsection $command } ; +{ $subsections + $command-map + $command +} ; ABOUT: "ui-commands" diff --git a/basis/ui/commands/commands.factor b/basis/ui/commands/commands.factor index f45c3f8b05..7988432676 100644 --- a/basis/ui/commands/commands.factor +++ b/basis/ui/commands/commands.factor @@ -78,10 +78,4 @@ M: word invoke-command ( target command -- ) M: word command-word ; -M: f invoke-command ( target command -- ) 2drop ; - -: command-string ( gesture command -- string ) - [ - command-name % - gesture>string [ " (" % % ")" % ] when* - ] "" make ; \ No newline at end of file +M: f invoke-command ( target command -- ) 2drop ; \ No newline at end of file diff --git a/basis/ui/gadgets/books/books-docs.factor b/basis/ui/gadgets/books/books-docs.factor index 38018fa720..2c20401316 100644 --- a/basis/ui/gadgets/books/books-docs.factor +++ b/basis/ui/gadgets/books/books-docs.factor @@ -17,8 +17,10 @@ HELP: <empty-book> ARTICLE: "ui-book-layout" "Book layouts" "Books can contain any number of children, and display one child at a time. The currently visible child is determined by the value of the model, which must be an integer." -{ $subsection book } -{ $subsection <book> } -{ $subsection <empty-book> } ; +{ $subsections + book + <book> + <empty-book> +} ; ABOUT: "ui-book-layout" diff --git a/basis/ui/gadgets/borders/borders-docs.factor b/basis/ui/gadgets/borders/borders-docs.factor index 1c0172041d..bd25abbe0f 100644 --- a/basis/ui/gadgets/borders/borders-docs.factor +++ b/basis/ui/gadgets/borders/borders-docs.factor @@ -10,7 +10,9 @@ HELP: <border> ARTICLE: "ui.gadgets.borders" "Border gadgets" "The " { $vocab-link "ui.gadgets.borders" } " vocabulary implements border gadgets, which add empty space around a child gadget." -{ $subsection border } -{ $subsection <border> } ; +{ $subsections + border + <border> +} ; ABOUT: "ui.gadgets.borders" diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor index 7f0d827fb8..cee38dbd78 100644 --- a/basis/ui/gadgets/buttons/buttons-docs.factor +++ b/basis/ui/gadgets/buttons/buttons-docs.factor @@ -48,17 +48,21 @@ HELP: <toolbar> ARTICLE: "ui.gadgets.buttons" "Button gadgets" "The " { $vocab-link "ui.gadgets.buttons" } " vocabulary implements buttons. Buttons respond to mouse clicks by invoking a quotation." -{ $subsection button } +{ $subsections button } "There are many ways to create a new button:" -{ $subsection <button> } -{ $subsection <roll-button> } -{ $subsection <border-button> } -{ $subsection <repeat-button> } +{ $subsections + <button> + <roll-button> + <border-button> + <repeat-button> +} "Gadgets for invoking commands:" -{ $subsection <command-button> } -{ $subsection <toolbar> } +{ $subsections + <command-button> + <toolbar> +} "Button appearance can be customized:" -{ $subsection button-pen } +{ $subsections button-pen } "Button constructors take " { $emphasis "label specifiers" } " as input. A label specifier is either a string, an array of strings, a gadget or " { $link f } "." { $see-also <command-button> "ui-commands" } ; diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index fb6f8153e9..061fd8d364 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -1,12 +1,13 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel math models namespaces sequences -strings quotations assocs combinators classes colors colors.constants -classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets -ui.gadgets.borders ui.gadgets.labels ui.gadgets.tracks -ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.pens ui.pens.solid -ui.pens.image ui.pens.tile math.rectangles locals fry -combinators.smart ; +USING: accessors arrays assocs classes classes.tuple colors +colors.constants combinators combinators.short-circuit +combinators.smart fry kernel locals math math.rectangles +math.vectors models namespaces opengl opengl.gl quotations +sequences strings ui.commands ui.gadgets ui.gadgets.borders +ui.gadgets.labels ui.gadgets.packs ui.gadgets.tracks +ui.gadgets.worlds ui.gestures ui.pens ui.pens.image +ui.pens.solid ui.pens.tile ; FROM: models => change-model ; IN: ui.gadgets.buttons @@ -30,7 +31,7 @@ PRIVATE> : button-update ( button -- ) dup - [ mouse-clicked? ] [ button-rollover? ] bi and + { [ mouse-clicked? ] [ button-rollover? ] } 1&& buttons-down? and >>pressed? relayout-1 ; @@ -42,8 +43,9 @@ PRIVATE> dup "" swap show-status button-update ; : button-clicked ( button -- ) - dup button-update - dup button-rollover? + [ ] + [ button-update ] + [ button-rollover? ] tri [ dup quot>> call( button -- ) ] [ drop ] if ; button H{ @@ -67,7 +69,9 @@ C: <button-pen> button-pen : button-pen ( button pen -- button pen ) over find-button { - { [ dup [ pressed?>> ] [ selected?>> ] bi and ] [ drop pressed-selected>> ] } + { [ dup { [ pressed?>> ] [ selected?>> ] } 1&& ] [ + drop pressed-selected>> + ] } { [ dup pressed?>> ] [ drop pressed>> ] } { [ dup selected?>> ] [ drop selected>> ] } { [ dup button-rollover? ] [ drop rollover>> ] } @@ -233,7 +237,7 @@ PRIVATE> '[ _ _ invoke-command ] ; : gesture>tooltip ( gesture -- str/f ) - dup [ gesture>string "Shortcut: " prepend ] when ; + gesture>string dup [ "Shortcut: " prepend ] when ; : <command-button> ( target gesture command -- button ) swapd [ command-name swap ] keep command-button-quot diff --git a/basis/ui/gadgets/editors/editors-docs.factor b/basis/ui/gadgets/editors/editors-docs.factor index 0ad37cb10f..3f7594ac01 100644 --- a/basis/ui/gadgets/editors/editors-docs.factor +++ b/basis/ui/gadgets/editors/editors-docs.factor @@ -67,24 +67,30 @@ HELP: set-editor-string ARTICLE: "gadgets-editors-selection" "The caret and mark" "If there is no selection, the caret and the mark are at the same location; otherwise the mark delimits the end-point of the selection opposite the caret." -{ $subsection editor-caret } -{ $subsection editor-mark } -{ $subsection change-caret } -{ $subsection change-caret&mark } -{ $subsection mark>caret } +{ $subsections + editor-caret + editor-mark + change-caret + change-caret&mark + mark>caret +} "Getting the selected text:" -{ $subsection gadget-selection? } -{ $subsection gadget-selection } +{ $subsections + gadget-selection? + gadget-selection +} "Removing selected text:" -{ $subsection remove-selection } +{ $subsections remove-selection } "Scrolling to the caret location:" -{ $subsection scroll>caret } +{ $subsections scroll>caret } "Use " { $link user-input* } " to change selected text." ; ARTICLE: "gadgets-editors-contents" "Getting and setting editor contents" -{ $subsection editor-string } -{ $subsection set-editor-string } -{ $subsection clear-editor } ; +{ $subsections + editor-string + set-editor-string + clear-editor +} ; ARTICLE: "gadgets-editors-commands" "Editor gadget commands" { $command-map editor "editing" } @@ -95,19 +101,23 @@ ARTICLE: "gadgets-editors-commands" "Editor gadget commands" ARTICLE: "ui.gadgets.editors" "Editor gadgets" "The " { $vocab-link "ui.gadgets.editors" } " vocabulary implements editor gadgets. An editor edits a passage of text. Editors display a " { $link document } ". Editors are built from and inherit all features of " { $link "ui.gadgets.line-support" } "." -{ $subsection "gadgets-editors-commands" } +{ $subsections "gadgets-editors-commands" } "Editors:" -{ $subsection editor } -{ $subsection <editor> } -{ $subsection "gadgets-editors-contents" } -{ $subsection "gadgets-editors-selection" } +{ $subsections + editor + <editor> + "gadgets-editors-contents" + "gadgets-editors-selection" +} "Multiline editors:" -{ $subsection <multiline-editor> } +{ $subsections <multiline-editor> } "Fields:" -{ $subsection <model-field> } -{ $subsection <action-field> } +{ $subsections + <model-field> + <action-field> +} "Editors edit " { $emphasis "documents" } ":" -{ $subsection "documents" } ; +{ $subsections "documents" } ; TIP: "Editor gadgets support undo and redo; press " { $command editor "editing" com-undo } " and " { $command editor "editing" com-redo } "." ; diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index b1b82a0542..f83c5d710a 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays documents documents.elements kernel math -math.ranges models models.arrow namespaces locals fry make opengl -opengl.gl sequences strings math.vectors math.functions sorting colors -colors.constants combinators assocs math.order calendar alarms -continuations ui.clipboards ui.commands ui.gadgets ui.gadgets.borders -ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers -ui.gadgets.menus ui.gadgets.wrappers ui.render ui.pens.solid -ui.gadgets.line-support ui.text ui.gestures ui.baseline-alignment -math.rectangles splitting unicode.categories grouping ; +USING: accessors alarms arrays assocs calendar colors.constants +combinators combinators.short-circuit documents +documents.elements fry grouping kernel locals make math +math.functions math.order math.ranges math.rectangles +math.vectors models models.arrow namespaces opengl sequences +sorting splitting ui.baseline-alignment ui.clipboards +ui.commands ui.gadgets ui.gadgets.borders +ui.gadgets.line-support ui.gadgets.menus ui.gadgets.scrollers +ui.gestures ui.pens.solid ui.render ui.text unicode.categories ; EXCLUDE: fonts => selection ; IN: ui.gadgets.editors @@ -37,14 +37,14 @@ focused? blink blink-alarm ; editor new-editor ; : activate-editor-model ( editor model -- ) - 2dup add-connection - dup activate-model - swap model>> add-loc ; + [ add-connection ] + [ nip activate-model ] + [ swap model>> add-loc ] 2tri ; : deactivate-editor-model ( editor model -- ) - 2dup remove-connection - dup deactivate-model - swap model>> remove-loc ; + [ remove-connection ] + [ nip deactivate-model ] + [ swap model>> remove-loc ] 2tri ; : blink-caret ( editor -- ) [ not ] change-blink relayout-1 ; @@ -71,23 +71,20 @@ SYMBOL: blink-interval ] [ drop ] if ; M: editor graft* - dup - dup caret>> activate-editor-model - dup mark>> activate-editor-model ; + [ dup caret>> activate-editor-model ] + [ dup mark>> activate-editor-model ] bi ; M: editor ungraft* - dup - dup stop-blinking - dup caret>> deactivate-editor-model - dup mark>> deactivate-editor-model ; + [ stop-blinking ] + [ dup caret>> deactivate-editor-model ] + [ dup mark>> deactivate-editor-model ] tri ; : editor-caret ( editor -- loc ) caret>> value>> ; : editor-mark ( editor -- loc ) mark>> value>> ; : set-caret ( loc editor -- ) - [ model>> validate-loc ] keep - caret>> set-model ; + [ model>> validate-loc ] [ caret>> ] bi set-model ; : change-caret ( editor quot -- ) [ [ [ editor-caret ] [ model>> ] bi ] dip call ] [ drop ] 2bi @@ -136,7 +133,7 @@ M: editor ungraft* [ editor-caret ] keep loc>point ; : caret-dim ( editor -- dim ) - line-height 0 swap 2array ; + [ 0 ] dip line-height 2array ; : scroll>caret ( editor -- ) dup graft-state>> second [ @@ -146,7 +143,7 @@ M: editor ungraft* ] [ drop ] if ; : draw-caret? ( editor -- ? ) - [ focused?>> ] [ blink>> ] bi and ; + { [ focused?>> ] [ blink>> ] } 1&& ; : draw-caret ( editor -- ) dup draw-caret? [ @@ -166,8 +163,9 @@ TUPLE: selected-line start end first? last? ; : compute-selection ( editor -- assoc ) dup gadget-selection? [ - [ selection-start/end [ [ first ] bi@ [a,b] ] 2keep ] keep model>> - '[ [ _ _ ] keep _ start/end-on-line 2array ] H{ } map>assoc + [ selection-start/end [ [ first ] bi@ [a,b] ] [ ] 2bi ] + [ model>> ] bi + '[ [ _ _ ] [ _ start/end-on-line ] bi 2array ] H{ } map>assoc ] [ drop f ] if ; :: draw-selection ( line pair editor -- ) @@ -186,8 +184,8 @@ TUPLE: selected-line start end first? last? ; ] [ [ draw-selection ] [ - [ [ first2 ] [ selection-color>> ] bi* <selection> ] keep - draw-unselected-line + [ [ first2 ] [ selection-color>> ] bi* <selection> ] + [ draw-unselected-line ] bi ] 3bi ] if ; @@ -209,32 +207,31 @@ M: editor baseline font>> font-metrics ascent>> ; M: editor cap-height font>> font-metrics cap-height>> ; : contents-changed ( model editor -- ) - swap - over caret>> [ over validate-loc ] (change-model) - over mark>> [ over validate-loc ] (change-model) - drop relayout ; + [ [ nip caret>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ] + [ [ nip mark>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ] + [ nip relayout ] 2tri ; -: caret/mark-changed ( model editor -- ) - nip [ restart-blinking ] [ scroll>caret ] bi ; +: caret/mark-changed ( editor -- ) + [ restart-blinking ] keep scroll>caret ; M: editor model-changed { { [ 2dup model>> eq? ] [ contents-changed ] } - { [ 2dup caret>> eq? ] [ caret/mark-changed ] } - { [ 2dup mark>> eq? ] [ caret/mark-changed ] } + { [ 2dup caret>> eq? ] [ nip caret/mark-changed ] } + { [ 2dup mark>> eq? ] [ nip caret/mark-changed ] } } cond ; M: editor gadget-selection? selection-start/end = not ; M: editor gadget-selection - [ selection-start/end ] keep model>> doc-range ; + [ selection-start/end ] [ model>> ] bi doc-range ; : remove-selection ( editor -- ) - [ selection-start/end ] keep model>> remove-doc-range ; + [ selection-start/end ] [ model>> ] bi remove-doc-range ; M: editor user-input* - [ selection-start/end ] keep model>> set-doc-range t ; + [ selection-start/end ] [ model>> ] bi set-doc-range t ; : editor-string ( editor -- string ) model>> doc-string ; @@ -245,9 +242,9 @@ M: editor user-input* M: editor gadget-text* editor-string % ; : extend-selection ( editor -- ) - dup request-focus - dup restart-blinking - dup caret>> click-loc ; + [ request-focus ] + [ restart-blinking ] + [ dup caret>> click-loc ] tri ; : mouse-elt ( -- element ) hand-click# get { @@ -260,24 +257,25 @@ M: editor gadget-text* editor-string % ; : drag-selection-caret ( loc editor element -- loc ) [ - [ drag-direction? ] 2keep model>> + [ drag-direction? ] [ model>> ] 2bi ] dip prev/next-elt ? ; : drag-selection-mark ( loc editor element -- loc ) [ - [ drag-direction? not ] keep - [ editor-mark ] [ model>> ] bi + [ drag-direction? not ] + [ editor-mark ] + [ model>> ] tri ] dip prev/next-elt ? ; : drag-caret&mark ( editor -- caret mark ) - dup clicked-loc swap mouse-elt - [ drag-selection-caret ] 3keep - drag-selection-mark ; + [ clicked-loc ] [ mouse-elt ] bi + [ drag-selection-caret ] + [ drag-selection-mark ] 3bi ; : drag-selection ( editor -- ) - dup drag-caret&mark - pick mark>> set-model - swap caret>> set-model ; + [ drag-caret&mark ] + [ mark>> set-model ] + [ caret>> set-model ] tri ; : editor-cut ( editor clipboard -- ) [ gadget-copy ] [ drop remove-selection ] 2bi ; @@ -343,11 +341,9 @@ M: editor gadget-text* editor-string % ; : delete-to-end-of-line ( editor -- ) one-line-elt editor-backspace ; -: com-undo ( editor -- ) - model>> undo ; +: com-undo ( editor -- ) model>> undo ; -: com-redo ( editor -- ) - model>> redo ; +: com-redo ( editor -- ) model>> redo ; editor "editing" f { { undo-action com-undo } @@ -515,7 +511,7 @@ PRIVATE> "\n" swap user-input* drop ; : change-selection ( editor quot -- ) - '[ gadget-selection @ ] keep user-input* drop ; inline + '[ gadget-selection @ ] [ user-input* drop ] bi ; inline : join-lines ( string -- string' ) "\n" split @@ -526,7 +522,7 @@ PRIVATE> : this-line-and-next ( document line -- start end ) [ nip 0 swap 2array ] - [ [ nip 1 + ] [ 1 + swap doc-line length ] 2bi 2array ] + [ 1 + [ nip ] [ swap doc-line length ] 2bi 2array ] 2bi ; : last-line? ( document line -- ? ) @@ -589,15 +585,16 @@ TUPLE: field < border editor min-cols max-cols ; M: field font>> editor>> font>> ; M: field pref-dim* - dup - [ editor>> pref-dim ] keep - [ line-gadget-width ] [ drop second ] 2bi 2array - border-pref-dim ; + [ ] + [ editor>> pref-dim ] + [ [ line-gadget-width ] [ drop second ] 2bi 2array ] + tri border-pref-dim ; TUPLE: model-field < field field-model ; : <model-field> ( model -- gadget ) - model-field new-field swap >>field-model ; + model-field new-field + swap >>field-model ; M: model-field graft* [ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ] @@ -613,7 +610,8 @@ M: model-field model-changed TUPLE: action-field < field quot ; : <action-field> ( quot -- gadget ) - action-field new-field swap >>quot ; + action-field new-field + swap >>quot ; : invoke-action-field ( field -- ) [ editor>> editor-string ] diff --git a/basis/ui/gadgets/frames/frames-docs.factor b/basis/ui/gadgets/frames/frames-docs.factor index 006d842673..b82870779a 100644 --- a/basis/ui/gadgets/frames/frames-docs.factor +++ b/basis/ui/gadgets/frames/frames-docs.factor @@ -8,9 +8,9 @@ $nl "The filled cell's column/row pair is stored in the frame gadget's " { $slot "filled-cell" } " slot. If the actual dimensions of a frame exceed it preferred dimensions, then the fill slot is resized appropriately, together with its row and column." $nl "Because frames inherit from grids, grid layout words can be used to add and remove children." -{ $subsection frame } +{ $subsections frame } "Creating empty frames:" -{ $subsection <frame> } ; +{ $subsections <frame> } ; HELP: frame { $class-description "A frame is a gadget which lays out its children in a grid, and assigns all remaining space to a distinguished filled cell. The " { $slot "filled-cell" } " slot stores a pair with shape " { $snippet "{ col row }" } "." diff --git a/basis/ui/gadgets/frames/frames.factor b/basis/ui/gadgets/frames/frames.factor index 168fb4bb11..884813916f 100644 --- a/basis/ui/gadgets/frames/frames.factor +++ b/basis/ui/gadgets/frames/frames.factor @@ -26,7 +26,8 @@ M: glue pref-dim* drop { 0 0 } ; length 1 + * [-] ; inline : -center) ( pref-dim gap filled-cell dims -- ) - [ nip available-space ] 2keep [ remove-nth sum [-] ] 2keep set-nth ; inline + [ nip available-space ] + [ [ remove-nth sum [-] ] [ set-nth ] 2bi ] 2bi ; inline : (fill-center) ( frame grid-layout quot1 quot2 -- ) (fill- -center) ; inline @@ -35,7 +36,7 @@ M: glue pref-dim* drop { 0 0 } ; [ [ second ] [ row-heights>> ] (fill-center) ] 2bi ; : <frame-layout> ( frame -- grid-layout ) - dup <grid-layout> [ fill-center ] keep ; + dup <grid-layout> [ fill-center ] [ ] bi ; PRIVATE> diff --git a/basis/ui/gadgets/gadgets-docs.factor b/basis/ui/gadgets/gadgets-docs.factor index 557c6f812c..606cf1a9af 100644 --- a/basis/ui/gadgets/gadgets-docs.factor +++ b/basis/ui/gadgets/gadgets-docs.factor @@ -185,6 +185,8 @@ ARTICLE: "ui-control-impl" "Implementing controls" "A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $snippet "model" } " slot set to a " { $link model } " instance." $nl "Some utility words useful in control implementations:" -{ $subsection control-value } -{ $subsection set-control-value } +{ $subsections + control-value + set-control-value +} { $see-also "models" } ; diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 26d0fee2e3..e4a0e672d2 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -85,7 +85,7 @@ M: gadget contains-point? ( loc gadget -- ? ) : pick-up ( point gadget -- child/f ) 2dup [ dup point>rect ] dip children-on [ contains-point? ] with find-last nip - [ [ loc>> v- ] keep pick-up ] [ nip ] ?if ; + [ [ loc>> v- ] [ pick-up ] bi ] [ nip ] ?if ; : max-dim ( dims -- dim ) { 0 0 } [ vmax ] reduce ; @@ -183,7 +183,7 @@ GENERIC: pref-dim* ( gadget -- dim ) : pref-dim ( gadget -- dim ) dup pref-dim>> [ ] [ - [ pref-dim* ] keep dup layout-state>> + [ pref-dim* ] [ ] [ layout-state>> ] tri [ drop ] [ dupd (>>pref-dim) ] if ] ?if ; @@ -267,7 +267,7 @@ M: gadget ungraft* drop ; : notify ( gadget -- ) dup graft-state>> - [ first { f f } { t t } ? >>graft-state ] keep + [ first { f f } { t t } ? >>graft-state ] [ ] bi { { { f t } [ dup activate-control graft* ] } { { t f } [ dup deactivate-control ungraft* ] } diff --git a/basis/ui/gadgets/glass/glass-docs.factor b/basis/ui/gadgets/glass/glass-docs.factor index bd9028d414..04e6f12dfc 100644 --- a/basis/ui/gadgets/glass/glass-docs.factor +++ b/basis/ui/gadgets/glass/glass-docs.factor @@ -43,13 +43,15 @@ $nl "This feature is used for completion popups and " { $link "ui.gadgets.menus" } " in the " { $link "ui-tools" } "." $nl "Displaying a gadget in a glass layer:" -{ $subsection show-glass } +{ $subsections show-glass } "Hiding a gadget in a glass layer:" -{ $subsection hide-glass } +{ $subsections hide-glass } "Callback generic invoked on the gadget when its glass layer is hidden:" -{ $subsection hide-glass-hook } +{ $subsections hide-glass-hook } "Popup gadgets add support for forwarding keyboard gestures from an owner gadget to the glass layer:" -{ $subsection show-popup } -{ $subsection pass-to-popup } ; +{ $subsections + show-popup + pass-to-popup +} ; ABOUT: "ui.gadgets.glass" \ No newline at end of file diff --git a/basis/ui/gadgets/grid-lines/grid-lines-docs.factor b/basis/ui/gadgets/grid-lines/grid-lines-docs.factor index 2101e3598e..e28786723e 100644 --- a/basis/ui/gadgets/grid-lines/grid-lines-docs.factor +++ b/basis/ui/gadgets/grid-lines/grid-lines-docs.factor @@ -11,7 +11,9 @@ HELP: <grid-lines> { $description "Creates a new " { $link grid-lines } "." } ; ARTICLE: "ui.gadgets.grid-lines" "Grid lines" -{ $subsection grid-lines } -{ $subsection <grid-lines> } ; +{ $subsections + grid-lines + <grid-lines> +} ; ABOUT: "ui.gadgets.grid-lines" \ No newline at end of file diff --git a/basis/ui/gadgets/grids/grids-docs.factor b/basis/ui/gadgets/grids/grids-docs.factor index 66db44f524..10b3bb7259 100644 --- a/basis/ui/gadgets/grids/grids-docs.factor +++ b/basis/ui/gadgets/grids/grids-docs.factor @@ -3,15 +3,17 @@ IN: ui.gadgets.grids ARTICLE: "ui-grid-layout" "Grid layouts" "Grid gadgets layout their children in a rectangular grid." -{ $subsection grid } +{ $subsections grid } "Creating grids from a fixed set of gadgets:" -{ $subsection <grid> } +{ $subsections <grid> } "Managing children:" -{ $subsection grid-add } -{ $subsection grid-remove } -{ $subsection grid-child } +{ $subsections + grid-add + grid-remove + grid-child +} "Grid lines:" -{ $subsection "ui.gadgets.grid-lines" } ; +{ $subsections "ui.gadgets.grid-lines" } ; HELP: grid { $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height." diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index ddcfa1465d..9b5b737406 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/basis/ui/gadgets/grids/grids.factor @@ -27,7 +27,9 @@ PRIVATE> : grid-child ( grid pair -- gadget ) grid@ nth ; : grid-add ( grid child pair -- grid ) - [ nip grid-child unparent ] [ drop add-gadget ] [ swapd grid@ set-nth ] 3tri ; + [ nip grid-child unparent ] + [ drop add-gadget ] + [ swapd grid@ set-nth ] 3tri ; : grid-remove ( grid pair -- grid ) [ <gadget> ] dip grid-add ; @@ -114,8 +116,7 @@ M: grid layout* [ grid>> ] [ <grid-layout> ] bi grid-layout ; M: grid children-on ( rect gadget -- seq ) dup children>> empty? [ 2drop f ] [ [ { 0 1 } ] dip grid>> - [ 0 <column> fast-children-on ] keep - <slice> concat + [ 0 <column> fast-children-on ] [ <slice> concat ] bi ] if ; M: grid gadget-text* @@ -123,4 +124,4 @@ M: grid gadget-text* [ [ gadget-text ] map ] map format-table [ CHAR: \n , ] [ % ] interleave ; -PRIVATE> \ No newline at end of file +PRIVATE> diff --git a/basis/ui/gadgets/incremental/incremental-docs.factor b/basis/ui/gadgets/incremental/incremental-docs.factor index 930d5ed502..cf408174c1 100644 --- a/basis/ui/gadgets/incremental/incremental-docs.factor +++ b/basis/ui/gadgets/incremental/incremental-docs.factor @@ -34,11 +34,15 @@ $nl "Incremental layout is used by " { $link "ui.gadgets.panes" } " to ensure that new lines of output does not take longer to display when the pane already has previous output." $nl "Incremental layouts are not a general replacement for " { $link "ui-pack-layout" } " and there are some limitations to be aware of." -{ $subsection incremental } -{ $subsection <incremental> } +{ $subsections + incremental + <incremental> +} "Children are added and removed with a special set of words which perform necessary relayout immediately:" -{ $subsection add-incremental } -{ $subsection clear-incremental } +{ $subsections + add-incremental + clear-incremental +} "Calling " { $link unparent } " to remove a child of an incremental layout is permitted, however the relayout following the removal will not be performed in constant time, because all gadgets following the removed gadget need to be moved." ; ABOUT: "ui-incremental-layout" diff --git a/basis/ui/gadgets/labeled/labeled-docs.factor b/basis/ui/gadgets/labeled/labeled-docs.factor index 831ae2a127..3211763750 100644 --- a/basis/ui/gadgets/labeled/labeled-docs.factor +++ b/basis/ui/gadgets/labeled/labeled-docs.factor @@ -11,7 +11,9 @@ HELP: <labeled-gadget> ARTICLE: "ui.gadgets.labeled" "Labeled gadgets" "The " { $vocab-link "ui.gadgets.labeled" } " vocabulary implements labeled borders around child gadgets." -{ $subsection labeled-gadget } -{ $subsection <labeled-gadget> } ; +{ $subsections + labeled-gadget + <labeled-gadget> +} ; ABOUT: "ui.gadgets.labeled" diff --git a/basis/ui/gadgets/labels/labels-docs.factor b/basis/ui/gadgets/labels/labels-docs.factor index 066a79b900..dcbf638efc 100644 --- a/basis/ui/gadgets/labels/labels-docs.factor +++ b/basis/ui/gadgets/labels/labels-docs.factor @@ -16,13 +16,15 @@ HELP: <label-control> ARTICLE: "ui.gadgets.labels" "Label gadgets" "The " { $vocab-link "ui.gadgets.labels" } " vocabulary implements labels. A label displays a piece of text, which is either a single line string or an array of line strings." -{ $subsection label } -{ $subsection <label> } -{ $subsection <label-control> } +{ $subsections + label + <label> + <label-control> +} "Labels have a virtual slot named " { $slot "string" } " which contains the displayed text. The " { $slot "text" } " slot should not be set directly." $nl "Label specifiers are used by buttons, checkboxes and radio buttons:" -{ $subsection >label } ; +{ $subsections >label } ; ABOUT: "ui.gadgets.labels" diff --git a/basis/ui/gadgets/line-support/line-support-docs.factor b/basis/ui/gadgets/line-support/line-support-docs.factor index 164f8d3ddc..f52b2efe1f 100644 --- a/basis/ui/gadgets/line-support/line-support-docs.factor +++ b/basis/ui/gadgets/line-support/line-support-docs.factor @@ -5,25 +5,33 @@ ARTICLE: "ui.gadgets.line-support" "Gadget line support" "The " { $vocab-link "ui.gadgets.line-support" } " vocabulary provides common code shared by gadgets which display a sequence of lines of text. Currently, the two gadgets that use it are " { $link "ui.gadgets.editors" } " and " { $link "ui.gadgets.tables" } "." $nl "The class of line gadgets:" -{ $subsection line-gadget } -{ $subsection line-gadget? } +{ $subsections + line-gadget + line-gadget? +} "Line gadgets are backed by a model which must be a sequence. The number of lines in the gadget is the length of the sequence." $nl "Line gadgets cannot be created and used directly, instead a subclass must be defined:" -{ $subsection new-line-gadget } +{ $subsections new-line-gadget } "Subclasses must implement a generic word:" -{ $subsection draw-line } +{ $subsections draw-line } "Two optional generic words may be implemented; if they are not implemented in the subclass, a default implementation based on font metrics will be used:" -{ $subsection line-height } -{ $subsection line-leading } +{ $subsections + line-height + line-leading +} "Validating line numbers:" -{ $subsection validate-line } +{ $subsections validate-line } "Working with visible lines:" -{ $subsection visible-lines } -{ $subsection first-visible-line } -{ $subsection last-visible-line } +{ $subsections + visible-lines + first-visible-line + last-visible-line +} "Converting y co-ordinates to line numbers, and vice versa:" -{ $subsection line>y } -{ $subsection y>line } ; +{ $subsections + line>y + y>line +} ; ABOUT: "ui.gadgets.line-support" \ No newline at end of file diff --git a/basis/ui/gadgets/line-support/line-support.factor b/basis/ui/gadgets/line-support/line-support.factor index 3292e3e6c5..c229c8c075 100644 --- a/basis/ui/gadgets/line-support/line-support.factor +++ b/basis/ui/gadgets/line-support/line-support.factor @@ -79,7 +79,7 @@ PRIVATE> [ second ] [ [ line-height ] [ min-rows>> ] [ max-rows>> ] tri ] bi* clamp ; M: line-gadget pref-viewport-dim - [ pref-dim ] keep + [ pref-dim ] [ ] bi [ line-gadget-width ] [ line-gadget-height ] 2bi 2array ; diff --git a/basis/ui/gadgets/menus/menus-docs.factor b/basis/ui/gadgets/menus/menus-docs.factor index ad0881a382..bebfaf13fe 100644 --- a/basis/ui/gadgets/menus/menus-docs.factor +++ b/basis/ui/gadgets/menus/menus-docs.factor @@ -17,8 +17,10 @@ HELP: show-commands-menu ARTICLE: "ui.gadgets.menus" "Popup menus" "The " { $vocab-link "ui.gadgets.menus" } " vocabulary displays popup menus in " { $link "ui.gadgets.glass" } "." -{ $subsection <commands-menu> } -{ $subsection show-menu } -{ $subsection show-commands-menu } ; +{ $subsections + <commands-menu> + show-menu + show-commands-menu +} ; ABOUT: "ui.gadgets.menus" diff --git a/basis/ui/gadgets/packs/packs-docs.factor b/basis/ui/gadgets/packs/packs-docs.factor index 938a8bf740..6d477bd936 100644 --- a/basis/ui/gadgets/packs/packs-docs.factor +++ b/basis/ui/gadgets/packs/packs-docs.factor @@ -5,15 +5,19 @@ IN: ui.gadgets.packs ARTICLE: "ui-pack-layout" "Pack layouts" "Pack gadgets layout their children along a single axis." -{ $subsection pack } +{ $subsections pack } "Creating empty packs:" -{ $subsection <pack> } -{ $subsection <pile> } -{ $subsection <shelf> } +{ $subsections + <pack> + <pile> + <shelf> +} "For more control, custom layouts can reuse portions of pack layout logic:" -{ $subsection pack-pref-dim } -{ $subsection pack-layout } ; +{ $subsections + pack-pref-dim + pack-layout +} ; HELP: pack { $class-description "A gadget which lays out its children along a single axis stored in the " { $snippet "orientation" } " slot. Can be constructed with one of the following words:" diff --git a/basis/ui/gadgets/panes/panes-docs.factor b/basis/ui/gadgets/panes/panes-docs.factor index cb747bf84d..8b9988b0ff 100644 --- a/basis/ui/gadgets/panes/panes-docs.factor +++ b/basis/ui/gadgets/panes/panes-docs.factor @@ -49,20 +49,28 @@ HELP: <pane-stream> ARTICLE: "ui.gadgets.panes" "Pane gadgets" "The " { $vocab-link "ui.gadgets.panes" } " vocabulary implements panes, which display formatted text." -{ $subsection pane } -{ $subsection <pane> } -{ $subsection <pane-control> } +{ $subsections + pane + <pane> + <pane-control> +} "Panes are written to by creating a special output stream:" -{ $subsection pane-stream } -{ $subsection <pane-stream> } +{ $subsections + pane-stream + <pane-stream> +} "In addition to the stream output words (" { $link "stream-protocol" } ", pane streams can have gadgets written to them:" -{ $subsection write-gadget } -{ $subsection print-gadget } -{ $subsection gadget. } +{ $subsections + write-gadget + print-gadget + gadget. +} "The " { $link gadget. } " word is useful for interactive debugging of gadgets in the listener." $nl "There are a few combinators for working with panes:" -{ $subsection with-pane } -{ $subsection make-pane } ; +{ $subsections + with-pane + make-pane +} ; ABOUT: "ui.gadgets.panes" diff --git a/basis/ui/gadgets/presentations/presentations-docs.factor b/basis/ui/gadgets/presentations/presentations-docs.factor index 4b98f65c82..3404f1d7f6 100644 --- a/basis/ui/gadgets/presentations/presentations-docs.factor +++ b/basis/ui/gadgets/presentations/presentations-docs.factor @@ -45,7 +45,9 @@ ARTICLE: "ui.gadgets.presentations" "Presentation gadgets" "The " { $vocab-link "ui.gadgets.presentations" } " vocabulary implements presentations, which are graphical representations of an object, associated with the object itself (see " { $link "ui-operations" } ")." $nl "Clicking a presentation with the left mouse button invokes the object's primary operation, and clicking with the right mouse button displays a menu of all applicable operations. Presentations are usually not constructed directly, and instead are written to " { $link "ui.gadgets.panes" } " with formatted stream output words (see " { $link "presentations" } ")." -{ $subsection presentation } -{ $subsection <presentation> } ; +{ $subsections + presentation + <presentation> +} ; ABOUT: "ui.gadgets.presentations" diff --git a/basis/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor index 011afa5c97..1e4b875f28 100644 --- a/basis/ui/gadgets/scrollers/scrollers-docs.factor +++ b/basis/ui/gadgets/scrollers/scrollers-docs.factor @@ -45,15 +45,21 @@ HELP: scroll>top ARTICLE: "ui.gadgets.scrollers" "Scroller gadgets" "The " { $vocab-link "ui.gadgets.scrollers" } " vocabulary implements scroller gadgets. A scroller displays a gadget which is larger than the visible area." -{ $subsection scroller } -{ $subsection <scroller> } +{ $subsections + scroller + <scroller> +} "Getting and setting the scroll position:" -{ $subsection scroll-position } -{ $subsection set-scroll-position } +{ $subsections + scroll-position + set-scroll-position +} "Writing scrolling-aware gadgets:" -{ $subsection scroll>bottom } -{ $subsection scroll>top } -{ $subsection scroll>rect } -{ $subsection find-scroller } ; +{ $subsections + scroll>bottom + scroll>top + scroll>rect + find-scroller +} ; ABOUT: "ui.gadgets.scrollers" diff --git a/basis/ui/gadgets/sliders/sliders-docs.factor b/basis/ui/gadgets/sliders/sliders-docs.factor index 570291a18f..c59c1360fe 100644 --- a/basis/ui/gadgets/sliders/sliders-docs.factor +++ b/basis/ui/gadgets/sliders/sliders-docs.factor @@ -35,12 +35,16 @@ HELP: <slider> ARTICLE: "ui.gadgets.sliders" "Slider gadgets" "The " { $vocab-link "ui.gadgets.sliders" } " vocabulary implements slider gadgets. A slider allows the user to graphically manipulate a value by moving a thumb back and forth." -{ $subsection slider } -{ $subsection <slider> } +{ $subsections + slider + <slider> +} "Changing slider values:" -{ $subsection slide-by } -{ $subsection slide-by-line } -{ $subsection slide-by-page } +{ $subsections + slide-by + slide-by-line + slide-by-page +} "Since sliders are controls the value can be get and set by via the " { $snippet "model" } " slot. " ; ABOUT: "ui.gadgets.sliders" diff --git a/basis/ui/gadgets/status-bar/status-bar-docs.factor b/basis/ui/gadgets/status-bar/status-bar-docs.factor index 7a68310e36..115c8783f8 100644 --- a/basis/ui/gadgets/status-bar/status-bar-docs.factor +++ b/basis/ui/gadgets/status-bar/status-bar-docs.factor @@ -24,10 +24,12 @@ HELP: open-status-window ARTICLE: "ui.gadgets.status-bar" "Status bars and mouse-over help" "The " { $vocab-link "ui.gadgets.status-bar" } " vocabulary implements a word to display windows with a status bar." -{ $subsection open-status-window } +{ $subsections open-status-window } "Gadgets can use a pair of words to show and hide status bar messages. These words will work in any gadget, but will have no effect unless the gadget is displayed inside a window with a status bar." -{ $subsection show-status } -{ $subsection hide-status } +{ $subsections + show-status + hide-status +} { $link "ui.gadgets.presentations" } " use the status bar to display object summary." ; ABOUT: "ui.gadgets.status-bar" diff --git a/basis/ui/gadgets/tables/tables-docs.factor b/basis/ui/gadgets/tables/tables-docs.factor index 81e5f0f778..057c8320ac 100644 --- a/basis/ui/gadgets/tables/tables-docs.factor +++ b/basis/ui/gadgets/tables/tables-docs.factor @@ -5,15 +5,19 @@ ARTICLE: "ui.gadgets.tables.renderers" "Table row renderer protocol" "Table gadgets use a row renderer to display rows and do a few other things." $nl "Renderers are usually instances of singleton classes, since they don't need any state of their own. Renderers are required to implement a single generic word:" -{ $subsection row-columns } +{ $subsections row-columns } "Renderers can also implement the following optional generic words for additional row information:" -{ $subsection row-value } -{ $subsection row-color } +{ $subsections + row-value + row-color +} "The following optional generic words allow the renderer to provide some information about the display of all rows:" -{ $subsection prototype-row } -{ $subsection column-alignment } -{ $subsection filled-column } -{ $subsection column-titles } ; +{ $subsections + prototype-row + column-alignment + filled-column + column-titles +} ; ARTICLE: "ui.gadgets.tables.selection" "Table row selection" "A few slots in the table gadget concern row selection:" @@ -24,9 +28,11 @@ ARTICLE: "ui.gadgets.tables.selection" "Table row selection" { { $slot "multiple-selection?" } { " - if set to a true value, users are allowed to select more than one value." } } } "Some words for row selection:" -{ $subsection selected-rows } -{ $subsection (selected-rows) } -{ $subsection selected } ; +{ $subsections + selected-rows + (selected-rows) + selected +} ; ARTICLE: "ui.gadgets.tables.actions" "Table row actions" "When the user double-clicks on a row, or presses " { $command table "row" row-action } " while a row is selected, optional action and hook quotations are invoked. The action receives the row value and the hook receives the table gadget itself. These quotations are stored in the " { $slot "action" } " and " { $snippet "hook" } " slots of a table, respectively." @@ -34,7 +40,7 @@ $nl "If the " { $slot "single-click?" } " slot is set to a true value, then single-clicking on a row will invoke the row action. The default value is " { $link f } "." $nl "The row action can also be invoked programmatically:" -{ $subsection row-action } ; +{ $subsections row-action } ; ARTICLE: "ui.gadgets.tables.config" "Table gadget configuration" "Various slots in the table gadget can be set to change the appearance and behavior of the table gadget." @@ -55,13 +61,17 @@ $nl "Tables display a model as a series of rows. The model must be a sequence, and a " { $emphasis "renderer" } " creates a sequence of columns for each row. Tables are built from and inherit all features of " { $link "ui.gadgets.line-support" } "." { $command-map table "row" } "The class of tables:" -{ $subsection table } -{ $subsection table? } +{ $subsections + table + table? +} "Creating new tables:" -{ $subsection <table> } -{ $subsection "ui.gadgets.tables.renderers" } -{ $subsection "ui.gadgets.tables.selection" } -{ $subsection "ui.gadgets.tables.actions" } -{ $subsection "ui.gadgets.tables.example" } ; +{ $subsections + <table> + "ui.gadgets.tables.renderers" + "ui.gadgets.tables.selection" + "ui.gadgets.tables.actions" + "ui.gadgets.tables.example" +} ; ABOUT: "ui.gadgets.tables" \ No newline at end of file diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index ccc5550adb..c907e90673 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -307,7 +307,7 @@ PRIVATE> '[ _ row-value eq? ] with find drop ; : (update-selected-indices) ( table -- set ) - [ selection>> value>> dup [ array? not ] [ ] bi and [ 1array ] when ] keep + [ selection>> value>> dup { [ array? not ] [ ] } 1&& [ 1array ] when ] keep '[ _ find-row-index ] map sift unique f assoc-like ; : initial-selected-indices ( table -- set ) diff --git a/basis/ui/gadgets/tracks/tracks-docs.factor b/basis/ui/gadgets/tracks/tracks-docs.factor index b83865fd52..0bbedc8d0d 100644 --- a/basis/ui/gadgets/tracks/tracks-docs.factor +++ b/basis/ui/gadgets/tracks/tracks-docs.factor @@ -4,11 +4,11 @@ IN: ui.gadgets.tracks ARTICLE: "ui-track-layout" "Track layouts" "Track gadgets are like " { $link "ui-pack-layout" } " except each child is resized to a fixed multiple of the track's dimension." -{ $subsection track } +{ $subsections track } "Creating empty tracks:" -{ $subsection <track> } +{ $subsections <track> } "Adding children:" -{ $subsection track-add } ; +{ $subsections track-add } ; HELP: track { $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $snippet "orientation" } ". Tracks are created by calling " { $link <track> } "." } ; diff --git a/basis/ui/gadgets/tracks/tracks.factor b/basis/ui/gadgets/tracks/tracks.factor index 92268690ac..4bccab8c98 100644 --- a/basis/ui/gadgets/tracks/tracks.factor +++ b/basis/ui/gadgets/tracks/tracks.factor @@ -61,6 +61,7 @@ PRIVATE> pick sizes>> push add-gadget ; M: track remove-gadget - [ [ children>> index ] keep sizes>> delete-nth ] [ call-next-method ] 2bi ; + [ [ children>> index ] [ sizes>> ] bi delete-nth ] + [ call-next-method ] 2bi ; : clear-track ( track -- ) [ sizes>> delete-all ] [ clear-gadget ] bi ; diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor index 7359ac82d3..83d042db43 100755 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -99,22 +99,26 @@ HELP: draw-world* ARTICLE: "ui.gadgets.worlds-subclassing" "Subclassing worlds" "The " { $link world } " gadget can be subclassed, giving Factor code full control of the window's OpenGL context. The following generic words can be overridden to replace standard UI behavior:" -{ $subsection begin-world } -{ $subsection end-world } -{ $subsection resize-world } -{ $subsection draw-world* } +{ $subsections + begin-world + end-world + resize-world + draw-world* +} "See the " { $vocab-link "spheres" } " and " { $vocab-link "bunny" } " demos for examples." ; ARTICLE: "ui-paint-custom" "Implementing custom drawing logic" "The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:" -{ $subsection draw-gadget* } +{ $subsections draw-gadget* } "Custom drawing code has access to the full OpenGL API in the " { $vocab-link "opengl" } " vocabulary." $nl "Gadgets which need to allocate and deallocate OpenGL resources such as textures, display lists, and so on, should perform the allocation in the " { $link graft* } " method, and the deallocation in the " { $link ungraft* } " method. Since those words are not necessarily called with the gadget's OpenGL context active, a utility word can be used to find and make the correct OpenGL context current:" -{ $subsection find-gl-context } +{ $subsections find-gl-context } "OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa. To take full control of the OpenGL context, see " { $link "ui.gadgets.worlds-subclassing" } "." -{ $subsection "ui-paint-coord" } -{ $subsection "ui.gadgets.worlds-subclassing" } -{ $subsection "gl-utilities" } -{ $subsection "text-rendering" } ; +{ $subsections + "ui-paint-coord" + "ui.gadgets.worlds-subclassing" + "gl-utilities" + "text-rendering" +} ; diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 91666c4e7a..b736c3f74f 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs continuations kernel math models -namespaces opengl opengl.textures sequences io combinators +namespaces opengl opengl.textures sequences io colors combinators combinators.short-circuit fry math.vectors math.rectangles cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks ui.pixel-formats destructors literals strings ; @@ -13,10 +13,15 @@ SYMBOLS: maximize-button resize-handles small-title-bar - normal-title-bar ; + normal-title-bar + textured-background ; CONSTANT: default-world-pixel-format-attributes - { windowed double-buffered T{ depth-bits { value 16 } } } + { + windowed + double-buffered + T{ depth-bits { value 16 } } + } CONSTANT: default-world-window-controls { @@ -34,6 +39,7 @@ TUPLE: world < track text-handle handle images window-loc pixel-format-attributes + background-color window-controls window-resources ; @@ -113,12 +119,18 @@ M: world request-focus-on ( child gadget -- ) f >>grab-input? V{ } clone >>window-resources ; +: initial-background-color ( attributes -- color ) + window-controls>> textured-background swap memq? + [ T{ rgba f 0.0 0.0 0.0 0.0 } ] + [ T{ rgba f 1.0 1.0 1.0 1.0 } ] if ; + : apply-world-attributes ( world attributes -- world ) { [ title>> >>title ] [ status>> >>status ] [ pixel-format-attributes>> >>pixel-format-attributes ] [ window-controls>> >>window-controls ] + [ initial-background-color >>background-color ] [ grab-input?>> >>grab-input? ] [ gadgets>> [ 1 track-add ] each ] } cleave ; diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor index 1e5a8df1dd..3deb0c619d 100644 --- a/basis/ui/gestures/gestures-docs.factor +++ b/basis/ui/gestures/gestures-docs.factor @@ -263,28 +263,34 @@ ARTICLE: "ui-gestures" "UI gestures" "User actions such as keyboard input and mouse button clicks deliver " { $emphasis "gestures" } " to gadgets. If the direct receiver of the gesture does not handle it, the gesture is passed on to the receiver's parent, and this way it travels up the gadget hierarchy. Gestures which are not handled at some point are ignored." $nl "There are two ways to define gesture handling logic. The simplest way is to associate a fixed set of gestures with a class:" -{ $subsection set-gestures } +{ $subsections set-gestures } "Another way is to define a generic word on a class which handles all gestures sent to gadgets of that class:" -{ $subsection handle-gesture } +{ $subsections handle-gesture } "Sometimes a gesture needs to be presented to the user:" -{ $subsection gesture>string } +{ $subsections gesture>string } "Keyboard input:" -{ $subsection "ui-focus" } -{ $subsection "keyboard-gestures" } -{ $subsection "action-gestures" } -{ $subsection "ui-user-input" } +{ $subsections + "ui-focus" + "keyboard-gestures" + "action-gestures" + "ui-user-input" +} "Mouse input:" -{ $subsection "mouse-gestures" } -{ $subsection "multitouch-gestures" } +{ $subsections + "mouse-gestures" + "multitouch-gestures" +} "Guidelines for cross-platform applications:" -{ $subsection "gesture-differences" } +{ $subsections "gesture-differences" } "Abstractions built on top of gestures:" -{ $subsection "ui-commands" } -{ $subsection "ui-operations" } ; +{ $subsections + "ui-commands" + "ui-operations" +} ; ARTICLE: "ui-focus" "Keyboard focus" "The gadget with keyboard focus is the current receiver of keyboard gestures and user input. Gadgets that wish to receive keyboard input should request focus when clicked:" -{ $subsection request-focus } +{ $subsections request-focus } "The following example demonstrates defining a handler for a mouse click gesture which requests focus:" { $code "my-gadget H{" @@ -292,21 +298,27 @@ ARTICLE: "ui-focus" "Keyboard focus" "} set-gestures" } "To nominate a single child as the default focusable child, implement a method on a generic word:" -{ $subsection focusable-child* } +{ $subsections focusable-child* } "Gestures are sent to a gadget when it gains or loses focus; this can be used to change the gadget's appearance, for example by displaying a border:" -{ $subsection gain-focus } -{ $subsection lose-focus } ; +{ $subsections + gain-focus + lose-focus +} ; ARTICLE: "keyboard-gestures" "Keyboard gestures" "There are two types of keyboard gestures:" -{ $subsection key-down } -{ $subsection key-up } +{ $subsections + key-down + key-up +} "Each keyboard gesture has a set of modifiers and a key symbol. The set modifiers is denoted by an array which must either be " { $link f } ", or an order-preserving subsequence of the following:" { $code "{ S+ C+ A+ M+ }" } -{ $subsection S+ } -{ $subsection C+ } -{ $subsection A+ } -{ $subsection M+ } +{ $subsections + S+ + C+ + A+ + M+ +} "A key symbol is either a single-character string denoting literal input, or one of the following strings:" { $list { $snippet "CLEAR" } @@ -339,66 +351,82 @@ ARTICLE: "keyboard-gestures" "Keyboard gestures" ARTICLE: "ui-user-input" "Free-form keyboard input" "Whereas keyboard gestures are intended to be used for keyboard shortcuts, certain gadgets such as text fields need to accept free-form keyboard input. This can be done by implementing a generic word:" -{ $subsection user-input* } ; +{ $subsections user-input* } ; ARTICLE: "mouse-gestures" "Mouse gestures" "There are two types of mouse gestures indicating button clicks:" -{ $subsection button-down } -{ $subsection button-up } +{ $subsections + button-down + button-up +} "When a mouse button is pressed or released, two gestures are sent. The first gesture indicates the specific button number, and if this gesture is not handled, the second has a button number set to " { $link f } ":" { $code "T{ button-down f 1 }" "T{ button-down f f }" } "Because tuple literals fill unspecified slots with " { $link f } ", the last gesture can be written as " { $snippet "T{ button-down }" } "." $nl "Gestures to indicate mouse motion, depending on whenever a button is held down or not:" -{ $subsection motion } -{ $subsection drag } +{ $subsections + motion + drag +} "Gestures to indicate that the mouse has crossed gadget boundaries:" -{ $subsection mouse-enter } -{ $subsection mouse-leave } +{ $subsections + mouse-enter + mouse-leave +} "A number of global variables are set after a mouse gesture is sent. These variables can be read to obtain additional information about the gesture." -{ $subsection hand-gadget } -{ $subsection hand-world } -{ $subsection hand-loc } -{ $subsection hand-buttons } -{ $subsection hand-clicked } -{ $subsection hand-click-loc } -{ $subsection hand-click# } +{ $subsections + hand-gadget + hand-world + hand-loc + hand-buttons + hand-clicked + hand-click-loc + hand-click# +} "There are some utility words for working with click locations:" -{ $subsection hand-rel } -{ $subsection hand-click-rel } -{ $subsection drag-loc } +{ $subsections + hand-rel + hand-click-rel + drag-loc +} "Mouse scroll wheel gesture:" -{ $subsection mouse-scroll } +{ $subsections mouse-scroll } "Global variable set when a mouse scroll wheel gesture is sent:" -{ $subsection scroll-direction } ; +{ $subsections scroll-direction } ; ARTICLE: "multitouch-gestures" "Multi-touch gestures" "Multi-touch gestures are only supported on Mac OS X with newer MacBook and MacBook Pro models." $nl "Three-finger swipe:" -{ $subsection left-action } -{ $subsection right-action } -{ $subsection up-action } -{ $subsection down-action } +{ $subsections + left-action + right-action + up-action + down-action +} "Two-finger pinch:" -{ $subsection zoom-in-action } -{ $subsection zoom-out-action } ; +{ $subsections + zoom-in-action + zoom-out-action +} ; ARTICLE: "action-gestures" "Action gestures" "Action gestures exist to keep keyboard shortcuts for common application operations consistent." -{ $subsection undo-action } -{ $subsection redo-action } -{ $subsection cut-action } -{ $subsection copy-action } -{ $subsection paste-action } -{ $subsection delete-action } -{ $subsection select-all-action } -{ $subsection new-action } -{ $subsection open-action } -{ $subsection save-action } -{ $subsection save-as-action } -{ $subsection revert-action } -{ $subsection close-action } +{ $subsections + undo-action + redo-action + cut-action + copy-action + paste-action + delete-action + select-all-action + new-action + open-action + save-action + save-as-action + revert-action + close-action +} "The following keyboard gestures, if not handled directly, send action gestures:" { $table { { $strong "Keyboard gesture" } { $strong "Action gesture" } } diff --git a/basis/ui/images/images.factor b/basis/ui/images/images.factor index 519217a644..b97a5c14fe 100755 --- a/basis/ui/images/images.factor +++ b/basis/ui/images/images.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces cache images images.loader accessors assocs kernel opengl opengl.gl opengl.textures ui.gadgets.worlds -memoize images.tiff ; +memoize images.png images.tiff ; IN: ui.images TUPLE: image-name path ; diff --git a/basis/ui/operations/operations-docs.factor b/basis/ui/operations/operations-docs.factor index 4114a2c3b2..b574e5317b 100644 --- a/basis/ui/operations/operations-docs.factor +++ b/basis/ui/operations/operations-docs.factor @@ -74,13 +74,17 @@ HELP: $operation ARTICLE: "ui-operations" "Operations" "Operations are commands performed on presentations." -{ $subsection operation } -{ $subsection define-operation } -{ $subsection primary-operation } -{ $subsection secondary-operation } -{ $subsection define-operation-map } +{ $subsections + operation + define-operation + primary-operation + secondary-operation + define-operation-map +} "When documenting gadgets, operation documentation can be automatically generated:" -{ $subsection $operations } -{ $subsection $operation } ; +{ $subsections + $operations + $operation +} ; ABOUT: "ui-operations" diff --git a/basis/ui/operations/operations.factor b/basis/ui/operations/operations.factor index a502707ee6..48ff20837e 100755 --- a/basis/ui/operations/operations.factor +++ b/basis/ui/operations/operations.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays definitions kernel ui.commands -ui.gestures sequences strings math words generic namespaces -hashtables quotations assocs fry linked-assocs ; +USING: accessors arrays assocs combinators.short-circuit fry +kernel linked-assocs namespaces sequences ui.commands words ; IN: ui.operations SYMBOL: +keyboard+ @@ -18,7 +17,7 @@ TUPLE: operation predicate command translator listener? ; swap >>predicate ; PREDICATE: listener-operation < operation - [ command>> listener-command? ] [ listener?>> ] bi or ; + { [ command>> listener-command? ] [ listener?>> ] } 1|| ; M: operation command-name command>> command-name ; diff --git a/basis/ui/pens/gradient/gradient.factor b/basis/ui/pens/gradient/gradient.factor index 53b4357d44..7f7bd02204 100644 --- a/basis/ui/pens/gradient/gradient.factor +++ b/basis/ui/pens/gradient/gradient.factor @@ -3,6 +3,7 @@ USING: kernel accessors math math.vectors locals sequences specialized-arrays colors arrays combinators opengl opengl.gl ui.pens ui.pens.caching ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: ui.pens.gradient diff --git a/basis/ui/pens/pens-docs.factor b/basis/ui/pens/pens-docs.factor index 865210ed1b..4aa0e50945 100644 --- a/basis/ui/pens/pens-docs.factor +++ b/basis/ui/pens/pens-docs.factor @@ -11,8 +11,10 @@ HELP: draw-boundary ARTICLE: "ui-pen-protocol" "UI pen protocol" "The " { $snippet "interior" } " and " { $snippet "boundary" } " slots of a gadget facilitate easy factoring and sharing of drawing logic. Objects stored in these slots must implement the pen protocol:" -{ $subsection draw-interior } -{ $subsection draw-boundary } +{ $subsections + draw-interior + draw-boundary +} "The default value of these slots is the " { $link f } " singleton, which implements the above protocol by doing nothing." $nl "Some other pre-defined implementations:" diff --git a/basis/ui/pens/polygon/polygon.factor b/basis/ui/pens/polygon/polygon.factor index a39a5cb7cd..c1e1ada61b 100644 --- a/basis/ui/pens/polygon/polygon.factor +++ b/basis/ui/pens/polygon/polygon.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors colors help.markup help.syntax kernel opengl -opengl.gl sequences math.vectors ui.gadgets ui.pens -specialized-arrays ; +USING: accessors alien.c-types colors help.markup help.syntax +kernel opengl opengl.gl sequences math.vectors ui.gadgets +ui.pens specialized-arrays ; SPECIALIZED-ARRAY: float IN: ui.pens.polygon @@ -36,4 +36,4 @@ M: polygon draw-interior : <polygon-gadget> ( color points -- gadget ) [ <polygon> ] [ { 0 0 } [ vmax ] reduce ] bi - [ <gadget> ] 2dip [ >>interior ] [ >>dim ] bi* ; \ No newline at end of file + [ <gadget> ] 2dip [ >>interior ] [ >>dim ] bi* ; diff --git a/basis/ui/pixel-formats/pixel-formats-docs.factor b/basis/ui/pixel-formats/pixel-formats-docs.factor index b1ab1bc398..c82990a79e 100644 --- a/basis/ui/pixel-formats/pixel-formats-docs.factor +++ b/basis/ui/pixel-formats/pixel-formats-docs.factor @@ -1,4 +1,4 @@ -USING: destructors help.markup help.syntax kernel math multiline sequences +USING: destructors help.markup help.syntax kernel math sequences vocabs vocabs.parser words namespaces ; IN: ui.pixel-formats @@ -11,37 +11,41 @@ IN: ui.pixel-formats ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes" "The following pixel format attributes can be requested and queried of " { $link pixel-format } "s. Binary attributes are represented by the presence of a symbol in an attribute sequence:" -{ $subsection double-buffered } -{ $subsection stereo } -{ $subsection offscreen } -{ $subsection fullscreen } -{ $subsection windowed } -{ $subsection accelerated } -{ $subsection software-rendered } -{ $subsection backing-store } -{ $subsection multisampled } -{ $subsection supersampled } -{ $subsection sample-alpha } -{ $subsection color-float } +{ $subsections + double-buffered + stereo + offscreen + fullscreen + windowed + accelerated + software-rendered + backing-store + multisampled + supersampled + sample-alpha + color-float +} "Integer attributes are represented by a " { $link tuple } " with a single " { $snippet "value" } "slot:" -{ $subsection color-bits } -{ $subsection red-bits } -{ $subsection green-bits } -{ $subsection blue-bits } -{ $subsection alpha-bits } -{ $subsection accum-bits } -{ $subsection accum-red-bits } -{ $subsection accum-green-bits } -{ $subsection accum-blue-bits } -{ $subsection accum-alpha-bits } -{ $subsection depth-bits } -{ $subsection stencil-bits } -{ $subsection aux-buffers } -{ $subsection sample-buffers } -{ $subsection samples } +{ $subsections + color-bits + red-bits + green-bits + blue-bits + alpha-bits + accum-bits + accum-red-bits + accum-green-bits + accum-blue-bits + accum-alpha-bits + depth-bits + stencil-bits + aux-buffers + sample-buffers + samples +} { $examples "The following " { $link world } " subclass will request a double-buffered window with minimum 24-bit color and depth buffers, and will throw an error if the requirements aren't met:" -{ $code <" +{ $code """ USING: kernel ui.worlds ui.pixel-formats ; IN: ui.pixel-formats.examples @@ -60,7 +64,7 @@ M: picky-depth-buffered-world check-world-pixel-format [ color-bits pixel-format-attribute 24 < [ "Not enough color bits!" throw ] when ] [ depth-bits pixel-format-attribute 24 < [ "Not enough depth bits!" throw ] when ] tri ; -"> } } +""" } } ; HELP: double-buffered @@ -180,19 +184,23 @@ related-words ARTICLE: "ui.pixel-formats" "Pixel formats" "The UI allows you to control the window system's OpenGL interface with a cross-platform set of pixel format specifiers:" -{ $subsection "ui.pixel-formats-attributes" } +{ $subsections "ui.pixel-formats-attributes" } "Pixel formats can be requested using these attributes:" -{ $subsection pixel-format } -{ $subsection <pixel-format> } -{ $subsection pixel-format-attribute } +{ $subsections + pixel-format + <pixel-format> + pixel-format-attribute +} "If a request for a set of pixel format attributes cannot be satisfied, an error is thrown:" -{ $subsection invalid-pixel-format-attributes } +{ $subsections invalid-pixel-format-attributes } "Pixel formats are requested as part of opening a window for a " { $link world } ". These generics can be overridden on " { $snippet "world" } " subclasses to control pixel format selection:" -{ $subsection world-pixel-format-attributes } -{ $subsection check-world-pixel-format } +{ $subsections + world-pixel-format-attributes + check-world-pixel-format +} ; ABOUT: "ui.pixel-formats" diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index 5dcd9bde9a..abc857c566 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -1,6 +1,6 @@ -USING: accessors assocs classes destructors functors kernel -lexer math parser sequences specialized-arrays ui.backend -words ; +USING: alien.c-types accessors assocs classes destructors +functors kernel lexer math parser sequences specialized-arrays +ui.backend words ; SPECIALIZED-ARRAY: int IN: ui.pixel-formats diff --git a/basis/ui/render/render-docs.factor b/basis/ui/render/render-docs.factor index dd49989664..9348569a5f 100644 --- a/basis/ui/render/render-docs.factor +++ b/basis/ui/render/render-docs.factor @@ -39,12 +39,14 @@ ARTICLE: "ui-paint" "Customizing gadget appearance" { "The " { $link draw-boundary } " generic word is called on the value of the " { $snippet "boundary" } " slot." } } "Now, each one of these steps will be covered in detail." -{ $subsection "ui-pen-protocol" } -{ $subsection "ui-paint-custom" } ; +{ $subsections + "ui-pen-protocol" + "ui-paint-custom" +} ; ARTICLE: "ui-paint-coord" "The UI co-ordinate system" "The UI uses a co-ordinate system where the y axis is oriented down. The OpenGL " { $link GL_MODELVIEW } " matrix is saved or restored when rendering a gadget, and the origin is translated to the gadget's origin within the window. The current origin is stored in a variable:" -{ $subsection origin } +{ $subsections origin } "Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $slot "clipped?" } " slot to " { $link t } " in the gadget's constructor." ; ABOUT: "ui-paint" diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index c4e6f56886..8ce9074225 100755 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -27,18 +27,20 @@ SYMBOL: viewport-translation [ clip set ] bi do-clip ; -: init-gl ( clip-rect -- ) +SLOT: background-color + +: init-gl ( world -- ) GL_SMOOTH glShadeModel GL_SCISSOR_TEST glEnable GL_BLEND glEnable GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc GL_VERTEX_ARRAY glEnableClientState init-matrices - init-clip - ! white gl-clear is broken w.r.t window resizing - ! Linux/PPC Radeon 9200 - COLOR: white gl-color - { 0 0 } clip get dim>> gl-fill-rect ; + [ init-clip ] + [ + background-color>> >rgba-components glClearColor + GL_COLOR_BUFFER_BIT glClear + ] bi ; GENERIC: draw-gadget* ( gadget -- ) diff --git a/basis/ui/text/text-docs.factor b/basis/ui/text/text-docs.factor index c2732754f6..492ab76a13 100644 --- a/basis/ui/text/text-docs.factor +++ b/basis/ui/text/text-docs.factor @@ -50,21 +50,27 @@ HELP: line-metrics ARTICLE: "text-rendering" "Rendering text" "The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X and FreeType on Windows and X11." -{ $subsection "fonts" } +{ $subsections "fonts" } "Measuring text:" -{ $subsection text-dim } -{ $subsection text-width } -{ $subsection text-height } -{ $subsection line-metrics } +{ $subsections + text-dim + text-width + text-height + line-metrics +} "Converting screen locations to string offsets, and vice versa:" -{ $subsection x>offset } -{ $subsection offset>x } +{ $subsections + x>offset + offset>x +} "Rendering text:" -{ $subsection draw-text } +{ $subsections draw-text } "Low-level text protocol for UI backends:" -{ $subsection string-width } -{ $subsection string-height } -{ $subsection string-dim } -{ $subsection draw-string } ; +{ $subsections + string-width + string-height + string-dim + draw-string +} ; ABOUT: "text-rendering" \ No newline at end of file diff --git a/basis/ui/tools/browser/browser-docs.factor b/basis/ui/tools/browser/browser-docs.factor index b07e72dbce..1132e1bdce 100644 --- a/basis/ui/tools/browser/browser-docs.factor +++ b/basis/ui/tools/browser/browser-docs.factor @@ -3,8 +3,10 @@ IN: ui.tools.browser ARTICLE: "ui-browser" "UI browser" "The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or article link presentation is clicked. It can also be opened using words:" -{ $subsection com-browse } -{ $subsection browser-window } +{ $subsections + com-browse + browser-window +} { $command-map browser-gadget "toolbar" } { $command-map browser-gadget "scrolling" } { $command-map browser-gadget "navigation" } diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index 3d590feb58..173e1c0595 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: debugger classes help help.topics help.crossref help.home -kernel models compiler.units assocs words vocabs accessors fry arrays -combinators.short-circuit namespaces sequences help.apropos -combinators ui ui.commands ui.gadgets ui.gadgets.panes -ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons -ui.gadgets.packs ui.gadgets.editors ui.gadgets.labels -ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders -ui.gadgets.viewports ui.tools.common ui.tools.browser.popups -ui.tools.browser.history ; +USING: accessors arrays assocs classes combinators +combinators.short-circuit compiler.units debugger fry help +help.apropos help.crossref help.home help.topics kernel models +sequences ui ui.commands ui.gadgets ui.gadgets.borders +ui.gadgets.buttons ui.gadgets.editors ui.gadgets.glass +ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers +ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.viewports +ui.gestures ui.tools.browser.history ui.tools.browser.popups +ui.tools.common vocabs ; IN: ui.tools.browser TUPLE: browser-gadget < tool history scroller search-field popup ; @@ -95,8 +95,10 @@ M: browser-gadget focusable-child* search-field>> ; "help.home" (browser-window) ; : error-help-window ( error -- ) - [ error-help ] - [ dup tuple? [ class ] [ drop "errors" ] if ] bi or (browser-window) ; + { + [ error-help ] + [ dup tuple? [ class ] [ drop "errors" ] if ] + } 1|| (browser-window) ; \ browser-window H{ { +nullary+ t } } define-command @@ -162,4 +164,4 @@ browser-gadget "scrolling" { T{ key-down f f "PAGE_DOWN" } com-page-down } } define-command-map -MAIN: browser-window \ No newline at end of file +MAIN: browser-window diff --git a/basis/ui/tools/deploy/deploy-docs.factor b/basis/ui/tools/deploy/deploy-docs.factor index b0a2fb6cf9..aa1fb1b68e 100644 --- a/basis/ui/tools/deploy/deploy-docs.factor +++ b/basis/ui/tools/deploy/deploy-docs.factor @@ -10,7 +10,7 @@ ARTICLE: "ui.tools.deploy" "Application deployment UI tool" "The application deployment UI tool provides a graphical front-end to deployment configuration. Using the tool, you can set deployment options graphically." $nl "To start the tool, pass a vocabulary name to a word:" -{ $subsection deploy-tool } +{ $subsections deploy-tool } "Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu." { $see-also "tools.deploy" } ; diff --git a/basis/ui/tools/inspector/inspector-docs.factor b/basis/ui/tools/inspector/inspector-docs.factor index 72f4e1fe66..fa6ae3bb87 100644 --- a/basis/ui/tools/inspector/inspector-docs.factor +++ b/basis/ui/tools/inspector/inspector-docs.factor @@ -14,12 +14,12 @@ ARTICLE: "ui-inspector" "UI inspector" "The graphical inspector provides functionality similar to the terminal inspector (see " { $link "inspector" } "), adding in-place editing of slot values." $nl "To display an object in the UI inspector, right-click a presentation and choose " { $strong "Inspector" } " from the menu that appears. The inspector can also be opened from the listener using a word:" -{ $subsection inspector } +{ $subsections inspector } "The inspector embeds a table gadget, which supports keyboard navigation; see " { $link "ui.gadgets.tables" } ". It also provides a few other commands:" { $command-map inspector-gadget "toolbar" } { $command-map inspector-gadget "multi-touch" } "The UI inspector is an instance of " { $link inspector-gadget } "." -{ $subsection "ui-inspector-edit" } ; +{ $subsections "ui-inspector-edit" } ; HELP: inspector { $values { "obj" object } } diff --git a/basis/ui/tools/inspector/inspector.factor b/basis/ui/tools/inspector/inspector.factor index b4a772dca5..1fc1ad1860 100644 --- a/basis/ui/tools/inspector/inspector.factor +++ b/basis/ui/tools/inspector/inspector.factor @@ -92,7 +92,7 @@ M: inspector-gadget focusable-child* : slot-editor-window ( close-hook update-hook assoc key key-string -- ) [ <value-ref> <slot-editor> ] [ "Slot editor: " prepend ] bi* - open-window ; + open-status-window ; : com-edit-slot ( inspector -- ) [ close-window ] swap diff --git a/basis/ui/tools/listener/completion/completion-tests.factor b/basis/ui/tools/listener/completion/completion-tests.factor index 9b2b5a1673..5b79e918b5 100644 --- a/basis/ui/tools/listener/completion/completion-tests.factor +++ b/basis/ui/tools/listener/completion/completion-tests.factor @@ -3,8 +3,18 @@ USING: tools.test ui.tools.listener.completion ; IN: ui.tools.listener.completion.tests -[ t ] [ { "USING:" "A" "B" "C" } complete-USING:? ] unit-test +[ f ] [ { "USE:" "A" "B" "C" } complete-vocab? ] unit-test -[ f ] [ { "USING:" "A" "B" "C" ";" } complete-USING:? ] unit-test +[ t ] [ { "USE:" "A" } complete-vocab? ] unit-test -[ t ] [ { "X" ";" "USING:" "A" "B" "C" } complete-USING:? ] unit-test \ No newline at end of file +[ t ] [ { "UNUSE:" "A" } complete-vocab? ] unit-test + +[ t ] [ { "QUALIFIED:" "A" } complete-vocab? ] unit-test + +[ t ] [ { "QUALIFIED-WITH:" "A" } complete-vocab? ] unit-test + +[ t ] [ { "USING:" "A" "B" "C" } complete-vocab-list? ] unit-test + +[ f ] [ { "USING:" "A" "B" "C" ";" } complete-vocab-list? ] unit-test + +[ t ] [ { "X" ";" "USING:" "A" "B" "C" } complete-vocab-list? ] unit-test \ No newline at end of file diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index 760b959e78..5dd0581cf2 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -72,13 +72,14 @@ M: word-completion row-color M: vocab-completion row-color drop vocab? COLOR: black COLOR: dark-gray ? ; -: complete-IN:/USE:? ( tokens -- ? ) - 1 short head* 2 short tail* { "IN:" "USE:" } intersects? ; +: complete-vocab? ( tokens -- ? ) + 1 short head* 2 short tail* + { "IN:" "USE:" "UNUSE:" "QUALIFIED:" "QUALIFIED-WITH:" } intersects? ; : chop-; ( seq -- seq' ) { ";" } split1-last [ ] [ ] ?if ; -: complete-USING:? ( tokens -- ? ) +: complete-vocab-list? ( tokens -- ? ) chop-; 1 short head* { "USING:" } intersects? ; : complete-CHAR:? ( tokens -- ? ) @@ -90,7 +91,7 @@ M: vocab-completion row-color : completion-mode ( interactor -- symbol ) [ manifest>> ] [ editor-caret ] [ model>> ] tri up-to-caret " \r\n" split { - { [ dup { [ complete-IN:/USE:? ] [ complete-USING:? ] } 1|| ] [ 2drop vocab-completion ] } + { [ dup { [ complete-vocab? ] [ complete-vocab-list? ] } 1|| ] [ 2drop vocab-completion ] } { [ dup complete-CHAR:? ] [ 2drop char-completion ] } [ drop <word-completion> ] } cond ; diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 4b9a4a1ef3..990bafec90 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -150,11 +150,11 @@ M: interactor stream-readln ] if ; M: interactor stream-read - swap dup zero? [ - 2drop "" + swap [ + drop "" ] [ [ interactor-read dup [ "\n" join ] when ] dip short head - ] if ; + ] if-zero ; M: interactor stream-read-partial stream-read ; @@ -386,6 +386,8 @@ interactor "completion" f { error-summary? off tip-of-the-day. nl listener + nl + "The listener has exited. To start it again, click âRestart Listenerâ." print ] with-streams* ; : start-listener-thread ( listener -- ) @@ -406,25 +408,22 @@ interactor "completion" f { [ wait-for-listener ] } cleave ; -: listener-help ( -- ) "help.home" com-browse ; +: com-help ( -- ) "help.home" com-browse ; -\ listener-help H{ { +nullary+ t } } define-command +\ com-help H{ { +nullary+ t } } define-command : com-auto-use ( -- ) auto-use? [ not ] change ; \ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command -listener-gadget "misc" "Miscellaneous commands" { - { T{ key-down f f "F1" } listener-help } -} define-command-map - listener-gadget "toolbar" f { { f restart-listener } { T{ key-down f { A+ } "u" } com-auto-use } { T{ key-down f { A+ } "k" } clear-output } { T{ key-down f { A+ } "K" } clear-stack } { T{ key-down f { C+ } "d" } com-end } + { T{ key-down f f "F1" } com-help } } define-command-map listener-gadget "scrolling" diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor index c3fbdb88cd..bb23bc0692 100644 --- a/basis/ui/tools/profiler/profiler.factor +++ b/basis/ui/tools/profiler/profiler.factor @@ -1,14 +1,15 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel quotations accessors fry assocs present math.order -math.vectors arrays locals models.search models.sort models sequences -vocabs tools.profiler words prettyprint combinators.smart -definitions.icons see ui ui.commands ui.gadgets ui.gadgets.panes -ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons -ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.labeled -ui.gadgets.packs ui.gadgets.labels ui.gadgets.tabbed -ui.gadgets.status-bar ui.gadgets.borders ui.tools.browser -ui.tools.common ui.baseline-alignment ui.operations ui.images ; +USING: accessors arrays assocs combinators.short-circuit +combinators.smart definitions.icons fry kernel locals +math.order models models.search models.sort present see +sequences tools.profiler ui.baseline-alignment ui.commands +ui.gadgets ui.gadgets.borders ui.gadgets.buttons +ui.gadgets.labeled ui.gadgets.labels ui.gadgets.packs +ui.gadgets.search-tables ui.gadgets.status-bar +ui.gadgets.tabbed ui.gadgets.tables ui.gadgets.tracks +ui.gestures ui.images ui.operations ui.tools.browser +ui.tools.common vocabs words ; FROM: models.arrow => <arrow> ; FROM: models.arrow.smart => <smart-arrow> ; FROM: models.product => <product> ; @@ -105,9 +106,10 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ; : method-matches? ( method generic class -- ? ) [ first ] 2dip - [ drop dup [ subwords memq? ] [ 2drop t ] if ] - [ nip dup [ swap "method-class" word-prop = ] [ 2drop t ] if ] - 3bi and ; + { + [ drop dup [ subwords memq? ] [ 2drop t ] if ] + [ nip dup [ swap "method-class" word-prop = ] [ 2drop t ] if ] + } 3&& ; : <methods-model> ( profiler -- model ) [ diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor index 7be008f296..e9d9a6e4b9 100644 --- a/basis/ui/tools/tools-docs.factor +++ b/basis/ui/tools/tools-docs.factor @@ -16,7 +16,9 @@ ARTICLE: "starting-ui-tools" "Starting the UI tools" { $code "USE: threads" "[ \"ui.tools\" run ] in-thread" } ; ARTICLE: "ui-shortcuts" "UI tool keyboard shortcuts" -"Every UI tool has its own set of keyboard shortcuts; press " { $snippet "F1" } " inside a tool to see help. Some common shortcuts are also supported by all tools:" +"Every UI tool has its own set of keyboard shortcuts. Mouse-over a toolbar button to see its shortcut, if any, in the status bar, or press " { $snippet "F1" } " to see a list of all shortcuts supported by the tool." +$nl +"Some common shortcuts are supported by all tools:" { $command-map tool "tool-switching" } { $command-map tool "common" } ; @@ -44,23 +46,27 @@ $nl ARTICLE: "ui-tools" "UI developer tools" "The " { $vocab-link "ui.tools" } " vocabulary hierarchy implements a collection of simple developer tools." -{ $subsection "starting-ui-tools" } +{ $subsections "starting-ui-tools" } "To take full advantage of the UI tools, you should be using a supported text editor. See " { $link "editor" } "." $nl "Common functionality:" -{ $subsection "ui-shortcuts" } -{ $subsection "ui-presentations" } -{ $subsection "definitions.icons" } +{ $subsections + "ui-shortcuts" + "ui-presentations" + "definitions.icons" +} "Tools:" -{ $subsection "ui-listener" } -{ $subsection "ui-browser" } -{ $subsection "ui-inspector" } -{ $subsection "ui.tools.error-list" } -{ $subsection "ui.tools.profiler" } -{ $subsection "ui-walker" } -{ $subsection "ui.tools.deploy" } +{ $subsections + "ui-listener" + "ui-browser" + "ui-inspector" + "ui.tools.error-list" + "ui.tools.profiler" + "ui-walker" + "ui.tools.deploy" +} "Platform-specific features:" -{ $subsection "ui-cocoa" } ; +{ $subsections "ui-cocoa" } ; TIP: "All UI developer tools support a common set of " { $link "ui-shortcuts" } ". Each individual tool has its own shortcuts as well; the F1 key is context-sensitive." ; diff --git a/basis/ui/tools/walker/walker-docs.factor b/basis/ui/tools/walker/walker-docs.factor index da4f345de2..81dfdf9cad 100644 --- a/basis/ui/tools/walker/walker-docs.factor +++ b/basis/ui/tools/walker/walker-docs.factor @@ -27,8 +27,10 @@ ARTICLE: "ui-walker" "UI walker" "The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "." $nl "Walkers are instances of " { $link walker-gadget } "." -{ $subsection "ui-walker-step" } -{ $subsection "breakpoints" } +{ $subsections + "ui-walker-step" + "breakpoints" +} { $command-map walker-gadget "toolbar" } { $command-map walker-gadget "multitouch" } ; diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index 43dd22cde7..51ff4c2609 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -98,56 +98,66 @@ ARTICLE: "ui-glossary" "UI glossary" ARTICLE: "building-ui" "Building user interfaces" "A gadget is a graphical element which responds to user input. Gadgets are implemented as tuples which (directly or indirectly) inherit from " { $link gadget } ", which in turn inherits from " { $link rect } "." -{ $subsection gadget } +{ $subsections gadget } "Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget, stored in the " { $snippet "parent" } " slot." -{ $subsection "ui-geometry" } -{ $subsection "ui-layouts" } -{ $subsection "gadgets" } -{ $subsection "ui-windows" } -{ $subsection "ui.gadgets.status-bar" } +{ $subsections + "ui-geometry" + "ui-layouts" + "gadgets" + "ui-windows" + "ui.gadgets.status-bar" +} { $see-also "models" } ; ARTICLE: "gadgets" "Pre-made UI gadgets" -{ $subsection "ui.gadgets.labels" } -{ $subsection "ui.gadgets.borders" } -{ $subsection "ui.gadgets.labeled" } -{ $subsection "ui.gadgets.buttons" } -{ $subsection "ui.gadgets.sliders" } -{ $subsection "ui.gadgets.scrollers" } -{ $subsection "ui.gadgets.editors" } -{ $subsection "ui.gadgets.menus" } -{ $subsection "ui.gadgets.panes" } -{ $subsection "ui.gadgets.presentations" } -{ $subsection "ui.gadgets.tables" } ; +{ $subsections + "ui.gadgets.labels" + "ui.gadgets.borders" + "ui.gadgets.labeled" + "ui.gadgets.buttons" + "ui.gadgets.sliders" + "ui.gadgets.scrollers" + "ui.gadgets.editors" + "ui.gadgets.menus" + "ui.gadgets.panes" + "ui.gadgets.presentations" + "ui.gadgets.tables" +} ; ARTICLE: "ui-geometry" "Gadget geometry" "The " { $link gadget } " class inherits from the " { $link rect } " class, and thus all gadgets have a bounding box:" -{ $subsection "math.rectangles" } +{ $subsections "math.rectangles" } "Word for converting from a child gadget's co-ordinate system to a parent's:" -{ $subsection relative-loc } -{ $subsection screen-loc } +{ $subsections + relative-loc + screen-loc +} "Hit testing:" -{ $subsection pick-up } -{ $subsection children-on } ; +{ $subsections + pick-up + children-on +} ; ARTICLE: "ui-windows" "Top-level windows" "Opening a top-level window:" -{ $subsection open-window } +{ $subsections open-window } "Finding top-level windows:" -{ $subsection find-window } +{ $subsections find-window } "Top-level windows are stored in a global variable:" -{ $subsection windows } +{ $subsections windows } "When a gadget is displayed in a top-level window, or added to a parent which is already showing in a top-level window, a generic word is called allowing the gadget to perform initialization tasks:" -{ $subsection graft* } +{ $subsections graft* } "When the gadget is removed from a parent shown in a top-level window, or when the top-level window is closed, a corresponding generic word is called to clean up:" -{ $subsection ungraft* } +{ $subsections ungraft* } "The root of the gadget hierarchy in a window is a special gadget which is rarely operated on directly, but it is helpful to know it exists:" -{ $subsection world } ; +{ $subsections world } ; ARTICLE: "ui-backend" "Developing UI backends" "None of the words documented in this section should be called directly by user code. They are only of interest when developing new UI backends." -{ $subsection "ui-backend-init" } -{ $subsection "ui-backend-windows" } +{ $subsections + "ui-backend-init" + "ui-backend-windows" +} "UI backends may implement the " { $link "clipboard-protocol" } "." ; ARTICLE: "ui-backend-init" "UI initialization and the event loop" @@ -162,66 +172,82 @@ ARTICLE: "ui-backend-init" "UI initialization and the event loop" " ... start event loop here ... ;" } "The above word must call the following:" -{ $subsection start-ui } +{ $subsections start-ui } "The " { $link (with-ui) } " word must not return until the event loop has stopped and the UI has been shut down." ; ARTICLE: "ui-backend-windows" "UI backend window management" "The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:" -{ $subsection open-world-window } +{ $subsections open-world-window } "This word should create a native window, store some kind of handle in the " { $snippet "handle" } " slot, then call two words:" -{ $subsection register-window } +{ $subsections register-window } "The following words must also be implemented:" -{ $subsection set-title } -{ $subsection raise-window } +{ $subsections + set-title + raise-window +} "When a world needs to be redrawn, the UI will call a word automatically:" -{ $subsection draw-world } +{ $subsections draw-world } "This word can also be called directly if the UI backend is notified by the window system that window contents have been invalidated. Before and after drawing, two words are called, which the UI backend must implement:" -{ $subsection select-gl-context } -{ $subsection flush-gl-context } +{ $subsections + select-gl-context + flush-gl-context +} "If the user clicks the window's close box, you must call the following word:" -{ $subsection close-window } ; +{ $subsections close-window } ; ARTICLE: "ui-layouts" "Gadget hierarchy and layouts" "A layout gadget is a gadget whose sole purpose is to contain other gadgets. Layout gadgets position and resize children according to a certain policy, taking the preferred size of the children into account. Gadget hierarchies are constructed by building up nested layouts." -{ $subsection "ui-layout-basics" } +{ $subsections "ui-layout-basics" } "Common layout gadgets:" -{ $subsection "ui-pack-layout" } -{ $subsection "ui-track-layout" } -{ $subsection "ui-grid-layout" } -{ $subsection "ui-frame-layout" } -{ $subsection "ui-book-layout" } +{ $subsections + "ui-pack-layout" + "ui-track-layout" + "ui-grid-layout" + "ui-frame-layout" + "ui-book-layout" +} "Advanced topics:" -{ $subsection "ui.gadgets.glass" } -{ $subsection "ui-null-layout" } -{ $subsection "ui-incremental-layout" } -{ $subsection "ui-layout-impl" } +{ $subsections + "ui.gadgets.glass" + "ui-null-layout" + "ui-incremental-layout" + "ui-layout-impl" +} { $see-also "ui.gadgets.borders" } ; ARTICLE: "ui-layout-basics" "Layout basics" "Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget." $nl "Managing the gadget hierarchy:" -{ $subsection add-gadget } -{ $subsection unparent } -{ $subsection add-gadgets } -{ $subsection clear-gadget } +{ $subsections + add-gadget + unparent + add-gadgets + clear-gadget +} "The children of a gadget are available via the " { $snippet "children" } " slot. " $nl "Working with gadget children:" -{ $subsection gadget-child } -{ $subsection nth-gadget } -{ $subsection each-child } -{ $subsection child? } +{ $subsections + gadget-child + nth-gadget + each-child + child? +} "Working with gadget parents:" -{ $subsection parents } -{ $subsection each-parent } -{ $subsection find-parent } +{ $subsections + parents + each-parent + find-parent +} "Adding children, removing children and performing certain other operations initiates relayout requests automatically. In other cases, relayout may have to be triggered explicitly. There is no harm from doing this several times in a row as consecutive relayout requests are coalesced." -{ $subsection relayout } -{ $subsection relayout-1 } +{ $subsections + relayout + relayout-1 +} "Gadgets implement a generic word to inform their parents of their preferred size:" -{ $subsection pref-dim* } +{ $subsections pref-dim* } "To get a gadget's preferred size, do not call the above word, instead use " { $link pref-dim } ", which caches the result." ; ARTICLE: "ui-null-layout" "Manual layouts" @@ -229,14 +255,16 @@ ARTICLE: "ui-null-layout" "Manual layouts" ARTICLE: "ui-layout-impl" "Implementing layout gadgets" "The relayout process proceeds top-down, with parents laying out their children, which in turn lay out their children. Custom layout policy is implemented by defining a method on a generic word:" -{ $subsection layout* } +{ $subsections layout* } "When a " { $link layout* } " method is called, the size and location of the gadget has already been determined by its parent, and the method's job is to lay out the gadget's children. Children can be positioned and resized by setting a pair of slots, " { $snippet "loc" } " and " { $snippet "dim" } "." $nl "Some assorted utility words which are useful for implementing layout logic:" -{ $subsection pref-dim } -{ $subsection pref-dims } -{ $subsection prefer } -{ $subsection max-dim } -{ $subsection dim-sum } +{ $subsections + pref-dim + pref-dims + prefer + max-dim + dim-sum +} { $warning "When implementing the " { $link layout* } " generic word for a gadget which inherits from another layout, the " { $link children-on } " word might have to be re-implemented as well." $nl @@ -247,28 +275,32 @@ ARTICLE: "new-gadgets" "Implementing new gadgets" "One of the goals of the Factor UI is to minimize the need to implement new types of gadgets by offering a highly reusable, orthogonal set of building blocks. However, in some cases implementing a new type of gadget is necessary, for example when writing a graphical visualization." $nl "Bare gadgets can be constructed directly, which is useful if all you need is a custom appearance with no further behavior (see " { $link "ui-pen-protocol" } "):" -{ $subsection <gadget> } +{ $subsections <gadget> } "New gadgets are defined as subclasses of an existing gadget type, perhaps even " { $link gadget } " itself. Direct subclasses of " { $link gadget } " can be constructed using " { $link new } ", however some subclasses may define their own parametrized constructors (see " { $link "parametrized-constructors" } ")." $nl "Further topics:" -{ $subsection "ui-gestures" } -{ $subsection "ui-paint" } -{ $subsection "ui-control-impl" } -{ $subsection "clipboard-protocol" } -{ $subsection "ui.gadgets.line-support" } +{ $subsections + "ui-gestures" + "ui-paint" + "ui-control-impl" + "clipboard-protocol" + "ui.gadgets.line-support" +} { $see-also "ui-layout-impl" } ; ARTICLE: "starting-ui" "Starting the UI" "The main word of a vocabulary implementing a UI application should use a combinator to ensure that the application works when run from the command line as well as in the UI listener:" -{ $subsection with-ui } ; +{ $subsections with-ui } ; ARTICLE: "ui" "UI framework" "The " { $vocab-link "ui" } " vocabulary hierarchy implements the Factor UI framework. The implementation relies on a small amount of platform-specific code to open windows and receive keyboard and mouse events; UI gadgets are rendered using OpenGL." -{ $subsection "starting-ui" } -{ $subsection "ui-glossary" } -{ $subsection "building-ui" } -{ $subsection "new-gadgets" } -{ $subsection "ui-backend" } ; +{ $subsections + "starting-ui" + "ui-glossary" + "building-ui" + "new-gadgets" + "ui-backend" +} ; ABOUT: "ui" @@ -290,12 +322,18 @@ HELP: small-title-bar HELP: normal-title-bar { $description "Asks for a window to have a title bar. Without a title bar, the " { $link close-button } ", " { $link minimize-button } ", and " { $link maximize-button } " controls will not be available." } ; +HELP: textured-background +{ $description "Asks for a window to have a background that blends seamlessly with the window frame. Factor will leave the window background transparent and pass mouse button gestures not handled directly by a gadget through to the window system so that the window can be dragged from anywhere on its background." } ; + ARTICLE: "ui.gadgets.worlds-window-controls" "Window controls" "The following window controls can be placed in a " { $link world } " window:" -{ $subsection close-button } -{ $subsection minimize-button } -{ $subsection maximize-button } -{ $subsection resize-handles } -{ $subsection small-title-bar } -{ $subsection normal-title-bar } +{ $subsections + close-button + minimize-button + maximize-button + resize-handles + small-title-bar + normal-title-bar + textured-background +} "Provide a sequence of these values in the " { $snippet "window-controls" } " slot of the " { $link world-attributes } " tuple you pass to " { $link open-window } "." ; diff --git a/basis/unicode/breaks/breaks-docs.factor b/basis/unicode/breaks/breaks-docs.factor index 9c57aab9f6..e604c10c06 100644 --- a/basis/unicode/breaks/breaks-docs.factor +++ b/basis/unicode/breaks/breaks-docs.factor @@ -6,18 +6,22 @@ ABOUT: "unicode.breaks" ARTICLE: "unicode.breaks" "Word and grapheme breaks" "The " { $vocab-link "unicode.breaks" "unicode.breaks" } " vocabulary partially implements Unicode Standard Annex #29. This provides for segmentation of a string along grapheme and word boundaries. In Unicode, a grapheme, or a basic unit of display in text, may be more than one code point. For example, in the string \"e\\u000301\" (where U+0301 is a combining acute accent), there is only one grapheme, as the acute accent goes above the e, forming a single grapheme. Word breaks, in general, are more complicated than simply splitting by whitespace, and the Unicode algorithm provides for that." $nl "Operations for graphemes:" -{ $subsection first-grapheme } -{ $subsection first-grapheme-from } -{ $subsection last-grapheme } -{ $subsection last-grapheme-from } -{ $subsection >graphemes } -{ $subsection string-reverse } +{ $subsections + first-grapheme + first-grapheme-from + last-grapheme + last-grapheme-from + >graphemes + string-reverse +} "Operations on words:" -{ $subsection first-word } -{ $subsection first-word-from } -{ $subsection last-word } -{ $subsection last-word-from } -{ $subsection >words } ; +{ $subsections + first-word + first-word-from + last-word + last-word-from + >words +} ; HELP: first-grapheme { $values { "str" string } { "i" "an index" } } diff --git a/basis/unicode/case/case-docs.factor b/basis/unicode/case/case-docs.factor index 02da8e7635..7e4ac10e19 100644 --- a/basis/unicode/case/case-docs.factor +++ b/basis/unicode/case/case-docs.factor @@ -5,17 +5,21 @@ ABOUT: "unicode.case" ARTICLE: "unicode.case" "Case mapping" "When considering Unicode in general and not just ASCII or a smaller character set, putting a string in upper case, title case or lower case is slightly more complicated. In most contexts it's best to use the general Unicode routines for case conversion. There is an additional type of casing, case-fold, which is defined as bringing a string into upper case and then lower. This exists because in some cases it is different from simple lower case." -{ $subsection >upper } -{ $subsection >lower } -{ $subsection >title } -{ $subsection >case-fold } +{ $subsections + >upper + >lower + >title + >case-fold +} "To test if a string is in a given case:" -{ $subsection upper? } -{ $subsection lower? } -{ $subsection title? } -{ $subsection case-fold? } +{ $subsections + upper? + lower? + title? + case-fold? +} "For certain languages (Turkish, Azeri, Lithuanian), case mapping is dependent on locale; To change this, set the following variable to the ISO-639-1 code for your language:" -{ $subsection locale } +{ $subsections locale } "This is unnecessary for most locales." ; HELP: >upper diff --git a/basis/unicode/categories/categories-docs.factor b/basis/unicode/categories/categories-docs.factor index 924b197417..47e3f6f541 100644 --- a/basis/unicode/categories/categories-docs.factor +++ b/basis/unicode/categories/categories-docs.factor @@ -38,27 +38,29 @@ HELP: uncased ARTICLE: "unicode.categories" "Character classes" "The " { $vocab-link "unicode.categories" } " vocabulary implements predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ascii" } " equivalents in most cases. Each character class has an associated predicate word." -{ $subsection blank } -{ $subsection blank? } -{ $subsection letter } -{ $subsection letter? } -{ $subsection LETTER } -{ $subsection LETTER? } -{ $subsection Letter } -{ $subsection Letter? } -{ $subsection digit } -{ $subsection digit? } -{ $subsection printable } -{ $subsection printable? } -{ $subsection alpha } -{ $subsection alpha? } -{ $subsection control } -{ $subsection control? } -{ $subsection uncased } -{ $subsection uncased? } -{ $subsection character } -{ $subsection character? } -{ $subsection math } -{ $subsection math? } ; +{ $subsections + blank + blank? + letter + letter? + LETTER + LETTER? + Letter + Letter? + digit + digit? + printable + printable? + alpha + alpha? + control + control? + uncased + uncased? + character + character? + math + math? +} ; ABOUT: "unicode.categories" diff --git a/basis/unicode/categories/syntax/syntax-docs.factor b/basis/unicode/categories/syntax/syntax-docs.factor index 6293b92c72..89c8d3554c 100644 --- a/basis/unicode/categories/syntax/syntax-docs.factor +++ b/basis/unicode/categories/syntax/syntax-docs.factor @@ -7,8 +7,10 @@ ABOUT: "unicode.categories.syntax" ARTICLE: "unicode.categories.syntax" "Unicode category syntax" "There is special syntax sugar for making predicate classes which are unions of Unicode general categories, plus some other code." -{ $subsection POSTPONE: CATEGORY: } -{ $subsection POSTPONE: CATEGORY-NOT: } ; +{ $subsections + POSTPONE: CATEGORY: + POSTPONE: CATEGORY-NOT: +} ; HELP: CATEGORY: { $syntax "CATEGORY: foo Nl Pd Lu | \"Diacritic\" property? ;" } diff --git a/basis/unicode/collation/collation-docs.factor b/basis/unicode/collation/collation-docs.factor index 990390e82f..eea5ec0011 100644 --- a/basis/unicode/collation/collation-docs.factor +++ b/basis/unicode/collation/collation-docs.factor @@ -3,14 +3,18 @@ IN: unicode.collation ARTICLE: "unicode.collation" "Collation and weak comparison" "The " { $vocab-link "unicode.collation" "unicode.collation" } " vocabulary implements the Unicode Collation Algorithm. The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. It is far preferred over code point order when sorting for human consumption, in user interfaces. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are useful for collation directly:" -{ $subsection sort-strings } -{ $subsection collation-key } -{ $subsection string<=> } +{ $subsections + sort-strings + collation-key + string<=> +} "Predicates for weak equality testing:" -{ $subsection primary= } -{ $subsection secondary= } -{ $subsection tertiary= } -{ $subsection quaternary= } ; +{ $subsections + primary= + secondary= + tertiary= + quaternary= +} ; ABOUT: "unicode.collation" diff --git a/basis/unicode/data/data-docs.factor b/basis/unicode/data/data-docs.factor index 82706729bf..9df0481217 100644 --- a/basis/unicode/data/data-docs.factor +++ b/basis/unicode/data/data-docs.factor @@ -7,18 +7,20 @@ ABOUT: "unicode.data" ARTICLE: "unicode.data" "Unicode data tables" "The " { $vocab-link "unicode.data" "unicode.data" } " vocabulary contains core Unicode data tables and code for parsing this from files. The following words access these data tables." -{ $subsection canonical-entry } -{ $subsection combine-chars } -{ $subsection combining-class } -{ $subsection non-starter? } -{ $subsection name>char } -{ $subsection char>name } -{ $subsection property? } -{ $subsection category } -{ $subsection ch>upper } -{ $subsection ch>lower } -{ $subsection ch>title } -{ $subsection special-case } ; +{ $subsections + canonical-entry + combine-chars + combining-class + non-starter? + name>char + char>name + property? + category + ch>upper + ch>lower + ch>title + special-case +} ; HELP: canonical-entry { $values { "char" "a code point" } { "seq" string } } diff --git a/basis/unicode/normalize/normalize-docs.factor b/basis/unicode/normalize/normalize-docs.factor index 453ab24388..e4433f13e0 100644 --- a/basis/unicode/normalize/normalize-docs.factor +++ b/basis/unicode/normalize/normalize-docs.factor @@ -11,10 +11,12 @@ $nl "There are four normalization forms: NFD, NFC, NFKD, and NFKC. Basically, in NFD and NFKD, everything is expanded, whereas in NFC and NFKC, everything is contracted. In NFKD and NFKC, more things are expanded and contracted. This is a process which loses some information, so it should be done only with care." $nl "Most of the world uses NFC to communicate, but for many purposes, NFD/NFKD is easier to process. For more information, see Unicode Standard Annex #15 and section 3 of the Unicode standard." -{ $subsection nfc } -{ $subsection nfd } -{ $subsection nfkc } -{ $subsection nfkd } ; +{ $subsections + nfc + nfd + nfkc + nfkd +} ; HELP: nfc { $values { "string" string } { "nfc" "a string in NFC" } } diff --git a/basis/unicode/script/script-docs.factor b/basis/unicode/script/script-docs.factor index 2860f83bef..266f32144b 100644 --- a/basis/unicode/script/script-docs.factor +++ b/basis/unicode/script/script-docs.factor @@ -7,7 +7,7 @@ ABOUT: "unicode.script" ARTICLE: "unicode.script" "Unicode script properties" "The unicode standard gives every character a script. Note that this is different from a language, and that it is non-trivial to detect language from a string. To get the script of a character, use" -{ $subsection script-of } ; +{ $subsections script-of } ; HELP: script-of { $values { "char" "a code point" } { "script" string } } diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor index ebc0b80097..0825e42930 100644 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/bsd/bsd.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax classes.struct combinators system -vocabs.loader ; +USING: alien.c-types alien.syntax classes.struct combinators +system unix.types vocabs.loader ; IN: unix CONSTANT: MAXPATHLEN 1024 diff --git a/basis/unix/bsd/freebsd/freebsd.factor b/basis/unix/bsd/freebsd/freebsd.factor index 13a4a24be1..e6a2070520 100644 --- a/basis/unix/bsd/freebsd/freebsd.factor +++ b/basis/unix/bsd/freebsd/freebsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct unix.types ; IN: unix CONSTANT: FD_SETSIZE 1024 diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/bsd/netbsd/netbsd.factor index 40d7cf4b02..15b173c311 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/bsd/netbsd/netbsd.factor @@ -1,5 +1,5 @@ USING: alien.syntax alien.c-types math vocabs.loader -classes.struct ; +classes.struct unix.types ; IN: unix CONSTANT: FD_SETSIZE 256 diff --git a/basis/unix/bsd/openbsd/openbsd.factor b/basis/unix/bsd/openbsd/openbsd.factor index d5537abd8f..f48b7c1ac4 100644 --- a/basis/unix/bsd/openbsd/openbsd.factor +++ b/basis/unix/bsd/openbsd/openbsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct unix.types ; IN: unix CONSTANT: FD_SETSIZE 1024 diff --git a/basis/unix/getfsstat/freebsd/freebsd.factor b/basis/unix/getfsstat/freebsd/freebsd.factor index 44d85680a7..fefd316fdb 100644 --- a/basis/unix/getfsstat/freebsd/freebsd.factor +++ b/basis/unix/getfsstat/freebsd/freebsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.c-types alien.syntax unix.statfs.freebsd ; IN: unix.getfsstat.freebsd CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete diff --git a/basis/unix/getfsstat/macosx/macosx.factor b/basis/unix/getfsstat/macosx/macosx.factor index 0db1bb86ad..0b76d048fe 100644 --- a/basis/unix/getfsstat/macosx/macosx.factor +++ b/basis/unix/getfsstat/macosx/macosx.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.c-types alien.syntax unix.statfs.macosx ; IN: unix.getfsstat.macosx CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete CONSTANT: MNT_NOWAIT 2 ! start all I/O, but do not wait for it -FUNCTION: int getfsstat64 ( statfs* buf, int bufsize, int flags ) ; +FUNCTION: int getfsstat64 ( statfs64* buf, int bufsize, int flags ) ; diff --git a/basis/unix/getfsstat/netbsd/netbsd.factor b/basis/unix/getfsstat/netbsd/netbsd.factor index 1eca6d7dc3..cdad20e4b5 100644 --- a/basis/unix/getfsstat/netbsd/netbsd.factor +++ b/basis/unix/getfsstat/netbsd/netbsd.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.c-types alien.syntax unix.statvfs.netbsd ; IN: unix.getfsstat.netbsd CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete CONSTANT: MNT_NOWAIT 2 ! start all I/O, but do not wait for it CONSTANT: MNT_LAZY 3 ! push data not written by filesystem syncer -FUNCTION: int getvfsstat ( statfs* buf, int bufsize, int flags ) ; +FUNCTION: int getvfsstat ( statvfs* buf, int bufsize, int flags ) ; diff --git a/basis/unix/getfsstat/openbsd/openbsd.factor b/basis/unix/getfsstat/openbsd/openbsd.factor index 19465d8040..07b45f5df5 100644 --- a/basis/unix/getfsstat/openbsd/openbsd.factor +++ b/basis/unix/getfsstat/openbsd/openbsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.c-types alien.syntax unix.statfs.openbsd ; IN: unix.getfsstat.openbsd CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete diff --git a/basis/unix/groups/groups-docs.factor b/basis/unix/groups/groups-docs.factor index 05b22d3413..3afe344d53 100644 --- a/basis/unix/groups/groups-docs.factor +++ b/basis/unix/groups/groups-docs.factor @@ -82,17 +82,23 @@ ARTICLE: "unix.groups" "Unix groups" "The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups." $nl "Listing all groups:" -{ $subsection all-groups } +{ $subsections all-groups } "Real groups:" -{ $subsection real-group-name } -{ $subsection real-group-id } -{ $subsection set-real-group } +{ $subsections + real-group-name + real-group-id + set-real-group +} "Effective groups:" -{ $subsection effective-group-name } -{ $subsection effective-group-id } -{ $subsection set-effective-group } +{ $subsections + effective-group-name + effective-group-id + set-effective-group +} "Combinators to change groups:" -{ $subsection with-real-group } -{ $subsection with-effective-group } ; +{ $subsections + with-real-group + with-effective-group +} ; ABOUT: "unix.groups" diff --git a/basis/unix/kqueue/freebsd/freebsd.factor b/basis/unix/kqueue/freebsd/freebsd.factor index 4bf5af8482..54f576ffc1 100644 --- a/basis/unix/kqueue/freebsd/freebsd.factor +++ b/basis/unix/kqueue/freebsd/freebsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct unix.time ; IN: unix.kqueue STRUCT: kevent diff --git a/basis/unix/kqueue/kqueue.factor b/basis/unix/kqueue/kqueue.factor index 6c3b9ef2cb..17b653418a 100644 --- a/basis/unix/kqueue/kqueue.factor +++ b/basis/unix/kqueue/kqueue.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax system sequences vocabs.loader words +USING: alien.c-types alien.syntax system sequences vocabs.loader words accessors ; IN: unix.kqueue diff --git a/basis/unix/kqueue/macosx/macosx.factor b/basis/unix/kqueue/macosx/macosx.factor index c30584efab..f0dc8c8f5e 100644 --- a/basis/unix/kqueue/macosx/macosx.factor +++ b/basis/unix/kqueue/macosx/macosx.factor @@ -1,4 +1,4 @@ -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct unix.time ; IN: unix.kqueue STRUCT: kevent diff --git a/basis/unix/kqueue/netbsd/netbsd.factor b/basis/unix/kqueue/netbsd/netbsd.factor index d9a9116930..9ba6202585 100644 --- a/basis/unix/kqueue/netbsd/netbsd.factor +++ b/basis/unix/kqueue/netbsd/netbsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct unix.time ; IN: unix.kqueue STRUCT: kevent diff --git a/basis/unix/kqueue/openbsd/openbsd.factor b/basis/unix/kqueue/openbsd/openbsd.factor index 1d851c8d68..ab680345b6 100644 --- a/basis/unix/kqueue/openbsd/openbsd.factor +++ b/basis/unix/kqueue/openbsd/openbsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct unix.time ; IN: unix.kqueue STRUCT: kevent diff --git a/basis/unix/linux/epoll/epoll.factor b/basis/unix/linux/epoll/epoll.factor index 966db32f60..e613b042f2 100644 --- a/basis/unix/linux/epoll/epoll.factor +++ b/basis/unix/linux/epoll/epoll.factor @@ -1,18 +1,18 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: unix.linux.epoll -USING: alien.syntax classes.struct math ; +USING: alien.c-types alien.syntax classes.struct math ; FUNCTION: int epoll_create ( int size ) ; -FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ; - STRUCT: epoll-event { events uint } { fd uint } { padding uint } ; -FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ; +FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll-event* event ) ; + +FUNCTION: int epoll_wait ( int epfd, epoll-event* events, int maxevents, int timeout ) ; CONSTANT: EPOLL_CTL_ADD 1 ! Add a file decriptor to the interface. CONSTANT: EPOLL_CTL_DEL 2 ! Remove a file decriptor from the interface. diff --git a/basis/unix/linux/inotify/inotify.factor b/basis/unix/linux/inotify/inotify.factor index 5f9bf5d462..f589c17e28 100644 --- a/basis/unix/linux/inotify/inotify.factor +++ b/basis/unix/linux/inotify/inotify.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax math math.bitwise classes.struct ; +USING: alien.c-types alien.syntax math math.bitwise classes.struct ; IN: unix.linux.inotify STRUCT: inotify-event diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor index 48044c731c..93bf621acd 100644 --- a/basis/unix/linux/linux.factor +++ b/basis/unix/linux/linux.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax alien system classes.struct ; +USING: alien.c-types alien.syntax alien system classes.struct +unix.types ; IN: unix ! Linux. @@ -60,7 +61,7 @@ CONSTANT: max-un-path 108 STRUCT: sockaddr-un { family ushort } - { path { "char" max-un-path } } ; + { path { char max-un-path } } ; CONSTANT: SOCK_STREAM 1 CONSTANT: SOCK_DGRAM 2 @@ -102,7 +103,7 @@ STRUCT: dirent { d_name char[256] } ; FUNCTION: int open64 ( char* path, int flags, int prot ) ; -FUNCTION: dirent64* readdir64 ( DIR* dirp ) ; +FUNCTION: dirent* readdir64 ( DIR* dirp ) ; FUNCTION: int readdir64_r ( void* dirp, dirent* entry, dirent** result ) ; M: linux open-file [ open64 ] unix-system-call ; diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index 2912f8b744..ab10aef3ea 100644 --- a/basis/unix/process/process.factor +++ b/basis/unix/process/process.factor @@ -1,6 +1,6 @@ USING: kernel alien.c-types alien.data alien.strings sequences math alien.syntax unix namespaces continuations threads assocs -io.backend.unix io.encodings.utf8 unix.utilities fry ; +io.backend.unix io.encodings.utf8 unix.types unix.utilities fry ; IN: unix.process ! Low-level Unix process launching utilities. These are used diff --git a/basis/unix/solaris/solaris.factor b/basis/unix/solaris/solaris.factor index b7ea3f172e..1a1a7603f0 100644 --- a/basis/unix/solaris/solaris.factor +++ b/basis/unix/solaris/solaris.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006 Patrick Mauritz. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax system kernel layouts ; +USING: alien.c-types alien.syntax system kernel layouts ; IN: unix ! Solaris. diff --git a/basis/unix/stat/freebsd/freebsd.factor b/basis/unix/stat/freebsd/freebsd.factor index 0acf2512e8..04f884e496 100644 --- a/basis/unix/stat/freebsd/freebsd.factor +++ b/basis/unix/stat/freebsd/freebsd.factor @@ -1,4 +1,5 @@ -USING: kernel alien.syntax math classes.struct ; +USING: kernel alien.c-types alien.syntax math classes.struct +unix.time unix.types ; IN: unix.stat ! FreeBSD 8.0-CURRENT diff --git a/basis/unix/stat/linux/32/32.factor b/basis/unix/stat/linux/32/32.factor index 324237d645..f01140ff4b 100644 --- a/basis/unix/stat/linux/32/32.factor +++ b/basis/unix/stat/linux/32/32.factor @@ -1,4 +1,5 @@ -USING: kernel alien.syntax math classes.struct ; +USING: kernel alien.c-types alien.syntax math classes.struct +unix.time unix.types ; IN: unix.stat ! stat64 diff --git a/basis/unix/stat/linux/64/64.factor b/basis/unix/stat/linux/64/64.factor index cfd6553ca3..bb16133c76 100644 --- a/basis/unix/stat/linux/64/64.factor +++ b/basis/unix/stat/linux/64/64.factor @@ -1,4 +1,5 @@ -USING: kernel alien.syntax math classes.struct ; +USING: kernel alien.c-types alien.syntax math classes.struct +unix.time unix.types ; IN: unix.stat ! Ubuntu 7.10 64-bit diff --git a/basis/unix/stat/macosx/macosx.factor b/basis/unix/stat/macosx/macosx.factor index afab727ddb..a2104dcb33 100644 --- a/basis/unix/stat/macosx/macosx.factor +++ b/basis/unix/stat/macosx/macosx.factor @@ -1,8 +1,8 @@ USING: alien.c-types arrays accessors combinators classes.struct -alien.syntax ; +alien.syntax unix.time unix.types ; IN: unix.stat -! Mac OS X ppc +! Mac OS X ! stat64 structure STRUCT: stat diff --git a/basis/unix/stat/netbsd/32/32.factor b/basis/unix/stat/netbsd/32/32.factor index 98403313b8..fb0d61b7e9 100644 --- a/basis/unix/stat/netbsd/32/32.factor +++ b/basis/unix/stat/netbsd/32/32.factor @@ -1,4 +1,5 @@ -USING: kernel alien.syntax math classes.struct ; +USING: kernel alien.c-types alien.syntax math classes.struct +unix.time unix.types ; IN: unix.stat ! NetBSD 4.0 diff --git a/basis/unix/stat/netbsd/64/64.factor b/basis/unix/stat/netbsd/64/64.factor index c532e7e9ff..47c4e0c129 100644 --- a/basis/unix/stat/netbsd/64/64.factor +++ b/basis/unix/stat/netbsd/64/64.factor @@ -1,4 +1,5 @@ -USING: kernel alien.syntax math classes.struct ; +USING: kernel alien.c-types alien.syntax math classes.struct +unix.time unix.types ; IN: unix.stat ! NetBSD 4.0 diff --git a/basis/unix/stat/openbsd/openbsd.factor b/basis/unix/stat/openbsd/openbsd.factor index 5bf950fd4b..2702e60f6c 100644 --- a/basis/unix/stat/openbsd/openbsd.factor +++ b/basis/unix/stat/openbsd/openbsd.factor @@ -1,4 +1,5 @@ -USING: kernel alien.syntax math classes.struct ; +USING: kernel alien.c-types alien.syntax math classes.struct +unix.time unix.types ; IN: unix.stat ! OpenBSD 4.2 diff --git a/basis/unix/statfs/freebsd/freebsd.factor b/basis/unix/statfs/freebsd/freebsd.factor index d1e7949a54..ae418e6eb4 100644 --- a/basis/unix/statfs/freebsd/freebsd.factor +++ b/basis/unix/statfs/freebsd/freebsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax unix.types unix.stat classes.struct ; +USING: alien.syntax alien.c-types unix.types unix.stat classes.struct ; IN: unix.statfs.freebsd CONSTANT: MFSNAMELEN 16 ! length of type name including null */ @@ -27,8 +27,8 @@ STRUCT: statfs { f_owner uid_t } { f_fsid fsid_t } { f_charspare char[80] } - { f_fstypename { "char" MFSNAMELEN } } - { f_mntfromname { "char" MNAMELEN } } - { f_mntonname { "char" MNAMELEN } } ; + { f_fstypename { char MFSNAMELEN } } + { f_mntfromname { char MNAMELEN } } + { f_mntonname { char MNAMELEN } } ; -FUNCTION: int statfs ( char* path, statvfs* buf ) ; +FUNCTION: int statfs ( char* path, statfs* buf ) ; diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index 42d66ff1ba..ab37ab9605 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax unix.types unix.stat classes.struct ; +USING: alien.c-types alien.syntax unix.types unix.stat classes.struct ; IN: unix.statfs.linux STRUCT: statfs64 diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index 38709f64fe..e83d2d40a0 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -111,9 +111,9 @@ STRUCT: statfs64 { f_type uint32_t } { f_flags uint32_t } { f_fssubtype uint32_t } - { f_fstypename { "char" MFSTYPENAMELEN } } - { f_mntonname { "char" MAXPATHLEN } } - { f_mntfromname { "char" MAXPATHLEN } } + { f_fstypename { char MFSTYPENAMELEN } } + { f_mntonname { char MAXPATHLEN } } + { f_mntfromname { char MAXPATHLEN } } { f_reserved uint32_t[8] } ; FUNCTION: int statfs64 ( char* path, statfs64* buf ) ; diff --git a/basis/unix/statfs/openbsd/openbsd.factor b/basis/unix/statfs/openbsd/openbsd.factor index 590faf82a6..4e65e74c2c 100644 --- a/basis/unix/statfs/openbsd/openbsd.factor +++ b/basis/unix/statfs/openbsd/openbsd.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax unix.types unix.stat classes.struct ; +USING: alien.c-types alien.syntax unix.types classes.struct +unix.stat ; IN: unix.statfs.openbsd CONSTANT: MFSNAMELEN 16 @@ -25,9 +26,9 @@ STRUCT: statfs { f_owner uid_t } { f_ctime u_int32_t } { f_spare u_int32_t[3] } - { f_fstypename { "char" MFSNAMELEN } } - { f_mntonname { "char" MNAMELEN } } - { f_mntfromname { "char" MNAMELEN } } + { f_fstypename { char MFSNAMELEN } } + { f_mntonname { char MNAMELEN } } + { f_mntfromname { char MNAMELEN } } { mount_info char[160] } ; -FUNCTION: int statfs ( char* path, statvfs* buf ) ; +FUNCTION: int statfs ( char* path, statfs* buf ) ; diff --git a/basis/unix/statvfs/freebsd/freebsd.factor b/basis/unix/statvfs/freebsd/freebsd.factor index 2fcd0c7372..c2834736b7 100644 --- a/basis/unix/statvfs/freebsd/freebsd.factor +++ b/basis/unix/statvfs/freebsd/freebsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct unix.types ; IN: unix.statvfs.freebsd STRUCT: statvfs diff --git a/basis/unix/statvfs/linux/linux.factor b/basis/unix/statvfs/linux/linux.factor index 6e408c8fa4..d7139d84b2 100644 --- a/basis/unix/statvfs/linux/linux.factor +++ b/basis/unix/statvfs/linux/linux.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct unix.types ; IN: unix.statvfs.linux STRUCT: statvfs64 diff --git a/basis/unix/statvfs/macosx/macosx.factor b/basis/unix/statvfs/macosx/macosx.factor index 3b1fe71a6a..3fe44a28d0 100644 --- a/basis/unix/statvfs/macosx/macosx.factor +++ b/basis/unix/statvfs/macosx/macosx.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct unix.types ; IN: unix.statvfs.macosx STRUCT: statvfs diff --git a/basis/unix/statvfs/netbsd/netbsd.factor b/basis/unix/statvfs/netbsd/netbsd.factor index 25c96dc15d..a76774b656 100644 --- a/basis/unix/statvfs/netbsd/netbsd.factor +++ b/basis/unix/statvfs/netbsd/netbsd.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct unix.types +unix.stat ; IN: unix.statvfs.netbsd CONSTANT: _VFS_NAMELEN 32 @@ -28,8 +29,8 @@ STRUCT: statvfs { f_namemax ulong } { f_owner uid_t } { f_spare uint32_t[4] } - { f_fstypename { "char" _VFS_NAMELEN } } - { f_mntonname { "char" _VFS_MNAMELEN } } - { f_mntfromname { "char" _VFS_MNAMELEN } } ; + { f_fstypename { char _VFS_NAMELEN } } + { f_mntonname { char _VFS_MNAMELEN } } + { f_mntfromname { char _VFS_MNAMELEN } } ; FUNCTION: int statvfs ( char* path, statvfs* buf ) ; diff --git a/basis/unix/statvfs/openbsd/openbsd.factor b/basis/unix/statvfs/openbsd/openbsd.factor index f2d12c29cc..d5b2ee30a8 100644 --- a/basis/unix/statvfs/openbsd/openbsd.factor +++ b/basis/unix/statvfs/openbsd/openbsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct unix.types ; IN: unix.statvfs.openbsd STRUCT: statvfs diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index 4ca2c4368a..7650e9962f 100644 --- a/basis/unix/types/types.factor +++ b/basis/unix/types/types.factor @@ -1,4 +1,4 @@ -USING: kernel system alien.syntax combinators vocabs.loader ; +USING: kernel system alien.c-types alien.syntax combinators vocabs.loader ; IN: unix.types TYPEDEF: char int8_t @@ -37,6 +37,12 @@ TYPEDEF: fsfilcnt_t __fsfilcnt_t TYPEDEF: __uint64_t rlim_t TYPEDEF: uint32_t id_t +C-TYPE: DIR +C-TYPE: FILE +C-TYPE: rlimit +C-TYPE: rusage +C-TYPE: sockaddr + os { { linux [ "unix.types.linux" require ] } { macosx [ "unix.types.macosx" require ] } @@ -45,3 +51,4 @@ os { { netbsd [ "unix.types.netbsd" require ] } { winnt [ ] } } case + diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 59a3331354..afe24905d6 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -5,7 +5,7 @@ USING: alien alien.c-types alien.syntax kernel libc sequences continuations byte-arrays strings math namespaces system combinators vocabs.loader accessors stack-checker macros locals generalizations unix.types -io vocabs classes.struct ; +io vocabs classes.struct unix.time ; IN: unix CONSTANT: PROT_NONE 0 @@ -35,12 +35,6 @@ CONSTANT: DT_LNK 10 CONSTANT: DT_SOCK 12 CONSTANT: DT_WHT 14 -STRUCT: group - { gr_name char* } - { gr_passwd char* } - { gr_gid int } - { gr_mem char** } ; - LIBRARY: libc FUNCTION: char* strerror ( int errno ) ; @@ -68,6 +62,28 @@ MACRO:: unix-system-call ( quot -- ) ] ] ; +HOOK: open-file os ( path flags mode -- fd ) + +<< + +{ + { [ os linux? ] [ "unix.linux" require ] } + { [ os bsd? ] [ "unix.bsd" require ] } + { [ os solaris? ] [ "unix.solaris" require ] } +} cond + +"debugger" vocab [ + "unix.debugger" require +] when + +>> + +STRUCT: group + { gr_name char* } + { gr_passwd char* } + { gr_gid int } + { gr_mem char** } ; + FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ; FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ; FUNCTION: int chdir ( char* path ) ; @@ -86,7 +102,7 @@ FUNCTION: int dup2 ( int oldd, int newd ) ; ! FUNCTION: int dup ( int oldd ) ; : _exit ( status -- * ) #! We throw to give this a terminating stack effect. - "int" f "_exit" { "int" } alien-invoke "Exit failed" throw ; + int f "_exit" { int } alien-invoke "Exit failed" throw ; FUNCTION: void endpwent ( ) ; FUNCTION: int fchdir ( int fd ) ; FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ; @@ -141,8 +157,6 @@ FUNCTION: int shutdown ( int fd, int how ) ; FUNCTION: int open ( char* path, int flags, int prot ) ; -HOOK: open-file os ( path flags mode -- fd ) - M: unix open-file [ open ] unix-system-call ; FUNCTION: DIR* opendir ( char* path ) ; @@ -207,12 +221,3 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ; FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; -{ - { [ os linux? ] [ "unix.linux" require ] } - { [ os bsd? ] [ "unix.bsd" require ] } - { [ os solaris? ] [ "unix.solaris" require ] } -} cond - -"debugger" vocab [ - "unix.debugger" require -] when diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor index faee36d076..c7867db2bf 100644 --- a/basis/unix/users/users-docs.factor +++ b/basis/unix/users/users-docs.factor @@ -90,17 +90,23 @@ ARTICLE: "unix.users" "Unix users" "The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users." $nl "Listing all users:" -{ $subsection all-users } +{ $subsections all-users } "Real user:" -{ $subsection real-user-name } -{ $subsection real-user-id } -{ $subsection set-real-user } +{ $subsections + real-user-name + real-user-id + set-real-user +} "Effective user:" -{ $subsection effective-user-name } -{ $subsection effective-user-id } -{ $subsection set-effective-user } +{ $subsections + effective-user-name + effective-user-id + set-effective-user +} "Combinators to change users:" -{ $subsection with-real-user } -{ $subsection with-effective-user } ; +{ $subsections + with-real-user + with-effective-user +} ; ABOUT: "unix.users" diff --git a/basis/unrolled-lists/unrolled-lists-docs.factor b/basis/unrolled-lists/unrolled-lists-docs.factor index 387bb3dc7b..dd8611db9d 100644 --- a/basis/unrolled-lists/unrolled-lists-docs.factor +++ b/basis/unrolled-lists/unrolled-lists-docs.factor @@ -15,8 +15,10 @@ HELP: <hashed-unrolled-list> ARTICLE: "unrolled-lists" "Unrolled lists" "The " { $vocab-link "unrolled-lists" } " vocabulary provides an implementation of the " { $link deque } " protocol with constant time insertion and removal at both ends, and lower memory overhead than a " { $link dlist } " due to packing 32 elements per every node. The one tradeoff is that unlike dlists, " { $link delete-node } " is not supported for unrolled lists." -{ $subsection unrolled-list } -{ $subsection <unrolled-list> } -{ $subsection <hashed-unrolled-list> } ; +{ $subsections + unrolled-list + <unrolled-list> + <hashed-unrolled-list> +} ; ABOUT: "unrolled-lists" diff --git a/basis/urls/encoding/encoding-docs.factor b/basis/urls/encoding/encoding-docs.factor index a021bd6d23..39ce5c7bca 100644 --- a/basis/urls/encoding/encoding-docs.factor +++ b/basis/urls/encoding/encoding-docs.factor @@ -1,5 +1,5 @@ +USING: strings help.markup help.syntax assocs ; IN: urls.encoding -USING: strings help.markup help.syntax assocs multiline ; HELP: url-decode { $values { "str" string } { "decoded" string } } @@ -39,23 +39,27 @@ HELP: query>assoc "USING: prettyprint urls.encoding ;" "\"gender=female&agefrom=22&ageto=28&location=Omaha+NE\"" "query>assoc ." - <" H{ + """H{ { "gender" "female" } { "agefrom" "22" } { "ageto" "28" } { "location" "Omaha NE" } -}"> +}""" } } ; ARTICLE: "url-encoding" "URL encoding and decoding" "URL encoding and decoding strings:" -{ $subsection url-encode } -{ $subsection url-decode } -{ $subsection url-quotable? } +{ $subsections + url-encode + url-decode + url-quotable? +} "Encoding and decoding queries:" -{ $subsection assoc>query } -{ $subsection query>assoc } +{ $subsections + assoc>query + query>assoc +} "See " { $url "http://en.wikipedia.org/wiki/Percent-encoding" } " for a description of URL encoding." ; ABOUT: "url-encoding" diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor index eb8e452ca4..a66ba14694 100644 --- a/basis/urls/urls-docs.factor +++ b/basis/urls/urls-docs.factor @@ -1,6 +1,6 @@ USING: assocs hashtables help.markup help.syntax io.streams.string io.files io.pathnames kernel strings present -math multiline ; +math ; IN: urls HELP: url @@ -112,11 +112,11 @@ HELP: set-query-param } { $examples { $code - <" USING: kernel http.client urls ; + """USING: kernel http.client urls ; URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" clone "concatenative programming (NSFW)" "query" set-query-param "1" "adult_ok" set-query-param -http-get"> +http-get""" } "(For a complete Yahoo! search web service implementation, see the " { $vocab-link "yahoo" } " vocabulary.)" } @@ -167,9 +167,11 @@ HELP: url-append-path { $description "Like " { $link append-path } ", but intended for use with URL paths and not filesystem paths." } ; ARTICLE: "url-utilities" "URL implementation utilities" -{ $subsection parse-host } -{ $subsection secure-protocol? } -{ $subsection url-append-path } ; +{ $subsections + parse-host + secure-protocol? + url-append-path +} ; ARTICLE: "urls" "URL objects" "The " { $vocab-link "urls" } " vocabulary implements a URL data type. The benefit of using a data type to prepresent URLs rather than a string is that the parsing, printing and escaping logic is encapsulated and reused, rather than re-implemented in a potentially buggy manner every time." @@ -177,25 +179,29 @@ $nl "URL objects are used heavily by the " { $vocab-link "http" } " and " { $vocab-link "furnace" } " vocabularies, and are also useful on their own." $nl "The class of URLs, and a constructor:" -{ $subsection url } -{ $subsection <url> } +{ $subsections + url + <url> +} "Converting strings to URLs:" -{ $subsection >url } +{ $subsections >url } "URLs can be converted back to strings using the " { $link present } " word." $nl "URL literal syntax:" -{ $subsection POSTPONE: URL" } +{ $subsections POSTPONE: URL" } "Manipulating URLs:" -{ $subsection derive-url } -{ $subsection relative-url } -{ $subsection ensure-port } -{ $subsection query-param } -{ $subsection set-query-param } +{ $subsections + derive-url + relative-url + ensure-port + query-param + set-query-param +} "Creating " { $link "network-addressing" } " from URLs:" -{ $subsection url-addr } +{ $subsections url-addr } "The URL implemention encodes and decodes components of " { $link url } " instances automatically, but sometimes this functionality is needed for non-URL strings." -{ $subsection "url-encoding" } +{ $subsections "url-encoding" } "Utility words used by the URL implementation:" -{ $subsection "url-utilities" } ; +{ $subsections "url-utilities" } ; ABOUT: "urls" diff --git a/basis/uuid/uuid-docs.factor b/basis/uuid/uuid-docs.factor index 487d5a1104..ad8ddba5da 100644 --- a/basis/uuid/uuid-docs.factor +++ b/basis/uuid/uuid-docs.factor @@ -36,10 +36,12 @@ ARTICLE: "uuid" "UUID (Universally Unique Identifier)" "The below words can be used to generate version 1, 3, 4, and 5 UUIDs as specified in RFC 4122." $nl "If all you want is a unique ID, you should probably call " { $link uuid1 } " or " { $link uuid4 } "." -{ $subsection uuid1 } -{ $subsection uuid3 } -{ $subsection uuid4 } -{ $subsection uuid5 } +{ $subsections + uuid1 + uuid3 + uuid4 + uuid5 +} ; ABOUT: "uuid" diff --git a/basis/validators/validators-docs.factor b/basis/validators/validators-docs.factor index 45444889de..41f80ee65c 100644 --- a/basis/validators/validators-docs.factor +++ b/basis/validators/validators-docs.factor @@ -89,27 +89,33 @@ $nl "Note that validators which take numbers must be preceded by " { $link v-integer } " or " { $link v-number } " if the original input is a string." $nl "Higher-order validators which require additional parameters:" -{ $subsection v-default } -{ $subsection v-optional } -{ $subsection v-min-length } -{ $subsection v-max-length } -{ $subsection v-min-value } -{ $subsection v-max-value } -{ $subsection v-regexp } +{ $subsections + v-default + v-optional + v-min-length + v-max-length + v-min-value + v-max-value + v-regexp +} "Simple validators:" -{ $subsection v-required } -{ $subsection v-number } -{ $subsection v-integer } -{ $subsection v-one-line } -{ $subsection v-one-word } -{ $subsection v-captcha } -{ $subsection v-checkbox } +{ $subsections + v-required + v-number + v-integer + v-one-line + v-one-word + v-captcha + v-checkbox +} "More complex validators:" -{ $subsection v-email } -{ $subsection v-url } -{ $subsection v-username } -{ $subsection v-password } -{ $subsection v-credit-card } -{ $subsection v-mode } ; +{ $subsections + v-email + v-url + v-username + v-password + v-credit-card + v-mode +} ; ABOUT: "validators" diff --git a/basis/values/values-docs.factor b/basis/values/values-docs.factor index 7c96f19ac9..880dcf3d8a 100644 --- a/basis/values/values-docs.factor +++ b/basis/values/values-docs.factor @@ -3,12 +3,14 @@ IN: values ARTICLE: "values" "Global values" "Usually, dynamically-scoped variables subsume global variables and are sufficient for holding global data. But occasionally, for global information that's calculated just once and must be accessed more rapidly than a dynamic variable lookup can provide, it's useful to use the word mechanism instead, and set a word to the appropriate value just once. The " { $vocab-link "values" } " vocabulary implements " { $emphasis "values" } ", which abstract over this concept. To create a new word as a value, use the following syntax:" -{ $subsection POSTPONE: VALUE: } +{ $subsections POSTPONE: VALUE: } "To get the value, just call the word. The following words manipulate values:" -{ $subsection get-value } -{ $subsection set-value } -{ $subsection POSTPONE: to: } -{ $subsection change-value } ; +{ $subsections + get-value + set-value + POSTPONE: to: + change-value +} ; ABOUT: "values" diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor index ab5a98ab3c..11d9dabb3d 100644 --- a/basis/vm/vm.factor +++ b/basis/vm/vm.factor @@ -1,23 +1,22 @@ ! Copyright (C) 2009 Phil Dawes. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.structs alien.syntax ; +USING: classes.struct alien.c-types alien.syntax ; IN: vm TYPEDEF: void* cell +C-TYPE: context -C-STRUCT: zone - { "cell" "start" } - { "cell" "here" } - { "cell" "size" } - { "cell" "end" } - ; +STRUCT: zone + { start cell } + { here cell } + { size cell } + { end cell } ; -C-STRUCT: vm - { "context*" "stack_chain" } - { "zone" "nursery" } - { "cell" "cards_offset" } - { "cell" "decks_offset" } - { "cell[70]" "userenv" } - ; +STRUCT: vm + { stack_chain context* } + { nursery zone } + { cards_offset cell } + { decks_offset cell } + { userenv cell[70] } ; -: vm-field-offset ( field -- offset ) "vm" offset-of ; \ No newline at end of file +: vm-field-offset ( field -- offset ) vm offset-of ; inline diff --git a/basis/vocabs/generated/authors.txt b/basis/vocabs/generated/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/generated/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/vocabs/generated/generated.factor b/basis/vocabs/generated/generated.factor new file mode 100644 index 0000000000..cb1f847ece --- /dev/null +++ b/basis/vocabs/generated/generated.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: compiler.units continuations fry kernel vocabs vocabs.parser ; +IN: vocabs.generated + +: generate-vocab ( vocab-name quot -- vocab ) + [ dup vocab [ ] ] dip '[ + [ + [ + [ _ with-current-vocab ] [ ] [ forget-vocab ] cleanup + ] with-compilation-unit + ] keep + ] ?if ; inline diff --git a/basis/vocabs/hierarchy/hierarchy-docs.factor b/basis/vocabs/hierarchy/hierarchy-docs.factor index 8eb39732c0..fee3fd30e0 100644 --- a/basis/vocabs/hierarchy/hierarchy-docs.factor +++ b/basis/vocabs/hierarchy/hierarchy-docs.factor @@ -5,20 +5,30 @@ ARTICLE: "vocabs.hierarchy" "Vocabulary hierarchy tools" "These tools operate on all vocabularies found in the current set of " { $link vocab-roots } ", loaded or not." $nl "Loading vocabulary hierarchies:" -{ $subsection load } -{ $subsection load-all } +{ $subsections + load + load-all +} "Getting all vocabularies from disk:" -{ $subsection all-vocabs } -{ $subsection all-vocabs-recursive } +{ $subsections + all-vocabs + all-vocabs-recursive +} "Getting all vocabularies from disk whose names which match a string prefix:" -{ $subsection child-vocabs } -{ $subsection child-vocabs-recursive } +{ $subsections + child-vocabs + child-vocabs-recursive +} "Words for modifying output:" -{ $subsection no-roots } -{ $subsection no-prefixes } +{ $subsections + no-roots + no-prefixes +} "Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:" -{ $subsection all-tags } -{ $subsection all-authors } ; +{ $subsections + all-tags + all-authors +} ; ABOUT: "vocabs.hierarchy" diff --git a/basis/vocabs/metadata/metadata-docs.factor b/basis/vocabs/metadata/metadata-docs.factor index 002f8534b4..66041e249c 100644 --- a/basis/vocabs/metadata/metadata-docs.factor +++ b/basis/vocabs/metadata/metadata-docs.factor @@ -3,18 +3,26 @@ IN: vocabs.metadata ARTICLE: "vocabs.metadata" "Vocabulary metadata" "Vocabulary summaries:" -{ $subsection vocab-summary } -{ $subsection set-vocab-summary } +{ $subsections + vocab-summary + set-vocab-summary +} "Vocabulary authors:" -{ $subsection vocab-authors } -{ $subsection set-vocab-authors } +{ $subsections + vocab-authors + set-vocab-authors +} "Vocabulary tags:" -{ $subsection vocab-tags } -{ $subsection set-vocab-tags } -{ $subsection add-vocab-tags } +{ $subsections + vocab-tags + set-vocab-tags + add-vocab-tags +} "Getting and setting arbitrary vocabulary metadata:" -{ $subsection vocab-file-contents } -{ $subsection set-vocab-file-contents } ; +{ $subsections + vocab-file-contents + set-vocab-file-contents +} ; ABOUT: "vocabs.metadata" diff --git a/basis/vocabs/prettyprint/prettyprint-tests.factor b/basis/vocabs/prettyprint/prettyprint-tests.factor index 9ad0aae59d..4da5280115 100644 --- a/basis/vocabs/prettyprint/prettyprint-tests.factor +++ b/basis/vocabs/prettyprint/prettyprint-tests.factor @@ -1,44 +1,44 @@ +USING: vocabs.prettyprint tools.test io.streams.string eval ; IN: vocabs.prettyprint.tests -USING: vocabs.prettyprint tools.test io.streams.string multiline eval ; : manifest-test-1 ( -- string ) - <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ; + """USING: kernel namespaces vocabs.parser vocabs.prettyprint ; - << manifest get pprint-manifest >> "> ; + << manifest get pprint-manifest >>""" ; [ -<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;"> +"""USING: kernel namespaces vocabs.parser vocabs.prettyprint ;""" ] [ [ manifest-test-1 eval( -- ) ] with-string-writer ] unit-test : manifest-test-2 ( -- string ) - <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ; + """USING: kernel namespaces vocabs.parser vocabs.prettyprint ; IN: vocabs.prettyprint.tests - << manifest get pprint-manifest >> "> ; + << manifest get pprint-manifest >>""" ; [ -<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ; -IN: vocabs.prettyprint.tests"> +"""USING: kernel namespaces vocabs.parser vocabs.prettyprint ; +IN: vocabs.prettyprint.tests""" ] [ [ manifest-test-2 eval( -- ) ] with-string-writer ] unit-test : manifest-test-3 ( -- string ) - <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ; + """USING: kernel namespaces vocabs.parser vocabs.prettyprint ; FROM: math => + - ; QUALIFIED: system QUALIFIED-WITH: assocs a EXCLUDE: parser => run-file ; IN: vocabs.prettyprint.tests - << manifest get pprint-manifest >> "> ; + << manifest get pprint-manifest >>""" ; [ -<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ; +"""USING: kernel namespaces vocabs.parser vocabs.prettyprint ; FROM: math => + - ; QUALIFIED: system QUALIFIED-WITH: assocs a EXCLUDE: parser => run-file ; -IN: vocabs.prettyprint.tests"> +IN: vocabs.prettyprint.tests""" ] -[ [ manifest-test-3 eval( -- ) ] with-string-writer ] unit-test \ No newline at end of file +[ [ manifest-test-3 eval( -- ) ] with-string-writer ] unit-test diff --git a/basis/vocabs/refresh/refresh-docs.factor b/basis/vocabs/refresh/refresh-docs.factor index 5652d2ac6a..b074a9e502 100644 --- a/basis/vocabs/refresh/refresh-docs.factor +++ b/basis/vocabs/refresh/refresh-docs.factor @@ -16,7 +16,9 @@ HELP: refresh-all ARTICLE: "vocabs.refresh" "Runtime code reloading" "Reloading source files changed on disk:" -{ $subsection refresh } -{ $subsection refresh-all } ; +{ $subsections + refresh + refresh-all +} ; ABOUT: "vocabs.refresh" diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor index 21f048a00f..fa478b03ed 100755 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -1,5 +1,5 @@ -USING: alien.syntax kernel math windows.types windows.kernel32 -math.bitwise classes.struct ; +USING: alien.c-types alien.syntax kernel math windows.types +windows.kernel32 math.bitwise classes.struct ; IN: windows.advapi32 LIBRARY: advapi32 @@ -222,15 +222,15 @@ C-ENUM: SE_WMIGUID_OBJECT SE_REGISTRY_WOW64_32KEY ; -TYPEDEF: TRUSTEE* PTRUSTEE - STRUCT: TRUSTEE - { pMultipleTrustee PTRUSTEE } + { pMultipleTrustee TRUSTEE* } { MultipleTrusteeOperation MULTIPLE_TRUSTEE_OPERATION } { TrusteeForm TRUSTEE_FORM } { TrusteeType TRUSTEE_TYPE } { ptstrName LPTSTR } ; +TYPEDEF: TRUSTEE* PTRUSTEE + STRUCT: EXPLICIT_ACCESS { grfAccessPermissions DWORD } { grfAccessMode ACCESS_MODE } diff --git a/basis/windows/com/com-tests.factor b/basis/windows/com/com-tests.factor index 289581a929..ae8ef62c16 100644 --- a/basis/windows/com/com-tests.factor +++ b/basis/windows/com/com-tests.factor @@ -37,13 +37,13 @@ TUPLE: test-implementation x ; C: <test-implementation> test-implementation { - { "IInherited" { + { IInherited { [ drop S_OK ] ! ISimple::returnOK [ drop E_FAIL ] ! ISimple::returnError [ x>> ] ! IInherited::getX [ >>x drop ] ! IInherited::setX } } - { "IUnrelated" { + { IUnrelated { [ swap x>> + ] ! IUnrelated::xPlus [ spin x>> * + ] ! IUnrelated::xMulAdd } } @@ -85,7 +85,7 @@ dup +test-wrapper+ set [ +guinea-pig-implementation+ get ISimple-iid com-query-interface dup com-release ] unit-test - "void*" heap-size +guinea-pig-implementation+ get <displaced-alien> + void* heap-size +guinea-pig-implementation+ get <displaced-alien> +guinea-pig-implementation+ get 2array [ +guinea-pig-implementation+ get IUnrelated-iid com-query-interface diff --git a/basis/windows/com/com.factor b/basis/windows/com/com.factor old mode 100644 new mode 100755 index e06f5b6071..9628b890fb --- a/basis/windows/com/com.factor +++ b/basis/windows/com/com.factor @@ -1,45 +1,51 @@ -USING: alien alien.c-types alien.destructors windows.com.syntax -windows.ole32 windows.types continuations kernel alien.syntax -libc destructors accessors alien.data ; -IN: windows.com - -LIBRARY: ole32 - -COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046} - HRESULT QueryInterface ( REFGUID iid, void** ppvObject ) - ULONG AddRef ( ) - ULONG Release ( ) ; - -COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046} - HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) - HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) - HRESULT QueryGetData ( FORMATETC* pFormatetc ) - HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut ) - HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease ) - HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc ) - HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection ) - HRESULT DUnadvise ( DWORD pdwConnection ) - HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ; - -COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046} - HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) - HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) - HRESULT DragLeave ( ) - HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ; - -: com-query-interface ( interface iid -- interface' ) - [ - "void*" malloc-object &free - [ IUnknown::QueryInterface ole32-error ] keep *void* - ] with-destructors ; - -: com-add-ref ( interface -- interface ) - [ IUnknown::AddRef drop ] keep ; inline - -: com-release ( interface -- ) - IUnknown::Release drop ; inline - -: with-com-interface ( interface quot -- ) - over [ com-release ] curry [ ] cleanup ; inline - -DESTRUCTOR: com-release +USING: alien alien.c-types alien.destructors windows.com.syntax +windows.ole32 windows.types continuations kernel alien.syntax +libc destructors accessors alien.data ; +IN: windows.com + +LIBRARY: ole32 + +COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046} + HRESULT QueryInterface ( REFGUID iid, void** ppvObject ) + ULONG AddRef ( ) + ULONG Release ( ) ; + +C-TYPE: IAdviseSink + +COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046} + HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) + HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) + HRESULT QueryGetData ( FORMATETC* pFormatetc ) + HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut ) + HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease ) + HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc ) + HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection ) + HRESULT DUnadvise ( DWORD pdwConnection ) + HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ; + +COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046} + HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) + HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) + HRESULT DragLeave ( ) + HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ; + +FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ; +FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ; +FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ; + +: com-query-interface ( interface iid -- interface' ) + [ + "void*" malloc-object &free + [ IUnknown::QueryInterface ole32-error ] keep *void* + ] with-destructors ; + +: com-add-ref ( interface -- interface ) + [ IUnknown::AddRef drop ] keep ; inline + +: com-release ( interface -- ) + IUnknown::Release drop ; inline + +: with-com-interface ( interface quot -- ) + over [ com-release ] curry [ ] cleanup ; inline + +DESTRUCTOR: com-release diff --git a/basis/windows/com/syntax/syntax-docs.factor b/basis/windows/com/syntax/syntax-docs.factor index 62a3c6eaa0..bbfbf39cd1 100644 --- a/basis/windows/com/syntax/syntax-docs.factor +++ b/basis/windows/com/syntax/syntax-docs.factor @@ -1,5 +1,4 @@ -USING: help.markup help.syntax io kernel math quotations -multiline ; +USING: help.markup help.syntax io kernel math quotations ; IN: windows.com.syntax HELP: GUID: @@ -7,14 +6,13 @@ HELP: GUID: { $description "\nCreate a COM globally-unique identifier (GUID) literal at parse time, and push it onto the data stack." } ; HELP: COM-INTERFACE: -{ $syntax <" -COM-INTERFACE: <interface> <parent> <iid> +{ $syntax """COM-INTERFACE: <interface> <parent> <iid> <function-1> ( <params1> ) <function-2> ( <params2> ) ... ; -"> } +""" } { $description "\nFor the interface " { $snippet "<interface>" } ", a word " { $snippet "<interface>-iid ( -- iid )" } " is defined to push the interface GUID (IID) onto the stack. Words of the form " { $snippet "<interface>::<function>" } " are also defined to invoke each method, as well as the methods inherited from " { $snippet "<parent>" } ". A " { $snippet "<parent>" } " of " { $snippet "f" } " indicates that the interface is a root interface. (Note that COM conventions demand that all interfaces at least inherit from " { $snippet "IUnknown" } ".)\n\nExample:" } -{ $code <" +{ $code """ COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046} HRESULT QueryInterface ( REFGUID iid, void** ppvObject ) ULONG AddRef ( ) @@ -27,4 +25,4 @@ COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd} int getX ( ) void setX ( int newX ) ; -"> } ; +""" } ; diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor index 3cf8b55e39..bbade332cc 100755 --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -1,8 +1,8 @@ -USING: alien alien.c-types alien.accessors effects kernel -windows.ole32 parser lexer splitting grouping sequences -namespaces assocs quotations generalizations accessors words -macros alien.syntax fry arrays layouts math classes.struct -windows.kernel32 ; +USING: alien alien.c-types alien.accessors alien.parser +effects kernel windows.ole32 parser lexer splitting grouping +sequences namespaces assocs quotations generalizations +accessors words macros alien.syntax fry arrays layouts math +classes.struct windows.kernel32 ; IN: windows.com.syntax <PRIVATE @@ -14,7 +14,7 @@ MACRO: com-invoke ( n return parameters -- ) "stdcall" alien-indirect ] ; -TUPLE: com-interface-definition name parent iid functions ; +TUPLE: com-interface-definition word parent iid functions ; C: <com-interface-definition> com-interface-definition TUPLE: com-function-definition name return parameters ; @@ -25,22 +25,25 @@ SYMBOL: +com-interface-definitions+ [ H{ } +com-interface-definitions+ set-global ] unless +ERROR: no-com-interface interface ; + : find-com-interface-definition ( name -- definition ) - dup "f" = [ drop f ] [ + [ dup +com-interface-definitions+ get-global at* - [ nip ] - [ " COM interface hasn't been defined" prepend throw ] - if - ] if ; + [ nip ] [ drop no-com-interface ] if + ] [ f ] if* ; : save-com-interface-definition ( definition -- ) - dup name>> +com-interface-definitions+ get-global set-at ; + dup word>> +com-interface-definitions+ get-global set-at ; : (parse-com-function) ( tokens -- definition ) [ second ] [ first ] - [ 3 tail [ CHAR: , swap remove ] map 2 group { "void*" "this" } prefix ] - tri + [ + 3 tail [ CHAR: , swap remove ] map + 2 group [ first2 normalize-c-arg 2array ] map + { void* "this" } prefix + ] tri <com-function-definition> ; : parse-com-functions ( -- functions ) @@ -48,10 +51,11 @@ unless [ (parse-com-function) ] map ; : (iid-word) ( definition -- word ) - name>> "-iid" append create-in ; + word>> name>> "-iid" append create-in ; : (function-word) ( function interface -- word ) - name>> "::" rot name>> 3append create-in ; + swap [ word>> name>> "::" ] [ name>> ] bi* + 3append create-in ; : family-tree ( definition -- definitions ) dup parent>> [ family-tree ] [ { } ] if* @@ -79,7 +83,7 @@ unless : define-words-for-com-interface ( definition -- ) [ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ] - [ name>> "com-interface" swap typedef ] + [ word>> void* swap typedef ] [ dup family-tree-functions [ (define-word-for-function) ] with each-index @@ -89,8 +93,8 @@ unless PRIVATE> SYNTAX: COM-INTERFACE: - scan - scan find-com-interface-definition + CREATE-C-TYPE + scan-object find-com-interface-definition scan string>guid parse-com-functions <com-interface-definition> diff --git a/basis/windows/com/wrapper/wrapper-docs.factor b/basis/windows/com/wrapper/wrapper-docs.factor index c863bb2762..6a6f6f2bb4 100644 --- a/basis/windows/com/wrapper/wrapper-docs.factor +++ b/basis/windows/com/wrapper/wrapper-docs.factor @@ -1,12 +1,12 @@ USING: help.markup help.syntax io kernel math quotations -multiline alien windows.com windows.com.syntax continuations +alien windows.com windows.com.syntax continuations destructors ; IN: windows.com.wrapper HELP: <com-wrapper> { $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } } { $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "<com-wrapper>" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper object and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" } -{ $code <" +{ $code """ COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} HRESULT returnOK ( ) HRESULT returnError ( ) ; @@ -30,8 +30,7 @@ COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} [ swap x>> + ] ! IUnrelated::xPlus [ spin x>> * + ] ! IUnrealted::xMulAdd } } -} <com-wrapper> -"> } ; +} <com-wrapper>""" } ; HELP: com-wrap { $values { "object" "The factor object to wrap" } { "wrapper" "A " { $link com-wrapper } " object" } { "wrapped-object" "A COM object referencing " { $snippet "object" } } } diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index e4f0ef0654..27672df833 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -52,13 +52,13 @@ unless swap GUID memory>struct _ case [ - "void*" heap-size * rot <displaced-alien> com-add-ref + void* heap-size * rot <displaced-alien> com-add-ref swap 0 set-alien-cell S_OK ] [ nip f swap 0 set-alien-cell E_NOINTERFACE ] if* ] ; : (make-add-ref) ( interfaces -- quot ) - length "void*" heap-size * '[ + length void* heap-size * '[ _ [ alien-unsigned-4 1 + dup ] [ set-alien-unsigned-4 ] @@ -66,7 +66,7 @@ unless ] ; : (make-release) ( interfaces -- quot ) - length "void*" heap-size * '[ + length void* heap-size * '[ _ [ drop ] [ alien-unsigned-4 1 - dup ] @@ -84,7 +84,7 @@ unless : (thunk) ( n -- quot ) dup 0 = [ drop [ ] ] - [ "void*" heap-size neg * '[ _ swap <displaced-alien> ] ] + [ void* heap-size neg * '[ _ swap <displaced-alien> ] ] if ; : (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s ) @@ -97,15 +97,15 @@ unless [ [ (( -- alien )) define-declared ] pick [ call ] dip ] with-compilation-unit ; -: (callback-word) ( function-name interface-name counter -- word ) - [ "::" rot 3append "-callback-" ] dip number>string 3append +: (callback-word) ( function-name interface counter -- word ) + [ name>> "::" rot 3append "-callback-" ] dip number>string 3append "windows.com.wrapper.callbacks" create ; : (finish-thunk) ( param-count thunk quot -- thunked-quot ) [ [ drop [ ] ] [ swap 1 - '[ _ _ ndip ] ] if-empty ] dip compose ; -: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words ) +: (make-interface-callbacks) ( interface quots iunknown-methods n -- words ) (thunk) (thunked-quots) swap [ find-com-interface-definition family-tree-functions ] keep (next-vtbl-counter) '[ @@ -128,8 +128,8 @@ unless curry map-index ; : (malloc-wrapped-object) ( wrapper -- wrapped-object ) - vtbls>> length "void*" heap-size * - [ "ulong" heap-size + malloc ] keep + vtbls>> length void* heap-size * + [ ulong heap-size + malloc ] keep [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ; : (callbacks>vtbl) ( callbacks -- vtbl ) diff --git a/basis/windows/dinput/dinput.factor b/basis/windows/dinput/dinput.factor index 598df9a389..70d9500a7b 100755 --- a/basis/windows/dinput/dinput.factor +++ b/basis/windows/dinput/dinput.factor @@ -1,6 +1,6 @@ USING: windows.kernel32 windows.ole32 windows.com windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces math -classes.struct ; +classes.struct windows.types ; IN: windows.dinput LIBRARY: dinput @@ -297,23 +297,23 @@ STRUCT: DIJOYSTATE2 TYPEDEF: DIJOYSTATE2* LPDIJOYSTATE2 TYPEDEF: DIJOYSTATE2* LPCDIJOYSTATE2 -STDCALL-CALLBACK: BOOL LPDIENUMDEVICESCALLBACKW ( +CALLBACK: BOOL LPDIENUMDEVICESCALLBACKW ( LPCDIDEVICEINSTANCEW lpddi, LPVOID pvRef ) ; -STDCALL-CALLBACK: BOOL LPDICONFIGUREDEVICESCALLBACK ( +CALLBACK: BOOL LPDICONFIGUREDEVICESCALLBACK ( IUnknown* lpDDSTarget, LPVOID pvRef ) ; -STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSCALLBACKW ( +CALLBACK: BOOL LPDIENUMEFFECTSCALLBACKW ( LPCDIEFFECTINFOW pdei, LPVOID pvRef ) ; -STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSINFILECALLBACK ( +CALLBACK: BOOL LPDIENUMEFFECTSINFILECALLBACK ( LPCDIFILEEFFECT lpDiFileEf, LPVOID pvRef ) ; -STDCALL-CALLBACK: BOOL LPDIENUMDEVICEOBJECTSCALLBACKW ( +CALLBACK: BOOL LPDIENUMDEVICEOBJECTSCALLBACKW ( LPCDIDEVICEOBJECTINSTANCEW lpddoi, LPVOID pvRef ) ; @@ -330,7 +330,7 @@ COM-INTERFACE: IDirectInputEffect IUnknown {E7E1F7C0-88D2-11D0-9AD0-00A0C9A06E35 HRESULT Unload ( ) HRESULT Escape ( LPDIEFFESCAPE pesc ) ; -STDCALL-CALLBACK: BOOL LPDIENUMCREATEDEFFECTOBJECTSCALLBACK ( +CALLBACK: BOOL LPDIENUMCREATEDEFFECTOBJECTSCALLBACK ( IDirectInputEffect* peff, LPVOID pvRef ) ; @@ -366,7 +366,7 @@ COM-INTERFACE: IDirectInputDevice8W IUnknown {54D41081-DC15-4833-A41B-748F73A381 HRESULT SetActionMap ( LPDIACTIONFORMATW lpdiActionFormat, LPCWSTR lpwszUserName, DWORD dwFlags ) HRESULT GetImageInfo ( LPDIDEVICEIMAGEINFOHEADERW lpdiDeviceImageInfoHeader ) ; -STDCALL-CALLBACK: BOOL LPDIENUMDEVICESBYSEMANTICSCBW ( +CALLBACK: BOOL LPDIENUMDEVICESBYSEMANTICSCBW ( LPCDIDEVICEINSTANCEW lpddi, IDirectInputDevice8W* lpdid, DWORD dwFlags, diff --git a/basis/windows/dwmapi/authors.txt b/basis/windows/dwmapi/authors.txt new file mode 100755 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/windows/dwmapi/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/windows/dwmapi/dwmapi.factor b/basis/windows/dwmapi/dwmapi.factor new file mode 100755 index 0000000000..998846ebc2 --- /dev/null +++ b/basis/windows/dwmapi/dwmapi.factor @@ -0,0 +1,37 @@ +! (c)2009 Joe Groff bsd license +USING: alien.c-types alien.data alien.libraries alien.syntax +classes.struct kernel math system-info.windows windows.types ; +IN: windows.dwmapi + +STRUCT: MARGINS + { cxLeftWidth int } + { cxRightWidth int } + { cyTopHeight int } + { cyBottomHeight int } ; + +STRUCT: DWM_BLURBEHIND + { dwFlags DWORD } + { fEnable BOOL } + { hRgnBlur HANDLE } + { fTransitionOnMaximized BOOL } ; + +: <MARGINS> ( l r t b -- MARGINS ) + MARGINS <struct-boa> ; inline + +: full-window-margins ( -- MARGINS ) + -1 -1 -1 -1 <MARGINS> ; inline + +<< "dwmapi" "dwmapi.dll" "stdcall" add-library >> + +LIBRARY: dwmapi + +FUNCTION: HRESULT DwmExtendFrameIntoClientArea ( HWND hWnd, MARGINS* pMarInset ) ; +FUNCTION: HRESULT DwmEnableBlurBehindWindow ( HWND hWnd, DWM_BLURBEHIND* pBlurBehind ) ; +FUNCTION: HRESULT DwmIsCompositionEnabled ( BOOL* pfEnabled ) ; + +CONSTANT: WM_DWMCOMPOSITIONCHANGED HEX: 31E + +: composition-enabled? ( -- ? ) + windows-major 6 >= + [ 0 <int> [ DwmIsCompositionEnabled drop ] keep *int c-bool> ] + [ f ] if ; diff --git a/basis/windows/dwmapi/summary.txt b/basis/windows/dwmapi/summary.txt new file mode 100755 index 0000000000..9aa451d350 --- /dev/null +++ b/basis/windows/dwmapi/summary.txt @@ -0,0 +1 @@ +Windows Vista Desktop Window Manager API functions diff --git a/basis/windows/dwmapi/tags.txt b/basis/windows/dwmapi/tags.txt new file mode 100755 index 0000000000..43bc035447 --- /dev/null +++ b/basis/windows/dwmapi/tags.txt @@ -0,0 +1,2 @@ +windows +unportable diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 5187c3f660..43307cb6ba 100755 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax alien.destructors kernel windows.types -math.bitwise ; +USING: alien alien.c-types alien.syntax alien.destructors +kernel windows.types math.bitwise ; IN: windows.gdi32 CONSTANT: BI_RGB 0 diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 075b0218b3..70c104e2df 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax kernel windows.types multiline -classes.struct ; +USING: alien alien.c-types alien.syntax kernel windows.types +multiline classes.struct ; IN: windows.kernel32 CONSTANT: MAX_PATH 260 @@ -543,7 +543,7 @@ STRUCT: DCB TYPEDEF: DCB* PDCB TYPEDEF: DCB* LPDCB -STRUCT: COMM_CONFIG +STRUCT: COMMCONFIG { dwSize DWORD } { wVersion WORD } { wReserved WORD } @@ -704,7 +704,7 @@ STRUCT: WIN32_FIND_DATA { nFileSizeLow DWORD } { dwReserved0 DWORD } { dwReserved1 DWORD } - { cFileName { "TCHAR" MAX_PATH } } + { cFileName { TCHAR MAX_PATH } } { cAlternateFileName TCHAR[14] } ; TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor index 3bc7f45960..6e90cae89a 100755 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -111,10 +111,6 @@ CONSTANT: COINIT_SPEED_OVER_MEMORY 8 FUNCTION: HRESULT OleInitialize ( void* reserved ) ; FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ; -FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ; -FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ; -FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ; - : succeeded? ( hresult -- ? ) 0 HEX: 7FFFFFFF between? ; diff --git a/basis/windows/shell32/shell32.factor b/basis/windows/shell32/shell32.factor old mode 100644 new mode 100755 index 6b4e0d797e..bede62c813 --- a/basis/windows/shell32/shell32.factor +++ b/basis/windows/shell32/shell32.factor @@ -3,8 +3,8 @@ USING: alien alien.c-types alien.strings alien.syntax classes.struct combinators io.encodings.utf16n io.files io.pathnames kernel windows.errors windows.com -windows.com.syntax windows.user32 windows.ole32 windows -specialized-arrays ; +windows.com.syntax windows.types windows.user32 +windows.ole32 windows specialized-arrays ; SPECIALIZED-ARRAY: ushort IN: windows.shell32 diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 6275f2d3c9..ea5daba688 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -61,6 +61,7 @@ TYPEDEF: ulong ULONG_PTR TYPEDEF: int INT32 TYPEDEF: uint UINT32 TYPEDEF: uint DWORD32 +TYPEDEF: long LONG32 TYPEDEF: ulong ULONG32 TYPEDEF: ulonglong ULONG64 TYPEDEF: long* POINTER_32 @@ -75,6 +76,8 @@ TYPEDEF: longlong LARGE_INTEGER TYPEDEF: ulonglong ULARGE_INTEGER TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER +TYPEDEF: size_t SIZE_T +TYPEDEF: ptrdiff_t SSIZE_T TYPEDEF: wchar_t* LPCSTR TYPEDEF: wchar_t* LPWSTR @@ -201,15 +204,6 @@ TYPEDEF: LONG_PTR SSIZE_T TYPEDEF: LONGLONG USN TYPEDEF: UINT_PTR WPARAM -TYPEDEF: RECT* LPRECT -TYPEDEF: void* PWNDCLASS -TYPEDEF: void* PWNDCLASSEX -TYPEDEF: void* LPWNDCLASS -TYPEDEF: void* LPWNDCLASSEX -TYPEDEF: void* MSGBOXPARAMSA -TYPEDEF: void* MSGBOXPARAMSW -TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE - TYPEDEF: size_t socklen_t TYPEDEF: void* WNDPROC @@ -343,6 +337,14 @@ TYPEDEF: PFD* LPPFD TYPEDEF: HANDLE HGLRC TYPEDEF: HANDLE HRGN +TYPEDEF: void* PWNDCLASS +TYPEDEF: void* PWNDCLASSEX +TYPEDEF: void* LPWNDCLASS +TYPEDEF: void* LPWNDCLASSEX +TYPEDEF: void* MSGBOXPARAMSA +TYPEDEF: void* MSGBOXPARAMSW +TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE + STRUCT: LVITEM { mask uint } { iItem int } @@ -378,9 +380,15 @@ TYPEDEF: DWORD* LPCOLORREF : RGB ( r g b -- COLORREF ) { 16 8 0 } bitfield ; inline +: >RGB< ( COLORREF -- r g b ) + [ HEX: ff bitand ] + [ -8 shift HEX: ff bitand ] + [ -16 shift HEX: ff bitand ] tri ; : color>RGB ( color -- COLORREF ) >rgba-components drop [ 255 * >integer ] tri@ RGB ; +: RGB>color ( COLORREF -- color ) + >RGB< [ 1/255. * >float ] tri@ 1.0 <rgba> ; STRUCT: TEXTMETRICW { tmHeight LONG } diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 4c39385ce5..a2461395d9 100755 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax parser namespaces kernel math -windows.types generalizations math.bitwise classes.struct -literals ; +USING: alien alien.c-types alien.syntax parser namespaces +kernel math windows.types generalizations math.bitwise +classes.struct literals windows.kernel32 ; IN: windows.user32 ! HKL for ActivateKeyboardLayout @@ -560,7 +560,7 @@ STRUCT: MONITORINFOEX { rcMonitor RECT } { rcWork RECT } { dwFlags DWORD } - { szDevice { "TCHAR" $ CCHDEVICENAME } } ; + { szDevice { TCHAR CCHDEVICENAME } } ; TYPEDEF: MONITORINFOEX* LPMONITORINFOEX TYPEDEF: MONITORINFOEX* LPMONITORINFO @@ -998,7 +998,7 @@ FUNCTION: int GetPriorityClipboardFormat ( UINT* paFormatPriorityList, int cForm ! FUNCTION: GetScrollRange ! FUNCTION: GetShellWindow ! FUNCTION: GetSubMenu -! FUNCTION: GetSysColor +FUNCTION: COLORREF GetSysColor ( int nIndex ) ; FUNCTION: HBRUSH GetSysColorBrush ( int nIndex ) ; FUNCTION: HMENU GetSystemMenu ( HWND hWnd, BOOL bRevert ) ; ! FUNCTION: GetSystemMetrics diff --git a/basis/windows/usp10/usp10.factor b/basis/windows/usp10/usp10.factor index eb57a46925..57702d8780 100755 --- a/basis/windows/usp10/usp10.factor +++ b/basis/windows/usp10/usp10.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax alien.destructors classes.struct ; +USING: alien.c-types alien.syntax alien.destructors classes.struct +windows.types ; IN: windows.usp10 LIBRARY: usp10 @@ -56,6 +57,9 @@ SCRIPT_JUSTIFFY_RESERVED4 ; STRUCT: SCRIPT_VISATTR { flags WORD } ; +TYPEDEF: void* SCRIPT_CACHE* +C-TYPE: ABC + FUNCTION: HRESULT ScriptShape ( HDC hdc, SCRIPT_CACHE* psc, diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index dc751e64a6..7bd86c8e47 100755 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -105,6 +105,8 @@ CONSTANT: SD_BOTH 2 CONSTANT: SOL_SOCKET HEX: ffff +C-TYPE: sockaddr + STRUCT: sockaddr-in { family short } { port ushort } @@ -139,13 +141,15 @@ STRUCT: timeval { sec long } { usec long } ; +TYPEDEF: void* fd_set* + LIBRARY: winsock FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ; FUNCTION: ushort htons ( ushort n ) ; FUNCTION: ushort ntohs ( ushort n ) ; -FUNCTION: int bind ( void* socket, sockaddr_in* sockaddr, int len ) ; +FUNCTION: int bind ( void* socket, sockaddr-in* sockaddr, int len ) ; FUNCTION: int listen ( void* socket, int backlog ) ; FUNCTION: char* inet_ntoa ( int in-addr ) ; FUNCTION: int getaddrinfo ( char* nodename, @@ -158,15 +162,15 @@ FUNCTION: void freeaddrinfo ( addrinfo* ai ) ; FUNCTION: hostent* gethostbyname ( char* name ) ; FUNCTION: int gethostname ( char* name, int len ) ; -FUNCTION: int connect ( void* socket, sockaddr_in* sockaddr, int addrlen ) ; +FUNCTION: int connect ( void* socket, sockaddr-in* sockaddr, int addrlen ) ; FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ; FUNCTION: int closesocket ( SOCKET s ) ; FUNCTION: int shutdown ( SOCKET s, int how ) ; FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ; FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ; -FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ; -FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ; +FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen ) ; +FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen ) ; TYPEDEF: uint SERVICETYPE TYPEDEF: OVERLAPPED WSAOVERLAPPED diff --git a/basis/wrap/strings/strings-docs.factor b/basis/wrap/strings/strings-docs.factor index e20780d3ac..c8c08d3db1 100644 --- a/basis/wrap/strings/strings-docs.factor +++ b/basis/wrap/strings/strings-docs.factor @@ -7,9 +7,11 @@ ABOUT: "wrap.strings" ARTICLE: "wrap.strings" "String word wrapping" "The " { $vocab-link "wrap.strings" } " vocabulary implements word wrapping for simple strings, assumed to be in monospace font." -{ $subsection wrap-lines } -{ $subsection wrap-string } -{ $subsection wrap-indented-string } ; +{ $subsections + wrap-lines + wrap-string + wrap-indented-string +} ; HELP: wrap-lines { $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } } diff --git a/basis/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor index cf01499bcb..b9abedc4c4 100644 --- a/basis/wrap/strings/strings-tests.factor +++ b/basis/wrap/strings/strings-tests.factor @@ -1,29 +1,29 @@ ! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: wrap.strings tools.test multiline ; +USING: wrap.strings tools.test ; IN: wrap.strings.tests [ - <" This is a + """This is a long piece of text that we wish to -word wrap."> +word wrap.""" ] [ - <" This is a long piece of text that we wish to word wrap."> 10 + """This is a long piece of text that we wish to word wrap.""" 10 wrap-string ] unit-test [ - <" This is a + """ This is a long piece of text that we wish to - word wrap."> + word wrap.""" ] [ - <" This is a long piece of text that we wish to word wrap."> 12 + """This is a long piece of text that we wish to word wrap.""" 12 " " wrap-indented-string ] unit-test diff --git a/basis/wrap/words/words-docs.factor b/basis/wrap/words/words-docs.factor index 422aea0ac3..66d0a30fba 100644 --- a/basis/wrap/words/words-docs.factor +++ b/basis/wrap/words/words-docs.factor @@ -7,9 +7,11 @@ ABOUT: "wrap.words" ARTICLE: "wrap.words" "Word object wrapping" "The " { $vocab-link "wrap.words" } " vocabulary implements word wrapping on abstract word objects, which have certain properties making it a more suitable input representation than strings." -{ $subsection wrap-words } -{ $subsection word } -{ $subsection <word> } ; +{ $subsections + wrap-words + word + <word> +} ; HELP: wrap-words { $values { "words" { "a sequence of " { $instance word } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } } diff --git a/basis/x11/constants/constants.factor b/basis/x11/constants/constants.factor index 1fe825d6af..763cddaaf1 100644 --- a/basis/x11/constants/constants.factor +++ b/basis/x11/constants/constants.factor @@ -3,7 +3,7 @@ ! Based on X.h -USING: alien alien.syntax math x11.xlib ; +USING: alien alien.c-types alien.syntax math x11.xlib ; IN: x11.constants TYPEDEF: ulong Mask @@ -406,4 +406,4 @@ CONSTANT: MSBFirst 1 ! * EXTENDED WINDOW MANAGER HINTS ! ***************************************************************** -C-ENUM: _NET_WM_STATE_REMOVE _NET_WM_STATE_ADD _NET_WM_STATE_TOGGLE ; \ No newline at end of file +C-ENUM: _NET_WM_STATE_REMOVE _NET_WM_STATE_ADD _NET_WM_STATE_TOGGLE ; diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 0cd7704cf8..a6097c9dad 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -31,12 +31,12 @@ TYPEDEF: XID KeySym TYPEDEF: ulong Atom TYPEDEF: char* XPointer -TYPEDEF: void* Screen* +C-TYPE: Screen TYPEDEF: void* GC -TYPEDEF: void* Visual* -TYPEDEF: void* XExtData* -TYPEDEF: void* XFontProp* -TYPEDEF: void* XComposeStatus* +C-TYPE: Visual +C-TYPE: XExtData +C-TYPE: XFontProp +C-TYPE: XComposeStatus TYPEDEF: void* XIM TYPEDEF: void* XIC @@ -47,9 +47,6 @@ TYPEDEF: int Bool TYPEDEF: ulong VisualID TYPEDEF: ulong Time -TYPEDEF: void* Window** -TYPEDEF: void* Atom** - ALIAS: <XID> <ulong> ALIAS: <Window> <XID> ALIAS: <Drawable> <XID> @@ -410,10 +407,6 @@ STRUCT: XCharStruct { descent short } { attributes ushort } ; -X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ; -X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ; -X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ; - STRUCT: XFontStruct { ext_data XExtData* } { fid Font } @@ -432,6 +425,10 @@ STRUCT: XFontStruct { ascent int } { descent int } ; +X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ; +X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ; +X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ; + X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ; ! 8.6 - Drawing Text diff --git a/basis/xml-rpc/xml-rpc-docs.factor b/basis/xml-rpc/xml-rpc-docs.factor index d812e8503b..113fc00407 100644 --- a/basis/xml-rpc/xml-rpc-docs.factor +++ b/basis/xml-rpc/xml-rpc-docs.factor @@ -53,20 +53,26 @@ HELP: post-rpc { $description "posts an XML-RPC document to the specified URL, receives the response and parses it as XML-RPC, returning the tuple" } ; ARTICLE: { "xml-rpc" "intro" } "XML-RPC" - "This is the XML-RPC library. XML-RPC is used instead of SOAP because it is far simpler and easier to use for most tasks. The library was implemented by Daniel Ehrenberg." - $nl - "The most important words that this library implements are:" - { $subsection send-rpc } - { $subsection receive-rpc } - "data types in XML-RPC" - { $subsection base64 } - { $subsection rpc-method } - { $subsection rpc-response } - { $subsection rpc-fault } - "the constructors for these are" - { $subsection <base64> } - { $subsection <rpc-method> } - { $subsection <rpc-response> } - { $subsection <rpc-fault> } - "other words include" - { $subsection post-rpc } ; +"This is the XML-RPC library. XML-RPC is used instead of SOAP because it is far simpler and easier to use for most tasks. The library was implemented by Daniel Ehrenberg." +$nl +"The most important words that this library implements are:" +{ $subsections + send-rpc + receive-rpc +} +"data types in XML-RPC" +{ $subsections + base64 + rpc-method + rpc-response + rpc-fault +} +"the constructors for these are" +{ $subsections + <base64> + <rpc-method> + <rpc-response> + <rpc-fault> +} +"other words include" +{ $subsections post-rpc } ; diff --git a/basis/xml/data/data-docs.factor b/basis/xml/data/data-docs.factor index 8c837fdf19..feb035d37a 100644 --- a/basis/xml/data/data-docs.factor +++ b/basis/xml/data/data-docs.factor @@ -5,52 +5,60 @@ ABOUT: "xml.data" ARTICLE: "xml.data" "XML data types" "The " { $vocab-link "xml.data" } " vocabulary defines a simple document object model for XML. Everything is simply a tuple and can be manipulated as such." -{ $subsection { "xml.data" "classes" } } -{ $subsection { "xml.data" "constructors" } } +{ $subsections + { "xml.data" "classes" } + { "xml.data" "constructors" } +} "Simple words for manipulating names:" - { $subsection names-match? } - { $subsection assure-name } +{ $subsections + names-match? + assure-name +} "For high-level tools for manipulating XML, see " { $vocab-link "xml.traversal" } ; ARTICLE: { "xml.data" "classes" } "XML data classes" - "XML documents and chunks are made of the following classes:" - { $subsection xml } - { $subsection xml-chunk } - { $subsection tag } - { $subsection name } - { $subsection contained-tag } - { $subsection open-tag } - { $subsection prolog } - { $subsection comment } - { $subsection instruction } - { $subsection unescaped } - { $subsection element-decl } - { $subsection attlist-decl } - { $subsection entity-decl } - { $subsection system-id } - { $subsection public-id } - { $subsection doctype-decl } - { $subsection notation-decl } ; +"XML documents and chunks are made of the following classes:" +{ $subsections + xml + xml-chunk + tag + name + contained-tag + open-tag + prolog + comment + instruction + unescaped + element-decl + attlist-decl + entity-decl + system-id + public-id + doctype-decl + notation-decl +} ; ARTICLE: { "xml.data" "constructors" } "XML data constructors" - "These data types are constructed with:" - { $subsection <xml> } - { $subsection <xml-chunk> } - { $subsection <tag> } - { $subsection <name> } - { $subsection <contained-tag> } - { $subsection <prolog> } - { $subsection <comment> } - { $subsection <instruction> } - { $subsection <unescaped> } - { $subsection <simple-name> } - { $subsection <element-decl> } - { $subsection <attlist-decl> } - { $subsection <entity-decl> } - { $subsection <system-id> } - { $subsection <public-id> } - { $subsection <doctype-decl> } - { $subsection <notation-decl> } ; +"These data types are constructed with:" +{ $subsections + <xml> + <xml-chunk> + <tag> + <name> + <contained-tag> + <prolog> + <comment> + <instruction> + <unescaped> + <simple-name> + <element-decl> + <attlist-decl> + <entity-decl> + <system-id> + <public-id> + <doctype-decl> + <notation-decl> +} ; HELP: tag { $class-description "Tuple representing an XML tag, delegating to a " { $link diff --git a/basis/xml/entities/entities-docs.factor b/basis/xml/entities/entities-docs.factor index 158b83d9a8..13cc51bbf2 100644 --- a/basis/xml/entities/entities-docs.factor +++ b/basis/xml/entities/entities-docs.factor @@ -7,8 +7,10 @@ ABOUT: "xml.entities" ARTICLE: "xml.entities" "XML entities" "When XML is parsed, entities like &foo; are replaced with the characters they represent. A few entities like & and < are defined by default, but more are available, and the set of entities can be customized. Below are some words involved in XML entities, defined in the vocabulary 'entities':" - { $subsection entities } - { $subsection with-entities } +{ $subsections + entities + with-entities +} "For entities used in HTML/XHTML, see " { $vocab-link "xml.entities.html" } ; HELP: entities diff --git a/basis/xml/entities/html/html-docs.factor b/basis/xml/entities/html/html-docs.factor index f436944954..7ff83d9729 100644 --- a/basis/xml/entities/html/html-docs.factor +++ b/basis/xml/entities/html/html-docs.factor @@ -5,8 +5,10 @@ IN: xml.entities.html ARTICLE: "xml.entities.html" "HTML entities" { $vocab-link "xml.entities.html" } " defines words for using entities defined in HTML/XHTML." -{ $subsection html-entities } -{ $subsection with-html-entities } ; +{ $subsections + html-entities + with-html-entities +} ; HELP: html-entities { $description "A hash table from HTML entity names to their character values." } diff --git a/basis/xml/errors/errors-docs.factor b/basis/xml/errors/errors-docs.factor index 01a943eab7..3e6f43e8f9 100644 --- a/basis/xml/errors/errors-docs.factor +++ b/basis/xml/errors/errors-docs.factor @@ -92,29 +92,31 @@ HELP: xml-error ARTICLE: "xml.errors" "XML parsing errors" "The " { $vocab-link "xml.errors" } " vocabulary provides a rich and highly inspectable set of parsing errors. All XML errors are described by the union class " { $link xml-error } "." - { $subsection multitags } - { $subsection notags } - { $subsection extra-attrs } - { $subsection nonexist-ns } - { $subsection not-yes/no } - { $subsection unclosed } - { $subsection mismatched } - { $subsection expected } - { $subsection no-entity } - { $subsection pre/post-content } - { $subsection unclosed-quote } - { $subsection bad-name } - { $subsection quoteless-attr } - { $subsection disallowed-char } - { $subsection missing-close } - { $subsection unexpected-end } - { $subsection duplicate-attr } - { $subsection bad-cdata } - { $subsection text-w/]]> } - { $subsection attr-w/< } - { $subsection misplaced-directive } - "Additionally, most of these errors are a kind of " { $link xml-error-at } " which provides more information about where the error occurred." - $nl - "Note that, in parsing an XML document, only the first error is reported." ; +{ $subsections + multitags + notags + extra-attrs + nonexist-ns + not-yes/no + unclosed + mismatched + expected + no-entity + pre/post-content + unclosed-quote + bad-name + quoteless-attr + disallowed-char + missing-close + unexpected-end + duplicate-attr + bad-cdata + text-w/]]> + attr-w/< + misplaced-directive +} +"Additionally, most of these errors are a kind of " { $link xml-error-at } " which provides more information about where the error occurred." +$nl +"Note that, in parsing an XML document, only the first error is reported." ; ABOUT: "xml.errors" diff --git a/basis/xml/syntax/syntax-docs.factor b/basis/xml/syntax/syntax-docs.factor index 0f04f1b7b2..9e0c50a37d 100644 --- a/basis/xml/syntax/syntax-docs.factor +++ b/basis/xml/syntax/syntax-docs.factor @@ -1,21 +1,23 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax xml.data present multiline ; +USING: help.markup help.syntax xml.data present ; IN: xml.syntax ABOUT: "xml.syntax" ARTICLE: "xml.syntax" "Syntax extensions for XML" "The " { $link "xml.syntax" } " vocabulary defines a number of new parsing words forXML processing." -{ $subsection { "xml.syntax" "tags" } } -{ $subsection { "xml.syntax" "literals" } } -{ $subsection POSTPONE: XML-NS: } ; +{ $subsections + { "xml.syntax" "tags" } + { "xml.syntax" "literals" } + POSTPONE: XML-NS: +} ; ARTICLE: { "xml.syntax" "tags" } "Dispatch on XML tag names" "There is a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use" -{ $subsection POSTPONE: TAGS: } +{ $subsections POSTPONE: TAGS: } "and to define a new 'method' for this word, use" -{ $subsection POSTPONE: TAG: } ; +{ $subsections POSTPONE: TAG: } ; HELP: TAGS: { $syntax "TAGS: word" } @@ -32,10 +34,12 @@ HELP: TAG: ARTICLE: { "xml.syntax" "literals" } "XML literals" "The following words provide syntax for XML literals:" -{ $subsection POSTPONE: <XML } -{ $subsection POSTPONE: [XML } +{ $subsections + POSTPONE: <XML + POSTPONE: [XML +} "These can be used for creating an XML literal, which can be used with variables or a fry-like syntax to interpolate data into XML." -{ $subsection { "xml.syntax" "interpolation" } } ; +{ $subsections { "xml.syntax" "interpolation" } } ; HELP: <XML { $syntax "<XML <?xml version=\"1.0\"?><document>...</document> XML>" } @@ -50,11 +54,12 @@ ARTICLE: { "xml.syntax" "interpolation" } "XML interpolation syntax" $nl "These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:" { $example -{" USING: splitting xml.writer xml.syntax ; +"""USING: splitting xml.writer xml.syntax ; "one two three" " " split [ [XML <item><-></item> XML] ] map -<XML <doc><-></doc> XML> pprint-xml"} -{" <?xml version="1.0" encoding="UTF-8"?> +<XML <doc><-></doc> XML> pprint-xml""" + +"""<?xml version="1.0" encoding="UTF-8"?> <doc> <item> one @@ -65,16 +70,16 @@ $nl <item> three </item> -</doc>"} } +</doc>""" } "Here is an example of the locals version:" { $example -{" USING: locals urls xml.syntax xml.writer ; +"""USING: locals urls xml.syntax xml.writer ; [let | number [ 3 ] false [ f ] url [ URL" http://factorcode.org/" ] string [ "hello" ] - word [ \ drop ] | + word [ \\ drop ] | <XML <x number=<-number-> @@ -82,11 +87,13 @@ $nl url=<-url-> string=<-string-> word=<-word-> /> - XML> pprint-xml ] "} -{" <?xml version="1.0" encoding="UTF-8"?> -<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} } + XML> pprint-xml +]""" + +"""<?xml version="1.0" encoding="UTF-8"?> +<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>""" } "XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:" -{ $example {" USING: xml.syntax inverse ; +{ $example """USING: xml.syntax inverse ; : dispatch ( xml -- string ) { { [ [XML <a><-></a> XML] ] [ "a" prepend ] } @@ -94,7 +101,8 @@ $nl { [ [XML <b val='yes'/> XML] ] [ "yes" ] } { [ [XML <b val=<->/> XML] ] [ "no" prepend ] } } switch ; -[XML <a>pple</a> XML] dispatch write "} "apple" } ; +[XML <a>pple</a> XML] dispatch write""" +"apple" } ; HELP: XML-NS: { $syntax "XML-NS: name http://url" } diff --git a/basis/xml/syntax/syntax-tests.factor b/basis/xml/syntax/syntax-tests.factor index 06ba2028a6..5c1669adb1 100644 --- a/basis/xml/syntax/syntax-tests.factor +++ b/basis/xml/syntax/syntax-tests.factor @@ -47,13 +47,13 @@ XML-NS: foo http://blah.com [ extract-variables ] tri ] unit-test -[ {" <?xml version="1.0" encoding="UTF-8"?> +[ """<?xml version="1.0" encoding="UTF-8"?> <x> one <b val="two"/> y <foo/> -</x>"} ] [ +</x>""" ] [ [let* | a [ "one" ] c [ "two" ] x [ "y" ] d [ [XML <-x-> <foo/> XML] ] | <XML @@ -62,7 +62,7 @@ XML-NS: foo http://blah.com ] ] unit-test -[ {" <?xml version="1.0" encoding="UTF-8"?> +[ """<?xml version="1.0" encoding="UTF-8"?> <doc> <item> one @@ -73,14 +73,14 @@ XML-NS: foo http://blah.com <item> three </item> -</doc>"} ] [ +</doc>""" ] [ "one two three" " " split [ [XML <item><-></item> XML] ] map <XML <doc><-></doc> XML> pprint-xml>string ] unit-test -[ {" <?xml version="1.0" encoding="UTF-8"?> -<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ] +[ """<?xml version="1.0" encoding="UTF-8"?> +<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>""" ] [ 3 f "http://factorcode.org/" "hello" \ drop <XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML> pprint-xml>string ] unit-test diff --git a/basis/xml/traversal/traversal-docs.factor b/basis/xml/traversal/traversal-docs.factor index 9f26774647..bb7ce7ce31 100644 --- a/basis/xml/traversal/traversal-docs.factor +++ b/basis/xml/traversal/traversal-docs.factor @@ -1,37 +1,41 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax xml.data sequences strings multiline ; +USING: help.markup help.syntax xml.data sequences strings ; IN: xml.traversal ABOUT: "xml.traversal" ARTICLE: "xml.traversal" "Utilities for traversing XML" "The " { $vocab-link "xml.traversal" } " vocabulary provides utilities for traversing an XML DOM tree and viewing the contents of a single tag. The following words are defined:" - $nl - { $subsection { "xml.traversal" "intro" } } - { $subsection tag-named } - { $subsection tags-named } - { $subsection deep-tag-named } - { $subsection deep-tags-named } - { $subsection get-id } - "To get at the contents of a single tag, use" - { $subsection children>string } - { $subsection children-tags } - { $subsection first-child-tag } - { $subsection assert-tag } ; +$nl +{ $subsections + { "xml.traversal" "intro" } + tag-named + tags-named + deep-tag-named + deep-tags-named + get-id +} +"To get at the contents of a single tag, use" +{ $subsections + children>string + children-tags + first-child-tag + assert-tag +} ; ARTICLE: { "xml.traversal" "intro" } "An example of XML processing" "To illustrate how to use the XML library, we develop a simple Atom parser in Factor. Atom is an XML-based syndication format, like RSS. To see the full version of what we develop here, look at " { $snippet "basis/syndication" } " at the " { $snippet "atom1.0" } " word. First, we want to load a file and get a DOM tree for it." -{ $code <" "file.xml" file>xml "> } +{ $code """"file.xml" file>xml""" } "No encoding descriptor is needed, because XML files contain sufficient information to auto-detect the encoding. Next, we want to extract information from the tree. To get the title, we can use the following:" -{ $code <" "title" tag-named children>string "> } +{ $code """"title" tag-named children>string""" } "The " { $link tag-named } " word finds the first tag named " { $snippet "title" } " in the top level (just under the main tag). Then, with a tag on the stack, its children are asserted to be a string, and the string is returned." $nl "For a slightly more complicated example, we can look at how entries are parsed. To get a sequence of tags with the name " { $snippet "entry" } ":" -{ $code <" "entry" tags-named "> } +{ $code """"entry" tags-named""" } "Imagine that, for each of these, we want to get the URL of the entry. In Atom, the URLs are in a " { $snippet "link" } " tag which is contained in the " { $snippet "entry" } " tag. There are multiple " { $snippet "link" } " tags, but one of them contains the attribute " { $snippet "rel=alternate" } ", and the " { $snippet "href" } " attribute has the URL. So, given an element of the sequence produced in the above quotation, we run the code:" -{ $code <" "link" tags-named [ "rel" attr "alternate" = ] find nip "> } +{ $code """"link" tags-named [ "rel" attr "alternate" = ] find nip """ } "to get the link tag on the stack, and" -{ $code <" "href" attr >url "> } +{ $code """"href" attr >url """ } "to extract the URL from it." ; HELP: deep-tag-named diff --git a/basis/xml/writer/writer-docs.factor b/basis/xml/writer/writer-docs.factor index 9971abcdf1..17d9880bb3 100644 --- a/basis/xml/writer/writer-docs.factor +++ b/basis/xml/writer/writer-docs.factor @@ -6,16 +6,22 @@ IN: xml.writer ABOUT: "xml.writer" ARTICLE: "xml.writer" "Writing XML" - "These words are used to print XML preserving whitespace in text nodes" - { $subsection write-xml } - { $subsection xml>string } - "These words are used to prettyprint XML" - { $subsection pprint-xml>string } - { $subsection pprint-xml } - "Certain variables can be changed to mainpulate prettyprinting" - { $subsection sensitive-tags } - { $subsection indenter } - "All of these words operate on arbitrary pieces of XML: they can take, as in put, XML documents, comments, tags, strings (text nodes), XML chunks, etc." ; +"These words are used to print XML preserving whitespace in text nodes" +{ $subsections + write-xml + xml>string +} +"These words are used to prettyprint XML" +{ $subsections + pprint-xml>string + pprint-xml +} +"Certain variables can be changed to mainpulate prettyprinting" +{ $subsections + sensitive-tags + indenter +} +"All of these words operate on arbitrary pieces of XML: they can take, as in put, XML documents, comments, tags, strings (text nodes), XML chunks, etc." ; HELP: xml>string { $values { "xml" "an XML document" } { "string" "a string" } } @@ -41,18 +47,19 @@ HELP: pprint-xml HELP: indenter { $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" } -{ $example {" USING: xml.syntax xml.writer namespaces ; -[XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable "} {" +{ $example """USING: xml.syntax xml.writer namespaces ; +[XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable """ """ <foo> %%%%bar -</foo>"} } ; +</foo>""" } ; HELP: sensitive-tags { $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" } -{ $example {" USING: xml.syntax xml.writer namespaces ; +{ $example """USING: xml.syntax xml.writer namespaces ; [XML <html> <head> <title> something

From: Guillaume Nargeot Date: Mon, 12 Oct 2009 08:08:50 +0000 (+0900) Subject: merge project-euler.factor X-Git-Tag: 0.97~5272^2^2~2 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=f97ede3d91eb0348fcec880ee9b69ff37e441209;hp=6f87a9c4e42f3f34f351f291fa4b0e926abc2e35 merge project-euler.factor --- diff --git a/Makefile b/Makefile index 10efe34d34..f9eb353a34 100755 --- a/Makefile +++ b/Makefile @@ -31,6 +31,7 @@ ifdef CONFIG endif DLL_OBJS = $(PLAF_DLL_OBJS) \ + vm/aging_collector.o \ vm/alien.o \ vm/arrays.o \ vm/bignum.o \ @@ -38,30 +39,33 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/byte_arrays.o \ vm/callstack.o \ vm/code_block.o \ - vm/code_gc.o \ vm/code_heap.o \ vm/contexts.o \ - vm/data_gc.o \ vm/data_heap.o \ vm/debug.o \ vm/dispatch.o \ vm/errors.o \ vm/factor.o \ + vm/full_collector.o \ + vm/gc.o \ + vm/heap.o \ vm/image.o \ vm/inline_cache.o \ vm/io.o \ vm/jit.o \ - vm/local_roots.o \ vm/math.o \ + vm/nursery_collector.o \ + vm/old_space.o \ vm/primitives.o \ vm/profiler.o \ vm/quotations.o \ vm/run.o \ vm/strings.o \ + vm/to_tenured_collector.o \ vm/tuples.o \ vm/utilities.o \ - vm/words.o \ - vm/write_barrier.o + vm/vm.o \ + vm/words.o EXE_OBJS = $(PLAF_EXE_OBJS) diff --git a/README.txt b/README.txt deleted file mode 100755 index 016d60e68c..0000000000 --- a/README.txt +++ /dev/null @@ -1,154 +0,0 @@ -The Factor programming language -------------------------------- - -This file covers installation and basic usage of the Factor -implementation. It is not an introduction to the language itself. - -* Contents - -- Compiling the Factor VM -- Libraries needed for compilation -- Bootstrapping the Factor image -- Running Factor on Unix with X11 -- Running Factor on Mac OS X - Cocoa UI -- Running Factor on Mac OS X - X11 UI -- Running Factor on Windows -- Command line usage -- The Factor FAQ -- Source organization -- Community - -* Compiling the Factor VM - -Factor supports various platforms. For an up-to-date list, see -. - -The Factor VM is written in C++ and uses GNU extensions. When compiling -with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor -uses std::tr1::unordered_map which is shipped as part of GCC. - -Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM. - -* Bootstrapping the Factor image - -Once you have compiled the Factor VM, you must bootstrap the Factor -system using the image that corresponds to your CPU architecture. - -Boot images can be obtained from . - -Once you download the right image, bootstrap Factor with the -following command line: - -./factor -i=boot..image - -Bootstrap can take a while, depending on your system. When the process -completes, a 'factor.image' file will be generated. Note that this image -is both CPU and OS-specific, so in general cannot be shared between -machines. - -* Running Factor on Unix with X11 - -On Unix, Factor can either run a graphical user interface using X11, or -a terminal listener. - -For X11 support, you need recent development libraries for libc, -Pango, X11, and OpenGL. On a Debian-derived Linux distribution -(like Ubuntu), you can use the following line to grab everything: - - sudo apt-get install libc6-dev libpango1.0-dev libx11-dev libgl1-mesa-dev - -Note that if you are using a proprietary OpenGL driver, you should -probably leave out the last package in the list. - -If your DISPLAY environment variable is set, the UI will start -automatically when you run Factor: - - ./factor - -To run an interactive terminal listener: - - ./factor -run=listener - -* Running Factor on Mac OS X - Cocoa UI - -On Mac OS X, a Cocoa UI is available in addition to the terminal -listener. - -The 'factor' executable runs the terminal listener: - - ./factor - -The 'Factor.app' bundle runs the Cocoa UI. Note that this is not a -self-contained bundle, it must be run from the same directory which -contains factor.image and the library sources. - -* Running Factor on Mac OS X - X11 UI - -The X11 UI is also available on Mac OS X, however its use is not -recommended since it does not integrate with the host OS. - -When compiling Factor, pass the X11=1 parameter: - - make X11=1 - -Then bootstrap with the following switches: - - ./factor -i=boot..image -ui-backend=x11 - -Now if $DISPLAY is set, running ./factor will start the UI. - -* Running Factor on Windows XP/Vista - -The Factor runtime is compiled into two binaries: - - factor.com - a Windows console application - factor.exe - a Windows native application, without a console - -If you did not download the binary package, you can bootstrap Factor in -the command prompt using the console application: - - factor.com -i=boot..image - -Once bootstrapped, double-clicking factor.exe or factor.com starts -the Factor UI. - -To run the listener in the command prompt: - - factor.com -run=listener - -* The Factor FAQ - -The Factor FAQ is available at the following location: - - - -* Command line usage - -Factor supports a number of command line switches. To read command line -usage documentation, enter the following in the UI listener: - - "command-line" about - -* Source organization - -The Factor source tree is organized as follows: - - build-support/ - scripts used for compiling Factor - vm/ - Factor VM - core/ - Factor core library - basis/ - Factor basis library, compiler, tools - extra/ - more libraries and applications - misc/ - editor modes, icons, etc - unmaintained/ - unmaintained contributions, please help! - -* Community - -The Factor homepage is located at . - -Factor developers meet in the #concatenative channel on the -irc.freenode.net server. Drop by if you want to discuss anything related -to Factor or language design in general. - -Have fun! - -:tabSize=2:indentSize=2:noTabs=true: diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor index 2d494afca3..82134e825e 100644 --- a/basis/alarms/alarms-docs.factor +++ b/basis/alarms/alarms-docs.factor @@ -24,10 +24,12 @@ HELP: every ARTICLE: "alarms" "Alarms" "The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread." -{ $subsection alarm } -{ $subsection add-alarm } -{ $subsection later } -{ $subsection cancel-alarm } +{ $subsections + alarm + add-alarm + later + cancel-alarm +} "Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ; ABOUT: "alarms" diff --git a/basis/alien/arrays/arrays-docs.factor b/basis/alien/arrays/arrays-docs.factor deleted file mode 100755 index 74174485fe..0000000000 --- a/basis/alien/arrays/arrays-docs.factor +++ /dev/null @@ -1,12 +0,0 @@ -USING: help.syntax help.markup byte-arrays alien.c-types alien.data ; -IN: alien.arrays - -ARTICLE: "c-arrays" "C arrays" -"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "." -$nl -"C type specifiers for array types are documented in " { $link "c-types-specs" } "." -$nl -"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " vocabulary set. They can also be loaded and constructed through their primitive C types:" -{ $subsection require-c-array } -{ $subsection } -{ $subsection } ; diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 390477dcac..a0dea4e539 100755 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -3,6 +3,7 @@ byte-arrays strings hashtables alien.syntax alien.strings sequences io.encodings.string debugger destructors vocabs.loader classes.struct ; QUALIFIED: math +QUALIFIED: sequences IN: alien.c-types HELP: byte-length @@ -10,25 +11,24 @@ HELP: byte-length { $contract "Outputs the size of the byte array, struct, or specialized array data in bytes." } ; HELP: heap-size -{ $values { "type" string } { "size" math:integer } } +{ $values { "name" "a C type name" } { "size" math:integer } } { $description "Outputs the number of bytes needed for a heap-allocated value of this C type." } { $examples - "On a 32-bit system, you will get the following output:" - { $unchecked-example "USE: alien\n\"void*\" heap-size ." "4" } + { $example "USING: alien alien.c-types prettyprint ;\nint heap-size ." "4" } } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; HELP: stack-size -{ $values { "type" string } { "size" math:integer } } +{ $values { "name" "a C type name" } { "size" math:integer } } { $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; HELP: -{ $values { "type" hashtable } } +{ $values { "c-type" c-type } } { $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ; HELP: no-c-type -{ $values { "type" string } } +{ $values { "name" "a C type name" } } { $description "Throws a " { $link no-c-type } " error." } { $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ; @@ -36,32 +36,32 @@ HELP: c-types { $var-description "Global variable holding a hashtable mapping C type names to C types. Use the " { $link c-type } " word to look up C types." } ; HELP: c-type -{ $values { "name" string } { "type" hashtable } } +{ $values { "name" "a C type" } { "c-type" c-type } } { $description "Looks up a C type by name." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; HELP: c-getter -{ $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } } +{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } } { $description "Outputs a quotation which reads values of this C type from a C structure." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; HELP: c-setter -{ $values { "name" string } { "quot" { $quotation "( obj c-ptr n -- )" } } } +{ $values { "name" "a C type" } { "quot" { $quotation "( obj c-ptr n -- )" } } } { $description "Outputs a quotation which writes values of this C type to a C structure." } { $errors "Throws an error if the type does not exist." } ; HELP: box-parameter -{ $values { "n" math:integer } { "ctype" string } } +{ $values { "n" math:integer } { "c-type" "a C type" } } { $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." } { $notes "This is an internal word used by the compiler when compiling callbacks." } ; HELP: box-return -{ $values { "ctype" string } } +{ $values { "c-type" "a C type" } } { $description "Generates code for converting a C value stored in return registers into a Factor object to be pushed on the data stack." } { $notes "This is an internal word used by the compiler when compiling alien calls." } ; HELP: unbox-return -{ $values { "ctype" string } } +{ $values { "c-type" "a C type" } } { $description "Generates code for converting a Factor value on the data stack into a C value to be stored in the return registers." } { $notes "This is an internal word used by the compiler when compiling callbacks." } ; @@ -89,16 +89,24 @@ HELP: uint { $description "This C type represents a four-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ; HELP: long { $description "This C type represents a four- or eight-byte signed integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: intptr_t +{ $description "This C type represents a signed integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ; HELP: ulong { $description "This C type represents a four- or eight-byte unsigned integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: uintptr_t +{ $description "This C type represents an unsigned integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: ptrdiff_t +{ $description "This C type represents a signed integer type large enough to hold the distance between two pointer values; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: size_t +{ $description "This C type represents unsigned size values of the size expected by the platform's standard C library (usually four bytes on a 32-bit platform, and eight on a 64-bit platform). Input values will be converted to " { $link math:integer } "s and truncated to the appropriate size; output values will be returned as " { $link math:integer } "s." } ; HELP: longlong { $description "This C type represents an eight-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ; HELP: ulonglong { $description "This C type represents an eight-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ; HELP: void -{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition, or an " { $link alien-invoke } " or " { $link alien-callback } " call." } ; +{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition or for an " { $link alien-invoke } " or " { $link alien-callback } " call." } ; HELP: void* -{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Output values are returned as " { $link alien } "s." } ; +{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as " { $snippet "void*" } " function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. " { $snippet "void*" } " output values are returned as " { $link alien } "s." } ; HELP: char* { $description "This C type represents a pointer to a C string. See " { $link "c-strings" } " for details about using strings with the FFI." } ; HELP: float @@ -128,39 +136,41 @@ ARTICLE: "c-out-params" "Output parameters in C" "A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations." $nl "Each numerical C type, together with " { $snippet "void*" } ", has an associated " { $emphasis "out parameter constructor" } " word which takes a Factor object as input, constructs a byte array of the correct size, and converts the Factor object to a C value stored into the byte array:" -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } +{ $subsections + + + + + + + + + + + + + +} "You call the out parameter constructor with the required initial value, then pass the byte array to the C function, which receives a pointer to the start of the byte array's data area. The C function then returns, leaving the result in the byte array; you read it back using the next set of words:" -{ $subsection *char } -{ $subsection *uchar } -{ $subsection *short } -{ $subsection *ushort } -{ $subsection *int } -{ $subsection *uint } -{ $subsection *long } -{ $subsection *ulong } -{ $subsection *longlong } -{ $subsection *ulonglong } -{ $subsection *float } -{ $subsection *double } -{ $subsection *void* } +{ $subsections + *char + *uchar + *short + *ushort + *int + *uint + *long + *ulong + *longlong + *ulonglong + *float + *double + *void* +} "Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link } " and " { $link *void* } " may be used." ; -ARTICLE: "c-types-specs" "C type specifiers" -"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words. New C types can be defined by the words " { $link POSTPONE: STRUCT: } ", " { $link POSTPONE: UNION-STRUCT: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: TYPEDEF: } "." -$nl -"The following numerical types are available; a " { $snippet "u" } " prefix denotes an unsigned type:" +ARTICLE: "c-types.primitives" "Primitive C types" +"The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:" { $table { "C type" "Notes" } { { $link char } "always 1 byte" } @@ -175,15 +185,68 @@ $nl { { $link ulonglong } { } } { { $link float } { "single-precision float (not the same as Factor's " { $link math:float } " class!)" } } { { $link double } { "double-precision float (the same format as Factor's " { $link math:float } " objects)" } } +} +"The following C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary:" +{ $table { { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link math:complex } " values" } } { { $link complex-double } { "C99 or Fortran " { $snippet "complex double" } " type, converted to and from Factor " { $link math:complex } " values" } } } -"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." -$nl +"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." ; + +ARTICLE: "c-types.pointers" "Pointer and array types" "Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned." $nl "Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:" { $code "int[3][4]" } -"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation." +"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation." ; + +ARTICLE: "c-types.ambiguity" "Word name clashes with C types" +"Note that some of the C type word names clash with commonly-used Factor words:" +{ $list + { { $link short } " clashes with the " { $link sequences:short } " word in the " { $vocab-link "sequences" } " vocabulary" } + { { $link float } " clashes with the " { $link math:float } " word in the " { $vocab-link "math" } " vocabulary" } +} +"If you use the wrong vocabulary, you will see a " { $link no-c-type } " error. For example, the following is " { $strong "not" } " valid, and will raise an error because the " { $link math:float } " word from the " { $vocab-link "math" } " vocabulary is not a C type:" +{ $code + "USING: alien.syntax math prettyprint ;" + "FUNCTION: float magic_number ( ) ;" + "magic_number 3.0 + ." +} +"The following won't work either; now the problem is that there are two vocabularies in the search path that define a word named " { $snippet "float" } ":" +{ $code + "USING: alien.c-types alien.syntax math prettyprint ;" + "FUNCTION: float magic_number ( ) ;" + "magic_number 3.0 + ." +} +"The correct solution is to use one of " { $link POSTPONE: FROM: } ", " { $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: QUALIFIED-WITH: } " to disambiguate word lookup:" +{ $code + "USING: alien.syntax math prettyprint ;" + "QUALIFIED-WITH: alien.c-types c" + "FUNCTION: c:float magic_number ( ) ;" + "magic_number 3.0 + ." +} +"See " { $link "word-search-semantics" } " for details." ; + +ARTICLE: "c-types.structs" "Struct and union types" +"Struct and union types are identified by their class word. See " { $link "classes.struct" } "." ; + +ARTICLE: "c-types-specs" "C type specifiers" +"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words." $nl -"Structure and union types are specified by the name of the structure or union." ; +"Defining new C types:" +{ $subsections + POSTPONE: STRUCT: + POSTPONE: UNION-STRUCT: + POSTPONE: CALLBACK: + POSTPONE: TYPEDEF: +} +{ $heading "Related articles" } +{ $subsections + "c-types.primitives" + "c-types.pointers" + "c-types.ambiguity" + "c-types.structs" +} +; + +ABOUT: "c-types-specs" diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor old mode 100644 new mode 100755 index 792e7d416a..d134d57189 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -1,49 +1,50 @@ -USING: alien alien.syntax alien.c-types kernel tools.test -sequences system libc alien.strings io.encodings.utf8 ; +USING: alien alien.syntax alien.c-types alien.parser +eval kernel tools.test sequences system libc alien.strings +io.encodings.utf8 math.constants classes.struct classes ; IN: alien.c-types.tests CONSTANT: xyz 123 -[ 492 ] [ { "int" xyz } heap-size ] unit-test +[ 492 ] [ { int xyz } heap-size ] unit-test [ -1 ] [ -1 *char ] unit-test [ -1 ] [ -1 *short ] unit-test [ -1 ] [ -1 *int ] unit-test -C-UNION: foo - "int" - "int" ; +UNION-STRUCT: foo + { a int } + { b int } ; -[ f ] [ "char*" c-type "void*" c-type eq? ] unit-test -[ t ] [ "char**" c-type "void*" c-type eq? ] unit-test +[ f ] [ char resolve-pointer-type c-type void* c-type eq? ] unit-test +[ t ] [ char* resolve-pointer-type c-type void* c-type eq? ] unit-test -[ t ] [ "foo" heap-size "int" heap-size = ] unit-test +[ t ] [ foo heap-size int heap-size = ] unit-test TYPEDEF: int MyInt -[ t ] [ "int" c-type "MyInt" c-type eq? ] unit-test -[ t ] [ "void*" c-type "MyInt*" c-type eq? ] unit-test +[ t ] [ int c-type MyInt c-type eq? ] unit-test +[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test TYPEDEF: char MyChar -[ t ] [ "char" c-type "MyChar" c-type eq? ] unit-test -[ f ] [ "void*" c-type "MyChar*" c-type eq? ] unit-test -[ t ] [ "char*" c-type "MyChar*" c-type eq? ] unit-test +[ t ] [ char c-type MyChar c-type eq? ] unit-test +[ f ] [ void* c-type MyChar resolve-pointer-type c-type eq? ] unit-test +[ t ] [ char* c-type MyChar resolve-pointer-type c-type eq? ] unit-test -[ 32 ] [ { "int" 8 } heap-size ] unit-test +[ 32 ] [ { int 8 } heap-size ] unit-test TYPEDEF: char* MyString -[ t ] [ "char*" c-type "MyString" c-type eq? ] unit-test -[ t ] [ "void*" c-type "MyString*" c-type eq? ] unit-test +[ t ] [ char* c-type MyString c-type eq? ] unit-test +[ t ] [ void* c-type MyString resolve-pointer-type c-type eq? ] unit-test TYPEDEF: int* MyIntArray -[ t ] [ "void*" c-type "MyIntArray" c-type eq? ] unit-test +[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test TYPEDEF: uchar* MyLPBYTE -[ t ] [ { char* utf8 } c-type "MyLPBYTE" c-type = ] unit-test +[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test [ 0 B{ 1 2 3 4 } @@ -52,3 +53,50 @@ TYPEDEF: uchar* MyLPBYTE os windows? cpu x86.64? and [ [ -2147467259 ] [ 2147500037 *long ] unit-test ] when + +[ 0 ] [ -10 uchar c-type-clamp ] unit-test +[ 12 ] [ 12 uchar c-type-clamp ] unit-test +[ -10 ] [ -10 char c-type-clamp ] unit-test +[ 127 ] [ 230 char c-type-clamp ] unit-test +[ t ] [ pi dup float c-type-clamp = ] unit-test + +C-TYPE: opaque + +[ t ] [ void* c-type opaque resolve-pointer-type c-type eq? ] unit-test +[ opaque c-type ] [ no-c-type? ] must-fail-with + +[ """ + USING: alien.syntax ; + IN: alien.c-types.tests + FUNCTION: opaque return_opaque ( ) ; +""" eval( -- ) ] [ no-c-type? ] must-fail-with + +C-TYPE: forward +STRUCT: backward { x forward* } ; +STRUCT: forward { x backward* } ; + +[ t ] [ forward c-type struct-c-type? ] unit-test +[ t ] [ backward c-type struct-c-type? ] unit-test + +DEFER: struct-redefined + +[ f ] +[ + + """ + USING: alien.c-types classes.struct ; + IN: alien.c-types.tests + + STRUCT: struct-redefined { x int } ; + """ eval( -- ) + + """ + USING: alien.syntax ; + IN: alien.c-types.tests + + C-TYPE: struct-redefined + """ eval( -- ) + + \ struct-redefined class? +] unit-test + diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index fa27e29c04..dec7f92501 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays arrays assocs kernel kernel.private math -namespaces make parser sequences strings words splitting math.parser -cpu.architecture alien alien.accessors alien.strings quotations -layouts system compiler.units io io.files io.encodings.binary -io.streams.memory accessors combinators effects continuations fry -classes vocabs vocabs.loader words.symbol ; +math.order math.parser namespaces make parser sequences strings +words splitting cpu.architecture alien alien.accessors +alien.strings quotations layouts system compiler.units io +io.files io.encodings.binary io.streams.memory accessors +combinators effects continuations fry classes vocabs +vocabs.loader words.symbol ; QUALIFIED: math IN: alien.c-types @@ -38,8 +39,8 @@ unboxer { rep initial: int-rep } stack-align? ; -: ( -- type ) - \ c-type new ; +: ( -- c-type ) + \ c-type new ; inline SYMBOL: c-types @@ -55,13 +56,19 @@ PREDICATE: c-type-word < word UNION: c-type-name string c-type-word ; ! C type protocol -GENERIC: c-type ( name -- type ) foldable +GENERIC: c-type ( name -- c-type ) foldable GENERIC: resolve-pointer-type ( name -- c-type ) +<< \ void \ void* "pointer-c-type" set-word-prop >> + +: void? ( c-type -- ? ) + { void "void" } member? ; + M: word resolve-pointer-type dup "pointer-c-type" word-prop [ ] [ drop void* ] ?if ; + M: string resolve-pointer-type dup "*" append dup c-types get at [ nip ] [ @@ -70,14 +77,15 @@ M: string resolve-pointer-type [ resolve-pointer-type ] [ drop void* ] if ] if ; -: resolve-typedef ( name -- type ) +: resolve-typedef ( name -- c-type ) + dup void? [ no-c-type ] when dup c-type-name? [ c-type ] when ; -: parse-array-type ( name -- dims type ) +: parse-array-type ( name -- dims c-type ) "[" split unclip [ [ "]" ?tail drop string>number ] map ] dip ; -M: string c-type ( name -- type ) +M: string c-type ( name -- c-type ) CHAR: ] over member? [ parse-array-type prefix ] [ @@ -87,12 +95,10 @@ M: string c-type ( name -- type ) ] if ; M: word c-type - "c-type" word-prop resolve-typedef ; + dup "c-type" word-prop resolve-typedef + [ ] [ no-c-type ] ?if ; -: void? ( c-type -- ? ) - { void "void" } member? ; - -GENERIC: c-struct? ( type -- ? ) +GENERIC: c-struct? ( c-type -- ? ) M: object c-struct? drop f ; @@ -168,33 +174,33 @@ M: c-type c-type-stack-align? stack-align?>> ; M: c-type-name c-type-stack-align? c-type c-type-stack-align? ; -: c-type-box ( n type -- ) +: c-type-box ( n c-type -- ) [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi %box ; -: c-type-unbox ( n ctype -- ) +: c-type-unbox ( n c-type -- ) [ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi %unbox ; -GENERIC: box-parameter ( n ctype -- ) +GENERIC: box-parameter ( n c-type -- ) M: c-type box-parameter c-type-box ; M: c-type-name box-parameter c-type box-parameter ; -GENERIC: box-return ( ctype -- ) +GENERIC: box-return ( c-type -- ) M: c-type box-return f swap c-type-box ; M: c-type-name box-return c-type box-return ; -GENERIC: unbox-parameter ( n ctype -- ) +GENERIC: unbox-parameter ( n c-type -- ) M: c-type unbox-parameter c-type-unbox ; M: c-type-name unbox-parameter c-type unbox-parameter ; -GENERIC: unbox-return ( ctype -- ) +GENERIC: unbox-return ( c-type -- ) M: c-type unbox-return f swap c-type-unbox ; @@ -202,13 +208,13 @@ M: c-type-name unbox-return c-type unbox-return ; : little-endian? ( -- ? ) 1 *char 1 = ; foldable -GENERIC: heap-size ( type -- size ) foldable +GENERIC: heap-size ( name -- size ) foldable M: c-type-name heap-size c-type heap-size ; M: abstract-c-type heap-size size>> ; -GENERIC: stack-size ( type -- size ) foldable +GENERIC: stack-size ( name -- size ) foldable M: c-type-name stack-size c-type stack-size ; @@ -235,7 +241,7 @@ MIXIN: value-type [ "Cannot write struct fields with this type" throw ] ] unless* ; -: array-accessor ( type quot -- def ) +: array-accessor ( c-type quot -- def ) [ \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi* ] [ ] make ; @@ -261,19 +267,19 @@ M: word typedef ( old new -- ) TUPLE: long-long-type < c-type ; -: ( -- type ) +: ( -- c-type ) long-long-type new ; -M: long-long-type unbox-parameter ( n type -- ) +M: long-long-type unbox-parameter ( n c-type -- ) c-type-unboxer %unbox-long-long ; -M: long-long-type unbox-return ( type -- ) +M: long-long-type unbox-return ( c-type -- ) f swap unbox-parameter ; -M: long-long-type box-parameter ( n type -- ) +M: long-long-type box-parameter ( n c-type -- ) c-type-boxer %box-long-long ; -M: long-long-type box-return ( type -- ) +M: long-long-type box-return ( c-type -- ) f swap box-parameter ; : define-deref ( name -- ) @@ -285,13 +291,13 @@ M: long-long-type box-return ( type -- ) [ dup c-setter '[ _ heap-size [ 0 @ ] keep ] ] bi (( value -- c-ptr )) define-inline ; -: define-primitive-type ( type name -- ) +: define-primitive-type ( c-type name -- ) [ typedef ] [ name>> define-deref ] [ name>> define-out ] tri ; -: if-void ( type true false -- ) +: if-void ( c-type true false -- ) pick void? [ drop nip call ] [ nip call ] if ; inline CONSTANT: primitive-types @@ -306,7 +312,7 @@ CONSTANT: primitive-types } SYMBOLS: - ptrdiff_t intptr_t size_t + ptrdiff_t intptr_t uintptr_t size_t char* uchar* ; [ @@ -467,8 +473,33 @@ SYMBOLS: [ >float ] >>unboxer-quot \ double define-primitive-type - \ long \ ptrdiff_t typedef - \ long \ intptr_t typedef - \ ulong \ size_t typedef + \ long c-type \ ptrdiff_t typedef + \ long c-type \ intptr_t typedef + \ ulong c-type \ uintptr_t typedef + \ ulong c-type \ size_t typedef ] with-compilation-unit +M: char-16-rep rep-component-type drop char ; +M: uchar-16-rep rep-component-type drop uchar ; +M: short-8-rep rep-component-type drop short ; +M: ushort-8-rep rep-component-type drop ushort ; +M: int-4-rep rep-component-type drop int ; +M: uint-4-rep rep-component-type drop uint ; +M: longlong-2-rep rep-component-type drop longlong ; +M: ulonglong-2-rep rep-component-type drop ulonglong ; +M: float-4-rep rep-component-type drop float ; +M: double-2-rep rep-component-type drop double ; + +: (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable +: unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable +: (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable +: signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable + +: c-type-interval ( c-type -- from to ) + { + { [ dup { float double } memq? ] [ drop -1/0. 1/0. ] } + { [ dup { char short int long longlong } memq? ] [ signed-interval ] } + { [ dup { uchar ushort uint ulong ulonglong } memq? ] [ unsigned-interval ] } + } cond ; foldable + +: c-type-clamp ( value c-type -- value' ) c-type-interval clamp ; inline diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor index 7bf826d87e..87f0c98b47 100644 --- a/basis/alien/complex/complex-tests.factor +++ b/basis/alien/complex/complex-tests.factor @@ -16,6 +16,6 @@ STRUCT: complex-holder [ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test -[ number ] [ "complex-float" c-type-boxed-class ] unit-test +[ complex ] [ "complex-float" c-type-boxed-class ] unit-test -[ number ] [ "complex-double" c-type-boxed-class ] unit-test +[ complex ] [ "complex-double" c-type-boxed-class ] unit-test diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 1faa64be61..cb46f2d67a 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -25,7 +25,7 @@ STRUCT: T-class { real N } { imaginary N } ; T-class c-type 1quotation >>unboxer-quot *T 1quotation >>boxer-quot -number >>boxed-class +complex >>boxed-class drop ;FUNCTOR diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor index 685639beed..0536d15736 100644 --- a/basis/alien/data/data-docs.factor +++ b/basis/alien/data/data-docs.factor @@ -1,6 +1,7 @@ -USING: alien alien.c-types help.syntax help.markup libc kernel.private -byte-arrays math strings hashtables alien.syntax alien.strings sequences -io.encodings.string debugger destructors vocabs.loader ; +USING: alien alien.c-types help.syntax help.markup libc +kernel.private byte-arrays math strings hashtables alien.syntax +alien.strings sequences io.encodings.string debugger destructors +vocabs.loader classes.struct ; IN: alien.data HELP: @@ -26,7 +27,7 @@ HELP: byte-array>memory { $warning "This word is unsafe. Improper use can corrupt memory." } ; HELP: malloc-array -{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } } +{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" "a specialized array" } } { $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link } "." } { $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } @@ -52,60 +53,70 @@ ARTICLE: "malloc" "Manual memory management" "Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case." $nl "Allocating a C datum with a fixed address:" -{ $subsection malloc-object } -{ $subsection malloc-array } -{ $subsection malloc-byte-array } -"There is a set of words in the " { $vocab-link "libc" } " vocabulary which directly call C standard library memory management functions:" -{ $subsection malloc } -{ $subsection calloc } -{ $subsection realloc } +{ $subsections + malloc-object + malloc-byte-array +} +"The " { $vocab-link "libc" } " vocabulary defines several words which directly call C standard library memory management functions:" +{ $subsections + malloc + calloc + realloc +} "You must always free pointers returned by any of the above words when the block of memory is no longer in use:" -{ $subsection free } +{ $subsections free } "Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":" -{ $subsection &free } -{ $subsection |free } +{ $subsections + &free + |free +} "The " { $link &free } " and " { $link |free } " words are generated using " { $link "alien.destructors" } "." $nl "You can unsafely copy a range of bytes from one memory location to another:" -{ $subsection memcpy } +{ $subsections memcpy } "You can copy a range of bytes from memory into a byte array:" -{ $subsection memory>byte-array } +{ $subsections memory>byte-array } "You can copy a byte array to memory unsafely:" -{ $subsection byte-array>memory } ; - - -ARTICLE: "c-byte-arrays" "Passing data in byte arrays" -"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array." -$nl -"Byte arrays can be allocated directly with a byte count using the " { $link } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:" -{ $subsection } -{ $subsection } +{ $subsections byte-array>memory } ; + +ARTICLE: "c-pointers" "Passing pointers to C functions" +"The following Factor objects may be passed to C function parameters with pointer types:" +{ $list + { "Instances of " { $link alien } "." } + { "Instances of " { $link f } "; this is interpreted as a null pointer." } + { "Instances of " { $link byte-array } "; the C function receives a pointer to the first element of the array." } + { "Any data type which defines a method on " { $link >c-ptr } " that returns an instance of one of the above. This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." } +} +"The class of primitive C pointer types:" +{ $subsections c-ptr } +"A generic word for converting any object to a C pointer; user-defined types may add methods to this generic word:" +{ $subsections >c-ptr } +"More about the " { $link alien } " type:" +{ $subsections "aliens" } { $warning -"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." } -{ $see-also "c-arrays" } ; +"The Factor garbage collector can move byte arrays around, and code passing byte arrays, or objects backed by byte arrays, must obey important guidelines. See " { $link "byte-arrays-gc" } "." } ; ARTICLE: "c-data" "Passing data between Factor and C" "Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers." $nl "Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "." -{ $subsection "c-types-specs" } -{ $subsection "c-byte-arrays" } -{ $subsection "malloc" } -{ $subsection "c-strings" } -{ $subsection "c-arrays" } -{ $subsection "c-out-params" } +{ $subsections + "c-types-specs" + "c-pointers" + "malloc" + "c-strings" + "c-out-params" +} "Important guidelines for passing data in byte arrays:" -{ $subsection "byte-arrays-gc" } +{ $subsections "byte-arrays-gc" } "C-style enumerated types are supported:" -{ $subsection POSTPONE: C-ENUM: } +{ $subsections POSTPONE: C-ENUM: } "C types can be aliased for convenience and consitency with native library documentation:" -{ $subsection POSTPONE: TYPEDEF: } -"New C types can be defined:" -{ $subsection "c-structs" } -{ $subsection "c-unions" } +{ $subsections POSTPONE: TYPEDEF: } "A utility for defining " { $link "destructors" } " for deallocating memory:" -{ $subsection "alien.destructors" } -{ $see-also "aliens" } ; +{ $subsections "alien.destructors" } +"C struct and union types can be defined with " { $link POSTPONE: STRUCT: } " and " { $link POSTPONE: UNION: } ". See " { $link "classes.struct" } " for details. For passing arrays to and from C, use the " { $link "specialized-arrays" } " vocabulary." ; + HELP: malloc-string { $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } } { $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." } @@ -138,11 +149,13 @@ $nl "Care must be taken if the C function expects a " { $link char* } " with a length in bytes, rather than a null-terminated " { $link char* } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array." $nl "Sometimes a C function has a parameter type of " { $link void* } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:" -{ $subsection string>alien } -{ $subsection malloc-string } +{ $subsections + string>alien + malloc-string +} "The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." $nl "A word to read strings from arbitrary addresses:" -{ $subsection alien>string } +{ $subsections alien>string } "For example, if a C function returns a " { $link char* } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $link void* } ", and call one of the above words before passing the pointer to " { $link free } "." ; diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor index 1f2c5160e1..fc18921ef1 100644 --- a/basis/alien/data/data.factor +++ b/basis/alien/data/data.factor @@ -1,35 +1,35 @@ ! (c)2009 Slava Pestov, Joe Groff bsd license USING: accessors alien alien.c-types alien.strings arrays byte-arrays cpu.architecture fry io io.encodings.binary -io.files io.streams.memory kernel libc math sequences ; +io.files io.streams.memory kernel libc math sequences words ; IN: alien.data GENERIC: require-c-array ( c-type -- ) M: array require-c-array first require-c-array ; -GENERIC: c-array-constructor ( c-type -- word ) +GENERIC: c-array-constructor ( c-type -- word ) foldable -GENERIC: c-(array)-constructor ( c-type -- word ) +GENERIC: c-(array)-constructor ( c-type -- word ) foldable -GENERIC: c-direct-array-constructor ( c-type -- word ) +GENERIC: c-direct-array-constructor ( c-type -- word ) foldable GENERIC: ( len c-type -- array ) -M: c-type-name +M: word c-array-constructor execute( len -- array ) ; inline GENERIC: (c-array) ( len c-type -- array ) -M: c-type-name (c-array) +M: word (c-array) c-(array)-constructor execute( len -- array ) ; inline GENERIC: ( alien len c-type -- array ) -M: c-type-name +M: word c-direct-array-constructor execute( alien len -- array ) ; inline -: malloc-array ( n type -- alien ) +: malloc-array ( n type -- array ) [ heap-size calloc ] [ ] 2bi ; inline : (malloc-array) ( n type -- alien ) @@ -56,9 +56,6 @@ M: c-type-name : malloc-string ( string encoding -- alien ) string>alien malloc-byte-array ; -: malloc-file-contents ( path -- alien len ) - binary file-contents [ malloc-byte-array ] [ length ] bi ; - M: memory-stream stream-read [ [ index>> ] [ alien>> ] bi @@ -81,3 +78,4 @@ M: value-type c-type-setter ( type -- quot ) [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri '[ @ swap @ _ memcpy ] ; + diff --git a/basis/alien/destructors/destructors-docs.factor b/basis/alien/destructors/destructors-docs.factor index bc08dc7486..fcc56abe43 100644 --- a/basis/alien/destructors/destructors-docs.factor +++ b/basis/alien/destructors/destructors-docs.factor @@ -25,6 +25,6 @@ HELP: DESTRUCTOR: ARTICLE: "alien.destructors" "Alien destructors" "The " { $vocab-link "alien.destructors" } " vocabulary defines a utility parsing word for defining new disposable classes." -{ $subsection POSTPONE: DESTRUCTOR: } ; +{ $subsections POSTPONE: DESTRUCTOR: } ; ABOUT: "alien.destructors" \ No newline at end of file diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor index 7778500bf1..87b3e9e735 100644 --- a/basis/alien/fortran/fortran-docs.factor +++ b/basis/alien/fortran/fortran-docs.factor @@ -56,13 +56,14 @@ HELP: fortran-invoke ARTICLE: "alien.fortran" "Fortran FFI" "The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran." -{ $subsection "alien.fortran-types" } -{ $subsection "alien.fortran-abis" } -{ $subsection add-fortran-library } -{ $subsection POSTPONE: LIBRARY: } -{ $subsection POSTPONE: FUNCTION: } -{ $subsection POSTPONE: SUBROUTINE: } -{ $subsection fortran-invoke } -; +{ $subsections + "alien.fortran-types" + "alien.fortran-abis" + add-fortran-library + POSTPONE: LIBRARY: + POSTPONE: FUNCTION: + POSTPONE: SUBROUTINE: + fortran-invoke +} ; ABOUT: "alien.fortran" diff --git a/basis/alien/libraries/libraries-docs.factor b/basis/alien/libraries/libraries-docs.factor index a23a00b502..bface7f45a 100755 --- a/basis/alien/libraries/libraries-docs.factor +++ b/basis/alien/libraries/libraries-docs.factor @@ -45,10 +45,12 @@ HELP: load-library HELP: add-library { $values { "name" string } { "path" string } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } } -{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." } -{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " cannot be used in the same file as " { $link POSTPONE: FUNCTION: } " definitions from that library. The " { $link add-library } " call will happen too late, after compilation, and the alien calls will not work." +{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } " and the specified ABI. The logical library name can then be used by a " { $link POSTPONE: LIBRARY: } " form to specify the logical library for subsequent " { $link POSTPONE: FUNCTION: } " definitions." } +{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " must be placed within a " { $snippet "<< ... >>" } " parse-time evaluation block." $nl -"Instead, " { $link add-library } " calls must either be placed in different source files from those that use that library, or alternatively, " { $link "syntax-immediate" } " can be used to load the library before compilation." } +"This ensures that if the logical library is later used in the same file, for example by a " { $link POSTPONE: FUNCTION: } " definition. Otherwise, the " { $link add-library } " call will happen too late, after compilation, and the C function calls will not refer to the correct library." +$nl +"For details about parse-time evaluation, see " { $link "syntax-immediate" } "." } { $examples "Here is a typical usage of " { $link add-library } ":" { $code "<< \"freetype\" {" @@ -65,8 +67,10 @@ HELP: remove-library ARTICLE: "loading-libs" "Loading native libraries" "Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:" -{ $subsection add-library } -{ $subsection remove-library } +{ $subsections + add-library + remove-library +} "Once a library has been defined, you can try loading it to see if the path name is correct:" -{ $subsection load-library } +{ $subsections load-library } "If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ; diff --git a/basis/alien/parser/parser-tests.factor b/basis/alien/parser/parser-tests.factor new file mode 100644 index 0000000000..061deb84c5 --- /dev/null +++ b/basis/alien/parser/parser-tests.factor @@ -0,0 +1,43 @@ +! (c)2009 Joe Groff bsd license +USING: accessors alien.c-types alien.parser alien.syntax +tools.test vocabs.parser parser eval vocabs.parser debugger +continuations ; +IN: alien.parser.tests + +TYPEDEF: char char2 + +SYMBOL: not-c-type + +[ + "alien.parser.tests" use-vocab + "alien.c-types" use-vocab + + [ int ] [ "int" parse-c-type ] unit-test + [ { int 5 } ] [ "int[5]" parse-c-type ] unit-test + [ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test + [ void* ] [ "int*" parse-c-type ] unit-test + [ void* ] [ "int**" parse-c-type ] unit-test + [ void* ] [ "int***" parse-c-type ] unit-test + [ void* ] [ "int****" parse-c-type ] unit-test + [ char* ] [ "char*" parse-c-type ] unit-test + [ void* ] [ "char**" parse-c-type ] unit-test + [ void* ] [ "char***" parse-c-type ] unit-test + [ void* ] [ "char****" parse-c-type ] unit-test + [ char2 ] [ "char2" parse-c-type ] unit-test + [ char* ] [ "char2*" parse-c-type ] unit-test + + [ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with + [ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with + +] with-file-vocabs + +! Reported by mnestic +TYPEDEF: int alien-parser-test-int ! reasonably unique name... + +[ "OK!" ] [ + [ + "USE: specialized-arrays SPECIALIZED-ARRAY: alien-parser-test-int" eval( -- ) + ! after restart, we end up here + "OK!" + ] [ :1 ] recover +] unit-test \ No newline at end of file diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index d58f9a315c..e4ff5789d2 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -1,22 +1,23 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types arrays assocs -combinators combinators.short-circuit effects grouping +USING: accessors alien alien.c-types alien.parser +alien.libraries arrays assocs classes combinators +combinators.short-circuit compiler.units effects grouping kernel parser sequences splitting words fry locals lexer namespaces summary math vocabs.parser ; IN: alien.parser -: parse-c-type-name ( name -- word/string ) - [ search ] keep or ; +: parse-c-type-name ( name -- word ) + dup search [ ] [ no-word ] ?if ; -: parse-c-type ( string -- array ) +: parse-c-type ( string -- type ) { { [ dup "void" = ] [ drop void ] } { [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] } { [ dup search c-type-word? ] [ parse-c-type-name ] } - { [ dup c-types get at ] [ ] } + { [ "**" ?tail ] [ drop void* ] } { [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] } - [ no-c-type ] + [ dup search [ no-c-type ] [ no-word ] ?if ] } cond ; : scan-c-type ( -- c-type ) @@ -25,10 +26,22 @@ IN: alien.parser [ parse-c-type ] if ; : reset-c-type ( word -- ) - { "c-type" "pointer-c-type" "callback-effect" "callback-abi" } reset-props ; + dup "struct-size" word-prop + [ dup [ forget-class ] [ { "struct-size" } reset-props ] bi ] when + { + "c-type" + "pointer-c-type" + "callback-effect" + "callback-library" + } reset-props ; : CREATE-C-TYPE ( -- word ) - scan current-vocab create dup reset-c-type ; + scan current-vocab create { + [ fake-definition ] + [ set-word ] + [ reset-c-type ] + [ ] + } cleave ; : normalize-c-arg ( type name -- type' name' ) [ length ] @@ -67,17 +80,21 @@ IN: alien.parser : callback-quot ( return types abi -- quot ) [ [ ] 3curry dip alien-callback ] 3curry ; -:: make-callback-type ( abi return! type-name! parameters -- word quot effect ) +: library-abi ( lib -- abi ) + library [ abi>> ] [ "cdecl" ] if* ; + +:: make-callback-type ( lib return! type-name! parameters -- word quot effect ) return type-name normalize-c-arg type-name! return! type-name current-vocab create :> type-word type-word [ reset-generic ] [ reset-c-type ] bi void* type-word typedef parameters return parse-arglist :> callback-effect :> types type-word callback-effect "callback-effect" set-word-prop - type-word abi "callback-abi" set-word-prop - type-word return types abi callback-quot (( quot -- alien )) ; + type-word lib "callback-library" set-word-prop + type-word return types lib library-abi callback-quot (( quot -- alien )) ; -: (CALLBACK:) ( abi -- word quot effect ) +: (CALLBACK:) ( -- word quot effect ) + "c-library" get scan scan parse-arg-tokens make-callback-type ; PREDICATE: alien-function-word < word diff --git a/basis/alien/prettyprint/prettyprint.factor b/basis/alien/prettyprint/prettyprint.factor index eea3515c8f..ded8f692cd 100644 --- a/basis/alien/prettyprint/prettyprint.factor +++ b/basis/alien/prettyprint/prettyprint.factor @@ -45,13 +45,16 @@ M: typedef-word synopsis* first2 pprint-function-arg ] if-empty ; +: pprint-library ( library -- ) + [ \ LIBRARY: [ text ] pprint-prefix ] when* ; + M: alien-function-word definer drop \ FUNCTION: \ ; ; M: alien-function-word definition drop f ; M: alien-function-word synopsis* { [ seeing-word ] - [ def>> second [ \ LIBRARY: [ text ] pprint-prefix ] when* ] + [ def>> second pprint-library ] [ definer. ] [ def>> first pprint-c-type ] [ pprint-word ] @@ -64,13 +67,12 @@ M: alien-function-word synopsis* } cleave ; M: alien-callback-type-word definer - "callback-abi" word-prop "stdcall" = - \ STDCALL-CALLBACK: \ CALLBACK: ? - f ; + drop \ CALLBACK: \ ; ; M: alien-callback-type-word definition drop f ; M: alien-callback-type-word synopsis* { [ seeing-word ] + [ "callback-library" word-prop pprint-library ] [ definer. ] [ def>> first pprint-c-type ] [ pprint-word ] diff --git a/basis/alien/structs/authors.txt b/basis/alien/structs/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/basis/alien/structs/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor deleted file mode 100644 index 1fa2fe0b0c..0000000000 --- a/basis/alien/structs/fields/fields.factor +++ /dev/null @@ -1,45 +0,0 @@ -! Copyright (C) 2005, 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel kernel.private math namespaces -make sequences strings words effects combinators alien.c-types ; -IN: alien.structs.fields - -TUPLE: field-spec name offset type reader writer ; - -: reader-word ( class name vocab -- word ) - [ "-" glue ] dip create dup make-deprecated ; - -: writer-word ( class name vocab -- word ) - [ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ; - -: ( struct-name vocab type field-name -- spec ) - field-spec new - 0 >>offset - swap >>name - swap >>type - 3dup name>> swap reader-word >>reader - 3dup name>> swap writer-word >>writer - 2nip ; - -: align-offset ( offset type -- offset ) - c-type-align align ; - -: struct-offsets ( specs -- size ) - 0 [ - [ type>> align-offset ] keep - [ (>>offset) ] [ type>> heap-size + ] 2bi - ] reduce ; - -: define-struct-slot-word ( word quot spec effect -- ) - [ offset>> prefix ] dip define-inline ; - -: define-getter ( spec -- ) - [ reader>> ] [ type>> c-type-getter-boxer ] [ ] tri - (( c-ptr -- value )) define-struct-slot-word ; - -: define-setter ( spec -- ) - [ writer>> ] [ type>> c-setter ] [ ] tri - (( value c-ptr -- )) define-struct-slot-word ; - -: define-field ( spec -- ) - [ define-getter ] [ define-setter ] bi ; diff --git a/basis/alien/structs/fields/summary.txt b/basis/alien/structs/fields/summary.txt deleted file mode 100644 index d9370ca575..0000000000 --- a/basis/alien/structs/fields/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Struct field implementation and reflection support diff --git a/basis/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor deleted file mode 100644 index d0485ae4ba..0000000000 --- a/basis/alien/structs/structs-docs.factor +++ /dev/null @@ -1,33 +0,0 @@ -USING: alien.c-types alien.data strings help.markup help.syntax alien.syntax -sequences io arrays kernel words assocs namespaces ; -IN: alien.structs - -ARTICLE: "c-structs" "C structure types" -"A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address." -{ $subsection POSTPONE: C-STRUCT: } -"Great care must be taken when working with C structures since no type or bounds checking is possible." -$nl -"An example:" -{ $code - "C-STRUCT: XVisualInfo" - " { \"Visual*\" \"visual\" }" - " { \"VisualID\" \"visualid\" }" - " { \"int\" \"screen\" }" - " { \"uint\" \"depth\" }" - " { \"int\" \"class\" }" - " { \"ulong\" \"red_mask\" }" - " { \"ulong\" \"green_mask\" }" - " { \"ulong\" \"blue_mask\" }" - " { \"int\" \"colormap_size\" }" - " { \"int\" \"bits_per_rgb\" } ;" -} -"C structure objects can be allocated by calling " { $link } " or " { $link malloc-object } "." -$nl -"Arrays of C structures can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ; - -ARTICLE: "c-unions" "C unions" -"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values." -{ $subsection POSTPONE: C-UNION: } -"C union objects can be allocated by calling " { $link } " or " { $link malloc-object } "." -$nl -"Arrays of C unions can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ; diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor deleted file mode 100755 index d22aa5ee45..0000000000 --- a/basis/alien/structs/structs-tests.factor +++ /dev/null @@ -1,59 +0,0 @@ -USING: alien alien.syntax alien.c-types alien.data kernel tools.test -sequences system libc words vocabs namespaces layouts ; -IN: alien.structs.tests - -C-STRUCT: bar - { "int" "x" } - { { "int" 8 } "y" } ; - -[ 36 ] [ "bar" heap-size ] unit-test -[ t ] [ \ "bar" c-type-getter memq? ] unit-test - -C-STRUCT: align-test - { "int" "x" } - { "double" "y" } ; - -os winnt? cpu x86? and [ - [ 16 ] [ "align-test" heap-size ] unit-test - - cell 4 = [ - C-STRUCT: one - { "long" "a" } { "double" "b" } { "int" "c" } ; - - [ 24 ] [ "one" heap-size ] unit-test - ] when -] when - -CONSTANT: MAX_FOOS 30 - -C-STRUCT: foox - { { "int" MAX_FOOS } "x" } ; - -[ 120 ] [ "foox" heap-size ] unit-test - -C-UNION: barx - { "int" MAX_FOOS } - "float" ; - -[ 120 ] [ "barx" heap-size ] unit-test - -"help" vocab [ - "print-topic" "help" lookup "help" set - [ ] [ \ foox-x "help" get execute ] unit-test - [ ] [ \ set-foox-x "help" get execute ] unit-test -] when - -C-STRUCT: nested - { "int" "x" } ; - -C-STRUCT: nested-2 - { "nested" "y" } ; - -[ 4 ] [ - "nested-2" - "nested" - 4 over set-nested-x - over set-nested-2-y - nested-2-y - nested-x -] unit-test diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor deleted file mode 100755 index 9478f98c63..0000000000 --- a/basis/alien/structs/structs.factor +++ /dev/null @@ -1,71 +0,0 @@ -! Copyright (C) 2004, 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs generic hashtables kernel kernel.private -math namespaces parser sequences strings words libc fry -alien.c-types alien.structs.fields cpu.architecture math.order -quotations byte-arrays ; -IN: alien.structs - -TUPLE: struct-type < abstract-c-type fields return-in-registers? ; - -INSTANCE: struct-type value-type - -M: struct-type c-type ; - -M: struct-type c-type-stack-align? drop f ; - -: if-value-struct ( ctype true false -- ) - [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline - -M: struct-type unbox-parameter - [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ; - -M: struct-type box-parameter - [ %box-large-struct ] [ box-parameter ] if-value-struct ; - -: if-small-struct ( c-type true false -- ? ) - [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline - -M: struct-type unbox-return - [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ; - -M: struct-type box-return - [ %box-small-struct ] [ %box-large-struct ] if-small-struct ; - -M: struct-type stack-size - [ heap-size ] [ stack-size ] if-value-struct ; - -M: struct-type c-struct? drop t ; - -: (define-struct) ( name size align fields class -- ) - [ [ align ] keep ] 2dip new - byte-array >>class - byte-array >>boxed-class - swap >>fields - swap >>align - swap >>size - swap typedef ; - -: make-fields ( name vocab fields -- fields ) - [ first2 ] with with map ; - -: compute-struct-align ( types -- n ) - [ c-type-align ] [ max ] map-reduce ; - -: define-struct ( name vocab fields -- ) - [ 2drop ] [ make-fields ] 3bi - [ struct-offsets ] keep - [ [ type>> ] map compute-struct-align ] keep - [ struct-type (define-struct) ] keep - [ define-field ] each ; deprecated - -: define-union ( name members -- ) - [ [ heap-size ] [ max ] map-reduce ] keep - compute-struct-align f struct-type (define-struct) ; deprecated - -: offset-of ( field struct -- offset ) - c-types get at fields>> - [ name>> = ] with find nip offset>> ; - -USE: vocabs.loader -"specialized-arrays" require diff --git a/basis/alien/structs/summary.txt b/basis/alien/structs/summary.txt deleted file mode 100644 index 4825c5b781..0000000000 --- a/basis/alien/structs/summary.txt +++ /dev/null @@ -1 +0,0 @@ -C structure support diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index 93a74c3b0a..a8d3048b82 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -1,6 +1,6 @@ IN: alien.syntax -USING: alien alien.c-types alien.parser alien.structs -classes.struct help.markup help.syntax ; +USING: alien alien.c-types alien.parser alien.libraries +classes.struct help.markup help.syntax see ; HELP: DLL" { $syntax "DLL\" path\"" } @@ -14,13 +14,16 @@ HELP: ALIEN: { $notes "Alien objects are invalidated between image saves and loads, and hence source files should not contain alien literals; this word is for interactive use only. See " { $link "alien-expiry" } " for details." } ; ARTICLE: "syntax-aliens" "Alien object literal syntax" -{ $subsection POSTPONE: ALIEN: } -{ $subsection POSTPONE: DLL" } ; +{ $subsections + POSTPONE: ALIEN: + POSTPONE: DLL" +} ; HELP: LIBRARY: { $syntax "LIBRARY: name" } { $values { "name" "a logical library name" } } -{ $description "Sets the logical library for consequent " { $link POSTPONE: FUNCTION: } " definitions that follow." } ; +{ $description "Sets the logical library for consequent " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: C-GLOBAL: } " and " { $link POSTPONE: CALLBACK: } " definitions, as well as " { $link POSTPONE: &: } " forms." } +{ $notes "Logical library names are defined with the " { $link add-library } " word." } ; HELP: FUNCTION: { $syntax "FUNCTION: return name ( parameters )" } @@ -54,21 +57,6 @@ HELP: TYPEDEF: { $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." } { $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ; -HELP: C-STRUCT: -{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." } -{ $syntax "C-STRUCT: name pairs... ;" } -{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } } -{ $description "Defines a C struct layout and accessor words." } -{ $notes "C type names are documented in " { $link "c-types-specs" } "." } ; - -HELP: C-UNION: -{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." } -{ $syntax "C-UNION: name members... ;" } -{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } } -{ $description "Defines a new C type sized to fit its largest member." } -{ $notes "C type names are documented in " { $link "c-types-specs" } "." } -{ $examples { $code "C-UNION: event \"active-event\" \"keyboard-event\" \"mouse-event\" ;" } } ; - HELP: C-ENUM: { $syntax "C-ENUM: words... ;" } { $values { "words" "a sequence of word names" } } @@ -81,10 +69,20 @@ HELP: C-ENUM: { $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" } } ; +HELP: C-TYPE: +{ $syntax "C-TYPE: type" } +{ $values { "type" "a new C type" } } +{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a pointer (that is, as " { $snippet "type*" } ")." $nl +{ $snippet "C-TYPE:" } " can also be used to forward-declare C types to enable circular dependencies. For example:" +{ $code """C-TYPE: forward +STRUCT: backward { x forward* } ; +STRUCT: forward { x backward* } ; """ } } +{ $notes "Primitive C types are also displayed using " { $snippet "C-TYPE:" } " syntax when they are displayed by " { $link see } "." } ; + HELP: CALLBACK: { $syntax "CALLBACK: return type ( parameters ) ;" } { $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } } -{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"cdecl\"" } " ABI." } +{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters. The ABI of the callback is decided from the ABI of the active " { $link POSTPONE: LIBRARY: } " declaration." } { $examples { $code "CALLBACK: bool FakeCallback ( int message, void* payload ) ;" @@ -98,42 +96,28 @@ HELP: CALLBACK: } } ; -HELP: STDCALL-CALLBACK: -{ $syntax "STDCALL-CALLBACK: return type ( parameters ) ;" } -{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } } -{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"stdcall\"" } " ABI." } -{ $examples - { $code - "STDCALL-CALLBACK: bool FakeCallback ( int message, void* payload ) ;" - ": MyFakeCallback ( -- alien )" - " [| message payload |" - " \"message #\" write" - " message number>string write" - " \" received\" write nl" - " t" - " ] FakeCallback ;" - } -} ; - -{ POSTPONE: CALLBACK: POSTPONE: STDCALL-CALLBACK: } related-words - HELP: &: { $syntax "&: symbol" } -{ $values { "symbol" "A C library symbol name" } } +{ $values { "symbol" "A C global variable name" } } { $description "Pushes the address of a symbol named " { $snippet "symbol" } " from the current library, set with " { $link POSTPONE: LIBRARY: } "." } ; HELP: typedef -{ $values { "old" "a string" } { "new" "a string" } } +{ $values { "old" "a C type" } { "new" "a C type" } } { $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." } { $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ; { POSTPONE: TYPEDEF: typedef } related-words HELP: c-struct? -{ $values { "type" "a string" } { "?" "a boolean" } } -{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: C-STRUCT: } "." } ; +{ $values { "c-type" "a C type" } { "?" "a boolean" } } +{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ; HELP: define-function { $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } } { $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." } { $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ; + +HELP: C-GLOBAL: +{ $syntax "C-GLOBAL: type name" } +{ $values { "type" "a C type" } { "name" "a C global variable name" } } +{ $description "Defines a new word named " { $snippet "name" } " which accesses a global variable in the current library, set with " { $link POSTPONE: LIBRARY: } "." } ; diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 611133bacb..7adf837841 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2009 Slava Pestov, Alex Chapman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays alien alien.c-types alien.structs +USING: accessors arrays alien alien.c-types alien.arrays alien.strings kernel math namespaces parser sequences words quotations math.parser splitting grouping effects assocs combinators lexer strings.parser alien.parser @@ -19,26 +19,17 @@ SYNTAX: FUNCTION: (FUNCTION:) define-declared ; SYNTAX: CALLBACK: - "cdecl" (CALLBACK:) define-inline ; - -SYNTAX: STDCALL-CALLBACK: - "stdcall" (CALLBACK:) define-inline ; + (CALLBACK:) define-inline ; SYNTAX: TYPEDEF: scan-c-type CREATE-C-TYPE typedef ; -SYNTAX: C-STRUCT: - scan current-vocab parse-definition define-struct ; deprecated - -SYNTAX: C-UNION: - scan parse-definition define-union ; deprecated - SYNTAX: C-ENUM: ";" parse-tokens [ [ create-in ] dip define-constant ] each-index ; SYNTAX: C-TYPE: - "Primitive C type definition not supported" throw ; + void CREATE-C-TYPE typedef ; ERROR: no-such-symbol name library ; @@ -47,3 +38,12 @@ ERROR: no-such-symbol name library ; SYNTAX: &: scan "c-library" get '[ _ _ address-of ] over push-all ; + +: global-quot ( type word -- quot ) + name>> "c-library" get '[ _ _ address-of 0 ] + swap c-type-getter-boxer append ; + +: define-global ( type word -- ) + [ nip ] [ global-quot ] 2bi (( -- value )) define-declared ; + +SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ; diff --git a/basis/ascii/ascii-docs.factor b/basis/ascii/ascii-docs.factor index b2bbc16836..54e66fea8a 100644 --- a/basis/ascii/ascii-docs.factor +++ b/basis/ascii/ascii-docs.factor @@ -61,18 +61,22 @@ ARTICLE: "ascii" "ASCII" "The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead." $nl "ASCII character classes:" -{ $subsection blank? } -{ $subsection letter? } -{ $subsection LETTER? } -{ $subsection digit? } -{ $subsection printable? } -{ $subsection control? } -{ $subsection quotable? } -{ $subsection ascii? } +{ $subsections + blank? + letter? + LETTER? + digit? + printable? + control? + quotable? + ascii? +} "ASCII case conversion:" -{ $subsection ch>lower } -{ $subsection ch>upper } -{ $subsection >lower } -{ $subsection >upper } ; +{ $subsections + ch>lower + ch>upper + >lower + >upper +} ; ABOUT: "ascii" diff --git a/basis/base64/base64-docs.factor b/basis/base64/base64-docs.factor index 530caab8bd..da2f33c5f9 100644 --- a/basis/base64/base64-docs.factor +++ b/basis/base64/base64-docs.factor @@ -36,12 +36,16 @@ HELP: encode-base64-lines ARTICLE: "base64" "Base 64 conversions" "The " { $vocab-link "base64" } " vocabulary implements conversions of sequences to printable characters in base 64. These plain-text representations of binary data may be passed around and converted back to binary data later." $nl "Converting to and from base64 as strings:" -{ $subsection >base64 } -{ $subsection >base64-lines } -{ $subsection base64> } +{ $subsections + >base64 + >base64-lines + base64> +} "Using base64 from streams:" -{ $subsection encode-base64 } -{ $subsection encode-base64-lines } -{ $subsection decode-base64 } ; +{ $subsections + encode-base64 + encode-base64-lines + decode-base64 +} ; ABOUT: "base64" diff --git a/basis/biassocs/biassocs-docs.factor b/basis/biassocs/biassocs-docs.factor index b55af5b902..5588920f2e 100644 --- a/basis/biassocs/biassocs-docs.factor +++ b/basis/biassocs/biassocs-docs.factor @@ -26,12 +26,16 @@ $nl "Bidirectional assocs implement the entire " { $link "assocs-protocol" } " with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with." $nl "The class of biassocs:" -{ $subsection biassoc } -{ $subsection biassoc? } +{ $subsections + biassoc + biassoc? +} "Creating new biassocs:" -{ $subsection } -{ $subsection } +{ $subsections + + +} "Converting existing assocs to biassocs:" -{ $subsection >biassoc } ; +{ $subsections >biassoc } ; ABOUT: "biassocs" diff --git a/basis/binary-search/binary-search-docs.factor b/basis/binary-search/binary-search-docs.factor index 20b33a0bcb..728ac41e94 100644 --- a/basis/binary-search/binary-search-docs.factor +++ b/basis/binary-search/binary-search-docs.factor @@ -33,11 +33,13 @@ HELP: sorted-memq? ARTICLE: "binary-search" "Binary search" "The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time." -{ $subsection search } +{ $subsections search } "Variants of sequence words optimized for sorted sequences:" -{ $subsection sorted-index } -{ $subsection sorted-member? } -{ $subsection sorted-memq? } +{ $subsections + sorted-index + sorted-member? + sorted-memq? +} { $see-also "order-specifiers" "sequences-sorting" } ; ABOUT: "binary-search" diff --git a/basis/bit-arrays/bit-arrays-docs.factor b/basis/bit-arrays/bit-arrays-docs.factor index fab2a62062..e9c9e1dc51 100644 --- a/basis/bit-arrays/bit-arrays-docs.factor +++ b/basis/bit-arrays/bit-arrays-docs.factor @@ -7,22 +7,30 @@ ARTICLE: "bit-arrays" "Bit arrays" $nl "Bit array words are in the " { $vocab-link "bit-arrays" } " vocabulary." $nl -"Bit arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-byte-arrays" } "." +"Bit arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-pointers" } "." $nl "Bit arrays form a class of objects:" -{ $subsection bit-array } -{ $subsection bit-array? } +{ $subsections + bit-array + bit-array? +} "Creating new bit arrays:" -{ $subsection >bit-array } -{ $subsection } +{ $subsections + >bit-array + +} "Efficiently setting and clearing all bits in a bit array:" -{ $subsection set-bits } -{ $subsection clear-bits } +{ $subsections + set-bits + clear-bits +} "Converting between unsigned integers and their binary representation:" -{ $subsection integer>bit-array } -{ $subsection bit-array>integer } +{ $subsections + integer>bit-array + bit-array>integer +} "Bit array literal syntax:" -{ $subsection POSTPONE: ?{ } ; +{ $subsections POSTPONE: ?{ } ; ABOUT: "bit-arrays" diff --git a/basis/bit-vectors/bit-vectors-docs.factor b/basis/bit-vectors/bit-vectors-docs.factor index 66d3d603fe..f8d5644cf2 100644 --- a/basis/bit-vectors/bit-vectors-docs.factor +++ b/basis/bit-vectors/bit-vectors-docs.factor @@ -6,13 +6,17 @@ ARTICLE: "bit-vectors" "Bit vectors" "A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary." $nl "Bit vectors form a class:" -{ $subsection bit-vector } -{ $subsection bit-vector? } +{ $subsections + bit-vector + bit-vector? +} "Creating bit vectors:" -{ $subsection >bit-vector } -{ $subsection } +{ $subsections + >bit-vector + +} "Literal syntax:" -{ $subsection POSTPONE: ?V{ } +{ $subsections POSTPONE: ?V{ } "If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:" { $code "?V{ } clone" } ; diff --git a/basis/bootstrap/image/image-docs.factor b/basis/bootstrap/image/image-docs.factor index 835c39c171..2d29274556 100644 --- a/basis/bootstrap/image/image-docs.factor +++ b/basis/bootstrap/image/image-docs.factor @@ -3,7 +3,7 @@ IN: bootstrap.image ARTICLE: "bootstrap.image" "Bootstrapping new images" "A new image can be built from source; this is known as " { $emphasis "bootstrap" } ". Bootstrap is a two-step process. The first stage is the creation of a bootstrap image from a running Factor instance:" -{ $subsection make-image } +{ $subsections make-image } "The second bootstrapping stage is initiated by running the resulting bootstrap image:" { $code "./factor -i=boot.x86.32.image" } "This stage loads additional code, compiles all words, and dumps a final " { $snippet "factor.image" } "." diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index ee081a14ca..eee65c1eba 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -163,6 +163,7 @@ USERENV: jit-3dip 40 USERENV: jit-execute-word 41 USERENV: jit-execute-jump 42 USERENV: jit-execute-call 43 +USERENV: jit-declare-word 44 ! PIC stubs USERENV: pic-load 47 @@ -493,6 +494,7 @@ M: quotation ' \ inline-cache-miss-tail \ pic-miss-tail-word set \ mega-cache-lookup \ mega-lookup-word set \ mega-cache-miss \ mega-miss-word set + \ declare jit-declare-word set [ undefined ] undefined-quot set ; : emit-userenvs ( -- ) diff --git a/basis/boxes/boxes-docs.factor b/basis/boxes/boxes-docs.factor index df1abe992b..7b28682910 100644 --- a/basis/boxes/boxes-docs.factor +++ b/basis/boxes/boxes-docs.factor @@ -24,14 +24,16 @@ HELP: ?box ARTICLE: "boxes" "Boxes" "A " { $emphasis "box" } " is a container which can either be empty or hold a single value." -{ $subsection box } +{ $subsections box } "Creating an empty box:" -{ $subsection } +{ $subsections } "Storing a value and removing a value from a box:" -{ $subsection >box } -{ $subsection box> } +{ $subsections + >box + box> +} "Safely removing a value:" -{ $subsection ?box } +{ $subsections ?box } "Testing if a box is full can be done by reading the " { $snippet "occupied" } " slot." ; ABOUT: "boxes" diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 71e052bb6c..8cb1e751b2 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -520,125 +520,142 @@ HELP: since-1970 ARTICLE: "calendar" "Calendar" "The two data types used throughout the calendar library:" -{ $subsection timestamp } -{ $subsection duration } +{ $subsections + timestamp + duration +} "Durations represent spans of time:" -{ $subsection "using-durations" } +{ $subsections "using-durations" } "Arithmetic on timestamps and durations:" -{ $subsection "timestamp-arithmetic" } +{ $subsections "timestamp-arithmetic" } "Getting the current timestamp:" -{ $subsection now } -{ $subsection gmt } +{ $subsections + now + gmt +} "Converting between timestamps:" -{ $subsection >local-time } -{ $subsection >gmt } +{ $subsections + >local-time + >gmt +} "Converting between timezones:" -{ $subsection convert-timezone } +{ $subsections convert-timezone } "Timestamps relative to each other:" -{ $subsection "relative-timestamps" } +{ $subsections "relative-timestamps" } "Operations on units of time:" -{ $subsection "years" } -{ $subsection "months" } -{ $subsection "days" } +{ $subsections + "years" + "months" + "days" +} "Meta-data about the calendar:" -{ $subsection "calendar-facts" } +{ $subsections "calendar-facts" } ; ARTICLE: "timestamp-arithmetic" "Timestamp arithmetic" "Adding timestamps and durations, or durations and durations:" -{ $subsection time+ } +{ $subsections time+ } "Subtracting:" -{ $subsection time- } +{ $subsections time- } "Element-wise multiplication:" -{ $subsection time* } ; +{ $subsections time* } ; ARTICLE: "using-durations" "Using durations" "Creating a duration object:" -{ $subsection years } -{ $subsection months } -{ $subsection weeks } -{ $subsection days } -{ $subsection hours } -{ $subsection minutes } -{ $subsection seconds } -{ $subsection milliseconds } -{ $subsection microseconds } -{ $subsection nanoseconds } -{ $subsection instant } +{ $subsections + years + months + weeks + days + hours + minutes + seconds + milliseconds + microseconds + nanoseconds + instant +} "Converting a duration to a number:" -{ $subsection duration>years } -{ $subsection duration>months } -{ $subsection duration>days } -{ $subsection duration>hours } -{ $subsection duration>minutes } -{ $subsection duration>seconds } -{ $subsection duration>milliseconds } -{ $subsection duration>microseconds } -{ $subsection duration>nanoseconds } ; +{ $subsections + duration>years + duration>months + duration>days + duration>hours + duration>minutes + duration>seconds + duration>milliseconds + duration>microseconds + duration>nanoseconds +} ; ARTICLE: "relative-timestamps" "Relative timestamps" "In the future:" -{ $subsection hence } +{ $subsections hence } "In the past:" -{ $subsection ago } +{ $subsections ago } "Invert a duration:" -{ $subsection before } +{ $subsections before } "Days of the week relative to " { $link now } ":" -{ $subsection sunday } -{ $subsection monday } -{ $subsection tuesday } -{ $subsection wednesday } -{ $subsection thursday } -{ $subsection friday } -{ $subsection saturday } +{ $subsections + sunday + monday + tuesday + wednesday + thursday + friday + saturday +} "New timestamps relative to calendar events:" -{ $subsection beginning-of-year } -{ $subsection beginning-of-month } -{ $subsection beginning-of-week } -{ $subsection midnight } -{ $subsection noon } -; +{ $subsections + beginning-of-year + beginning-of-month + beginning-of-week + midnight + noon +} ; ARTICLE: "days" "Day operations" "Naming days:" -{ $subsection day-abbreviation2 } -{ $subsection day-abbreviations2 } -{ $subsection day-abbreviation3 } -{ $subsection day-abbreviations3 } -{ $subsection day-name } -{ $subsection day-names } +{ $subsections + day-abbreviation2 + day-abbreviations2 + day-abbreviation3 + day-abbreviations3 + day-name + day-names +} "Calculating a Julian day number:" -{ $subsection julian-day-number } +{ $subsections julian-day-number } "Calculate a timestamp:" -{ $subsection julian-day-number>date } -; +{ $subsections julian-day-number>date } ; ARTICLE: "calendar-facts" "Calendar facts" "Calendar facts:" -{ $subsection average-month } -{ $subsection months-per-year } -{ $subsection days-per-year } -{ $subsection hours-per-year } -{ $subsection minutes-per-year } -{ $subsection seconds-per-year } -{ $subsection days-in-month } -{ $subsection day-of-year } -{ $subsection day-of-week } -; +{ $subsections + average-month + months-per-year + days-per-year + hours-per-year + minutes-per-year + seconds-per-year + days-in-month + day-of-year + day-of-week +} ; ARTICLE: "years" "Year operations" "Leap year predicate:" -{ $subsection leap-year? } +{ $subsections leap-year? } "Find the number of days in a year:" -{ $subsection days-in-year } -; +{ $subsections days-in-year } ; ARTICLE: "months" "Month operations" "Naming months:" -{ $subsection month-name } -{ $subsection month-names } -{ $subsection month-abbreviation } -{ $subsection month-abbreviations } -; +{ $subsections + month-name + month-names + month-abbreviation + month-abbreviations +} ; ABOUT: "calendar" diff --git a/basis/channels/channels-docs.factor b/basis/channels/channels-docs.factor index b6ddc299e5..09dac901fe 100644 --- a/basis/channels/channels-docs.factor +++ b/basis/channels/channels-docs.factor @@ -37,10 +37,10 @@ HELP: from ARTICLE: "channels" "Channels" "The " { $vocab-link "channels" } " vocabulary provides a simple abstraction to send and receive objects." $nl "Opening a channel:" -{ $subsection } +{ $subsections } "Sending a message:" -{ $subsection to } +{ $subsections to } "Receiving a message:" -{ $subsection from } ; +{ $subsections from } ; ABOUT: "channels" diff --git a/basis/checksums/adler-32/adler-32-docs.factor b/basis/checksums/adler-32/adler-32-docs.factor index 3e4e5d8210..c31b52668d 100644 --- a/basis/checksums/adler-32/adler-32-docs.factor +++ b/basis/checksums/adler-32/adler-32-docs.factor @@ -6,6 +6,6 @@ HELP: adler-32 ARTICLE: "checksums.adler-32" "Adler-32 checksum" "The Adler-32 checksum algorithm implements simple and fast checksum. It is used in zlib and rsync." -{ $subsection adler-32 } ; +{ $subsections adler-32 } ; ABOUT: "checksums.adler-32" diff --git a/basis/checksums/fnv1/fnv1-docs.factor b/basis/checksums/fnv1/fnv1-docs.factor index 4fbecd2b75..1c242a6591 100644 --- a/basis/checksums/fnv1/fnv1-docs.factor +++ b/basis/checksums/fnv1/fnv1-docs.factor @@ -44,24 +44,29 @@ HELP: fnv1a-1024 ARTICLE: "checksums.fnv1" "Fowler-Noll-Vo checksum" "The Fowler-Noll-Vo checksum algorithm is another simple and fast checksum. It comes in 32, 64, 128, 256, 512 and 1024-bit versions, each in 1 and 1a variants. The 1a variants tend to produce a slightly better result. See http://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash for more details." - - { $subsection fnv1-32 } - { $subsection fnv1a-32 } - - { $subsection fnv1-64 } - { $subsection fnv1a-64 } - - { $subsection fnv1-128 } - { $subsection fnv1a-128 } - - { $subsection fnv1-256 } - { $subsection fnv1a-256 } - - { $subsection fnv1-512 } - { $subsection fnv1a-512 } - - { $subsection fnv1-1024 } - { $subsection fnv1a-1024 } - ; +{ $subsections + fnv1-32 + fnv1a-32 +} +{ $subsections + fnv1-64 + fnv1a-64 +} +{ $subsections + fnv1-128 + fnv1a-128 +} +{ $subsections + fnv1-256 + fnv1a-256 +} +{ $subsections + fnv1-512 + fnv1a-512 +} +{ $subsections + fnv1-1024 + fnv1a-1024 +} ; ABOUT: "checksums.fnv1" diff --git a/basis/checksums/md5/md5-docs.factor b/basis/checksums/md5/md5-docs.factor index 4e475b18a0..c395133152 100644 --- a/basis/checksums/md5/md5-docs.factor +++ b/basis/checksums/md5/md5-docs.factor @@ -6,6 +6,6 @@ HELP: md5 ARTICLE: "checksums.md5" "MD5 checksum" "The MD5 checksum algorithm implements a one-way hash function. While it is widely used, many weaknesses are known and it should not be used in new applications (" { $url "http://www.schneier.com/blog/archives/2005/03/more_hash_funct.html" } ")." -{ $subsection md5 } ; +{ $subsections md5 } ; ABOUT: "checksums.md5" diff --git a/basis/checksums/md5/md5-tests.factor b/basis/checksums/md5/md5-tests.factor index 730c0b8516..45dc253c86 100644 --- a/basis/checksums/md5/md5-tests.factor +++ b/basis/checksums/md5/md5-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays checksums checksums.md5 io.encodings.binary -io.streams.byte-array kernel math namespaces tools.test ; +io.streams.byte-array kernel math namespaces tools.test +sequences ; IN: checksums.md5.tests [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test @@ -33,3 +34,9 @@ IN: checksums.md5.tests "asdf" binary add-checksum-stream [ get-checksum ] [ get-checksum ] bi = ] unit-test + +[ + t +] [ + { "abcd" "efg" } md5 checksum-lines length 16 = +] unit-test diff --git a/basis/checksums/openssl/openssl-docs.factor b/basis/checksums/openssl/openssl-docs.factor index 27df72c4ea..acee0e1ef1 100644 --- a/basis/checksums/openssl/openssl-docs.factor +++ b/basis/checksums/openssl/openssl-docs.factor @@ -21,14 +21,16 @@ HELP: unknown-digest ARTICLE: "checksums.openssl" "OpenSSL checksums" "The OpenSSL library provides a large number of efficient checksum (message digest) algorithms which may be used independently of its SSL functionality." -{ $subsection openssl-checksum } +{ $subsections openssl-checksum } "Constructing a checksum from a known name:" -{ $subsection } +{ $subsections } "Two utility words:" -{ $subsection openssl-md5 } -{ $subsection openssl-sha1 } +{ $subsections + openssl-md5 + openssl-sha1 +} "An error thrown if the digest name is unrecognized:" -{ $subsection unknown-digest } +{ $subsections unknown-digest } "An example where we compute the SHA1 checksum of a string using the OpenSSL implementation of SHA1:" { $example "USING: byte-arrays checksums checksums.openssl ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } "If we use the Factor implementation, we get the same result, just slightly slower:" diff --git a/basis/checksums/openssl/openssl.factor b/basis/checksums/openssl/openssl.factor index bc70230fd0..095ab38ace 100644 --- a/basis/checksums/openssl/openssl.factor +++ b/basis/checksums/openssl/openssl.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov +! copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors byte-arrays alien.c-types alien.data kernel continuations destructors sequences io openssl openssl.libcrypto @@ -23,10 +23,10 @@ TUPLE: evp-md-context < disposable handle ; : ( -- ctx ) evp-md-context new-disposable - EVP_MD_CTX dup EVP_MD_CTX_init >>handle ; + EVP_MD_CTX_create >>handle ; M: evp-md-context dispose* - handle>> EVP_MD_CTX_cleanup drop ; + handle>> EVP_MD_CTX_destroy ; : with-evp-md-context ( quot -- ) maybe-init-ssl [ ] dip with-disposal ; inline diff --git a/basis/checksums/sha/sha-docs.factor b/basis/checksums/sha/sha-docs.factor index 780c2b39d8..44d5072536 100644 --- a/basis/checksums/sha/sha-docs.factor +++ b/basis/checksums/sha/sha-docs.factor @@ -10,9 +10,11 @@ HELP: sha-256 ARTICLE: "checksums.sha" "SHA-2 checksum" "The SHA family of checksum algorithms are one-way hashes useful for checksumming data. SHA-1 is considered insecure, while SHA-2 It is generally considered to be pretty strong." $nl "SHA-2 checksums:" -{ $subsection sha-224 } -{ $subsection sha-256 } +{ $subsections + sha-224 + sha-256 +} "SHA-1 checksum:" -{ $subsection sha1 } ; +{ $subsections sha1 } ; ABOUT: "checksums.sha" diff --git a/basis/circular/circular-docs.factor b/basis/circular/circular-docs.factor index 235d5db2c7..8abadfadd2 100644 --- a/basis/circular/circular-docs.factor +++ b/basis/circular/circular-docs.factor @@ -51,14 +51,20 @@ HELP: rotate-circular ARTICLE: "circular" "Circular sequences" "The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl "Creating a new circular object:" -{ $subsection } -{ $subsection } -{ $subsection } +{ $subsections + + + +} "Changing the start index:" -{ $subsection change-circular-start } -{ $subsection rotate-circular } +{ $subsections + change-circular-start + rotate-circular +} "Pushing new elements:" -{ $subsection push-circular } -{ $subsection push-growing-circular } ; +{ $subsections + push-circular + push-growing-circular +} ; ABOUT: "circular" diff --git a/basis/classes/struct/bit-accessors/bit-accessors-tests.factor b/basis/classes/struct/bit-accessors/bit-accessors-tests.factor new file mode 100644 index 0000000000..e2ff6dbd9c --- /dev/null +++ b/basis/classes/struct/bit-accessors/bit-accessors-tests.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: classes.struct.bit-accessors tools.test effects kernel random stack-checker ; +IN: classes.struct.bit-accessors.test + +[ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test +[ t ] [ 20 random 20 random bit-writer infer (( n alien -- )) effect= ] unit-test diff --git a/basis/classes/struct/bit-accessors/bit-accessors.factor b/basis/classes/struct/bit-accessors/bit-accessors.factor new file mode 100644 index 0000000000..c535e52c0a --- /dev/null +++ b/basis/classes/struct/bit-accessors/bit-accessors.factor @@ -0,0 +1,46 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences math fry locals math.order alien.accessors ; +IN: classes.struct.bit-accessors + +! Bitfield accessors are little-endian on all platforms +! Why not? It's unspecified in C + +: ones-between ( start end -- n ) + [ 2^ 1 - ] bi@ swap bitnot bitand ; + +:: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' ) + offset 8 /mod :> start-bit :> i + start-bit bits + 8 min :> end-bit + start-bit end-bit ones-between :> mask + end-bit start-bit - :> used-bits + + i mask start-bit step-quot call( i mask start-bit -- quot ) + used-bits + i 1 + 8 * + bits used-bits - ; inline + +:: bit-manipulator ( offset bits + step-quot: ( i mask start-bit -- quot ) + combine-quot: ( prev-quot shift-amount next-quot -- quot ) + -- quot ) + offset bits step-quot manipulate-bits + dup zero? [ 3drop ] [ + step-quot combine-quot bit-manipulator + combine-quot call( prev shift next -- quot ) + ] if ; inline recursive + +: bit-reader ( offset bits -- quot: ( alien -- n ) ) + [ neg '[ _ alien-unsigned-1 _ bitand _ shift ] ] + [ swap '[ _ _ bi _ shift bitor ] ] + bit-manipulator ; + +:: write-bits ( n alien i mask start-bit -- ) + n start-bit shift mask bitand + alien i alien-unsigned-1 mask bitnot bitand + bitor alien i set-alien-unsigned-1 ; inline + +: bit-writer ( offset bits -- quot: ( n alien -- ) ) + [ '[ _ _ _ write-bits ] ] + [ '[ _ [ [ _ neg shift ] dip @ ] 2bi ] ] + bit-manipulator ; diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor index 43d24e5716..b7b51432dd 100644 --- a/basis/classes/struct/prettyprint/prettyprint.factor +++ b/basis/classes/struct/prettyprint/prettyprint.factor @@ -23,6 +23,11 @@ IN: classes.struct.prettyprint [ type>> pprint-c-type ] [ read-only>> [ \ read-only pprint-word ] when ] [ initial>> [ \ initial: pprint-word pprint* ] when* ] + [ + dup struct-bit-slot-spec? + [ \ bits: pprint-word bits>> pprint* ] + [ drop ] if + ] } cleave block> \ } pprint-word block> ; diff --git a/basis/classes/struct/struct-docs.factor b/basis/classes/struct/struct-docs.factor index 8a67f00354..1a5294992e 100644 --- a/basis/classes/struct/struct-docs.factor +++ b/basis/classes/struct/struct-docs.factor @@ -95,21 +95,84 @@ HELP: struct HELP: struct-class { $class-description "The metaclass of all " { $link struct } " classes." } ; -ARTICLE: "classes.struct" "Struct classes" -{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:" -{ $subsection POSTPONE: STRUCT: } +ARTICLE: "classes.struct.examples" "Struct class examples" +"A struct with a variety of fields:" +{ $code + "USING: alien.c-types classes.struct ;" + "" + "STRUCT: test-struct" + " { i int }" + " { chicken char[16] }" + " { data void* } ;" +} +"Creating a new instance of this struct, and printing out:" +{ $code "test-struct ." } +"Creating a new instance with slots initialized from the stack:" +{ $code + "USING: libc specialized-arrays ;" + "SPECIALIZED-ARRAY: char" + "" + "42" + "\"Hello, chicken.\" >char-array" + "1024 malloc" + "test-struct ." +} ; + +ARTICLE: "classes.struct.define" "Defining struct classes" +"Struct classes are defined using a syntax similar to the " { $link POSTPONE: TUPLE: } " syntax for defining tuple classes:" +{ $subsections POSTPONE: STRUCT: } +"Union structs are also supported, which behave like structs but share the same memory for all the slots." +{ $subsections POSTPONE: UNION-STRUCT: } ; + +ARTICLE: "classes.struct.create" "Creating instances of structs" "Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:" -{ $subsection } -{ $subsection } -{ $subsection malloc-struct } -{ $subsection memory>struct } +{ $subsections + + + malloc-struct + memory>struct +} "When the contents of a struct will be immediately reset, faster primitive words are available that will create a struct without initializing its contents:" -{ $subsection (struct) } -{ $subsection (malloc-struct) } -"Structs have literal syntax like tuples:" -{ $subsection POSTPONE: S{ } -"Union structs are also supported, which behave like structs but share the same memory for all the type's slots." -{ $subsection POSTPONE: UNION-STRUCT: } -; +{ $subsections + (struct) + (malloc-struct) +} +"Structs have literal syntax, similar to " { $link POSTPONE: T{ } " for tuples:" +{ $subsections POSTPONE: S{ } ; + +ARTICLE: "classes.struct.c" "Passing structs to C functions" +"Structs can be passed and returned by value, or by reference." +$nl +"If a parameter is declared with a struct type, the parameter is passed by value. To pass a struct by reference, declare a parameter with a pointer to struct type." +$nl +"If a C function is declared as returning a struct type, the struct is returned by value, and wrapped in an instance of the correct struct class automatically. If a C function is declared as returning a pointer to a struct, it will return an " { $link alien } " instance. This is because there is no way to distinguish between a pointer to a single struct and a pointer to an array of zero or more structs. It is up to the caller to wrap it in a struct, or a specialized array of structs, respectively." +$nl +"An example of a struct declaration:" +{ $code + "USING: alien.c-types classes.struct ;" + "" + "STRUCT: Point" + " { x int }" + " { y int }" + " { z int } ;" +} +"A C function which returns a struct by value:" +{ $code + "USING: alien.syntax ;" + "FUNCTION: Point give_me_a_point ( char* description ) ;" +} +"A C function which takes a struct parameter by reference:" +{ $code + "FUNCTION: void print_point ( Point* p ) ;" +} ; + +ARTICLE: "classes.struct" "Struct classes" +"The " { $vocab-link "classes.struct" } " vocabulary implements " { $link struct } " classes. They are similar to " { $link tuple } " classes, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for space-efficient storage of data in the Factor heap, as well as for passing data to and from C libraries using the " { $link "alien" } "." +{ $subsections + "classes.struct.examples" + "classes.struct.define" + "classes.struct.create" + "classes.struct.c" +} ; ABOUT: "classes.struct" diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index b60bfa375b..58ab2df80b 100755 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types alien.data ascii assocs byte-arrays classes.struct classes.tuple.private combinators compiler.tree.debugger compiler.units destructors io.encodings.utf8 io.pathnames io.streams.string kernel libc -literals math mirrors multiline namespaces prettyprint +literals math mirrors namespaces prettyprint prettyprint.config see sequences specialized-arrays system tools.test parser lexer eval layouts ; FROM: math => float ; @@ -183,18 +183,18 @@ STRUCT: struct-test-string-ptr ] with-scope ] unit-test -[ <" USING: alien.c-types classes.struct ; +[ "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-foo { x char initial: 0 } { y int initial: 123 } { z bool } ; -"> ] +" ] [ [ struct-test-foo see ] with-string-writer ] unit-test -[ <" USING: alien.c-types classes.struct ; +[ "USING: alien.c-types classes.struct ; IN: classes.struct.tests UNION-STRUCT: struct-test-float-and-bits { f float initial: 0.0 } { bits uint initial: 0 } ; -"> ] +" ] [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test [ { @@ -352,3 +352,16 @@ STRUCT: struct-that's-a-word { x int } ; ] unit-test [ f ] [ "a-struct" c-types get key? ] unit-test + +STRUCT: bit-field-test + { a uint bits: 12 } + { b int bits: 2 } + { c char } ; + +[ S{ bit-field-test f 0 0 0 } ] [ bit-field-test ] unit-test +[ S{ bit-field-test f 1 -2 3 } ] [ bit-field-test 1 >>a 2 >>b 3 >>c ] unit-test +[ 4095 ] [ bit-field-test 8191 >>a a>> ] unit-test +[ 1 ] [ bit-field-test 1 >>b b>> ] unit-test +[ -2 ] [ bit-field-test 2 >>b b>> ] unit-test +[ 1 ] [ bit-field-test 257 >>c c>> ] unit-test +[ 3 ] [ bit-field-test heap-size ] unit-test diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 7e99328652..af23834383 100755 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -1,4 +1,4 @@ -! (c)Joe Groff bsd license +! (c)Joe Groff, Daniel Ehrenberg bsd license USING: accessors alien alien.c-types alien.data alien.parser arrays byte-arrays classes classes.parser classes.tuple classes.tuple.parser classes.tuple.private combinators combinators.short-circuit @@ -6,7 +6,9 @@ combinators.smart cpu.architecture definitions functors.backend fry generalizations generic.parser kernel kernel.private lexer libc locals macros make math math.order parser quotations sequences slots slots.private specialized-arrays vectors words -summary namespaces assocs vocabs.parser ; +summary namespaces assocs vocabs.parser math.functions +classes.struct.bit-accessors bit-arrays ; +QUALIFIED: math IN: classes.struct SPECIALIZED-ARRAY: uchar @@ -22,14 +24,19 @@ TUPLE: struct TUPLE: struct-slot-spec < slot-spec type ; +! For a struct-bit-slot-spec, offset is in bits, not bytes +TUPLE: struct-bit-slot-spec < struct-slot-spec + bits signed? ; + PREDICATE: struct-class < tuple-class superclass \ struct eq? ; M: struct-class valid-superclass? drop f ; -GENERIC: struct-slots ( struct-class -- slots ) +SLOT: fields -M: struct-class struct-slots "struct-slots" word-prop ; +: struct-slots ( struct-class -- slots ) + "c-type" word-prop fields>> ; ! struct allocation @@ -83,14 +90,36 @@ MACRO: ( class -- quot: ( ... -- struct ) ) : pad-struct-slots ( values class -- values' class ) [ struct-slots [ initial>> ] map over length tail append ] keep ; -: (reader-quot) ( slot -- quot ) +: sign-extend ( n bits -- n' ) + ! formula from: + ! http://guru.multimedia.cx/fast-sign-extension/ + 1 - -1 swap shift [ + ] keep bitxor ; inline + +: sign-extender ( signed? bits -- quot ) + '[ _ [ _ sign-extend ] when ] ; + +GENERIC: (reader-quot) ( slot -- quot ) + +M: struct-slot-spec (reader-quot) [ type>> c-type-getter-boxer ] [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; -: (writer-quot) ( slot -- quot ) +M: struct-bit-slot-spec (reader-quot) + [ [ offset>> ] [ bits>> ] bi bit-reader ] + [ [ signed?>> ] [ bits>> ] bi sign-extender ] + bi compose + [ >c-ptr ] prepose ; + +GENERIC: (writer-quot) ( slot -- quot ) + +M: struct-slot-spec (writer-quot) [ type>> c-setter ] [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; +M: struct-bit-slot-spec (writer-quot) + [ offset>> ] [ bits>> ] bi bit-writer + [ >c-ptr ] prepose ; + : (boxer-quot) ( class -- quot ) '[ _ memory>struct ] ; @@ -103,6 +132,8 @@ M: struct-class boa>object [ ] [ struct-slots ] bi [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ; +M: struct-class initial-value* ; inline + ! Struct slot accessors GENERIC: struct-slot-values ( struct -- sequence ) @@ -113,6 +144,9 @@ M: struct-class reader-quot M: struct-class writer-quot nip (writer-quot) ; +: offset-of ( field struct -- offset ) + struct-slots slot-named offset>> ; inline + ! c-types TUPLE: struct-c-type < abstract-c-type @@ -170,31 +204,34 @@ M: struct-c-type c-struct? drop t ; [ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi define-inline-method ; -: c-type-for-class ( class -- c-type ) - struct-c-type new swap { - [ drop byte-array >>class ] - [ >>boxed-class ] - [ struct-slots >>fields ] - [ "struct-size" word-prop >>size ] - [ "struct-align" word-prop >>align ] - [ (unboxer-quot) >>unboxer-quot ] - [ (boxer-quot) >>boxer-quot ] - } cleave ; +:: c-type-for-class ( class slots size align -- c-type ) + struct-c-type new + byte-array >>class + class >>boxed-class + slots >>fields + size >>size + align >>align + class (unboxer-quot) >>unboxer-quot + class (boxer-quot) >>boxer-quot ; -: align-offset ( offset class -- offset' ) - c-type-align align ; +GENERIC: align-offset ( offset class -- offset' ) + +M: struct-slot-spec align-offset + [ type>> c-type-align 8 * align ] keep + [ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ; + +M: struct-bit-slot-spec align-offset + [ (>>offset) ] [ bits>> + ] 2bi ; : struct-offsets ( slots -- size ) - 0 [ - [ type>> align-offset ] keep - [ (>>offset) ] [ type>> heap-size + ] 2bi - ] reduce ; + 0 [ align-offset ] reduce 8 align 8 /i ; : union-struct-offsets ( slots -- size ) - [ 0 >>offset type>> heap-size ] [ max ] map-reduce ; + 1 [ 0 >>offset type>> heap-size max ] reduce ; : struct-align ( slots -- align ) - [ type>> c-type-align ] [ max ] map-reduce ; + [ struct-bit-slot-spec? not ] filter + 1 [ type>> c-type-align max ] reduce ; PRIVATE> M: struct byte-length class "struct-size" word-prop ; foldable @@ -202,50 +239,55 @@ M: struct byte-length class "struct-size" word-prop ; foldable ! class definition c-ptr ] bi + [ *uchar zero? ] curry all? ; + +: struct-needs-prototype? ( class -- ? ) + struct-slots [ initial>> binary-zero? ] all? not ; + : make-struct-prototype ( class -- prototype ) - [ "struct-size" word-prop ] - [ memory>struct ] - [ struct-slots ] tri - [ - [ initial>> ] - [ (writer-quot) ] bi - over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if - ] each ; + dup struct-needs-prototype? [ + [ "c-type" word-prop size>> ] + [ memory>struct ] + [ struct-slots ] tri + [ + [ initial>> ] + [ (writer-quot) ] bi + over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if + ] each + ] [ drop f ] if ; : (struct-methods) ( class -- ) [ (define-struct-slot-values-method) ] [ (define-clone-method) ] bi ; -: (struct-word-props) ( class slots size align -- ) - [ - [ "struct-slots" set-word-prop ] - [ define-accessors ] 2bi - ] - [ "struct-size" set-word-prop ] - [ "struct-align" set-word-prop ] tri-curry* - [ tri ] 3curry - [ dup make-struct-prototype "prototype" set-word-prop ] - [ (struct-methods) ] tri ; - : check-struct-slots ( slots -- ) [ type>> c-type drop ] each ; : redefine-struct-tuple-class ( class -- ) [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ; -: (define-struct-class) ( class slots offsets-quot -- ) - [ - empty? - [ struct-must-have-slots ] - [ redefine-struct-tuple-class ] if - ] - swap '[ - make-slots dup - [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri - (struct-word-props) - ] - [ drop [ c-type-for-class ] keep typedef ] 2tri ; inline +:: (define-struct-class) ( class slots offsets-quot -- ) + slots empty? [ struct-must-have-slots ] when + class redefine-struct-tuple-class + slots make-slots dup check-struct-slots :> slot-specs + slot-specs struct-align :> alignment + slot-specs offsets-quot call alignment align :> size + + class slot-specs size alignment c-type-for-class :> c-type + + c-type class typedef + class slot-specs define-accessors + class size "struct-size" set-word-prop + class dup make-struct-prototype "prototype" set-word-prop + class (struct-methods) ; inline PRIVATE> : define-struct-class ( class slots -- ) @@ -263,11 +305,43 @@ ERROR: invalid-struct-slot token ; c-type c-type-boxed-class dup \ byte-array = [ drop \ c-ptr ] when ; +SYMBOL: bits: + +>bits + slot-spec type>> { + { int [ t ] } + { uint [ f ] } + [ bad-type-for-bits ] + } case >>signed? + slot-spec name>> >>name + slot-spec class>> >>class + slot-spec type>> >>type + slot-spec read-only>> >>read-only + slot-spec initial>> >>initial ; + +: peel-off-struct-attributes ( slot-spec array -- slot-spec array ) + dup empty? [ + unclip { + { initial: [ [ first >>initial ] [ rest ] bi ] } + { read-only [ [ t >>read-only ] dip ] } + { bits: [ [ first set-bits ] [ rest ] bi ] } + [ bad-slot-attribute ] + } case + ] unless ; + +PRIVATE> + : ( name c-type attributes -- slot-spec ) [ struct-slot-spec new ] 3dip [ >>name ] [ [ >>type ] [ struct-slot-class >>class ] bi ] - [ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ; + [ [ dup empty? ] [ peel-off-struct-attributes ] until drop ] tri* ; } -{ $subsection POSTPONE: SUPER-> } +{ $subsections + POSTPONE: -> + POSTPONE: SUPER-> +} "These parsing words are actually syntax sugar for a pair of ordinary words; they can be used instead of the parsing words if the selector name is dynamically computed:" -{ $subsection send } -{ $subsection super-send } ; +{ $subsections + send + super-send +} ; ARTICLE: "cocoa" "Cocoa bridge" "The " { $vocab-link "cocoa" } " vocabulary implements a Factor-Cocoa bridge for Mac OS X (GNUstep is not supported)." @@ -41,14 +45,18 @@ $nl "The lowest layer uses the " { $link "alien" } " to define bindings for the various functions in Apple's Objective-C runtime. This is defined in the " { $vocab-link "cocoa.runtime" } " vocabulary." $nl "On top of this, a dynamic message send facility is built:" -{ $subsection "objc-calling" } -{ $subsection "objc-subclassing" } +{ $subsections + "objc-calling" + "objc-subclassing" +} "A utility library is built to faciliate the development of Cocoa applications in Factor:" -{ $subsection "cocoa-application-utils" } -{ $subsection "cocoa-dialogs" } -{ $subsection "cocoa-pasteboard-utils" } -{ $subsection "cocoa-view-utils" } -{ $subsection "cocoa-window-utils" } ; +{ $subsections + "cocoa-application-utils" + "cocoa-dialogs" + "cocoa-pasteboard-utils" + "cocoa-view-utils" + "cocoa-window-utils" +} ; IN: cocoa ABOUT: "cocoa" diff --git a/basis/cocoa/dialogs/dialogs-docs.factor b/basis/cocoa/dialogs/dialogs-docs.factor index 798d8aa135..a1a36c9d32 100644 --- a/basis/cocoa/dialogs/dialogs-docs.factor +++ b/basis/cocoa/dialogs/dialogs-docs.factor @@ -19,11 +19,15 @@ HELP: save-panel ARTICLE: "cocoa-dialogs" "Cocoa file dialogs" "Open dialogs:" -{ $subsection } -{ $subsection open-panel } +{ $subsections + + open-panel +} "Save dialogs:" -{ $subsection } -{ $subsection save-panel } ; +{ $subsections + + save-panel +} ; IN: cocoa.dialogs ABOUT: "cocoa-dialogs" diff --git a/basis/cocoa/pasteboard/pasteboard-docs.factor b/basis/cocoa/pasteboard/pasteboard-docs.factor index ca64b1e136..f63bc0ec47 100644 --- a/basis/cocoa/pasteboard/pasteboard-docs.factor +++ b/basis/cocoa/pasteboard/pasteboard-docs.factor @@ -14,9 +14,11 @@ HELP: set-pasteboard-string { $description "Sets the contents of the pasteboard." } ; ARTICLE: "cocoa-pasteboard-utils" "Cocoa pasteboard utilities" -{ $subsection pasteboard-string? } -{ $subsection pasteboard-string } -{ $subsection set-pasteboard-string } ; +{ $subsections + pasteboard-string? + pasteboard-string + set-pasteboard-string +} ; IN: cocoa.pasteboard ABOUT: "cocoa-pasteboard-utils" diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor index 28d812a489..f02f1f6182 100644 --- a/basis/cocoa/runtime/runtime.factor +++ b/basis/cocoa/runtime/runtime.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct ; IN: cocoa.runtime TYPEDEF: void* SEL diff --git a/basis/cocoa/subclassing/subclassing-docs.factor b/basis/cocoa/subclassing/subclassing-docs.factor index 6924777d3d..181912b0f0 100644 --- a/basis/cocoa/subclassing/subclassing-docs.factor +++ b/basis/cocoa/subclassing/subclassing-docs.factor @@ -37,9 +37,9 @@ HELP: CLASS: ARTICLE: "objc-subclassing" "Subclassing Objective C classes" "Objective C classes can be subclassed, with new methods defined in Factor, using a parsing word:" -{ $subsection POSTPONE: CLASS: } +{ $subsections POSTPONE: CLASS: } "This word is actually syntax sugar for an ordinary word:" -{ $subsection define-objc-class } +{ $subsections define-objc-class } "Objective C class definitions are saved in the image. If the image is saved and Factor is restarted with the saved image, custom class definitions are made available to the Objective C runtime when they are first accessed from within Factor." ; IN: cocoa.subclassing diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor index 0e0ef72ad2..1e1ec98245 100644 --- a/basis/cocoa/types/types.factor +++ b/basis/cocoa/types/types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax combinators kernel layouts -classes.struct core-graphics.types ; +classes.struct cocoa.runtime core-graphics.types ; IN: cocoa.types TYPEDEF: long NSInteger diff --git a/basis/cocoa/views/views-docs.factor b/basis/cocoa/views/views-docs.factor index 871326fcd4..4bc92a4c49 100644 --- a/basis/cocoa/views/views-docs.factor +++ b/basis/cocoa/views/views-docs.factor @@ -14,9 +14,11 @@ HELP: mouse-location { $description "Outputs the current mouse location." } ; ARTICLE: "cocoa-view-utils" "Cocoa view utilities" -{ $subsection } -{ $subsection view-dim } -{ $subsection mouse-location } ; +{ $subsections + + view-dim + mouse-location +} ; IN: cocoa.views ABOUT: "cocoa-view-utils" diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index badcac5cdb..585f23dde3 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -40,7 +40,9 @@ CONSTANT: NSOpenGLPFAScreenMask 84 CONSTANT: NSOpenGLPFAPixelBuffer 90 CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96 CONSTANT: NSOpenGLPFAVirtualScreenCount 128 + CONSTANT: NSOpenGLCPSwapInterval 222 +CONSTANT: NSOpenGLCPSurfaceOpacity 236 : ( class dim pixel-format -- view ) [ -> alloc ] diff --git a/basis/cocoa/windows/windows-docs.factor b/basis/cocoa/windows/windows-docs.factor index 690fe9b5aa..d29a379c2e 100644 --- a/basis/cocoa/windows/windows-docs.factor +++ b/basis/cocoa/windows/windows-docs.factor @@ -10,8 +10,10 @@ HELP: { $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions, containing the given view." } ; ARTICLE: "cocoa-window-utils" "Cocoa window utilities" -{ $subsection } -{ $subsection } ; +{ $subsections + + +} ; IN: cocoa.windows ABOUT: "cocoa-window-utils" diff --git a/basis/cocoa/windows/windows.factor b/basis/cocoa/windows/windows.factor index ed2c2d51bd..a4b1b7f210 100644 --- a/basis/cocoa/windows/windows.factor +++ b/basis/cocoa/windows/windows.factor @@ -5,11 +5,12 @@ sequences math.bitwise ; IN: cocoa.windows ! Window styles -CONSTANT: NSBorderlessWindowMask 0 -CONSTANT: NSTitledWindowMask 1 -CONSTANT: NSClosableWindowMask 2 -CONSTANT: NSMiniaturizableWindowMask 4 -CONSTANT: NSResizableWindowMask 8 +CONSTANT: NSBorderlessWindowMask 0 +CONSTANT: NSTitledWindowMask 1 +CONSTANT: NSClosableWindowMask 2 +CONSTANT: NSMiniaturizableWindowMask 4 +CONSTANT: NSResizableWindowMask 8 +CONSTANT: NSTexturedBackgroundWindowMask 256 ! Additional panel-only styles CONSTANT: NSUtilityWindowMask 16 @@ -26,7 +27,7 @@ CONSTANT: NSBackingStoreBuffered 2 -> initWithContentRect:styleMask:backing:defer: ; : class-for-style ( style -- NSWindow/NSPanel ) - HEX: 1ff0 bitand zero? NSWindow NSPanel ? ; + HEX: 1ef0 bitand zero? NSWindow NSPanel ? ; : ( view rect style -- window ) dup class-for-style [ swap -> setContentView: ] keep diff --git a/basis/colors/colors-docs.factor b/basis/colors/colors-docs.factor index 5e2b09380d..53cca50b7a 100644 --- a/basis/colors/colors-docs.factor +++ b/basis/colors/colors-docs.factor @@ -13,7 +13,7 @@ HELP: >rgba ARTICLE: "colors.protocol" "Color protocol" "Abstract superclass for colors:" -{ $subsection color } +{ $subsections color } "All color objects must are required to implement a method on the " { $link >rgba } " generic word." $nl "Optionally, they can provide methods on the accessors " { $link red>> } ", " { $link green>> } ", " { $link blue>> } " and " { $link alpha>> } ", either by defining slots with the appropriate names, or with methods which calculate the color component values. The accessors should return color components which are real numbers in the range between 0 and 1." @@ -24,15 +24,19 @@ ARTICLE: "colors" "Colors" "The " { $vocab-link "colors" } " vocabulary defines a protocol for colors, with a concrete implementation for RGBA colors. This vocabulary is used by " { $vocab-link "io.styles" } ", " { $vocab-link "ui" } " and other vocabularies, but it is independent of them." $nl "RGBA colors with floating point components in the range " { $snippet "[0,1]" } ":" -{ $subsection rgba } -{ $subsection } +{ $subsections + rgba + +} "Converting a color to RGBA:" -{ $subsection >rgba } +{ $subsections >rgba } "Extracting RGBA components of colors:" -{ $subsection >rgba-components } +{ $subsections >rgba-components } "Further topics:" -{ $subsection "colors.protocol" } -{ $subsection "colors.constants" } +{ $subsections + "colors.protocol" + "colors.constants" +} { $vocab-subsection "Grayscale colors" "colors.gray" } { $vocab-subsection "HSV colors" "colors.hsv" } ; diff --git a/basis/colors/constants/constants-docs.factor b/basis/colors/constants/constants-docs.factor index 73dd0c0ccc..650fb88ae2 100644 --- a/basis/colors/constants/constants-docs.factor +++ b/basis/colors/constants/constants-docs.factor @@ -24,8 +24,10 @@ HELP: COLOR: ARTICLE: "colors.constants" "Standard color database" "The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and Factor's " { $snippet "factor-colors.txt" } " theme database to provide words for looking up color values by name." -{ $subsection named-color } -{ $subsection named-colors } -{ $subsection POSTPONE: COLOR: } ; +{ $subsections + named-color + named-colors + POSTPONE: COLOR: +} ; ABOUT: "colors.constants" \ No newline at end of file diff --git a/basis/colors/constants/factor-colors.txt b/basis/colors/constants/factor-colors.txt index b8af9d3949..64a857a2a4 100644 --- a/basis/colors/constants/factor-colors.txt +++ b/basis/colors/constants/factor-colors.txt @@ -4,3 +4,4 @@ 172 167 147 FactorDarkTan 81 91 105 FactorLightSlateBlue 55 62 72 FactorDarkSlateBlue + 0 51 0 FactorDarkGreen diff --git a/basis/colors/gray/gray-docs.factor b/basis/colors/gray/gray-docs.factor index ac0f45e698..4f911f8337 100644 --- a/basis/colors/gray/gray-docs.factor +++ b/basis/colors/gray/gray-docs.factor @@ -3,7 +3,9 @@ IN: colors.gray ARTICLE: "colors.gray" "Grayscale colors" "The " { $vocab-link "colors.gray" } " vocabulary implements grayscale colors. These colors hold a single value, and respond to " { $link red>> } ", " { $link green>> } ", " { $link blue>> } " with that value. They also have an independent alpha channel, " { $link alpha>> } "." -{ $subsection gray } -{ $subsection } ; +{ $subsections + gray + +} ; ABOUT: "colors.gray" \ No newline at end of file diff --git a/basis/colors/hsv/hsv-docs.factor b/basis/colors/hsv/hsv-docs.factor index 4a9d8a9b9b..a4c037d36a 100644 --- a/basis/colors/hsv/hsv-docs.factor +++ b/basis/colors/hsv/hsv-docs.factor @@ -6,8 +6,10 @@ HELP: hsva ARTICLE: "colors.hsv" "HSV colors" "The " { $vocab-link "colors.hsv" } " vocabulary implements colors specified by their hue, saturation, and value, together with an alpha channel." -{ $subsection hsva } -{ $subsection } +{ $subsections + hsva + +} { $see-also "colors" } ; ABOUT: "colors.hsv" \ No newline at end of file diff --git a/basis/columns/columns-docs.factor b/basis/columns/columns-docs.factor index 1dd9257281..242f518d57 100644 --- a/basis/columns/columns-docs.factor +++ b/basis/columns/columns-docs.factor @@ -25,9 +25,11 @@ HELP: ARTICLE: "columns" "Column sequences" "A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:" -{ $subsection column } -{ $subsection } +{ $subsections + column + +} "A utility word:" -{ $subsection } ; +{ $subsections } ; ABOUT: "columns" diff --git a/basis/combinators/short-circuit/short-circuit-docs.factor b/basis/combinators/short-circuit/short-circuit-docs.factor index 5bd364e0e9..ca7c1d53c4 100644 --- a/basis/combinators/short-circuit/short-circuit-docs.factor +++ b/basis/combinators/short-circuit/short-circuit-docs.factor @@ -51,18 +51,24 @@ HELP: n|| ARTICLE: "combinators.short-circuit" "Short-circuit combinators" "The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl "AND combinators:" -{ $subsection 0&& } -{ $subsection 1&& } -{ $subsection 2&& } -{ $subsection 3&& } +{ $subsections + 0&& + 1&& + 2&& + 3&& +} "OR combinators:" -{ $subsection 0|| } -{ $subsection 1|| } -{ $subsection 2|| } -{ $subsection 3|| } +{ $subsections + 0|| + 1|| + 2|| + 3|| +} "Generalized combinators:" -{ $subsection n&& } -{ $subsection n|| } +{ $subsections + n&& + n|| +} ; ABOUT: "combinators.short-circuit" diff --git a/basis/combinators/short-circuit/smart/smart-docs.factor b/basis/combinators/short-circuit/smart/smart-docs.factor index 34abde15b6..941069cc00 100644 --- a/basis/combinators/short-circuit/smart/smart-docs.factor +++ b/basis/combinators/short-circuit/smart/smart-docs.factor @@ -31,8 +31,8 @@ ARTICLE: "combinators.short-circuit.smart" "Smart short-circuit combinators" "The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary is similar to " { $vocab-link "combinators.short-circuit" } " except the combinators here infer the number of inputs that the sequence of quotations takes." $nl "Generalized AND:" -{ $subsection && } +{ $subsections && } "Generalized OR:" -{ $subsection || } ; +{ $subsections || } ; ABOUT: "combinators.short-circuit.smart" diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index 85545a730c..f02da86c20 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel quotations math sequences -multiline stack-checker ; +stack-checker ; IN: combinators.smart HELP: inputarray { $description "Infers the number or outputs from the quotation and constructs an array from those outputs." } { $examples { $example - <" USING: combinators combinators.smart math prettyprint ; + "USING: combinators combinators.smart math prettyprint ; 9 [ { [ 1 - ] [ 1 + ] [ sq ] } cleave -] output>array ."> +] output>array ." "{ 8 10 81 }" } } ; @@ -119,20 +119,26 @@ HELP: keep-inputs ARTICLE: "combinators.smart" "Smart combinators" "A " { $emphasis "smart combinator" } " is a macro which reflects on the stack effect of an input quotation. The " { $vocab-link "combinators.smart" } " vocabulary implements a few simple smart combinators which look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl "Call a quotation and discard all output values or preserve all input values:" -{ $subsection drop-outputs } -{ $subsection keep-inputs } +{ $subsections + drop-outputs + keep-inputs +} "Take all input values from a sequence:" -{ $subsection inputsequence } -{ $subsection output>array } +{ $subsections + output>sequence + output>array +} "Reducing the set of output values:" -{ $subsection reduce-outputs } +{ $subsections reduce-outputs } "Summing output values:" -{ $subsection sum-outputs } +{ $subsections sum-outputs } "Concatenating output values:" -{ $subsection append-outputs } -{ $subsection append-outputs-as } +{ $subsections + append-outputs + append-outputs-as +} "New smart combinators can be created by defining " { $link "macros" } " which call " { $link infer } "." ; ABOUT: "combinators.smart" diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor index 5aeb49d6f2..697f95b14f 100644 --- a/basis/command-line/command-line-docs.factor +++ b/basis/command-line/command-line-docs.factor @@ -25,7 +25,7 @@ HELP: (command-line) { $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ; HELP: command-line -{ $var-description "The command line parameters which follow the name of the script on the command line." } ; +{ $var-description "When Factor is run with a script, this variable contains command line parameters which follow the name of the script on the command line. In deployed applications, it contains the entire command line. In all other cases it is set to " { $link f } "." } ; HELP: main-vocab-hook { $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ; @@ -47,7 +47,6 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM" { { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } } { { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" } { { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" } - { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" } { { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } } { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" } { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" } @@ -99,26 +98,28 @@ ARTICLE: "factor-boot-rc" "Bootstrap initialization file" "The botstrap initialization file is named " { $snippet "factor-boot-rc" } " on Windows and " { $snippet ".factor-boot-rc" } " on Unix. This file can contain " { $link require } " calls for vocabularies you use frequently, and other such long-running tasks that you do not want to perform every time Factor starts." $nl "A word to run this file from an existing Factor session:" -{ $subsection run-bootstrap-init } +{ $subsections run-bootstrap-init } "For example, if you changed " { $snippet ".factor-boot-rc" } " and do not want to bootstrap again, you can just invoke " { $link run-bootstrap-init } " in the listener." ; ARTICLE: "factor-rc" "Startup initialization file" "The startup initialization file is named " { $snippet "factor-rc" } " on Windows and " { $snippet ".factor-rc" } " on Unix. If it exists, it is run every time Factor starts." $nl "A word to run this file from an existing Factor session:" -{ $subsection run-user-init } ; +{ $subsections run-user-init } ; ARTICLE: "factor-roots" "Additional vocabulary roots file" "The vocabulary roots file is named " { $snippet "factor-roots" } " on Windows and " { $snippet ".factor-roots" } " on Unix. If it exists, it is loaded every time Factor starts. It contains a newline-separated list of " { $link "vocabs.roots" } "." $nl "A word to run this file from an existing Factor session:" -{ $subsection load-vocab-roots } ; +{ $subsections load-vocab-roots } ; ARTICLE: "rc-files" "Running code on startup" "Factor looks for three optional files in your home directory." -{ $subsection "factor-boot-rc" } -{ $subsection "factor-rc" } -{ $subsection "factor-roots" } +{ $subsections + "factor-boot-rc" + "factor-rc" + "factor-roots" +} "The " { $snippet "-no-user-init" } " command line switch will inhibit loading running of these files." $nl "If you are unsure where the files should be located, evaluate the following code:" @@ -127,19 +128,17 @@ $nl "\"factor-rc\" rc-path print" "\"factor-boot-rc\" rc-path print" } -"Here is an example " { $snippet ".factor-boot-rc" } " which sets up GVIM editor integration, adds an additional vocabulary root (see " { $link "vocabs.roots" } "), and increases the font size in the UI by setting the DPI (dots-per-inch) variable:" +"Here is an example " { $snippet ".factor-boot-rc" } " which sets up GVIM editor integration:" { $code - "USING: editors.gvim vocabs.loader ui.freetype namespaces sequences ;" + "USING: editors.gvim namespaces ;" "\"/opt/local/bin\" \\ gvim-path set-global" - "\"/home/jane/src/\" vocab-roots get push" - "100 dpi set-global" } ; ARTICLE: "cli" "Command line arguments" "Factor command line usage:" -{ $code "factor [system switches...] [script args...]" } -"Zero or more system switches can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup, any arguments after the script file are stored in a variable, with no further processing by Factor itself:" -{ $subsection command-line } +{ $code "factor [VM args...] [script] [args...]" } +"Zero or more VM arguments can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup, any arguments after the script file are stored in the following variable, with no further processing by Factor itself:" +{ $subsections command-line } "Instead of running a script, it is also possible to run a vocabulary; this invokes the vocabulary's " { $link POSTPONE: MAIN: } " word:" { $code "factor [system switches...] -run=" } "If no script file or " { $snippet "-run=" } " switch is specified, Factor will start " { $link "listener" } " or " { $link "ui-tools" } ", depending on the operating system." @@ -152,12 +151,14 @@ $nl { { $snippet "-no-" { $emphasis "foo" } } " - sets the global variable " { $snippet "\"" { $emphasis "foo" } "\"" } " to " { $link f } } { { $snippet "-" { $emphasis "foo" } "=" { $emphasis "bar" } } " - sets the global variable " { $snippet "\"" { $emphasis "foo" } "\"" } " to " { $snippet "\"" { $emphasis "bar" } "\"" } } } -{ $subsection "runtime-cli-args" } -{ $subsection "bootstrap-cli-args" } -{ $subsection "standard-cli-args" } +{ $subsections + "runtime-cli-args" + "bootstrap-cli-args" + "standard-cli-args" +} "The raw list of command line arguments can also be obtained and inspected directly:" -{ $subsection (command-line) } +{ $subsections (command-line) } "There is a way to override the default vocabulary to run on startup, if no script name or " { $snippet "-run" } " switch is specified:" -{ $subsection main-vocab-hook } ; +{ $subsections main-vocab-hook } ; ABOUT: "cli" diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index cb8b2de543..2303b98aed 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -1,10 +1,17 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math namespaces assocs hashtables sequences arrays -accessors vectors combinators sets classes cpu.architecture -compiler.cfg compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.def-use compiler.cfg.copy-prop compiler.cfg.rpo -compiler.cfg.liveness ; +accessors words vectors combinators combinators.short-circuit +sets classes layouts cpu.architecture +compiler.cfg +compiler.cfg.rpo +compiler.cfg.def-use +compiler.cfg.liveness +compiler.cfg.copy-prop +compiler.cfg.registers +compiler.cfg.comparisons +compiler.cfg.instructions +compiler.cfg.representations.preferred ; IN: compiler.cfg.alias-analysis ! We try to eliminate redundant slot operations using some simple heuristics. @@ -77,10 +84,15 @@ SYMBOL: acs>vregs : ac>vregs ( ac -- vregs ) acs>vregs get at ; -: aliases ( vreg -- vregs ) +GENERIC: aliases ( vreg -- vregs ) + +M: integer aliases #! All vregs which may contain the same value as vreg. vreg>ac ac>vregs ; +M: word aliases + 1array ; + : each-alias ( vreg quot -- ) [ aliases ] dip each ; inline @@ -181,7 +193,6 @@ SYMBOL: constants #! assigned by an ##load-immediate. resolve constants get at ; -! We treat slot accessors and stack traffic alike GENERIC: insn-slot# ( insn -- slot#/f ) GENERIC: insn-object ( insn -- vreg ) @@ -190,7 +201,7 @@ M: ##slot-imm insn-slot# slot>> ; M: ##set-slot insn-slot# slot>> constant ; M: ##set-slot-imm insn-slot# slot>> ; M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ; -M: ##vm-field-ptr insn-slot# fieldname>> 1array ; ! is this right? +M: ##vm-field-ptr insn-slot# field-name>> ; M: ##slot insn-object obj>> resolve ; M: ##slot-imm insn-object obj>> resolve ; @@ -206,18 +217,33 @@ M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ; H{ } clone live-slots set H{ } clone constants set H{ } clone copies set - + 0 ac-counter set next-ac heap-ac set + \ ##vm-field-ptr set-new-ac + \ ##alien-global set-new-ac + dup local-live-in [ set-heap-ac ] each ; GENERIC: analyze-aliases* ( insn -- insn' ) M: insn analyze-aliases* - dup defs-vreg [ set-heap-ac ] when* ; + ! If an instruction defines a value with a non-integer + ! representation it means that the value will be boxed + ! anywhere its used as a tagged pointer. Boxing allocates + ! a new value, except boxing instructions haven't been + ! inserted yet. + dup defs-vreg [ + over defs-vreg-rep int-rep eq? + [ set-heap-ac ] [ set-new-ac ] if + ] when* ; + +M: ##phi analyze-aliases* + dup defs-vreg set-heap-ac ; M: ##load-immediate analyze-aliases* + call-next-method dup [ val>> ] [ dst>> ] bi constants get set-at ; M: ##allocation analyze-aliases* @@ -249,6 +275,19 @@ M: ##copy analyze-aliases* #! vreg, since they both contain the same value. dup record-copy ; +: useless-compare? ( insn -- ? ) + { + [ cc>> cc= eq? ] + [ [ src1>> ] [ src2>> ] bi [ resolve vreg>ac ] bi@ = not ] + } 1&& ; inline + +M: ##compare analyze-aliases* + call-next-method + dup useless-compare? [ + dst>> \ f tag-number \ ##load-immediate new-insn + analyze-aliases* + ] when ; + : analyze-aliases ( insns -- insns' ) [ insn# set analyze-aliases* ] map-index sift ; diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index 90992fcc96..b5510c7142 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -25,7 +25,7 @@ M: stack-frame-insn compute-stack-frame* M: ##call compute-stack-frame* word>> sub-primitive>> [ frame-required? on ] unless ; -M: _gc compute-stack-frame* +M: ##gc compute-stack-frame* frame-required? on stack-frame new swap tagged-values>> length cells >>gc-root-size request-stack-frame ; diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index db0dd65a83..d303cc597f 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -4,6 +4,7 @@ compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker compiler.cfg arrays locals byte-arrays kernel.private math slots.private vectors sbufs strings math.partial-dispatch +hashtables assocs combinators.short-circuit strings.private accessors compiler.cfg.instructions ; IN: compiler.cfg.builder.tests @@ -158,9 +159,12 @@ IN: compiler.cfg.builder.tests { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg ] each -: contains-insn? ( quot insn-check -- ? ) +: count-insns ( quot insn-check -- ? ) [ test-mr [ instructions>> ] map ] dip - '[ _ any? ] any? ; inline + '[ _ count ] sigma ; inline + +: contains-insn? ( quot insn-check -- ? ) + count-insns 0 > ; inline [ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test @@ -196,12 +200,17 @@ IN: compiler.cfg.builder.tests [ f t ] [ [ { byte-array fixnum } declare alien-cell 4 alien-float ] [ [ ##box-alien? ] contains-insn? ] - [ [ ##box-float? ] contains-insn? ] bi + [ [ ##allot? ] contains-insn? ] bi ] unit-test [ f t ] [ [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ] [ [ ##box-alien? ] contains-insn? ] - [ [ ##box-float? ] contains-insn? ] bi + [ [ ##allot? ] contains-insn? ] bi ] unit-test -] when \ No newline at end of file + + [ 1 ] [ [ dup float+ ] [ ##alien-double? ] count-insns ] unit-test +] when + +! Regression. Make sure everything is inlined correctly +[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/comparisons/comparisons.factor b/basis/compiler/cfg/comparisons/comparisons.factor index e7c19e7206..0b4a6f2f02 100644 --- a/basis/compiler/cfg/comparisons/comparisons.factor +++ b/basis/compiler/cfg/comparisons/comparisons.factor @@ -9,6 +9,9 @@ SYMBOLS: cc< cc<= cc= cc> cc>= cc<> cc<>= cc/< cc/<= cc/= cc/> cc/>= cc/<> cc/<>= ; +SYMBOLS: + vcc-all vcc-notall vcc-any vcc-none ; + : negate-cc ( cc -- cc' ) H{ { cc< cc/< } @@ -27,6 +30,14 @@ SYMBOLS: { cc/<>= cc<>= } } at ; +: negate-vcc ( cc -- cc' ) + H{ + { vcc-all vcc-notall } + { vcc-any vcc-none } + { vcc-none vcc-any } + { vcc-notall vcc-all } + } at ; + : swap-cc ( cc -- cc' ) H{ { cc< cc> } diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index d51aa477c9..d4e8c5401a 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -7,10 +7,10 @@ prettyprint.sections parser compiler.tree.builder compiler.tree.optimizer cpu.architecture compiler.cfg.builder compiler.cfg.linearization compiler.cfg.registers compiler.cfg.stack-frame compiler.cfg.linear-scan -compiler.cfg.two-operand compiler.cfg.optimizer -compiler.cfg.instructions compiler.cfg.utilities -compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr -compiler.cfg.representations.preferred compiler.cfg ; +compiler.cfg.optimizer compiler.cfg.instructions +compiler.cfg.utilities compiler.cfg.def-use compiler.cfg.rpo +compiler.cfg.mr compiler.cfg.representations.preferred +compiler.cfg ; IN: compiler.cfg.debugger GENERIC: test-cfg ( quot -- cfgs ) @@ -44,6 +44,9 @@ M: word test-cfg nl ] each ; +: test-mr. ( quot -- ) + test-mr mr. ; inline + ! Prettyprinting : pprint-loc ( loc word -- ) > pprint* block> ; @@ -79,4 +82,4 @@ M: rs-loc pprint* \ R pprint-loc ; [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ] bi [ suffix ] when* ] map concat - ] map concat >hashtable representations set ; \ No newline at end of file + ] map concat >hashtable representations set ; diff --git a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor index 5580de9a47..27d37b115f 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor @@ -16,7 +16,7 @@ V{ } 0 test-bb V{ - T{ ##box-float f 0 1 } + T{ ##box-alien f 0 1 } } 1 test-bb 0 1 edge diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index 21a60768ea..5d3c79e40f 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences assocs fry -cpu.architecture +cpu.architecture layouts compiler.cfg.rpo compiler.cfg.registers compiler.cfg.instructions @@ -17,11 +17,26 @@ IN: compiler.cfg.gc-checks : blocks-with-gc ( cfg -- bbs ) post-order [ insert-gc-check? ] filter ; +GENERIC: allocation-size* ( insn -- n ) + +M: ##allot allocation-size* size>> ; + +M: ##box-alien allocation-size* drop 4 cells ; + +M: ##box-displaced-alien allocation-size* drop 4 cells ; + +: allocation-size ( bb -- n ) + instructions>> [ ##allocation? ] filter [ allocation-size* ] sigma ; + : insert-gc-check ( bb -- ) - dup '[ + dup dup '[ int-rep next-vreg-rep int-rep next-vreg-rep - f f _ uninitialized-locs \ ##gc new-insn + _ allocation-size + f + f + _ uninitialized-locs + \ ##gc new-insn prefix ] change-instructions drop ; diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 1b99b5d4dd..42aa5512bc 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -45,16 +45,15 @@ insn-classes get [ [ next-vreg dup ] dip { { [ dup not ] [ drop \ f tag-number ##load-immediate ] } { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] } + { [ dup float? ] [ ##load-constant ] } [ ##load-reference ] - } cond ; inline - -: ^^unbox-c-ptr ( src class -- dst ) - [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ; inline - -: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline -: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline -: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline -: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline -: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline -: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline -: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline + } cond ; + +: ^^offset>slot ( slot -- vreg' ) + cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; + +: ^^tag-fixnum ( src -- dst ) + tag-bits get ^^shl-imm ; + +: ^^untag-fixnum ( src -- dst ) + tag-bits get ^^sar-imm ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 7c28198f67..119af6d0b1 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -29,6 +29,10 @@ INSN: ##load-reference def: dst/int-rep constant: obj ; +INSN: ##load-constant +def: dst/int-rep +constant: obj ; + INSN: ##peek def: dst/int-rep literal: loc ; @@ -63,9 +67,7 @@ temp: temp/int-rep ; ! Slot access INSN: ##slot def: dst/int-rep -use: obj/int-rep slot/int-rep -literal: tag -temp: temp/int-rep ; +use: obj/int-rep slot/int-rep ; INSN: ##slot-imm def: dst/int-rep @@ -73,9 +75,7 @@ use: obj/int-rep literal: slot tag ; INSN: ##set-slot -use: src/int-rep obj/int-rep slot/int-rep -literal: tag -temp: temp/int-rep ; +use: src/int-rep obj/int-rep slot/int-rep ; INSN: ##set-slot-imm use: src/int-rep obj/int-rep @@ -190,31 +190,15 @@ PURE-INSN: ##not def: dst/int-rep use: src/int-rep ; -PURE-INSN: ##log2 +PURE-INSN: ##neg def: dst/int-rep use: src/int-rep ; -! Bignum/integer conversion -PURE-INSN: ##integer>bignum -def: dst/int-rep -use: src/int-rep -temp: temp/int-rep ; - -PURE-INSN: ##bignum>integer +PURE-INSN: ##log2 def: dst/int-rep -use: src/int-rep -temp: temp/int-rep ; - -! Float arithmetic -PURE-INSN: ##unbox-float -def: dst/double-rep use: src/int-rep ; -PURE-INSN: ##box-float -def: dst/int-rep -use: src/double-rep -temp: temp/int-rep ; - +! Float arithmetic PURE-INSN: ##add-float def: dst/double-rep use: src1/double-rep src2/double-rep ; @@ -273,21 +257,12 @@ def: dst/double-rep use: src/int-rep ; ! SIMD operations - -PURE-INSN: ##box-vector -def: dst/int-rep -use: src -literal: rep -temp: temp/int-rep ; - -PURE-INSN: ##unbox-vector +PURE-INSN: ##zero-vector def: dst -use: src/int-rep literal: rep ; -PURE-INSN: ##broadcast-vector +PURE-INSN: ##fill-vector def: dst -use: src/scalar-rep literal: rep ; PURE-INSN: ##gather-vector-2 @@ -300,21 +275,118 @@ def: dst use: src1/scalar-rep src2/scalar-rep src3/scalar-rep src4/scalar-rep literal: rep ; +PURE-INSN: ##shuffle-vector +def: dst +use: src shuffle +literal: rep ; + +PURE-INSN: ##shuffle-vector-imm +def: dst +use: src +literal: shuffle rep ; + +PURE-INSN: ##tail>head-vector +def: dst +use: src +literal: rep ; + +PURE-INSN: ##merge-vector-head +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##merge-vector-tail +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##signed-pack-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##unsigned-pack-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##unpack-vector-head +def: dst +use: src +literal: rep ; + +PURE-INSN: ##unpack-vector-tail +def: dst +use: src +literal: rep ; + +PURE-INSN: ##integer>float-vector +def: dst +use: src +literal: rep ; + +PURE-INSN: ##float>integer-vector +def: dst +use: src +literal: rep ; + +PURE-INSN: ##compare-vector +def: dst +use: src1 src2 +literal: rep cc ; + +PURE-INSN: ##test-vector +def: dst/int-rep +use: src1 +temp: temp/int-rep +literal: rep vcc ; + +INSN: ##test-vector-branch +use: src1 +temp: temp/int-rep +literal: rep vcc ; + +INSN: _test-vector-branch +literal: label +use: src1 +temp: temp/int-rep +literal: rep vcc ; + PURE-INSN: ##add-vector def: dst use: src1 src2 literal: rep ; +PURE-INSN: ##saturated-add-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##add-sub-vector +def: dst +use: src1 src2 +literal: rep ; + PURE-INSN: ##sub-vector def: dst use: src1 src2 literal: rep ; +PURE-INSN: ##saturated-sub-vector +def: dst +use: src1 src2 +literal: rep ; + PURE-INSN: ##mul-vector def: dst use: src1 src2 literal: rep ; +PURE-INSN: ##saturated-mul-vector +def: dst +use: src1 src2 +literal: rep ; + PURE-INSN: ##div-vector def: dst use: src1 src2 @@ -330,16 +402,97 @@ def: dst use: src1 src2 literal: rep ; +PURE-INSN: ##dot-vector +def: dst/scalar-rep +use: src1 src2 +literal: rep ; + +PURE-INSN: ##horizontal-add-vector +def: dst/scalar-rep +use: src +literal: rep ; + +PURE-INSN: ##horizontal-sub-vector +def: dst/scalar-rep +use: src +literal: rep ; + +PURE-INSN: ##horizontal-shl-vector +def: dst +use: src1 +literal: src2 rep ; + +PURE-INSN: ##horizontal-shr-vector +def: dst +use: src1 +literal: src2 rep ; + +PURE-INSN: ##abs-vector +def: dst +use: src +literal: rep ; + PURE-INSN: ##sqrt-vector def: dst use: src literal: rep ; -PURE-INSN: ##horizontal-add-vector +PURE-INSN: ##and-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##andn-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##or-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##xor-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##not-vector +def: dst +use: src +literal: rep ; + +PURE-INSN: ##shl-vector +def: dst +use: src1 src2/int-scalar-rep +literal: rep ; + +PURE-INSN: ##shr-vector +def: dst +use: src1 src2/int-scalar-rep +literal: rep ; + +! Scalar/vector conversion +PURE-INSN: ##scalar>integer +def: dst/int-rep +use: src +literal: rep ; + +PURE-INSN: ##integer>scalar +def: dst +use: src/int-rep +literal: rep ; + +PURE-INSN: ##vector>scalar def: dst/scalar-rep use: src literal: rep ; +PURE-INSN: ##scalar>vector +def: dst +use: src/scalar-rep +literal: rep ; + ! Boxing and unboxing aliens PURE-INSN: ##box-alien def: dst/int-rep @@ -375,65 +528,88 @@ use: src/int-rep ; ! Alien accessors INSN: ##alien-unsigned-1 def: dst/int-rep -use: src/int-rep ; +use: src/int-rep +literal: offset ; INSN: ##alien-unsigned-2 def: dst/int-rep -use: src/int-rep ; +use: src/int-rep +literal: offset ; INSN: ##alien-unsigned-4 def: dst/int-rep -use: src/int-rep ; +use: src/int-rep +literal: offset ; INSN: ##alien-signed-1 def: dst/int-rep -use: src/int-rep ; +use: src/int-rep +literal: offset ; INSN: ##alien-signed-2 def: dst/int-rep -use: src/int-rep ; +use: src/int-rep +literal: offset ; INSN: ##alien-signed-4 def: dst/int-rep -use: src/int-rep ; +use: src/int-rep +literal: offset ; INSN: ##alien-cell def: dst/int-rep -use: src/int-rep ; +use: src/int-rep +literal: offset ; INSN: ##alien-float def: dst/float-rep -use: src/int-rep ; +use: src/int-rep +literal: offset ; INSN: ##alien-double def: dst/double-rep -use: src/int-rep ; +use: src/int-rep +literal: offset ; INSN: ##alien-vector def: dst use: src/int-rep -literal: rep ; +literal: offset rep ; INSN: ##set-alien-integer-1 -use: src/int-rep value/int-rep ; +use: src/int-rep +literal: offset +use: value/int-rep ; INSN: ##set-alien-integer-2 -use: src/int-rep value/int-rep ; +use: src/int-rep +literal: offset +use: value/int-rep ; INSN: ##set-alien-integer-4 -use: src/int-rep value/int-rep ; +use: src/int-rep +literal: offset +use: value/int-rep ; INSN: ##set-alien-cell -use: src/int-rep value/int-rep ; +use: src/int-rep +literal: offset +use: value/int-rep ; INSN: ##set-alien-float -use: src/int-rep value/float-rep ; +use: src/int-rep +literal: offset +use: value/float-rep ; INSN: ##set-alien-double -use: src/int-rep value/double-rep ; +use: src/int-rep +literal: offset +use: value/double-rep ; INSN: ##set-alien-vector -use: src/int-rep value +use: src/int-rep +literal: offset +use: value literal: rep ; ! Memory allocation @@ -452,7 +628,7 @@ literal: symbol library ; INSN: ##vm-field-ptr def: dst/int-rep -literal: fieldname ; +literal: field-name ; ! FFI INSN: ##alien-invoke @@ -535,7 +711,7 @@ use: src1/int-rep src2/int-rep ; INSN: ##gc temp: temp1/int-rep temp2/int-rep -literal: data-values tagged-values uninitialized-locs ; +literal: size data-values tagged-values uninitialized-locs ; INSN: ##save-context temp: temp1/int-rep temp2/int-rep @@ -600,35 +776,29 @@ literal: label def: dst/int-rep use: src1/int-rep src2/int-rep ; -TUPLE: spill-slot n ; C: spill-slot - -INSN: _gc -temp: temp1 temp2 -literal: data-values tagged-values uninitialized-locs ; +TUPLE: spill-slot { n integer } ; +C: spill-slot ! These instructions operate on machine registers and not ! virtual registers INSN: _spill use: src -literal: rep n ; +literal: rep dst ; INSN: _reload def: dst -literal: rep n ; +literal: rep src ; INSN: _spill-area-size literal: n ; UNION: ##allocation ##allot -##box-float -##box-vector ##box-alien -##box-displaced-alien -##integer>bignum ; +##box-displaced-alien ; ! For alias analysis -UNION: ##read ##slot ##slot-imm ; +UNION: ##read ##slot ##slot-imm ##vm-field-ptr ##alien-global ; UNION: ##write ##set-slot ##set-slot-imm ; ! Instructions that kill all live vregs but cannot trigger GC @@ -648,8 +818,9 @@ UNION: kill-vreg-insn ! Instructions that have complex expansions and require that the ! output registers are not equal to any of the input registers UNION: def-is-use-insn -##integer>bignum -##bignum>integer +##box-alien +##box-displaced-alien +##string-nth ##unbox-any-c-ptr ; SYMBOL: vreg-insn diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index 2b903813a0..a37e100c3e 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -3,8 +3,9 @@ USING: accessors kernel sequences alien math classes.algebra fry locals combinators combinators.short-circuit cpu.architecture compiler.tree.propagation.info compiler.cfg.hats -compiler.cfg.stacks compiler.cfg.instructions -compiler.cfg.utilities compiler.cfg.builder.blocks ; +compiler.cfg.registers compiler.cfg.stacks +compiler.cfg.instructions compiler.cfg.utilities +compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.alien : emit-? ( node -- ? ) @@ -33,10 +34,13 @@ IN: compiler.cfg.intrinsics.alien [ second class>> fixnum class<= ] bi and ; -: prepare-alien-accessor ( info -- offset-vreg ) - class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ; +: ^^unbox-c-ptr ( src class -- dst ) + [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ; -: prepare-alien-getter ( infos -- offset-vreg ) +: prepare-alien-accessor ( info -- ptr-vreg offset ) + class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ; + +: prepare-alien-getter ( infos -- ptr-vreg offset ) first prepare-alien-accessor ; : inline-alien-getter ( node quot -- ) @@ -49,7 +53,7 @@ IN: compiler.cfg.intrinsics.alien [ third class>> fixnum class<= ] tri and and ; -: prepare-alien-setter ( infos -- offset-vreg ) +: prepare-alien-setter ( infos -- ptr-vreg offset ) second prepare-alien-accessor ; : inline-alien-integer-setter ( node quot -- ) diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index d4aa2750c0..8283299ea8 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -18,6 +18,9 @@ IN: compiler.cfg.intrinsics.allot : tuple-slot-regs ( layout -- vregs ) [ second ds-load ] [ ^^load-literal ] bi prefix ; +: ^^allot-tuple ( n -- dst ) + 2 + cells tuple ^^allot ; + : emit- ( node -- ) dup node-input-infos last literal>> dup array? [ @@ -36,6 +39,9 @@ IN: compiler.cfg.intrinsics.allot : expand-? ( obj -- ? ) dup integer? [ 0 8 between? ] [ drop f ] if ; +: ^^allot-array ( n -- dst ) + 2 + cells array ^^allot ; + :: emit- ( node -- ) [let | len [ node node-input-infos first literal>> ] | len expand-? [ @@ -49,18 +55,24 @@ IN: compiler.cfg.intrinsics.allot ] [ node emit-primitive ] if ] ; +: expand-(byte-array)? ( obj -- ? ) + dup integer? [ 0 1024 between? ] [ drop f ] if ; + : expand-? ( obj -- ? ) dup integer? [ 0 32 between? ] [ drop f ] if ; : bytes>cells ( m -- n ) cell align cell /i ; +: ^^allot-byte-array ( n -- dst ) + 2 cells + byte-array ^^allot ; + : emit-allot-byte-array ( len -- dst ) ds-drop dup ^^allot-byte-array [ byte-array store-length ] [ ds-push ] [ ] tri ; : emit-(byte-array) ( node -- ) - dup node-input-infos first literal>> dup expand-? + dup node-input-infos first literal>> dup expand-(byte-array)? [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ; :: emit- ( node -- ) diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 2e2bfd5f09..8ead484cf1 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -57,12 +57,6 @@ IN: compiler.cfg.intrinsics.fixnum : emit-fixnum-comparison ( cc -- ) '[ _ ^^compare ] emit-fixnum-op ; -: emit-bignum>fixnum ( -- ) - ds-pop ^^bignum>integer ^^tag-fixnum ds-push ; - -: emit-fixnum>bignum ( -- ) - ds-pop ^^untag-fixnum ^^integer>bignum ds-push ; - : emit-no-overflow-case ( dst -- final-bb ) [ ds-drop ds-drop ds-push ] with-branch ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 0daab82395..3b6674efee 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -151,27 +151,64 @@ IN: compiler.cfg.intrinsics { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] } } enable-intrinsics ; -: enable-sse2-simd ( -- ) +: enable-simd ( -- ) { { math.vectors.simd.intrinsics:assert-positive [ drop ] } { math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vs+) [ [ ^^saturated-add-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-v+-) [ [ ^^add-sub-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vs-) [ [ ^^saturated-sub-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vneg) [ [ generate-neg-vector ] emit-unary-vector-op ] } { math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-vector ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vbitandn) [ [ ^^andn-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vbitnot) [ [ generate-not-vector ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vand) [ [ ^^and-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vandn) [ [ ^^andn-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vor) [ [ ^^or-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vxor) [ [ ^^xor-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vnot) [ [ generate-not-vector ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-v<=) [ [ cc<= generate-compare-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-v<) [ [ cc< generate-compare-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-v=) [ [ cc= generate-compare-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-v>) [ [ cc> generate-compare-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-v>=) [ [ cc>= generate-compare-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vunordered?) [ [ cc/<>= generate-compare-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector ] emit-horizontal-shift ] } + { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector ] emit-horizontal-shift ] } + { math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] } { math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] } { math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] } + { math.vectors.simd.intrinsics:(simd-vshuffle-elements) [ emit-shuffle-vector ] } + { math.vectors.simd.intrinsics:(simd-vshuffle-bytes) [ emit-shuffle-vector-var ] } + { math.vectors.simd.intrinsics:(simd-(vmerge-head)) [ [ ^^merge-vector-head ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-(vmerge-tail)) [ [ ^^merge-vector-tail ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-(v>float)) [ [ ^^integer>float-vector ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-(v>integer)) [ [ ^^float>integer-vector ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-(vpack-signed)) [ [ ^^signed-pack-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-(vpack-unsigned)) [ [ ^^unsigned-pack-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-(vunpack-head)) [ [ generate-unpack-vector-head ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-(vunpack-tail)) [ [ generate-unpack-vector-tail ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-select) [ emit-select-vector ] } + { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] } { math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] } { math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] } } enable-intrinsics ; -: enable-sse3-simd ( -- ) - { - { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] } - } enable-intrinsics ; - : emit-intrinsic ( node word -- ) "intrinsic" word-prop call( node -- ) ; diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index f9f3488773..ce005e8353 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc.factor +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -12,5 +12,5 @@ IN: compiler.cfg.intrinsics.misc : emit-getenv ( node -- ) "userenv" ^^vm-field-ptr swap node-input-infos first literal>> - [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if* + [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if* ds-push ; diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index f1a6f986df..bd851199ca 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -1,22 +1,63 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays fry cpu.architecture kernel -sequences compiler.tree.propagation.info -compiler.cfg.builder.blocks compiler.cfg.stacks -compiler.cfg.stacks.local compiler.cfg.hats +USING: accessors alien byte-arrays fry classes.algebra +cpu.architecture kernel math sequences math.vectors +math.vectors.simd.intrinsics macros generalizations combinators +combinators.short-circuit arrays locals +compiler.tree.propagation.info compiler.cfg.builder.blocks +compiler.cfg.comparisons +compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.intrinsics.alien ; +compiler.cfg.intrinsics.alien +specialized-arrays ; +FROM: alien.c-types => heap-size char uchar float double ; +SPECIALIZED-ARRAYS: float double ; IN: compiler.cfg.intrinsics.simd +MACRO: check-elements ( quots -- ) + [ length '[ _ firstn ] ] + [ '[ _ spread ] ] + [ length 1 - \ and [ ] like ] + tri 3append ; + +MACRO: if-literals-match ( quots -- ) + [ length ] [ ] [ length ] tri + ! n quots n + '[ + ! node quot + [ + dup node-input-infos + _ tail-slice* [ literal>> ] map + dup _ check-elements + ] dip + swap [ + ! node literals quot + [ _ firstn ] dip call + drop + ] [ 2drop emit-primitive ] if + ] ; + : emit-vector-op ( node quot: ( rep -- ) -- ) - [ dup node-input-infos last literal>> ] dip over representation? - [ [ drop ] 2dip call ] [ 2drop emit-primitive ] if ; inline + { [ representation? ] } if-literals-match ; inline + +: [binary] ( quot -- quot' ) + '[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline : emit-binary-vector-op ( node quot -- ) - '[ [ ds-drop 2inputs ] dip @ ds-push ] emit-vector-op ; inline + [binary] emit-vector-op ; inline + +: [unary] ( quot -- quot' ) + '[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline : emit-unary-vector-op ( node quot -- ) - '[ [ ds-drop ds-pop ] dip @ ds-push ] emit-vector-op ; inline + [unary] emit-vector-op ; inline + +: [unary/param] ( quot -- quot' ) + '[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline + +: emit-horizontal-shift ( node quot -- ) + [unary/param] + { [ integer? ] [ representation? ] } if-literals-match ; inline : emit-gather-vector-2 ( node -- ) [ ^^gather-vector-2 ] emit-binary-vector-op ; @@ -35,6 +76,61 @@ IN: compiler.cfg.intrinsics.simd ds-push ] emit-vector-op ; +: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ; + +: >variable-shuffle ( shuffle rep -- shuffle' ) + rep-component-type heap-size + [ dup >byte-array ] + [ iota >byte-array ] bi + '[ _ n*v _ v+ ] map concat ; + +: generate-shuffle-vector-imm ( src shuffle rep -- dst ) + dup %shuffle-vector-imm-reps member? + [ ^^shuffle-vector-imm ] + [ + [ >variable-shuffle ^^load-constant ] keep + ^^shuffle-vector + ] if ; + +: emit-shuffle-vector-imm ( node -- ) + ! Pad the permutation with zeroes if it's too short, since we + ! can't throw an error at this point. + [ [ rep-components 0 pad-tail ] keep generate-shuffle-vector-imm ] [unary/param] + { [ shuffle? ] [ representation? ] } if-literals-match ; + +: emit-shuffle-vector-var ( node -- ) + [ ^^shuffle-vector ] [binary] + { [ %shuffle-vector-reps member? ] } if-literals-match ; + +: emit-shuffle-vector ( node -- ) + dup node-input-infos { + [ length 3 = ] + [ first class>> byte-array class<= ] + [ second class>> byte-array class<= ] + [ third literal>> representation? ] + } 1&& [ emit-shuffle-vector-var ] [ emit-shuffle-vector-imm ] if ; + +: ^^broadcast-vector ( src n rep -- dst ) + [ rep-components swap ] keep + generate-shuffle-vector-imm ; + +: emit-broadcast-vector ( node -- ) + [ ^^broadcast-vector ] [unary/param] + { [ integer? ] [ representation? ] } if-literals-match ; + +: ^^with-vector ( src rep -- dst ) + [ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ; + +: ^^select-vector ( src n rep -- dst ) + [ ^^broadcast-vector ] keep ^^vector>scalar ; + +: emit-select-vector ( node -- ) + [ ^^select-vector ] [unary/param] + { [ integer? ] [ representation? ] } if-literals-match ; inline + +: emit-alien-vector-op ( node quot: ( rep -- ) -- ) + { [ %alien-vector-reps member? ] } if-literals-match ; inline + : emit-alien-vector ( node -- ) dup [ '[ @@ -42,7 +138,7 @@ IN: compiler.cfg.intrinsics.simd _ ^^alien-vector ds-push ] [ inline-alien-getter? ] inline-alien - ] with emit-vector-op ; + ] with emit-alien-vector-op ; : emit-set-alien-vector ( node -- ) dup [ @@ -52,4 +148,106 @@ IN: compiler.cfg.intrinsics.simd ] [ byte-array inline-alien-setter? ] inline-alien - ] with emit-vector-op ; + ] with emit-alien-vector-op ; + +: generate-not-vector ( src rep -- dst ) + dup %not-vector-reps member? + [ ^^not-vector ] + [ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ; + +:: (generate-compare-vector) ( src1 src2 rep {cc,swap} -- dst ) + {cc,swap} first2 :> swap? :> cc + swap? + [ src2 src1 rep cc ^^compare-vector ] + [ src1 src2 rep cc ^^compare-vector ] if ; + +:: generate-compare-vector ( src1 src2 rep orig-cc -- dst ) + rep orig-cc %compare-vector-ccs :> not? :> ccs + + ccs empty? + [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ] + [ + ccs unclip :> first-cc :> rest-ccs + src1 src2 rep first-cc (generate-compare-vector) :> first-dst + + rest-ccs first-dst + [ [ src1 src2 rep ] dip (generate-compare-vector) rep ^^or-vector ] + reduce + + not? [ rep generate-not-vector ] when + ] if ; + +:: generate-unpack-vector-head ( src rep -- dst ) + { + { + [ rep %unpack-vector-head-reps member? ] + [ src rep ^^unpack-vector-head ] + } + [ + rep ^^zero-vector :> zero + zero src rep cc> ^^compare-vector :> sign + src sign rep ^^merge-vector-head + ] + } cond ; + +:: generate-unpack-vector-tail ( src rep -- dst ) + { + { + [ rep %unpack-vector-tail-reps member? ] + [ src rep ^^unpack-vector-tail ] + } + { + [ rep %unpack-vector-head-reps member? ] + [ + src rep ^^tail>head-vector :> tail + tail rep ^^unpack-vector-head + ] + } + [ + rep ^^zero-vector :> zero + zero src rep cc> ^^compare-vector :> sign + src sign rep ^^merge-vector-tail + ] + } cond ; + +:: generate-load-neg-zero-vector ( rep -- dst ) + rep { + { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] } + { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] } + [ drop rep ^^zero-vector ] + } case ; + +:: generate-neg-vector ( src rep -- dst ) + rep generate-load-neg-zero-vector + src rep ^^sub-vector ; + +:: generate-blend-vector ( mask true false rep -- dst ) + mask true rep ^^and-vector + mask false rep ^^andn-vector + rep ^^or-vector ; + +:: generate-abs-vector ( src rep -- dst ) + { + { + [ rep unsigned-int-vector-rep? ] + [ src ] + } + { + [ rep %abs-vector-reps member? ] + [ src rep ^^abs-vector ] + } + { + [ rep float-vector-rep? ] + [ + rep generate-load-neg-zero-vector + src rep ^^andn-vector + ] + } + [ + rep ^^zero-vector :> zero + zero src rep ^^sub-vector :> -src + zero src rep cc> ^^compare-vector :> sign + sign -src src rep generate-blend-vector + ] + } cond ; + diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 5ae51a28e2..8ee1c41cfb 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -8,9 +8,12 @@ IN: compiler.cfg.intrinsics.slots : value-tag ( info -- n ) class>> class-tag ; inline +: ^^tag-offset>slot ( slot tag -- vreg' ) + [ ^^offset>slot ] dip ^^sub-imm ; + : (emit-slot) ( infos -- dst ) - [ 2inputs ^^offset>slot ] [ first value-tag ] bi* - ^^slot ; + [ 2inputs ] [ first value-tag ] bi* + ^^tag-offset>slot ^^slot ; : (emit-slot-imm) ( infos -- dst ) ds-drop @@ -28,8 +31,8 @@ IN: compiler.cfg.intrinsics.slots ] [ drop emit-primitive ] if ; : (emit-set-slot) ( infos -- obj-reg ) - [ 3inputs ^^offset>slot ] [ second value-tag ] bi* - pick [ next-vreg ##set-slot ] dip ; + [ 3inputs ] [ second value-tag ] bi* + ^^tag-offset>slot over [ ##set-slot ] dip ; : (emit-set-slot-imm) ( infos -- obj-reg ) ds-drop diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index c23867ffe2..ac32265e65 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -34,11 +34,15 @@ IN: compiler.cfg.linear-scan.allocation [ drop assign-blocked-register ] } cond ; +: spill-at-sync-point ( live-interval n -- ? ) + ! If the live interval has a usage at 'n', don't spill it, + ! since this means its being defined by the sync point + ! instruction. Output t if this is the case. + 2dup [ uses>> ] dip swap member? [ 2drop t ] [ spill f ] if ; + : handle-sync-point ( n -- ) [ active-intervals get values ] dip - [ '[ [ _ spill ] each ] each ] - [ drop [ delete-all ] each ] - 2bi ; + '[ [ _ spill-at-sync-point ] filter-here ] each ; :: handle-progress ( n sync? -- ) n { diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 11874a567f..8b4dde59da 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators fry hints kernel locals -math sequences sets sorting splitting namespaces +math sequences sets sorting splitting namespaces linked-assocs combinators.short-circuit compiler.utilities compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.allocation.splitting @@ -83,7 +83,7 @@ ERROR: bad-live-ranges interval ; find-use-positions ; : spill-status ( new -- use-pos ) - H{ } clone + H{ } [ inactive-positions ] [ active-positions ] [ nip ] 2tri >alist alist-max ; diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index a311f97b66..aeebe31dcc 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators cpu.architecture fry heaps kernel math math.order namespaces sequences vectors -compiler.cfg compiler.cfg.registers -compiler.cfg.linear-scan.live-intervals ; +linked-assocs compiler.cfg compiler.cfg.registers +compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ; IN: compiler.cfg.linear-scan.allocation.state ! Start index of current live interval. We ensure that all @@ -118,7 +118,8 @@ SYMBOL: unhandled-intervals : next-spill-slot ( rep -- n ) rep-size cfg get - [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ; + [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop + ; ! Minheap of sync points which still need to be processed SYMBOL: unhandled-sync-points @@ -126,7 +127,7 @@ SYMBOL: unhandled-sync-points ! Mapping from vregs to spill slots SYMBOL: spill-slots -: vreg-spill-slot ( vreg -- n ) +: vreg-spill-slot ( vreg -- spill-slot ) spill-slots get [ rep-of next-spill-slot ] cache ; : init-allocator ( registers -- ) @@ -147,7 +148,8 @@ SYMBOL: spill-slots ! A utility used by register-status and spill-status words : free-positions ( new -- assoc ) - vreg>> rep-of reg-class-of registers get at [ 1/0. ] H{ } map>assoc ; + vreg>> rep-of reg-class-of registers get at + [ 1/0. ] H{ } map>assoc ; : add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 572107be6c..f69db1deea 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math assocs namespaces sequences heaps fry make combinators sets locals arrays -cpu.architecture +cpu.architecture layouts compiler.cfg compiler.cfg.def-use compiler.cfg.liveness @@ -33,7 +33,7 @@ ERROR: bad-vreg vreg ; : (vreg>reg) ( vreg pending -- reg ) ! If a live vreg is not in the pending set, then it must ! have been spilled. - ?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ; + ?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ; : vreg>reg ( vreg -- reg ) pending-interval-assoc get (vreg>reg) ; @@ -117,8 +117,6 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ] M: vreg-insn assign-registers-in-insn [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ; -! TODO: needs tagged-rep - : trace-on-gc ( assoc -- assoc' ) ! When a GC occurs, virtual registers which contain tagged data ! are traced by the GC. Outputs a sequence physical registers. @@ -141,12 +139,16 @@ M: vreg-insn assign-registers-in-insn ] assoc-each ] { } make ; +: gc-root-offsets ( registers -- alist ) + ! Outputs a sequence of { offset register/spill-slot } pairs + [ length iota [ cell * ] map ] keep zip ; + M: ##gc assign-registers-in-insn ! Since ##gc is always the first instruction in a block, the set of ! values live at the ##gc is just live-in. dup call-next-method basic-block get register-live-ins get at - [ trace-on-gc >>tagged-values ] [ spill-on-gc >>data-values ] bi + [ trace-on-gc gc-root-offsets >>tagged-values ] [ spill-on-gc >>data-values ] bi drop ; M: insn assign-registers-in-insn drop ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index f09fe403e6..3a9a7ac0a1 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -92,7 +92,7 @@ H{ { end 2 } { uses V{ 0 1 } } { ranges V{ T{ live-range f 0 2 } } } - { spill-to 0 } + { spill-to T{ spill-slot f 0 } } } T{ live-interval { vreg 1 } @@ -100,7 +100,7 @@ H{ { end 5 } { uses V{ 5 } } { ranges V{ T{ live-range f 5 5 } } } - { reload-from 0 } + { reload-from T{ spill-slot f 0 } } } ] [ T{ live-interval @@ -119,7 +119,7 @@ H{ { end 1 } { uses V{ 0 } } { ranges V{ T{ live-range f 0 1 } } } - { spill-to 4 } + { spill-to T{ spill-slot f 4 } } } T{ live-interval { vreg 2 } @@ -127,7 +127,7 @@ H{ { end 5 } { uses V{ 1 5 } } { ranges V{ T{ live-range f 1 5 } } } - { reload-from 4 } + { reload-from T{ spill-slot f 4 } } } ] [ T{ live-interval @@ -146,7 +146,7 @@ H{ { end 1 } { uses V{ 0 } } { ranges V{ T{ live-range f 0 1 } } } - { spill-to 8 } + { spill-to T{ spill-slot f 8 } } } T{ live-interval { vreg 3 } @@ -154,7 +154,7 @@ H{ { end 30 } { uses V{ 20 30 } } { ranges V{ T{ live-range f 20 30 } } } - { reload-from 8 } + { reload-from T{ spill-slot f 8 } } } ] [ T{ live-interval @@ -1042,8 +1042,8 @@ V{ [ _spill ] [ 1 get instructions>> second class ] unit-test [ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test -[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> cell / ] map ] unit-test -[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> cell / ] map ] unit-test +[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ dst>> n>> cell / ] map ] unit-test +[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ src>> n>> cell / ] map ] unit-test ! Resolve pass should insert this [ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test @@ -1465,7 +1465,7 @@ V{ [ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test -[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test +[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test V{ T{ ##peek f 0 D 0 } @@ -1487,4 +1487,4 @@ V{ [ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test -[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test +[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index 47c1f0ae76..e7f291d613 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -17,7 +17,7 @@ IN: compiler.cfg.linear-scan.resolve.tests [ { - T{ _reload { dst 1 } { rep int-rep } { n 0 } } + T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } } } ] [ [ @@ -27,7 +27,7 @@ IN: compiler.cfg.linear-scan.resolve.tests [ { - T{ _spill { src 1 } { rep int-rep } { n 0 } } + T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } } } ] [ [ @@ -54,14 +54,14 @@ H{ } clone spill-temps set { { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } } mapping-instructions { { - T{ _spill { src 0 } { rep int-rep } { n 8 } } + T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } } T{ ##copy { dst 0 } { src 1 } { rep int-rep } } - T{ _reload { dst 1 } { rep int-rep } { n 8 } } + T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } } } { - T{ _spill { src 1 } { rep int-rep } { n 8 } } + T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } } T{ ##copy { dst 1 } { src 0 } { rep int-rep } } - T{ _reload { dst 0 } { rep int-rep } { n 8 } } + T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } } } } member? ] unit-test diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 15dff23448..20c9ee4e99 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -34,10 +34,10 @@ SYMBOL: spill-temps ] if ; : memory->register ( from to -- ) - swap [ first2 ] [ first n>> ] bi* _reload ; + swap [ first2 ] [ first ] bi* _reload ; : register->memory ( from to -- ) - [ first2 ] [ first n>> ] bi* _spill ; + [ first2 ] [ first ] bi* _spill ; : temp->register ( from to -- ) nip [ first ] [ second ] [ second spill-temp ] tri _reload ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 66ac1addb0..34ae7f8cc6 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel math accessors sequences namespaces make combinators assocs arrays locals layouts hashtables -cpu.architecture +cpu.architecture generalizations compiler.cfg compiler.cfg.comparisons compiler.cfg.stack-frame @@ -42,14 +42,26 @@ M: ##branch linearize-insn : successors ( bb -- first second ) successors>> first2 ; inline +:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label ... ) + bb insn + conditional-quot + [ drop dup successors>> second useless-branch? ] 2bi + [ [ swap block-number ] n ndip ] + [ [ block-number ] n ndip negate-cc-quot call ] if ; inline + : (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc ) [ dup successors ] [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline : binary-conditional ( bb insn -- bb successor label2 src1 src2 cc ) - [ (binary-conditional) ] - [ drop dup successors>> second useless-branch? ] 2bi - [ [ swap block-number ] 3dip ] [ [ block-number ] 3dip negate-cc ] if ; + 3 [ (binary-conditional) ] [ negate-cc ] conditional ; + +: (test-vector-conditional) ( bb insn -- bb successor1 successor2 src1 temp rep vcc ) + [ dup successors ] + [ { [ src1>> ] [ temp>> ] [ rep>> ] [ vcc>> ] } cleave ] bi* ; inline + +: test-vector-conditional ( bb insn -- bb successor label src1 temp rep vcc ) + 4 [ (test-vector-conditional) ] [ negate-vcc ] conditional ; M: ##compare-branch linearize-insn binary-conditional _compare-branch emit-branch ; @@ -63,6 +75,9 @@ M: ##compare-float-ordered-branch linearize-insn M: ##compare-float-unordered-branch linearize-insn binary-conditional _compare-float-unordered-branch emit-branch ; +M: ##test-vector-branch linearize-insn + test-vector-conditional _test-vector-branch emit-branch ; + : overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 ) [ dup successors block-number ] [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline @@ -82,21 +97,6 @@ M: ##dispatch linearize-insn [ successors>> [ block-number _dispatch-label ] each ] bi* ; -: gc-root-offsets ( registers -- alist ) - ! Outputs a sequence of { offset register/spill-slot } pairs - [ length iota [ cell * ] map ] keep zip ; - -M: ##gc linearize-insn - nip - { - [ temp1>> ] - [ temp2>> ] - [ data-values>> ] - [ tagged-values>> gc-root-offsets ] - [ uninitialized-locs>> ] - } cleave - _gc ; - : linearize-basic-blocks ( cfg -- insns ) [ [ diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 649032b469..84726a9b99 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -12,7 +12,6 @@ compiler.cfg.copy-prop compiler.cfg.dce compiler.cfg.write-barrier compiler.cfg.representations -compiler.cfg.two-operand compiler.cfg.ssa.destruction compiler.cfg.empty-blocks compiler.cfg.checker ; @@ -37,7 +36,6 @@ SYMBOL: check-optimizer? eliminate-dead-code eliminate-write-barriers select-representations - convert-two-operand destruct-ssa delete-empty-blocks ?check ; diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor index 389b78c333..4444290f05 100644 --- a/basis/compiler/cfg/representations/preferred/preferred.factor +++ b/basis/compiler/cfg/representations/preferred/preferred.factor @@ -3,8 +3,8 @@ USING: kernel accessors sequences arrays fry namespaces generic words sets combinators generalizations cpu.architecture compiler.units compiler.cfg.utilities compiler.cfg compiler.cfg.rpo -compiler.cfg.instructions compiler.cfg.instructions.syntax -compiler.cfg.def-use ; +compiler.cfg.instructions compiler.cfg.def-use ; +FROM: compiler.cfg.instructions.syntax => insn-def-slot insn-use-slots insn-temp-slots scalar-rep ; IN: compiler.cfg.representations.preferred GENERIC: defs-vreg-rep ( insn -- rep/f ) diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor index ec2856f647..42059f4152 100644 --- a/basis/compiler/cfg/representations/representations.factor +++ b/basis/compiler/cfg/representations/representations.factor @@ -1,8 +1,10 @@ ! Copyright (C) 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry accessors sequences assocs sets namespaces -arrays combinators make locals deques dlists -cpu.architecture compiler.utilities +arrays combinators combinators.short-circuit math make locals +deques dlists layouts byte-arrays cpu.architecture +compiler.utilities +compiler.constants compiler.cfg compiler.cfg.rpo compiler.cfg.hats @@ -22,28 +24,44 @@ ERROR: bad-conversion dst src dst-rep src-rep ; GENERIC: emit-box ( dst src rep -- ) GENERIC: emit-unbox ( dst src rep -- ) -M: float-rep emit-box - drop - [ double-rep next-vreg-rep dup ] dip ##single>double-float - int-rep next-vreg-rep ##box-float ; +M:: float-rep emit-box ( dst src rep -- ) + double-rep next-vreg-rep :> temp + temp src ##single>double-float + dst temp double-rep emit-box ; -M: float-rep emit-unbox - drop - [ double-rep next-vreg-rep dup ] dip ##unbox-float - ##double>single-float ; +M:: float-rep emit-unbox ( dst src rep -- ) + double-rep next-vreg-rep :> temp + temp src double-rep emit-unbox + dst temp ##double>single-float ; M: double-rep emit-box drop - int-rep next-vreg-rep ##box-float ; + [ drop 16 float int-rep next-vreg-rep ##allot ] + [ float-offset swap ##set-alien-double ] + 2bi ; M: double-rep emit-unbox - drop ##unbox-float ; + drop float-offset ##alien-double ; -M: vector-rep emit-box - int-rep next-vreg-rep ##box-vector ; +M:: vector-rep emit-box ( dst src rep -- ) + int-rep next-vreg-rep :> temp + dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot + temp 16 tag-fixnum ##load-immediate + temp dst 1 byte-array tag-number ##set-slot-imm + dst byte-array-offset src rep ##set-alien-vector ; M: vector-rep emit-unbox - ##unbox-vector ; + [ byte-array-offset ] dip ##alien-vector ; + +M:: scalar-rep emit-box ( dst src rep -- ) + int-rep next-vreg-rep :> temp + temp src rep ##scalar>integer + dst temp tag-bits get ##shl-imm ; + +M:: scalar-rep emit-unbox ( dst src rep -- ) + int-rep next-vreg-rep :> temp + temp src tag-bits get ##sar-imm + dst temp rep ##integer>scalar ; : emit-conversion ( dst src dst-rep src-rep -- ) { @@ -87,9 +105,8 @@ SYMBOL: always-boxed H{ } clone [ '[ [ - dup ##load-reference? [ drop ] [ - [ _ (compute-always-boxed) ] each-def-rep - ] if + dup [ ##load-reference? ] [ ##load-constant? ] bi or + [ drop ] [ [ _ (compute-always-boxed) ] each-def-rep ] if ] each-non-phi ] each-basic-block ] keep ; @@ -135,6 +152,9 @@ SYMBOL: costs ! Insert conversions. This introduces new temporaries, so we need ! to rename opearands too. +! Mapping from vreg,rep pairs to vregs +SYMBOL: alternatives + :: emit-def-conversion ( dst preferred required -- new-dst' ) ! If an instruction defines a register with representation 'required', ! but the register has preferred representation 'preferred', then @@ -147,7 +167,13 @@ SYMBOL: costs ! but the register has preferred representation 'preferred', then ! we rename the instruction's input to a new register, which ! becomes the output of a conversion instruction. - required next-vreg-rep [ src required preferred emit-conversion ] keep ; + preferred required eq? [ src ] [ + src required alternatives get [ + required next-vreg-rep :> new-src + [ new-src ] 2dip preferred emit-conversion + new-src + ] 2cache + ] if ; SYMBOLS: renaming-set needs-renaming? ; @@ -200,6 +226,41 @@ SYMBOL: phi-mappings M: ##phi conversions-for-insn [ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ; +! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference +! with a ##zero-vector or ##fill-vector instruction since this is more efficient. +: convert-to-zero-vector? ( insn -- ? ) + { + [ dst>> rep-of vector-rep? ] + [ obj>> B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } = ] + } 1&& ; +: convert-to-fill-vector? ( insn -- ? ) + { + [ dst>> rep-of vector-rep? ] + [ obj>> B{ 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 } = ] + } 1&& ; + +: (convert-to-zero/fill-vector) ( insn -- dst rep ) + dst>> dup rep-of ; inline + +: conversions-for-load-insn ( insn -- ?insn ) + { + { + [ dup convert-to-zero-vector? ] + [ (convert-to-zero/fill-vector) ##zero-vector f ] + } + { + [ dup convert-to-fill-vector? ] + [ (convert-to-zero/fill-vector) ##fill-vector f ] + } + [ ] + } cond ; + +M: ##load-reference conversions-for-insn + conversions-for-load-insn [ call-next-method ] when* ; + +M: ##load-constant conversions-for-insn + conversions-for-load-insn [ call-next-method ] when* ; + M: vreg-insn conversions-for-insn [ compute-renaming-set ] [ perform-renaming ] bi ; @@ -209,6 +270,7 @@ M: insn conversions-for-insn , ; dup kill-block? [ drop ] [ [ [ + H{ } clone alternatives set [ conversions-for-insn ] each ] V{ } make ] change-instructions drop @@ -266,4 +328,4 @@ PRIVATE> [ insert-conversions ] [ ] } cleave - representations get cfg get (>>reps) ; \ No newline at end of file + representations get cfg get (>>reps) ; diff --git a/basis/compiler/cfg/ssa/cssa/cssa.factor b/basis/compiler/cfg/ssa/cssa/cssa.factor index 14287e900f..d58cebac65 100644 --- a/basis/compiler/cfg/ssa/cssa/cssa.factor +++ b/basis/compiler/cfg/ssa/cssa/cssa.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel locals fry +USING: accessors assocs kernel locals fry sequences cpu.architecture compiler.cfg.rpo +compiler.cfg.def-use compiler.cfg.utilities compiler.cfg.registers compiler.cfg.instructions @@ -13,10 +14,19 @@ IN: compiler.cfg.ssa.cssa ! selection, so it must keep track of representations when introducing ! new values. +: insert-copy? ( bb vreg -- ? ) + ! If the last instruction defines a value (which means it is + ! ##fixnum-add, ##fixnum-sub or ##fixnum-mul) then we don't + ! need to insert a copy since in fact doing so will result + ! in incorrect code. + [ instructions>> last defs-vreg ] dip eq? not ; + :: insert-copy ( bb src rep -- bb dst ) - rep next-vreg-rep :> dst - bb [ dst src rep src rep-of emit-conversion ] add-instructions - bb dst ; + bb src insert-copy? [ + rep next-vreg-rep :> dst + bb [ dst src rep src rep-of emit-conversion ] add-instructions + bb dst + ] [ bb src ] if ; : convert-phi ( ##phi -- ) dup dst>> rep-of '[ [ _ insert-copy ] assoc-map ] change-inputs drop ; diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor index 424be91e2b..071b5d4b20 100644 --- a/basis/compiler/cfg/ssa/destruction/destruction.factor +++ b/basis/compiler/cfg/ssa/destruction/destruction.factor @@ -6,6 +6,7 @@ sets vectors compiler.cfg.rpo compiler.cfg.def-use compiler.cfg.renaming +compiler.cfg.registers compiler.cfg.dominance compiler.cfg.instructions compiler.cfg.liveness.ssa @@ -60,15 +61,23 @@ SYMBOL: copies GENERIC: prepare-insn ( insn -- ) +: try-to-coalesce ( dst src -- ) 2array copies get push ; + +M: insn prepare-insn + [ defs-vreg ] [ uses-vregs ] bi + 2dup empty? not and [ + first + 2dup [ rep-of ] bi@ eq? + [ try-to-coalesce ] [ 2drop ] if + ] [ 2drop ] if ; + M: ##copy prepare-insn - [ dst>> ] [ src>> ] bi 2array copies get push ; + [ dst>> ] [ src>> ] bi try-to-coalesce ; M: ##phi prepare-insn [ dst>> ] [ inputs>> values ] bi [ eliminate-copy ] with each ; -M: insn prepare-insn drop ; - : prepare-block ( bb -- ) instructions>> [ prepare-insn ] each ; diff --git a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor index fd1f09a900..ef24914269 100644 --- a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor +++ b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor @@ -11,28 +11,25 @@ IN: compiler.cfg.ssa.interference.live-ranges SYMBOLS: local-def-indices local-kill-indices ; -: record-def ( n vreg -- ) +: record-def ( n insn -- ) ! We allow multiple defs of a vreg as long as they're ! all in the same basic block - dup [ + defs-vreg dup [ local-def-indices get 2dup key? [ 3drop ] [ set-at ] if ] [ 2drop ] if ; -: record-uses ( n vregs -- ) - local-kill-indices get '[ _ set-at ] with each ; +: record-uses ( n insn -- ) + ! Record live intervals so that all but the first input interfere + ! with the output. This lets us coalesce the output with the + ! first input. + [ uses-vregs ] [ def-is-use-insn? ] bi over empty? [ 3drop ] [ + [ [ first local-kill-indices get set-at ] [ rest-slice ] 2bi ] unless + [ 1 + ] dip [ local-kill-indices get set-at ] with each + ] if ; : visit-insn ( insn n -- ) - ! Instructions are numbered 2 apart. If the instruction requires - ! that outputs are in different registers than the inputs, then - ! a use will be registered for every output immediately after - ! this instruction and before the next one, ensuring that outputs - ! interfere with inputs. - 2 * - [ swap defs-vreg record-def ] - [ swap uses-vregs record-uses ] - [ over def-is-use-insn? [ 1 + swap defs-vreg 1array record-uses ] [ 2drop ] if ] - 2tri ; + 2 * swap [ record-def ] [ record-uses ] 2bi ; SYMBOLS: def-indices kill-indices ; diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor index ce0e98de5f..0bed759e52 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor @@ -9,7 +9,7 @@ IN: compiler.cfg.stacks.uninitialized ! Consider the following sequence of instructions: ! ##inc-d 2 -! _gc +! ##gc ! ##replace ... D 0 ! ##replace ... D 1 ! The GC check runs before stack locations 0 and 1 have been initialized, diff --git a/basis/compiler/cfg/two-operand/summary.txt b/basis/compiler/cfg/two-operand/summary.txt deleted file mode 100644 index 6c9154d306..0000000000 --- a/basis/compiler/cfg/two-operand/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Converting three-operand instructions into two-operand form diff --git a/basis/compiler/cfg/two-operand/two-operand-tests.factor b/basis/compiler/cfg/two-operand/two-operand-tests.factor deleted file mode 100644 index 41094cfac4..0000000000 --- a/basis/compiler/cfg/two-operand/two-operand-tests.factor +++ /dev/null @@ -1,52 +0,0 @@ -USING: kernel compiler.cfg.two-operand compiler.cfg.instructions -compiler.cfg.registers cpu.architecture namespaces tools.test ; -IN: compiler.cfg.two-operand.tests - -3 vreg-counter set-global - -[ - V{ - T{ ##copy f 1 2 int-rep } - T{ ##sub f 1 1 3 } - } -] [ - H{ - { 1 int-rep } - { 2 int-rep } - { 3 int-rep } - } clone representations set - { - T{ ##sub f 1 2 3 } - } (convert-two-operand) -] unit-test - -[ - V{ - T{ ##copy f 1 2 double-rep } - T{ ##sub-float f 1 1 3 } - } -] [ - H{ - { 1 double-rep } - { 2 double-rep } - { 3 double-rep } - } clone representations set - { - T{ ##sub-float f 1 2 3 } - } (convert-two-operand) -] unit-test - -[ - V{ - T{ ##copy f 1 2 double-rep } - T{ ##mul-float f 1 1 1 } - } -] [ - H{ - { 1 double-rep } - { 2 double-rep } - } clone representations set - { - T{ ##mul-float f 1 2 2 } - } (convert-two-operand) -] unit-test diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor deleted file mode 100644 index 20fa1d0b18..0000000000 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ /dev/null @@ -1,81 +0,0 @@ -! Copyright (C) 2008, 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences make combinators -compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.rpo cpu.architecture ; -IN: compiler.cfg.two-operand - -! This pass runs before SSA coalescing and normalizes instructions -! to fit the x86 two-address scheme. Since the input is in SSA, -! it suffices to convert -! -! x = y op z -! -! to -! -! x = y -! x = x op z -! -! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm -! since x86 has LEA and IMUL instructions which are effectively -! three-operand addition and multiplication, respectively. - -UNION: two-operand-insn - ##sub - ##mul - ##and - ##and-imm - ##or - ##or-imm - ##xor - ##xor-imm - ##shl - ##shl-imm - ##shr - ##shr-imm - ##sar - ##sar-imm - ##min - ##max - ##fixnum-add - ##fixnum-sub - ##fixnum-mul - ##add-float - ##sub-float - ##mul-float - ##div-float - ##min-float - ##max-float - ##add-vector - ##sub-vector - ##mul-vector - ##div-vector - ##min-vector - ##max-vector ; - -GENERIC: convert-two-operand* ( insn -- ) - -: emit-copy ( dst src -- ) - dup rep-of ##copy ; inline - -M: two-operand-insn convert-two-operand* - [ [ dst>> ] [ src1>> ] bi emit-copy ] - [ - dup [ src1>> ] [ src2>> ] bi = [ dup dst>> >>src2 ] when - dup dst>> >>src1 , - ] bi ; - -M: ##not convert-two-operand* - [ [ dst>> ] [ src>> ] bi emit-copy ] - [ dup dst>> >>src , ] - bi ; - -M: insn convert-two-operand* , ; - -: (convert-two-operand) ( insns -- insns' ) - dup first kill-vreg-insn? [ - [ [ convert-two-operand* ] each ] V{ } make - ] unless ; - -: convert-two-operand ( cfg -- cfg' ) - two-operand? [ [ (convert-two-operand) ] local-optimization ] when ; \ No newline at end of file diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor index 03aa28d70a..0ac973a206 100644 --- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -14,10 +14,10 @@ C: constant-expr M: constant-expr equal? over constant-expr? [ - { - [ [ value>> class ] bi@ = ] - [ [ value>> ] bi@ = ] - } 2&& + [ value>> ] bi@ + 2dup [ float? ] both? [ fp-bitwise= ] [ + { [ [ class ] bi@ = ] [ = ] } 2&& + ] if ] [ 2drop f ] if ; TUPLE: reference-expr < expr value ; @@ -25,13 +25,7 @@ TUPLE: reference-expr < expr value ; C: reference-expr M: reference-expr equal? - over reference-expr? [ - [ value>> ] bi@ { - { [ 2dup eq? ] [ 2drop t ] } - { [ 2dup [ float? ] both? ] [ fp-bitwise= ] } - [ 2drop f ] - } cond - ] [ 2drop f ] if ; + over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ; : constant>vn ( constant -- vn ) expr>vn ; inline @@ -43,6 +37,8 @@ M: ##load-immediate >expr val>> ; M: ##load-reference >expr obj>> ; +M: ##load-constant >expr obj>> ; + << : input-values ( slot-specs -- slot-specs' ) diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index e598862c2b..3842942a3b 100755 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. +! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.short-circuit arrays fry kernel layouts math namespaces sequences cpu.architecture -math.bitwise math.order classes vectors locals make +math.bitwise math.order math.vectors.simd.intrinsics classes +vectors locals make alien.c-types io.binary grouping compiler.cfg compiler.cfg.registers compiler.cfg.comparisons @@ -15,6 +16,7 @@ IN: compiler.cfg.value-numbering.rewrite : vreg-small-constant? ( vreg -- ? ) vreg>expr { [ constant-expr? ] + [ value>> fixnum? ] [ value>> small-enough? ] } 1&& ; @@ -38,6 +40,7 @@ M: insn rewrite drop f ; [ compare-imm-expr? ] [ compare-float-unordered-expr? ] [ compare-float-ordered-expr? ] + [ test-vector-expr? ] } 1|| ; : rewrite-boolean-comparison? ( insn -- ? ) @@ -51,12 +54,21 @@ M: insn rewrite drop f ; : >compare-imm-expr< ( expr -- in1 in2 cc ) [ src1>> vn>vreg ] [ src2>> vn>constant ] [ cc>> ] tri ; inline +: >test-vector-expr< ( expr -- src1 temp rep vcc ) + { + [ src1>> vn>vreg ] + [ drop next-vreg ] + [ rep>> ] + [ vcc>> ] + } cleave ; inline + : rewrite-boolean-comparison ( expr -- insn ) src1>> vreg>expr { { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] } { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] } { [ dup compare-float-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] } { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-branch new-insn ] } + { [ dup test-vector-expr? ] [ >test-vector-expr< \ ##test-vector-branch new-insn ] } } cond ; : tag-fixnum-expr? ( expr -- ? ) @@ -184,7 +196,7 @@ M: ##compare-branch rewrite : >boolean-insn ( insn ? -- insn' ) [ dst>> ] dip { - { t [ t \ ##load-reference new-insn ] } + { t [ t \ ##load-constant new-insn ] } { f [ \ f tag-number \ ##load-immediate new-insn ] } } case ; @@ -230,6 +242,28 @@ M: ##shl-imm constant-fold* drop shift ; [ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi \ ##load-immediate new-insn ; inline +: unary-constant-fold? ( insn -- ? ) + src>> vreg>expr constant-expr? ; inline + +GENERIC: unary-constant-fold* ( x insn -- y ) + +M: ##not unary-constant-fold* drop bitnot ; +M: ##neg unary-constant-fold* drop neg ; + +: unary-constant-fold ( insn -- insn' ) + [ dst>> ] + [ [ src>> vreg>constant ] [ ] bi unary-constant-fold* ] bi + \ ##load-immediate new-insn ; inline + +: maybe-unary-constant-fold ( insn -- insn' ) + dup unary-constant-fold? [ unary-constant-fold ] [ drop f ] if ; + +M: ##neg rewrite + maybe-unary-constant-fold ; + +M: ##not rewrite + maybe-unary-constant-fold ; + : reassociate ( insn op -- insn ) [ { @@ -258,16 +292,23 @@ M: ##sub-imm rewrite [ sub-imm>add-imm ] } cond ; -: strength-reduce-mul ( insn -- insn' ) - [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ; +: mul-to-neg? ( insn -- ? ) + src2>> -1 = ; + +: mul-to-neg ( insn -- insn' ) + [ dst>> ] [ src1>> ] bi \ ##neg new-insn ; -: strength-reduce-mul? ( insn -- ? ) +: mul-to-shl? ( insn -- ? ) src2>> power-of-2? ; +: mul-to-shl ( insn -- insn' ) + [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ; + M: ##mul-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } - { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] } + { [ dup mul-to-neg? ] [ mul-to-neg ] } + { [ dup mul-to-shl? ] [ mul-to-shl ] } { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] } [ drop f ] } cond ; @@ -338,8 +379,15 @@ M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ; : rewrite-subtraction-identity ( insn -- insn' ) dst>> 0 \ ##load-immediate new-insn ; +: sub-to-neg? ( ##sub -- ? ) + src1>> vn>expr expr-zero? ; + +: sub-to-neg ( ##sub -- insn ) + [ dst>> ] [ src2>> ] bi \ ##neg new-insn ; + M: ##sub rewrite { + { [ dup sub-to-neg? ] [ sub-to-neg ] } { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] } [ \ ##sub-imm rewrite-arithmetic ] } cond ; @@ -375,3 +423,71 @@ M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ; M: ##unbox-any-c-ptr rewrite dup src>> vreg>expr dup box-displaced-alien-expr? [ rewrite-unbox-displaced-alien ] [ 2drop f ] if ; + +! More efficient addressing for alien intrinsics +: rewrite-alien-addressing ( insn -- insn' ) + dup src>> vreg>expr dup add-imm-expr? [ + [ src1>> vn>vreg ] [ src2>> vn>constant ] bi + [ >>src ] [ '[ _ + ] change-offset ] bi* + ] [ 2drop f ] if ; + +M: ##alien-unsigned-1 rewrite rewrite-alien-addressing ; +M: ##alien-unsigned-2 rewrite rewrite-alien-addressing ; +M: ##alien-unsigned-4 rewrite rewrite-alien-addressing ; +M: ##alien-signed-1 rewrite rewrite-alien-addressing ; +M: ##alien-signed-2 rewrite rewrite-alien-addressing ; +M: ##alien-signed-4 rewrite rewrite-alien-addressing ; +M: ##alien-float rewrite rewrite-alien-addressing ; +M: ##alien-double rewrite rewrite-alien-addressing ; +M: ##alien-vector rewrite rewrite-alien-addressing ; +M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ; +M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ; +M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ; +M: ##set-alien-float rewrite rewrite-alien-addressing ; +M: ##set-alien-double rewrite rewrite-alien-addressing ; +M: ##set-alien-vector rewrite rewrite-alien-addressing ; + +! Some lame constant folding for SIMD intrinsics. Eventually this +! should be redone completely. + +: rewrite-shuffle-vector-imm ( insn expr -- insn' ) + 2dup [ rep>> ] bi@ eq? [ + [ [ dst>> ] [ src>> vn>vreg ] bi* ] + [ [ shuffle>> ] bi@ nths ] + [ drop rep>> ] + 2tri \ ##shuffle-vector-imm new-insn + ] [ 2drop f ] if ; + +: (fold-shuffle-vector-imm) ( shuffle bytes -- bytes' ) + 2dup length swap length /i group nths concat ; + +: fold-shuffle-vector-imm ( insn expr -- insn' ) + [ [ dst>> ] [ shuffle>> ] bi ] dip value>> + (fold-shuffle-vector-imm) \ ##load-constant new-insn ; + +M: ##shuffle-vector-imm rewrite + dup src>> vreg>expr { + { [ dup shuffle-vector-imm-expr? ] [ rewrite-shuffle-vector-imm ] } + { [ dup reference-expr? ] [ fold-shuffle-vector-imm ] } + { [ dup constant-expr? ] [ fold-shuffle-vector-imm ] } + [ 2drop f ] + } cond ; + +: (fold-scalar>vector) ( insn bytes -- insn' ) + [ [ dst>> ] [ rep>> rep-components ] bi ] dip concat + \ ##load-constant new-insn ; + +: fold-scalar>vector ( insn expr -- insn' ) + value>> over rep>> { + { float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] } + { double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] } + [ [ untag-fixnum ] dip rep-component-type heap-size >le (fold-scalar>vector) ] + } case ; + +M: ##scalar>vector rewrite + dup src>> vreg>expr dup constant-expr? + [ fold-scalar>vector ] [ 2drop f ] if ; + +M: ##xor-vector rewrite + dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq? + [ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ; diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor index e930bcaae9..df3dc6aab9 100644 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors combinators classes math layouts +sequences math.vectors.simd.intrinsics compiler.cfg.instructions compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.expressions ; @@ -22,6 +23,22 @@ M: unbox-any-c-ptr-expr simplify* simplify-unbox-alien ; : expr-one? ( expr -- ? ) T{ constant-expr f 1 } = ; inline +: expr-neg-one? ( expr -- ? ) T{ constant-expr f -1 } = ; inline + +: >unary-expr< ( expr -- in ) src>> vn>expr ; inline + +M: neg-expr simplify* + >unary-expr< { + { [ dup neg-expr? ] [ src>> ] } + [ drop f ] + } cond ; + +M: not-expr simplify* + >unary-expr< { + { [ dup not-expr? ] [ src>> ] } + [ drop f ] + } cond ; + : >binary-expr< ( expr -- in1 in2 ) [ src1>> vn>expr ] [ src2>> vn>expr ] bi ; inline @@ -113,6 +130,16 @@ M: box-displaced-alien-expr simplify* [ 2drop f ] } cond ; +M: scalar>vector-expr simplify* + src>> vn>expr { + { [ dup vector>scalar-expr? ] [ src>> ] } + [ drop f ] + } cond ; + +M: shuffle-vector-imm-expr simplify* + [ src>> ] [ shuffle>> ] [ rep>> rep-components iota ] tri + sequence= [ drop f ] unless ; + M: expr simplify* drop f ; : simplify ( expr -- vn ) diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 1a28aaa969..733b8cc22a 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -4,7 +4,7 @@ cpu.architecture tools.test kernel math combinators.short-circuit accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce compiler.cfg.ssa.destruction compiler.cfg.loop-detection compiler.cfg.representations compiler.cfg assocs vectors arrays -layouts namespaces alien ; +layouts literals namespaces alien ; IN: compiler.cfg.value-numbering.tests : trim-temps ( insns -- insns ) @@ -14,21 +14,23 @@ IN: compiler.cfg.value-numbering.tests [ ##compare-imm? ] [ ##compare-float-unordered? ] [ ##compare-float-ordered? ] + [ ##test-vector? ] + [ ##test-vector-branch? ] } 1|| [ f >>temp ] when ] map ; ! Folding constants together [ { - T{ ##load-reference f 0 0.0 } - T{ ##load-reference f 1 -0.0 } + T{ ##load-constant f 0 0.0 } + T{ ##load-constant f 1 -0.0 } T{ ##replace f 0 D 0 } T{ ##replace f 1 D 1 } } ] [ { - T{ ##load-reference f 0 0.0 } - T{ ##load-reference f 1 -0.0 } + T{ ##load-constant f 0 0.0 } + T{ ##load-constant f 1 -0.0 } T{ ##replace f 0 D 0 } T{ ##replace f 1 D 1 } } value-numbering-step @@ -36,15 +38,15 @@ IN: compiler.cfg.value-numbering.tests [ { - T{ ##load-reference f 0 0.0 } + T{ ##load-constant f 0 0.0 } T{ ##copy f 1 0 any-rep } T{ ##replace f 0 D 0 } T{ ##replace f 1 D 1 } } ] [ { - T{ ##load-reference f 0 0.0 } - T{ ##load-reference f 1 0.0 } + T{ ##load-constant f 0 0.0 } + T{ ##load-constant f 1 0.0 } T{ ##replace f 0 D 0 } T{ ##replace f 1 D 1 } } value-numbering-step @@ -52,15 +54,15 @@ IN: compiler.cfg.value-numbering.tests [ { - T{ ##load-reference f 0 t } + T{ ##load-constant f 0 t } T{ ##copy f 1 0 any-rep } T{ ##replace f 0 D 0 } T{ ##replace f 1 D 1 } } ] [ { - T{ ##load-reference f 0 t } - T{ ##load-reference f 1 t } + T{ ##load-constant f 0 t } + T{ ##load-constant f 1 t } T{ ##replace f 0 D 0 } T{ ##replace f 1 D 1 } } value-numbering-step @@ -107,19 +109,15 @@ IN: compiler.cfg.value-numbering.tests { T{ ##peek f 8 D 0 } T{ ##peek f 9 D -1 } - T{ ##unbox-float f 10 8 } - T{ ##unbox-float f 11 9 } - T{ ##compare-float-unordered f 12 10 11 cc< } - T{ ##compare-float-unordered f 14 10 11 cc/< } + T{ ##compare-float-unordered f 12 8 9 cc< } + T{ ##compare-float-unordered f 14 8 9 cc/< } T{ ##replace f 14 D 0 } } ] [ { T{ ##peek f 8 D 0 } T{ ##peek f 9 D -1 } - T{ ##unbox-float f 10 8 } - T{ ##unbox-float f 11 9 } - T{ ##compare-float-unordered f 12 10 11 cc< } + T{ ##compare-float-unordered f 12 8 9 cc< } T{ ##compare-imm f 14 12 5 cc= } T{ ##replace f 14 D 0 } } value-numbering-step trim-temps @@ -141,6 +139,20 @@ IN: compiler.cfg.value-numbering.tests } value-numbering-step trim-temps ] unit-test +[ + { + T{ ##peek f 1 D -1 } + T{ ##test-vector f 2 1 f float-4-rep vcc-any } + T{ ##test-vector-branch f 1 f float-4-rep vcc-any } + } +] [ + { + T{ ##peek f 1 D -1 } + T{ ##test-vector f 2 1 f float-4-rep vcc-any } + T{ ##compare-imm-branch f 2 5 cc/= } + } value-numbering-step trim-temps +] unit-test + ! Immediate operand conversion [ { @@ -236,6 +248,78 @@ IN: compiler.cfg.value-numbering.tests } value-numbering-step ] unit-test +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 -1 } + T{ ##neg f 2 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 -1 } + T{ ##mul f 2 0 1 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 -1 } + T{ ##neg f 2 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 -1 } + T{ ##mul f 2 1 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 0 } + T{ ##neg f 2 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 0 } + T{ ##sub f 2 1 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 0 } + T{ ##neg f 2 0 } + T{ ##copy f 3 0 any-rep } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 0 } + T{ ##sub f 2 1 0 } + T{ ##sub f 3 1 2 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##not f 1 0 } + T{ ##copy f 2 0 any-rep } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##not f 1 0 } + T{ ##not f 2 1 } + } value-numbering-step +] unit-test + [ { T{ ##peek f 0 D 0 } @@ -334,6 +418,20 @@ IN: compiler.cfg.value-numbering.tests } value-numbering-step trim-temps ] unit-test +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-constant f 1 3.5 } + T{ ##compare f 2 0 1 cc= } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-constant f 1 3.5 } + T{ ##compare f 2 0 1 cc= } + } value-numbering-step trim-temps +] unit-test + [ { T{ ##peek f 0 D 0 } @@ -362,6 +460,20 @@ IN: compiler.cfg.value-numbering.tests } value-numbering-step ] unit-test +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-constant f 1 3.5 } + T{ ##compare-branch f 0 1 cc= } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-constant f 1 3.5 } + T{ ##compare-branch f 0 1 cc= } + } value-numbering-step trim-temps +] unit-test + [ { T{ ##peek f 0 D 0 } @@ -871,6 +983,34 @@ cell 8 = [ ] unit-test ] when +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 -1 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##neg f 2 1 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 -2 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##not f 2 1 } + } value-numbering-step +] unit-test + ! Displaced alien optimizations 3 vreg-counter set-global @@ -947,7 +1087,7 @@ cell 8 = [ { T{ ##load-immediate f 1 1 } T{ ##load-immediate f 2 2 } - T{ ##load-reference f 3 t } + T{ ##load-constant f 3 t } } ] [ { @@ -961,7 +1101,7 @@ cell 8 = [ { T{ ##load-immediate f 1 1 } T{ ##load-immediate f 2 2 } - T{ ##load-reference f 3 t } + T{ ##load-constant f 3 t } } ] [ { @@ -1000,7 +1140,7 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-reference f 1 t } + T{ ##load-constant f 1 t } } ] [ { @@ -1024,7 +1164,7 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-reference f 1 t } + T{ ##load-constant f 1 t } } ] [ { @@ -1048,7 +1188,7 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-reference f 1 t } + T{ ##load-constant f 1 t } } ] [ { @@ -1057,6 +1197,90 @@ cell 8 = [ } value-numbering-step ] unit-test +[ + { + T{ ##vector>scalar f 1 0 float-4-rep } + T{ ##copy f 2 0 any-rep } + } +] [ + { + T{ ##vector>scalar f 1 0 float-4-rep } + T{ ##scalar>vector f 2 1 float-4-rep } + } value-numbering-step +] unit-test + +[ + { + T{ ##copy f 1 0 any-rep } + } +] [ + { + T{ ##shuffle-vector-imm f 1 0 { 0 1 2 3 } float-4-rep } + } value-numbering-step +] unit-test + +[ + { + T{ ##shuffle-vector-imm f 1 0 { 1 2 3 0 } float-4-rep } + T{ ##shuffle-vector-imm f 2 0 { 0 2 3 1 } float-4-rep } + } +] [ + { + T{ ##shuffle-vector-imm f 1 0 { 1 2 3 0 } float-4-rep } + T{ ##shuffle-vector-imm f 2 1 { 3 1 2 0 } float-4-rep } + } value-numbering-step +] unit-test + +[ + { + T{ ##shuffle-vector-imm f 1 0 { 1 2 3 0 } float-4-rep } + T{ ##shuffle-vector-imm f 2 1 { 1 0 } double-2-rep } + } +] [ + { + T{ ##shuffle-vector-imm f 1 0 { 1 2 3 0 } float-4-rep } + T{ ##shuffle-vector-imm f 2 1 { 1 0 } double-2-rep } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-constant f 0 $[ 55 tag-fixnum ] } + T{ ##load-constant f 1 B{ 55 0 0 0 55 0 0 0 55 0 0 0 55 0 0 0 } } + T{ ##copy f 2 1 any-rep } + } +] [ + { + T{ ##load-constant f 0 $[ 55 tag-fixnum ] } + T{ ##scalar>vector f 1 0 int-4-rep } + T{ ##shuffle-vector-imm f 2 1 { 0 0 0 0 } float-4-rep } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-constant f 0 1.25 } + T{ ##load-constant f 1 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } } + T{ ##copy f 2 1 any-rep } + } +] [ + { + T{ ##load-constant f 0 1.25 } + T{ ##scalar>vector f 1 0 float-4-rep } + T{ ##shuffle-vector-imm f 2 1 { 0 0 0 0 } float-4-rep } + } value-numbering-step +] unit-test + +[ + { + T{ ##zero-vector f 2 float-4-rep } + } +] [ + { + T{ ##xor-vector f 2 1 1 float-4-rep } + } value-numbering-step +] unit-test + : test-branch-folding ( insns -- insns' n ) [ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep @@ -1203,7 +1427,7 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-reference f 1 t } + T{ ##load-constant f 1 t } T{ ##branch } } 0 diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index 97b0c27af1..778d0526d5 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -75,7 +75,7 @@ M: insn remove-dead-barrier drop t ; ! Anticipation of this and set-slot would help too, maybe later FORWARD-ANALYSIS: slot -UNION: access ##read ##write ; +UNION: access ##slot ##slot-imm ##set-slot ##set-slot-imm ; M: slot-analysis transfer-set drop [ H{ } assoc-clone-like ] dip diff --git a/basis/compiler/codegen/codegen-tests.factor b/basis/compiler/codegen/codegen-tests.factor index 225577d0b9..43473ebcbb 100644 --- a/basis/compiler/codegen/codegen-tests.factor +++ b/basis/compiler/codegen/codegen-tests.factor @@ -1,14 +1,14 @@ USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make -compiler.constants ; +compiler.constants words ; IN: compiler.codegen.tests -[ ] [ [ ] with-fixup drop ] unit-test -[ ] [ [ \ + %call ] with-fixup drop ] unit-test +[ ] [ gensym [ ] with-fixup drop ] unit-test +[ ] [ gensym [ \ + %call ] with-fixup drop ] unit-test -[ ] [ [ dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test -[ ] [ [ dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test +[ ] [ gensym [ dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test +[ ] [ gensym [ dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test ! Error checking -[ [ dup define-label %jump-label ] with-fixup ] must-fail -[ [ dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail -[ [ dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail +[ gensym [ dup define-label %jump-label ] with-fixup ] must-fail +[ gensym [ dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail +[ gensym [ dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index e1551f54c0..938219af22 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -4,7 +4,7 @@ USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.strings alien.arrays alien.complex alien.libraries sets libc -continuations.private fry cpu.architecture classes locals +continuations.private fry cpu.architecture classes classes.struct locals source-files.errors slots parser generic.parser compiler.errors compiler.alien @@ -16,8 +16,6 @@ compiler.cfg.registers compiler.cfg.builder compiler.codegen.fixup compiler.utilities ; -QUALIFIED: classes.struct -QUALIFIED: alien.structs IN: compiler.codegen SYMBOL: insn-counts @@ -34,30 +32,21 @@ SYMBOL: calls #! Compile this word later. calls get push ; -SYMBOL: compiling-word - -: compiled-stack-traces? ( -- ? ) 67 getenv ; - ! Mapping _label IDs to label instances SYMBOL: labels -: init-generator ( word -- ) +: init-generator ( -- ) H{ } clone labels set - V{ } clone calls set - compiling-word set - compiled-stack-traces? [ compiling-word get add-literal ] when ; + V{ } clone calls set ; : generate-insns ( asm -- code ) - [ - [ word>> init-generator ] - [ - instructions>> - [ - [ class insn-counts get inc-at ] - [ generate-insn ] - bi - ] each - ] bi + dup word>> [ + init-generator + instructions>> [ + [ class insn-counts get inc-at ] + [ generate-insn ] + bi + ] each ] with-fixup ; : generate ( mr -- asm ) @@ -112,6 +101,7 @@ SYNTAX: CODEGEN: CODEGEN: ##load-immediate %load-immediate CODEGEN: ##load-reference %load-reference +CODEGEN: ##load-constant %load-reference CODEGEN: ##peek %peek CODEGEN: ##replace %replace CODEGEN: ##inc-d %inc-d @@ -144,12 +134,9 @@ CODEGEN: ##sar-imm %sar-imm CODEGEN: ##min %min CODEGEN: ##max %max CODEGEN: ##not %not +CODEGEN: ##neg %neg CODEGEN: ##log2 %log2 CODEGEN: ##copy %copy -CODEGEN: ##integer>bignum %integer>bignum -CODEGEN: ##bignum>integer %bignum>integer -CODEGEN: ##unbox-float %unbox-float -CODEGEN: ##box-float %box-float CODEGEN: ##add-float %add-float CODEGEN: ##sub-float %sub-float CODEGEN: ##mul-float %mul-float @@ -163,19 +150,51 @@ CODEGEN: ##single>double-float %single>double-float CODEGEN: ##double>single-float %double>single-float CODEGEN: ##integer>float %integer>float CODEGEN: ##float>integer %float>integer -CODEGEN: ##unbox-vector %unbox-vector -CODEGEN: ##broadcast-vector %broadcast-vector +CODEGEN: ##zero-vector %zero-vector +CODEGEN: ##fill-vector %fill-vector CODEGEN: ##gather-vector-2 %gather-vector-2 CODEGEN: ##gather-vector-4 %gather-vector-4 -CODEGEN: ##box-vector %box-vector +CODEGEN: ##shuffle-vector-imm %shuffle-vector-imm +CODEGEN: ##shuffle-vector %shuffle-vector +CODEGEN: ##tail>head-vector %tail>head-vector +CODEGEN: ##merge-vector-head %merge-vector-head +CODEGEN: ##merge-vector-tail %merge-vector-tail +CODEGEN: ##signed-pack-vector %signed-pack-vector +CODEGEN: ##unsigned-pack-vector %unsigned-pack-vector +CODEGEN: ##unpack-vector-head %unpack-vector-head +CODEGEN: ##unpack-vector-tail %unpack-vector-tail +CODEGEN: ##integer>float-vector %integer>float-vector +CODEGEN: ##float>integer-vector %float>integer-vector +CODEGEN: ##compare-vector %compare-vector +CODEGEN: ##test-vector %test-vector CODEGEN: ##add-vector %add-vector +CODEGEN: ##saturated-add-vector %saturated-add-vector +CODEGEN: ##add-sub-vector %add-sub-vector CODEGEN: ##sub-vector %sub-vector +CODEGEN: ##saturated-sub-vector %saturated-sub-vector CODEGEN: ##mul-vector %mul-vector +CODEGEN: ##saturated-mul-vector %saturated-mul-vector CODEGEN: ##div-vector %div-vector CODEGEN: ##min-vector %min-vector CODEGEN: ##max-vector %max-vector +CODEGEN: ##dot-vector %dot-vector CODEGEN: ##sqrt-vector %sqrt-vector CODEGEN: ##horizontal-add-vector %horizontal-add-vector +CODEGEN: ##horizontal-sub-vector %horizontal-sub-vector +CODEGEN: ##horizontal-shl-vector %horizontal-shl-vector +CODEGEN: ##horizontal-shr-vector %horizontal-shr-vector +CODEGEN: ##abs-vector %abs-vector +CODEGEN: ##and-vector %and-vector +CODEGEN: ##andn-vector %andn-vector +CODEGEN: ##or-vector %or-vector +CODEGEN: ##xor-vector %xor-vector +CODEGEN: ##not-vector %not-vector +CODEGEN: ##shl-vector %shl-vector +CODEGEN: ##shr-vector %shr-vector +CODEGEN: ##integer>scalar %integer>scalar +CODEGEN: ##scalar>integer %scalar>integer +CODEGEN: ##vector>scalar %vector>scalar +CODEGEN: ##scalar>vector %scalar>vector CODEGEN: ##box-alien %box-alien CODEGEN: ##box-displaced-alien %box-displaced-alien CODEGEN: ##unbox-alien %unbox-alien @@ -204,6 +223,7 @@ CODEGEN: ##compare-imm %compare-imm CODEGEN: ##compare-float-ordered %compare-float-ordered CODEGEN: ##compare-float-unordered %compare-float-unordered CODEGEN: ##save-context %save-context +CODEGEN: ##vm-field-ptr %vm-field-ptr CODEGEN: _fixnum-add %fixnum-add CODEGEN: _fixnum-sub %fixnum-sub @@ -214,6 +234,7 @@ CODEGEN: _compare-branch %compare-branch CODEGEN: _compare-imm-branch %compare-imm-branch CODEGEN: _compare-float-ordered-branch %compare-float-ordered-branch CODEGEN: _compare-float-unordered-branch %compare-float-unordered-branch +CODEGEN: _test-vector-branch %test-vector-branch CODEGEN: _dispatch %dispatch CODEGEN: _spill %spill CODEGEN: _reload %reload @@ -229,7 +250,7 @@ CODEGEN: _reload %reload GENERIC# save-gc-root 1 ( gc-root operand temp -- ) M:: spill-slot save-gc-root ( gc-root operand temp -- ) - temp int-rep operand n>> %reload + temp int-rep operand %reload gc-root temp %save-gc-root ; M: object save-gc-root drop %save-gc-root ; @@ -242,7 +263,7 @@ GENERIC# load-gc-root 1 ( gc-root operand temp -- ) M:: spill-slot load-gc-root ( gc-root operand temp -- ) gc-root temp %load-gc-root - temp int-rep operand n>> %spill ; + temp int-rep operand %spill ; M: object load-gc-root drop %load-gc-root ; @@ -250,15 +271,15 @@ M: object load-gc-root drop %load-gc-root ; : load-data-regs ( data-regs -- ) [ first3 %reload ] each ; -M: _gc generate-insn +M: ##gc generate-insn "no-gc" define-label { - [ [ "no-gc" get ] dip [ temp1>> ] [ temp2>> ] bi %check-nursery ] + [ [ "no-gc" get ] dip [ size>> ] [ temp1>> ] [ temp2>> ] tri %check-nursery ] [ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ] [ data-values>> save-data-regs ] [ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ] [ [ temp1>> ] [ temp2>> ] bi t %save-context ] - [ tagged-values>> length %call-gc ] + [ [ tagged-values>> length ] [ temp1>> ] bi %call-gc ] [ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ] [ data-values>> load-data-regs ] } cleave @@ -270,9 +291,6 @@ M: ##alien-global generate-insn [ dst>> ] [ symbol>> ] [ library>> ] tri %alien-global ; -M: ##vm-field-ptr generate-insn - [ dst>> ] [ fieldname>> ] bi %vm-field-ptr ; - ! ##alien-invoke GENERIC: next-fastcall-param ( rep -- ) @@ -321,10 +339,7 @@ GENERIC: flatten-value-type ( type -- types ) M: object flatten-value-type 1array ; -M: alien.structs:struct-type flatten-value-type ( type -- types ) - stack-size cell align (flatten-int-type) ; - -M: classes.struct:struct-c-type flatten-value-type ( type -- types ) +M: struct-c-type flatten-value-type ( type -- types ) stack-size cell align (flatten-int-type) ; M: long-long-type flatten-value-type ( type -- types ) @@ -437,7 +452,7 @@ M: ##alien-indirect generate-insn ! Generate code for boxing input parameters in a callback. [ dup \ %save-param-reg move-parameters - "nest_stacks" %vm-invoke-1st-arg + %nest-stacks box-parameters ] with-param-regs ; @@ -475,8 +490,6 @@ TUPLE: callback-context ; [ callback-context new do-callback ] % ] [ ] make ; -: %unnest-stacks ( -- ) "unnest_stacks" %vm-invoke-1st-arg ; - M: ##callback-return generate-insn #! All the extra book-keeping for %unwind is only for x86. #! On other platforms its an alias for %return. diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index d44f6afd99..60dd055a5f 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -4,9 +4,12 @@ USING: arrays byte-arrays byte-vectors generic assocs hashtables io.binary kernel kernel.private math namespaces make sequences words quotations strings alien.accessors alien.strings layouts system combinators math.bitwise math.order -accessors growable compiler.constants ; +accessors growable fry generalizations compiler.constants ; IN: compiler.codegen.fixup +! Owner +SYMBOL: compiling-word + ! Literal table SYMBOL: literal-table @@ -91,17 +94,19 @@ SYMBOL: relocation-table [ [ resolve-relative-label ] map concat ] bi* ; -: init-fixup ( -- ) +: init-fixup ( word -- ) + compiling-word set V{ } clone literal-table set V{ } clone label-table set BV{ } clone relocation-table set ; -: with-fixup ( quot -- code ) - [ +: with-fixup ( word quot -- code ) + '[ init-fixup - call + @ label-table [ resolve-labels ] change + compiling-word get literal-table get >array relocation-table get >byte-array label-table get - ] B{ } make 4array ; inline + ] B{ } make 5 narray ; inline diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 306ab515a8..f59d4fb027 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -12,19 +12,21 @@ HELP: disable-optimizer ARTICLE: "compiler-usage" "Calling the optimizing compiler" "Normally, new word definitions are recompiled automatically. This can be changed:" -{ $subsection disable-optimizer } -{ $subsection enable-optimizer } +{ $subsections + disable-optimizer + enable-optimizer +} "Removing a word's optimized definition:" -{ $subsection decompile } +{ $subsections decompile } "Compiling a single quotation:" -{ $subsection compile-call } +{ $subsections compile-call } "Higher-level words can be found in " { $link "compilation-units" } "." ; ARTICLE: "compiler-impl" "Compiler implementation" "The " { $vocab-link "compiler" } "vocabulary, in addition to providing the user-visible words of the compiler, implements the main compilation loop." $nl "Words are added to the " { $link compile-queue } " variable as needed and compiled." -{ $subsection compile-queue } +{ $subsections compile-queue } "Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "." $nl "The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:" @@ -49,10 +51,12 @@ $nl "The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information." $nl "Most code you write will run with the optimizing compiler. Sometimes, the non-optimizing compiler is used, for example for listener interactions, or for running the quotation passed to " { $link POSTPONE: call( } "." -{ $subsection "compiler-errors" } -{ $subsection "hints" } -{ $subsection "compiler-usage" } -{ $subsection "compiler-impl" } ; +{ $subsections + "compiler-errors" + "hints" + "compiler-usage" + "compiler-impl" +} ; ABOUT: "compiler" diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 504acc74b0..626ab678c0 100755 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -44,8 +44,11 @@ SYMBOL: compiled dup recompile-callers? [ compiled-usage keys [ queue-compile ] each ] [ drop ] if ; +: compiler-message ( string -- ) + "trace-compilation" get [ global [ print flush ] bind ] [ drop ] if ; + : start ( word -- ) - "trace-compilation" get [ dup name>> print flush ] when + dup name>> compiler-message H{ } clone dependencies set H{ } clone generic-dependencies set clear-compiler-error ; @@ -194,7 +197,7 @@ M: optimizing-compiler recompile ( words -- alist ) compile-queue get compile-loop compiled get >alist ] with-scope - "trace-compilation" get [ "--- compile done" print flush ] when ; + "--- compile done" compiler-message ; : with-optimizer ( quot -- ) [ optimizing-compiler compiler-impl ] dip with-variable ; inline diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index e21e13dc13..eaa8be72f0 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -4,7 +4,7 @@ compiler continuations effects io io.backend io.pathnames io.streams.string kernel math memory namespaces namespaces.private parser quotations sequences specialized-arrays stack-checker stack-checker.errors -system threads tools.test words ; +system threads tools.test words alien.complex ; FROM: alien.c-types => float short ; SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: char @@ -588,3 +588,8 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ; 123 >>parents ffi_test_48 ] unit-test + +! Regression: calling an undefined function would raise a protection fault +FUNCTION: void this_does_not_exist ( ) ; + +[ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 14ed2294c7..141fc24309 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -1,9 +1,10 @@ -USING: generalizations accessors arrays compiler kernel kernel.private -math hashtables.private math.private namespaces sequences tools.test -namespaces.private slots.private sequences.private byte-arrays alien -alien.accessors layouts words definitions compiler.units io -combinators vectors grouping make alien.c-types combinators.short-circuit -math.order math.libm math.parser ; +USING: generalizations accessors arrays compiler kernel +kernel.private math hashtables.private math.private namespaces +sequences tools.test namespaces.private slots.private +sequences.private byte-arrays alien alien.accessors layouts +words definitions compiler.units io combinators vectors grouping +make alien.c-types combinators.short-circuit math.order +math.libm math.parser math.functions alien.syntax ; FROM: math => float ; QUALIFIED: namespaces.private IN: compiler.tests.codegen @@ -431,3 +432,47 @@ cell 4 = [ ] curry each-integer ] compile-call ] unit-test + +! Bug in CSSA construction +TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-only } ; + +[ 2 ] [ + little-endian? + T{ myseq f B{ 1 0 0 0 } B{ 1 0 0 0 } } + T{ myseq f B{ 0 0 0 1 } B{ 0 0 0 1 } } ? + [ + { myseq } declare + [ 0 2 ] dip dup + [ + [ + over 1 < [ underlying1>> ] [ [ 1 - ] dip underlying2>> ] if + swap 4 * >fixnum alien-signed-4 + ] bi-curry@ bi * + + ] 2curry each-integer + ] compile-call +] unit-test + +! Bug in linear scan's partial sync point logic +[ t ] [ + [ 1.0 100 [ fsin ] times 1.0 float+ ] compile-call + 1.168852488727981 1.e-9 ~ +] unit-test + +[ 65537.0 ] [ + [ 2.0 4 [ 2.0 fpow ] times 1.0 float+ ] compile-call +] unit-test + +! ##box-displaced-alien is a def-is-use instruction +[ ALIEN: 3e9 ] [ + [ + f + 100 [ 10 swap ] times + 1 swap + ] compile-call +] unit-test + +! Forgot to two-operand shifts +[ 2 0 ] [ + 1 1 + [ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call +] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/folding.factor b/basis/compiler/tests/folding.factor index 5050ce1950..ebdee36b70 100644 --- a/basis/compiler/tests/folding.factor +++ b/basis/compiler/tests/folding.factor @@ -1,4 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words +USING: eval tools.test compiler.units vocabs words kernel classes.mixin arrays ; IN: compiler.tests.folding @@ -7,20 +7,18 @@ IN: compiler.tests.folding [ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: math arrays ; + "USING: math arrays ; IN: compiler.tests.folding GENERIC: foldable-generic ( a -- b ) foldable - M: integer foldable-generic f ; - "> eval( -- ) + M: integer foldable-generic f ;" + eval( -- ) ] unit-test [ ] [ - <" - USING: math arrays ; + "USING: math arrays ; IN: compiler.tests.folding - : fold-test ( -- x ) 10 foldable-generic ; - "> eval( -- ) + : fold-test ( -- x ) 10 foldable-generic ;" + eval( -- ) ] unit-test [ t ] [ diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor index 76d7e6de42..e508b55b8d 100644 --- a/basis/compiler/tests/low-level-ir.factor +++ b/basis/compiler/tests/low-level-ir.factor @@ -46,27 +46,13 @@ IN: compiler.tests.low-level-ir } compile-test-bb ] unit-test -! ##copy on floats. We can only run this test if float intrinsics -! are enabled. -\ float+ "intrinsic" word-prop [ - [ 1.5 ] [ - V{ - T{ ##load-reference f 4 1.5 } - T{ ##unbox-float f 1 4 } - T{ ##copy f 2 1 double-rep } - T{ ##box-float f 3 2 } - T{ ##copy f 0 3 int-rep } - } compile-test-bb - ] unit-test -] when - ! make sure slot access works when the destination is ! one of the sources [ t ] [ V{ - T{ ##load-immediate f 1 $[ 2 cell log2 shift ] } + T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] } T{ ##load-reference f 0 { t f t } } - T{ ##slot f 0 0 1 $[ array tag-number ] 2 } + T{ ##slot f 0 0 1 } } compile-test-bb ] unit-test @@ -79,9 +65,9 @@ IN: compiler.tests.low-level-ir [ t ] [ V{ - T{ ##load-immediate f 1 $[ 2 cell log2 shift ] } + T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] } T{ ##load-reference f 0 { t f t } } - T{ ##set-slot f 0 0 1 $[ array tag-number ] 2 } + T{ ##set-slot f 0 0 1 } } compile-test-bb dup first eq? ] unit-test @@ -132,24 +118,3 @@ IN: compiler.tests.low-level-ir T{ ##add-imm f 0 0 -8 } } compile-test-bb ] unit-test - -! These are def-is-use-insns -USE: multiline - -/* - -[ 100 ] [ - V{ - T{ ##load-immediate f 0 100 } - T{ ##integer>bignum f 0 0 1 } - } compile-test-bb -] unit-test - -[ 1 ] [ - V{ - T{ ##load-reference f 0 ALIEN: 8 } - T{ ##unbox-any-c-ptr f 0 0 1 } - } compile-test-bb -] unit-test - -*/ diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 18679ce77b..0c9b1817c8 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -413,5 +413,35 @@ M: object bad-dispatch-position-test* ; ] with-compilation-unit ] unit-test +[ 16 ] [ + [ + 0 2 + [ + nip + [ + 1 + { + [ 16 ] + [ 16 ] + [ 16 ] + } dispatch + ] [ + { + [ ] + [ ] + [ ] + } dispatch + ] bi + ] each-integer + ] compile-call +] unit-test + +: dispatch-branch-problem ( a b c -- d ) + dup 0 < [ "boo" throw ] when + 1 + { [ + ] [ - ] [ * ] } dispatch ; + +[ 3 4 -1 dispatch-branch-problem ] [ "boo" = ] must-fail-with +[ -1 ] [ 3 4 0 dispatch-branch-problem ] unit-test +[ 12 ] [ 3 4 1 dispatch-branch-problem ] unit-test + ! Not sure if I want to fix this... ! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with \ No newline at end of file diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor index 66edd75097..768b926389 100644 --- a/basis/compiler/tests/redefine10.factor +++ b/basis/compiler/tests/redefine10.factor @@ -1,5 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words -kernel ; +USING: eval tools.test compiler.units vocabs words kernel ; IN: compiler.tests.redefine10 ! Mixin redefinition did not recompile all necessary words. @@ -7,21 +6,19 @@ IN: compiler.tests.redefine10 [ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: kernel math classes ; + "USING: kernel math classes ; IN: compiler.tests.redefine10 MIXIN: my-mixin INSTANCE: fixnum my-mixin - : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ; - "> eval( -- ) + : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;" + eval( -- ) ] unit-test [ ] [ - <" - USE: math + "USE: math IN: compiler.tests.redefine10 - INSTANCE: float my-mixin - "> eval( -- ) + INSTANCE: float my-mixin" + eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine11.factor b/basis/compiler/tests/redefine11.factor index dbec57e3d5..0f16a42cc3 100644 --- a/basis/compiler/tests/redefine11.factor +++ b/basis/compiler/tests/redefine11.factor @@ -1,4 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words +USING: eval tools.test compiler.units vocabs words kernel classes.mixin arrays ; IN: compiler.tests.redefine11 @@ -7,8 +7,7 @@ IN: compiler.tests.redefine11 [ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: kernel math classes arrays ; + "USING: kernel math classes arrays ; IN: compiler.tests.redefine11 MIXIN: my-mixin INSTANCE: array my-mixin @@ -16,8 +15,8 @@ IN: compiler.tests.redefine11 GENERIC: my-generic ( a -- b ) M: my-mixin my-generic drop 0 ; M: object my-generic drop 1 ; - : my-inline ( -- b ) { } my-generic ; - "> eval( -- ) + : my-inline ( -- b ) { } my-generic ;" + eval( -- ) ] unit-test [ ] [ diff --git a/basis/compiler/tests/redefine5.factor b/basis/compiler/tests/redefine5.factor index 7613987852..38623393e7 100644 --- a/basis/compiler/tests/redefine5.factor +++ b/basis/compiler/tests/redefine5.factor @@ -1,5 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words -kernel ; +USING: eval tools.test compiler.units vocabs words kernel ; IN: compiler.tests.redefine5 ! Regression: if dispatch was eliminated but method was not inlined, @@ -8,22 +7,19 @@ IN: compiler.tests.redefine5 [ "compiler.tests.redefine5" forget-vocab ] with-compilation-unit [ ] [ - <" - USING: sorting kernel math.order ; + "USING: sorting kernel math.order ; IN: compiler.tests.redefine5 GENERIC: my-generic ( a -- b ) M: object my-generic [ <=> ] sort ; - : my-inline ( a -- b ) my-generic ; - "> eval( -- ) + : my-inline ( a -- b ) my-generic ;" + eval( -- ) ] unit-test [ ] [ - <" - USE: kernel + "USE: kernel IN: compiler.tests.redefine5 TUPLE: my-tuple ; - M: my-tuple my-generic drop 0 ; - "> eval( -- ) + M: my-tuple my-generic drop 0 ;" eval( -- ) ] unit-test [ 0 ] [ diff --git a/basis/compiler/tests/redefine6.factor b/basis/compiler/tests/redefine6.factor index fdf3e7edbb..892c768bc5 100644 --- a/basis/compiler/tests/redefine6.factor +++ b/basis/compiler/tests/redefine6.factor @@ -1,4 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words +USING: eval tools.test compiler.units vocabs words kernel ; IN: compiler.tests.redefine6 @@ -7,24 +7,22 @@ IN: compiler.tests.redefine6 [ ] [ [ "compiler.tests.redefine6" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: kernel kernel.private ; + "USING: kernel kernel.private ; IN: compiler.tests.redefine6 GENERIC: my-generic ( a -- b ) MIXIN: my-mixin M: my-mixin my-generic drop 0 ; - : my-inline ( a -- b ) { my-mixin } declare my-generic ; - "> eval( -- ) + : my-inline ( a -- b ) { my-mixin } declare my-generic ;" + eval( -- ) ] unit-test [ ] [ - <" - USING: kernel ; + "USING: kernel ; IN: compiler.tests.redefine6 TUPLE: my-tuple ; M: my-tuple my-generic drop 1 ; - INSTANCE: my-tuple my-mixin - "> eval( -- ) + INSTANCE: my-tuple my-mixin" + eval( -- ) ] unit-test [ 1 ] [ diff --git a/basis/compiler/tests/redefine7.factor b/basis/compiler/tests/redefine7.factor index cfe29603f9..8e7abcb372 100644 --- a/basis/compiler/tests/redefine7.factor +++ b/basis/compiler/tests/redefine7.factor @@ -1,4 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words +USING: eval tools.test compiler.units vocabs words kernel ; IN: compiler.tests.redefine7 @@ -7,21 +7,19 @@ IN: compiler.tests.redefine7 [ ] [ [ "compiler.tests.redefine7" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: kernel math ; + "USING: kernel math ; IN: compiler.tests.redefine7 MIXIN: my-mixin INSTANCE: fixnum my-mixin - : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ; - "> eval( -- ) + : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;" + eval( -- ) ] unit-test [ ] [ - <" - USE: math + "USE: math IN: compiler.tests.redefine7 - INSTANCE: float my-mixin - "> eval( -- ) + INSTANCE: float my-mixin" + eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine8.factor b/basis/compiler/tests/redefine8.factor index a79bfb5af5..b4deeb3cc1 100644 --- a/basis/compiler/tests/redefine8.factor +++ b/basis/compiler/tests/redefine8.factor @@ -1,4 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words +USING: eval tools.test compiler.units vocabs words kernel ; IN: compiler.tests.redefine8 @@ -7,24 +7,22 @@ IN: compiler.tests.redefine8 [ ] [ [ "compiler.tests.redefine8" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: kernel math math.order sorting ; + "USING: kernel math math.order sorting ; IN: compiler.tests.redefine8 MIXIN: my-mixin INSTANCE: fixnum my-mixin GENERIC: my-generic ( a -- b ) ! We add the bogus quotation here to hinder inlining ! since otherwise we cannot trigger this bug. - M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; - "> eval( -- ) + M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;" + eval( -- ) ] unit-test [ ] [ - <" - USE: math + "USE: math IN: compiler.tests.redefine8 - INSTANCE: float my-mixin - "> eval( -- ) + INSTANCE: float my-mixin" + eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor index 2598246472..abc677dd77 100644 --- a/basis/compiler/tests/redefine9.factor +++ b/basis/compiler/tests/redefine9.factor @@ -1,4 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words +USING: eval tools.test compiler.units vocabs words kernel generic.math ; IN: compiler.tests.redefine9 @@ -7,25 +7,23 @@ IN: compiler.tests.redefine9 [ ] [ [ "compiler.tests.redefine9" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: kernel math math.order sorting ; + "USING: kernel math math.order sorting ; IN: compiler.tests.redefine9 MIXIN: my-mixin INSTANCE: fixnum my-mixin GENERIC: my-generic ( a -- b ) ! We add the bogus quotation here to hinder inlining ! since otherwise we cannot trigger this bug. - M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; - "> eval( -- ) + M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;" + eval( -- ) ] unit-test [ ] [ - <" - USE: math + "USE: math IN: compiler.tests.redefine9 TUPLE: my-tuple ; - INSTANCE: my-tuple my-mixin - "> eval( -- ) + INSTANCE: my-tuple my-mixin" + eval( -- ) ] unit-test [ diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index f2613022fc..0d837d82ae 100755 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/basis/compiler/tree/propagation/branches/branches.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry kernel sequences assocs accessors namespaces math.intervals arrays classes.algebra combinators columns -stack-checker.branches +stack-checker.branches locals math compiler.utilities compiler.tree compiler.tree.combinators @@ -21,6 +21,9 @@ M: #if child-constraints M: #dispatch child-constraints children>> length f ; +! There is an important invariant here, either no flags are set +! in live-branches, exactly one is set, or all are set. + GENERIC: live-branches ( #branch -- indices ) M: #if live-branches @@ -32,8 +35,12 @@ M: #if live-branches } cond nip ; M: #dispatch live-branches - [ children>> length ] [ in-d>> first value-info interval>> ] bi - '[ _ interval-contains? ] map ; + [ children>> ] [ in-d>> first value-info ] bi { + { [ dup class>> null-class? ] [ drop length f ] } + { [ dup literal>> integer? not ] [ drop length t ] } + { [ 2dup literal>> swap bounds-check? not ] [ drop length t ] } + [ literal>> swap length f [ [ t ] 2dip set-nth ] keep ] + } cond ; : live-children ( #branch -- children ) [ children>> ] [ live-branches>> ] bi select-children ; @@ -82,6 +89,13 @@ M: #phi propagate-before ( #phi -- ) [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ] bi ; +:: update-constraints ( new old -- ) + new [| key value | key old [ value append ] change-at ] assoc-each ; + +: include-child-constraints ( i -- ) + infer-children-data get nth constraints swap at last + constraints get last update-constraints ; + : branch-phi-constraints ( output values booleans -- ) { { @@ -116,22 +130,24 @@ M: #phi propagate-before ( #phi -- ) swap t--> ] } - ! { - ! { { t f } { } } - ! [ B - ! first - ! [ [ =t ] bi@ <--> ] - ! [ [ =f ] bi@ <--> ] 2bi /\ - ! ] - ! } - ! { - ! { { } { t f } } - ! [ - ! second - ! [ [ =t ] bi@ <--> ] - ! [ [ =f ] bi@ <--> ] 2bi /\ - ! ] - ! } + { + { { t f } { } } + [ + first + [ [ =t ] bi@ <--> ] + [ [ =f ] bi@ <--> ] 2bi /\ + 0 include-child-constraints + ] + } + { + { { } { t f } } + [ + second + [ [ =t ] bi@ <--> ] + [ [ =f ] bi@ <--> ] 2bi /\ + 1 include-child-constraints + ] + } [ 3drop f ] } case assume ; @@ -146,9 +162,6 @@ M: #phi propagate-after ( #phi -- ) ] 3each ] [ drop ] if ; -M: #phi propagate-around ( #phi -- ) - [ propagate-before ] [ propagate-after ] bi ; - M: #branch propagate-around dup live-branches >>live-branches [ infer-children ] [ annotate-node ] bi ; diff --git a/basis/compiler/tree/propagation/constraints/constraints.factor b/basis/compiler/tree/propagation/constraints/constraints.factor index 31f6cea148..59c9912e47 100644 --- a/basis/compiler/tree/propagation/constraints/constraints.factor +++ b/basis/compiler/tree/propagation/constraints/constraints.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs math math.intervals kernel accessors sequences namespaces classes classes.algebra -combinators words +combinators words combinators.short-circuit compiler.tree compiler.tree.propagation.info compiler.tree.propagation.copy ; @@ -28,15 +28,19 @@ M: object satisfied? drop f ; ! Boolean constraints TUPLE: true-constraint value ; -: =t ( value -- constriant ) resolve-copy true-constraint boa ; +: =t ( value -- constraint ) resolve-copy true-constraint boa ; + +: follow-implications ( constraint -- ) + constraints get assoc-stack [ assume ] when* ; M: true-constraint assume* [ \ f class-not swap value>> refine-value-info ] - [ constraints get assoc-stack [ assume ] when* ] + [ follow-implications ] bi ; M: true-constraint satisfied? - value>> value-info class>> true-class? ; + value>> value-info class>> + { [ true-class? ] [ null-class? not ] } 1&& ; TUPLE: false-constraint value ; @@ -44,11 +48,12 @@ TUPLE: false-constraint value ; M: false-constraint assume* [ \ f swap value>> refine-value-info ] - [ constraints get assoc-stack [ assume ] when* ] + [ follow-implications ] bi ; M: false-constraint satisfied? - value>> value-info class>> false-class? ; + value>> value-info class>> + { [ false-class? ] [ null-class? not ] } 1&& ; ! Class constraints TUPLE: class-constraint value class ; @@ -82,7 +87,7 @@ TUPLE: implication p q ; C: --> implication -: assume-implication ( p q -- ) +: assume-implication ( q p -- ) [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ] [ satisfied? [ assume ] [ drop ] if ] 2bi ; diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 0a04b48160..53b2109bbb 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -302,7 +302,7 @@ SYMBOL: value-infos : refine-value-info ( info value -- ) resolve-copy value-infos get - [ assoc-stack value-info-intersect ] 2keep + [ assoc-stack [ value-info-intersect ] when* ] 2keep last set-at ; : value-literal ( value -- obj ? ) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 621b8d082b..d4780b335b 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -18,6 +18,7 @@ compiler.tree.propagation.constraints compiler.tree.propagation.call-effect compiler.tree.propagation.transforms compiler.tree.propagation.simd ; +FROM: alien.c-types => (signed-interval) (unsigned-interval) ; IN: compiler.tree.propagation.known-words { + - * / } @@ -260,15 +261,9 @@ generic-comparison-ops [ alien-unsigned-8 } [ dup name>> { - { - [ "alien-signed-" ?head ] - [ string>number 8 * 1 - 2^ dup neg swap 1 - [a,b] ] - } - { - [ "alien-unsigned-" ?head ] - [ string>number 8 * 2^ 1 - 0 swap [a,b] ] - } - } cond + { [ "alien-signed-" ?head ] [ string>number (signed-interval) ] } + { [ "alien-unsigned-" ?head ] [ string>number (unsigned-interval) ] } + } cond [a,b] [ fits-in-fixnum? fixnum integer ? ] keep '[ 2drop _ ] "outputs" set-word-prop ] each diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 0da234791b..0a8cb61a9f 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -9,9 +9,10 @@ compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals specialized-arrays system sorting math.libm -math.intervals quotations effects alien ; +math.intervals quotations effects alien alien.data ; FROM: math => float ; SPECIALIZED-ARRAY: double +SPECIALIZED-ARRAY: void* IN: compiler.tree.propagation.tests [ V{ } ] [ [ ] final-classes ] unit-test @@ -764,17 +765,17 @@ MIXIN: empty-mixin [ { word object } declare equal? ] final-classes ] unit-test -! [ V{ string } ] [ -! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes -! ] unit-test +[ V{ string } ] [ + [ dup string? t xor [ "A" throw ] [ ] if ] final-classes +] unit-test -! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test +[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test -! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test +[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test -! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test +[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test -! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test +[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test ! generalize-counter-interval wasn't being called in all the right places. ! bug found by littledan @@ -894,3 +895,14 @@ M: tuple-with-read-only-slot clone [ t ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { /i fixnum/i fixnum/i-fast } inlined? ] unit-test [ f ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { fixnum-shift-fast } inlined? ] unit-test [ f ] [ [ >float dup 0 >= [ 16 /i ] when ] { /i float/f } inlined? ] unit-test + +! We want this to inline +[ t ] [ [ void* ] { } inlined? ] unit-test +[ V{ void*-array } ] [ [ void* ] final-classes ] unit-test + +[ t ] [ [ alien-unsigned-1 255 bitand ] { bitand fixnum-bitand } inlined? ] unit-test +[ t ] [ [ alien-unsigned-1 255 swap bitand ] { bitand fixnum-bitand } inlined? ] unit-test + +[ t ] [ [ { fixnum } declare 256 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test +[ t ] [ [ { fixnum } declare 250 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test +[ f ] [ [ { fixnum } declare 257 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test diff --git a/basis/compiler/tree/propagation/simd/simd.factor b/basis/compiler/tree/propagation/simd/simd.factor index 3baa7cdcbf..1637148b88 100644 --- a/basis/compiler/tree/propagation/simd/simd.factor +++ b/basis/compiler/tree/propagation/simd/simd.factor @@ -1,46 +1,84 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays combinators fry +USING: accessors byte-arrays combinators fry sequences compiler.tree.propagation.info cpu.architecture kernel words math math.intervals math.vectors.simd.intrinsics ; IN: compiler.tree.propagation.simd -\ (simd-v+) { byte-array } "default-output-classes" set-word-prop - -\ (simd-v-) { byte-array } "default-output-classes" set-word-prop - -\ (simd-v*) { byte-array } "default-output-classes" set-word-prop - -\ (simd-v/) { byte-array } "default-output-classes" set-word-prop - -\ (simd-vmin) { byte-array } "default-output-classes" set-word-prop - -\ (simd-vmax) { byte-array } "default-output-classes" set-word-prop - -\ (simd-vsqrt) { byte-array } "default-output-classes" set-word-prop - -\ (simd-sum) [ - nip dup literal?>> [ +{ + (simd-v+) + (simd-v-) + (simd-vneg) + (simd-vabs) + (simd-v+-) + (simd-v*) + (simd-v/) + (simd-vmin) + (simd-vmax) + (simd-sum) + (simd-vsqrt) + (simd-vbitand) + (simd-vbitandn) + (simd-vbitor) + (simd-vbitxor) + (simd-vbitnot) + (simd-vand) + (simd-vandn) + (simd-vor) + (simd-vxor) + (simd-vnot) + (simd-vlshift) + (simd-vrshift) + (simd-hlshift) + (simd-hrshift) + (simd-vshuffle-bytes) + (simd-vshuffle-elements) + (simd-(vmerge-head)) + (simd-(vmerge-tail)) + (simd-(v>float)) + (simd-(v>integer)) + (simd-(vpack-signed)) + (simd-(vpack-unsigned)) + (simd-(vunpack-head)) + (simd-(vunpack-tail)) + (simd-v<=) + (simd-v<) + (simd-v=) + (simd-v>) + (simd-v>=) + (simd-vunordered?) + (simd-with) + (simd-gather-2) + (simd-gather-4) + alien-vector +} [ { byte-array } "default-output-classes" set-word-prop ] each + +: scalar-output-class ( rep -- class ) + dup literal?>> [ literal>> scalar-rep-of { { float-rep [ float ] } { double-rep [ float ] } + [ drop integer ] } case ] [ drop real ] if - -] "outputs" set-word-prop + ; -\ (simd-broadcast) { byte-array } "default-output-classes" set-word-prop +\ (simd-sum) [ nip scalar-output-class ] "outputs" set-word-prop -\ (simd-gather-2) { byte-array } "default-output-classes" set-word-prop +\ (simd-v.) [ 2nip scalar-output-class ] "outputs" set-word-prop -\ (simd-gather-4) { byte-array } "default-output-classes" set-word-prop +{ + (simd-vany?) + (simd-vall?) + (simd-vnone?) +} [ { boolean } "default-output-classes" set-word-prop ] each + +\ (simd-select) [ 2nip scalar-output-class ] "outputs" set-word-prop \ assert-positive [ real [0,inf] value-info-intersect ] "outputs" set-word-prop -\ alien-vector { byte-array } "default-output-classes" set-word-prop - ! If SIMD is not available, inline alien-vector and set-alien-vector ! to get a speedup : inline-unless-intrinsic ( word -- ) diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 8aa6a821d8..b8ff96f833 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -45,6 +45,27 @@ IN: compiler.tree.propagation.transforms : simplify-bitand? ( value -- ? ) value-info literal>> positive-fixnum? ; +: all-ones? ( int -- ? ) + dup 1 + bitand zero? ; inline + +: redundant-bitand? ( var 111... -- ? ) + [ value-info ] bi@ [ interval>> ] [ literal>> ] bi* { + [ nip integer? ] + [ nip all-ones? ] + [ 0 swap [a,b] interval-subset? ] + } 2&& ; + +: (zero-bitand?) ( value-info value-info' -- ? ) + [ interval>> ] [ literal>> ] bi* { + [ nip integer? ] + [ nip bitnot all-ones? ] + [ 0 swap bitnot [a,b] interval-subset? ] + } 2&& ; + +: zero-bitand? ( var1 var2 -- ? ) + [ value-info ] bi@ + { [ (zero-bitand?) ] [ swap (zero-bitand?) ] } 2|| ; + { bitand-integer-integer bitand-integer-fixnum @@ -53,6 +74,18 @@ IN: compiler.tree.propagation.transforms } [ [ { + { + [ dup in-d>> first2 zero-bitand? ] + [ drop [ 2drop 0 ] ] + } + { + [ dup in-d>> first2 redundant-bitand? ] + [ drop [ drop ] ] + } + { + [ dup in-d>> first2 swap redundant-bitand? ] + [ drop [ nip ] ] + } { [ dup in-d>> first simplify-bitand? ] [ drop [ >fixnum fixnum-bitand ] ] diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index d8df81fc0d..b6c6910e34 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -29,9 +29,9 @@ yield-hook [ [ ] ] initialize : alist-most ( alist quot -- pair ) [ [ ] ] dip '[ [ [ second ] bi@ @ ] most ] map-reduce ; inline -: alist-min ( alist -- pair ) [ before? ] alist-most ; +: alist-min ( alist -- pair ) [ before=? ] alist-most ; -: alist-max ( alist -- pair ) [ after? ] alist-most ; +: alist-max ( alist -- pair ) [ after=? ] alist-most ; : penultimate ( seq -- elt ) [ length 2 - ] keep nth ; diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor index 2df4dce916..9922048009 100755 --- a/basis/compression/huffman/huffman.factor +++ b/basis/compression/huffman/huffman.factor @@ -2,31 +2,35 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs fry hashtables io kernel locals math math.order math.parser -math.ranges multiline sequences ; +math.ranges multiline sequences bitstreams bit-arrays ; IN: compression.huffman QUALIFIED-WITH: bitstreams bs ( -- huffman-code ) + 0 0 0 huffman-code boa ; inline -: ( -- code ) 0 0 0 huffman-code boa ; -: next-size ( code -- ) [ 1 + ] change-size [ 2 * ] change-code drop ; -: next-code ( code -- ) [ 1 + ] change-code drop ; +: next-size ( huffman-code -- ) + [ 1 + ] change-size + [ 2 * ] change-code drop ; inline -:: all-patterns ( huff n -- seq ) - n log2 huff size>> - :> free-bits +: next-code ( huffman-code -- ) + [ 1 + ] change-code drop ; inline + +:: all-patterns ( huffman-code n -- seq ) + n log2 huffman-code size>> - :> free-bits free-bits 0 > - [ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ] - [ huff code>> free-bits neg 2^ /i 1array ] if ; + [ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ] + [ huffman-code code>> free-bits neg 2^ /i 1array ] if ; -:: huffman-each ( tdesc quot: ( huff -- ) -- ) +:: huffman-each ( tdesc quot: ( huffman-code -- ) -- ) :> code tdesc [ @@ -34,7 +38,7 @@ TUPLE: huffman-code [ code (>>value) code clone quot call code next-code ] each ] each ; inline -: update-reverse-table ( huff n table -- ) +: update-reverse-table ( huffman-code n table -- ) [ drop all-patterns ] [ nip '[ _ swap _ set-at ] each ] 3bi ; @@ -43,49 +47,29 @@ TUPLE: huffman-code tdesc [ n table update-reverse-table ] huffman-each table seq>> ; -:: huffman-table ( tdesc max -- table ) - max f :> table - tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each - table ; - PRIVATE> -! decoder - TUPLE: huffman-decoder - { bs } - { tdesc } - { rtable } - { bits/level } ; + { bs bit-reader } + { tdesc array } + { rtable array } + { bits/level fixnum } ; -: ( bs tdesc -- decoder ) +: ( bs tdesc -- huffman-decoder ) huffman-decoder new - swap >>tdesc - swap >>bs - 16 >>bits/level - [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ; + swap >>tdesc + swap >>bs + 16 >>bits/level + dup [ tdesc>> ] [ bits/level>> 2^ ] bi reverse-table >>rtable ; inline -: read1-huff ( decoder -- elt ) - 16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last - [ size>> swap bs>> bs:seek ] [ value>> ] bi ; +: read1-huff ( huffman-decoder -- elt ) + 16 over [ bs>> bs:peek ] [ rtable>> nth ] bi + [ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline -! %remove : reverse-bits ( value bits -- value' ) - [ >bin ] [ CHAR: 0 pad-head bin> ] bi* ; - -: read1-huff2 ( decoder -- elt ) - 16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last - [ size>> swap bs>> bs:seek ] [ value>> ] bi ; - -/* -: huff>string ( code -- str ) - [ value>> number>string ] - [ [ code>> ] [ size>> bits>string ] bi ] bi - " = " glue ; - -: huff. ( code -- ) huff>string print ; + [ integer>bit-array ] dip + f pad-tail reverse bit-array>integer ; inline -:: rtable. ( rtable -- ) - rtable length>> log2 :> n - rtable [ swap n bits. [ huff. ] each ] assoc-each ; -*/ +: read1-huff2 ( huffman-decoder -- elt ) + 16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi + [ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline diff --git a/basis/compression/inflate/inflate-tests.factor b/basis/compression/inflate/inflate-tests.factor new file mode 100644 index 0000000000..7bda94a999 --- /dev/null +++ b/basis/compression/inflate/inflate-tests.factor @@ -0,0 +1,102 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test compression.inflate ; +IN: compression.inflate.tests + +[ +B{ + 1 255 255 255 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 122 121 94 119 + 239 237 227 88 16 16 10 5 16 17 26 172 3 20 19 245 22 54 55 + 70 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 139 138 112 127 12 6 234 132 254 250 9 + 24 16 19 38 182 25 27 40 154 2 240 239 235 25 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 163 163 154 57 223 218 192 128 6 4 39 87 13 9 22 63 245 239 + 239 242 240 240 242 243 4 17 17 25 21 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 223 219 + 197 140 26 21 26 221 108 117 136 170 0 0 0 0 0 0 0 194 148 + 147 138 6 4 4 5 4 33 176 175 161 5 80 81 95 251 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 122 121 105 33 246 246 234 80 241 240 + 226 77 28 25 4 58 29 30 68 108 0 0 0 0 0 0 0 0 0 0 0 0 108 + 109 118 250 2 24 24 39 230 225 221 203 107 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 103 102 80 101 249 245 214 208 13 6 240 142 + 44 37 29 65 11 13 22 250 11 15 30 180 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 1 200 201 196 1 208 195 176 132 224 223 207 50 + 253 6 15 181 251 253 0 6 240 241 239 77 14 10 246 64 33 24 + 13 0 7 252 20 0 247 1 249 0 241 253 1 205 129 132 173 52 + 124 123 107 32 17 16 6 15 115 117 143 209 0 0 0 0 1 255 255 + 255 0 0 0 0 0 128 118 95 119 221 222 204 136 1 3 0 0 22 27 + 35 0 249 239 239 0 30 22 3 0 247 4 18 0 250 248 247 0 29 26 + 31 222 239 249 6 164 241 241 230 48 19 19 28 209 29 30 35 + 154 87 88 109 228 1 255 255 255 0 0 0 0 0 0 0 0 0 136 136 + 116 39 227 224 218 110 245 245 242 61 238 238 237 36 11 1 + 254 9 32 37 20 213 7 14 40 151 2 0 246 36 6 8 20 210 8 8 5 + 4 33 32 41 184 10 11 17 232 69 70 80 251 0 255 255 255 0 + 255 255 255 0 255 255 255 0 255 255 255 0 255 255 255 0 255 + 255 255 0 107 104 82 144 88 81 34 255 162 159 134 122 255 + 255 255 0 255 255 255 0 255 255 255 0 255 255 255 0 195 194 + 184 2 255 255 255 0 255 255 255 0 0 255 255 255 0 255 255 + 255 0 255 255 255 0 255 255 255 0 255 255 255 0 174 171 167 + 15 102 99 63 233 132 129 99 133 255 255 255 0 255 255 255 0 + 255 255 255 0 255 255 255 0 255 255 255 0 255 255 255 0 255 + 255 255 0 255 255 255 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 119 119 116 4 240 239 217 143 28 28 30 228 34 36 45 232 0 0 + 0 0 0 0 0 0 38 38 38 4 28 28 28 2 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 4 0 0 0 0 0 0 0 0 33 33 33 3 38 38 38 9 243 243 243 + 252 14 12 44 24 233 235 4 89 250 251 216 126 92 91 76 241 8 + 9 21 235 69 69 70 2 250 250 249 214 0 0 0 223 0 0 0 0 0 0 0 + 0 0 0 0 0 2 0 0 0 0 0 0 0 0 247 247 247 255 25 25 25 11 45 + 46 48 26 239 239 251 219 3 4 1 114 233 236 1 254 21 21 20 + 113 12 11 2 54 1 2 2 215 206 206 206 230 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 1 255 255 255 0 0 0 0 0 0 0 0 0 0 0 0 0 46 46 + 47 8 56 56 49 70 23 21 9 145 237 239 248 180 247 247 2 148 + 225 225 224 234 241 241 240 248 205 205 205 247 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 255 255 255 0 255 255 255 0 255 255 + 255 0 255 255 255 0 255 255 255 0 255 255 255 0 107 106 96 + 75 90 89 73 75 255 255 255 0 255 255 255 0 255 255 255 0 + 255 255 255 0 255 255 255 0 255 255 255 0 255 255 255 0 255 + 255 255 0 +} +] [ +B{ + 56 141 99 252 255 255 63 3 41 160 170 50 174 252 253 219 + 199 17 2 2 92 172 2 130 82 107 152 69 132 191 138 153 153 + 187 125 37 70 115 119 87 65 61 15 219 171 150 127 191 56 37 + 4 132 213 182 73 74 107 204 98 250 240 254 181 36 49 154 23 + 47 158 101 121 255 214 129 6 54 22 245 112 94 78 49 251 175 + 239 223 127 250 240 225 211 103 22 65 65 73 81 98 12 184 + 127 251 104 143 148 168 212 221 156 210 142 85 80 161 67 83 + 38 119 177 177 176 176 178 40 110 88 191 144 53 32 48 254 + 55 166 127 51 21 191 125 123 21 240 241 195 35 95 25 73 22 + 43 89 57 151 28 100 249 156 220 178 95 76 18 18 234 207 30 + 222 61 157 141 174 57 61 45 32 245 231 215 107 23 120 217 + 62 244 233 168 202 58 114 243 138 253 226 230 151 219 130 + 174 142 241 196 201 35 140 23 14 111 104 121 112 255 188 + 209 95 54 254 173 191 255 50 176 125 248 248 222 151 143 + 235 155 131 162 4 47 3 251 31 17 134 239 140 63 25 62 254 + 101 60 219 216 178 214 164 166 58 91 65 80 128 141 191 184 + 180 255 34 3 3 3 3 35 44 26 27 202 226 203 239 222 59 211 + 193 200 204 192 32 38 173 204 240 243 253 123 6 57 49 102 + 134 239 44 66 12 191 126 124 103 144 149 146 191 247 254 39 + 219 146 143 31 159 25 8 11 203 92 148 149 83 158 21 30 145 + 251 132 17 57 29 116 116 148 168 63 126 112 43 239 235 215 + 79 182 239 222 189 85 225 102 252 199 169 160 42 114 149 + 157 79 99 58 19 195 55 21 54 14 145 75 28 28 172 44 138 10 + 154 59 184 184 5 95 184 186 5 252 102 248 255 255 63 86 156 + 157 17 52 33 34 80 233 255 162 249 109 85 232 114 135 15 + 237 96 130 177 177 106 94 183 122 57 127 90 178 253 203 150 + 198 228 86 92 22 192 48 19 122 168 150 151 151 176 124 120 + 127 179 95 70 70 238 137 146 138 238 11 152 184 154 154 26 + 139 140 140 12 134 122 22 24 67 81 81 145 89 77 77 141 243 + 243 231 207 127 248 120 116 36 94 190 102 137 252 245 251 + 70 93 76 180 207 71 14 78 209 215 174 174 110 76 191 126 + 253 188 198 192 192 112 31 217 0 184 137 223 191 127 255 47 + 41 41 201 173 171 103 32 245 254 253 239 219 204 44 140 69 + 47 223 48 254 19 21 21 41 228 225 102 50 99 100 98 186 126 + 238 220 185 103 24 233 0 61 55 234 233 233 115 88 88 24 186 + 137 139 114 78 124 251 254 199 150 239 223 153 166 60 124 + 248 224 213 199 143 31 126 156 61 123 246 59 186 1 184 99 + 33 43 193 59 42 210 211 155 80 32 2 0 2 32 94 128 +} zlib-inflate +] unit-test diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index ff38f94c68..567c435c2e 100644 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -1,60 +1,47 @@ ! Copyright (C) 2009 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs byte-arrays -byte-vectors combinators fry grouping hashtables -compression.huffman images io.binary kernel locals -math math.bitwise math.order math.ranges multiline sequences -sorting ; -IN: compression.inflate - +USING: accessors arrays assocs byte-vectors combinators +combinators.smart compression.huffman fry hashtables io.binary +kernel literals locals math math.bitwise math.order math.ranges +sequences sorting memoize combinators.short-circuit byte-arrays ; QUALIFIED-WITH: bitstreams bs +IN: compression.inflate seq ( assoc -- seq ) - dup keys [ ] [ max ] map-reduce 1 + f - [ '[ swap _ set-nth ] assoc-each ] keep ; - ERROR: zlib-unimplemented ; ERROR: bad-zlib-data ; ERROR: bad-zlib-header ; - + :: check-zlib-header ( data -- ) 16 data bs:peek 2 >le be> 31 mod ! checksum - 0 assert= + 0 assert= 4 data bs:read 8 assert= ! compression method: deflate 4 data bs:read ! log2(max length)-8, 32K max - 7 <= [ bad-zlib-header ] unless - 5 data bs:seek ! drop check bits - 1 data bs:read 0 assert= ! dictionnary - not allowed in png + 7 <= [ bad-zlib-header ] unless + 5 data bs:seek ! drop check bits + 1 data bs:read 0 assert= ! dictionary - not allowed in png 2 data bs:seek ! compression level; ignore ; -:: default-table ( -- table ) - 0 :> table - 0 143 [a,b] 280 287 [a,b] append 8 table set-at - 144 255 [a,b] >array 9 table set-at - 256 279 [a,b] >array 7 table set-at - table enum>seq 1 tail ; - CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 } -: get-table ( values size -- table ) - 16 f clone - [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ; +: get-table ( values size -- table ) + 16 f + [ '[ _ push-at ] 2each ] keep + seq>> rest-slice [ natural-sort ] map ; inline :: decode-huffman-tables ( bitstream -- tables ) 5 bitstream bs:read 257 + 5 bitstream bs:read 1 + - 4 bitstream bs:read 4 + - clen-shuffle swap head - dup [ drop 3 bitstream bs:read ] map + 4 bitstream bs:read 4 + clen-shuffle swap head + + dup length iota [ 3 bitstream bs:read ] replicate get-table - bitstream swap + bitstream swap [ 2dup + ] dip swap :> k! '[ - _ read1-huff2 - { + _ read1-huff2 { { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] } { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] } { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] } @@ -62,158 +49,121 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 } } cond dup array? [ dup second ] [ 1 ] if k swap - dup k! 0 > - ] - [ ] produce swap suffix - { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1 + swap append ] bi* ] [ suffix ] if ] reduce + ] [ ] produce swap suffix + { } [ + dup { [ array? ] [ first 16 = ] } 1&& [ + [ unclip-last-slice ] + [ second 1 + swap append ] bi* + ] [ + suffix + ] if + ] reduce [ dup array? [ second 0 ] [ 1array ] if ] map concat - nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ; - + nip swap cut 2array + [ [ length>> iota ] [ ] bi get-table ] map ; + +MEMO: static-huffman-tables ( -- obj ) + [ + 0 143 [a,b] [ 8 ] replicate + 144 255 [a,b] [ 9 ] replicate append + 256 279 [a,b] [ 7 ] replicate append + 280 287 [a,b] [ 8 ] replicate append + ] append-outputs + 0 31 [a,b] [ 5 ] replicate 2array + [ [ length>> [0,b) ] [ ] bi get-table ] map ; + CONSTANT: length-table { - 3 4 5 6 7 8 9 10 - 11 13 15 17 - 19 23 27 31 - 35 43 51 59 - 67 83 99 115 - 131 163 195 227 258 + 3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 + 35 43 51 59 67 83 99 115 131 163 195 227 258 } CONSTANT: dist-table { - 1 2 3 4 - 5 7 9 13 - 17 25 33 49 - 65 97 129 193 - 257 385 513 769 - 1025 1537 2049 3073 - 4097 6145 8193 12289 - 16385 24577 + 1 2 3 4 5 7 9 13 17 25 33 49 + 65 97 129 193 257 385 513 769 1025 1537 2049 3073 + 4097 6145 8193 12289 16385 24577 } : nth* ( n seq -- elt ) - [ length 1 - swap - ] [ nth ] bi ; + [ length 1 - swap - ] [ nth ] bi ; inline -:: inflate-lz77 ( seq -- bytes ) +:: inflate-lz77 ( seq -- byte-array ) 1000 :> bytes - seq - [ + seq [ dup array? [ first2 '[ _ 1 - bytes nth* bytes push ] times ] [ bytes push ] if - ] each - bytes ; + ] each + bytes >byte-array ; -:: inflate-dynamic ( bitstream -- bytes ) - bitstream decode-huffman-tables - bitstream '[ _ swap ] map :> tables +:: inflate-huffman ( bitstream tables -- bytes ) + bitstream tables [ ] with map :> tables [ tables first read1-huff2 - dup 256 > - [ - dup 285 = - [ ] - [ - dup 264 > - [ - dup 261 - 4 /i dup 5 > - [ bad-zlib-data ] when - bitstream bs:read 2array - ] - when - ] if - ! 5 bitstream read-bits ! distance + dup 256 > [ + dup 285 = [ + dup 264 > [ + dup 261 - 4 /i + dup 5 > [ bad-zlib-data ] when + bitstream bs:read 2array + ] when + ] unless + tables second read1-huff2 - dup 3 > - [ + + dup 3 > [ dup 2 - 2 /i dup 13 > [ bad-zlib-data ] when bitstream bs:read 2array - ] - when - 2array - ] - when - dup 256 = not - ] - [ ] produce nip + ] when 2array + ] when dup 256 = not + ] [ ] produce nip [ dup array? [ - first2 - [ + first2 [ dup array? [ first2 ] [ 0 ] if [ 257 - length-table nth ] [ + ] bi* - ] - [ + ] [ dup array? [ first2 ] [ 0 ] if [ dist-table nth ] [ + ] bi* - ] bi* - 2array + ] bi* 2array ] when ] map ; - -:: inflate-raw ( bitstream -- bytes ) - 8 bitstream bs:align + +:: inflate-raw ( bitstream -- bytes ) + 8 bitstream bs:align 16 bitstream bs:read :> len 16 bitstream bs:read :> nlen - len nlen + 16 >signed -1 assert= ! len + ~len = -1 + + ! len + ~len = -1 + len nlen + 16 >signed -1 assert= + bitstream byte-pos>> bitstream byte-pos>> len + bitstream bytes>> len 8 * bitstream bs:seek ; -: inflate-static ( bitstream -- bytes ) zlib-unimplemented ; +: inflate-dynamic ( bitstream -- array ) + dup decode-huffman-tables inflate-huffman ; -:: inflate-loop ( bitstream -- bytes ) - [ 1 bitstream bs:read 0 = ] - [ +: inflate-static ( bitstream -- array ) + static-huffman-tables inflate-huffman ; + +:: inflate-loop ( bitstream -- array ) + [ 1 bitstream bs:read 0 = ] [ bitstream 2 bitstream bs:read - { + { { 0 [ inflate-raw ] } { 1 [ inflate-static ] } { 2 [ inflate-dynamic ] } { 3 [ bad-zlib-data f ] } - } - case - ] - [ produce ] keep call suffix concat ; - - ! [ produce ] keep dip swap suffix - -:: paeth ( a b c -- p ) - a b + c - { a b c } [ [ - abs ] keep 2array ] with map - sort-keys first second ; - -:: png-unfilter-line ( prev curr filter -- curr' ) - prev :> c - prev 3 tail-slice :> b - curr :> a - curr 3 tail-slice :> x - x length [0,b) - filter - { - { 0 [ drop ] } - { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] } - { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] } - { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] } - { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] } - - } case - curr 3 tail ; + } case + ] [ produce ] keep call suffix concat ; PRIVATE> -: reverse-png-filter' ( lines -- byte-array ) - [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip - concat [ 128 + ] B{ } map-as ; - -: reverse-png-filter ( lines -- byte-array ) - dup first [ 0 ] replicate prefix - [ { 0 0 } prepend ] map - 2 clump [ - first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line - ] map B{ } concat-as ; - : zlib-inflate ( bytes -- bytes ) bs: [ check-zlib-header ] [ inflate-loop ] bi diff --git a/basis/compression/lzw/authors.txt b/basis/compression/lzw/authors.txt index b4bd0e7b35..14da4319b2 100644 --- a/basis/compression/lzw/authors.txt +++ b/basis/compression/lzw/authors.txt @@ -1 +1,2 @@ -Doug Coleman \ No newline at end of file +Doug Coleman +Keith Lazuka diff --git a/basis/compression/lzw/lzw-docs.factor b/basis/compression/lzw/lzw-docs.factor new file mode 100644 index 0000000000..dccfb25a39 --- /dev/null +++ b/basis/compression/lzw/lzw-docs.factor @@ -0,0 +1,85 @@ +! Copyright (C) 2009 Keith Lazuka +! See http://factorcode.org/license.txt for BSD license. +USING: bitstreams byte-arrays classes help.markup help.syntax +kernel math quotations sequences ; +IN: compression.lzw + +HELP: gif-lzw-uncompress +{ $values + { "seq" sequence } { "code-size" integer } + { "byte-array" byte-array } +} +{ $description "Decompresses a sequence of LZW-compressed bytes obtained from a GIF file." } ; + +HELP: tiff-lzw-uncompress +{ $values + { "seq" sequence } + { "byte-array" byte-array } +} +{ $description "Decompresses a sequence of LZW-compressed bytes obtained from a TIFF file." } ; + +HELP: lzw-read +{ $values + { "lzw" lzw } + { "lzw" lzw } { "n" integer } +} +{ $description "Read the next LZW code." } ; + +HELP: lzw-process-next-code +{ $values + { "lzw" lzw } { "quot" quotation } +} +{ $description "Read the next LZW code and, assuming that the code is neither the Clear Code nor the End of Information Code, conditionally processes it by calling " { $snippet "quot" } " with the lzw object and the LZW code. If it does read a Clear Code, this combinator will take care of handling the Clear Code for you." } ; + +HELP: +{ $values + { "input" bit-reader } { "code-size" "number of bits" } { "class" class } + { "obj" object } +} +{ $description "Instantiate a new LZW decompressor." } ; + +HELP: code-space-full? +{ $values + { "lzw" lzw } + { "?" boolean } +} +{ $description "Determines when to increment the variable length code's bit-width." } ; + +HELP: reset-lzw-uncompress +{ $values + { "lzw" lzw } + { "lzw" lzw } +} +{ $description "Reset the LZW uncompressor state (either at initialization time or immediately after receiving a Clear Code). " } ; + +ARTICLE: "compression.lzw.differences" "LZW Differences between TIFF and GIF" +{ $vocab-link "compression.lzw" } +$nl +"There are some subtle differences between the LZW algorithm used by TIFF and GIF images." +{ $heading "Variable Length Codes" } +"Both TIFF and GIF use a variation of the LZW algorithm that uses variable length codes. In both cases, the maximum code size is 12 bits. The initial code size, however, is different between the two formats. TIFF's initial code size is always 9 bits. GIF's initial code size is specified on a per-file basis at the beginning of the image descriptor block, with a minimum of 3 bits." +$nl +"TIFF and GIF each switch to the next code size using slightly different algorithms. GIF increments the code size as soon as the LZW string table's length is equal to 2**code-size, while TIFF increments the code size when the table's length is equal to 2**code-size - 1." +{ $heading "Packing Bits into Bytes" } +"TIFF and GIF LZW algorithms differ in how they pack the code bits into the byte stream. The least significant bit in a TIFF code is stored in the most significant bit of the bytestream, while the least significant bit in a GIF code is stored in the least significant bit of the bytestream." +{ $heading "Special Codes" } +"TIFF and GIF both add the concept of a 'Clear Code' and a 'End of Information Code' to the LZW algorithm. In both cases, the 'Clear Code' is equal to 2**(code-size - 1) and the 'End of Information Code' is equal to the Clear Code + 1. These 2 codes are reserved in the string table. So in both cases, the LZW string table is initialized to have a length equal to the End of Information Code + 1." +; + +ARTICLE: "compression.lzw" "LZW Compression" +{ $vocab-link "compression.lzw" } +$nl +"Implements both the TIFF and GIF variations of the LZW algorithm." +{ $heading "Decompression" } +{ $subsections + tiff-lzw-uncompress + gif-lzw-uncompress +} +{ $heading "Compression" } +"Compression has not yet been implemented." +$nl +"Implementation details:" +{ $subsections "compression.lzw.differences" } +; + +ABOUT: "compression.lzw" diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index 46a319662e..e017636009 100644 --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -1,39 +1,37 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.accessors assocs byte-arrays combinators -io.encodings.binary io.streams.byte-array kernel math sequences -vectors ; -IN: compression.lzw - +USING: accessors combinators io kernel math namespaces +prettyprint sequences vectors ; QUALIFIED-WITH: bitstreams bs +IN: compression.lzw -CONSTANT: clear-code 256 -CONSTANT: end-of-information 257 - -TUPLE: lzw input output table code old-code ; - -SYMBOL: table-full - -: lzw-bit-width ( n -- n' ) - { - { [ dup 510 <= ] [ drop 9 ] } - { [ dup 1022 <= ] [ drop 10 ] } - { [ dup 2046 <= ] [ drop 11 ] } - { [ dup 4094 <= ] [ drop 12 ] } - [ drop table-full ] - } cond ; +TUPLE: lzw +input +output +table +code +old-code +initial-code-size +code-size +clear-code +end-of-information-code ; -: lzw-bit-width-uncompress ( lzw -- n ) - table>> length lzw-bit-width ; +TUPLE: tiff-lzw < lzw ; +TUPLE: gif-lzw < lzw ; -: initial-uncompress-table ( -- seq ) - 258 iota [ 1vector ] V{ } map-as ; +: initial-uncompress-table ( size -- seq ) + iota [ 1vector ] V{ } map-as ; : reset-lzw-uncompress ( lzw -- lzw ) - initial-uncompress-table >>table ; - -: ( input -- obj ) - lzw new + dup end-of-information-code>> 1 + initial-uncompress-table >>table + dup initial-code-size>> >>code-size ; + +: ( input code-size class -- obj ) + new + swap >>code-size + dup code-size>> >>initial-code-size + dup code-size>> 1 - 2^ >>clear-code + dup clear-code>> 1 + >>end-of-information-code swap >>input BV{ } clone >>output reset-lzw-uncompress ; @@ -55,22 +53,43 @@ ERROR: not-in-table value ; : write-code ( lzw -- ) [ lookup-code ] [ output>> ] bi push-all ; -: add-to-table ( seq lzw -- ) table>> push ; +GENERIC: code-space-full? ( lzw -- ? ) + +: size-and-limit ( lzw -- m n ) [ table>> length ] [ code-size>> 2^ ] bi ; + +M: tiff-lzw code-space-full? size-and-limit 1 - = ; +M: gif-lzw code-space-full? size-and-limit = ; + +: maybe-increment-code-size ( lzw -- lzw ) + dup code-space-full? [ [ 1 + ] change-code-size ] when ; + +: add-to-table ( seq lzw -- ) + [ table>> push ] + [ maybe-increment-code-size 2drop ] 2bi ; : lzw-read ( lzw -- lzw n ) - [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ; + [ ] [ code-size>> ] [ input>> ] tri bs:read ; + +: end-of-information? ( lzw code -- ? ) swap end-of-information-code>> = ; +: clear-code? ( lzw code -- ? ) swap clear-code>> = ; + +DEFER: handle-clear-code +: lzw-process-next-code ( lzw quot: ( lzw code -- ) -- ) + [ lzw-read ] dip { + { [ 3dup drop end-of-information? ] [ 3drop ] } + { [ 3dup drop clear-code? ] [ 2drop handle-clear-code ] } + [ call( lzw code -- ) ] + } cond ; inline DEFER: lzw-uncompress-char : handle-clear-code ( lzw -- ) reset-lzw-uncompress - lzw-read dup end-of-information = [ - 2drop - ] [ + [ >>code [ write-code ] [ code>old-code ] bi lzw-uncompress-char - ] if ; + ] lzw-process-next-code ; : handle-uncompress-code ( lzw -- lzw ) dup code-in-table? [ @@ -89,23 +108,15 @@ DEFER: lzw-uncompress-char ] if ; : lzw-uncompress-char ( lzw -- ) - lzw-read [ - >>code - dup code>> end-of-information = [ - drop - ] [ - dup code>> clear-code = [ - handle-clear-code - ] [ - handle-uncompress-code - lzw-uncompress-char - ] if - ] if - ] [ - drop - ] if* ; + [ >>code handle-uncompress-code lzw-uncompress-char ] + lzw-process-next-code ; -: lzw-uncompress ( seq -- byte-array ) - bs: +: lzw-uncompress ( bitstream code-size class -- byte-array ) [ lzw-uncompress-char ] [ output>> ] bi ; + +: tiff-lzw-uncompress ( seq -- byte-array ) + bs: 9 tiff-lzw lzw-uncompress ; + +: gif-lzw-uncompress ( seq code-size -- byte-array ) + [ bs: ] dip gif-lzw lzw-uncompress ; diff --git a/basis/compression/zlib/ffi/ffi.factor b/basis/compression/zlib/ffi/ffi.factor index a472f9a2fe..553b55cf6e 100755 --- a/basis/compression/zlib/ffi/ffi.factor +++ b/basis/compression/zlib/ffi/ffi.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax combinators system alien.libraries ; +USING: alien alien.c-types alien.syntax combinators system +alien.libraries ; IN: compression.zlib.ffi << "zlib" { diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor index c61967fc8a..177a00b8c3 100644 --- a/basis/concurrency/combinators/combinators-docs.factor +++ b/basis/concurrency/combinators/combinators-docs.factor @@ -30,14 +30,18 @@ ARTICLE: "concurrency.combinators" "Concurrent combinators" "The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of various combinators." $nl "Concurrent sequence combinators:" -{ $subsection parallel-each } -{ $subsection 2parallel-each } -{ $subsection parallel-map } -{ $subsection 2parallel-map } -{ $subsection parallel-filter } +{ $subsections + parallel-each + 2parallel-each + parallel-map + 2parallel-map + parallel-filter +} "Concurrent cleave combinators:" -{ $subsection parallel-cleave } -{ $subsection parallel-spread } -{ $subsection parallel-napply } ; +{ $subsections + parallel-cleave + parallel-spread + parallel-napply +} ; ABOUT: "concurrency.combinators" diff --git a/basis/concurrency/count-downs/count-downs-docs.factor b/basis/concurrency/count-downs/count-downs-docs.factor index 12681e2638..4c961deb96 100644 --- a/basis/concurrency/count-downs/count-downs-docs.factor +++ b/basis/concurrency/count-downs/count-downs-docs.factor @@ -17,9 +17,11 @@ HELP: await ARTICLE: "concurrency.count-downs" "Count-down latches" "The " { $vocab-link "concurrency.count-downs" } " vocabulary implements the " { $emphasis "count-down latch" } " data type, whichis a wrapper for a non-negative integer value which tends towards zero. A thread can either decrement the value, or wait for it to become zero." -{ $subsection } -{ $subsection count-down } -{ $subsection await } +{ $subsections + + count-down + await +} "The vocabulary was modelled after a similar feature in Java's " { $snippet "java.util.concurrent" } " library." ; ABOUT: "concurrency.count-downs" diff --git a/basis/concurrency/distributed/distributed-docs.factor b/basis/concurrency/distributed/distributed-docs.factor index 91de425d8a..76c9918cca 100644 --- a/basis/concurrency/distributed/distributed-docs.factor +++ b/basis/concurrency/distributed/distributed-docs.factor @@ -10,9 +10,9 @@ HELP: start-node ARTICLE: "concurrency.distributed" "Distributed message passing" "The " { $vocab-link "concurrency.distributed" } " implements transparent distributed message passing, inspired by Erlang and Termite." -{ $subsection start-node } +{ $subsections start-node } "Instances of " { $link thread } " can be sent to remote processes, at which point they are converted to objects holding the thread ID and the current node's host name:" -{ $subsection remote-process } +{ $subsections remote-process } "The " { $vocab-link "serialize" } " vocabulary is used to convert Factor objects to byte arrays for transfer over a socket." ; ABOUT: "concurrency.distributed" diff --git a/basis/concurrency/exchangers/exchangers-docs.factor b/basis/concurrency/exchangers/exchangers-docs.factor index d283b92452..48dd04f4f7 100644 --- a/basis/concurrency/exchangers/exchangers-docs.factor +++ b/basis/concurrency/exchangers/exchangers-docs.factor @@ -14,9 +14,11 @@ HELP: exchange ARTICLE: "concurrency.exchangers" "Object exchange points" "The " { $vocab-link "concurrency.exchangers" } " vocabulary implements " { $emphasis "object exchange points" } ", which are rendezvous points where two threads can exchange objects." -{ $subsection exchanger } -{ $subsection } -{ $subsection exchange } +{ $subsections + exchanger + + exchange +} "One use-case is two threads, where one thread reads data into a buffer and another thread processes the data. The reader thread can begin by reading the data, then passing the buffer through an exchanger, then recursing. The processing thread can begin by creating an empty buffer, and exchanging it through the exchanger. It then processes the result and recurses." $nl "The vocabulary was modelled after a similar feature in Java's " { $snippet "java.util.concurrent" } " library." ; diff --git a/basis/concurrency/flags/flags-docs.factor b/basis/concurrency/flags/flags-docs.factor index 1b2c1b754e..2d622d6b30 100644 --- a/basis/concurrency/flags/flags-docs.factor +++ b/basis/concurrency/flags/flags-docs.factor @@ -28,11 +28,15 @@ $nl "The flag can be raised at any time; raising a raised flag does nothing. Lowering a flag if it has not been raised yet will wait for another thread to raise the flag." $nl "Essentially, a flag can be thought of as a counting semaphore where the count never goes above one." -{ $subsection flag } -{ $subsection flag? } +{ $subsections + flag + flag? +} "Waiting for a flag to be raised:" -{ $subsection raise-flag } -{ $subsection wait-for-flag } -{ $subsection lower-flag } ; +{ $subsections + raise-flag + wait-for-flag + lower-flag +} ; ABOUT: "concurrency.flags" diff --git a/basis/concurrency/futures/futures-docs.factor b/basis/concurrency/futures/futures-docs.factor index 3d2ac552de..ff5773a86c 100644 --- a/basis/concurrency/futures/futures-docs.factor +++ b/basis/concurrency/futures/futures-docs.factor @@ -22,8 +22,10 @@ HELP: ?future ARTICLE: "concurrency.futures" "Futures" "The " { $vocab-link "concurrency.futures" } " vocabulary implements " { $emphasis "futures" } ", which are deferred computations performed in a background thread. A thread may create a future, then proceed to perform other tasks, then later wait for the future to complete." -{ $subsection future } -{ $subsection ?future } -{ $subsection ?future-timeout } ; +{ $subsections + future + ?future + ?future-timeout +} ; ABOUT: "concurrency.futures" diff --git a/basis/concurrency/locks/locks-docs.factor b/basis/concurrency/locks/locks-docs.factor index b74dcec384..f600b01056 100644 --- a/basis/concurrency/locks/locks-docs.factor +++ b/basis/concurrency/locks/locks-docs.factor @@ -26,11 +26,13 @@ ARTICLE: "concurrency.locks.mutex" "Mutual-exclusion locks" "A mutual-exclusion lock ensures that only one thread executes with the lock held at a time. They are used to protect critical sections so that certain operations appear to be atomic to other threads." $nl "There are two varieties of locks: non-reentrant and reentrant. The latter may be acquired recursively by the same thread. Attempting to do so with the former will deadlock." -{ $subsection lock } -{ $subsection } -{ $subsection } -{ $subsection with-lock } -{ $subsection with-lock-timeout } ; +{ $subsections + lock + + + with-lock + with-lock-timeout +} ; HELP: rw-lock { $class-description "The class of reader/writer locks." } ; @@ -61,17 +63,23 @@ $nl "Read/write locks allow any number of threads to hold the read lock simulateneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks." $nl "Read/write locks are reentrant. A thread holding a write lock may acquire a read lock or a write lock without blocking. However a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held." -{ $subsection rw-lock } -{ $subsection } -{ $subsection with-read-lock } -{ $subsection with-write-lock } +{ $subsections + rw-lock + + with-read-lock + with-write-lock +} "Versions of the above that take a timeout duration:" -{ $subsection with-read-lock-timeout } -{ $subsection with-write-lock-timeout } ; +{ $subsections + with-read-lock-timeout + with-write-lock-timeout +} ; ARTICLE: "concurrency.locks" "Locks" "A " { $emphasis "lock" } " is an object protecting a critical region of code, enforcing a particular mutual-exclusion policy. The " { $vocab-link "concurrency.locks" } " vocabulary implements two types of locks:" -{ $subsection "concurrency.locks.mutex" } -{ $subsection "concurrency.locks.rw" } ; +{ $subsections + "concurrency.locks.mutex" + "concurrency.locks.rw" +} ; ABOUT: "concurrency.locks" diff --git a/basis/concurrency/mailboxes/mailboxes-docs.factor b/basis/concurrency/mailboxes/mailboxes-docs.factor index 234fb27d60..a58a1a4cc6 100644 --- a/basis/concurrency/mailboxes/mailboxes-docs.factor +++ b/basis/concurrency/mailboxes/mailboxes-docs.factor @@ -53,20 +53,28 @@ HELP: mailbox-get? ARTICLE: "concurrency.mailboxes" "Mailboxes" "A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary." -{ $subsection mailbox } -{ $subsection } +{ $subsections + mailbox + +} "Removing the first element:" -{ $subsection mailbox-get } -{ $subsection mailbox-get-timeout } +{ $subsections + mailbox-get + mailbox-get-timeout +} "Removing the first element matching a predicate:" -{ $subsection mailbox-get? } -{ $subsection mailbox-get-timeout? } +{ $subsections + mailbox-get? + mailbox-get-timeout? +} "Emptying out a mailbox:" -{ $subsection mailbox-get-all } +{ $subsections mailbox-get-all } "Adding an element:" -{ $subsection mailbox-put } +{ $subsections mailbox-put } "Testing if a mailbox is empty:" -{ $subsection mailbox-empty? } -{ $subsection while-mailbox-empty } ; +{ $subsections + mailbox-empty? + while-mailbox-empty +} ; ABOUT: "concurrency.mailboxes" diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor index d58df3519b..17f05e20fb 100644 --- a/basis/concurrency/messaging/messaging-docs.factor +++ b/basis/concurrency/messaging/messaging-docs.factor @@ -38,19 +38,21 @@ $nl "The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is." $nl "The " { $link spawn } " word pushes the newly-created thread on the calling thread's stack; this thread object can then be sent messages:" -{ $subsection send } +{ $subsections send } "A thread can get a message from its queue:" -{ $subsection receive } -{ $subsection receive-timeout } -{ $subsection receive-if } -{ $subsection receive-if-timeout } +{ $subsections + receive + receive-timeout + receive-if + receive-if-timeout +} { $see-also "concurrency.mailboxes" } ; 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:" -{ $subsection send-synchronous } +{ $subsections send-synchronous } "To reply to a synchronous message:" -{ $subsection reply-synchronous } +{ $subsections reply-synchronous } "An example:" { $example "USING: concurrency.messaging threads ;" @@ -66,7 +68,7 @@ ARTICLE: { "concurrency" "exceptions" } "Linked exceptions" "A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:" { $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" } "Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threads can be created that are notified when child threads terminate and possibly restart them." -{ $subsection spawn-linked } +{ $subsections spawn-linked } "This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:" { $code "[" " [ 1 0 / \"This will not print\" print ] \"linked-division\" spawn-linked drop" @@ -80,8 +82,10 @@ $nl "A concurrency-oriented program is one in which multiple threads run simultaneously in a single Factor image or across multiple running Factor instances. The threads can communicate with each other by asynchronous message sends." $nl "Although threads can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code." -{ $subsection { "concurrency" "messaging" } } -{ $subsection { "concurrency" "synchronous-sends" } } -{ $subsection { "concurrency" "exceptions" } } ; +{ $subsections + { "concurrency" "messaging" } + { "concurrency" "synchronous-sends" } + { "concurrency" "exceptions" } +} ; ABOUT: "concurrency.messaging" diff --git a/basis/concurrency/promises/promises-docs.factor b/basis/concurrency/promises/promises-docs.factor index 69f12d8739..3d7390ae28 100644 --- a/basis/concurrency/promises/promises-docs.factor +++ b/basis/concurrency/promises/promises-docs.factor @@ -31,10 +31,12 @@ HELP: fulfill ARTICLE: "concurrency.promises" "Promises" "The " { $vocab-link "concurrency.promises" } " vocabulary implements " { $emphasis "promises" } ", which are thread-safe write-once variables. Once a promise is created, threads may block waiting for it to be " { $emphasis "fulfilled" } "; at some point in the future, another thread may provide a value at which point all waiting threads are notified." -{ $subsection promise } -{ $subsection } -{ $subsection fulfill } -{ $subsection ?promise } -{ $subsection ?promise-timeout } ; +{ $subsections + promise + + fulfill + ?promise + ?promise-timeout +} ; ABOUT: "concurrency.promises" diff --git a/basis/concurrency/semaphores/semaphores-docs.factor b/basis/concurrency/semaphores/semaphores-docs.factor index c86623f86f..343adb00c9 100644 --- a/basis/concurrency/semaphores/semaphores-docs.factor +++ b/basis/concurrency/semaphores/semaphores-docs.factor @@ -43,14 +43,20 @@ $nl "] parallel-map" } "Creating semaphores:" -{ $subsection semaphore } -{ $subsection } +{ $subsections + semaphore + +} "Unlike locks, where acquisition and release are always paired by a combinator, semaphores expose these operations directly and there is no requirement that they be performed in the same thread:" -{ $subsection acquire } -{ $subsection acquire-timeout } -{ $subsection release } +{ $subsections + acquire + acquire-timeout + release +} "Combinators which pair acquisition and release:" -{ $subsection with-semaphore } -{ $subsection with-semaphore-timeout } ; +{ $subsections + with-semaphore + with-semaphore-timeout +} ; ABOUT: "concurrency.semaphores" diff --git a/basis/cords/cords.factor b/basis/cords/cords.factor index 915744491f..a50de60c45 100644 --- a/basis/cords/cords.factor +++ b/basis/cords/cords.factor @@ -6,35 +6,37 @@ IN: cords > length ] [ second>> length ] bi + ; + [ first>> length ] [ second>> length ] bi + ; inline -M: simple-cord virtual-seq first>> ; +M: simple-cord virtual-seq first>> ; inline M: simple-cord virtual@ 2dup first>> length < - [ first>> ] [ [ first>> length - ] [ second>> ] bi ] if ; + [ first>> ] [ [ first>> length - ] [ second>> ] bi ] if ; inline -TUPLE: multi-cord count seqs ; +TUPLE: multi-cord + { count read-only } { seqs read-only } ; -M: multi-cord length count>> ; +M: multi-cord length count>> ; inline M: multi-cord virtual@ dupd seqs>> [ first <=> ] with search nip - [ first - ] [ second ] bi ; + [ first - ] [ second ] bi ; inline M: multi-cord virtual-seq - seqs>> [ f ] [ first second ] if-empty ; + seqs>> [ f ] [ first second ] if-empty ; inline : ( seqs -- cord ) dup length 2 = [ first2 simple-cord boa ] [ [ 0 [ length + ] accumulate ] keep zip multi-cord boa - ] if ; + ] if ; inline PRIVATE> @@ -52,7 +54,7 @@ INSTANCE: multi-cord virtual-sequence { [ over cord? ] [ [ seqs>> values ] dip suffix ] } { [ dup cord? ] [ seqs>> values swap prefix ] } [ 2array ] - } cond ; + } cond ; inline : cord-concat ( seqs -- cord ) { @@ -67,4 +69,4 @@ INSTANCE: multi-cord virtual-sequence } cond ] map concat ] - } cond ; + } cond ; inline diff --git a/basis/core-foundation/arrays/arrays.factor b/basis/core-foundation/arrays/arrays.factor index 1205352fcb..f0dfff9143 100644 --- a/basis/core-foundation/arrays/arrays.factor +++ b/basis/core-foundation/arrays/arrays.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel sequences fry ; +USING: alien.c-types alien.syntax core-foundation kernel +sequences fry ; IN: core-foundation.arrays TYPEDEF: void* CFArrayRef diff --git a/basis/core-foundation/attributed-strings/attributed-strings.factor b/basis/core-foundation/attributed-strings/attributed-strings.factor index 48c262f3a3..cd620bb876 100644 --- a/basis/core-foundation/attributed-strings/attributed-strings.factor +++ b/basis/core-foundation/attributed-strings/attributed-strings.factor @@ -1,6 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel destructors core-foundation +USING: alien.c-types alien.syntax kernel destructors +core-foundation core-foundation.dictionaries +core-foundation.strings core-foundation.utilities ; IN: core-foundation.attributed-strings @@ -16,4 +18,4 @@ FUNCTION: CFAttributedStringRef CFAttributedStringCreate ( [ [ >cf &CFRelease ] bi@ [ kCFAllocatorDefault ] 2dip CFAttributedStringCreate - ] with-destructors ; \ No newline at end of file + ] with-destructors ; diff --git a/basis/core-foundation/bundles/bundles.factor b/basis/core-foundation/bundles/bundles.factor index 790f1766c3..e45e2c52be 100644 --- a/basis/core-foundation/bundles/bundles.factor +++ b/basis/core-foundation/bundles/bundles.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel sequences core-foundation -core-foundation.urls ; +USING: alien.c-types alien.syntax kernel sequences +core-foundation core-foundation.urls ; IN: core-foundation.bundles TYPEDEF: void* CFBundleRef diff --git a/basis/core-foundation/data/data.factor b/basis/core-foundation/data/data.factor index ef5973888e..c4c09d0cc5 100644 --- a/basis/core-foundation/data/data.factor +++ b/basis/core-foundation/data/data.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax kernel math sequences ; +USING: alien.c-types alien.syntax core-foundation kernel math +sequences ; IN: core-foundation.data TYPEDEF: void* CFDataRef @@ -16,4 +17,4 @@ FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFInd FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ; : ( byte-array -- alien ) - [ f ] dip dup length CFDataCreate ; \ No newline at end of file + [ f ] dip dup length CFDataCreate ; diff --git a/basis/core-foundation/dictionaries/dictionaries.factor b/basis/core-foundation/dictionaries/dictionaries.factor index cc0175e0ea..fc0e98a215 100644 --- a/basis/core-foundation/dictionaries/dictionaries.factor +++ b/basis/core-foundation/dictionaries/dictionaries.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax core-foundation kernel assocs +USING: alien.c-types alien.syntax core-foundation kernel assocs specialized-arrays math sequences accessors ; IN: core-foundation.dictionaries @@ -8,8 +8,8 @@ SPECIALIZED-ARRAY: void* TYPEDEF: void* CFDictionaryRef TYPEDEF: void* CFMutableDictionaryRef -TYPEDEF: void* CFDictionaryKeyCallBacks* -TYPEDEF: void* CFDictionaryValueCallBacks* +C-TYPE: CFDictionaryKeyCallBacks +C-TYPE: CFDictionaryValueCallBacks FUNCTION: CFDictionaryRef CFDictionaryCreate ( CFAllocatorRef allocator, @@ -31,4 +31,4 @@ FUNCTION: void* CFDictionaryGetValue ( [ [ underlying>> ] bi@ ] [ nip length ] 2bi &: kCFTypeDictionaryKeyCallBacks &: kCFTypeDictionaryValueCallBacks - CFDictionaryCreate ; \ No newline at end of file + CFDictionaryCreate ; diff --git a/basis/core-foundation/file-descriptors/file-descriptors.factor b/basis/core-foundation/file-descriptors/file-descriptors.factor index c9fe3131b1..ec5581d463 100644 --- a/basis/core-foundation/file-descriptors/file-descriptors.factor +++ b/basis/core-foundation/file-descriptors/file-descriptors.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel math.bitwise core-foundation ; +USING: alien.c-types alien.syntax kernel math.bitwise core-foundation ; IN: core-foundation.file-descriptors TYPEDEF: void* CFFileDescriptorRef TYPEDEF: int CFFileDescriptorNativeDescriptor TYPEDEF: void* CFFileDescriptorCallBack +C-TYPE: CFFileDescriptorContext FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate ( CFAllocatorRef allocator, diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 9a22046a3a..6f5484fb77 100755 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -4,8 +4,8 @@ USING: alien alien.c-types alien.strings alien.syntax kernel math sequences namespaces make assocs init accessors continuations combinators io.encodings.utf8 destructors locals arrays specialized-arrays classes.struct core-foundation -core-foundation.run-loop core-foundation.strings -core-foundation.time ; +core-foundation.arrays core-foundation.run-loop +core-foundation.strings core-foundation.time unix.types ; IN: core-foundation.fsevents SPECIALIZED-ARRAY: void* diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 10d858a32f..7b454266f2 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.syntax kernel math namespaces -sequences destructors combinators threads heaps deques calendar -core-foundation core-foundation.strings +USING: accessors alien alien.c-types alien.syntax kernel math +namespaces sequences destructors combinators threads heaps +deques calendar core-foundation core-foundation.strings core-foundation.file-descriptors core-foundation.timers core-foundation.time ; IN: core-foundation.run-loop diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index 4bbe050230..cbabb083aa 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax alien.strings io.encodings.string kernel -sequences byte-arrays io.encodings.utf8 math core-foundation +USING: alien.c-types alien.syntax alien.strings io.encodings.string +kernel sequences byte-arrays io.encodings.utf8 math core-foundation core-foundation.arrays destructors parser fry alien words ; IN: core-foundation.strings diff --git a/basis/core-foundation/time/time.factor b/basis/core-foundation/time/time.factor index 15ad7bb1a1..8f09652462 100644 --- a/basis/core-foundation/time/time.factor +++ b/basis/core-foundation/time/time.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: calendar alien.syntax ; +USING: calendar alien.c-types alien.syntax ; IN: core-foundation.time TYPEDEF: double CFTimeInterval diff --git a/basis/core-foundation/timers/timers.factor b/basis/core-foundation/timers/timers.factor index 51ee982592..cf17cb41d9 100644 --- a/basis/core-foundation/timers/timers.factor +++ b/basis/core-foundation/timers/timers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax system math kernel calendar core-foundation -core-foundation.time ; +USING: alien.c-types alien.syntax system math kernel calendar +core-foundation core-foundation.time ; IN: core-foundation.timers TYPEDEF: void* CFRunLoopTimerRef diff --git a/basis/core-foundation/urls/urls.factor b/basis/core-foundation/urls/urls.factor index 7ffef498b6..f22095c344 100644 --- a/basis/core-foundation/urls/urls.factor +++ b/basis/core-foundation/urls/urls.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel core-foundation.strings -core-foundation ; +USING: alien.c-types alien.syntax kernel core-foundation.strings +core-foundation core-foundation.urls ; IN: core-foundation.urls CONSTANT: kCFURLPOSIXPathStyle 0 diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index a7bec04798..f3f759115c 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.destructors alien.syntax accessors destructors fry kernel math math.bitwise sequences libc colors -images images.memory core-graphics.types core-foundation.utilities ; +images images.memory core-graphics.types core-foundation.utilities +opengl.gl ; IN: core-graphics ! CGImageAlphaInfo diff --git a/basis/core-graphics/types/types-docs.factor b/basis/core-graphics/types/types-docs.factor index e35c81d38a..e7e1de5cd5 100644 --- a/basis/core-graphics/types/types-docs.factor +++ b/basis/core-graphics/types/types-docs.factor @@ -21,9 +21,11 @@ ARTICLE: "core-graphics.types" "Core Graphics types" "CGSize" } "Some words for working with the above:" -{ $subsection } -{ $subsection } -{ $subsection } ; +{ $subsections + + + +} ; IN: core-graphics.types ABOUT: "core-graphics.types" diff --git a/basis/core-graphics/types/types.factor b/basis/core-graphics/types/types.factor index ad4620e174..a1e9b1dc9a 100644 --- a/basis/core-graphics/types/types.factor +++ b/basis/core-graphics/types/types.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.syntax classes.struct kernel layouts -math math.rectangles arrays ; +math math.rectangles arrays literals ; +FROM: alien.c-types => float ; IN: core-graphics.types -<< cell 4 = "float" "double" ? "CGFloat" typedef >> +SYMBOL: CGFloat +<< cell 4 = float double ? \ CGFloat typedef >> : ( x -- alien ) cell 4 = [ ] [ ] if ; inline diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor index 99849c1666..3459b368f7 100644 --- a/basis/core-text/core-text.factor +++ b/basis/core-text/core-text.factor @@ -6,19 +6,19 @@ math.order math.vectors math.rectangles math.functions locals init namespaces combinators fonts colors cache core-foundation core-foundation.strings core-foundation.attributed-strings core-foundation.utilities core-graphics core-graphics.types -core-text.fonts core-text.utilities ; +core-text.fonts ; IN: core-text TYPEDEF: void* CTLineRef -C-GLOBAL: kCTFontAttributeName -C-GLOBAL: kCTKernAttributeName -C-GLOBAL: kCTLigatureAttributeName -C-GLOBAL: kCTForegroundColorAttributeName -C-GLOBAL: kCTParagraphStyleAttributeName -C-GLOBAL: kCTUnderlineStyleAttributeName -C-GLOBAL: kCTVerticalFormsAttributeName -C-GLOBAL: kCTGlyphInfoAttributeName +C-GLOBAL: CFStringRef kCTFontAttributeName +C-GLOBAL: CFStringRef kCTKernAttributeName +C-GLOBAL: CFStringRef kCTLigatureAttributeName +C-GLOBAL: CFStringRef kCTForegroundColorAttributeName +C-GLOBAL: CFStringRef kCTParagraphStyleAttributeName +C-GLOBAL: CFStringRef kCTUnderlineStyleAttributeName +C-GLOBAL: CFStringRef kCTVerticalFormsAttributeName +C-GLOBAL: CFStringRef kCTGlyphInfoAttributeName FUNCTION: CTLineRef CTLineCreateWithAttributedString ( CFAttributedStringRef string ) ; diff --git a/basis/core-text/fonts/fonts.factor b/basis/core-text/fonts/fonts.factor index 2656811c1f..5c57034632 100644 --- a/basis/core-text/fonts/fonts.factor +++ b/basis/core-text/fonts/fonts.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.syntax assocs core-foundation -core-foundation.strings core-text.utilities destructors init -kernel math memoize fonts combinators ; +USING: accessors alien.c-types alien.syntax assocs core-foundation +core-foundation.dictionaries core-foundation.strings +core-graphics.types destructors init +kernel math memoize fonts combinators unix.types ; IN: core-text.fonts TYPEDEF: void* CTFontRef @@ -17,28 +18,28 @@ TYPEDEF: void* CTFontDescriptorRef : kCTFontVerticalTrait ( -- n ) 11 2^ ; inline : kCTFontUIOptimizedTrait ( -- n ) 12 2^ ; inline -C-GLOBAL: kCTFontSymbolicTrait -C-GLOBAL: kCTFontWeightTrait -C-GLOBAL: kCTFontWidthTrait -C-GLOBAL: kCTFontSlantTrait - -C-GLOBAL: kCTFontNameAttribute -C-GLOBAL: kCTFontDisplayNameAttribute -C-GLOBAL: kCTFontFamilyNameAttribute -C-GLOBAL: kCTFontStyleNameAttribute -C-GLOBAL: kCTFontTraitsAttribute -C-GLOBAL: kCTFontVariationAttribute -C-GLOBAL: kCTFontSizeAttribute -C-GLOBAL: kCTFontMatrixAttribute -C-GLOBAL: kCTFontCascadeListAttribute -C-GLOBAL: kCTFontCharacterSetAttribute -C-GLOBAL: kCTFontLanguagesAttribute -C-GLOBAL: kCTFontBaselineAdjustAttribute -C-GLOBAL: kCTFontMacintoshEncodingsAttribute -C-GLOBAL: kCTFontFeaturesAttribute -C-GLOBAL: kCTFontFeatureSettingsAttribute -C-GLOBAL: kCTFontFixedAdvanceAttribute -C-GLOBAL: kCTFontOrientationAttribute +C-GLOBAL: CFStringRef kCTFontSymbolicTrait +C-GLOBAL: CFStringRef kCTFontWeightTrait +C-GLOBAL: CFStringRef kCTFontWidthTrait +C-GLOBAL: CFStringRef kCTFontSlantTrait + +C-GLOBAL: CFStringRef kCTFontNameAttribute +C-GLOBAL: CFStringRef kCTFontDisplayNameAttribute +C-GLOBAL: CFStringRef kCTFontFamilyNameAttribute +C-GLOBAL: CFStringRef kCTFontStyleNameAttribute +C-GLOBAL: CFStringRef kCTFontTraitsAttribute +C-GLOBAL: CFStringRef kCTFontVariationAttribute +C-GLOBAL: CFStringRef kCTFontSizeAttribute +C-GLOBAL: CFStringRef kCTFontMatrixAttribute +C-GLOBAL: CFStringRef kCTFontCascadeListAttribute +C-GLOBAL: CFStringRef kCTFontCharacterSetAttribute +C-GLOBAL: CFStringRef kCTFontLanguagesAttribute +C-GLOBAL: CFStringRef kCTFontBaselineAdjustAttribute +C-GLOBAL: CFStringRef kCTFontMacintoshEncodingsAttribute +C-GLOBAL: CFStringRef kCTFontFeaturesAttribute +C-GLOBAL: CFStringRef kCTFontFeatureSettingsAttribute +C-GLOBAL: CFStringRef kCTFontFixedAdvanceAttribute +C-GLOBAL: CFStringRef kCTFontOrientationAttribute FUNCTION: CTFontDescriptorRef CTFontDescriptorCreateWithAttributes ( CFDictionaryRef attributes diff --git a/basis/core-text/utilities/authors.txt b/basis/core-text/utilities/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/core-text/utilities/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/core-text/utilities/utilities.factor b/basis/core-text/utilities/utilities.factor deleted file mode 100644 index d3b1352750..0000000000 --- a/basis/core-text/utilities/utilities.factor +++ /dev/null @@ -1,10 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: words parser alien alien.c-types kernel fry accessors -alien.libraries ; -IN: core-text.utilities - -SYNTAX: C-GLOBAL: - CREATE-WORD - dup name>> '[ _ f dlsym *void* ] - (( -- value )) define-declared ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index fbec9f697a..19b38fd8f8 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays generic kernel kernel.private math -memory namespaces make sequences layouts system hashtables +USING: accessors arrays assocs generic kernel kernel.private +math memory namespaces make sequences layouts system hashtables classes alien byte-arrays combinators words sets fry ; IN: cpu.architecture @@ -22,24 +22,69 @@ SINGLETONS: float-rep double-rep ; ! On x86, floating point registers are really vector registers SINGLETONS: -float-4-rep -double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep -uint-4-rep ; +uint-4-rep +longlong-2-rep +ulonglong-2-rep ; -UNION: vector-rep +! Scalar values in the high component of a vector register +SINGLETONS: +char-scalar-rep +uchar-scalar-rep +short-scalar-rep +ushort-scalar-rep +int-scalar-rep +uint-scalar-rep +longlong-scalar-rep +ulonglong-scalar-rep ; + +SINGLETONS: float-4-rep -double-2-rep +double-2-rep ; + +UNION: int-vector-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep -uint-4-rep ; +uint-4-rep +longlong-2-rep +ulonglong-2-rep ; + +UNION: signed-int-vector-rep +char-16-rep +short-8-rep +int-4-rep +longlong-2-rep ; + +UNION: unsigned-int-vector-rep +uchar-16-rep +ushort-8-rep +uint-4-rep +ulonglong-2-rep ; + +UNION: scalar-rep +char-scalar-rep +uchar-scalar-rep +short-scalar-rep +ushort-scalar-rep +int-scalar-rep +uint-scalar-rep +longlong-scalar-rep +ulonglong-scalar-rep ; + +UNION: float-vector-rep +float-4-rep +double-2-rep ; + +UNION: vector-rep +int-vector-rep +float-vector-rep ; UNION: representation any-rep @@ -47,7 +92,20 @@ tagged-rep int-rep float-rep double-rep -vector-rep ; +vector-rep +scalar-rep ; + +: unsign-rep ( rep -- rep' ) + { + { uint-4-rep int-4-rep } + { ulonglong-2-rep longlong-2-rep } + { ushort-8-rep short-8-rep } + { uchar-16-rep char-16-rep } + { uchar-scalar-rep char-scalar-rep } + { ushort-scalar-rep short-scalar-rep } + { uint-scalar-rep int-scalar-rep } + { ulonglong-scalar-rep longlong-scalar-rep } + } ?at drop ; ! Register classes SINGLETONS: int-regs float-regs ; @@ -58,13 +116,18 @@ CONSTANT: reg-classes { int-regs float-regs } ! A pseudo-register class for parameters spilled on the stack SINGLETON: stack-params +! On x86, vectors and floats are stored in the same register bank +! On PowerPC they are distinct +HOOK: vector-regs cpu ( -- reg-class ) + GENERIC: reg-class-of ( rep -- reg-class ) M: tagged-rep reg-class-of drop int-regs ; M: int-rep reg-class-of drop int-regs ; M: float-rep reg-class-of drop float-regs ; M: double-rep reg-class-of drop float-regs ; -M: vector-rep reg-class-of drop float-regs ; +M: vector-rep reg-class-of drop vector-regs ; +M: scalar-rep reg-class-of drop vector-regs ; M: stack-params reg-class-of drop stack-params ; GENERIC: rep-size ( rep -- n ) foldable @@ -75,17 +138,35 @@ M: float-rep rep-size drop 4 ; M: double-rep rep-size drop 8 ; M: stack-params rep-size drop cell ; M: vector-rep rep-size drop 16 ; +M: char-scalar-rep rep-size drop 1 ; +M: uchar-scalar-rep rep-size drop 1 ; +M: short-scalar-rep rep-size drop 2 ; +M: ushort-scalar-rep rep-size drop 2 ; +M: int-scalar-rep rep-size drop 4 ; +M: uint-scalar-rep rep-size drop 4 ; +M: longlong-scalar-rep rep-size drop 8 ; +M: ulonglong-scalar-rep rep-size drop 8 ; + +GENERIC: rep-component-type ( rep -- n ) + +! Methods defined in alien.c-types GENERIC: scalar-rep-of ( rep -- rep' ) M: float-4-rep scalar-rep-of drop float-rep ; M: double-2-rep scalar-rep-of drop double-rep ; +M: char-16-rep scalar-rep-of drop char-scalar-rep ; +M: uchar-16-rep scalar-rep-of drop uchar-scalar-rep ; +M: short-8-rep scalar-rep-of drop short-scalar-rep ; +M: ushort-8-rep scalar-rep-of drop ushort-scalar-rep ; +M: int-4-rep scalar-rep-of drop int-scalar-rep ; +M: uint-4-rep scalar-rep-of drop uint-scalar-rep ; +M: longlong-2-rep scalar-rep-of drop longlong-scalar-rep ; +M: ulonglong-2-rep scalar-rep-of drop ulonglong-scalar-rep ; ! Mapping from register class to machine registers HOOK: machine-registers cpu ( -- assoc ) -HOOK: two-operand? cpu ( -- ? ) - HOOK: %load-immediate cpu ( reg obj -- ) HOOK: %load-reference cpu ( reg obj -- ) @@ -102,9 +183,9 @@ HOOK: %return cpu ( -- ) HOOK: %dispatch cpu ( src temp -- ) -HOOK: %slot cpu ( dst obj slot tag temp -- ) +HOOK: %slot cpu ( dst obj slot -- ) HOOK: %slot-imm cpu ( dst obj slot tag -- ) -HOOK: %set-slot cpu ( src obj slot tag temp -- ) +HOOK: %set-slot cpu ( src obj slot -- ) HOOK: %set-slot-imm cpu ( src obj slot tag -- ) HOOK: %string-nth cpu ( dst obj index temp -- ) @@ -131,6 +212,7 @@ HOOK: %sar-imm cpu ( dst src1 src2 -- ) HOOK: %min cpu ( dst src1 src2 -- ) HOOK: %max cpu ( dst src1 src2 -- ) HOOK: %not cpu ( dst src -- ) +HOOK: %neg cpu ( dst src -- ) HOOK: %log2 cpu ( dst src -- ) HOOK: %copy cpu ( dst src rep -- ) @@ -139,12 +221,6 @@ HOOK: %fixnum-add cpu ( label dst src1 src2 -- ) HOOK: %fixnum-sub cpu ( label dst src1 src2 -- ) HOOK: %fixnum-mul cpu ( label dst src1 src2 -- ) -HOOK: %integer>bignum cpu ( dst src temp -- ) -HOOK: %bignum>integer cpu ( dst src temp -- ) - -HOOK: %unbox-float cpu ( dst src -- ) -HOOK: %box-float cpu ( dst src temp -- ) - HOOK: %add-float cpu ( dst src1 src2 -- ) HOOK: %sub-float cpu ( dst src1 src2 -- ) HOOK: %mul-float cpu ( dst src1 src2 -- ) @@ -161,45 +237,161 @@ HOOK: %double>single-float cpu ( dst src -- ) HOOK: %integer>float cpu ( dst src -- ) HOOK: %float>integer cpu ( dst src -- ) -HOOK: %box-vector cpu ( dst src temp rep -- ) -HOOK: %unbox-vector cpu ( dst src rep -- ) - -HOOK: %broadcast-vector cpu ( dst src rep -- ) +HOOK: %zero-vector cpu ( dst rep -- ) +HOOK: %fill-vector cpu ( dst rep -- ) HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- ) HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- ) - +HOOK: %shuffle-vector cpu ( dst src shuffle rep -- ) +HOOK: %shuffle-vector-imm cpu ( dst src shuffle rep -- ) +HOOK: %tail>head-vector cpu ( dst src rep -- ) +HOOK: %merge-vector-head cpu ( dst src1 src2 rep -- ) +HOOK: %merge-vector-tail cpu ( dst src1 src2 rep -- ) +HOOK: %signed-pack-vector cpu ( dst src1 src2 rep -- ) +HOOK: %unsigned-pack-vector cpu ( dst src1 src2 rep -- ) +HOOK: %unpack-vector-head cpu ( dst src rep -- ) +HOOK: %unpack-vector-tail cpu ( dst src rep -- ) +HOOK: %integer>float-vector cpu ( dst src rep -- ) +HOOK: %float>integer-vector cpu ( dst src rep -- ) +HOOK: %compare-vector cpu ( dst src1 src2 rep cc -- ) +HOOK: %test-vector cpu ( dst src1 temp rep vcc -- ) +HOOK: %test-vector-branch cpu ( label src1 temp rep vcc -- ) HOOK: %add-vector cpu ( dst src1 src2 rep -- ) +HOOK: %saturated-add-vector cpu ( dst src1 src2 rep -- ) +HOOK: %add-sub-vector cpu ( dst src1 src2 rep -- ) HOOK: %sub-vector cpu ( dst src1 src2 rep -- ) +HOOK: %saturated-sub-vector cpu ( dst src1 src2 rep -- ) HOOK: %mul-vector cpu ( dst src1 src2 rep -- ) +HOOK: %saturated-mul-vector cpu ( dst src1 src2 rep -- ) HOOK: %div-vector cpu ( dst src1 src2 rep -- ) HOOK: %min-vector cpu ( dst src1 src2 rep -- ) HOOK: %max-vector cpu ( dst src1 src2 rep -- ) +HOOK: %dot-vector cpu ( dst src1 src2 rep -- ) HOOK: %sqrt-vector cpu ( dst src rep -- ) HOOK: %horizontal-add-vector cpu ( dst src rep -- ) +HOOK: %horizontal-sub-vector cpu ( dst src rep -- ) +HOOK: %abs-vector cpu ( dst src rep -- ) +HOOK: %and-vector cpu ( dst src1 src2 rep -- ) +HOOK: %andn-vector cpu ( dst src1 src2 rep -- ) +HOOK: %or-vector cpu ( dst src1 src2 rep -- ) +HOOK: %xor-vector cpu ( dst src1 src2 rep -- ) +HOOK: %not-vector cpu ( dst src rep -- ) +HOOK: %shl-vector cpu ( dst src1 src2 rep -- ) +HOOK: %shr-vector cpu ( dst src1 src2 rep -- ) +HOOK: %horizontal-shl-vector cpu ( dst src1 src2 rep -- ) +HOOK: %horizontal-shr-vector cpu ( dst src1 src2 rep -- ) + +HOOK: %integer>scalar cpu ( dst src rep -- ) +HOOK: %scalar>integer cpu ( dst src rep -- ) +HOOK: %vector>scalar cpu ( dst src rep -- ) +HOOK: %scalar>vector cpu ( dst src rep -- ) + +HOOK: %zero-vector-reps cpu ( -- reps ) +HOOK: %fill-vector-reps cpu ( -- reps ) +HOOK: %gather-vector-2-reps cpu ( -- reps ) +HOOK: %gather-vector-4-reps cpu ( -- reps ) +HOOK: %alien-vector-reps cpu ( -- reps ) +HOOK: %shuffle-vector-reps cpu ( -- reps ) +HOOK: %shuffle-vector-imm-reps cpu ( -- reps ) +HOOK: %merge-vector-reps cpu ( -- reps ) +HOOK: %signed-pack-vector-reps cpu ( -- reps ) +HOOK: %unsigned-pack-vector-reps cpu ( -- reps ) +HOOK: %unpack-vector-head-reps cpu ( -- reps ) +HOOK: %unpack-vector-tail-reps cpu ( -- reps ) +HOOK: %integer>float-vector-reps cpu ( -- reps ) +HOOK: %float>integer-vector-reps cpu ( -- reps ) +HOOK: %compare-vector-reps cpu ( cc -- reps ) +HOOK: %compare-vector-ccs cpu ( rep cc -- {cc,swap?}s not? ) +HOOK: %test-vector-reps cpu ( -- reps ) +HOOK: %add-vector-reps cpu ( -- reps ) +HOOK: %saturated-add-vector-reps cpu ( -- reps ) +HOOK: %add-sub-vector-reps cpu ( -- reps ) +HOOK: %sub-vector-reps cpu ( -- reps ) +HOOK: %saturated-sub-vector-reps cpu ( -- reps ) +HOOK: %mul-vector-reps cpu ( -- reps ) +HOOK: %saturated-mul-vector-reps cpu ( -- reps ) +HOOK: %div-vector-reps cpu ( -- reps ) +HOOK: %min-vector-reps cpu ( -- reps ) +HOOK: %max-vector-reps cpu ( -- reps ) +HOOK: %dot-vector-reps cpu ( -- reps ) +HOOK: %sqrt-vector-reps cpu ( -- reps ) +HOOK: %horizontal-add-vector-reps cpu ( -- reps ) +HOOK: %horizontal-sub-vector-reps cpu ( -- reps ) +HOOK: %abs-vector-reps cpu ( -- reps ) +HOOK: %and-vector-reps cpu ( -- reps ) +HOOK: %andn-vector-reps cpu ( -- reps ) +HOOK: %or-vector-reps cpu ( -- reps ) +HOOK: %xor-vector-reps cpu ( -- reps ) +HOOK: %not-vector-reps cpu ( -- reps ) +HOOK: %shl-vector-reps cpu ( -- reps ) +HOOK: %shr-vector-reps cpu ( -- reps ) +HOOK: %horizontal-shl-vector-reps cpu ( -- reps ) +HOOK: %horizontal-shr-vector-reps cpu ( -- reps ) + +M: object %zero-vector-reps { } ; +M: object %fill-vector-reps { } ; +M: object %gather-vector-2-reps { } ; +M: object %gather-vector-4-reps { } ; +M: object %alien-vector-reps { } ; +M: object %shuffle-vector-reps { } ; +M: object %shuffle-vector-imm-reps { } ; +M: object %merge-vector-reps { } ; +M: object %signed-pack-vector-reps { } ; +M: object %unsigned-pack-vector-reps { } ; +M: object %unpack-vector-head-reps { } ; +M: object %unpack-vector-tail-reps { } ; +M: object %integer>float-vector-reps { } ; +M: object %float>integer-vector-reps { } ; +M: object %compare-vector-reps drop { } ; +M: object %compare-vector-ccs 2drop { } f ; +M: object %test-vector-reps { } ; +M: object %add-vector-reps { } ; +M: object %saturated-add-vector-reps { } ; +M: object %add-sub-vector-reps { } ; +M: object %sub-vector-reps { } ; +M: object %saturated-sub-vector-reps { } ; +M: object %mul-vector-reps { } ; +M: object %saturated-mul-vector-reps { } ; +M: object %div-vector-reps { } ; +M: object %min-vector-reps { } ; +M: object %max-vector-reps { } ; +M: object %dot-vector-reps { } ; +M: object %sqrt-vector-reps { } ; +M: object %horizontal-add-vector-reps { } ; +M: object %horizontal-sub-vector-reps { } ; +M: object %abs-vector-reps { } ; +M: object %and-vector-reps { } ; +M: object %andn-vector-reps { } ; +M: object %or-vector-reps { } ; +M: object %xor-vector-reps { } ; +M: object %not-vector-reps { } ; +M: object %shl-vector-reps { } ; +M: object %shr-vector-reps { } ; +M: object %horizontal-shl-vector-reps { } ; +M: object %horizontal-shr-vector-reps { } ; HOOK: %unbox-alien cpu ( dst src -- ) HOOK: %unbox-any-c-ptr cpu ( dst src temp -- ) HOOK: %box-alien cpu ( dst src temp -- ) HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- ) -HOOK: %alien-unsigned-1 cpu ( dst src -- ) -HOOK: %alien-unsigned-2 cpu ( dst src -- ) -HOOK: %alien-unsigned-4 cpu ( dst src -- ) -HOOK: %alien-signed-1 cpu ( dst src -- ) -HOOK: %alien-signed-2 cpu ( dst src -- ) -HOOK: %alien-signed-4 cpu ( dst src -- ) -HOOK: %alien-cell cpu ( dst src -- ) -HOOK: %alien-float cpu ( dst src -- ) -HOOK: %alien-double cpu ( dst src -- ) -HOOK: %alien-vector cpu ( dst src rep -- ) - -HOOK: %set-alien-integer-1 cpu ( ptr value -- ) -HOOK: %set-alien-integer-2 cpu ( ptr value -- ) -HOOK: %set-alien-integer-4 cpu ( ptr value -- ) -HOOK: %set-alien-cell cpu ( ptr value -- ) -HOOK: %set-alien-float cpu ( ptr value -- ) -HOOK: %set-alien-double cpu ( ptr value -- ) -HOOK: %set-alien-vector cpu ( ptr value rep -- ) +HOOK: %alien-unsigned-1 cpu ( dst src offset -- ) +HOOK: %alien-unsigned-2 cpu ( dst src offset -- ) +HOOK: %alien-unsigned-4 cpu ( dst src offset -- ) +HOOK: %alien-signed-1 cpu ( dst src offset -- ) +HOOK: %alien-signed-2 cpu ( dst src offset -- ) +HOOK: %alien-signed-4 cpu ( dst src offset -- ) +HOOK: %alien-cell cpu ( dst src offset -- ) +HOOK: %alien-float cpu ( dst src offset -- ) +HOOK: %alien-double cpu ( dst src offset -- ) +HOOK: %alien-vector cpu ( dst src offset rep -- ) + +HOOK: %set-alien-integer-1 cpu ( ptr offset value -- ) +HOOK: %set-alien-integer-2 cpu ( ptr offset value -- ) +HOOK: %set-alien-integer-4 cpu ( ptr offset value -- ) +HOOK: %set-alien-cell cpu ( ptr offset value -- ) +HOOK: %set-alien-float cpu ( ptr offset value -- ) +HOOK: %set-alien-double cpu ( ptr offset value -- ) +HOOK: %set-alien-vector cpu ( ptr offset value rep -- ) HOOK: %alien-global cpu ( dst symbol library -- ) HOOK: %vm-field-ptr cpu ( dst fieldname -- ) @@ -208,10 +400,10 @@ HOOK: %allot cpu ( dst size class temp -- ) HOOK: %write-barrier cpu ( src card# table -- ) ! GC checks -HOOK: %check-nursery cpu ( label temp1 temp2 -- ) +HOOK: %check-nursery cpu ( label size temp1 temp2 -- ) HOOK: %save-gc-root cpu ( gc-root register -- ) HOOK: %load-gc-root cpu ( gc-root register -- ) -HOOK: %call-gc cpu ( gc-root-count -- ) +HOOK: %call-gc cpu ( gc-root-count temp1 -- ) HOOK: %prologue cpu ( n -- ) HOOK: %epilogue cpu ( n -- ) @@ -226,8 +418,8 @@ HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- ) HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- ) HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- ) -HOOK: %spill cpu ( src rep n -- ) -HOOK: %reload cpu ( dst rep n -- ) +HOOK: %spill cpu ( src rep dst -- ) +HOOK: %reload cpu ( dst rep src -- ) HOOK: %loop-entry cpu ( -- ) @@ -298,9 +490,6 @@ M: object %prepare-var-args ; HOOK: %alien-invoke cpu ( function library -- ) -HOOK: %vm-invoke-1st-arg cpu ( function -- ) -HOOK: %vm-invoke-3rd-arg cpu ( function -- ) - HOOK: %cleanup cpu ( params -- ) M: object %cleanup ( params -- ) drop ; @@ -313,6 +502,10 @@ HOOK: %alien-callback cpu ( quot -- ) HOOK: %callback-value cpu ( ctype -- ) +HOOK: %nest-stacks cpu ( -- ) + +HOOK: %unnest-stacks cpu ( -- ) + ! Return to caller with stdcall unwinding (only for x86) HOOK: %callback-return cpu ( params -- ) diff --git a/basis/cpu/arm/assembler/assembler-tests.factor b/basis/cpu/arm/assembler/assembler-tests.factor new file mode 100644 index 0000000000..3164fc197a --- /dev/null +++ b/basis/cpu/arm/assembler/assembler-tests.factor @@ -0,0 +1,46 @@ +IN: cpu.arm.assembler.tests +USING: cpu.arm.assembler math tools.test namespaces make +sequences kernel quotations ; +FROM: cpu.arm.assembler => B ; + +: test-opcode ( expect quot -- ) [ { } make first ] curry unit-test ; + +[ HEX: ea000000 ] [ 0 B ] test-opcode +[ HEX: eb000000 ] [ 0 BL ] test-opcode +! [ HEX: e12fff30 ] [ R0 BLX ] test-opcode + +[ HEX: e24cc004 ] [ IP IP 4 SUB ] test-opcode +[ HEX: e24cb004 ] [ FP IP 4 SUB ] test-opcode +[ HEX: e087e3ac ] [ LR R7 IP 7 ADD ] test-opcode +[ HEX: e08c0109 ] [ R0 IP R9 2 ADD ] test-opcode +[ HEX: 02850004 ] [ R0 R5 4 EQ ADD ] test-opcode +[ HEX: 00000000 ] [ R0 R0 R0 EQ AND ] test-opcode + +[ HEX: e1a0c00c ] [ IP IP MOV ] test-opcode +[ HEX: e1a0c00d ] [ IP SP MOV ] test-opcode +[ HEX: e3a03003 ] [ R3 3 MOV ] test-opcode +[ HEX: e1a00003 ] [ R0 R3 MOV ] test-opcode +[ HEX: e1e01c80 ] [ R1 R0 25 MVN ] test-opcode +[ HEX: e1e00ca1 ] [ R0 R1 25 MVN ] test-opcode +[ HEX: 11a021ac ] [ R2 IP 3 NE MOV ] test-opcode + +[ HEX: e3530007 ] [ R3 7 CMP ] test-opcode + +[ HEX: e008049a ] [ R8 SL R4 MUL ] test-opcode + +[ HEX: e5151004 ] [ R1 R5 4 <-> LDR ] test-opcode +[ HEX: e41c2004 ] [ R2 IP 4 <-!> LDR ] test-opcode +[ HEX: e50e2004 ] [ R2 LR 4 <-> STR ] test-opcode + +[ HEX: e7910002 ] [ R0 R1 R2 <+> LDR ] test-opcode +[ HEX: e7910102 ] [ R0 R1 R2 2 <+> LDR ] test-opcode + +[ HEX: e1d310bc ] [ R1 R3 12 <+> LDRH ] test-opcode +[ HEX: e1d310fc ] [ R1 R3 12 <+> LDRSH ] test-opcode +[ HEX: e1d310dc ] [ R1 R3 12 <+> LDRSB ] test-opcode +[ HEX: e1c310bc ] [ R1 R3 12 <+> STRH ] test-opcode +[ HEX: e19310b4 ] [ R1 R3 R4 <+> LDRH ] test-opcode +[ HEX: e1f310fc ] [ R1 R3 12 LDRSH ] test-opcode +[ HEX: e1b310d4 ] [ R1 R3 R4 LDRSB ] test-opcode +[ HEX: e0c317bb ] [ R1 R3 123 <+!> STRH ] test-opcode +[ HEX: e08310b4 ] [ R1 R3 R4 <+!> STRH ] test-opcode diff --git a/basis/cpu/arm/assembler/assembler.factor b/basis/cpu/arm/assembler/assembler.factor new file mode 100755 index 0000000000..38e385020f --- /dev/null +++ b/basis/cpu/arm/assembler/assembler.factor @@ -0,0 +1,367 @@ +! Copyright (C) 2007, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators kernel make math math.bitwise +namespaces sequences words words.symbol parser ; +IN: cpu.arm.assembler + +! Registers +<< + +SYMBOL: registers + +V{ } registers set-global + +SYNTAX: REGISTER: + CREATE-WORD + [ define-symbol ] + [ registers get length "register" set-word-prop ] + [ registers get push ] + tri ; + +>> + +REGISTER: R0 +REGISTER: R1 +REGISTER: R2 +REGISTER: R3 +REGISTER: R4 +REGISTER: R5 +REGISTER: R6 +REGISTER: R7 +REGISTER: R8 +REGISTER: R9 +REGISTER: R10 +REGISTER: R11 +REGISTER: R12 +REGISTER: R13 +REGISTER: R14 +REGISTER: R15 + +ALIAS: SL R10 ALIAS: FP R11 ALIAS: IP R12 +ALIAS: SP R13 ALIAS: LR R14 ALIAS: PC R15 + +boolean ; + +GENERIC: register ( register -- n ) +M: word register "register" word-prop ; +M: f register drop 0 ; + +PRIVATE> + +! Condition codes +SYMBOL: cond-code + +: >CC ( n -- ) + cond-code set ; + +: CC> ( -- n ) + #! Default value is BIN: 1110 AL (= always) + cond-code [ f ] change BIN: 1110 or ; + +: EQ ( -- ) BIN: 0000 >CC ; +: NE ( -- ) BIN: 0001 >CC ; +: CS ( -- ) BIN: 0010 >CC ; +: CC ( -- ) BIN: 0011 >CC ; +: LO ( -- ) BIN: 0100 >CC ; +: PL ( -- ) BIN: 0101 >CC ; +: VS ( -- ) BIN: 0110 >CC ; +: VC ( -- ) BIN: 0111 >CC ; +: HI ( -- ) BIN: 1000 >CC ; +: LS ( -- ) BIN: 1001 >CC ; +: GE ( -- ) BIN: 1010 >CC ; +: LT ( -- ) BIN: 1011 >CC ; +: GT ( -- ) BIN: 1100 >CC ; +: LE ( -- ) BIN: 1101 >CC ; +: AL ( -- ) BIN: 1110 >CC ; +: NV ( -- ) BIN: 1111 >CC ; + + 28 shift bitor , ; + +: insn ( bitspec -- ) bitfield (insn) ; inline + +! Branching instructions +GENERIC# (B) 1 ( target l -- ) + +M: integer (B) { 24 { 1 25 } { 0 26 } { 1 27 } 0 } insn ; + +PRIVATE> + +: B ( target -- ) 0 (B) ; +: BL ( target -- ) 1 (B) ; + +! Data processing instructions + + +: S ( -- ) updates-cond-code on ; + +: S> ( -- ? ) updates-cond-code [ f ] change ; + + [ 20 2^ bitor ] when (insn) ; inline + +GENERIC# shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n ) + +M: integer shift-imm/reg ( shift-imm Rm shift -- n ) + { { 0 4 } 5 { register 0 } 7 } bitfield ; + +M: register shift-imm/reg ( Rs Rm shift -- n ) + { + { 1 4 } + { 0 7 } + 5 + { register 8 } + { register 0 } + } bitfield ; + +PRIVATE> + +TUPLE: IMM immed rotate ; +C: IMM + +TUPLE: shifter Rm by shift ; +C: shifter + +> ] [ rotate>> ] bi { { 1 25 } 8 0 } bitfield ; + +M: shifter shifter-op + [ by>> ] [ Rm>> ] [ shift>> ] tri shift-imm/reg ; + +PRIVATE> + +: ( Rm shift-imm/Rs -- shifter-op ) BIN: 00 ; +: ( Rm shift-imm/Rs -- shifter-op ) BIN: 01 ; +: ( Rm shift-imm/Rs -- shifter-op ) BIN: 10 ; +: ( Rm shift-imm/Rs -- shifter-op ) BIN: 11 ; +: ( Rm -- shifter-op ) 0 ; + +M: register shifter-op 0 shifter-op ; +M: integer shifter-op 0 shifter-op ; + + + +: AND ( Rd Rn shifter-op -- ) BIN: 0000 addr1 ; +: EOR ( Rd Rn shifter-op -- ) BIN: 0001 addr1 ; +: SUB ( Rd Rn shifter-op -- ) BIN: 0010 addr1 ; +: RSB ( Rd Rn shifter-op -- ) BIN: 0011 addr1 ; +: ADD ( Rd Rn shifter-op -- ) BIN: 0100 addr1 ; +: ADC ( Rd Rn shifter-op -- ) BIN: 0101 addr1 ; +: SBC ( Rd Rn shifter-op -- ) BIN: 0110 addr1 ; +: RSC ( Rd Rn shifter-op -- ) BIN: 0111 addr1 ; +: ORR ( Rd Rn shifter-op -- ) BIN: 1100 addr1 ; +: BIC ( Rd Rn shifter-op -- ) BIN: 1110 addr1 ; + +: MOV ( Rd shifter-op -- ) [ f ] dip BIN: 1101 addr1 ; +: MVN ( Rd shifter-op -- ) [ f ] dip BIN: 1111 addr1 ; + +! These always update the condition code flags + + +: TST ( Rn shifter-op -- ) BIN: 1000 (CMP) ; +: TEQ ( Rn shifter-op -- ) BIN: 1001 (CMP) ; +: CMP ( Rn shifter-op -- ) BIN: 1010 (CMP) ; +: CMN ( Rn shifter-op -- ) BIN: 1011 (CMP) ; + +! Multiply instructions + + +: MUL ( Rd Rm Rs -- ) f 0 (MLA) ; +: MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ; + +: SMLAL ( RdLo RdHi Rm Rs -- ) 1 1 (S/UMLAL) ; +: SMULL ( RdLo RdHi Rm Rs -- ) 1 0 (S/UMLAL) ; +: UMLAL ( RdLo RdHi Rm Rs -- ) 0 1 (S/UMLAL) ; +: UMULL ( RdLo RdHi Rm Rs -- ) 0 0 (S/UMLAL) ; + +! Miscellaneous arithmetic instructions +: CLZ ( Rd Rm -- ) + { + { 1 24 } + { 1 22 } + { 1 21 } + { BIN: 111 16 } + { BIN: 1111 8 } + { 1 4 } + { register 0 } + { register 12 } + } sinsn ; + +! Status register acess instructions + +! Load and store instructions + addressing + +M: addressing addressing-mode-2 + { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-2 ] } cleave + { 0 21 23 24 } bitfield ; + +M: integer addressing-mode-2 ; + +M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ; + +: addr2 ( Rd Rn addressing-mode b l -- ) + { + { 1 26 } + 20 + 22 + { addressing-mode-2 0 } + { register 16 } + { register 12 } + } insn ; + +PRIVATE> + +! Offset +: <+> ( base -- addressing ) 1 1 0 ; +: <-> ( base -- addressing ) 1 0 0 ; + +! Pre-indexed +: ( base -- addressing ) 1 1 1 ; +: ( base -- addressing ) 1 0 1 ; + +! Post-indexed +: <+!> ( base -- addressing ) 0 1 0 ; +: <-!> ( base -- addressing ) 0 0 0 ; + +: LDR ( Rd Rn addressing-mode -- ) 0 1 addr2 ; +: LDRB ( Rd Rn addressing-mode -- ) 1 1 addr2 ; +: STR ( Rd Rn addressing-mode -- ) 0 0 addr2 ; +: STRB ( Rd Rn addressing-mode -- ) 1 0 addr2 ; + +! We might have to simulate these instructions since older ARM +! chips don't have them. +SYMBOL: have-BX? +SYMBOL: have-BLX? + + + +: BX ( Rm -- ) have-BX? get [ 0 (BX) ] [ [ PC ] dip MOV ] if ; + +: BLX ( Rm -- ) have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ; + +! More load and store instructions +n/n ( b -- n n ) [ -4 shift ] [ HEX: f bitand ] bi ; + +M: addressing addressing-mode-3 + { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-3 ] } cleave + { 0 21 23 24 } bitfield ; + +M: integer addressing-mode-3 + b>n/n { + ! { 1 24 } + { 1 22 } + { 1 7 } + { 1 4 } + 0 + 8 + } bitfield ; + +M: object addressing-mode-3 + shifter-op { + ! { 1 24 } + { 1 7 } + { 1 4 } + 0 + } bitfield ; + +: addr3 ( Rn Rd addressing-mode h l s -- ) + { + 6 + 20 + 5 + { addressing-mode-3 0 } + { register 16 } + { register 12 } + } insn ; + +PRIVATE> + +: LDRH ( Rn Rd addressing-mode -- ) 1 1 0 addr3 ; +: LDRSB ( Rn Rd addressing-mode -- ) 0 1 1 addr3 ; +: LDRSH ( Rn Rd addressing-mode -- ) 1 1 1 addr3 ; +: STRH ( Rn Rd addressing-mode -- ) 1 0 0 addr3 ; + +! Load and store multiple instructions + +! Semaphore instructions + +! Exception-generating instructions diff --git a/basis/cpu/arm/assembler/authors.txt b/basis/cpu/arm/assembler/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/cpu/arm/assembler/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index c63372fa3f..b9e374f0bb 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -51,8 +51,9 @@ CONSTANT: rs-reg 14 0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel 4 3 0 LWZ 1 4 0 STW - 0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel - 3 MTCTR + 4 0 swap LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel + 0 5 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel + 5 MTCTR BCTR ] jit-primitive jit-define @@ -254,8 +255,9 @@ CONSTANT: rs-reg 14 [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI - 4 3 quot-xt-offset LWZ - 4 MTCTR + 4 0 swap LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel + 5 3 quot-xt-offset LWZ + 5 MTCTR BCTR ] \ (call) define-sub-primitive diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index eb9709a350..9237d320f3 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -40,9 +40,6 @@ enable-float-intrinsics M: ppc %vm-field-ptr ( dst field -- ) %load-vm-field-addr ; -M: ppc %vm-invoke-1st-arg ( function -- ) f %alien-invoke ; -M: ppc %vm-invoke-3rd-arg ( function -- ) f %alien-invoke ; - M: ppc machine-registers { { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] } @@ -52,8 +49,6 @@ M: ppc machine-registers CONSTANT: scratch-reg 30 CONSTANT: fp-scratch-reg 30 -M: ppc two-operand? f ; - M: ppc %load-immediate ( reg n -- ) swap LOAD ; M: ppc %load-reference ( reg obj -- ) @@ -142,16 +137,12 @@ M:: ppc %dispatch ( src temp -- ) temp MTCTR BCTR ; -:: (%slot) ( obj slot tag temp -- reg offset ) - temp slot obj ADD - temp tag neg ; inline - : (%slot-imm) ( obj slot tag -- reg offset ) [ cells ] dip - ; inline -M: ppc %slot ( dst obj slot tag temp -- ) (%slot) LWZ ; +M: ppc %slot ( dst obj slot -- ) swapd LWZX ; M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ; -M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ; +M: ppc %set-slot ( src obj slot -- ) swapd STWX ; M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ; M:: ppc %string-nth ( dst src index temp -- ) @@ -193,6 +184,7 @@ M: ppc %shr-imm swapd SRWI ; M: ppc %sar SRAW ; M: ppc %sar-imm SRAWI ; M: ppc %not NOT ; +M: ppc %neg NEG ; :: overflow-template ( label dst src1 src2 insn -- ) 0 0 LI @@ -209,59 +201,6 @@ M: ppc %fixnum-sub ( label dst src1 src2 -- ) M: ppc %fixnum-mul ( label dst src1 src2 -- ) [ MULLWO. ] overflow-template ; -: bignum@ ( n -- offset ) cells bignum tag-number - ; inline - -M:: ppc %integer>bignum ( dst src temp -- ) - [ - "end" define-label - dst 0 >bignum %load-reference - ! Is it zero? Then just go to the end and return this zero - 0 src 0 CMPI - "end" get BEQ - ! Allocate a bignum - dst 4 cells bignum temp %allot - ! Write length - 2 tag-fixnum temp LI - temp dst 1 bignum@ STW - ! Compute sign - temp src MR - temp temp cell-bits 1 - SRAWI - temp temp 1 ANDI - ! Store sign - temp dst 2 bignum@ STW - ! Make negative value positive - temp temp temp ADD - temp temp NEG - temp temp 1 ADDI - temp src temp MULLW - ! Store the bignum - temp dst 3 bignum@ STW - "end" resolve-label - ] with-scope ; - -M:: ppc %bignum>integer ( dst src temp -- ) - [ - "end" define-label - temp src 1 bignum@ LWZ - ! if the length is 1, its just the sign and nothing else, - ! so output 0 - 0 dst LI - 0 temp 1 tag-fixnum CMPI - "end" get BEQ - ! load the value - dst src 3 bignum@ LWZ - ! load the sign - temp src 2 bignum@ LWZ - ! branchless arithmetic: we want to turn 0 into 1, - ! and 1 into -1 - temp temp temp ADD - temp temp 1 SUBI - temp temp NEG - ! multiply value by sign - dst dst temp MULLW - "end" resolve-label - ] with-scope ; - M: ppc %add-float FADD ; M: ppc %sub-float FSUB ; M: ppc %mul-float FMUL ; @@ -284,22 +223,23 @@ M:: ppc %float>integer ( dst src -- ) dst 1 4 scratch@ LWZ ; M: ppc %copy ( dst src rep -- ) - { - { int-rep [ MR ] } - { double-rep [ FMR ] } - } case ; + 2over eq? [ 3drop ] [ + { + { int-rep [ MR ] } + { double-rep [ FMR ] } + } case + ] if ; -M: ppc %unbox-float ( dst src -- ) float-offset LFD ; +GENERIC: float-function-param* ( dst src -- ) -M:: ppc %box-float ( dst src temp -- ) - dst 16 float temp %allot - src dst float-offset STFD ; +M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ; +M: integer float-function-param* FMR ; -: float-function-param ( i spill-slot -- ) - [ float-regs param-regs nth 1 ] [ n>> spill@ ] bi* LFD ; +: float-function-param ( i src -- ) + [ float-regs param-regs nth ] dip float-function-param* ; : float-function-return ( reg -- ) - float-regs return-reg 2dup = [ 2drop ] [ FMR ] if ; + float-regs return-reg double-rep %copy ; M:: ppc %unary-float-function ( dst src func -- ) 0 src float-function-param @@ -313,9 +253,8 @@ M:: ppc %binary-float-function ( dst src1 src2 func -- ) dst float-function-return ; ! Internal format is always double-precision on PowerPC -M: ppc %single>double-float FMR ; - -M: ppc %double>single-float FMR ; +M: ppc %single>double-float double-rep %copy ; +M: ppc %double>single-float double-rep %copy ; M: ppc %unbox-alien ( dst src -- ) alien-offset LWZ ; @@ -412,24 +351,24 @@ M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-cl "end" resolve-label ] with-scope ; -M: ppc %alien-unsigned-1 0 LBZ ; -M: ppc %alien-unsigned-2 0 LHZ ; +M: ppc %alien-unsigned-1 LBZ ; +M: ppc %alien-unsigned-2 LHZ ; -M: ppc %alien-signed-1 dupd 0 LBZ dup EXTSB ; -M: ppc %alien-signed-2 0 LHA ; +M: ppc %alien-signed-1 [ dup ] 2dip LBZ dup EXTSB ; +M: ppc %alien-signed-2 LHA ; -M: ppc %alien-cell 0 LWZ ; +M: ppc %alien-cell LWZ ; -M: ppc %alien-float 0 LFS ; -M: ppc %alien-double 0 LFD ; +M: ppc %alien-float LFS ; +M: ppc %alien-double LFD ; -M: ppc %set-alien-integer-1 swap 0 STB ; -M: ppc %set-alien-integer-2 swap 0 STH ; +M: ppc %set-alien-integer-1 -rot STB ; +M: ppc %set-alien-integer-2 -rot STH ; -M: ppc %set-alien-cell swap 0 STW ; +M: ppc %set-alien-cell -rot STW ; -M: ppc %set-alien-float swap 0 STFS ; -M: ppc %set-alien-double swap 0 STFD ; +M: ppc %set-alien-float -rot STFS ; +M: ppc %set-alien-double -rot STFD ; : load-zone-ptr ( reg -- ) "nursery" %load-vm-field-addr ; @@ -473,12 +412,11 @@ M:: ppc %write-barrier ( src card# table -- ) src card# deck-bits SRWI table scratch-reg card# STBX ; -M:: ppc %check-nursery ( label temp1 temp2 -- ) +M:: ppc %check-nursery ( label size temp1 temp2 -- ) temp2 load-zone-ptr temp1 temp2 cell LWZ temp2 temp2 3 cells LWZ - ! add ALLOT_BUFFER_ZONE to here - temp1 temp1 1024 ADDI + temp1 temp1 size ADDI ! is here >= end? temp1 0 temp2 CMP label BLE ; @@ -489,9 +427,10 @@ M:: ppc %save-gc-root ( gc-root register -- ) M:: ppc %load-gc-root ( gc-root register -- ) register 1 gc-root gc-root@ LWZ ; -M:: ppc %call-gc ( gc-root-count -- ) +M:: ppc %call-gc ( gc-root-count temp -- ) 3 1 gc-root-base local@ ADDI gc-root-count 4 LI + 5 %load-vm-addr "inline_gc" f %alien-invoke ; M: ppc %prologue ( n -- ) @@ -615,11 +554,11 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- ) { stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] } } case ; -M: ppc %spill ( src rep n -- ) - swap [ spill@ ] dip store-to-frame ; +M: ppc %spill ( src rep dst -- ) + swap [ n>> spill@ ] dip store-to-frame ; -M: ppc %reload ( dst rep n -- ) - swap [ spill@ ] dip load-from-frame ; +M: ppc %reload ( dst rep src -- ) + swap [ n>> spill@ ] dip load-from-frame ; M: ppc %loop-entry ; @@ -640,13 +579,14 @@ M: ppc %prepare-unbox ( -- ) M: ppc %unbox ( n rep func -- ) ! Value must be in r3 + 4 %load-vm-addr ! Call the unboxer f %alien-invoke ! Store the return value on the C stack over [ [ reg-class-of return-reg ] keep %save-param-reg ] [ 2drop ] if ; M: ppc %unbox-long-long ( n func -- ) - ! Value must be in r3:r4 + 4 %load-vm-addr ! Call the unboxer f %alien-invoke ! Store the return value on the C stack @@ -659,15 +599,17 @@ M: ppc %unbox-large-struct ( n c-type -- ) ! Value must be in r3 ! Compute destination address and load struct size [ [ 4 1 ] dip local@ ADDI ] [ heap-size 5 LI ] bi* + 6 %load-vm-addr ! Call the function "to_value_struct" f %alien-invoke ; -M: ppc %box ( n rep func -- ) +M:: ppc %box ( n rep func -- ) ! If the source is a stack location, load it into freg #0. ! If the source is f, then we assume the value is already in ! freg #0. - [ over [ 0 over reg-class-of param-reg swap %load-param-reg ] [ 2drop ] if ] dip - f %alien-invoke ; + n [ 0 rep reg-class-of param-reg rep %load-param-reg ] when* + rep double-rep? 5 4 ? %load-vm-addr + func f %alien-invoke ; M: ppc %box-long-long ( n func -- ) [ @@ -675,6 +617,7 @@ M: ppc %box-long-long ( n func -- ) [ [ 3 1 ] dip local@ LWZ ] [ [ 4 1 ] dip cell + local@ LWZ ] bi ] when* + 5 %load-vm-addr ] dip f %alien-invoke ; : struct-return@ ( n -- n ) @@ -689,6 +632,7 @@ M: ppc %box-large-struct ( n c-type -- ) ! If n = f, then we're boxing a returned struct ! Compute destination address and load struct size [ [ 3 1 ] dip struct-return@ ADDI ] [ heap-size 4 LI ] bi* + 5 %load-vm-addr ! Call the function "box_value_struct" f %alien-invoke ; @@ -708,9 +652,12 @@ M: ppc %alien-invoke ( symbol dll -- ) [ 11 ] 2dip %alien-global 11 MTLR BLRL ; M: ppc %alien-callback ( quot -- ) - 3 swap %load-reference "c_to_factor" f %alien-invoke ; + 3 swap %load-reference + 4 %load-vm-addr + "c_to_factor" f %alien-invoke ; M: ppc %prepare-alien-indirect ( -- ) + 3 %load-vm-addr "unbox_alien" f %alien-invoke 15 3 MR ; @@ -721,6 +668,7 @@ M: ppc %callback-value ( ctype -- ) ! Save top of data stack 3 ds-reg 0 LWZ 3 1 0 local@ STW + 3 %load-vm-addr ! Restore data/call/retain stacks "unnest_stacks" f %alien-invoke ! Restore top of data stack @@ -736,27 +684,39 @@ M: ppc return-struct-in-registers? ( c-type -- ? ) M: ppc %box-small-struct ( c-type -- ) #! Box a <= 16-byte struct returned in r3:r4:r5:r6 heap-size 7 LI + 8 %load-vm-addr "box_medium_struct" f %alien-invoke ; : %unbox-struct-1 ( -- ) ! Alien must be in r3. + 4 %load-vm-addr "alien_offset" f %alien-invoke 3 3 0 LWZ ; : %unbox-struct-2 ( -- ) ! Alien must be in r3. + 4 %load-vm-addr "alien_offset" f %alien-invoke 4 3 4 LWZ 3 3 0 LWZ ; : %unbox-struct-4 ( -- ) ! Alien must be in r3. + 4 %load-vm-addr "alien_offset" f %alien-invoke 6 3 12 LWZ 5 3 8 LWZ 4 3 4 LWZ 3 3 0 LWZ ; +M: ppc %nest-stacks ( -- ) + 3 %load-vm-addr + "nest_stacks" f %alien-invoke ; + +M: ppc %unnest-stacks ( -- ) + 3 %load-vm-addr + "unnest_stacks" f %alien-invoke ; + M: ppc %unbox-small-struct ( size -- ) #! Alien must be in EAX. heap-size cell align cell /i { diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 85db5fb09c..414249f88e 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -1,12 +1,14 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: locals alien.c-types alien.syntax arrays kernel fry math -namespaces sequences system layouts io vocabs.loader accessors init -combinators command-line make compiler compiler.units -compiler.constants compiler.alien compiler.codegen -compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder -compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler -cpu.x86.assembler.operands cpu.x86 cpu.architecture ; +USING: locals alien.c-types alien.libraries alien.syntax arrays +kernel fry math namespaces sequences system layouts io +vocabs.loader accessors init combinators command-line make +compiler compiler.units compiler.constants compiler.alien +compiler.codegen compiler.codegen.fixup +compiler.cfg.instructions compiler.cfg.builder +compiler.cfg.intrinsics compiler.cfg.stack-frame +cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 +cpu.architecture ; IN: cpu.x86.32 ! We implement the FFI for Linux, OS X and Windows all at once. @@ -38,8 +40,8 @@ M:: x86.32 %dispatch ( src temp -- ) bi ; ! Registers for fastcall -M: x86.32 param-reg-1 EAX ; -M: x86.32 param-reg-2 EDX ; +: param-reg-1 ( -- reg ) EAX ; +: param-reg-2 ( -- reg ) EDX ; M: x86.32 pic-tail-reg EBX ; @@ -48,16 +50,7 @@ M: x86.32 reserved-area-size 0 ; M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; : push-vm-ptr ( -- ) - temp-reg 0 MOV rc-absolute-cell rt-vm rel-fixup ! push the vm ptr as an argument - temp-reg PUSH ; - -M: x86.32 %vm-invoke-1st-arg ( function -- ) - push-vm-ptr - f %alien-invoke - temp-reg POP ; - -M: x86.32 %vm-invoke-3rd-arg ( function -- ) - %vm-invoke-1st-arg ; ! first 2 args are regs, 3rd is stack so vm-invoke-1st-arg works here + 0 PUSH rc-absolute-cell rt-vm rel-fixup ; ! push the vm ptr as an argument M: x86.32 return-struct-in-registers? ( c-type -- ? ) c-type @@ -246,6 +239,18 @@ M:: x86.32 %unbox-large-struct ( n c-type -- ) "to_value_struct" f %alien-invoke ] with-aligned-stack ; +M: x86.32 %nest-stacks ( -- ) + 4 [ + push-vm-ptr + "nest_stacks" f %alien-invoke + ] with-aligned-stack ; + +M: x86.32 %unnest-stacks ( -- ) + 4 [ + push-vm-ptr + "unnest_stacks" f %alien-invoke + ] with-aligned-stack ; + M: x86.32 %prepare-alien-indirect ( -- ) push-vm-ptr "unbox_alien" f %alien-invoke temp-reg POP @@ -279,6 +284,35 @@ M: x86.32 %callback-value ( ctype -- ) ! Unbox EAX unbox-return ; +GENERIC: float-function-param ( stack-slot dst src -- ) + +M:: spill-slot float-function-param ( stack-slot dst src -- ) + ! We can clobber dst here since its going to contain the + ! final result + dst src double-rep %copy + stack-slot dst double-rep %copy ; + +M: register float-function-param + nip double-rep %copy ; + +: float-function-return ( reg -- ) + ESP [] FSTPL + ESP [] MOVSD + ESP 16 ADD ; + +M:: x86.32 %unary-float-function ( dst src func -- ) + ESP -16 [+] dst src float-function-param + ESP 16 SUB + func "libm" load-library %alien-invoke + dst float-function-return ; + +M:: x86.32 %binary-float-function ( dst src1 src2 func -- ) + ESP -16 [+] dst src1 float-function-param + ESP -8 [+] dst src2 float-function-param + ESP 16 SUB + func "libm" load-library %alien-invoke + dst float-function-return ; + M: x86.32 %cleanup ( params -- ) #! a) If we just called an stdcall function in Windows, it #! cleaned up the stack frame for us. But we don't want that @@ -310,6 +344,19 @@ M: x86.32 %callback-return ( n -- ) [ drop 0 ] } cond RET ; +M:: x86.32 %call-gc ( gc-root-count temp -- ) + temp gc-root-base param@ LEA + 12 [ + ! Pass the VM ptr as the third parameter + 0 PUSH rc-absolute-cell rt-vm rel-fixup + ! Pass number of roots as second parameter + gc-root-count PUSH + ! Pass pointer to start of GC roots as first parameter + temp PUSH + ! Call GC + "inline_gc" f %alien-invoke + ] with-aligned-stack ; + M: x86.32 dummy-stack-params? f ; M: x86.32 dummy-int-params? f ; @@ -322,4 +369,4 @@ os windows? [ 4 "double" c-type (>>align) ] unless -"cpu.x86.features" require +check-sse diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index e2096987da..0540ccd6d6 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -11,7 +11,7 @@ IN: bootstrap.x86 : shift-arg ( -- reg ) ECX ; : div-arg ( -- reg ) EAX ; : mod-arg ( -- reg ) EDX ; -: arg ( -- reg ) EAX ; +: arg1 ( -- reg ) EAX ; : arg2 ( -- reg ) EDX ; : temp0 ( -- reg ) EAX ; : temp1 ( -- reg ) EDX ; @@ -29,7 +29,7 @@ IN: bootstrap.x86 ! save stack pointer temp0 [] stack-reg MOV ! pass vm ptr to primitive - arg 0 MOV rc-absolute-cell rt-vm jit-rel + arg1 0 MOV rc-absolute-cell rt-vm jit-rel ! call the primitive 0 JMP rc-relative rt-primitive jit-rel ] jit-primitive jit-define diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 0528733af1..805dda982b 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -36,9 +36,10 @@ M:: x86.64 %dispatch ( src temp -- ) [ align-code ] bi ; -M: x86.64 param-reg-1 int-regs param-regs first ; -M: x86.64 param-reg-2 int-regs param-regs second ; +: param-reg-1 ( -- reg ) int-regs param-regs first ; inline +: param-reg-2 ( -- reg ) int-regs param-regs second ; inline : param-reg-3 ( -- reg ) int-regs param-regs third ; inline +: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline M: x86.64 pic-tail-reg RBX ; @@ -58,9 +59,9 @@ M: stack-params copy-register* { [ over integer? ] [ R11 swap MOV param@ R11 MOV ] } } cond ; -M: x86 %save-param-reg [ param@ ] 2dip copy-register ; +M: x86 %save-param-reg [ param@ ] 2dip %copy ; -M: x86 %load-param-reg [ swap param@ ] dip copy-register ; +M: x86 %load-param-reg [ swap param@ ] dip %copy ; : with-return-regs ( quot -- ) [ @@ -74,26 +75,13 @@ M: x86.64 %prepare-unbox ( -- ) param-reg-1 R14 [] MOV R14 cell SUB ; -M: x86.64 %vm-invoke-1st-arg ( function -- ) - param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup - f %alien-invoke ; - -: %vm-invoke-2nd-arg ( function -- ) - param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup - f %alien-invoke ; - -M: x86.64 %vm-invoke-3rd-arg ( function -- ) - param-reg-3 0 MOV rc-absolute-cell rt-vm rel-fixup - f %alien-invoke ; - -: %vm-invoke-4th-arg ( function -- ) - int-regs param-regs fourth 0 MOV rc-absolute-cell rt-vm rel-fixup - f %alien-invoke ; - +: %mov-vm-ptr ( reg -- ) + 0 MOV rc-absolute-cell rt-vm rel-fixup ; M:: x86.64 %unbox ( n rep func -- ) + param-reg-2 %mov-vm-ptr ! Call the unboxer - func %vm-invoke-2nd-arg + func f %alien-invoke ! Store the return value on the C stack if this is an ! alien-invoke, otherwise leave it the return register if ! this is the end of alien-callback @@ -109,10 +97,10 @@ M: x86.64 %unbox-long-long ( n func -- ) { float-regs [ float-regs get pop swap MOVSD ] } } case ; - M: x86.64 %unbox-small-struct ( c-type -- ) ! Alien must be in param-reg-1. - "alien_offset" %vm-invoke-2nd-arg + param-reg-2 %mov-vm-ptr + "alien_offset" f %alien-invoke ! Move alien_offset() return value to R11 so that we don't ! clobber it. R11 RAX MOV @@ -126,16 +114,15 @@ M:: x86.64 %unbox-large-struct ( n c-type -- ) param-reg-2 n param@ LEA ! Load structure size into param-reg-3 param-reg-3 c-type heap-size MOV + param-reg-4 %mov-vm-ptr ! Copy the struct to the C stack - "to_value_struct" %vm-invoke-4th-arg ; + "to_value_struct" f %alien-invoke ; : load-return-value ( rep -- ) [ [ 0 ] dip reg-class-of param-reg ] [ reg-class-of return-reg ] [ ] - tri copy-register ; - - + tri %copy ; M:: x86.64 %box ( n rep func -- ) n [ @@ -145,7 +132,8 @@ M:: x86.64 %box ( n rep func -- ) ] [ rep load-return-value ] if - rep int-rep? [ func %vm-invoke-2nd-arg ] [ func %vm-invoke-1st-arg ] if ; + rep int-rep? [ param-reg-2 ] [ param-reg-1 ] if %mov-vm-ptr + func f %alien-invoke ; M: x86.64 %box-long-long ( n func -- ) [ int-rep ] dip %box ; @@ -165,7 +153,8 @@ M: x86.64 %box-small-struct ( c-type -- ) [ param-reg-3 swap heap-size MOV ] bi param-reg-1 0 box-struct-field@ MOV param-reg-2 1 box-struct-field@ MOV - "box_small_struct" %vm-invoke-4th-arg + param-reg-4 %mov-vm-ptr + "box_small_struct" f %alien-invoke ] with-return-regs ; : struct-return@ ( n -- operand ) @@ -176,8 +165,9 @@ M: x86.64 %box-large-struct ( n c-type -- ) param-reg-2 swap heap-size MOV ! Compute destination address param-reg-1 swap struct-return@ LEA + param-reg-3 %mov-vm-ptr ! Copy the struct from the C stack - "box_value_struct" %vm-invoke-3rd-arg ; + "box_value_struct" f %alien-invoke ; M: x86.64 %prepare-box-struct ( -- ) ! Compute target address for value struct return @@ -192,9 +182,17 @@ M: x86.64 %alien-invoke rc-absolute-cell rel-dlsym R11 CALL ; +M: x86.64 %nest-stacks ( -- ) + param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup + "nest_stacks" f %alien-invoke ; + +M: x86.64 %unnest-stacks ( -- ) + param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup + "unnest_stacks" f %alien-invoke ; M: x86.64 %prepare-alien-indirect ( -- ) - "unbox_alien" %vm-invoke-1st-arg + param-reg-1 %mov-vm-ptr + "unbox_alien" f %alien-invoke RBP RAX MOV ; M: x86.64 %alien-indirect ( -- ) @@ -202,7 +200,8 @@ M: x86.64 %alien-indirect ( -- ) M: x86.64 %alien-callback ( quot -- ) param-reg-1 swap %load-reference - "c_to_factor" %vm-invoke-2nd-arg ; + param-reg-2 %mov-vm-ptr + "c_to_factor" f %alien-invoke ; M: x86.64 %callback-value ( ctype -- ) ! Save top of data stack @@ -210,19 +209,20 @@ M: x86.64 %callback-value ( ctype -- ) ! Save top of data stack RSP 8 SUB param-reg-1 PUSH + param-reg-1 %mov-vm-ptr ! Restore data/call/retain stacks - "unnest_stacks" %vm-invoke-1st-arg + "unnest_stacks" f %alien-invoke ! Put former top of data stack in param-reg-1 param-reg-1 POP RSP 8 ADD ! Unbox former top of data stack to return registers unbox-return ; -: float-function-param ( i spill-slot -- ) - [ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ; +: float-function-param ( i src -- ) + [ float-regs param-regs nth ] dip double-rep %copy ; : float-function-return ( reg -- ) - float-regs return-reg double-rep copy-register ; + float-regs return-reg double-rep %copy ; M:: x86.64 %unary-float-function ( dst src func -- ) 0 src float-function-param @@ -230,18 +230,27 @@ M:: x86.64 %unary-float-function ( dst src func -- ) dst float-function-return ; M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) + ! src1 might equal dst; otherwise it will be a spill slot + ! src2 is always a spill slot 0 src1 float-function-param 1 src2 float-function-param func f %alien-invoke dst float-function-return ; +M:: x86.64 %call-gc ( gc-root-count temp -- ) + ! Pass pointer to start of GC roots as first parameter + param-reg-1 gc-root-base param@ LEA + ! Pass number of roots as second parameter + param-reg-2 gc-root-count MOV + ! Pass VM ptr as third parameter + param-reg-3 %mov-vm-ptr + ! Call GC + "inline_gc" f %alien-invoke ; + ! The result of reading 4 bytes from memory is a fixnum on ! x86-64. enable-alien-4-intrinsics -! Enable fast calling of libc math functions -enable-float-functions - USE: vocabs.loader { @@ -249,4 +258,4 @@ USE: vocabs.loader { [ os winnt? ] [ "cpu.x86.64.winnt" require ] } } cond -"cpu.x86.features" require +check-sse diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index aa7a5dcd67..bffe056656 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -21,7 +21,6 @@ IN: bootstrap.x86 : rex-length ( -- n ) 1 ; [ - ! load stack_chain temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel temp0 temp0 [] MOV @@ -30,7 +29,7 @@ IN: bootstrap.x86 ! load XT temp1 0 MOV rc-absolute-cell rt-primitive jit-rel ! load vm ptr - arg 0 MOV rc-absolute-cell rt-vm jit-rel + arg1 0 MOV rc-absolute-cell rt-vm jit-rel ! go temp1 JMP ] jit-primitive jit-define diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor index 199fe8daf4..2ad3a721af 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -5,7 +5,7 @@ cpu.x86.assembler cpu.x86.assembler.operands layouts vocabs parser ; IN: bootstrap.x86 : stack-frame-size ( -- n ) 4 bootstrap-cells ; -: arg ( -- reg ) RDI ; +: arg1 ( -- reg ) RDI ; : arg2 ( -- reg ) RSI ; << "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >> diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index 13e91a87a4..b3d184bc97 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -1,11 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays sequences math splitting make assocs kernel -layouts system alien.c-types cpu.architecture +layouts system alien.c-types classes.struct cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen compiler.cfg.registers ; -QUALIFIED: alien.structs -QUALIFIED: classes.struct IN: cpu.x86.64.unix M: int-regs param-regs @@ -48,9 +46,7 @@ stack-params \ (stack-value) c-type (>>rep) >> flatten-small-struct ] if ; -M: alien.structs:struct-type flatten-value-type ( type -- seq ) - flatten-struct ; -M: classes.struct:struct-c-type flatten-value-type ( type -- seq ) +M: struct-c-type flatten-value-type ( type -- seq ) flatten-struct ; M: x86.64 return-struct-in-registers? ( c-type -- ? ) diff --git a/basis/cpu/x86/64/winnt/bootstrap.factor b/basis/cpu/x86/64/winnt/bootstrap.factor index 72b9d27ca4..2dd3e889a5 100644 --- a/basis/cpu/x86/64/winnt/bootstrap.factor +++ b/basis/cpu/x86/64/winnt/bootstrap.factor @@ -6,7 +6,7 @@ cpu.x86.assembler.operands ; IN: bootstrap.x86 : stack-frame-size ( -- n ) 8 bootstrap-cells ; -: arg ( -- reg ) RCX ; +: arg1 ( -- reg ) RCX ; : arg2 ( -- reg ) RDX ; << "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >> diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 47d6434279..531110da7b 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -56,8 +56,24 @@ IN: cpu.x86.assembler.tests ! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 11 HEX: 04 HEX: 24 } ] [ [ R12 [] XMM0 MOVSD ] { } make ] unit-test ! 3-operand r-rm-imm sse instructions -[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test -[ { HEX: 0f HEX: c6 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 SHUFPS ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ] +[ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test + +[ { HEX: 0f HEX: c6 HEX: c1 HEX: 02 } ] +[ [ XMM0 XMM1 2 SHUFPS ] { } make ] unit-test + +! shufflers with arrays of indexes +[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ] +[ [ XMM0 XMM1 { 2 0 0 0 } PSHUFD ] { } make ] unit-test + +[ { HEX: 0f HEX: c6 HEX: c1 HEX: 63 } ] +[ [ XMM0 XMM1 { 3 0 2 1 } SHUFPS ] { } make ] unit-test + +[ { HEX: 66 HEX: 0f HEX: c6 HEX: c1 HEX: 2 } ] +[ [ XMM0 XMM1 { 0 1 } SHUFPD ] { } make ] unit-test + +[ { HEX: 66 HEX: 0f HEX: c6 HEX: c1 HEX: 1 } ] +[ [ XMM0 XMM1 { 1 0 } SHUFPD ] { } make ] unit-test ! scalar register insert/extract sse instructions [ { HEX: 66 HEX: 0f HEX: c4 HEX: c1 HEX: 02 } ] [ [ XMM0 ECX 2 PINSRW ] { } make ] unit-test diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index ead1c8a695..57738ce4ba 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2005, 2009 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io.binary kernel combinators kernel.private math locals -namespaces make sequences words system layouts math.order accessors -cpu.x86.assembler.operands cpu.x86.assembler.operands.private ; +USING: arrays io.binary kernel combinators kernel.private math +math.bitwise locals namespaces make sequences words system +layouts math.order accessors cpu.x86.assembler.operands +cpu.x86.assembler.operands.private ; QUALIFIED: sequences IN: cpu.x86.assembler @@ -198,12 +199,16 @@ M: register POP f HEX: 58 short-operand ; M: operand POP { BIN: 000 f HEX: 8f } 1-operand ; ! MOV where the src is immediate. + + GENERIC: MOV ( dst src -- ) M: immediate MOV swap (MOV-I) ; M: operand MOV HEX: 88 2-operand ; @@ -219,9 +224,13 @@ GENERIC: CALL ( op -- ) M: integer CALL HEX: e8 , 4, ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; + + : JO ( dst -- ) HEX: 80 JUMPcc ; : JNO ( dst -- ) HEX: 81 JUMPcc ; : JB ( dst -- ) HEX: 82 JUMPcc ; @@ -296,6 +305,8 @@ M: operand TEST OCT: 204 2-operand ; : CDQ ( -- ) HEX: 99 , ; : CQO ( -- ) HEX: 48 , CDQ ; + + : ROL ( dst n -- ) BIN: 000 (SHIFT) ; : ROR ( dst n -- ) BIN: 001 (SHIFT) ; : RCL ( dst n -- ) BIN: 010 (SHIFT) ; @@ -605,9 +618,18 @@ ALIAS: PINSRQ PINSRD : MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ; : MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ; -: PSHUFD ( dest src imm -- ) HEX: 70 HEX: 66 3-operand-rm-sse ; -: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ; -: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ; + + +: PSHUFD ( dest src imm -- ) 4shuffler HEX: 70 HEX: 66 3-operand-rm-sse ; +: PSHUFLW ( dest src imm -- ) 4shuffler HEX: 70 HEX: f2 3-operand-rm-sse ; +: PSHUFHW ( dest src imm -- ) 4shuffler HEX: 70 HEX: f3 3-operand-rm-sse ; : MOVNTI ( dest src -- ) { HEX: 0f HEX: c3 } (2-operand) ; : PINSRW ( dest src imm -- ) HEX: c4 HEX: 66 3-operand-rm-sse ; -: SHUFPS ( dest src imm -- ) HEX: c6 f 3-operand-rm-sse ; -: SHUFPD ( dest src imm -- ) HEX: c6 HEX: 66 3-operand-rm-sse ; +: SHUFPS ( dest src imm -- ) 4shuffler HEX: c6 f 3-operand-rm-sse ; +: SHUFPD ( dest src imm -- ) 2shuffler HEX: c6 HEX: 66 3-operand-rm-sse ; : ADDSUBPD ( dest src -- ) HEX: d0 HEX: 66 2-operand-rm-sse ; : ADDSUBPS ( dest src -- ) HEX: d0 HEX: f2 2-operand-rm-sse ; diff --git a/basis/cpu/x86/assembler/operands/authors.txt b/basis/cpu/x86/assembler/operands/authors.txt new file mode 100644 index 0000000000..580f882c8d --- /dev/null +++ b/basis/cpu/x86/assembler/operands/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Joe Groff diff --git a/basis/cpu/x86/assembler/operands/summary.txt b/basis/cpu/x86/assembler/operands/summary.txt new file mode 100644 index 0000000000..474b715848 --- /dev/null +++ b/basis/cpu/x86/assembler/operands/summary.txt @@ -0,0 +1 @@ +x86 registers and memory operands diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 5bc5272ab4..3cc71d22f7 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -248,13 +248,13 @@ big-endian off ! Quotations and words [ ! load from stack - arg ds-reg [] MOV + arg1 ds-reg [] MOV ! pop stack ds-reg bootstrap-cell SUB ! pass vm pointer arg2 0 MOV rc-absolute-cell rt-vm jit-rel ! call quotation - arg quot-xt-offset [+] JMP + arg1 quot-xt-offset [+] JMP ] \ (call) define-sub-primitive ! Objects diff --git a/basis/cpu/x86/features/features.factor b/basis/cpu/x86/features/features.factor index c5cf2d470a..b21aa762d8 100644 --- a/basis/cpu/x86/features/features.factor +++ b/basis/cpu/x86/features/features.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system kernel math math.order math.parser namespaces -alien.c-types alien.syntax combinators locals init io cpu.x86 +USING: system kernel memoize math math.order math.parser +namespaces alien.c-types alien.syntax combinators locals init io compiler compiler.units accessors ; IN: cpu.x86.features @@ -13,7 +13,18 @@ FUNCTION: longlong read_timestamp_counter ( ) ; PRIVATE> -ALIAS: sse-version sse_version +MEMO: sse-version ( -- n ) + sse_version + "sse-version" get string>number [ min ] when* ; + +[ \ sse-version reset-memoized ] "cpu.x86.features" add-init-hook + +: sse? ( -- ? ) sse-version 10 >= ; +: sse2? ( -- ? ) sse-version 20 >= ; +: sse3? ( -- ? ) sse-version 30 >= ; +: ssse3? ( -- ? ) sse-version 33 >= ; +: sse4.1? ( -- ? ) sse-version 41 >= ; +: sse4.2? ( -- ? ) sse-version 42 >= ; : sse-string ( version -- string ) { @@ -32,37 +43,3 @@ M: x86 instruction-count read_timestamp_counter ; : count-instructions ( quot -- n ) instruction-count [ call ] dip instruction-count swap - ; inline - -USING: cpu.x86.features cpu.x86.features.private ; - -:: install-sse-check ( version -- ) - [ - sse-version version < [ - "This image was built to use " write - version sse-string write - " but your CPU only supports " write - sse-version sse-string write "." print - "You will need to bootstrap Factor again." print - flush - 1 exit - ] when - ] "cpu.x86" add-init-hook ; - -: enable-sse ( version -- ) - { - { 00 [ ] } - { 10 [ ] } - { 20 [ enable-sse2 ] } - { 30 [ enable-sse3 ] } - { 33 [ enable-sse3 ] } - { 41 [ enable-sse3 ] } - { 42 [ enable-sse3 ] } - } case ; - -[ { sse_version } compile ] with-optimizer - -"Checking for multimedia extensions: " write sse-version -"sse-version" get [ string>number min ] when* -[ sse-string write " detected" print ] -[ install-sse-check ] -[ enable-sse ] tri diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index d8e02fe516..8612acdcff 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -2,9 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs alien alien.c-types arrays strings cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands -cpu.architecture kernel kernel.private math memory namespaces make -sequences words system layouts combinators math.order fry locals -compiler.constants vm byte-arrays +cpu.x86.features cpu.x86.features.private cpu.architecture kernel +kernel.private math memory namespaces make sequences words system +layouts combinators math.order fry locals compiler.constants +byte-arrays io macros quotations compiler compiler.units init vm compiler.cfg.registers compiler.cfg.instructions compiler.cfg.intrinsics @@ -19,7 +20,7 @@ IN: cpu.x86 M: label JMP 0 JMP rc-relative label-fixup ; M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ; -M: x86 two-operand? t ; +M: x86 vector-regs float-regs ; HOOK: stack-reg cpu ( -- reg ) @@ -49,10 +50,6 @@ M: x86 stack-frame-size ( stack-frame -- i ) ! use in calls in and out of C HOOK: temp-reg cpu ( -- reg ) -! Fastcall calling convention -HOOK: param-reg-1 cpu ( -- reg ) -HOOK: param-reg-2 cpu ( -- reg ) - HOOK: pic-tail-reg cpu ( -- reg ) M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ; @@ -95,38 +92,44 @@ M: x86 %return ( -- ) 0 RET ; : align-code ( n -- ) 0 % ; -:: (%slot) ( obj slot tag temp -- op ) - temp slot obj [+] LEA - temp tag neg [+] ; inline - :: (%slot-imm) ( obj slot tag -- op ) obj slot cells tag - [+] ; inline -M: x86 %slot ( dst obj slot tag temp -- ) (%slot) MOV ; +M: x86 %slot ( dst obj slot -- ) [+] MOV ; M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ; -M: x86 %set-slot ( src obj slot tag temp -- ) (%slot) swap MOV ; +M: x86 %set-slot ( src obj slot -- ) [+] swap MOV ; M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ; +:: two-operand ( dst src1 src2 rep -- dst src ) + dst src2 eq? dst src1 eq? not and [ "Cannot handle this case" throw ] when + dst src1 rep %copy + dst src2 ; inline + +:: one-operand ( dst src rep -- dst ) + dst src rep %copy + dst ; inline + M: x86 %add 2over eq? [ nip ADD ] [ [+] LEA ] if ; M: x86 %add-imm 2over eq? [ nip ADD ] [ [+] LEA ] if ; -M: x86 %sub nip SUB ; +M: x86 %sub int-rep two-operand SUB ; M: x86 %sub-imm 2over eq? [ nip SUB ] [ neg [+] LEA ] if ; -M: x86 %mul nip swap IMUL2 ; +M: x86 %mul int-rep two-operand swap IMUL2 ; M: x86 %mul-imm IMUL3 ; -M: x86 %and nip AND ; -M: x86 %and-imm nip AND ; -M: x86 %or nip OR ; -M: x86 %or-imm nip OR ; -M: x86 %xor nip XOR ; -M: x86 %xor-imm nip XOR ; -M: x86 %shl-imm nip SHL ; -M: x86 %shr-imm nip SHR ; -M: x86 %sar-imm nip SAR ; - -M: x86 %min nip [ CMP ] [ CMOVG ] 2bi ; -M: x86 %max nip [ CMP ] [ CMOVL ] 2bi ; - -M: x86 %not drop NOT ; +M: x86 %and int-rep two-operand AND ; +M: x86 %and-imm int-rep two-operand AND ; +M: x86 %or int-rep two-operand OR ; +M: x86 %or-imm int-rep two-operand OR ; +M: x86 %xor int-rep two-operand XOR ; +M: x86 %xor-imm int-rep two-operand XOR ; +M: x86 %shl-imm int-rep two-operand SHL ; +M: x86 %shr-imm int-rep two-operand SHR ; +M: x86 %sar-imm int-rep two-operand SAR ; + +M: x86 %min int-rep two-operand [ CMP ] [ CMOVG ] 2bi ; +M: x86 %max int-rep two-operand [ CMP ] [ CMOVL ] 2bi ; + +M: x86 %not int-rep one-operand NOT ; +M: x86 %neg int-rep one-operand NEG ; M: x86 %log2 BSR ; GENERIC: copy-register* ( dst src rep -- ) @@ -139,205 +142,20 @@ M: float-4-rep copy-register* drop MOVUPS ; M: double-2-rep copy-register* drop MOVUPD ; M: vector-rep copy-register* drop MOVDQU ; -: copy-register ( dst src rep -- ) - 2over eq? [ 3drop ] [ copy-register* ] if ; - -M: x86 %copy ( dst src rep -- ) copy-register ; - -:: overflow-template ( label dst src1 src2 insn -- ) - src1 src2 insn call - label JO ; inline +M: x86 %copy ( dst src rep -- ) + 2over eq? [ 3drop ] [ + [ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip + copy-register* + ] if ; M: x86 %fixnum-add ( label dst src1 src2 -- ) - [ ADD ] overflow-template ; + int-rep two-operand ADD JO ; M: x86 %fixnum-sub ( label dst src1 src2 -- ) - [ SUB ] overflow-template ; + int-rep two-operand SUB JO ; M: x86 %fixnum-mul ( label dst src1 src2 -- ) - [ swap IMUL2 ] overflow-template ; - -: bignum@ ( reg n -- op ) - cells bignum tag-number - [+] ; inline - -M:: x86 %integer>bignum ( dst src temp -- ) - #! on entry, inreg is a signed 32-bit quantity - #! exits with tagged ptr to bignum in outreg - #! 1 cell header, 1 cell length, 1 cell sign, + digits - #! length is the # of digits + sign - [ - "end" define-label - ! Load cached zero value - dst 0 >bignum %load-reference - src 0 CMP - ! Is it zero? Then just go to the end and return this zero - "end" get JE - ! Allocate a bignum - dst 4 cells bignum temp %allot - ! Write length - dst 1 bignum@ 2 tag-fixnum MOV - ! Store value - dst 3 bignum@ src MOV - ! Compute sign - temp src MOV - temp cell-bits 1 - SAR - temp 1 AND - ! Store sign - dst 2 bignum@ temp MOV - ! Make negative value positive - temp temp ADD - temp NEG - temp 1 ADD - src temp IMUL2 - ! Store the bignum - dst 3 bignum@ temp MOV - "end" resolve-label - ] with-scope ; - -M:: x86 %bignum>integer ( dst src temp -- ) - [ - "end" define-label - ! load length - temp src 1 bignum@ MOV - ! if the length is 1, its just the sign and nothing else, - ! so output 0 - dst 0 MOV - temp 1 tag-fixnum CMP - "end" get JE - ! load the value - dst src 3 bignum@ MOV - ! load the sign - temp src 2 bignum@ MOV - ! convert it into -1 or 1 - temp temp ADD - temp NEG - temp 1 ADD - ! make dst signed - temp dst IMUL2 - "end" resolve-label - ] with-scope ; - -M: x86 %add-float nip ADDSD ; -M: x86 %sub-float nip SUBSD ; -M: x86 %mul-float nip MULSD ; -M: x86 %div-float nip DIVSD ; -M: x86 %min-float nip MINSD ; -M: x86 %max-float nip MAXSD ; -M: x86 %sqrt SQRTSD ; - -M: x86 %single>double-float CVTSS2SD ; -M: x86 %double>single-float CVTSD2SS ; - -M: x86 %integer>float CVTSI2SD ; -M: x86 %float>integer CVTTSD2SI ; - -M: x86 %unbox-float ( dst src -- ) - float-offset [+] MOVSD ; - -M:: x86 %box-float ( dst src temp -- ) - dst 16 float temp %allot - dst float-offset [+] src MOVSD ; - -M:: x86 %box-vector ( dst src rep temp -- ) - dst rep rep-size 2 cells + byte-array temp %allot - 16 tag-fixnum dst 1 byte-array tag-number %set-slot-imm - dst byte-array-offset [+] - src rep copy-register ; - -M:: x86 %unbox-vector ( dst src rep -- ) - dst src byte-array-offset [+] - rep copy-register ; - -M: x86 %broadcast-vector ( dst src rep -- ) - { - { float-4-rep [ [ MOVSS ] [ drop dup 0 SHUFPS ] 2bi ] } - { double-2-rep [ [ MOVSD ] [ drop dup UNPCKLPD ] 2bi ] } - } case ; - -M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- ) - rep { - { - float-4-rep - [ - dst src1 MOVSS - dst src2 UNPCKLPS - src3 src4 UNPCKLPS - dst src3 MOVLHPS - ] - } - } case ; - -M:: x86 %gather-vector-2 ( dst src1 src2 rep -- ) - rep { - { - double-2-rep - [ - dst src1 MOVSD - dst src2 UNPCKLPD - ] - } - } case ; - -M: x86 %add-vector ( dst src1 src2 rep -- ) - { - { float-4-rep [ ADDPS ] } - { double-2-rep [ ADDPD ] } - { char-16-rep [ PADDB ] } - { uchar-16-rep [ PADDB ] } - { short-8-rep [ PADDW ] } - { ushort-8-rep [ PADDW ] } - { int-4-rep [ PADDD ] } - { uint-4-rep [ PADDD ] } - } case drop ; - -M: x86 %sub-vector ( dst src1 src2 rep -- ) - { - { float-4-rep [ SUBPS ] } - { double-2-rep [ SUBPD ] } - { char-16-rep [ PSUBB ] } - { uchar-16-rep [ PSUBB ] } - { short-8-rep [ PSUBW ] } - { ushort-8-rep [ PSUBW ] } - { int-4-rep [ PSUBD ] } - { uint-4-rep [ PSUBD ] } - } case drop ; - -M: x86 %mul-vector ( dst src1 src2 rep -- ) - { - { float-4-rep [ MULPS ] } - { double-2-rep [ MULPD ] } - { int-4-rep [ PMULLW ] } - } case drop ; - -M: x86 %div-vector ( dst src1 src2 rep -- ) - { - { float-4-rep [ DIVPS ] } - { double-2-rep [ DIVPD ] } - } case drop ; - -M: x86 %min-vector ( dst src1 src2 rep -- ) - { - { float-4-rep [ MINPS ] } - { double-2-rep [ MINPD ] } - } case drop ; - -M: x86 %max-vector ( dst src1 src2 rep -- ) - { - { float-4-rep [ MAXPS ] } - { double-2-rep [ MAXPD ] } - } case drop ; - -M: x86 %sqrt-vector ( dst src rep -- ) - { - { float-4-rep [ SQRTPS ] } - { double-2-rep [ SQRTPD ] } - } case ; - -M: x86 %horizontal-add-vector ( dst src rep -- ) - { - { float-4-rep [ [ MOVAPS ] [ HADDPS ] [ HADDPS ] 2tri ] } - { double-2-rep [ [ MOVAPD ] [ HADDPD ] 2bi ] } - } case ; + int-rep two-operand swap IMUL2 JO ; M: x86 %unbox-alien ( dst src -- ) alien-offset [+] MOV ; @@ -452,9 +270,6 @@ M: x86.64 has-small-reg? 2drop t ; [ quot call ] with-save/restore ] if ; inline -: ?MOV ( dst src -- ) - 2dup = [ 2drop ] [ MOV ] if ; inline - M:: x86 %string-nth ( dst src index temp -- ) ! We request a small-reg of size 8 since those of size 16 are ! a superset. @@ -482,77 +297,77 @@ M:: x86 %string-nth ( dst src index temp -- ) ! Compute code point new-dst temp XOR "end" resolve-label - dst new-dst ?MOV + dst new-dst int-rep %copy ] with-small-register ; M:: x86 %set-string-nth-fast ( ch str index temp -- ) ch { index str temp } 8 [| new-ch | - new-ch ch ?MOV + new-ch ch int-rep %copy temp str index [+] LEA temp string-offset [+] new-ch 8-bit-version-of MOV ] with-small-register ; -:: %alien-integer-getter ( dst src size quot -- ) +:: %alien-integer-getter ( dst src offset size quot -- ) dst { src } size [| new-dst | - new-dst dup size n-bit-version-of dup src [] MOV + new-dst dup size n-bit-version-of dup src offset [+] MOV quot call - dst new-dst ?MOV + dst new-dst int-rep %copy ] with-small-register ; inline -: %alien-unsigned-getter ( dst src size -- ) +: %alien-unsigned-getter ( dst src offset size -- ) [ MOVZX ] %alien-integer-getter ; inline +: %alien-signed-getter ( dst src offset size -- ) + [ MOVSX ] %alien-integer-getter ; inline + +:: %alien-integer-setter ( ptr offset value size -- ) + value { ptr } size [| new-value | + new-value value int-rep %copy + ptr offset [+] new-value size n-bit-version-of MOV + ] with-small-register ; inline + M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ; M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ; M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ; -: %alien-signed-getter ( dst src size -- ) - [ MOVSX ] %alien-integer-getter ; inline - M: x86 %alien-signed-1 8 %alien-signed-getter ; M: x86 %alien-signed-2 16 %alien-signed-getter ; M: x86 %alien-signed-4 32 %alien-signed-getter ; -M: x86 %alien-cell [] MOV ; -M: x86 %alien-float [] MOVSS ; -M: x86 %alien-double [] MOVSD ; -M: x86 %alien-vector [ [] ] dip copy-register ; - -:: %alien-integer-setter ( ptr value size -- ) - value { ptr } size [| new-value | - new-value value ?MOV - ptr [] new-value size n-bit-version-of MOV - ] with-small-register ; inline +M: x86 %alien-cell [+] MOV ; +M: x86 %alien-float [+] MOVSS ; +M: x86 %alien-double [+] MOVSD ; +M: x86 %alien-vector [ [+] ] dip %copy ; M: x86 %set-alien-integer-1 8 %alien-integer-setter ; M: x86 %set-alien-integer-2 16 %alien-integer-setter ; M: x86 %set-alien-integer-4 32 %alien-integer-setter ; -M: x86 %set-alien-cell [ [] ] dip MOV ; -M: x86 %set-alien-float [ [] ] dip MOVSS ; -M: x86 %set-alien-double [ [] ] dip MOVSD ; -M: x86 %set-alien-vector [ [] ] 2dip copy-register ; +M: x86 %set-alien-cell [ [+] ] dip MOV ; +M: x86 %set-alien-float [ [+] ] dip MOVSS ; +M: x86 %set-alien-double [ [+] ] dip MOVSD ; +M: x86 %set-alien-vector [ [+] ] 2dip %copy ; : shift-count? ( reg -- ? ) { ECX RCX } memq? ; -:: emit-shift ( dst src1 src2 quot -- ) - src2 shift-count? [ +:: emit-shift ( dst src quot -- ) + src shift-count? [ dst CL quot call ] [ dst shift-count? [ - dst src2 XCHG - src2 CL quot call - dst src2 XCHG + dst src XCHG + src CL quot call + dst src XCHG ] [ ECX native-version-of [ - CL src2 MOV + CL src MOV drop dst CL quot call ] with-save/restore ] if ] if ; inline -M: x86 %shl [ SHL ] emit-shift ; -M: x86 %shr [ SHR ] emit-shift ; -M: x86 %sar [ SAR ] emit-shift ; +M: x86 %shl int-rep two-operand [ SHL ] emit-shift ; +M: x86 %shr int-rep two-operand [ SHR ] emit-shift ; +M: x86 %sar int-rep two-operand [ SAR ] emit-shift ; M: x86 %vm-field-ptr ( dst field -- ) [ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ] @@ -580,7 +395,6 @@ M:: x86 %allot ( dst size class nursery-ptr -- ) dst class store-tagged nursery-ptr size inc-allot-ptr ; - M:: x86 %write-barrier ( src card# table -- ) #! Mark the card pointed to by vreg. ! Mark the card @@ -596,10 +410,10 @@ M:: x86 %write-barrier ( src card# table -- ) table table [] MOV table card# [+] card-mark MOV ; -M:: x86 %check-nursery ( label temp1 temp2 -- ) +M:: x86 %check-nursery ( label size temp1 temp2 -- ) temp1 load-zone-ptr temp2 temp1 cell [+] MOV - temp2 1024 ADD + temp2 size ADD temp1 temp1 3 cells [+] MOV temp2 temp1 CMP label JLE ; @@ -608,14 +422,6 @@ M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ; M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ; -M:: x86 %call-gc ( gc-root-count -- ) - ! Pass pointer to start of GC roots as first parameter - param-reg-1 gc-root-base param@ LEA - ! Pass number of roots as second parameter - param-reg-2 gc-root-count MOV - ! Call GC - "inline_gc" %vm-invoke-3rd-arg ; - M: x86 %alien-global ( dst symbol library -- ) [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; @@ -626,8 +432,13 @@ M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; temp 0 MOV \ t rc-absolute-cell rel-immediate dst temp word execute ; inline +: (%compare) ( src1 src2 cc -- ) + 2over [ { cc= cc/= } member? ] [ register? ] [ 0 = ] tri* and and + [ drop dup TEST ] + [ CMP ] if ; + M:: x86 %compare ( dst src1 src2 cc temp -- ) - src1 src2 CMP + src1 src2 cc (%compare) cc order-cc { { cc< [ dst temp \ CMOVL %boolean ] } { cc<= [ dst temp \ CMOVLE %boolean ] } @@ -640,6 +451,34 @@ M:: x86 %compare ( dst src1 src2 cc temp -- ) M: x86 %compare-imm ( dst src1 src2 cc temp -- ) %compare ; +M:: x86 %compare-branch ( label src1 src2 cc -- ) + src1 src2 cc (%compare) + cc order-cc { + { cc< [ label JL ] } + { cc<= [ label JLE ] } + { cc> [ label JG ] } + { cc>= [ label JGE ] } + { cc= [ label JE ] } + { cc/= [ label JNE ] } + } case ; + +M: x86 %compare-imm-branch ( label src1 src2 cc -- ) + %compare-branch ; + +M: x86 %add-float double-rep two-operand ADDSD ; +M: x86 %sub-float double-rep two-operand SUBSD ; +M: x86 %mul-float double-rep two-operand MULSD ; +M: x86 %div-float double-rep two-operand DIVSD ; +M: x86 %min-float double-rep two-operand MINSD ; +M: x86 %max-float double-rep two-operand MAXSD ; +M: x86 %sqrt SQRTSD ; + +M: x86 %single>double-float CVTSS2SD ; +M: x86 %double>single-float CVTSD2SS ; + +M: x86 %integer>float CVTSI2SD ; +M: x86 %float>integer CVTTSD2SI ; + : %cmov-float= ( dst src -- ) [ "no-move" define-label @@ -685,20 +524,6 @@ M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- ) M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- ) \ UCOMISD (%compare-float) ; -M:: x86 %compare-branch ( label src1 src2 cc -- ) - src1 src2 CMP - cc order-cc { - { cc< [ label JL ] } - { cc<= [ label JLE ] } - { cc> [ label JG ] } - { cc>= [ label JGE ] } - { cc= [ label JE ] } - { cc/= [ label JNE ] } - } case ; - -M: x86 %compare-imm-branch ( label src1 src2 cc -- ) - %compare-branch ; - : %jump-float= ( label -- ) [ "no-jump" define-label @@ -734,11 +559,767 @@ M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- ) M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- ) \ UCOMISD (%compare-float-branch) ; -M:: x86 %spill ( src rep n -- ) - n spill@ src rep copy-register ; +MACRO: available-reps ( alist -- ) + ! Each SSE version adds new representations and supports + ! all old ones + unzip { } [ append ] accumulate rest swap suffix + [ [ 1quotation ] map ] bi@ zip + reverse [ { } ] suffix + '[ _ cond ] ; -M:: x86 %reload ( dst rep n -- ) - dst n spill@ rep copy-register ; +M: x86 %alien-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %zero-vector + { + { double-2-rep [ dup XORPD ] } + { float-4-rep [ dup XORPS ] } + [ drop dup PXOR ] + } case ; + +M: x86 %zero-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %fill-vector + { + { double-2-rep [ dup [ XORPD ] [ CMPEQPD ] 2bi ] } + { float-4-rep [ dup [ XORPS ] [ CMPEQPS ] 2bi ] } + [ drop dup PCMPEQB ] + } case ; + +M: x86 %fill-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +! M:: x86 %broadcast-vector ( dst src rep -- ) +! rep unsign-rep { +! { float-4-rep [ +! dst src float-4-rep %copy +! dst dst { 0 0 0 0 } SHUFPS +! ] } +! { double-2-rep [ +! dst src MOVDDUP +! ] } +! { longlong-2-rep [ +! dst src = +! [ dst dst PUNPCKLQDQ ] +! [ dst src { 0 1 0 1 } PSHUFD ] +! if +! ] } +! { int-4-rep [ +! dst src { 0 0 0 0 } PSHUFD +! ] } +! { short-8-rep [ +! dst src { 0 0 0 0 } PSHUFLW +! dst dst PUNPCKLQDQ +! ] } +! { char-16-rep [ +! dst src char-16-rep %copy +! dst dst PUNPCKLBW +! dst dst { 0 0 0 0 } PSHUFLW +! dst dst PUNPCKLQDQ +! ] } +! } case ; +! +! M: x86 %broadcast-vector-reps +! { +! ! Can't do this with sse1 since it will want to unbox +! ! a double-precision float and convert to single precision +! { sse2? { float-4-rep double-2-rep longlong-2-rep ulonglong-2-rep int-4-rep uint-4-rep short-8-rep ushort-8-rep char-16-rep uchar-16-rep } } +! } available-reps ; + +M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- ) + rep unsign-rep { + { float-4-rep [ + dst src1 float-4-rep %copy + dst src2 UNPCKLPS + src3 src4 UNPCKLPS + dst src3 MOVLHPS + ] } + { int-4-rep [ + dst src1 int-4-rep %copy + dst src2 PUNPCKLDQ + src3 src4 PUNPCKLDQ + dst src3 PUNPCKLQDQ + ] } + } case ; + +M: x86 %gather-vector-4-reps + { + ! Can't do this with sse1 since it will want to unbox + ! double-precision floats and convert to single precision + { sse2? { float-4-rep int-4-rep uint-4-rep } } + } available-reps ; + +M:: x86 %gather-vector-2 ( dst src1 src2 rep -- ) + rep unsign-rep { + { double-2-rep [ + dst src1 double-2-rep %copy + dst src2 UNPCKLPD + ] } + { longlong-2-rep [ + dst src1 longlong-2-rep %copy + dst src2 PUNPCKLQDQ + ] } + } case ; + +M: x86 %gather-vector-2-reps + { + { sse2? { double-2-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +: double-2-shuffle ( dst shuffle -- ) + { + { { 0 1 } [ drop ] } + { { 0 0 } [ dup UNPCKLPD ] } + { { 1 1 } [ dup UNPCKHPD ] } + [ dupd SHUFPD ] + } case ; + +: sse1-float-4-shuffle ( dst shuffle -- ) + { + { { 0 1 2 3 } [ drop ] } + { { 0 1 0 1 } [ dup MOVLHPS ] } + { { 2 3 2 3 } [ dup MOVHLPS ] } + { { 0 0 1 1 } [ dup UNPCKLPS ] } + { { 2 2 3 3 } [ dup UNPCKHPS ] } + [ dupd SHUFPS ] + } case ; + +: float-4-shuffle ( dst shuffle -- ) + sse3? [ + { + { { 0 0 2 2 } [ dup MOVSLDUP ] } + { { 1 1 3 3 } [ dup MOVSHDUP ] } + [ sse1-float-4-shuffle ] + } case + ] [ sse1-float-4-shuffle ] if ; + +: int-4-shuffle ( dst shuffle -- ) + { + { { 0 1 2 3 } [ drop ] } + { { 0 0 1 1 } [ dup PUNPCKLDQ ] } + { { 2 2 3 3 } [ dup PUNPCKHDQ ] } + { { 0 1 0 1 } [ dup PUNPCKLQDQ ] } + { { 2 3 2 3 } [ dup PUNPCKHQDQ ] } + [ dupd PSHUFD ] + } case ; + +: longlong-2-shuffle ( dst shuffle -- ) + first2 [ 2 * dup 1 + ] bi@ 4array int-4-shuffle ; + +M:: x86 %shuffle-vector-imm ( dst src shuffle rep -- ) + dst src rep %copy + dst shuffle rep unsign-rep { + { double-2-rep [ double-2-shuffle ] } + { float-4-rep [ float-4-shuffle ] } + { int-4-rep [ int-4-shuffle ] } + { longlong-2-rep [ longlong-2-shuffle ] } + } case ; + +M: x86 %shuffle-vector-imm-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %shuffle-vector ( dst src shuffle rep -- ) + two-operand PSHUFB ; + +M: x86 %shuffle-vector-reps + { + { ssse3? { float-4-rep double-2-rep longlong-2-rep ulonglong-2-rep int-4-rep uint-4-rep short-8-rep ushort-8-rep char-16-rep uchar-16-rep } } + } available-reps ; + +M: x86 %merge-vector-head + [ two-operand ] keep + unsign-rep { + { double-2-rep [ UNPCKLPD ] } + { float-4-rep [ UNPCKLPS ] } + { longlong-2-rep [ PUNPCKLQDQ ] } + { int-4-rep [ PUNPCKLDQ ] } + { short-8-rep [ PUNPCKLWD ] } + { char-16-rep [ PUNPCKLBW ] } + } case ; + +M: x86 %merge-vector-tail + [ two-operand ] keep + unsign-rep { + { double-2-rep [ UNPCKHPD ] } + { float-4-rep [ UNPCKHPS ] } + { longlong-2-rep [ PUNPCKHQDQ ] } + { int-4-rep [ PUNPCKHDQ ] } + { short-8-rep [ PUNPCKHWD ] } + { char-16-rep [ PUNPCKHBW ] } + } case ; + +M: x86 %merge-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %signed-pack-vector + [ two-operand ] keep + { + { int-4-rep [ PACKSSDW ] } + { short-8-rep [ PACKSSWB ] } + } case ; + +M: x86 %signed-pack-vector-reps + { + { sse2? { short-8-rep int-4-rep } } + } available-reps ; + +M: x86 %unsigned-pack-vector + [ two-operand ] keep + unsign-rep { + { int-4-rep [ PACKUSDW ] } + { short-8-rep [ PACKUSWB ] } + } case ; + +M: x86 %unsigned-pack-vector-reps + { + { sse2? { short-8-rep } } + { sse4.1? { int-4-rep } } + } available-reps ; + +M: x86 %tail>head-vector ( dst src rep -- ) + dup { + { float-4-rep [ drop MOVHLPS ] } + { double-2-rep [ [ %copy ] [ drop UNPCKHPD ] 3bi ] } + [ drop [ %copy ] [ drop PUNPCKHQDQ ] 3bi ] + } case ; + +M: x86 %unpack-vector-head ( dst src rep -- ) + { + { char-16-rep [ PMOVSXBW ] } + { uchar-16-rep [ PMOVZXBW ] } + { short-8-rep [ PMOVSXWD ] } + { ushort-8-rep [ PMOVZXWD ] } + { int-4-rep [ PMOVSXDQ ] } + { uint-4-rep [ PMOVZXDQ ] } + { float-4-rep [ CVTPS2PD ] } + } case ; + +M: x86 %unpack-vector-head-reps ( -- reps ) + { + { sse2? { float-4-rep } } + { sse4.1? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } } + } available-reps ; + +M: x86 %integer>float-vector ( dst src rep -- ) + { + { int-4-rep [ CVTDQ2PS ] } + } case ; + +M: x86 %integer>float-vector-reps + { + { sse2? { int-4-rep } } + } available-reps ; + +M: x86 %float>integer-vector ( dst src rep -- ) + { + { float-4-rep [ CVTTPS2DQ ] } + } case ; + +M: x86 %float>integer-vector-reps + { + { sse2? { float-4-rep } } + } available-reps ; + +: (%compare-float-vector) ( dst src rep double single -- ) + [ double-2-rep eq? ] 2dip if ; inline +: %compare-float-vector ( dst src rep cc -- ) + { + { cc< [ [ CMPLTPD ] [ CMPLTPS ] (%compare-float-vector) ] } + { cc<= [ [ CMPLEPD ] [ CMPLEPS ] (%compare-float-vector) ] } + { cc= [ [ CMPEQPD ] [ CMPEQPS ] (%compare-float-vector) ] } + { cc<>= [ [ CMPORDPD ] [ CMPORDPS ] (%compare-float-vector) ] } + { cc/< [ [ CMPNLTPD ] [ CMPNLTPS ] (%compare-float-vector) ] } + { cc/<= [ [ CMPNLEPD ] [ CMPNLEPS ] (%compare-float-vector) ] } + { cc/= [ [ CMPNEQPD ] [ CMPNEQPS ] (%compare-float-vector) ] } + { cc/<>= [ [ CMPUNORDPD ] [ CMPUNORDPS ] (%compare-float-vector) ] } + } case ; + +:: (%compare-int-vector) ( dst src rep int64 int32 int16 int8 -- ) + rep unsign-rep :> rep' + dst src rep' { + { longlong-2-rep [ int64 call ] } + { int-4-rep [ int32 call ] } + { short-8-rep [ int16 call ] } + { char-16-rep [ int8 call ] } + } case ; inline +: %compare-int-vector ( dst src rep cc -- ) + { + { cc= [ [ PCMPEQQ ] [ PCMPEQD ] [ PCMPEQW ] [ PCMPEQB ] (%compare-int-vector) ] } + { cc> [ [ PCMPGTQ ] [ PCMPGTD ] [ PCMPGTW ] [ PCMPGTB ] (%compare-int-vector) ] } + } case ; + +M: x86 %compare-vector ( dst src1 src2 rep cc -- ) + [ [ two-operand ] keep ] dip + over float-vector-rep? + [ %compare-float-vector ] + [ %compare-int-vector ] if ; + +: %compare-vector-eq-reps ( -- reps ) + { + { sse? { float-4-rep } } + { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } } + { sse4.1? { longlong-2-rep ulonglong-2-rep } } + } available-reps ; +: %compare-vector-ord-reps ( -- reps ) + { + { sse? { float-4-rep } } + { sse2? { double-2-rep char-16-rep short-8-rep int-4-rep } } + { sse4.1? { longlong-2-rep } } + } available-reps ; + +M: x86 %compare-vector-reps + { + { [ dup { cc= cc/= } memq? ] [ drop %compare-vector-eq-reps ] } + [ drop %compare-vector-ord-reps ] + } cond ; + +: %compare-float-vector-ccs ( cc -- ccs not? ) + { + { cc< [ { { cc< f } } f ] } + { cc<= [ { { cc<= f } } f ] } + { cc> [ { { cc< t } } f ] } + { cc>= [ { { cc<= t } } f ] } + { cc= [ { { cc= f } } f ] } + { cc<> [ { { cc< f } { cc< t } } f ] } + { cc<>= [ { { cc<>= f } } f ] } + { cc/< [ { { cc/< f } } f ] } + { cc/<= [ { { cc/<= f } } f ] } + { cc/> [ { { cc/< t } } f ] } + { cc/>= [ { { cc/<= t } } f ] } + { cc/= [ { { cc/= f } } f ] } + { cc/<> [ { { cc/= f } { cc/<>= f } } f ] } + { cc/<>= [ { { cc/<>= f } } f ] } + } case ; + +: %compare-int-vector-ccs ( cc -- ccs not? ) + order-cc { + { cc< [ { { cc> t } } f ] } + { cc<= [ { { cc> f } } t ] } + { cc> [ { { cc> f } } f ] } + { cc>= [ { { cc> t } } t ] } + { cc= [ { { cc= f } } f ] } + { cc/= [ { { cc= f } } t ] } + { t [ { } t ] } + { f [ { } f ] } + } case ; + +M: x86 %compare-vector-ccs + swap float-vector-rep? + [ %compare-float-vector-ccs ] + [ %compare-int-vector-ccs ] if ; + +:: %test-vector-mask ( dst temp mask vcc -- ) + vcc { + { vcc-any [ dst dst TEST dst temp \ CMOVNE %boolean ] } + { vcc-none [ dst dst TEST dst temp \ CMOVE %boolean ] } + { vcc-all [ dst mask CMP dst temp \ CMOVE %boolean ] } + { vcc-notall [ dst mask CMP dst temp \ CMOVNE %boolean ] } + } case ; + +: %move-vector-mask ( dst src rep -- mask ) + { + { double-2-rep [ MOVMSKPD HEX: 3 ] } + { float-4-rep [ MOVMSKPS HEX: f ] } + [ drop PMOVMSKB HEX: ffff ] + } case ; + +M:: x86 %test-vector ( dst src temp rep vcc -- ) + dst src rep %move-vector-mask :> mask + dst temp mask vcc %test-vector-mask ; + +:: %test-vector-mask-branch ( label temp mask vcc -- ) + vcc { + { vcc-any [ temp temp TEST label JNE ] } + { vcc-none [ temp temp TEST label JE ] } + { vcc-all [ temp mask CMP label JE ] } + { vcc-notall [ temp mask CMP label JNE ] } + } case ; + +M:: x86 %test-vector-branch ( label src temp rep vcc -- ) + temp src rep %move-vector-mask :> mask + label temp mask vcc %test-vector-mask-branch ; + +M: x86 %test-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %add-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { float-4-rep [ ADDPS ] } + { double-2-rep [ ADDPD ] } + { char-16-rep [ PADDB ] } + { uchar-16-rep [ PADDB ] } + { short-8-rep [ PADDW ] } + { ushort-8-rep [ PADDW ] } + { int-4-rep [ PADDD ] } + { uint-4-rep [ PADDD ] } + { longlong-2-rep [ PADDQ ] } + { ulonglong-2-rep [ PADDQ ] } + } case ; + +M: x86 %add-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %saturated-add-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { char-16-rep [ PADDSB ] } + { uchar-16-rep [ PADDUSB ] } + { short-8-rep [ PADDSW ] } + { ushort-8-rep [ PADDUSW ] } + } case ; + +M: x86 %saturated-add-vector-reps + { + { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } } + } available-reps ; + +M: x86 %add-sub-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { float-4-rep [ ADDSUBPS ] } + { double-2-rep [ ADDSUBPD ] } + } case ; + +M: x86 %add-sub-vector-reps + { + { sse3? { float-4-rep double-2-rep } } + } available-reps ; + +M: x86 %sub-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { float-4-rep [ SUBPS ] } + { double-2-rep [ SUBPD ] } + { char-16-rep [ PSUBB ] } + { uchar-16-rep [ PSUBB ] } + { short-8-rep [ PSUBW ] } + { ushort-8-rep [ PSUBW ] } + { int-4-rep [ PSUBD ] } + { uint-4-rep [ PSUBD ] } + { longlong-2-rep [ PSUBQ ] } + { ulonglong-2-rep [ PSUBQ ] } + } case ; + +M: x86 %sub-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %saturated-sub-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { char-16-rep [ PSUBSB ] } + { uchar-16-rep [ PSUBUSB ] } + { short-8-rep [ PSUBSW ] } + { ushort-8-rep [ PSUBUSW ] } + } case ; + +M: x86 %saturated-sub-vector-reps + { + { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } } + } available-reps ; + +M: x86 %mul-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { float-4-rep [ MULPS ] } + { double-2-rep [ MULPD ] } + { short-8-rep [ PMULLW ] } + { ushort-8-rep [ PMULLW ] } + { int-4-rep [ PMULLD ] } + { uint-4-rep [ PMULLD ] } + } case ; + +M: x86 %mul-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep short-8-rep ushort-8-rep } } + { sse4.1? { int-4-rep uint-4-rep } } + } available-reps ; + +M: x86 %div-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { float-4-rep [ DIVPS ] } + { double-2-rep [ DIVPD ] } + } case ; + +M: x86 %div-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep } } + } available-reps ; + +M: x86 %min-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { char-16-rep [ PMINSB ] } + { uchar-16-rep [ PMINUB ] } + { short-8-rep [ PMINSW ] } + { ushort-8-rep [ PMINUW ] } + { int-4-rep [ PMINSD ] } + { uint-4-rep [ PMINUD ] } + { float-4-rep [ MINPS ] } + { double-2-rep [ MINPD ] } + } case ; + +M: x86 %min-vector-reps + { + { sse? { float-4-rep } } + { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } } + { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } } + } available-reps ; + +M: x86 %max-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { char-16-rep [ PMAXSB ] } + { uchar-16-rep [ PMAXUB ] } + { short-8-rep [ PMAXSW ] } + { ushort-8-rep [ PMAXUW ] } + { int-4-rep [ PMAXSD ] } + { uint-4-rep [ PMAXUD ] } + { float-4-rep [ MAXPS ] } + { double-2-rep [ MAXPD ] } + } case ; + +M: x86 %max-vector-reps + { + { sse? { float-4-rep } } + { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } } + { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } } + } available-reps ; + +M: x86 %dot-vector + [ two-operand ] keep + { + { float-4-rep [ + sse4.1? + [ HEX: ff DPPS ] + [ [ MULPS ] [ drop dup float-4-rep %horizontal-add-vector ] 2bi ] + if + ] } + { double-2-rep [ + sse4.1? + [ HEX: ff DPPD ] + [ [ MULPD ] [ drop dup double-2-rep %horizontal-add-vector ] 2bi ] + if + ] } + } case ; + +M: x86 %dot-vector-reps + { + { sse3? { float-4-rep double-2-rep } } + } available-reps ; + +M: x86 %horizontal-add-vector ( dst src rep -- ) + { + { float-4-rep [ [ float-4-rep %copy ] [ HADDPS ] [ HADDPS ] 2tri ] } + { double-2-rep [ [ double-2-rep %copy ] [ HADDPD ] 2bi ] } + } case ; + +M: x86 %horizontal-add-vector-reps + { + { sse3? { float-4-rep double-2-rep } } + } available-reps ; + +M: x86 %horizontal-shl-vector ( dst src1 src2 rep -- ) + two-operand PSLLDQ ; + +M: x86 %horizontal-shl-vector-reps + { + { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %horizontal-shr-vector ( dst src1 src2 rep -- ) + two-operand PSRLDQ ; + +M: x86 %horizontal-shr-vector-reps + { + { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %abs-vector ( dst src rep -- ) + { + { char-16-rep [ PABSB ] } + { short-8-rep [ PABSW ] } + { int-4-rep [ PABSD ] } + } case ; + +M: x86 %abs-vector-reps + { + { ssse3? { char-16-rep short-8-rep int-4-rep } } + } available-reps ; + +M: x86 %sqrt-vector ( dst src rep -- ) + { + { float-4-rep [ SQRTPS ] } + { double-2-rep [ SQRTPD ] } + } case ; + +M: x86 %sqrt-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep } } + } available-reps ; + +M: x86 %and-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { float-4-rep [ ANDPS ] } + { double-2-rep [ ANDPD ] } + [ drop PAND ] + } case ; + +M: x86 %and-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %andn-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { float-4-rep [ ANDNPS ] } + { double-2-rep [ ANDNPD ] } + [ drop PANDN ] + } case ; + +M: x86 %andn-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %or-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { float-4-rep [ ORPS ] } + { double-2-rep [ ORPD ] } + [ drop POR ] + } case ; + +M: x86 %or-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %xor-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { float-4-rep [ XORPS ] } + { double-2-rep [ XORPD ] } + [ drop PXOR ] + } case ; + +M: x86 %xor-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %shl-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { short-8-rep [ PSLLW ] } + { ushort-8-rep [ PSLLW ] } + { int-4-rep [ PSLLD ] } + { uint-4-rep [ PSLLD ] } + { longlong-2-rep [ PSLLQ ] } + { ulonglong-2-rep [ PSLLQ ] } + } case ; + +M: x86 %shl-vector-reps + { + { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %shr-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + { + { short-8-rep [ PSRAW ] } + { ushort-8-rep [ PSRLW ] } + { int-4-rep [ PSRAD ] } + { uint-4-rep [ PSRLD ] } + { ulonglong-2-rep [ PSRLQ ] } + } case ; + +M: x86 %shr-vector-reps + { + { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep ulonglong-2-rep } } + } available-reps ; + +: scalar-sized-reg ( reg rep -- reg' ) + rep-size 8 * n-bit-version-of ; + +M: x86 %integer>scalar drop MOVD ; + +M:: x86 %scalar>integer ( dst src rep -- ) + rep { + { int-scalar-rep [ + dst 32-bit-version-of src MOVD + dst dst 32-bit-version-of + 2dup eq? [ 2drop ] [ MOVSX ] if + ] } + { uint-scalar-rep [ + dst 32-bit-version-of src MOVD + ] } + { short-scalar-rep [ + dst 32-bit-version-of src MOVD + dst dst 16-bit-version-of MOVSX + ] } + { ushort-scalar-rep [ + dst 32-bit-version-of src MOVD + dst dst 16-bit-version-of MOVZX + ] } + { char-scalar-rep [ + dst 32-bit-version-of src MOVD + dst { } 8 [| tmp-dst | + tmp-dst dst int-rep %copy + tmp-dst tmp-dst 8-bit-version-of MOVSX + dst tmp-dst int-rep %copy + ] with-small-register + ] } + { uchar-scalar-rep [ + dst 32-bit-version-of src MOVD + dst { } 8 [| tmp-dst | + tmp-dst dst int-rep %copy + tmp-dst tmp-dst 8-bit-version-of MOVZX + dst tmp-dst int-rep %copy + ] with-small-register + ] } + } case ; + +M: x86 %vector>scalar %copy ; +M: x86 %scalar>vector %copy ; + +M:: x86 %spill ( src rep dst -- ) dst src rep %copy ; +M:: x86 %reload ( dst rep src -- ) dst src rep %copy ; M: x86 %loop-entry 16 code-alignment [ NOP ] times ; @@ -767,15 +1348,30 @@ M: x86 small-enough? ( n -- ? ) #! set up by the caller. stack-frame get total-size>> + stack@ ; -: enable-sse2 ( -- ) - enable-float-intrinsics - enable-fsqrt - enable-float-min/max - enable-sse2-simd ; +enable-simd +enable-min/max +enable-fixnum-log2 -: enable-sse3 ( -- ) - enable-sse2 - enable-sse3-simd ; +:: install-sse2-check ( -- ) + [ + sse-version 20 < [ + "This image was built to use SSE2 but your CPU does not support it." print + "You will need to bootstrap Factor again." print + flush + 1 exit + ] when + ] "cpu.x86" add-init-hook ; + +: enable-sse2 ( version -- ) + 20 >= [ + enable-float-intrinsics + enable-float-functions + enable-float-min/max + enable-fsqrt + install-sse2-check + ] when ; -enable-min/max -enable-fixnum-log2 \ No newline at end of file +: check-sse ( -- ) + [ { sse_version } compile ] with-optimizer + "Checking for multimedia extensions: " write sse-version + [ sse-string write " detected" print ] [ enable-sse2 ] bi ; diff --git a/basis/csv/csv-docs.factor b/basis/csv/csv-docs.factor index 6ae75b6b2f..1f05ab639b 100644 --- a/basis/csv/csv-docs.factor +++ b/basis/csv/csv-docs.factor @@ -39,14 +39,14 @@ HELP: with-delimiter ARTICLE: "csv" "Comma-separated-values parsing and writing" "The " { $vocab-link "csv" } " vocabulary can read and write CSV (comma-separated-value) files." $nl "Reading a csv file:" -{ $subsection file>csv } +{ $subsections file>csv } "Writing a csv file:" -{ $subsection csv>file } +{ $subsections csv>file } "Changing the delimiter from a comma:" -{ $subsection with-delimiter } +{ $subsections with-delimiter } "Reading from a stream:" -{ $subsection csv } +{ $subsections csv } "Writing to a stream:" -{ $subsection write-csv } ; +{ $subsections write-csv } ; ABOUT: "csv" diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index e73783fdfc..13af6d1090 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: classes kernel help.markup help.syntax sequences -alien assocs strings math multiline quotations db.private ; +alien assocs strings math quotations db.private ; IN: db HELP: db-connection @@ -31,8 +31,10 @@ HELP: statement HELP: result-set { $description "An object encapsulating a raw SQL result object. There are two ways in which a result set can be accessed, but they are specific to the database backend in use." - { $subsection "db-random-access-result-set" } - { $subsection "db-sequential-result-set" } +{ $subsections + "db-random-access-result-set" + "db-sequential-result-set" +} } ; HELP: new-result-set @@ -177,14 +179,16 @@ HELP: with-transaction ARTICLE: "db" "Database library" "Accessing a database:" -{ $subsection "db-custom-database-combinators" } +{ $subsections "db-custom-database-combinators" } "Higher-level database help:" { $vocab-subsection "Database types" "db.types" } { $vocab-subsection "High-level tuple/database integration" "db.tuples" } "Low-level database help:" -{ $subsection "db-protocol" } -{ $subsection "db-result-sets" } -{ $subsection "db-lowlevel-tutorial" } +{ $subsections + "db-protocol" + "db-result-sets" + "db-lowlevel-tutorial" +} "Supported database backends:" { $vocab-subsection "SQLite" "db.sqlite" } { $vocab-subsection "PostgreSQL" "db.postgresql" } ; @@ -193,82 +197,98 @@ ARTICLE: "db-random-access-result-set" "Random access result sets" "Random-access result sets do not have to be traversed in order. For instance, PostgreSQL's result set object can be accessed as a matrix with i,j coordinates." $nl "Databases which work in this way must provide methods for the following traversal words:" -{ $subsection #rows } -{ $subsection #columns } -{ $subsection row-column } -{ $subsection row-column-typed } ; +{ $subsections + #rows + #columns + row-column + row-column-typed +} ; ARTICLE: "db-sequential-result-set" "Sequential result sets" "Sequential result sets can be iterated one element after the next. SQLite's result sets offer this method of traversal." $nl "Databases which work in this way must provide methods for the following traversal words:" -{ $subsection more-rows? } -{ $subsection advance-row } -{ $subsection row-column } -{ $subsection row-column-typed } ; +{ $subsections + more-rows? + advance-row + row-column + row-column-typed +} ; ARTICLE: "db-result-sets" "Result sets" "Result sets are the encapsulated, database-specific results from a SQL query." $nl "Two possible protocols for iterating over result sets exist:" -{ $subsection "db-random-access-result-set" } -{ $subsection "db-sequential-result-set" } +{ $subsections + "db-random-access-result-set" + "db-sequential-result-set" +} "Query the number of rows or columns:" -{ $subsection #rows } -{ $subsection #columns } +{ $subsections + #rows + #columns +} "Traversing a result set:" -{ $subsection advance-row } -{ $subsection more-rows? } +{ $subsections + advance-row + more-rows? +} "Pulling out a single row of results:" -{ $subsection row-column } -{ $subsection row-column-typed } ; +{ $subsections + row-column + row-column-typed +} ; ARTICLE: "db-protocol" "Low-level database protocol" "The high-level protocol (see " { $vocab-link "db.tuples" } ") uses this low-level protocol for executing statements and queries." $nl "Opening a database:" -{ $subsection db-open } +{ $subsections db-open } "Closing a database:" -{ $subsection db-close } +{ $subsections db-close } "Creating statements:" -{ $subsection } -{ $subsection } +{ $subsections + + +} "Using statements with the database:" -{ $subsection prepare-statement } -{ $subsection bind-statement* } -{ $subsection low-level-bind } +{ $subsections + prepare-statement + bind-statement* + low-level-bind +} "Performing a query:" -{ $subsection query-results } +{ $subsections query-results } "Handling query results:" -{ $subsection "db-result-sets" } +{ $subsections "db-result-sets" } ; ! { $subsection bind-tuple } 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:" -{ $subsection sql-command } +{ $subsections sql-command } "Executing a query directly:" -{ $subsection sql-query } +{ $subsections sql-query } "Here's an example usage where we'll make a book table, insert some objects, and query them." $nl "First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details." -{ $code <" +{ $code """ USING: db.sqlite db io.files io.files.temp ; : with-book-db ( quot -- ) - "book.db" temp-file swap with-db ; inline"> } + "book.db" temp-file swap with-db ; inline" } "Now let's create the table manually:" -{ $code <" "create table books +{ $code " "create table books (id integer primary key, title text, author text, date_published timestamp, edition integer, cover_price double, condition text)" - [ sql-command ] with-book-db"> } + [ sql-command ] with-book-db""" } "Time to insert some books:" -{ $code <" +{ $code """ "insert into books (title, author, date_published, edition, cover_price, condition) values('Factor for Sheeple', 'Mister Stacky Pants', date('now'), 1, 13.37, 'mint')" -[ sql-command ] with-book-db"> } +[ sql-command ] with-book-db""" } "Now let's select the book:" -{ $code <" -"select id, title, cover_price from books;" [ sql-query ] with-book-db "> } +{ $code """ +"select id, title, cover_price from books;" [ sql-query ] with-book-db""" } "Notice that the result of this query is a Factor array containing the database rows as arrays of strings. We would have to convert the " { $snippet "cover_price" } " from a string to a number in order to use it in a calculation." $nl "In conclusion, this method of accessing a database is supported, but it is fairly low-level and generally specific to a single database. The " { $vocab-link "db.tuples" } " vocabulary is a good alternative to writing SQL by hand." ; @@ -278,13 +298,13 @@ ARTICLE: "db-custom-database-combinators" "Custom database combinators" "Make a " { $snippet "with-" } " combinator to open and close a database so that resources are not leaked." $nl "SQLite example combinator:" -{ $code <" +{ $code """ USING: db.sqlite db io.files io.files.temp ; : with-sqlite-db ( quot -- ) - "my-database.db" temp-file swap with-db ; inline"> } + "my-database.db" temp-file swap with-db ; inline""" } "PostgreSQL example combinator:" -{ $code <" USING: db.postgresql db ; +{ $code """USING: db.postgresql db ; : with-postgresql-db ( quot -- ) "localhost" >>host @@ -292,7 +312,7 @@ USING: db.sqlite db io.files io.files.temp ; "erg" >>username "secrets?" >>password "factor-test" >>database - swap with-db ; inline"> + swap with-db ; inline""" } ; ABOUT: "db" diff --git a/basis/db/postgresql/ffi/ffi.factor b/basis/db/postgresql/ffi/ffi.factor index 93f93c9a13..f4a55e3280 100644 --- a/basis/db/postgresql/ffi/ffi.factor +++ b/basis/db/postgresql/ffi/ffi.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007, 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. ! tested on debian linux with postgresql 8.1 -USING: alien alien.syntax combinators system alien.libraries ; +USING: alien alien.c-types alien.syntax combinators system +alien.libraries ; IN: db.postgresql.ffi << "postgresql" { @@ -58,18 +59,18 @@ TYPEDEF: int PostgresPollingStatusType TYPEDEF: int PGTransactionStatusType TYPEDEF: int PGVerbosity -TYPEDEF: void* PGconn* -TYPEDEF: void* PGresult* -TYPEDEF: void* PGcancel* +C-TYPE: PGconn +C-TYPE: PGresult +C-TYPE: PGcancel TYPEDEF: uint Oid TYPEDEF: uint* Oid* TYPEDEF: char pqbool -TYPEDEF: void* PQconninfoOption* -TYPEDEF: void* PGnotify* -TYPEDEF: void* PQArgBlock* -TYPEDEF: void* PQprintOpt* -TYPEDEF: void* FILE* -TYPEDEF: void* SSL* +C-TYPE: PQconninfoOption +C-TYPE: PGnotify +C-TYPE: PQArgBlock +C-TYPE: PQprintOpt +C-TYPE: SSL +C-TYPE: FILE LIBRARY: postgresql diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 5b658f36c9..ffcbec70d0 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -6,7 +6,7 @@ sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators math.intervals io nmake accessors vectors math.ranges random math.bitwise db.queries destructors db.tuples.private interpolate -io.streams.string multiline make db.private sequences.deep +io.streams.string make db.private sequences.deep db.errors.sqlite ; IN: db.sqlite @@ -201,19 +201,19 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : insert-trigger ( -- string ) [ - <" + """ CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE INSERT ON ${table-name} FOR EACH ROW BEGIN SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"') WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; - "> interpolate + """ interpolate ] with-string-writer ; : insert-trigger-not-null ( -- string ) [ - <" + """ CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE INSERT ON ${table-name} FOR EACH ROW BEGIN @@ -221,24 +221,24 @@ M: sqlite-db-connection persistent-table ( -- assoc ) WHERE NEW.${table-id} IS NOT NULL AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; - "> interpolate + """ interpolate ] with-string-writer ; : update-trigger ( -- string ) [ - <" + """ CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE UPDATE ON ${table-name} FOR EACH ROW BEGIN SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"') WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; - "> interpolate + """ interpolate ] with-string-writer ; : update-trigger-not-null ( -- string ) [ - <" + """ CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE UPDATE ON ${table-name} FOR EACH ROW BEGIN @@ -246,30 +246,30 @@ M: sqlite-db-connection persistent-table ( -- assoc ) WHERE NEW.${table-id} IS NOT NULL AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; - "> interpolate + """ interpolate ] with-string-writer ; : delete-trigger-restrict ( -- string ) [ - <" + """ CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE DELETE ON ${foreign-table-name} FOR EACH ROW BEGIN SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"') WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL; END; - "> interpolate + """ interpolate ] with-string-writer ; : delete-trigger-cascade ( -- string ) [ - <" + """ CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE DELETE ON ${foreign-table-name} FOR EACH ROW BEGIN DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id}; END; - "> interpolate + """ interpolate ] with-string-writer ; : can-be-null? ( -- ? ) diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor index bd88c56431..01d65484f3 100644 --- a/basis/db/tuples/tuples-docs.factor +++ b/basis/db/tuples/tuples-docs.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: classes help.markup help.syntax io.streams.string kernel -quotations sequences strings multiline math db.types -db.tuples.private db ; +quotations sequences strings math db.types db.tuples.private db ; IN: db.tuples HELP: random-id-generator @@ -155,52 +154,58 @@ HELP: count-tuples ARTICLE: "db-tuples" "High-level tuple/database integration" "Start with a tutorial:" -{ $subsection "db-tuples-tutorial" } +{ $subsections "db-tuples-tutorial" } "Database types supported:" -{ $subsection "db.types" } +{ $subsections "db.types" } "Useful words:" -{ $subsection "db-tuples-words" } +{ $subsections "db-tuples-words" } "For porting db.tuples to other databases:" -{ $subsection "db-tuples-protocol" } +{ $subsections "db-tuples-protocol" } ; ARTICLE: "db-tuples-words" "High-level tuple/database words" "Making tuples work with a database:" -{ $subsection define-persistent } +{ $subsections define-persistent } "Creating tables:" -{ $subsection create-table } -{ $subsection ensure-table } -{ $subsection ensure-tables } -{ $subsection recreate-table } +{ $subsections + create-table + ensure-table + ensure-tables + recreate-table +} "Dropping tables:" -{ $subsection drop-table } +{ $subsections drop-table } "Inserting a tuple:" -{ $subsection insert-tuple } +{ $subsections insert-tuple } "Updating a tuple:" -{ $subsection update-tuple } +{ $subsections update-tuple } "Deleting tuples:" -{ $subsection delete-tuples } +{ $subsections delete-tuples } "Querying tuples:" -{ $subsection select-tuple } -{ $subsection select-tuples } -{ $subsection count-tuples } ; +{ $subsections + select-tuple + select-tuples + count-tuples +} ; ARTICLE: "db-tuples-protocol" "Tuple database protocol" "Creating a table:" -{ $subsection create-sql-statement } +{ $subsections create-sql-statement } "Dropping a table:" -{ $subsection drop-sql-statement } +{ $subsections drop-sql-statement } "Inserting a tuple:" -{ $subsection } -{ $subsection } +{ $subsections + + +} "Updating a tuple:" -{ $subsection } +{ $subsections } "Deleting tuples:" -{ $subsection } +{ $subsections } "Selecting tuples:" -{ $subsection } +{ $subsections } "Counting tuples:" -{ $subsection } ; +{ $subsections } ; ARTICLE: "db-tuples-tutorial" "Tuple database tutorial" "Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl @@ -209,7 +214,7 @@ ARTICLE: "db-tuples-tutorial" "Tuple database tutorial" "The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl "To actually bind the tuple slots to the database types, we'll use " { $link define-persistent } "." { $code -<" USING: db.tuples db.types ; +"""USING: db.tuples db.types ; book "BOOK" { { "id" "ID" +db-assigned-id+ } @@ -219,9 +224,9 @@ book "BOOK" { "edition" "EDITION" INTEGER } { "cover-price" "COVER_PRICE" DOUBLE } { "condition" "CONDITION" VARCHAR } -} define-persistent "> } +} define-persistent""" } "That's all we'll have to do with the database for this tutorial. Now let's make a book." -{ $code <" USING: calendar namespaces ; +{ $code """USING: calendar namespaces ; T{ book { title "Factor for Sheeple" } { author "Mister Stacky Pants" } @@ -229,35 +234,35 @@ T{ book { edition 1 } { cover-price 13.37 } } book set -"> } +""" } "Now we've created a book. Let's save it to the database." -{ $code <" USING: db db.sqlite fry io.files ; +{ $code """USING: db db.sqlite fry io.files.temp ; : with-book-tutorial ( quot -- ) - '[ "book-tutorial.db" temp-file _ with-db ] call ; + '[ "book-tutorial.db" temp-file _ with-db ] call ; inline [ book recreate-table book get insert-tuple ] with-book-tutorial -"> } +""" } "Is it really there?" -{ $code <" [ +{ $code """[ T{ book { title "Factor for Sheeple" } } select-tuples . -] with-book-tutorial "> } +] with-book-tutorial""" } "Oops, we spilled some orange juice on the book cover." -{ $code <" book get "Small orange juice stain on cover" >>condition "> } +{ $code """book get "Small orange juice stain on cover" >>condition""" } "Now let's save the modified book." -{ $code <" [ +{ $code """[ book get update-tuple -] with-book-tutorial "> } +] with-book-tutorial""" } "And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "." -{ $code <" [ +{ $code """[ T{ book { title "Factor for Sheeple" } } select-tuples -] with-book-tutorial "> } +] with-book-tutorial""" } "Let's drop the table because we're done." -{ $code <" [ +{ $code """[ book drop-table -] with-book-tutorial "> } +] with-book-tutorial""" } "To summarize, the steps for using Factor's tuple database are:" { $list "Make a new tuple to represent your data" diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor index 60d92717e8..8b62e7d4ae 100644 --- a/basis/db/types/types-docs.factor +++ b/basis/db/types/types-docs.factor @@ -157,32 +157,42 @@ HELP: unknown-modifier ARTICLE: "db.types" "Database types" "The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." $nl "Primary keys:" -{ $subsection +db-assigned-id+ } -{ $subsection +user-assigned-id+ } -{ $subsection +random-id+ } +{ $subsections + +db-assigned-id+ + +user-assigned-id+ + +random-id+ +} "Null and boolean types:" -{ $subsection NULL } -{ $subsection BOOLEAN } +{ $subsections + NULL + BOOLEAN +} "Text types:" -{ $subsection VARCHAR } -{ $subsection TEXT } +{ $subsections + VARCHAR + TEXT +} "Number types:" -{ $subsection INTEGER } -{ $subsection BIG-INTEGER } -{ $subsection SIGNED-BIG-INTEGER } -{ $subsection UNSIGNED-BIG-INTEGER } -{ $subsection DOUBLE } -{ $subsection REAL } +{ $subsections + INTEGER + BIG-INTEGER + SIGNED-BIG-INTEGER + UNSIGNED-BIG-INTEGER + DOUBLE + REAL +} "Calendar types:" -{ $subsection DATE } -{ $subsection DATETIME } -{ $subsection TIME } -{ $subsection TIMESTAMP } +{ $subsections + DATE + DATETIME + TIME + TIMESTAMP +} "Factor byte-arrays:" -{ $subsection BLOB } +{ $subsections BLOB } "Arbitrary Factor objects:" -{ $subsection FACTOR-BLOB } +{ $subsections FACTOR-BLOB } "Factor URLs:" -{ $subsection URL } ; +{ $subsections URL } ; ABOUT: "db.types" diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index 0845a1734f..87e70d69e7 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -6,23 +6,29 @@ IN: debugger ARTICLE: "debugger" "The debugger" "Caught errors can be logged in human-readable form:" -{ $subsection print-error } -{ $subsection try } +{ $subsections + print-error + try +} "User-defined errors can have customized printed representation by implementing a generic word:" -{ $subsection error. } +{ $subsections error. } "A number of words facilitate interactive debugging of errors:" -{ $subsection :error } -{ $subsection :s } -{ $subsection :r } -{ $subsection :c } -{ $subsection :get } +{ $subsections + :error + :s + :r + :c + :get +} "Most types of errors are documented, and the documentation is instantly accessible:" -{ $subsection :help } +{ $subsections :help } "If the error was restartable, a list of restarts is also printed, and a numbered restart can be invoked:" -{ $subsection :1 } -{ $subsection :2 } -{ $subsection :3 } -{ $subsection :res } +{ $subsections + :1 + :2 + :3 + :res +} "You can read more about error handling in " { $link "errors" } "." $nl "Note that in Factor, the debugger is a tool for printing and inspecting errors, not for walking through code. For the latter, see " { $link "ui-walker" } "." ; diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 1e08896e8d..4888896866 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -319,7 +319,9 @@ M: lexer-error error-help M: bad-effect summary drop "Bad stack effect declaration" ; -M: bad-escape summary drop "Bad escape code" ; +M: bad-escape error. + "Bad escape code: \\" write + char>> 1string print ; M: bad-literal-tuple summary drop "Bad literal tuple" ; diff --git a/basis/definitions/icons/class-predicate-word.png b/basis/definitions/icons/class-predicate-word.png new file mode 100644 index 0000000000..d70aa21412 Binary files /dev/null and b/basis/definitions/icons/class-predicate-word.png differ diff --git a/basis/definitions/icons/class-predicate-word.tiff b/basis/definitions/icons/class-predicate-word.tiff deleted file mode 100644 index f2a5df964d..0000000000 Binary files a/basis/definitions/icons/class-predicate-word.tiff and /dev/null differ diff --git a/basis/definitions/icons/class-word.png b/basis/definitions/icons/class-word.png new file mode 100644 index 0000000000..a137690333 Binary files /dev/null and b/basis/definitions/icons/class-word.png differ diff --git a/basis/definitions/icons/class-word.tiff b/basis/definitions/icons/class-word.tiff deleted file mode 100644 index 16e94f70b8..0000000000 Binary files a/basis/definitions/icons/class-word.tiff and /dev/null differ diff --git a/basis/definitions/icons/constant-word.png b/basis/definitions/icons/constant-word.png new file mode 100644 index 0000000000..2b265e00aa Binary files /dev/null and b/basis/definitions/icons/constant-word.png differ diff --git a/basis/definitions/icons/constant-word.tiff b/basis/definitions/icons/constant-word.tiff deleted file mode 100644 index 69ee5fa6ac..0000000000 Binary files a/basis/definitions/icons/constant-word.tiff and /dev/null differ diff --git a/basis/definitions/icons/generic-word.png b/basis/definitions/icons/generic-word.png new file mode 100644 index 0000000000..e260cc55a5 Binary files /dev/null and b/basis/definitions/icons/generic-word.png differ diff --git a/basis/definitions/icons/generic-word.tiff b/basis/definitions/icons/generic-word.tiff deleted file mode 100644 index 17741d05c6..0000000000 Binary files a/basis/definitions/icons/generic-word.tiff and /dev/null differ diff --git a/basis/definitions/icons/help-article.png b/basis/definitions/icons/help-article.png new file mode 100644 index 0000000000..ce35018a0e Binary files /dev/null and b/basis/definitions/icons/help-article.png differ diff --git a/basis/definitions/icons/help-article.tiff b/basis/definitions/icons/help-article.tiff deleted file mode 100644 index 5fb3375520..0000000000 Binary files a/basis/definitions/icons/help-article.tiff and /dev/null differ diff --git a/basis/definitions/icons/icons-docs.factor b/basis/definitions/icons/icons-docs.factor index 8bca46bc3a..7493d4c05a 100644 --- a/basis/definitions/icons/icons-docs.factor +++ b/basis/definitions/icons/icons-docs.factor @@ -5,8 +5,8 @@ ARTICLE: "definitions.icons" "Definition icons" "The " { $vocab-link "definitions.icons" } " vocabulary associates common definition types with icons." { $definition-icons } "Looking up the icon associated with a definition:" -{ $subsection definition-icon } +{ $subsections definition-icon } "Defining new icons:" -{ $subsection POSTPONE: ICON: } ; +{ $subsections POSTPONE: ICON: } ; ABOUT: "definitions.icons" \ No newline at end of file diff --git a/basis/definitions/icons/icons.factor b/basis/definitions/icons/icons.factor index 3c4dad5be7..90b8d3363c 100644 --- a/basis/definitions/icons/icons.factor +++ b/basis/definitions/icons/icons.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs classes.predicate fry generic io.pathnames kernel -macros sequences vocabs words words.symbol words.constant -lexer parser help.topics help.markup namespaces sorting ; +USING: assocs classes.predicate fry generic help.topics +io.pathnames kernel lexer macros namespaces parser sequences +vocabs words words.constant words.symbol ; IN: definitions.icons GENERIC: definition-icon ( definition -- path ) : definition-icon-path ( string -- string' ) - "vocab:definitions/icons/" prepend-path ".tiff" append ; + "vocab:definitions/icons/" prepend-path ".png" append ; << @@ -41,10 +41,3 @@ ICON: topic help-article ICON: runnable-vocab runnable-vocab ICON: vocab open-vocab ICON: vocab-link unopen-vocab - -: $definition-icons ( element -- ) - drop - icons get >alist sort-keys - [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map - { "" "Definition class" } prefix - $table ; \ No newline at end of file diff --git a/basis/definitions/icons/macro-word.png b/basis/definitions/icons/macro-word.png new file mode 100644 index 0000000000..1c6f0f3947 Binary files /dev/null and b/basis/definitions/icons/macro-word.png differ diff --git a/basis/definitions/icons/macro-word.tiff b/basis/definitions/icons/macro-word.tiff deleted file mode 100644 index 040a243667..0000000000 Binary files a/basis/definitions/icons/macro-word.tiff and /dev/null differ diff --git a/basis/definitions/icons/normal-word.png b/basis/definitions/icons/normal-word.png new file mode 100644 index 0000000000..27966b4971 Binary files /dev/null and b/basis/definitions/icons/normal-word.png differ diff --git a/basis/definitions/icons/normal-word.tiff b/basis/definitions/icons/normal-word.tiff deleted file mode 100644 index ad837ebdb0..0000000000 Binary files a/basis/definitions/icons/normal-word.tiff and /dev/null differ diff --git a/basis/definitions/icons/open-vocab.png b/basis/definitions/icons/open-vocab.png new file mode 100644 index 0000000000..6f6b3cb87c Binary files /dev/null and b/basis/definitions/icons/open-vocab.png differ diff --git a/basis/definitions/icons/open-vocab.tiff b/basis/definitions/icons/open-vocab.tiff deleted file mode 100644 index e12a8e8880..0000000000 Binary files a/basis/definitions/icons/open-vocab.tiff and /dev/null differ diff --git a/basis/definitions/icons/parsing-word.png b/basis/definitions/icons/parsing-word.png new file mode 100644 index 0000000000..eabb381b20 Binary files /dev/null and b/basis/definitions/icons/parsing-word.png differ diff --git a/basis/definitions/icons/parsing-word.tiff b/basis/definitions/icons/parsing-word.tiff deleted file mode 100644 index 220ad1bd19..0000000000 Binary files a/basis/definitions/icons/parsing-word.tiff and /dev/null differ diff --git a/basis/definitions/icons/primitive-word.png b/basis/definitions/icons/primitive-word.png new file mode 100644 index 0000000000..2952a0b921 Binary files /dev/null and b/basis/definitions/icons/primitive-word.png differ diff --git a/basis/definitions/icons/primitive-word.tiff b/basis/definitions/icons/primitive-word.tiff deleted file mode 100644 index ade51951d9..0000000000 Binary files a/basis/definitions/icons/primitive-word.tiff and /dev/null differ diff --git a/basis/definitions/icons/runnable-vocab.png b/basis/definitions/icons/runnable-vocab.png new file mode 100644 index 0000000000..c028bf28e1 Binary files /dev/null and b/basis/definitions/icons/runnable-vocab.png differ diff --git a/basis/definitions/icons/runnable-vocab.tiff b/basis/definitions/icons/runnable-vocab.tiff deleted file mode 100644 index eef52e32d8..0000000000 Binary files a/basis/definitions/icons/runnable-vocab.tiff and /dev/null differ diff --git a/basis/definitions/icons/symbol-word.png b/basis/definitions/icons/symbol-word.png new file mode 100644 index 0000000000..6f0c267c96 Binary files /dev/null and b/basis/definitions/icons/symbol-word.png differ diff --git a/basis/definitions/icons/symbol-word.tiff b/basis/definitions/icons/symbol-word.tiff deleted file mode 100644 index a00f84e2e4..0000000000 Binary files a/basis/definitions/icons/symbol-word.tiff and /dev/null differ diff --git a/basis/definitions/icons/unopen-vocab.png b/basis/definitions/icons/unopen-vocab.png new file mode 100644 index 0000000000..05ca4a4682 Binary files /dev/null and b/basis/definitions/icons/unopen-vocab.png differ diff --git a/basis/definitions/icons/unopen-vocab.tiff b/basis/definitions/icons/unopen-vocab.tiff deleted file mode 100644 index 892e64b83a..0000000000 Binary files a/basis/definitions/icons/unopen-vocab.tiff and /dev/null differ diff --git a/basis/definitions/icons/word-help-article.png b/basis/definitions/icons/word-help-article.png new file mode 100644 index 0000000000..141d390e20 Binary files /dev/null and b/basis/definitions/icons/word-help-article.png differ diff --git a/basis/definitions/icons/word-help-article.tiff b/basis/definitions/icons/word-help-article.tiff deleted file mode 100644 index 8ec1bf7c11..0000000000 Binary files a/basis/definitions/icons/word-help-article.tiff and /dev/null differ diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor index 42e770aa75..4ce3776277 100644 --- a/basis/delegate/delegate-docs.factor +++ b/basis/delegate/delegate-docs.factor @@ -44,13 +44,17 @@ $nl "Unlike " { $link "tuple-subclassing" } ", which expresses " { $emphasis "is-a" } " relationships by statically including the methods and slots of the superclass in all subclasses, consultation forwards generic word calls to another distinct object." $nl "Defining new protocols:" -{ $subsection POSTPONE: PROTOCOL: } -{ $subsection define-protocol } +{ $subsections + POSTPONE: PROTOCOL: + define-protocol +} "Defining new protocols consisting of slot accessors:" -{ $subsection POSTPONE: SLOT-PROTOCOL: } +{ $subsections POSTPONE: SLOT-PROTOCOL: } "Defining consultation:" -{ $subsection POSTPONE: CONSULT: } -{ $subsection define-consult } +{ $subsections + POSTPONE: CONSULT: + define-consult +} "Every tuple class has an associated protocol consisting of all of its slot accessor methods. The " { $vocab-link "delegate.protocols" } " vocabulary defines formal protocols for the various informal protocols used in the Factor core, such as " { $link "sequence-protocol" } ", " { $link "assocs-protocol" } " or " { $link "stream-protocol" } ; ABOUT: "delegate" diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index d9581152e1..17f81708c5 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -105,20 +105,20 @@ PROTOCOL: silly-protocol do-me ; ! Replacing a method definition with a consultation would cause problems [ [ ] ] [ - <" IN: delegate.tests + "IN: delegate.tests USE: kernel - M: a-tuple do-me drop ; "> "delegate-test" parse-stream + M: a-tuple do-me drop ;" "delegate-test" parse-stream ] unit-test [ ] [ T{ a-tuple } do-me ] unit-test ! Change method definition to consultation [ [ ] ] [ - <" IN: delegate.tests + "IN: delegate.tests USE: kernel USE: delegate - CONSULT: silly-protocol a-tuple drop f ; "> "delegate-test" parse-stream + CONSULT: silly-protocol a-tuple drop f ; " "delegate-test" parse-stream ] unit-test ! Method should be there @@ -126,7 +126,7 @@ PROTOCOL: silly-protocol do-me ; ! Now try removing the consulation [ [ ] ] [ - <" IN: delegate.tests "> "delegate-test" parse-stream + "IN: delegate.tests" "delegate-test" parse-stream ] unit-test ! Method should be gone @@ -139,18 +139,18 @@ SLOT: y [ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test [ [ ] ] [ - <" IN: delegate.tests + "IN: delegate.tests USING: accessors delegate ; TUPLE: slot-protocol-test-3 x ; -CONSULT: y>> slot-protocol-test-3 x>> ;"> +CONSULT: y>> slot-protocol-test-3 x>> ;" "delegate-test-1" parse-stream ] unit-test [ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test [ [ ] ] [ - <" IN: delegate.tests -TUPLE: slot-protocol-test-3 x y ;"> + "IN: delegate.tests +TUPLE: slot-protocol-test-3 x y ;" "delegate-test-1" parse-stream ] unit-test @@ -160,11 +160,11 @@ TUPLE: slot-protocol-test-3 x y ;"> ! We want to be able to override methods after consultation [ [ ] ] [ - <" IN: delegate.tests + "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 ; "> + M: override-method-test like drop ; " "delegate-test-2" parse-stream ] unit-test @@ -172,10 +172,10 @@ DEFER: seq-delegate ! See if removing a consultation updates protocol-consult word prop [ [ ] ] [ - <" IN: delegate.tests + "IN: delegate.tests USING: accessors delegate delegate.protocols ; TUPLE: seq-delegate seq ; - CONSULT: sequence-protocol seq-delegate seq>> ;"> + CONSULT: sequence-protocol seq-delegate seq>> ;" "remove-consult-test" parse-stream ] unit-test @@ -186,9 +186,9 @@ DEFER: seq-delegate ] unit-test [ [ ] ] [ - <" IN: delegate.tests + "IN: delegate.tests USING: delegate delegate.protocols ; - TUPLE: seq-delegate seq ;"> + TUPLE: seq-delegate seq ;" "remove-consult-test" parse-stream ] unit-test diff --git a/basis/deques/deques-docs.factor b/basis/deques/deques-docs.factor index e747bd9316..c625b9a27d 100644 --- a/basis/deques/deques-docs.factor +++ b/basis/deques/deques-docs.factor @@ -99,31 +99,39 @@ ARTICLE: "deques" "Deques" "The " { $vocab-link "deques" } " vocabulary implements the deque data structure which has constant-time insertion and removal of elements at both ends." $nl "Deques must be instances of a mixin class:" -{ $subsection deque } +{ $subsections deque } "Deques must implement a protocol." $nl "Querying the deque:" -{ $subsection peek-front } -{ $subsection peek-back } -{ $subsection deque-empty? } -{ $subsection deque-member? } +{ $subsections + peek-front + peek-back + deque-empty? + deque-member? +} "Adding and removing elements:" -{ $subsection push-front* } -{ $subsection push-back* } -{ $subsection pop-front* } -{ $subsection pop-back* } -{ $subsection clear-deque } +{ $subsections + push-front* + push-back* + pop-front* + pop-back* + clear-deque +} "Working with node objects output by " { $link push-front* } " and " { $link push-back* } ":" -{ $subsection delete-node } -{ $subsection node-value } +{ $subsections + delete-node + node-value +} "Utility operations built in terms of the above:" -{ $subsection push-front } -{ $subsection push-all-front } -{ $subsection push-back } -{ $subsection push-all-back } -{ $subsection pop-front } -{ $subsection pop-back } -{ $subsection slurp-deque } +{ $subsections + push-front + push-all-front + push-back + push-all-back + pop-front + pop-back + slurp-deque +} "When using a deque as a queue, the convention is to queue elements with " { $link push-front } " and deque them with " { $link pop-back } "." ; ABOUT: "deques" diff --git a/basis/disjoint-sets/disjoint-sets-docs.factor b/basis/disjoint-sets/disjoint-sets-docs.factor index cded25b48d..73de932a30 100644 --- a/basis/disjoint-sets/disjoint-sets-docs.factor +++ b/basis/disjoint-sets/disjoint-sets-docs.factor @@ -42,17 +42,21 @@ $nl "The two main supported operations are equating two elements, which joins their equivalence classes, and checking if two elements belong to the same equivalence class. Both operations have the time complexity of the inverse Ackermann function, which for all intents and purposes is constant time." $nl "The class of disjoint sets:" -{ $subsection disjoint-set } +{ $subsections disjoint-set } "Creating new disjoint sets:" -{ $subsection } -{ $subsection assoc>disjoint-set } +{ $subsections + + assoc>disjoint-set +} "Queries:" -{ $subsection equiv? } -{ $subsection equiv-set-size } +{ $subsections + equiv? + equiv-set-size +} "Adding elements:" -{ $subsection add-atom } +{ $subsections add-atom } "Equating elements:" -{ $subsection equate } +{ $subsections equate } "Additionally, disjoint sets implement the " { $link clone } " generic word." ; ABOUT: "disjoint-sets" diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor index e210ad35ce..716c20d6f6 100755 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -6,22 +6,28 @@ ARTICLE: "dlists" "Double-linked lists" "A double-linked list is the canonical implementation of a " { $link deque } "." $nl "Double-linked lists form a class:" -{ $subsection dlist } -{ $subsection dlist? } +{ $subsections + dlist + dlist? +} "Constructing a double-linked list:" -{ $subsection } +{ $subsections } "Double-linked lists support all the operations of the deque protocol (" { $link "deques" } ") as well as the following." $nl "Iterating over elements:" -{ $subsection dlist-each } -{ $subsection dlist-find } -{ $subsection dlist-filter } -{ $subsection dlist-any? } +{ $subsections + dlist-each + dlist-find + dlist-filter + dlist-any? +} "Deleting a node matching a predicate:" -{ $subsection delete-node-if* } -{ $subsection delete-node-if } +{ $subsections + delete-node-if* + delete-node-if +} "Search deque implementation:" -{ $subsection } ; +{ $subsections } ; ABOUT: "dlists" diff --git a/basis/documents/documents-docs.factor b/basis/documents/documents-docs.factor index a0b1eeb118..850c68fd9d 100644 --- a/basis/documents/documents-docs.factor +++ b/basis/documents/documents-docs.factor @@ -93,32 +93,45 @@ HELP: clear-doc ARTICLE: "documents" "Documents" "The " { $vocab-link "documents" } " vocabulary implements " { $emphasis "documents" } ", which are models storing a passage of text as a sequence of lines. Operations are defined for operating on subranges of the text, and " { $link "ui.gadgets.editors" } " can display these models." -{ $subsection document } -{ $subsection } +{ $subsections + document + +} "Getting and setting the contents of the entire document:" -{ $subsection doc-string } -{ $subsection set-doc-string } -{ $subsection clear-doc } +{ $subsections + doc-string + set-doc-string + clear-doc +} "Getting and setting subranges:" -{ $subsection doc-line } -{ $subsection doc-lines } -{ $subsection doc-range } -{ $subsection set-doc-range } -{ $subsection remove-doc-range } +{ $subsections + doc-line + doc-lines + doc-range + set-doc-range + remove-doc-range +} "A combinator:" -{ $subsection each-line } -{ $subsection "document-locs" } -{ $subsection "documents.elements" } +{ $subsections each-line } +"More info:" +{ $subsections + "document-locs" + "documents.elements" +} { $see-also "ui.gadgets.editors" } ; ARTICLE: "document-locs" "Document locations" "Locations in the document are represented as a line/column number pair, with both indices being zero-based. There are some words for manipulating locations:" -{ $subsection +col } -{ $subsection +line } -{ $subsection =col } -{ $subsection =line } +{ $subsections + +col + +line + =col + =line +} "Miscellaneous words for working with locations:" -{ $subsection lines-equal? } -{ $subsection validate-loc } ; +{ $subsections + lines-equal? + validate-loc +} ; ABOUT: "documents" diff --git a/basis/documents/elements/elements-docs.factor b/basis/documents/elements/elements-docs.factor index 935f927c30..6a3f57c15a 100644 --- a/basis/documents/elements/elements-docs.factor +++ b/basis/documents/elements/elements-docs.factor @@ -37,14 +37,18 @@ ARTICLE: "documents.elements" "Document elements" "Document elements, defined in the " { $vocab-link "documents.elements" } " vocabulary, overlay a hierarchy of structure on top of the flat sequence of characters presented by the document." $nl "The different types of document elements correspond to the standard editing taxonomy:" -{ $subsection char-elt } -{ $subsection one-word-elt } -{ $subsection word-elt } -{ $subsection one-line-elt } -{ $subsection line-elt } -{ $subsection doc-elt } +{ $subsections + char-elt + one-word-elt + word-elt + one-line-elt + line-elt + doc-elt +} "New locations can be created out of existing ones by finding the start or end of a document element nearest to a given location." -{ $subsection prev-elt } -{ $subsection next-elt } ; +{ $subsections + prev-elt + next-elt +} ; ABOUT: "documents.elements" \ No newline at end of file diff --git a/basis/documents/elements/elements-tests.factor b/basis/documents/elements/elements-tests.factor index 9b323ae8e9..70476e16a9 100644 --- a/basis/documents/elements/elements-tests.factor +++ b/basis/documents/elements/elements-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test namespaces documents documents.elements multiline ; +USING: tools.test namespaces documents documents.elements ; IN: document.elements.tests SYMBOL: doc @@ -56,12 +56,12 @@ SYMBOL: doc ! page-elt doc set -<" First line +"First line Second line Third line Fourth line Fifth line -Sixth line"> doc get set-doc-string +Sixth line" doc get set-doc-string [ { 0 0 } ] [ { 3 3 } doc get 4 prev-elt ] unit-test [ { 1 2 } ] [ { 5 2 } doc get 4 prev-elt ] unit-test diff --git a/basis/editors/editors-docs.factor b/basis/editors/editors-docs.factor index 43fd679e3a..c561e7077b 100644 --- a/basis/editors/editors-docs.factor +++ b/basis/editors/editors-docs.factor @@ -4,15 +4,15 @@ IN: editors ARTICLE: "editor" "Editor integration" "Factor development is best done with one of the supported editors; this allows you to quickly jump to definitions from the Factor environment." -{ $subsection edit } +{ $subsections edit } "Depending on the editor you are using, you must load one of the child vocabularies of the " { $vocab-link "editors" } " vocabulary, for example " { $vocab-link "editors.emacs" } ":" { $code "USE: editors.emacs" } "If you intend to always use the same editor, it helps to have it load during stage 2 bootstrap. Place the code to load and possibly configure it in the " { $link "factor-boot-rc" } "." $nl "Editor integration vocabularies store a quotation in a global variable when loaded:" -{ $subsection edit-hook } +{ $subsections edit-hook } "If a syntax error was thrown while loading a source file, you can jump to the location of the error in your editor:" -{ $subsection :edit } ; +{ $subsections :edit } ; ABOUT: "editor" diff --git a/basis/environment/environment-docs.factor b/basis/environment/environment-docs.factor index 0f88181f28..3df3a8da8f 100644 --- a/basis/environment/environment-docs.factor +++ b/basis/environment/environment-docs.factor @@ -60,11 +60,15 @@ ARTICLE: "environment" "Environment variables" "The " { $vocab-link "environment" } " vocabulary interfaces to the platform-dependent mechanism for setting environment variables." $nl "Windows CE has no concept of environment variables, so these words are undefined on that platform." $nl "Reading environment variables:" -{ $subsection os-env } -{ $subsection os-envs } +{ $subsections + os-env + os-envs +} "Writing environment variables:" -{ $subsection set-os-env } -{ $subsection unset-os-env } -{ $subsection set-os-envs } ; +{ $subsections + set-os-env + unset-os-env + set-os-envs +} ; ABOUT: "environment" diff --git a/basis/environment/unix/macosx/macosx.factor b/basis/environment/unix/macosx/macosx.factor index 51cee7ba08..e811455927 100644 --- a/basis/environment/unix/macosx/macosx.factor +++ b/basis/environment/unix/macosx/macosx.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax system environment.unix ; +USING: alien.c-types alien.syntax system environment.unix ; IN: environment.unix.macosx FUNCTION: void* _NSGetEnviron ( ) ; diff --git a/basis/eval/eval-docs.factor b/basis/eval/eval-docs.factor index b30c6d9cb9..250241dcfc 100644 --- a/basis/eval/eval-docs.factor +++ b/basis/eval/eval-docs.factor @@ -17,7 +17,9 @@ HELP: eval>string ARTICLE: "eval" "Evaluating strings at runtime" "The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime." -{ $subsection POSTPONE: eval( } -{ $subsection eval>string } ; +{ $subsections + POSTPONE: eval( + eval>string +} ; ABOUT: "eval" diff --git a/basis/farkup/farkup-docs.factor b/basis/farkup/farkup-docs.factor index 036f0d667a..3779d0e680 100644 --- a/basis/farkup/farkup-docs.factor +++ b/basis/farkup/farkup-docs.factor @@ -19,34 +19,40 @@ HELP: (write-farkup) ARTICLE: "farkup-ast" "Farkup syntax tree nodes" "The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "." -{ $subsection heading1 } -{ $subsection heading2 } -{ $subsection heading3 } -{ $subsection heading4 } -{ $subsection strong } -{ $subsection emphasis } -{ $subsection superscript } -{ $subsection subscript } -{ $subsection inline-code } -{ $subsection paragraph } -{ $subsection list-item } -{ $subsection unordered-list } -{ $subsection ordered-list } -{ $subsection table } -{ $subsection table-row } -{ $subsection link } -{ $subsection image } -{ $subsection code } ; +{ $subsections + heading1 + heading2 + heading3 + heading4 + strong + emphasis + superscript + subscript + inline-code + paragraph + list-item + unordered-list + ordered-list + table + table-row + link + image + code +} ; ARTICLE: "farkup" "Farkup" "The " { $vocab-link "farkup" } " vocabulary implements Farkup (Factor mARKUP), a simple markup language. Farkup was loosely based on the markup languages employed by MediaWiki and " { $url "http://reddit.com" } "." $nl "The main entry points for converting Farkup to HTML:" -{ $subsection convert-farkup } -{ $subsection write-farkup } +{ $subsections + convert-farkup + write-farkup +} "The syntax tree of a piece of Farkup can also be inspected and modified:" -{ $subsection parse-farkup } -{ $subsection (write-farkup) } -{ $subsection "farkup-ast" } ; +{ $subsections + parse-farkup + (write-farkup) + "farkup-ast" +} ; ABOUT: "farkup" diff --git a/basis/fonts/fonts-docs.factor b/basis/fonts/fonts-docs.factor index c529efc100..3b30713ef3 100644 --- a/basis/fonts/fonts-docs.factor +++ b/basis/fonts/fonts-docs.factor @@ -26,16 +26,22 @@ HELP: font-with-foreground ARTICLE: "fonts" "Fonts" "The " { $vocab-link "fonts" } " vocabulary implements a data type for fonts that other vocabularies, for example " { $link "ui" } ", can use. A font combines a font name, size, style, and color information into a single object." -{ $subsection font } -{ $subsection } +{ $subsections + font + +} "Modifying fonts:" -{ $subsection font-with-foreground } -{ $subsection font-with-background } +{ $subsections + font-with-foreground + font-with-background +} "Useful constants:" -{ $subsection monospace-font } -{ $subsection sans-serif-font } -{ $subsection serif-font } +{ $subsections + monospace-font + sans-serif-font + serif-font +} "A data type for font metrics. The " { $vocab-link "fonts" } " vocabulary does not provide any means of computing font metrics, it simply defines a common data type that other vocabularies, such as " { $vocab-link "ui.text" } " may use:" -{ $subsection metrics } ; +{ $subsections metrics } ; ABOUT: "fonts" diff --git a/basis/formatting/formatting-docs.factor b/basis/formatting/formatting-docs.factor index 95b24ae351..47720ad671 100644 --- a/basis/formatting/formatting-docs.factor +++ b/basis/formatting/formatting-docs.factor @@ -129,10 +129,11 @@ HELP: strftime ARTICLE: "formatting" "Formatted printing" "The " { $vocab-link "formatting" } " vocabulary is used for formatted printing." -{ $subsection printf } -{ $subsection sprintf } -{ $subsection strftime } -; +{ $subsections + printf + sprintf + strftime +} ; ABOUT: "formatting" diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index 32ad856d00..13b9e61632 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -78,17 +78,21 @@ ARTICLE: "fry" "Fried quotations" "The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with âholesâ (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack." $nl "Fried quotations are started by a special parsing word:" -{ $subsection POSTPONE: '[ } +{ $subsections POSTPONE: '[ } "There are two types of fry specifiers; the first can hold a value, and the second âsplicesâ a quotation, as if it were inserted without surrounding brackets:" -{ $subsection _ } -{ $subsection @ } +{ $subsections + _ + @ +} "The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on." -{ $subsection "fry.examples" } -{ $subsection "fry.philosophy" } +{ $subsections + "fry.examples" + "fry.philosophy" +} "Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)." $nl "Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:" -{ $subsection fry } +{ $subsections fry } "Fried quotations are an abstraction on top of the " { $link "compositional-combinators" } "; their use is encouraged over the combinators, because often the fry form is shorter and clearer than the combinator form." ; ABOUT: "fry" diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index 58da96aa17..544c2ed1e4 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -105,14 +105,13 @@ M: integer W 1 + ; ! Does replacing an ordinary word with a functor-generated one work? [ [ ] ] [ - <" IN: functors.tests + "IN: functors.tests TUPLE: some-tuple ; : some-word ( -- ) ; GENERIC: some-generic ( a -- b ) M: some-tuple some-generic ; - SYMBOL: some-symbol - "> "functors-test" parse-stream + SYMBOL: some-symbol" "functors-test" parse-stream ] unit-test : test-redefinition ( -- ) @@ -145,9 +144,8 @@ SYMBOL: W-symbol ;FUNCTOR [ [ ] ] [ - <" IN: functors.tests - << "some" redefine-test >> - "> "functors-test" parse-stream + """IN: functors.tests + << "some" redefine-test >>""" "functors-test" parse-stream ] unit-test test-redefinition diff --git a/basis/furnace/actions/actions-docs.factor b/basis/furnace/actions/actions-docs.factor index 6468b8deb7..a49d6d54b3 100644 --- a/basis/furnace/actions/actions-docs.factor +++ b/basis/furnace/actions/actions-docs.factor @@ -1,6 +1,6 @@ USING: assocs classes help.markup help.syntax io.streams.string http http.server.dispatchers http.server.responses -furnace.redirection strings multiline html.forms ; +furnace.redirection strings html.forms ; IN: furnace.actions HELP: @@ -53,12 +53,12 @@ HELP: validate-params { $examples "A simple validator from " { $vocab-link "webapps.todo" } "; this word is invoked from the " { $slot "validate" } " quotation of action for editing a todo list item:" { $code - <" : validate-todo ( -- ) + """: validate-todo ( -- ) { { "summary" [ v-one-line ] } { "priority" [ v-integer 0 v-min-value 10 v-max-value ] } { "description" [ v-required ] } - } validate-params ;"> + } validate-params ;""" } } ; @@ -81,12 +81,14 @@ ARTICLE: "furnace.actions.page.example" "Furnace page action example" ARTICLE: "furnace.actions.page" "Furnace page actions" "Page actions implement the common case of an action that simply serves a Chloe template in response to a GET request." -{ $subsection page-action } -{ $subsection } +{ $subsections + page-action + +} "When using a page action, instead of setting the " { $slot "display" } " slot, the " { $slot "template" } " slot is set instead. The " { $slot "init" } ", " { $slot "authorize" } ", " { $slot "validate" } " and " { $slot "submit" } " slots can still be set as usual." $nl "The " { $slot "template" } " slot of a " { $link page-action } " contains a pair with shape " { $snippet "{ responder name }" } ", where " { $snippet "responder" } " is a responder class, usually a subclass of " { $link dispatcher } ", and " { $snippet "name" } " is the name of a template file, without the " { $snippet ".xml" } " extension, relative to the directory containing the responder's vocabulary source file." -{ $subsection "furnace.actions.page.example" } ; +{ $subsections "furnace.actions.page.example" } ; ARTICLE: "furnace.actions.config" "Furnace action configuration" "Actions have the following slots:" @@ -104,10 +106,10 @@ ARTICLE: "furnace.actions.validation" "Form validation with actions" "The action code is set up so that the " { $slot "init" } " quotation can validate query parameters, and the " { $slot "validate" } " quotation can validate POST parameters." $nl "A word to validate parameters and make them available as HTML form values (see " { $link "html.forms.values" } "); typically this word is invoked from the " { $slot "init" } " and " { $slot "validate" } " quotations:" -{ $subsection validate-params } +{ $subsections validate-params } "The above word expects an association list mapping parameter names to validator quotations; validator quotations can use the words in the " "Custom validation logic can invoke a word when validation fails; " { $link validate-params } " invokes this word for you:" -{ $subsection validation-failed } +{ $subsections validation-failed } "If validation fails, no more action code is executed, and the client is redirected back to the originating page, where validation errors can be displayed. Note that validation errors are rendered automatically by the " { $link "html.components" } " words, and in particular, " { $link "html.templates.chloe" } " use these words." ; ARTICLE: "furnace.actions.lifecycle" "Furnace action lifecycle" @@ -133,7 +135,7 @@ ARTICLE: "furnace.actions.lifecycle" "Furnace action lifecycle" ARTICLE: "furnace.actions.impl" "Furnace actions implementation" "The following parametrized constructor should be called from constructors for subclasses of " { $link action } ":" -{ $subsection new-action } ; +{ $subsections new-action } ; ARTICLE: "furnace.actions" "Furnace actions" "The " { $vocab-link "furnace.actions" } " vocabulary implements a type of responder, called an " { $emphasis "action" } ", which handles the form validation lifecycle." @@ -141,18 +143,18 @@ $nl "Other than form validation capability, actions are also often simpler to use than implementing new responders directly, since creating a new class is not required, and the action dispatches on the request type (GET, HEAD, or POST)." $nl "The class of actions:" -{ $subsection action } +{ $subsections action } "Creating a new action:" -{ $subsection } +{ $subsections } "Once created, an action needs to be configured; typically the creation and configuration of an action is encapsulated into a single word:" -{ $subsection "furnace.actions.config" } +{ $subsections "furnace.actions.config" } "Validating forms with actions:" -{ $subsection "furnace.actions.validation" } +{ $subsections "furnace.actions.validation" } "More about the form validation lifecycle:" -{ $subsection "furnace.actions.lifecycle" } +{ $subsections "furnace.actions.lifecycle" } "A convenience class:" -{ $subsection "furnace.actions.page" } +{ $subsections "furnace.actions.page" } "Low-level features:" -{ $subsection "furnace.actions.impl" } ; +{ $subsections "furnace.actions.impl" } ; ABOUT: "furnace.actions" diff --git a/basis/furnace/alloy/alloy-docs.factor b/basis/furnace/alloy/alloy-docs.factor index f21fc237a8..8e073a12ca 100644 --- a/basis/furnace/alloy/alloy-docs.factor +++ b/basis/furnace/alloy/alloy-docs.factor @@ -1,5 +1,5 @@ +USING: help.markup help.syntax db ; IN: furnace.alloy -USING: help.markup help.syntax db multiline ; HELP: init-furnace-tables { $description "Initializes database tables used by asides, conversations and session management. This word must be invoked inside a " { $link with-db } " scope." } ; @@ -10,13 +10,13 @@ HELP: { $examples "The " { $vocab-link "webapps.counter" } " vocabulary uses an alloy to configure the counter:" { $code - <" : counter-db ( -- db ) "counter.db" ; + """: counter-db ( -- db ) "counter.db" ; : run-counter ( -- ) counter-db main-responder set-global - 8080 httpd ;"> + 8080 httpd ;""" } } ; @@ -33,10 +33,10 @@ ARTICLE: "furnace.alloy" "Furnace alloy responder" { $link "furnace.db" } } "A word to wrap a responder in an alloy:" -{ $subsection } +{ $subsections } "Initializing database tables for asides, conversations and sessions:" -{ $subsection init-furnace-tables } +{ $subsections init-furnace-tables } "Start a timer to expire asides, conversations and sessions:" -{ $subsection start-expiring } ; +{ $subsections start-expiring } ; ABOUT: "furnace.alloy" diff --git a/basis/furnace/asides/asides-docs.factor b/basis/furnace/asides/asides-docs.factor index c5b7bdd537..c4ad45c8ea 100644 --- a/basis/furnace/asides/asides-docs.factor +++ b/basis/furnace/asides/asides-docs.factor @@ -21,13 +21,13 @@ ARTICLE: "furnace.asides" "Furnace asides" "The " { $vocab-link "furnace.asides" } " vocabulary provides support for sending a user to a page which can then return to the former location." $nl "To use asides, wrap your responder in an aside responder:" -{ $subsection } +{ $subsections } "The asides responder must be wrapped inside a session responder (" { $link } "), which in turn must be wrapped inside a database persistence responder (" { $link } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one." $nl "Saving the current page in an aside which propagates through " { $link } " responses:" -{ $subsection begin-aside } +{ $subsections begin-aside } "Returning from an aside:" -{ $subsection end-aside } +{ $subsections end-aside } "Asides are used by " { $vocab-link "furnace.auth.login" } "; when the client requests a protected page, an aside begins and the client is redirected to a login page. Upon a successful login, the aside ends and the client returns to the protected page. If the client directly visits the login page and logs in, there is no current aside, so the client is sent to the default URL passed to " { $link end-aside } ", which in the case of login is the root URL." ; ABOUT: "furnace.asides" diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor index efd6a52ef0..c7fc0d5f0b 100644 --- a/basis/furnace/auth/auth-docs.factor +++ b/basis/furnace/auth/auth-docs.factor @@ -1,7 +1,7 @@ USING: assocs classes help.markup help.syntax kernel quotations strings words words.symbol furnace.auth.providers.db checksums.sha furnace.auth.providers math byte-arrays -http multiline ; +http ; IN: furnace.auth HELP: @@ -86,15 +86,17 @@ ARTICLE: "furnace.auth.capabilities" "Authentication capabilities" "Every user in the authentication framework has a set of associated capabilities." $nl "Defining new capabilities:" -{ $subsection define-capability } +{ $subsections define-capability } "Capabilities are stored in a global variable:" -{ $subsection capabilities } +{ $subsections capabilities } "Protected resources can be restricted to users possessing certain capabilities only by storing a sequence of capabilities in the " { $slot "capabilities" } " slot of a " { $link protected } " instance." ; ARTICLE: "furnace.auth.protected" "Protected resources" "To restrict access to authenticated clients only, wrap a responder in a protected responder." -{ $subsection protected } -{ $subsection } +{ $subsections + protected + +} "Protected responders have the following two slots which may be set:" { $table { { $slot "description" } "A string identifying the protected resource for user interface purposes" } @@ -114,79 +116,87 @@ ARTICLE: "furnace.auth.providers" "Authentication providers" "The " { $vocab-link "furnace.auth" } " framework looks up users using an authentication provider. Different authentication providers can be swapped in to implement various authentication strategies." $nl "Each authentication realm has a provider stored in the " { $slot "users" } " slot. The default provider is " { $link users-in-db } "." -{ $subsection "furnace.auth.providers.protocol" } -{ $subsection "furnace.auth.providers.null" } -{ $subsection "furnace.auth.providers.assoc" } -{ $subsection "furnace.auth.providers.db" } ; +{ $subsections + "furnace.auth.providers.protocol" + "furnace.auth.providers.null" + "furnace.auth.providers.assoc" + "furnace.auth.providers.db" +} ; ARTICLE: "furnace.auth.features" "Optional authentication features" "Vocabularies having names prefixed by " { $code "furnace.auth.features" } " implement optional features which can be enabled by calling special words. These words define new actions on an authentication realm." -{ $subsection "furnace.auth.features.deactivate-user" } -{ $subsection "furnace.auth.features.edit-profile" } -{ $subsection "furnace.auth.features.recover-password" } -{ $subsection "furnace.auth.features.registration" } ; +{ $subsections + "furnace.auth.features.deactivate-user" + "furnace.auth.features.edit-profile" + "furnace.auth.features.recover-password" + "furnace.auth.features.registration" +} ; ARTICLE: "furnace.auth.realms" "Authentication realms" "The superclass of authentication realms:" -{ $subsection realm } +{ $subsections realm } "There are two concrete implementations:" -{ $subsection "furnace.auth.basic" } -{ $subsection "furnace.auth.login" } +{ $subsections + "furnace.auth.basic" + "furnace.auth.login" +} "Authentication realms need to be configured after construction." -{ $subsection "furnace.auth.realm-config" } ; +{ $subsections "furnace.auth.realm-config" } ; ARTICLE: "furnace.auth.users" "User profiles" "A responder wrapped in an authentication realm may access the currently logged-in user," -{ $subsection logged-in-user } +{ $subsections logged-in-user } "as well as the logged-in username:" -{ $subsection username } +{ $subsections username } "Values can also be stored in user profile variables:" -{ $subsection uget } -{ $subsection uset } -{ $subsection uchange } +{ $subsections + uget + uset + uchange +} "User profile variables have the same restrictions on their values as session variables; see " { $link "furnace.sessions.serialize" } " for a discussion." ; ARTICLE: "furnace.auth.example" "Furnace authentication example" "The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message âYou must log in to view your todo listâ:" { $code - <" - "view your todo list" >>description"> + """ + "view your todo list" >>description""" } "The " { $vocab-link "webapps.wiki" } " vocabulary defines a mix of protected and unprotected actions. One example of a protected action is that for deleting wiki pages, an action normally reserved for administrators. This action is protected with the following code:" { $code - <" + """ "delete wiki articles" >>description - { can-delete-wiki-articles? } >>capabilities"> + { can-delete-wiki-articles? } >>capabilities""" } "The " { $vocab-link "websites.concatenative" } " vocabulary wraps all of its responders, including the wiki, in a login authentication realm:" { $code -<" : ( responder -- responder' ) +""": ( responder -- responder' ) "Factor website" "Factor website" >>name allow-registration allow-password-recovery allow-edit-profile - allow-deactivation ;"> + allow-deactivation ;""" } ; ARTICLE: "furnace.auth" "Furnace authentication" "The " { $vocab-link "furnace.auth" } " vocabulary implements a pluggable authentication framework." $nl "Usernames and passwords are verified using an " { $emphasis "authentication provider" } "." -{ $subsection "furnace.auth.providers" } +{ $subsections "furnace.auth.providers" } "Users have capabilities assigned to them." -{ $subsection "furnace.auth.capabilities" } +{ $subsections "furnace.auth.capabilities" } "An " { $emphasis "authentication realm" } " is a responder which manages access to protected resources." -{ $subsection "furnace.auth.realms" } +{ $subsections "furnace.auth.realms" } "Actions contained inside an authentication realm can be protected by wrapping them with a responder." -{ $subsection "furnace.auth.protected" } +{ $subsections "furnace.auth.protected" } "Actions contained inside an authentication realm can access the currently logged-in user profile." -{ $subsection "furnace.auth.users" } +{ $subsections "furnace.auth.users" } "Authentication realms can be adorned with additional functionality." -{ $subsection "furnace.auth.features" } +{ $subsections "furnace.auth.features" } "An administration tool." -{ $subsection "furnace.auth.user-admin" } +{ $subsections "furnace.auth.user-admin" } "A concrete example." -{ $subsection "furnace.auth.example" } ; +{ $subsections "furnace.auth.example" } ; ABOUT: "furnace.auth" diff --git a/basis/furnace/auth/basic/basic-docs.factor b/basis/furnace/auth/basic/basic-docs.factor index c0d3184c78..019c308b58 100644 --- a/basis/furnace/auth/basic/basic-docs.factor +++ b/basis/furnace/auth/basic/basic-docs.factor @@ -10,7 +10,9 @@ HELP: basic-auth-realm ARTICLE: "furnace.auth.basic" "Basic authentication" "The " { $vocab-link "furnace.auth.basic" } " vocabulary implements HTTP basic authentication." -{ $subsection basic-auth-realm } -{ $subsection } ; +{ $subsections + basic-auth-realm + +} ; ABOUT: "furnace.auth.basic" diff --git a/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor b/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor index ef4f2e1075..a652e734a1 100644 --- a/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor +++ b/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor @@ -13,9 +13,9 @@ ARTICLE: "furnace.auth.features.deactivate-user" "User profile deactivation" "The " { $vocab-link "furnace.auth.features.deactivate-user" } " vocabulary implements an authentication feature for user profile deactivation, allowing users to voluntarily deactivate their account." $nl "To enable this feature, call the following word on an authentication realm:" -{ $subsection allow-deactivation } +{ $subsections allow-deactivation } "To check if deactivation is enabled:" -{ $subsection allow-deactivation? } +{ $subsections allow-deactivation? } "This feature adds a " { $snippet "deactivate-user" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:" { $code "" diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor b/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor index 6f3c9d151b..1124ad43ec 100644 --- a/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor +++ b/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor @@ -13,9 +13,9 @@ ARTICLE: "furnace.auth.features.edit-profile" "User profile editing" "The " { $vocab-link "furnace.auth.features.edit-profile" } " vocabulary implements an authentication feature for user profile editing, allowing users to change some details of their account." $nl "To enable this feature, call the following word on an authentication realm:" -{ $subsection allow-edit-profile } +{ $subsections allow-edit-profile } "To check if profile editing is enabled:" -{ $subsection allow-edit-profile? } +{ $subsections allow-edit-profile? } "This feature adds an " { $snippet "edit-profile" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:" { $code "" diff --git a/basis/furnace/auth/features/recover-password/recover-password-docs.factor b/basis/furnace/auth/features/recover-password/recover-password-docs.factor index 1dc7e99eff..22fa95f23e 100644 --- a/basis/furnace/auth/features/recover-password/recover-password-docs.factor +++ b/basis/furnace/auth/features/recover-password/recover-password-docs.factor @@ -17,13 +17,13 @@ ARTICLE: "furnace.auth.features.recover-password" "User password recovery" " vocabulary implements an authentication feature for user password recovery, allowing users to get a new password e-mailed to them in the event they forget their current one." $nl "To enable this feature, first call the following word on an authentication realm," -{ $subsection allow-password-recovery } +{ $subsections allow-password-recovery } "Then set a global configuration variable:" -{ $subsection lost-password-from } +{ $subsections lost-password-from } "In addition, the " { $link "smtp" } " may need to be configured as well." $nl "To check if password recovery is enabled:" -{ $subsection allow-password-recovery? } +{ $subsections allow-password-recovery? } "This feature adds a " { $snippet "recover-password" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:" { $code "" diff --git a/basis/furnace/auth/features/registration/registration-docs.factor b/basis/furnace/auth/features/registration/registration-docs.factor index 1f12570173..d64a14c869 100644 --- a/basis/furnace/auth/features/registration/registration-docs.factor +++ b/basis/furnace/auth/features/registration/registration-docs.factor @@ -13,9 +13,9 @@ ARTICLE: "furnace.auth.features.registration" "User registration" "The " { $vocab-link "furnace.auth.features.registration" } " vocabulary implements an authentication feature for user registration, allowing new users to create accounts." $nl "To enable this feature, call the following word on an authentication realm:" -{ $subsection allow-registration } +{ $subsections allow-registration } "To check if user registration is enabled:" -{ $subsection allow-registration? } +{ $subsections allow-registration? } "This feature adds a " { $snippet "register" } " action to the realm. A link to this action is inserted on the login page if the " { $vocab-link "furnace.auth.login" } " authentication realm is used. Links to this action can be inserted from other pages using the following Chloe XML snippet:" { $code "" diff --git a/basis/furnace/auth/login/login-docs.factor b/basis/furnace/auth/login/login-docs.factor index 08b7d933e6..3af0c353a0 100644 --- a/basis/furnace/auth/login/login-docs.factor +++ b/basis/furnace/auth/login/login-docs.factor @@ -13,8 +13,10 @@ HELP: login-realm ARTICLE: "furnace.auth.login" "Login authentication" "The " { $vocab-link "furnace.auth.login" } " vocabulary implements an authentication realm which displays a login page with a username and password field." -{ $subsection login-realm } -{ $subsection } +{ $subsections + login-realm + +} "The " { $snippet "logout" } " action logs the user out of the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:" { $code "Logout" diff --git a/basis/furnace/auth/providers/assoc/assoc-docs.factor b/basis/furnace/auth/providers/assoc/assoc-docs.factor index 61c2ac4eed..6017adb1b9 100644 --- a/basis/furnace/auth/providers/assoc/assoc-docs.factor +++ b/basis/furnace/auth/providers/assoc/assoc-docs.factor @@ -7,8 +7,10 @@ HELP: ARTICLE: "furnace.auth.providers.assoc" "In-memory authentication provider" "The " { $vocab-link "furnace.auth.providers.assoc" } " vocabulary implements an authentication provider which looks up usernames and passwords in an associative mapping." -{ $subsection users-in-memory } -{ $subsection } +{ $subsections + users-in-memory + +} "The " { $slot "assoc" } " slot of the " { $link users-in-memory } " tuple maps usernames to checksums of passwords." ; ABOUT: "furnace.auth.providers.assoc" diff --git a/basis/furnace/auth/providers/db/db-docs.factor b/basis/furnace/auth/providers/db/db-docs.factor index 219edf9490..5e80da545c 100644 --- a/basis/furnace/auth/providers/db/db-docs.factor +++ b/basis/furnace/auth/providers/db/db-docs.factor @@ -8,6 +8,6 @@ ARTICLE: "furnace.auth.providers.db" "Database authentication provider" "The " { $vocab-link "furnace.auth.providers.db" } " vocabulary implements an authentication provider which looks up authentication requests in the " { $snippet "USERS" } " table of the current database. The database schema is Factor-specific, and the table should be initialized by calling" { $code "users create-table" } "The authentication provider class:" -{ $subsection users-in-db } ; +{ $subsections users-in-db } ; ABOUT: "furnace.auth.providers.db" diff --git a/basis/furnace/auth/providers/providers-docs.factor b/basis/furnace/auth/providers/providers-docs.factor index 5d15bf4f65..ef092b285c 100644 --- a/basis/furnace/auth/providers/providers-docs.factor +++ b/basis/furnace/auth/providers/providers-docs.factor @@ -36,10 +36,12 @@ ARTICLE: "furnace.auth.providers.protocol" "Authentication provider protocol" "The " { $vocab-link "furnace.auth.providers" } " vocabulary implements a protocol for persistence and authentication of users." $nl "The class of users:" -{ $subsection user } +{ $subsections user } "Generic protocol:" -{ $subsection get-user } -{ $subsection new-user } -{ $subsection update-user } ; +{ $subsections + get-user + new-user + update-user +} ; ABOUT: "furnace.auth.providers.protocol" diff --git a/basis/furnace/boilerplate/boilerplate-docs.factor b/basis/furnace/boilerplate/boilerplate-docs.factor index ad983c8dc1..c5c9a01a12 100644 --- a/basis/furnace/boilerplate/boilerplate-docs.factor +++ b/basis/furnace/boilerplate/boilerplate-docs.factor @@ -27,9 +27,11 @@ ARTICLE: "furnace.boilerplate.example" "Boilerplate example" ARTICLE: "furnace.boilerplate" "Furnace boilerplate support" "The " { $vocab-link "furnace.boilerplate" } " vocabulary implements a facility for sharing a common header and footer between different pages on a web site. It builds on top of " { $link "html.templates.boilerplate" } "." -{ $subsection } -{ $subsection "furnace.boilerplate.config" } -{ $subsection "furnace.boilerplate.example" } +{ $subsections + + "furnace.boilerplate.config" + "furnace.boilerplate.example" +} { $see-also "html.templates.chloe.tags.boilerplate" } ; ABOUT: "furnace.boilerplate" diff --git a/basis/furnace/conversations/conversations-docs.factor b/basis/furnace/conversations/conversations-docs.factor index 2b644ef422..443384147d 100644 --- a/basis/furnace/conversations/conversations-docs.factor +++ b/basis/furnace/conversations/conversations-docs.factor @@ -37,17 +37,21 @@ $nl "Conversation scope is used by form validation to pass validation errors between requests." $nl "To use conversation scope, wrap your responder in an conversation responder:" -{ $subsection

The Factor programming language

Getting started

Documentation

Command line usage

Source organization

Community