! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.strings alien.c-types alien.data alien.accessors
+USING: alien alien.strings alien.c-types alien.accessors
arrays words sequences math kernel namespaces fry cpu.architecture
-io.encodings.binary io.encodings.utf8 accessors ;
+io.encodings.binary io.encodings.utf8 accessors compiler.units ;
IN: alien.arrays
INSTANCE: array value-type
M: array stack-size drop void* stack-size ;
-M: array c-type-boxer-quot
- unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
-
-M: array c-type-unboxer-quot drop [ >c-ptr ] ;
-
PREDICATE: string-type < pair
first2 [ c-string = ] [ word? ] bi* and ;
M: string-type c-type-setter
drop [ set-alien-cell ] ;
-{ c-string utf8 } c-string typedef
+[ { c-string utf8 } c-string typedef ] with-compilation-unit
! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
-USING: accessors alien alien.c-types alien.strings arrays
+USING: accessors alien alien.c-types alien.arrays alien.strings arrays
byte-arrays cpu.architecture fry io io.encodings.binary
io.files io.streams.memory kernel libc math sequences words
byte-vectors ;
M: value-type c-type-setter ( type -- quot )
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;
+
+M: array c-type-boxer-quot
+ unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
+
+M: array c-type-unboxer-quot drop [ >c-ptr ] ;
+
: function-effect ( names return -- effect )
[ { } ] [ return-type-name 1array ] if-void <effect> ;
-:: make-function ( return function library types names -- word quot effect )
- function create-in dup reset-generic
+: create-function ( name -- word )
+ create-in dup reset-generic ;
+
+:: (make-function) ( return function library types names -- quot effect )
return library function types function-quot
names return function-effect ;
-: (FUNCTION:) ( -- word quot effect )
- scan-function-name current-library get ";" scan-c-args make-function ;
+:: make-function ( return function library types names -- word quot effect )
+ function create-function
+ return function library types names (make-function) ;
+
+: (FUNCTION:) ( -- return function library types names )
+ scan-function-name current-library get ";" scan-c-args ;
: callback-quot ( return types abi -- quot )
'[ [ _ _ _ ] dip alien-callback ] ;
current-library get
scan-function-name ";" scan-c-args make-callback-type ;
-PREDICATE: alien-function-word < word
+PREDICATE: alien-function-alias-word < word
def>> {
[ length 5 = ]
[ last \ alien-invoke eq? ]
} 1&& ;
+PREDICATE: alien-function-word < alien-function-alias-word
+ [ def>> third ] [ name>> ] bi = ;
+
PREDICATE: alien-callback-type-word < typedef-word
"callback-effect" word-prop ;
: pprint-library ( library -- )
[ \ LIBRARY: [ text ] pprint-prefix ] when* ;
+: pprint-function ( word quot -- )
+ [ def>> first pprint-c-type ]
+ swap
+ [
+ <block "(" text
+ [ def>> fourth ] [ stack-effect in>> ] bi
+ pprint-function-args
+ ")" text block>
+ ] tri ; inline
+
+M: alien-function-alias-word definer
+ drop \ FUNCTION-ALIAS: \ ; ;
+M: alien-function-alias-word definition drop f ;
+M: alien-function-alias-word synopsis*
+ {
+ [ seeing-word ]
+ [ def>> second pprint-library ]
+ [ definer. ]
+ [ pprint-word ]
+ [ [ def>> third text ] pprint-function ]
+ } cleave ;
+
M: alien-function-word definer
drop \ FUNCTION: \ ; ;
-M: alien-function-word definition drop f ;
M: alien-function-word synopsis*
{
[ seeing-word ]
[ def>> second pprint-library ]
[ definer. ]
- [ def>> first pprint-c-type ]
- [ pprint-word ]
- [
- <block "(" text
- [ def>> fourth ] [ stack-effect in>> ] bi
- pprint-function-args
- ")" text block>
- ]
+ [ [ pprint-word ] pprint-function ]
} cleave ;
M: alien-callback-type-word definer
{ $notes "Logical library names are defined with the " { $link add-library } " word." } ;
HELP: FUNCTION:
-{ $syntax "FUNCTION: return name ( parameters )" }
+{ $syntax "FUNCTION: return name ( parameters ) ;" }
{ $values { "return" "a C return type" } { "name" "a C function name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
-{ $description "Defines a new word " { $snippet "name" } " which calls a C library function with the same name, in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
+{ $description "Defines a new word " { $snippet "name" } " which calls the C library function with the same " { $snippet "name" } " in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
$nl
"The new word must be compiled before being executed." }
{ $examples
"The answer to the question is 42."
} }
"Using the " { $link c-string } " type instead of " { $snippet "char*" } " causes the FFI to automatically convert Factor strings to C strings. See " { $link "c-strings" } " for more information on using strings with the FFI."
-{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted; they serve no purpose other than to make the declaration slightly easier to read:"
+{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted; they serve no purpose other than to make the declaration easier to read. The following definitions are equivalent:"
{ $code
"FUNCTION: void glHint ( GLenum target, GLenum mode ) ;"
"FUNCTION: void glHint GLenum target GLenum mode ;"
-} } ;
+}
+"To make a Factor word with a name different from the C function, use " { $link POSTPONE: FUNCTION-ALIAS: } "." } ;
+
+HELP: FUNCTION-ALIAS:
+{ $syntax "FUNCTION-ALIAS: factor-name
+ return c_name ( parameters ) ;" }
+{ $values { "factor-name" "a Factor word name" } { "return" "a C return type" } { "name" "a C function name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
+{ $description "Defines a new word " { $snippet "factor-name" } " which calls the C library function named " { $snippet "c_name" } " in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
+$nl
+"The new word must be compiled before being executed." }
+{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted. They serve no purpose other than to make the declaration easier to read." } ;
+
+{ POSTPONE: FUNCTION: POSTPONE: FUNCTION-ALIAS: } related-words
HELP: TYPEDEF:
{ $syntax "TYPEDEF: old new" }
SYNTAX: LIBRARY: scan current-library set ;
SYNTAX: FUNCTION:
- (FUNCTION:) define-declared ;
+ (FUNCTION:) make-function define-declared ;
+
+SYNTAX: FUNCTION-ALIAS:
+ scan create-function
+ (FUNCTION:) (make-function) define-declared ;
SYNTAX: CALLBACK:
(CALLBACK:) define-inline ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry kernel sequences assocs accessors namespaces
+USING: fry kernel sequences assocs accessors
math.intervals arrays classes.algebra combinators columns
-stack-checker.branches locals math
+stack-checker.branches locals math namespaces
compiler.utilities
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.nodes
compiler.tree.propagation.simple
compiler.tree.propagation.constraints ;
+FROM: sets => union ;
+FROM: assocs => change-at ;
IN: compiler.tree.propagation.branches
! For conditionals, an assoc of child node # --> constraint
bi ;
:: update-constraints ( new old -- )
- new [| key value | key old [ value append ] change-at ] assoc-each ;
+ new [| key value | key old [ value union ] change-at ] assoc-each ;
: include-child-constraints ( i -- )
infer-children-data get nth constraints swap at last
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs math math.intervals kernel accessors
sequences namespaces classes classes.algebra
C: --> implication
+: maybe-add ( elt seq -- seq' )
+ 2dup member? [ nip ] [ swap suffix ] if ;
+
: assume-implication ( q p -- )
- [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ]
+ [ constraints get [ assoc-stack maybe-add ] 2keep last set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
M: implication assume*
compiler
-untested
+not loaded
-untested
+not loaded
compiler
-untested
+not loaded
compiler
-untested
+not loaded
compiler
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
! Bind the same function as above, but for unsigned 64bit integers
-: sqlite3-bind-uint64 ( pStmt index in64 -- int )
- int "sqlite" "sqlite3_bind_int64"
- { pointer: sqlite3_stmt int sqlite3_uint64 } alien-invoke ;
+FUNCTION-ALIAS: sqlite3-bind-uint64
+ int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_uint64 in64 ) ;
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, c-string text, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, c-string name ) ;
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
! Bind the same function as above, but for unsigned 64bit integers
-: sqlite3-column-uint64 ( pStmt col -- uint64 )
- sqlite3_uint64 "sqlite" "sqlite3_column_int64"
- { pointer: sqlite3_stmt int } alien-invoke ;
+FUNCTION-ALIAS: sqlite3-column-uint64
+ sqlite3_uint64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: c-string sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: c-string sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
"USING: formatting ;"
"1.23456789 \"%.3f\" printf"
"1.235" }
- { $example
- "USING: formatting ;"
- "1234567890 \"%.5e\" printf"
- "1.23457e+09" }
{ $example
"USING: formatting ;"
"12 \"%'#4d\" printf"
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: calendar kernel formatting tools.test ;
+USING: calendar kernel formatting tools.test system ;
IN: formatting.tests
[ "%s" printf ] must-infer
[ "%s" sprintf ] must-infer
-[ t ] [ "" "" sprintf = ] unit-test
-[ t ] [ "asdf" "asdf" sprintf = ] unit-test
-[ t ] [ "10" 10 "%d" sprintf = ] unit-test
-[ t ] [ "+10" 10 "%+d" sprintf = ] unit-test
-[ t ] [ "-10" -10 "%d" sprintf = ] unit-test
-[ t ] [ " -10" -10 "%5d" sprintf = ] unit-test
-[ t ] [ "-0010" -10 "%05d" sprintf = ] unit-test
-[ t ] [ "+0010" 10 "%+05d" sprintf = ] unit-test
-[ t ] [ "123.456000" 123.456 "%f" sprintf = ] unit-test
-[ t ] [ "2.44" 2.436 "%.2f" sprintf = ] unit-test
-[ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test
-[ t ] [ "1.2346" 1.23456789 "%.4f" sprintf = ] unit-test
-[ t ] [ " 1.23" 1.23456789 "%6.2f" sprintf = ] unit-test
-[ t ] [ "1.234000e+08" 123400000 "%e" sprintf = ] unit-test
-[ t ] [ "-1.234000e+08" -123400000 "%e" sprintf = ] unit-test
-[ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test
-[ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test
-[ t ] [ "2.500000e-03" 0.0025 "%e" sprintf = ] unit-test
-[ t ] [ "2.500000E-03" 0.0025 "%E" sprintf = ] unit-test
-[ t ] [ " 1.0E+01" 10 "%10.1E" sprintf = ] unit-test
-[ t ] [ " -1.0E+01" -10 "%10.1E" sprintf = ] unit-test
-[ t ] [ " -1.0E+01" -10 "%+10.1E" sprintf = ] unit-test
-[ t ] [ " +1.0E+01" 10 "%+10.1E" sprintf = ] unit-test
-[ t ] [ "-001.0E+01" -10 "%+010.1E" sprintf = ] unit-test
-[ t ] [ "+001.0E+01" 10 "%+010.1E" sprintf = ] unit-test
-[ t ] [ "ff" HEX: ff "%x" sprintf = ] unit-test
-[ t ] [ "FF" HEX: ff "%X" sprintf = ] unit-test
-[ t ] [ "0f" HEX: f "%02x" sprintf = ] unit-test
-[ t ] [ "0F" HEX: f "%02X" sprintf = ] unit-test
-[ t ] [ "2008-09-10"
- 2008 9 10 "%04d-%02d-%02d" sprintf = ] unit-test
-[ t ] [ "Hello, World!"
- "Hello, World!" "%s" sprintf = ] unit-test
-[ t ] [ "printf test"
- "printf test" sprintf = ] unit-test
-[ t ] [ "char a = 'a'"
- CHAR: a "char %c = 'a'" sprintf = ] unit-test
-[ t ] [ "00" HEX: 0 "%02x" sprintf = ] unit-test
-[ t ] [ "ff" HEX: ff "%02x" sprintf = ] unit-test
-[ t ] [ "0 message(s)"
- 0 "message" "%d %s(s)" sprintf = ] unit-test
-[ t ] [ "0 message(s) with %"
- 0 "message" "%d %s(s) with %%" sprintf = ] unit-test
-[ t ] [ "justif: \"left \""
- "left" "justif: \"%-10s\"" sprintf = ] unit-test
-[ t ] [ "justif: \" right\""
- "right" "justif: \"%10s\"" sprintf = ] unit-test
-[ t ] [ " 3: 0003 zero padded"
- 3 " 3: %04d zero padded" sprintf = ] unit-test
-[ t ] [ " 3: 3 left justif"
- 3 " 3: %-4d left justif" sprintf = ] unit-test
-[ t ] [ " 3: 3 right justif"
- 3 " 3: %4d right justif" sprintf = ] unit-test
-[ t ] [ " -3: -003 zero padded"
- -3 " -3: %04d zero padded" sprintf = ] unit-test
-[ t ] [ " -3: -3 left justif"
- -3 " -3: %-4d left justif" sprintf = ] unit-test
-[ t ] [ " -3: -3 right justif"
- -3 " -3: %4d right justif" sprintf = ] unit-test
-[ t ] [ "There are 10 monkeys in the kitchen"
- 10 "kitchen" "There are %d monkeys in the %s" sprintf = ] unit-test
-[ f ] [ "%d" 10 "%d" sprintf = ] unit-test
-[ t ] [ "[monkey]" "monkey" "[%s]" sprintf = ] unit-test
-[ t ] [ "[ monkey]" "monkey" "[%10s]" sprintf = ] unit-test
-[ t ] [ "[monkey ]" "monkey" "[%-10s]" sprintf = ] unit-test
-[ t ] [ "[0000monkey]" "monkey" "[%010s]" sprintf = ] unit-test
-[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
-[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test
+[ "" ] [ "" sprintf ] unit-test
+[ "asdf" ] [ "asdf" sprintf ] unit-test
+[ "10" ] [ 10 "%d" sprintf ] unit-test
+[ "+10" ] [ 10 "%+d" sprintf ] unit-test
+[ "-10" ] [ -10 "%d" sprintf ] unit-test
+[ " -10" ] [ -10 "%5d" sprintf ] unit-test
+[ "-0010" ] [ -10 "%05d" sprintf ] unit-test
+[ "+0010" ] [ 10 "%+05d" sprintf ] unit-test
+[ "123.456000" ] [ 123.456 "%f" sprintf ] unit-test
+[ "2.44" ] [ 2.436 "%.2f" sprintf ] unit-test
+[ "8.950" ] [ 8.950179003580072 "%.3f" sprintf ] unit-test
+[ "123.10" ] [ 123.1 "%01.2f" sprintf ] unit-test
+[ "1.2346" ] [ 1.23456789 "%.4f" sprintf ] unit-test
+[ " 1.23" ] [ 1.23456789 "%6.2f" sprintf ] unit-test
-[ t ] [ "{ 1, 2, 3 }" { 1 2 3 } "%[%s, %]" sprintf = ] unit-test
-[ t ] [ "{ 1:2, 3:4 }" H{ { 1 2 } { 3 4 } } "%[%s: %s %]" sprintf = ] unit-test
+os windows? [
+ [ "1.234000e+008" ] [ 123400000 "%e" sprintf ] unit-test
+ [ "-1.234000e+008" ] [ -123400000 "%e" sprintf ] unit-test
+ [ "1.234567e+008" ] [ 123456700 "%e" sprintf ] unit-test
+ [ "3.625e+008" ] [ 362525200 "%.3e" sprintf ] unit-test
+ [ "2.500000e-003" ] [ 0.0025 "%e" sprintf ] unit-test
+ [ "2.500000E-003" ] [ 0.0025 "%E" sprintf ] unit-test
+ [ " 1.0E+001" ] [ 10 "%11.1E" sprintf ] unit-test
+ [ " -1.0E+001" ] [ -10 "%11.1E" sprintf ] unit-test
+ [ " -1.0E+001" ] [ -10 "%+11.1E" sprintf ] unit-test
+ [ " +1.0E+001" ] [ 10 "%+11.1E" sprintf ] unit-test
+ [ "-001.0E+001" ] [ -10 "%+011.1E" sprintf ] unit-test
+ [ "+001.0E+001" ] [ 10 "%+011.1E" sprintf ] unit-test
+] [
+ [ "1.234000e+08" ] [ 123400000 "%e" sprintf ] unit-test
+ [ "-1.234000e+08" ] [ -123400000 "%e" sprintf ] unit-test
+ [ "1.234567e+08" ] [ 123456700 "%e" sprintf ] unit-test
+ [ "3.625e+08" ] [ 362525200 "%.3e" sprintf ] unit-test
+ [ "2.500000e-03" ] [ 0.0025 "%e" sprintf ] unit-test
+ [ "2.500000E-03" ] [ 0.0025 "%E" sprintf ] unit-test
+ [ " 1.0E+01" ] [ 10 "%10.1E" sprintf ] unit-test
+ [ " -1.0E+01" ] [ -10 "%10.1E" sprintf ] unit-test
+ [ " -1.0E+01" ] [ -10 "%+10.1E" sprintf ] unit-test
+ [ " +1.0E+01" ] [ 10 "%+10.1E" sprintf ] unit-test
+ [ "-001.0E+01" ] [ -10 "%+010.1E" sprintf ] unit-test
+ [ "+001.0E+01" ] [ 10 "%+010.1E" sprintf ] unit-test
+] if
+
+[ "ff" ] [ HEX: ff "%x" sprintf ] unit-test
+[ "FF" ] [ HEX: ff "%X" sprintf ] unit-test
+[ "0f" ] [ HEX: f "%02x" sprintf ] unit-test
+[ "0F" ] [ HEX: f "%02X" sprintf ] unit-test
+[ "2008-09-10" ] [ 2008 9 10 "%04d-%02d-%02d" sprintf ] unit-test
+[ "Hello, World!" ] [ "Hello, World!" "%s" sprintf ] unit-test
+[ "printf test" ] [ "printf test" sprintf ] unit-test
+[ "char a = 'a'" ] [ CHAR: a "char %c = 'a'" sprintf ] unit-test
+[ "00" ] [ HEX: 0 "%02x" sprintf ] unit-test
+[ "ff" ] [ HEX: ff "%02x" sprintf ] unit-test
+[ "0 message(s)" ] [ 0 "message" "%d %s(s)" sprintf ] unit-test
+[ "0 message(s) with %" ] [ 0 "message" "%d %s(s) with %%" sprintf ] unit-test
+[ "justif: \"left \"" ] [ "left" "justif: \"%-10s\"" sprintf ] unit-test
+[ "justif: \" right\"" ] [ "right" "justif: \"%10s\"" sprintf ] unit-test
+[ " 3: 0003 zero padded" ] [ 3 " 3: %04d zero padded" sprintf ] unit-test
+[ " 3: 3 left justif" ] [ 3 " 3: %-4d left justif" sprintf ] unit-test
+[ " 3: 3 right justif" ] [ 3 " 3: %4d right justif" sprintf ] unit-test
+[ " -3: -003 zero padded" ] [ -3 " -3: %04d zero padded" sprintf ] unit-test
+[ " -3: -3 left justif" ] [ -3 " -3: %-4d left justif" sprintf ] unit-test
+[ " -3: -3 right justif" ] [ -3 " -3: %4d right justif" sprintf ] unit-test
+[ "There are 10 monkeys in the kitchen" ] [ 10 "kitchen" "There are %d monkeys in the %s" sprintf ] unit-test
+[ "10" ] [ 10 "%d" sprintf ] unit-test
+[ "[monkey]" ] [ "monkey" "[%s]" sprintf ] unit-test
+[ "[ monkey]" ] [ "monkey" "[%10s]" sprintf ] unit-test
+[ "[monkey ]" ] [ "monkey" "[%-10s]" sprintf ] unit-test
+[ "[0000monkey]" ] [ "monkey" "[%010s]" sprintf ] unit-test
+[ "[####monkey]" ] [ "monkey" "[%'#10s]" sprintf ] unit-test
+[ "[many monke]" ] [ "many monkeys" "[%10.10s]" sprintf ] unit-test
+
+[ "{ 1, 2, 3 }" ] [ { 1 2 3 } "%[%s, %]" sprintf ] unit-test
+[ "{ 1:2, 3:4 }" ] [ H{ { 1 2 } { 3 4 } } "%[%s: %s %]" sprintf ] unit-test
[ "%H:%M:%S" strftime ] must-infer
[ t ] [ "October" testtime "%B" strftime = ] unit-test
[ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test
[ t ] [ "PM" testtime "%p" strftime = ] unit-test
-
-
USING: accessors arrays assocs calendar combinators fry kernel
generalizations io io.streams.string macros math math.functions
math.parser peg.ebnf quotations sequences splitting strings
-unicode.categories unicode.case vectors combinators.smart ;
+unicode.categories unicode.case vectors combinators.smart
+present ;
+FROM: math.parser.private => format-float ;
IN: formatting
<PRIVATE
: >digits ( string -- digits )
[ 0 ] [ string>number ] if-empty ;
-: pad-digits ( string digits -- string' )
- [ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ;
+: format-simple ( x digits string -- string )
+ [ [ >float ] [ number>string ] bi* "%." ] dip
+ surround format-float ;
-: max-digits ( n digits -- n' )
- 10^ [ * round ] keep / ; inline
+: format-scientific ( x digits -- string ) "e" format-simple ;
-: >exp ( x -- exp base )
- [
- abs 0 swap
- [ dup [ 10.0 >= ] [ 1.0 < ] bi or ]
- [ dup 10.0 >=
- [ 10.0 / [ 1 + ] dip ]
- [ 10.0 * [ 1 - ] dip ] if
- ] while
- ] keep 0 < [ neg ] when ;
-
-: exp>string ( exp base digits -- string )
- [ max-digits ] keep -rot
- [
- [ 0 < "-" "+" ? ]
- [ abs number>string 2 CHAR: 0 pad-head ] bi
- "e" -rot 3append
- ]
- [ number>string ] bi*
- rot pad-digits prepend ;
+: format-decimal ( x digits -- string ) "f" format-simple ;
+
+ERROR: unknown-printf-directive ;
EBNF: parse-printf
fmt-% = "%" => [[ [ "%" ] ]]
fmt-c = "c" => [[ [ 1string ] ]]
fmt-C = "C" => [[ [ 1string >upper ] ]]
-fmt-s = "s" => [[ [ dup number? [ number>string ] when ] ]]
-fmt-S = "S" => [[ [ dup number? [ number>string ] when >upper ] ]]
-fmt-d = "d" => [[ [ >fixnum number>string ] ]]
-fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]]
-fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]]
-fmt-f = digits "f" => [[ first dup '[ >float _ max-digits number>string _ pad-digits ] ]]
+fmt-s = "s" => [[ [ present ] ]]
+fmt-S = "S" => [[ [ present >upper ] ]]
+fmt-d = "d" => [[ [ >integer number>string ] ]]
+fmt-e = digits "e" => [[ first '[ _ format-scientific ] ]]
+fmt-E = digits "E" => [[ first '[ _ format-scientific >upper ] ]]
+fmt-f = digits "f" => [[ first '[ _ format-decimal ] ]]
fmt-x = "x" => [[ [ >hex ] ]]
fmt-X = "X" => [[ [ >hex >upper ] ]]
-unknown = (.)* => [[ "Unknown directive" throw ]]
+unknown = (.)* => [[ unknown-printf-directive ]]
strings_ = fmt-c|fmt-C|fmt-s|fmt-S
strings = pad width strings_ => [[ reverse compose-all ]]
] when ;
: spawn-process ( process -- * )
- [ setup-priority ] [ 250 _exit ] recover
- [ setup-redirection ] [ 251 _exit ] recover
- [ current-directory get absolute-path cd ] [ 252 _exit ] recover
- [ setup-environment ] [ 253 _exit ] recover
- [ get-arguments exec-args-with-path ] [ 254 _exit ] recover
- 255 _exit ;
+ [ setup-priority ] [ 2drop 250 _exit ] recover
+ [ setup-redirection ] [ 2drop 251 _exit ] recover
+ [ current-directory get absolute-path cd ] [ 2drop 252 _exit ] recover
+ [ setup-environment ] [ 2drop 253 _exit ] recover
+ [ get-arguments exec-args-with-path ] [ 2drop 254 _exit ] recover
+ 255 _exit
+ f throw ;
M: unix current-process-handle ( -- handle ) getpid ;
! Copyright (C) 2007, 2010 Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types assocs continuations alien.destructors kernel
-namespaces accessors sets summary destructors destructors.private ;
+USING: alien alien.c-types alien.syntax assocs continuations
+alien.destructors kernel namespaces accessors sets summary
+destructors destructors.private ;
IN: libc
-: errno ( -- int )
- int "factor" "err_no" { } alien-invoke ;
+LIBRARY: factor
-: set-errno ( int -- )
- void "factor" "set_err_no" { int } alien-invoke ;
+FUNCTION-ALIAS: errno
+ int err_no ( ) ;
+
+FUNCTION-ALIAS: set-errno
+ void set_err_no ( int err-no ) ;
: clear-errno ( -- )
0 set-errno ;
: preserve-errno ( quot -- )
errno [ call ] dip set-errno ; inline
-: (malloc) ( size -- alien )
- void* "libc" "malloc" { ulong } alien-invoke ;
+LIBRARY: libc
+
+FUNCTION-ALIAS: (malloc)
+ void* malloc ( ulong size ) ;
-: (calloc) ( count size -- alien )
- void* "libc" "calloc" { ulong ulong } alien-invoke ;
+FUNCTION-ALIAS: (calloc)
+ void* calloc ( ulong count, ulong size ) ;
-: (free) ( alien -- )
- void "libc" "free" { void* } alien-invoke ;
+FUNCTION-ALIAS: (free)
+ void free ( void* alien ) ;
-: (realloc) ( alien size -- newalien )
- void* "libc" "realloc" { void* ulong } alien-invoke ;
+FUNCTION-ALIAS: (realloc)
+ void* realloc ( void* alien, ulong size ) ;
<PRIVATE
: free ( alien -- )
>c-ptr [ delete-malloc ] [ (free) ] bi ;
-: memcpy ( dst src size -- )
- void "libc" "memcpy" { void* void* ulong } alien-invoke ;
+FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ;
-: memcmp ( a b size -- cmp )
- int "libc" "memcmp" { void* void* ulong } alien-invoke ;
+FUNCTION: int memcmp ( void* a, void* b, ulong size ) ;
: memory= ( a b size -- ? )
memcmp 0 = ;
-: strlen ( alien -- len )
- size_t "libc" "strlen" { c-string } alien-invoke ;
+FUNCTION: size_t strlen ( c-string alien ) ;
DESTRUCTOR: free
+DESTRUCTOR: (free)
ABOUT: "math.libm"
HELP: facos
-{ $values { "x" real } { "y" real } }
+{ $values { "x" real } { "double" real } }
{ $description "Calls the inverse trigonometric cosine function from the C standard library. User code should call " { $link acos } " instead." } ;
HELP: fasin
-{ $values { "x" real } { "y" real } }
+{ $values { "x" real } { "double" real } }
{ $description "Calls the inverse trigonometric sine function from the C standard library. User code should call " { $link asin } " instead." } ;
HELP: fatan
-{ $values { "x" real } { "y" real } }
+{ $values { "x" real } { "double" real } }
{ $description "Calls the inverse trigonometric tangent function from the C standard library. User code should call " { $link atan } " instead." } ;
HELP: fatan2
-{ $values { "x" real } { "y" real } { "z" real } }
+{ $values { "x" real } { "y" real } { "double" real } }
{ $description "Calls the two-parameter inverse trigonometric tangent function from the C standard library. User code should call " { $link arg } " instead." } ;
HELP: fcos
-{ $values { "x" real } { "y" real } }
+{ $values { "x" real } { "double" real } }
{ $description "Calls the trigonometric cosine function from the C standard library. User code should call " { $link cos } " instead." } ;
HELP: fsin
-{ $values { "x" real } { "y" real } }
+{ $values { "x" real } { "double" real } }
{ $description "Calls the trigonometric sine function from the C standard library. User code should call " { $link sin } " instead." } ;
HELP: fcosh
-{ $values { "x" real } { "y" real } }
+{ $values { "x" real } { "double" real } }
{ $description "Calls the hyperbolic cosine function from the C standard library. User code should call " { $link cosh } " instead." } ;
HELP: fsinh
-{ $values { "x" real } { "y" real } }
+{ $values { "x" real } { "double" real } }
{ $description "Calls the hyperbolic sine function from the C standard library. User code should call " { $link sinh } " instead." } ;
HELP: fexp
-{ $values { "x" real } { "y" real } }
+{ $values { "x" real } { "double" real } }
{ $description "Calls the exponential function (" { $snippet "y=e^x" } " from the C standard library. User code should call " { $link exp } " instead." } ;
HELP: flog
-{ $values { "x" real } { "y" real } }
+{ $values { "x" real } { "double" real } }
{ $description "Calls the natural logarithm function from the C standard library. User code should call " { $link log } " instead." } ;
HELP: flog10
-{ $values { "x" real } { "y" real } }
+{ $values { "x" real } { "double" real } }
{ $description "Calls the base 10 logarithm function from the C standard library. User code should call " { $link log10 } " instead." } ;
HELP: fpow
-{ $values { "x" real } { "y" real } { "z" real } }
+{ $values { "x" real } { "y" real } { "double" real } }
{ $description "Calls the power function (" { $snippet "z=x^y" } ") from the C standard library. User code should call " { $link ^ } " instead." } ;
HELP: fsqrt
-{ $values { "x" real } { "y" real } }
+{ $values { "x" real } { "double" real } }
{ $description "Calls the square root function from the C standard library. User code should call " { $link sqrt } " instead." } ;
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types ;
+USING: alien alien.c-types alien.syntax ;
IN: math.libm
-: facos ( x -- y )
- double "libm" "acos" { double } alien-invoke ;
+LIBRARY: libm
-: fasin ( x -- y )
- double "libm" "asin" { double } alien-invoke ;
+FUNCTION-ALIAS: facos
+ double acos ( double x ) ;
-: fatan ( x -- y )
- double "libm" "atan" { double } alien-invoke ;
+FUNCTION-ALIAS: fasin
+ double asin ( double x ) ;
-: fatan2 ( x y -- z )
- double "libm" "atan2" { double double } alien-invoke ;
+FUNCTION-ALIAS: fatan
+ double atan ( double x ) ;
-: fcos ( x -- y )
- double "libm" "cos" { double } alien-invoke ;
+FUNCTION-ALIAS: fatan2
+ double atan2 ( double x, double y ) ;
-: fsin ( x -- y )
- double "libm" "sin" { double } alien-invoke ;
+FUNCTION-ALIAS: fcos
+ double cos ( double x ) ;
-: ftan ( x -- y )
- double "libm" "tan" { double } alien-invoke ;
+FUNCTION-ALIAS: fsin
+ double sin ( double x ) ;
-: fcosh ( x -- y )
- double "libm" "cosh" { double } alien-invoke ;
+FUNCTION-ALIAS: ftan
+ double tan ( double x ) ;
-: fsinh ( x -- y )
- double "libm" "sinh" { double } alien-invoke ;
+FUNCTION-ALIAS: fcosh
+ double cosh ( double x ) ;
-: ftanh ( x -- y )
- double "libm" "tanh" { double } alien-invoke ;
+FUNCTION-ALIAS: fsinh
+ double sinh ( double x ) ;
-: fexp ( x -- y )
- double "libm" "exp" { double } alien-invoke ;
+FUNCTION-ALIAS: ftanh
+ double tanh ( double x ) ;
-: flog ( x -- y )
- double "libm" "log" { double } alien-invoke ;
+FUNCTION-ALIAS: fexp
+ double exp ( double x ) ;
-: flog10 ( x -- y )
- double "libm" "log10" { double } alien-invoke ;
+FUNCTION-ALIAS: flog
+ double log ( double x ) ;
-: fpow ( x y -- z )
- double "libm" "pow" { double double } alien-invoke ;
+FUNCTION-ALIAS: flog10
+ double log10 ( double x ) ;
-: fsqrt ( x -- y )
- double "libm" "sqrt" { double } alien-invoke ;
+FUNCTION-ALIAS: fpow
+ double pow ( double x, double y ) ;
+
+FUNCTION-ALIAS: fsqrt
+ double sqrt ( double x ) ;
! Windows doesn't have these...
-: flog1+ ( x -- y )
- double "libm" "log1p" { double } alien-invoke ;
+FUNCTION-ALIAS: flog1+
+ double log1p ( double x ) ;
-: facosh ( x -- y )
- double "libm" "acosh" { double } alien-invoke ;
+FUNCTION-ALIAS: facosh
+ double acosh ( double x ) ;
-: fasinh ( x -- y )
- double "libm" "asinh" { double } alien-invoke ;
+FUNCTION-ALIAS: fasinh
+ double asinh ( double x ) ;
-: fatanh ( x -- y )
- double "libm" "atanh" { double } alien-invoke ;
+FUNCTION-ALIAS: fatanh
+ double atanh ( double x ) ;
\ (dlsym) { byte-array object } { c-ptr } define-primitive
\ (exists?) { string } { object } define-primitive
\ (exit) { integer } { } define-primitive
-\ (float>string) { float } { byte-array } define-primitive \ (float>string) make-foldable
+\ (format-float) { float byte-array } { byte-array } define-primitive \ (format-float) make-foldable
\ (fopen) { byte-array byte-array } { alien } define-primitive
\ (identity-hashcode) { object } { fixnum } define-primitive
\ (save-image) { byte-array byte-array } { } define-primitive
! See http://factorcode.org/license.txt for BSD license.
USING: unix alien alien.c-types kernel math sequences strings
io.backend.unix splitting io.encodings.utf8 io.encodings.string
-specialized-arrays ;
+specialized-arrays alien.syntax ;
SPECIALIZED-ARRAY: char
IN: system-info.linux
-: (uname) ( buf -- int )
- int f "uname" { c-string } alien-invoke ;
+FUNCTION-ALIAS: (uname)
+ int uname ( c-string buf ) ;
: uname ( -- seq )
65536 <char-array> [ (uname) io-error ] keep
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators compiler.units
continuations debugger effects fry generalizations io io.files
-io.styles kernel lexer locals macros math.parser namespaces parser
-vocabs.parser prettyprint quotations sequences source-files splitting
-stack-checker summary unicode.case vectors vocabs vocabs.loader
-vocabs.files words tools.errors source-files.errors io.streams.string
-make compiler.errors ;
+io.styles kernel lexer locals macros math.parser namespaces
+parser vocabs.parser prettyprint quotations sequences
+source-files splitting stack-checker summary unicode.case
+vectors vocabs vocabs.loader vocabs.files vocabs.metadata words
+tools.errors source-files.errors io.streams.string make
+compiler.errors ;
IN: tools.test
TUPLE: test-failure < source-file-error continuation ;
forget-tests? get
[ [ [ forget-source ] each ] with-compilation-unit ] [ drop ] if ;
-: run-vocab-tests ( vocab -- )
+: test-vocab ( vocab -- )
vocab dup [
dup source-loaded?>> [
vocab-tests
] [ drop ] if
] [ drop ] if ;
+: test-vocabs ( vocabs -- ) [ test-vocab ] each ;
+
PRIVATE>
TEST: unit-test
: :test-failures ( -- ) test-failures get errors. ;
-: test ( prefix -- )
- child-vocabs [ run-vocab-tests ] each ;
+: test ( prefix -- ) child-vocabs test-vocabs ;
-: test-all ( -- ) "" test ;
+: test-all ( -- ) vocabs filter-don't-test test-vocabs ;
[ [ first ] [ ] bi ] dip exec-with-env ;
: with-fork ( child parent -- )
- [ [ fork-process dup zero? ] dip '[ drop @ ] ] dip
- if ; inline
+ [ fork-process ] 2dip if-zero ; inline
CONSTANT: SIGKILL 9
CONSTANT: SIGTERM 15
: close-file ( fd -- ) [ close ] unix-system-call drop ;
-: _exit ( status -- * )
- #! We throw to give this a terminating stack effect.
- int f "_exit" { int } alien-invoke "Exit failed" throw ;
+FUNCTION: int _exit ( int status ) ;
M: unix open-file [ open ] unix-system-call ;
\r
<PRIVATE\r
\r
-: filter-unportable ( seq -- seq' )\r
- [ vocab-name unportable? not ] filter ;\r
-\r
: collect-vocabs ( quot -- seq )\r
[ all-vocabs-recursive no-roots no-prefixes ] dip\r
gather natural-sort ; inline\r
: (load) ( prefix -- failures )\r
[ child-vocabs-recursive no-roots no-prefixes ]\r
[ dup find-vocab-root [ >vocab-link prefix ] [ drop ] if ] bi\r
- filter-unportable\r
+ filter-don't-load\r
require-all ;\r
\r
: load ( prefix -- )\r
: supported-platform? ( platforms -- ? )
[ t ] [ [ os swap class<= ] any? ] if-empty ;
-: unportable? ( vocab -- ? )
+: don't-load? ( vocab -- ? )
{
- [ vocab-tags "untested" swap member? ]
+ [ vocab-tags "not loaded" swap member? ]
[ vocab-platforms supported-platform? not ]
} 1|| ;
+: filter-don't-load ( vocabs -- vocabs' )
+ [ vocab-name don't-load? not ] filter ;
+
+: don't-test? ( vocab -- ? )
+ vocab-tags "not tested" swap member? ;
+
+: filter-don't-test ( vocabs -- vocabs' )
+ [ don't-test? not ] filter ;
+
TUPLE: unsupported-platform vocab requires ;
: unsupported-platform ( vocab requires -- )
IN: x11.syntax
SYNTAX: X-FUNCTION:
- (FUNCTION:)
+ (FUNCTION:) make-function
[ \ awaken-event-loop suffix ] dip
- define-declared ;
\ No newline at end of file
+ define-declared ;
{ $subsections
POSTPONE: LIBRARY:
POSTPONE: FUNCTION:
+ POSTPONE: FUNCTION-ALIAS:
}
"The above parsing words create word definitions which call a lower-level word; you can use it directly, too:"
{ $subsections alien-invoke }
{ $contract "Creates a new assoc of the same size as " { $snippet "exemplar" } " which can hold " { $snippet "capacity" } " entries before growing." } ;
HELP: assoc-find
-{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( ... key value -- ... ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
{ $description "Applies a predicate quotation to each entry in the assoc. Returns the key and value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found; this can be used to distinguish between a key and a value equal to " { $link f } ", or nothing being found." } ;
HELP: clear-assoc
{ $description "Looks up the value associated with a key. If the key was not present, an error can be thrown without extra stack shuffling. This word handles assocs that store " { $link f } "." } ;
HELP: assoc-each
-{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- )" } } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( ... key value -- ... )" } } }
{ $description "Applies a quotation to each entry in the assoc." }
{ $examples
{ $example
} ;
HELP: assoc-map
-{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- newkey newvalue )" } } { "newassoc" "a new assoc" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( ... key value -- ... newkey newvalue )" } } { "newassoc" "a new assoc" } }
{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the same type as the input." }
{ $examples
{ $unchecked-example
{ assoc-map assoc-map-as } related-words
HELP: assoc-filter
-{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "subassoc" "a new assoc" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( ... key value -- ... ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
HELP: assoc-filter-as
-{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "exemplar" assoc } { "subassoc" "a new assoc" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( ... key value -- ... ? )" } } { "exemplar" assoc } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "exemplar" } " consisting of all entries for which the predicate quotation yields true." } ;
HELP: assoc-filter!
-{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( ... key value -- ... ? )" } } }
{ $description "Removes all entries for which the predicate quotation yields true." }
{ $side-effects "assoc" } ;
{ $description "Calls a predicate quotation on each key of the input assoc. If the test yields true, the key/value pair is added to " { $snippet "true-assoc" } "; if false, it's added to " { $snippet "false-assoc" } "." } ;
HELP: assoc-any?
-{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( ... key value -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
HELP: assoc-all?
-{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( ... key value -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
HELP: assoc-subset?
{ $description "Creates a new sequence where elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " are replaced by the corresponding values, and all other elements are unchanged." } ;
HELP: cache
-{ $values { "key" "a key" } { "assoc" assoc } { "quot" { $quotation "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
+{ $values { "key" "a key" } { "assoc" assoc } { "quot" { $quotation "( ... key -- ... value )" } } { "value" "a previously-retained or freshly-computed value" } }
{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc. Returns a value either looked up or newly stored in the assoc." }
{ $side-effects "assoc" } ;
HELP: 2cache
-{ $values { "key1" "a key" } { "key2" "a key" } { "assoc" assoc } { "quot" { $quotation "( key1 key2 -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
+{ $values { "key1" "a key" } { "key2" "a key" } { "assoc" assoc } { "quot" { $quotation "( ... key1 key2 -- ... value )" } } { "value" "a previously-retained or freshly-computed value" } }
{ $description "If a single key composed of the input keys is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the keys/value pair into the assoc. Returns the value stored in the assoc. Returns a value either looked up or newly stored in the assoc." }
{ $side-effects "assoc" } ;
HELP: map>assoc
-{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- key value )" } } { "exemplar" assoc } { "assoc" "a new assoc" } }
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( ... elt -- ... key value )" } } { "exemplar" assoc } { "assoc" "a new assoc" } }
{ $description "Applies the quotation to each element of the sequence, and collects the keys and values into a new assoc having the same type as " { $snippet "exemplar" } "." } ;
HELP: assoc>map
-{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- elt )" } } { "exemplar" "a sequence" } { "seq" "a new sequence" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( ... key value -- ... elt )" } } { "exemplar" "a sequence" } { "seq" "a new sequence" } }
{ $description "Applies the quotation to each entry of the assoc and collects the results into a new sequence of the same type as the exemplar." } ;
HELP: change-at
-{ $values { "key" object } { "assoc" assoc } { "quot" { $quotation "( value -- newvalue )" } } }
+{ $values { "key" object } { "assoc" assoc } { "quot" { $quotation "( ..a value -- ..b newvalue )" } } }
{ $description "Applies the quotation to the value associated with " { $snippet "key" } ", storing the new value back in the assoc." }
{ $side-effects "assoc" } ;
HELP: assoc-map-as
{ $values
- { "assoc" assoc } { "quot" { $quotation "( key value -- newkey newvalue )" } } { "exemplar" assoc }
+ { "assoc" assoc } { "quot" { $quotation "( ... key value -- ... newkey newvalue )" } } { "exemplar" assoc }
{ "newassoc" assoc } }
{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the stame type as the exemplar." }
{ $examples { $example "USING: prettyprint assocs hashtables math ;" " H{ { 1 2 } { 3 4 } } [ sq ] { } assoc-map-as ." "{ { 1 4 } { 3 16 } }" } } ;
PRIVATE>
-: assoc-find ( assoc quot -- key value ? )
+: assoc-find ( ... assoc quot: ( ... key value -- ... ? ) -- ... key value ? )
(assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
: key? ( key assoc -- ? ) at* nip ; inline
-: assoc-each ( assoc quot -- )
+: assoc-each ( ... assoc quot: ( ... key value -- ... ) -- ... )
(assoc-each) each ; inline
-: assoc>map ( assoc quot exemplar -- seq )
+: assoc>map ( ... assoc quot: ( ... key value -- ... elt ) exemplar -- ... seq )
[ collector-for [ assoc-each ] dip ] [ like ] bi ; inline
-: assoc-map-as ( assoc quot exemplar -- newassoc )
+: assoc-map-as ( ... assoc quot: ( ... key value -- ... newkey newvalue ) exemplar -- ... newassoc )
[ [ 2array ] compose V{ } assoc>map ] dip assoc-like ; inline
-: assoc-map ( assoc quot -- newassoc )
+: assoc-map ( ... assoc quot: ( ... key value -- ... newkey newvalue ) -- ... newassoc )
over assoc-map-as ; inline
-: assoc-filter-as ( assoc quot exemplar -- subassoc )
+: assoc-filter-as ( ... assoc quot: ( ... key value -- ... ? ) exemplar -- ... subassoc )
[ (assoc-each) filter ] dip assoc-like ; inline
-: assoc-filter ( assoc quot -- subassoc )
+: assoc-filter ( ... assoc quot: ( ... key value -- ... ? ) -- ... subassoc )
over assoc-filter-as ; inline
-: assoc-filter! ( assoc quot -- assoc )
+: assoc-filter! ( ... assoc quot: ( ... key value -- ... ? ) -- ... assoc )
[
over [ [ [ drop ] 2bi ] dip [ delete-at ] 2curry unless ] 2curry
assoc-each
] [ drop ] 2bi ; inline
-: assoc-partition ( assoc quot -- true-assoc false-assoc )
+: assoc-partition ( ... assoc quot: ( ... key value -- ... ? ) -- ... true-assoc false-assoc )
[ (assoc-each) partition ] [ drop ] 2bi
[ assoc-like ] curry bi@ ; inline
-: assoc-any? ( assoc quot -- ? )
+: assoc-any? ( ... assoc quot: ( ... key value -- ... ? ) -- ... ? )
assoc-find 2nip ; inline
-: assoc-all? ( assoc quot -- ? )
+: assoc-all? ( ... assoc quot: ( ... key value -- ... ? ) -- ... ? )
[ not ] compose assoc-any? not ; inline
: at ( key assoc -- value/f )
: substitute ( seq assoc -- newseq )
substituter map ;
-: cache ( key assoc quot -- value )
+: cache ( ... key assoc quot: ( ... key -- ... value ) -- ... value )
[ [ at* ] 2keep ] dip
[ [ nip call dup ] [ drop ] 3bi set-at ] 3curry
[ drop ] prepose
unless ; inline
-: 2cache ( key1 key2 assoc quot -- value )
+: 2cache ( ... key1 key2 assoc quot: ( ... key1 key2 -- ... value ) -- ... value )
[ 2array ] 2dip [ first2 ] prepose cache ; inline
-: change-at ( key assoc quot -- )
+: change-at ( ..a key assoc quot: ( ..a value -- ..b newvalue ) -- ..b )
[ [ at ] dip call ] [ drop ] 3bi set-at ; inline
: at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline
: inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline
-: map>assoc ( seq quot exemplar -- assoc )
+: map>assoc ( ... seq quot: ( ... elt -- ... key value ) exemplar -- ... assoc )
[ [ 2array ] compose { } map-as ] dip assoc-like ; inline
: extract-keys ( seq assoc -- subassoc )
{ "byte-array>bignum" "math" "primitive_byte_array_to_bignum" (( x -- y )) }
{ "double>bits" "math" "primitive_double_bits" (( x -- n )) }
{ "float>bits" "math" "primitive_float_bits" (( x -- n )) }
- { "(float>string)" "math.parser.private" "primitive_float_to_str" (( n -- str )) }
+ { "(format-float)" "math.parser.private" "primitive_format_float" (( n format -- byte-array )) }
{ "bignum*" "math.private" "primitive_bignum_multiply" (( x y -- z )) }
{ "bignum+" "math.private" "primitive_bignum_add" (( x y -- z )) }
{ "bignum-" "math.private" "primitive_bignum_subtract" (( x y -- z )) }
! (c)2009 Joe Groff bsd license
-USING: accessors combinators kernel kernel.private math
-namespaces sequences sequences.private splitting strings make ;
+USING: accessors byte-arrays combinators kernel kernel.private
+math namespaces sequences sequences.private splitting strings
+make ;
IN: math.parser
: digit> ( ch -- n )
mantissa-expt [ float>hex-value ] [ float>hex-expt ] bi*
] bi 3append ;
-: float>decimal ( n -- str )
- (float>string)
- [ 0 = ] trim-tail >string
+: format-float ( n format -- string )
+ 0 suffix >byte-array (format-float)
+ dup [ 0 = ] find drop head >string
fix-float ;
: float>base ( n base -- str )
{
{ 16 [ float>hex ] }
- [ drop float>decimal ]
+ [ drop "%.16g" format-float ]
} case ; inline
PRIVATE>
HELP: accumulate
{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "final" "the final result" } { "newseq" "a new array" } }
-{ $description "Combines successive elements of the sequence using a binary operation, and outputs an array of intermediate results, together with the final result."
+{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results, together with the final result."
$nl
"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
$nl
[ 5040 { 1 1 2 6 24 120 720 } ]
[ { 1 2 3 4 5 6 7 } 1 [ * ] accumulate ] unit-test
+[ 64 B{ 1 2 4 16 } ]
+[ B{ 2 2 4 4 } 1 [ * ] accumulate ] unit-test
+
[ 5040 { 1 1 2 6 24 120 720 } ]
[ { 1 2 3 4 5 6 7 } 1 [ * ] accumulate! ] unit-test
[ (accumulate) ] dip map-as ; inline
: accumulate ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final newseq )
- { } accumulate-as ; inline
+ pick accumulate-as ; inline
: accumulate! ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final seq )
(accumulate) map! ; inline
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien kernel ;
+IN: alien.cxx
+
+SINGLETONS: g++ visual-c++ ;
+UNION: c++-abi
+ g++ visual-c++ ;
+
+GENERIC: c++>c-abi ( c++-abi -- c-abi )
+
+M: g++ c++>c-abi drop cdecl ;
+M: visual-c++ c++>c-abi drop thiscall ;
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien.cxx kernel ;
+QUALIFIED-WITH: alien.cxx.demangle.libstdcxx libstdcxx
+IN: alien.cxx.demangle
+
+GENERIC: c++-symbol? ( mangled-name abi -- ? )
+GENERIC: demangle ( mangled-name abi -- c++-name )
+
+M: g++ c++-symbol?
+ drop libstdcxx:mangled-name? ;
+M: g++ demangle
+ drop libstdcxx:demangle ;
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien alien.c-types alien.libraries alien.strings
+alien.syntax combinators destructors io.encodings.ascii kernel
+libc locals sequences system ;
+IN: alien.cxx.demangle.libstdcxx
+
+FUNCTION: char* __cxa_demangle ( char* mangled_name, char* output_buffer, size_t* length, int* status ) ;
+
+ERROR: demangle-memory-allocation-failure ;
+ERROR: invalid-mangled-name name ;
+ERROR: invalid-demangle-args name ;
+
+: demangle-error ( name status -- )
+ {
+ { 0 [ drop ] }
+ { -1 [ drop demangle-memory-allocation-failure ] }
+ { -2 [ invalid-mangled-name ] }
+ { -3 [ invalid-demangle-args ] }
+ } case ;
+
+: mangled-name? ( name -- ? )
+ "_Z" head? ;
+
+:: demangle ( mangled-name -- c++-name )
+ 0 <ulong> :> length
+ 0 <int> :> status [
+ mangled-name ascii string>alien f length status __cxa_demangle &(free) :> demangled-buf
+ mangled-name status *int demangle-error
+ demangled-buf ascii alien>string
+ ] with-destructors ;
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien.cxx.demangle assocs combinators fry io.pathnames
+kernel macho sequences ;
+IN: alien.cxx.scaffold
+
+: library-symbols ( file -- symbols )
+ dup file-extension {
+ { "dylib" [ dylib-exports ] }
+ { f [ dylib-exports ] }
+ } case ;
+
+: c++-library-symbols ( file abi -- symbols )
+ [ library-symbols ] dip
+ [ '[ _ c++-symbol? ] filter ]
+ [ '[ dup _ demangle ] H{ } map>assoc ] bi ;
--- /dev/null
+namespace Namespace {
+ int namespaced(int x, int y) { return x + y; }
+}
+
+double toplevel(double x, double y) { return x + y; }
+double toplevel(double x, double y, double z) { return x + y + z; }
+
+class Class
+{
+ unsigned x;
+
+ Class();
+ Class(unsigned _x);
+
+ unsigned member(unsigned y);
+ unsigned member(unsigned y) const;
+
+ unsigned static_member(unsigned x, unsigned y);
+};
+
+Class::Class() : x(42) { }
+Class::Class(unsigned _x) : x(_x) { }
+unsigned Class::member(unsigned y) { return x += y; }
+unsigned Class::member(unsigned y) const { return x + y; }
+unsigned Class::static_member(unsigned x, unsigned y) { return Class(x).member(y); }
+
+template<typename T>
+T templated(T x, T y) { return x + y; }
+
+template int templated<int>(int x, int y);
+template double templated<double>(double x, double y);
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2
-USING: alien.c-types math kernel io io.files locals multiline
-assocs sequences sequences.private benchmark.reverse-complement
-hints io.encodings.ascii byte-arrays specialized-arrays ;
-SPECIALIZED-ARRAY: double
+USING: assocs benchmark.reverse-complement byte-arrays fry io
+io.encodings.ascii io.files locals kernel math sequences
+sequences.private specialized-arrays strings typed ;
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:double
IN: benchmark.fasta
CONSTANT: IM 139968
CONSTANT: initial-seed 42
CONSTANT: line-length 60
-: random ( seed -- n seed )
- >float IA * IC + IM mod [ IM /f ] keep ; inline
-
-HINTS: random fixnum ;
+: random ( seed -- seed n )
+ IA * IC + IM mod dup IM /f ; inline
CONSTANT: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"
{ CHAR: t 0.3015094502008 }
}
-: make-cumulative ( freq -- chars floats )
+TYPED: make-cumulative ( freq -- chars: byte-array floats: double-array )
[ keys >byte-array ]
- [ values >double-array ] bi unclip [ + ] accumulate swap suffix ;
+ [ values >double-array unclip [ + ] accumulate swap suffix ] bi ;
:: select-random ( seed chars floats -- seed elt )
- floats seed random -rot
- [ >= ] curry find drop
- chars nth-unsafe ; inline
+ seed random floats [ <= ] with find drop chars nth-unsafe ; inline
-: make-random-fasta ( seed len chars floats -- seed )
- [ iota ] 2dip [ [ drop ] 2dip select-random ] 2curry "" map-as print ; inline
+TYPED: make-random-fasta ( seed: float len: fixnum chars: byte-array floats: double-array -- seed: float )
+ '[ _ _ select-random ] "" replicate-as print ;
: write-description ( desc id -- )
- ">" write write bl print ; inline
+ ">" write write bl print ;
:: split-lines ( n quot -- )
n line-length /mod
[ [ line-length quot call ] times ] dip
quot unless-zero ; inline
-: write-random-fasta ( seed n chars floats desc id -- seed )
+TYPED: write-random-fasta ( seed: float n: fixnum chars: byte-array floats: double-array desc id -- seed: float )
write-description
- [ make-random-fasta ] 2curry split-lines ; inline
+ '[ _ _ make-random-fasta ] split-lines ;
-:: make-repeat-fasta ( k len alu -- k' )
+TYPED:: make-repeat-fasta ( k: fixnum len: fixnum alu: string -- k': fixnum )
alu length :> kn
len iota [ k + kn mod alu nth-unsafe ] "" map-as print
- k len + ; inline
+ k len + ;
: write-repeat-fasta ( n alu desc id -- )
write-description
:> alu
0 :> k!
[| len | k len alu make-repeat-fasta k! ] split-lines
- ] ; inline
+ ] ;
: fasta ( n out -- )
homo-sapiens make-cumulative
-USING: kernel locals io io.files splitting strings io.encodings.ascii
- hashtables sequences assocs math namespaces prettyprint
- math.parser combinators arrays sorting unicode.case ;
-
+USING: ascii kernel io io.files splitting strings
+io.encodings.ascii hashtables sequences assocs math
+math.statistics namespaces prettyprint math.parser combinators
+arrays sorting formatting grouping fry ;
IN: benchmark.knucleotide
-: float>string ( float places -- string )
- swap >float number>string
- "." split1 rot
- over length over <
- [ CHAR: 0 pad-tail ]
- [ head ] if "." glue ;
-
: discard-lines ( -- )
readln
[ ">THREE" head? [ discard-lines ] unless ] when* ;
">" read-until drop
CHAR: \n swap remove >upper ;
-: tally ( x exemplar -- b )
- clone [ [ inc-at ] curry each ] keep ;
-
-: small-groups ( x n -- b )
- swap
- [ length swap - 1 + iota ] 2keep
- [ [ over + ] dip subseq ] 2curry map ;
-
: handle-table ( inputs n -- )
- small-groups
- [ length ] keep
- H{ } tally >alist
- sort-values reverse
- [
- dup first write bl
- second 100 * over / 3 float>string print
- ] each
- drop ;
+ <clumps>
+ [ histogram >alist sort-values reverse ] [ length ] bi
+ '[
+ [ first write bl ]
+ [ second 100 * _ /f "%.3f" printf nl ] bi
+ ] each ;
-:: handle-n ( inputs x -- )
- inputs x length small-groups :> groups
- groups H{ } tally :> b
- x b at [ 0 ] unless*
- number>string 8 CHAR: \s pad-tail write ;
+: handle-n ( input x -- )
+ [ nip ] [ length <clumps> histogram ] 2bi at 0 or "%d\t" printf ;
: process-input ( input -- )
- dup 1 handle-table nl
- dup 2 handle-table nl
- { "GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT" }
- [ [ dupd handle-n ] keep print ] each
- drop ;
+ [ 1 handle-table nl ]
+ [ 2 handle-table nl ]
+ [
+ { "GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT" }
+ [ [ handle-n ] keep print ] with each
+ ]
+ tri ;
: knucleotide ( -- )
"resource:extra/benchmark/knucleotide/knucleotide-input.txt"
! Factor port of
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
USING: alien.c-types specialized-arrays kernel math
-math.functions math.vectors sequences prettyprint words hints
-locals ;
+math.functions math.vectors sequences sequences.private
+prettyprint words typed locals ;
SPECIALIZED-ARRAY: double
IN: benchmark.spectral-norm
+ 1 + recip ; inline
: (eval-A-times-u) ( u i j -- x )
- [ swap nth ] [ eval-A ] bi-curry bi* * ; inline
+ [ swap nth-unsafe ] [ eval-A ] bi-curry bi* * ; inline
: eval-A-times-u ( n u -- seq )
[ (eval-A-times-u) ] inner-loop ; inline
: (eval-At-times-u) ( u i j -- x )
- [ swap nth ] [ swap eval-A ] bi-curry bi* * ; inline
+ [ swap nth-unsafe ] [ swap eval-A ] bi-curry bi* * ; inline
: eval-At-times-u ( u n -- seq )
[ (eval-At-times-u) ] inner-loop ; inline
[ n eval-AtA-times-u ] keep
] times ; inline
-: spectral-norm ( n -- norm )
+TYPED: spectral-norm ( n: fixnum -- norm )
u/v [ v. ] [ norm-sq ] bi /f sqrt ;
-HINTS: spectral-norm fixnum ;
-
: spectral-norm-main ( -- )
2000 spectral-norm . ;
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.data assocs classes.struct
-combinators continuations cuda.ffi fry io.backend kernel
-sequences ;
+USING: accessors alien alien.c-types alien.data alien.parser
+alien.strings arrays assocs byte-arrays classes.struct
+combinators continuations cuda.ffi destructors fry io
+io.backend io.encodings.string io.encodings.utf8 kernel lexer
+locals math math.parser namespaces opengl.gl.extensions
+prettyprint quotations sequences ;
IN: cuda
+SYMBOL: cuda-device
+SYMBOL: cuda-context
+SYMBOL: cuda-module
+SYMBOL: cuda-function
+SYMBOL: cuda-launcher
+SYMBOL: cuda-memory-hashtable
+
ERROR: throw-cuda-error n ;
: cuda-error ( n -- )
- {
- { CUDA_SUCCESS [ ] }
- [ throw-cuda-error ]
- } case ;
+ dup CUDA_SUCCESS = [ drop ] [ throw-cuda-error ] if ;
: cuda-version ( -- n )
int <c-object> [ cuDriverGetVersion cuda-error ] keep *int ;
: init-cuda ( -- )
0 cuInit cuda-error ;
-: with-cuda ( quot -- )
- init-cuda [ ] [ ] cleanup ; inline
+TUPLE: launcher
+{ device integer initial: 0 }
+{ device-flags initial: 0 }
+path block-shape shared-size grid ;
+
+: with-cuda-context ( flags device quot -- )
+ [
+ [ CUcontext <c-object> ] 2dip
+ [ cuCtxCreate cuda-error ] 3keep 2drop *void*
+ ] dip
+ [ '[ _ @ ] ]
+ [ drop '[ _ cuCtxDestroy cuda-error ] ] 2bi
+ [ ] cleanup ; inline
+
+: with-cuda-module ( path quot -- )
+ [
+ normalize-path
+ [ CUmodule <c-object> ] dip
+ [ cuModuleLoad cuda-error ] 2keep drop *void*
+ ] dip
+ [ '[ _ @ ] ]
+ [ drop '[ _ cuModuleUnload cuda-error ] ] 2bi
+ [ ] cleanup ; inline
+
+: with-cuda-program ( flags device path quot -- )
+ [ dup cuda-device set ] 2dip
+ '[
+ cuda-context set
+ _ [
+ cuda-module set
+ _ call
+ ] with-cuda-module
+ ] with-cuda-context ; inline
+
+: with-cuda ( launcher quot -- )
+ [
+ init-cuda
+ H{ } clone cuda-memory-hashtable
+ ] 2dip '[
+ _
+ [ cuda-launcher set ]
+ [ [ device>> ] [ device-flags>> ] [ path>> ] tri ] bi
+ _ with-cuda-program
+ ] with-variable ; inline
<PRIVATE
: enumerate-cuda-devices ( -- devices )
#cuda-devices iota [ n>cuda-device ] map ;
-: cuda-device>properties ( device -- properties )
+: cuda-device-properties ( device -- properties )
[ CUdevprop <c-object> ] dip
[ cuDeviceGetProperties cuda-error ] 2keep drop
CUdevprop memory>struct ;
-: cuda-device-properties ( -- properties )
- enumerate-cuda-devices [ cuda-device>properties ] map ;
-
PRIVATE>
: cuda-devices ( -- assoc )
- enumerate-cuda-devices [ dup cuda-device>properties ] { } map>assoc ;
+ enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ;
-: with-cuda-context ( flags device quot -- )
- [
- [ CUcontext <c-object> ] 2dip
- [ cuCtxCreate cuda-error ] 3keep 2drop *void*
- ] dip
- [ '[ _ @ ] ]
- [ drop '[ _ cuCtxDestroy cuda-error ] ] 2bi
- [ ] cleanup ; inline
+: cuda-device-name ( n -- string )
+ [ 256 [ <byte-array> ] keep ] dip
+ [ cuDeviceGetName cuda-error ]
+ [ 2drop utf8 alien>string ] 3bi ;
-: with-cuda-module ( path quot -- )
- [
- normalize-path
- [ CUmodule <c-object> ] dip
- [ cuModuleLoad cuda-error ] 2keep drop *void*
- ] dip
- [ '[ _ @ ] ]
- [ drop '[ _ cuModuleUnload cuda-error ] ] 2bi
- [ ] cleanup ; inline
+: cuda-device-capability ( n -- pair )
+ [ int <c-object> int <c-object> ] dip
+ [ cuDeviceComputeCapability cuda-error ]
+ [ drop [ *int ] bi@ ] 3bi 2array ;
+
+: cuda-device-memory ( n -- bytes )
+ [ uint <c-object> ] dip
+ [ cuDeviceTotalMem cuda-error ]
+ [ drop *uint ] 2bi ;
-: get-cuda-function ( module string -- function )
+: get-cuda-function* ( module string -- function )
[ CUfunction <c-object> ] 2dip
[ cuModuleGetFunction cuda-error ] 3keep 2drop *void* ;
+: get-cuda-function ( string -- function )
+ [ cuda-module get ] dip get-cuda-function* ;
+
+: with-cuda-function ( string quot -- )
+ [
+ get-cuda-function cuda-function set
+ ] dip call ; inline
+
+: launch-function* ( function -- ) cuLaunch cuda-error ;
+
+: launch-function ( -- ) cuda-function get cuLaunch cuda-error ;
+
+: launch-function-grid* ( function width height -- )
+ cuLaunchGrid cuda-error ;
+
+: launch-function-grid ( width height -- )
+ [ cuda-function get ] 2dip
+ cuLaunchGrid cuda-error ;
+
+TUPLE: cuda-memory < disposable ptr length ;
+
+: <cuda-memory> ( ptr length -- obj )
+ cuda-memory new-disposable
+ swap >>length
+ swap >>ptr ;
+
+: add-cuda-memory ( obj -- obj )
+ dup dup ptr>> cuda-memory-hashtable get set-at ;
+
+: delete-cuda-memory ( obj -- )
+ cuda-memory-hashtable delete-at ;
+
+ERROR: invalid-cuda-memory ptr ;
+
+: cuda-memory-length ( cuda-memory -- n )
+ ptr>> cuda-memory-hashtable get ?at [
+ length>>
+ ] [
+ invalid-cuda-memory
+ ] if ;
+
+M: cuda-memory byte-length length>> ;
+
: cuda-malloc ( n -- ptr )
[ CUdeviceptr <c-object> ] dip
- [ cuMemAlloc cuda-error ] 2keep drop *int ;
+ [ cuMemAlloc cuda-error ] 2keep
+ [ *int ] dip <cuda-memory> add-cuda-memory ;
-: cuda-free ( ptr -- )
+: cuda-free* ( ptr -- )
cuMemFree cuda-error ;
+
+M: cuda-memory dispose ( ptr -- )
+ ptr>> cuda-free* ;
+
+: host>device ( dest-ptr src-ptr -- )
+ [ ptr>> ] dip dup length cuMemcpyHtoD cuda-error ;
+
+:: device>host ( ptr -- seq )
+ ptr byte-length <byte-array>
+ [ ptr [ ptr>> ] [ byte-length ] bi cuMemcpyDtoH cuda-error ] keep ;
+
+: memcpy-device>device ( dest-ptr src-ptr count -- )
+ cuMemcpyDtoD cuda-error ;
+
+: memcpy-device>array ( dest-array dest-index src-ptr count -- )
+ cuMemcpyDtoA cuda-error ;
+
+: memcpy-array>device ( dest-ptr src-array src-index count -- )
+ cuMemcpyAtoD cuda-error ;
+
+: memcpy-array>host ( dest-ptr src-array src-index count -- )
+ cuMemcpyAtoH cuda-error ;
+
+: memcpy-host>array ( dest-array dest-index src-ptr count -- )
+ cuMemcpyHtoA cuda-error ;
+
+: memcpy-array>array ( dest-array dest-index src-array src-ptr count -- )
+ cuMemcpyAtoA cuda-error ;
+
+: cuda-int* ( function offset value -- )
+ cuParamSeti cuda-error ;
+
+: cuda-int ( offset value -- )
+ [ cuda-function get ] 2dip cuda-int* ;
+
+: cuda-float* ( function offset value -- )
+ cuParamSetf cuda-error ;
+
+: cuda-float ( offset value -- )
+ [ cuda-function get ] 2dip cuda-float* ;
+
+: cuda-vector* ( function offset ptr n -- )
+ cuParamSetv cuda-error ;
+
+: cuda-vector ( offset ptr n -- )
+ [ cuda-function get ] 3dip cuda-vector* ;
+
+: param-size* ( function n -- )
+ cuParamSetSize cuda-error ;
+
+: param-size ( n -- )
+ [ cuda-function get ] dip param-size* ;
+
+: malloc-device-string ( string -- n )
+ utf8 encode
+ [ length cuda-malloc ] keep
+ [ host>device ] [ drop ] 2bi ;
+
+ERROR: bad-cuda-parameter parameter ;
+
+:: set-parameters ( seq -- )
+ cuda-function get :> function
+ 0 :> offset!
+ seq [
+ [ offset ] dip
+ {
+ { [ dup cuda-memory? ] [ ptr>> cuda-int ] }
+ { [ dup float? ] [ cuda-float ] }
+ { [ dup integer? ] [ cuda-int ] }
+ [ bad-cuda-parameter ]
+ } cond
+ offset 4 + offset!
+ ] each
+ offset param-size ;
+
+: cuda-device-attribute ( attribute dev -- n )
+ [ int <c-object> ] 2dip
+ [ cuDeviceGetAttribute cuda-error ]
+ [ 2drop *int ] 3bi ;
+
+: function-block-shape* ( function x y z -- )
+ cuFuncSetBlockShape cuda-error ;
+
+: function-block-shape ( x y z -- )
+ [ cuda-function get ] 3dip
+ cuFuncSetBlockShape cuda-error ;
+
+: function-shared-size* ( function n -- )
+ cuFuncSetSharedSize cuda-error ;
+
+: function-shared-size ( n -- )
+ [ cuda-function get ] dip
+ cuFuncSetSharedSize cuda-error ;
+
+: launch ( -- )
+ cuda-launcher get {
+ [ block-shape>> first3 function-block-shape ]
+ [ shared-size>> function-shared-size ]
+ [
+ grid>> [
+ launch-function
+ ] [
+ first2 launch-function-grid
+ ] if-empty
+ ]
+ } cleave ;
+
+: cuda-device. ( n -- )
+ {
+ [ "Device: " write number>string print ]
+ [ "Name: " write cuda-device-name print ]
+ [ "Memory: " write cuda-device-memory number>string print ]
+ [
+ "Capability: " write
+ cuda-device-capability [ number>string ] map " " join print
+ ]
+ [ "Properties: " write cuda-device-properties . ]
+ [
+ "CU_DEVICE_ATTRIBUTE_GPU_OVERLAP: " write
+ CU_DEVICE_ATTRIBUTE_GPU_OVERLAP swap
+ cuda-device-attribute number>string print
+ ]
+ } cleave ;
+
+: cuda. ( -- )
+ "CUDA Version: " write cuda-version number>string print nl
+ #cuda-devices iota [ nl ] [ cuda-device. ] interleave ;
+
+
+: test-cuda0 ( -- )
+ T{ launcher
+ { path "vocab:cuda/hello.ptx" }
+ { block-shape { 6 6 6 } }
+ { shared-size 2 }
+ { grid { 2 6 } }
+ } [
+ "helloWorld" [
+ "Hello World!" [ - ] map-index
+ malloc-device-string &dispose
+
+ [ 1array set-parameters ]
+ [ drop launch ]
+ [ device>host utf8 alien>string . ] tri
+ ] with-cuda-function
+ ] with-cuda ;
! (c)2010 Joe Groff bsd license
-USING: alien alien.c-types alien.libraries alien.syntax
-classes.struct combinators system ;
+USING: accessors alien alien.c-types alien.libraries alien.syntax
+classes.struct combinators kernel system ;
IN: cuda.ffi
<<
TYPEDEF: void* CUstream
TYPEDEF: void* CUgraphicsResource
+! versions of double and longlong that always 8-byte align
+
+SYMBOLS: CUdouble CUlonglong CUulonglong ;
+
+: >cuda-param-type ( c-type -- c-type' )
+ {
+ { CUdeviceptr [ void* ] }
+ { double [ CUdouble ] }
+ { longlong [ CUlonglong ] }
+ { ulonglong [ CUulonglong ] }
+ [ ]
+ } case ;
+
+<<
+: always-8-byte-align ( c-type -- c-type )
+ 8 >>align 8 >>align-first ;
+
+longlong c-type clone always-8-byte-align \ CUlonglong typedef
+ulonglong c-type clone always-8-byte-align \ CUulonglong typedef
+double c-type clone always-8-byte-align \ CUdouble typedef
+>>
+
STRUCT: CUuuid
{ bytes char[16] } ;
--- /dev/null
+not tested
+bindings
--- /dev/null
+/*
+ World using CUDA
+**
+** The string "Hello World!" is mangled then restored using a common CUDA idiom
+**
+** Byron Galbraith
+** 2009-02-18
+*/
+#include <cuda.h>
+#include <stdio.h>
+
+// Prototypes
+extern "C" __global__ void helloWorld(char*);
+
+// Host function
+int
+main(int argc, char** argv)
+{
+ int i;
+
+ // desired output
+ char str[] = "Hello World!";
+
+ // mangle contents of output
+ // the null character is left intact for simplicity
+ for(i = 0; i < 12; i++)
+ str[i] -= i;
+
+ // allocate memory on the device
+ char *d_str;
+ size_t size = sizeof(str);
+ cudaMalloc((void**)&d_str, size);
+
+ // copy the string to the device
+ cudaMemcpy(d_str, str, size, cudaMemcpyHostToDevice);
+
+ // set the grid and block sizes
+ dim3 dimGrid(2); // one block per word
+ dim3 dimBlock(6); // one thread per character
+
+ // invoke the kernel
+ helloWorld<<< dimGrid, dimBlock >>>(d_str);
+
+ // retrieve the results from the device
+ cudaMemcpy(str, d_str, size, cudaMemcpyDeviceToHost);
+
+ // free up the allocated memory on the device
+ cudaFree(d_str);
+
+ // everyone's favorite part
+ printf("%s\n", str);
+
+ return 0;
+}
+
+// Device kernel
+__global__ void
+helloWorld(char* str)
+{
+ // determine where in the thread grid we are
+ int idx = blockIdx.x * blockDim.x + threadIdx.x;
+
+ // unmangle output
+ str[idx] += idx;
+}
--- /dev/null
+ .version 1.4
+ .target sm_10, map_f64_to_f32
+ // compiled with /usr/local/cuda/bin/../open64/lib//be
+ // nvopencc 3.0 built on 2010-03-11
+
+ //-----------------------------------------------------------
+ // Compiling /tmp/tmpxft_00000eab_00000000-7_hello.cpp3.i (/var/folders/KD/KDnx4D80Eh0fsORqNrFWBE+++TI/-Tmp-/ccBI#.AYqbdQ)
+ //-----------------------------------------------------------
+
+ //-----------------------------------------------------------
+ // Options:
+ //-----------------------------------------------------------
+ // Target:ptx, ISA:sm_10, Endian:little, Pointer Size:32
+ // -O3 (Optimization level)
+ // -g0 (Debug level)
+ // -m2 (Report advisories)
+ //-----------------------------------------------------------
+
+ .file 1 "<command-line>"
+ .file 2 "/tmp/tmpxft_00000eab_00000000-6_hello.cudafe2.gpu"
+ .file 3 "/usr/lib/gcc/i686-apple-darwin10/4.2.1/include/stddef.h"
+ .file 4 "/usr/local/cuda/bin/../include/crt/device_runtime.h"
+ .file 5 "/usr/local/cuda/bin/../include/host_defines.h"
+ .file 6 "/usr/local/cuda/bin/../include/builtin_types.h"
+ .file 7 "/usr/local/cuda/bin/../include/device_types.h"
+ .file 8 "/usr/local/cuda/bin/../include/driver_types.h"
+ .file 9 "/usr/local/cuda/bin/../include/texture_types.h"
+ .file 10 "/usr/local/cuda/bin/../include/vector_types.h"
+ .file 11 "/usr/local/cuda/bin/../include/device_launch_parameters.h"
+ .file 12 "/usr/local/cuda/bin/../include/crt/storage_class.h"
+ .file 13 "/usr/include/i386/_types.h"
+ .file 14 "/usr/include/time.h"
+ .file 15 "/usr/local/cuda/bin/../include/texture_fetch_functions.h"
+ .file 16 "/usr/local/cuda/bin/../include/common_functions.h"
+ .file 17 "/usr/local/cuda/bin/../include/crt/func_macro.h"
+ .file 18 "/usr/local/cuda/bin/../include/math_functions.h"
+ .file 19 "/usr/local/cuda/bin/../include/device_functions.h"
+ .file 20 "/usr/local/cuda/bin/../include/math_constants.h"
+ .file 21 "/usr/local/cuda/bin/../include/sm_11_atomic_functions.h"
+ .file 22 "/usr/local/cuda/bin/../include/sm_12_atomic_functions.h"
+ .file 23 "/usr/local/cuda/bin/../include/sm_13_double_functions.h"
+ .file 24 "/usr/local/cuda/bin/../include/common_types.h"
+ .file 25 "/usr/local/cuda/bin/../include/sm_20_atomic_functions.h"
+ .file 26 "/usr/local/cuda/bin/../include/sm_20_intrinsics.h"
+ .file 27 "/usr/local/cuda/bin/../include/math_functions_dbl_ptx1.h"
+ .file 28 "hello.cu"
+
+
+ .entry helloWorld (
+ .param .u32 __cudaparm_helloWorld_str)
+ {
+ .reg .u16 %rh<4>;
+ .reg .u32 %r<9>;
+ .loc 28 58 0
+$LBB1_helloWorld:
+ .loc 28 64 0
+ mov.u16 %rh1, %ctaid.x;
+ mov.u16 %rh2, %ntid.x;
+ mul.wide.u16 %r1, %rh1, %rh2;
+ cvt.u32.u16 %r2, %tid.x;
+ add.u32 %r3, %r2, %r1;
+ ld.param.u32 %r4, [__cudaparm_helloWorld_str];
+ add.u32 %r5, %r4, %r3;
+ ld.global.s8 %r6, [%r5+0];
+ add.s32 %r7, %r6, %r3;
+ st.global.s8 [%r5+0], %r7;
+ .loc 28 65 0
+ exit;
+$LDWend_helloWorld:
+ } // helloWorld
+
--- /dev/null
+not tested
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays elf kernel sequences system tools.test ;
+IN: elf.tests
+
+cpu ppc? [
+{
+ {
+ ""
+ ".interp"
+ ".note.ABI-tag"
+ ".note.gnu.build-id"
+ ".hash"
+ ".gnu.hash"
+ ".dynsym"
+ ".dynstr"
+ ".gnu.version"
+ ".gnu.version_r"
+ ".rela.dyn"
+ ".rela.plt"
+ ".init"
+ ".plt"
+ ".text"
+ ".fini"
+ ".rodata"
+ ".eh_frame_hdr"
+ ".eh_frame"
+ ".ctors"
+ ".dtors"
+ ".jcr"
+ ".dynamic"
+ ".got"
+ ".got.plt"
+ ".data"
+ ".bss"
+ ".comment"
+ ".debug_aranges"
+ ".debug_pubnames"
+ ".debug_info"
+ ".debug_abbrev"
+ ".debug_line"
+ ".debug_str"
+ ".shstrtab"
+ ".symtab"
+ ".strtab"
+ }
+}
+[
+ "resource:extra/elf/a.elf" [
+ sections [ name>> ] map
+ ] with-mapped-elf
+]
+unit-test
+
+{
+ {
+ ".interp"
+ ".note.ABI-tag"
+ ".note.gnu.build-id"
+ ".hash"
+ ".gnu.hash"
+ ".dynsym"
+ ".dynstr"
+ ".gnu.version"
+ ".gnu.version_r"
+ ".rela.dyn"
+ ".rela.plt"
+ ".init"
+ ".plt"
+ ".text"
+ ".fini"
+ ".rodata"
+ ".eh_frame_hdr"
+ ".eh_frame"
+ }
+}
+[
+ "resource:extra/elf/a.elf" [
+ segments [ program-header>> p_type>> PT_LOAD = ] find nip
+ sections [ name>> ] map
+ ] with-mapped-elf
+]
+unit-test
+
+{
+ {
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ ""
+ "init.c"
+ "call_gmon_start"
+ "crtstuff.c"
+ "__CTOR_LIST__"
+ "__DTOR_LIST__"
+ "__JCR_LIST__"
+ "__do_global_dtors_aux"
+ "completed.7342"
+ "dtor_idx.7344"
+ "frame_dummy"
+ "crtstuff.c"
+ "__CTOR_END__"
+ "__FRAME_END__"
+ "__JCR_END__"
+ "__do_global_ctors_aux"
+ "test.c"
+ "_GLOBAL_OFFSET_TABLE_"
+ "__init_array_end"
+ "__init_array_start"
+ "_DYNAMIC"
+ "data_start"
+ "printf@@GLIBC_2.2.5"
+ "__libc_csu_fini"
+ "_start"
+ "__gmon_start__"
+ "_Jv_RegisterClasses"
+ "_fini"
+ "__libc_start_main@@GLIBC_2.2.5"
+ "_IO_stdin_used"
+ "__data_start"
+ "__dso_handle"
+ "__DTOR_END__"
+ "__libc_csu_init"
+ "__bss_start"
+ "_end"
+ "_edata"
+ "main"
+ "_init"
+ }
+}
+[
+ "resource:extra/elf/a.elf" [
+ sections ".symtab" find-section symbols
+ [ name>> ] map
+ ] with-mapped-elf
+]
+unit-test
+
+{
+ B{
+ 85 72 137 229 184 44 6 64 0 72 137 199 184 0 0 0 0 232 222
+ 254 255 255 201 195
+ }
+}
+[
+ "resource:extra/elf/a.elf" [
+ sections ".symtab" "main" find-section-symbol
+ symbol-data >byte-array
+ ] with-mapped-elf
+]
+unit-test
+] unless
! Copyright (C) 2010 Erik Charlebois.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings alien.syntax arrays
-classes.struct fry io.encodings.ascii kernel locals math
+classes.struct fry io.encodings.ascii io.mmap kernel locals math
math.intervals sequences specialized-arrays strings typed ;
IN: elf
symbol sym>> st_size>> <direct-uchar-array> ;
: find-section ( sections name -- section/f )
- '[ name>> _ = ] find nip ;
+ '[ name>> _ = ] find nip ; inline
+
+: find-symbol ( symbols name -- symbol/f )
+ '[ name>> _ = ] find nip ; inline
+
+: find-section-symbol ( sections section symbol -- symbol/f )
+ [ find-section ] dip over [
+ [ symbols ] dip find-symbol ] [ 2drop f ] if ;
+
+: with-mapped-elf ( path quot -- )
+ '[
+ address>> <elf> @
+ ] with-mapped-file ; inline
USING: elf help.markup help.syntax ;
IN: elf.nm
-HELP: nm
+HELP: elf-nm
{ $values
{ "path" "a pathname string" }
}
{ $description "Prints the value, section and name of the given symbol." } ;
ARTICLE: "elf.nm" "ELF nm"
-{ $description "Utility to print the values, sections and names of the symbols in a given ELF file. In an ELF executable or shared library, the symbol values are typically their virtual addresses. In a relocatable ELF object, they are section-relative offsets." }
+"The " { $vocab-link "elf.nm" } " vocab prints the values, sections and names of the symbols in a given ELF file. In an ELF executable or shared library, the symbol values are typically their virtual addresses. In a relocatable ELF object, they are section-relative offsets."
+{ $subsections elf-nm }
;
ABOUT: "elf.nm"
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: elf.nm io io.streams.string kernel literals multiline strings
+system tools.test ;
+IN: elf.nm.tests
+
+STRING: validation-output
+0000000000000000 absolute init.c
+000000000040046c .text call_gmon_start
+0000000000000000 absolute crtstuff.c
+0000000000600e18 .ctors __CTOR_LIST__
+0000000000600e28 .dtors __DTOR_LIST__
+0000000000600e38 .jcr __JCR_LIST__
+0000000000400490 .text __do_global_dtors_aux
+0000000000601020 .bss completed.7342
+0000000000601028 .bss dtor_idx.7344
+0000000000400500 .text frame_dummy
+0000000000000000 absolute crtstuff.c
+0000000000600e20 .ctors __CTOR_END__
+00000000004006d8 .eh_frame __FRAME_END__
+0000000000600e38 .jcr __JCR_END__
+00000000004005e0 .text __do_global_ctors_aux
+0000000000000000 absolute test.c
+0000000000600fe8 .got.plt _GLOBAL_OFFSET_TABLE_
+0000000000600e14 .ctors __init_array_end
+0000000000600e14 .ctors __init_array_start
+0000000000600e40 .dynamic _DYNAMIC
+0000000000601010 .data data_start
+0000000000000000 undefined printf@@GLIBC_2.2.5
+0000000000400540 .text __libc_csu_fini
+0000000000400440 .text _start
+0000000000000000 undefined __gmon_start__
+0000000000000000 undefined _Jv_RegisterClasses
+0000000000400618 .fini _fini
+0000000000000000 undefined __libc_start_main@@GLIBC_2.2.5
+0000000000400628 .rodata _IO_stdin_used
+0000000000601010 .data __data_start
+0000000000601018 .data __dso_handle
+0000000000600e30 .dtors __DTOR_END__
+0000000000400550 .text __libc_csu_init
+0000000000601020 absolute __bss_start
+0000000000601030 absolute _end
+0000000000601020 absolute _edata
+0000000000400524 .text main
+00000000004003f0 .init _init
+
+;
+
+cpu ppc? [
+ { $ validation-output }
+ [ <string-writer> dup [ "resource:extra/elf/a.elf" elf-nm ] with-output-stream >string ]
+ unit-test
+] unless
IN: elf.nm
: print-symbol ( sections symbol -- )
- [ sym>> st_value>> "%016d " printf ]
+ [ sym>> st_value>> "%016x " printf ]
[
sym>> st_shndx>>
{
]
[ name>> "%s\n" printf ] tri ;
-: nm ( path -- )
+: elf-nm ( path -- )
[
- address>> <elf> sections
- dup ".symtab" find-section
+ sections dup ".symtab" find-section
symbols [ name>> empty? not ] filter
[ print-symbol ] with each
- ] with-mapped-file ;
+ ] with-mapped-elf ;
! Copyright (C) 2009 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.libraries alien.syntax system sequences combinators kernel alien.c-types ;
+USING: alien alien.libraries alien.syntax system sequences combinators kernel alien.c-types ;
IN: llvm.core
! Copyright (C) 2009 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.libraries alien.syntax llvm.core ;
+USING: alien.c-types alien.libraries alien.syntax llvm.core ;
IN: llvm.engine
<<
] [ ] make swap function-effect [ define-declared ] with-compilation-unit ;
: install-module ( name -- )
- thejit get mps>> at [
+ current-jit mps>> at [
module>> functions [ install-function ] each
] [ "no such module" throw ] if* ;
IN: llvm.jit
-SYMBOL: thejit
-
TUPLE: jit ee mps ;
: empty-engine ( -- engine )
: <jit> ( -- jit )
jit new empty-engine >>ee H{ } clone >>mps ;
+: current-jit ( -- jit )
+ \ current-jit global [ drop <jit> ] cache ;
+
: (remove-functions) ( function -- )
- thejit get ee>> value>> over LLVMFreeMachineCodeForFunction
+ current-jit ee>> value>> over LLVMFreeMachineCodeForFunction
LLVMGetNextFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ;
: remove-functions ( module -- )
LLVMGetFirstFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ;
: remove-provider ( provider -- )
- thejit get ee>> value>> swap value>> f <void*> f <void*>
+ current-jit ee>> value>> swap value>> f <void*> f <void*>
[ LLVMRemoveModuleProvider drop ] 2keep *void* [ llvm-throw ] when*
*void* module new swap >>value
[ value>> remove-functions ] with-disposal ;
: remove-module ( name -- )
- dup thejit get mps>> at [
+ dup current-jit mps>> at [
remove-provider
- thejit get mps>> delete-at
+ current-jit mps>> delete-at
] [ drop ] if* ;
: add-module ( module name -- )
[ <provider> ] dip [ remove-module ] keep
- thejit get ee>> value>> pick
+ current-jit ee>> value>> pick
[ [ value>> LLVMAddModuleProvider ] [ t >>disposed drop ] bi ] with-disposal
- thejit get mps>> set-at ;
+ current-jit mps>> set-at ;
: function-pointer ( name -- alien )
- thejit get ee>> value>> dup
+ current-jit ee>> value>> dup
rot f <void*> [ LLVMFindFunction drop ] keep
- *void* LLVMGetPointerToGlobal ;
-
-thejit [ <jit> ] initialize
\ No newline at end of file
+ *void* LLVMGetPointerToGlobal ;
\ No newline at end of file
bindings
-untested
+not tested
VarArgs = WhiteSpace "..." WhiteSpace => [[ drop ... ]]
ParamListContinued = "," (Type | VarArgs):t => [[ t ]]
ParamList = "(" Type:t (ParamListContinued*):ts ")" => [[ ts t prefix ]]
-Function = T:t WhiteSpace ( ParamList | NoFunctionParams ):ts => [[ ... ts member? dup [ ... ts delete ] when t ts >array rot <function> ]]
+Function = T:t WhiteSpace ( ParamList | NoFunctionParams ):ts => [[ ... ts member? dup [ ... ts remove! drop ] when t ts >array rot <function> ]]
PackedStructure = "<" WhiteSpace "{" Type:ty (StructureTypesList)*:ts "}" WhiteSpace ">" => [[ ts ty prefix >array t <struct> ]]
UpReference = "\\" Number:n => [[ n <up-ref> ]]
Name = '%' ([a-zA-Z][a-zA-Z0-9]*):id => [[ id flatten >string ]]
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien io io.streams.string kernel literals macho
+multiline sequences strings system tools.test ;
+IN: macho.tests
+
+STRING: validation-output
+0000000100000f1c __stub_helper stub helpers
+0000000100001040 __program_vars _pvars
+0000000100001068 __data _NXArgc
+0000000100001070 __data _NXArgv
+0000000100001080 __data ___progname
+0000000100000000 __mh_execute_header
+0000000100001078 __data _environ
+0000000100000ef8 __text _main
+0000000100000ebc __text start
+0000000000000000 ___gxx_personality_v0
+0000000000000000 _exit
+0000000000000000 _printf
+0000000000000000 dyld_stub_binder
+
+;
+
+cpu ppc? [
+ { $ validation-output }
+ [ <string-writer> dup [ "resource:extra/macho/a.macho" macho-nm ] with-output-stream >string ]
+ unit-test
+
+ { t } [
+ "resource:extra/macho/a2.macho" [
+ >c-ptr fat-binary-members first data>> >c-ptr macho-header 64-bit?
+ ] with-mapped-macho
+ ] unit-test
+] unless
! Copyright (C) 2010 Erik Charlebois.
! See http:// factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax classes.struct kernel literals math ;
+USING: accessors alien alien.c-types alien.strings alien.syntax
+classes classes.struct combinators combinators.short-circuit
+io.encodings.ascii io.encodings.string kernel literals make
+math sequences specialized-arrays typed fry io.mmap formatting
+locals splitting io.binary arrays ;
+FROM: alien.c-types => short ;
IN: macho
+! FFI data
TYPEDEF: int integer_t
TYPEDEF: int vm_prot_t
TYPEDEF: integer_t cpu_type_t
PPC_RELOC_JBSR
PPC_RELOC_LO14_SECTDIFF
PPC_RELOC_LOCAL_SECTDIFF ;
+
+! Low-level interface
+SPECIALIZED-ARRAYS: section section_64 nlist nlist_64 fat_arch uchar ;
+UNION: mach_header_32/64 mach_header mach_header_64 ;
+UNION: segment_command_32/64 segment_command segment_command_64 ;
+UNION: load-command segment_command segment_command_64
+ dylib_command sub_framework_command
+ sub_client_command sub_umbrella_command sub_library_command
+ prebound_dylib_command dylinker_command thread_command
+ routines_command routines_command_64 symtab_command
+ dysymtab_command twolevel_hints_command uuid_command ;
+UNION: section_32/64 section section_64 ;
+UNION: section_32/64-array section-array section_64-array ;
+UNION: nlist_32/64 nlist nlist_64 ;
+UNION: nlist_32/64-array nlist-array nlist_64-array ;
+
+TUPLE: fat-binary-member cpu-type cpu-subtype data ;
+ERROR: not-fat-binary ;
+
+TYPED: fat-binary-members ( >c-ptr -- fat-binary-members )
+ fat_header memory>struct dup magic>> {
+ { FAT_MAGIC [ ] }
+ { FAT_CIGAM [ ] }
+ [ 2drop not-fat-binary ]
+ } case dup
+ [ >c-ptr fat_header heap-size swap <displaced-alien> ]
+ [ nfat_arch>> 4 >be le> ] bi
+ <direct-fat_arch-array> [
+ {
+ [ nip cputype>> 4 >be le> ]
+ [ nip cpusubtype>> 4 >be le> ]
+ [ offset>> 4 >be le> swap >c-ptr <displaced-alien> ]
+ [ nip size>> 4 >be le> <direct-uchar-array> ]
+ } 2cleave fat-binary-member boa
+ ] with { } map-as ;
+
+TYPED: 64-bit? ( macho: mach_header_32/64 -- ? )
+ magic>> {
+ { MH_MAGIC_64 [ t ] }
+ { MH_CIGAM_64 [ t ] }
+ [ drop f ]
+ } case ;
+
+TYPED: macho-header ( c-ptr -- macho: mach_header_32/64 )
+ dup mach_header_64 memory>struct 64-bit?
+ [ mach_header_64 memory>struct ]
+ [ mach_header memory>struct ] if ;
+
+: cmd>load-command ( cmd -- load-command )
+ {
+ { LC_UUID [ uuid_command ] }
+ { LC_SEGMENT [ segment_command ] }
+ { LC_SEGMENT_64 [ segment_command_64 ] }
+ { LC_SYMTAB [ symtab_command ] }
+ { LC_DYSYMTAB [ dysymtab_command ] }
+ { LC_THREAD [ thread_command ] }
+ { LC_UNIXTHREAD [ thread_command ] }
+ { LC_LOAD_DYLIB [ dylib_command ] }
+ { LC_ID_DYLIB [ dylib_command ] }
+ { LC_PREBOUND_DYLIB [ prebound_dylib_command ] }
+ { LC_LOAD_DYLINKER [ dylinker_command ] }
+ { LC_ID_DYLINKER [ dylinker_command ] }
+ { LC_ROUTINES [ routines_command ] }
+ { LC_ROUTINES_64 [ routines_command_64 ] }
+ { LC_TWOLEVEL_HINTS [ twolevel_hints_command ] }
+ { LC_SUB_FRAMEWORK [ sub_framework_command ] }
+ { LC_SUB_UMBRELLA [ sub_umbrella_command ] }
+ { LC_SUB_LIBRARY [ sub_library_command ] }
+ { LC_SUB_CLIENT [ sub_client_command ] }
+ { LC_DYLD_INFO [ dyld_info_command ] }
+ { LC_DYLD_INFO_ONLY [ dyld_info_command ] }
+ } case ;
+
+: read-command ( cmd -- next-cmd )
+ dup load_command memory>struct
+ [ cmd>> cmd>load-command memory>struct , ]
+ [ cmdsize>> swap <displaced-alien> ] 2bi ;
+
+TYPED: load-commands ( macho: mach_header_32/64 -- load-commands )
+ [
+ [ class heap-size ]
+ [ >c-ptr <displaced-alien> ]
+ [ ncmds>> ] tri iota [
+ drop read-command
+ ] each drop
+ ] { } make ;
+
+: segment-commands ( load-commands -- segment-commands )
+ [ segment_command_32/64? ] filter ; inline
+
+: symtab-commands ( load-commands -- segment-commands )
+ [ symtab_command? ] filter ; inline
+
+: read-array-string ( uchar-array -- string )
+ ascii decode [ 0 = not ] filter ;
+
+: segment-sections ( segment-command -- sections )
+ {
+ [ class heap-size ]
+ [ >c-ptr <displaced-alien> ]
+ [ nsects>> ]
+ [ segment_command_64? ]
+ } cleave
+ [ <direct-section_64-array> ]
+ [ <direct-section-array> ] if ;
+
+: sections-array ( segment-commands -- sections-array )
+ [
+ dup first segment_command_64?
+ [ section_64 ] [ section ] if <struct> ,
+ segment-commands [ segment-sections [ , ] each ] each
+ ] { } make ;
+
+: symbols ( mach-header symtab-command -- symbols string-table )
+ [ symoff>> swap >c-ptr <displaced-alien> ]
+ [ nsyms>> swap 64-bit?
+ [ <direct-nlist_64-array> ]
+ [ <direct-nlist-array> ] if ]
+ [ stroff>> swap >c-ptr <displaced-alien> ] 2tri ;
+
+: symbol-name ( symbol string-table -- name )
+ [ n_strx>> ] dip <displaced-alien> ascii alien>string ;
+
+: c-symbol-name ( symbol string-table -- name )
+ symbol-name "_" ?head drop ;
+
+: with-mapped-macho ( path quot -- )
+ '[
+ address>> macho-header @
+ ] with-mapped-file-reader ; inline
+
+: macho-nm ( path -- )
+ [| macho |
+ macho load-commands segment-commands sections-array :> sections
+ macho load-commands symtab-commands [| symtab |
+ macho symtab symbols [
+ [ drop n_value>> "%016x " printf ]
+ [
+ drop n_sect>> sections nth sectname>>
+ read-array-string "%-16s" printf
+ ]
+ [ symbol-name "%s\n" printf ] 2tri
+ ] curry each
+ ] each
+ ] with-mapped-macho ;
+
+: dylib-export? ( symtab-entry -- ? )
+ n_type>> {
+ [ N_EXT bitand zero? not ]
+ [ N_TYPE bitand N_UNDF = not ]
+ } 1&& ;
+
+: dylib-exports ( path -- symbol-names )
+ [| macho |
+ macho load-commands symtab-commands [| symtab |
+ macho symtab symbols
+ [ [ dylib-export? ] filter ]
+ [ [ c-symbol-name ] curry { } map-as ] bi*
+ ] { } map-as concat
+ ] with-mapped-macho ;
error. flush ;
: build-loop ( -- )
- notify-heartbeat
?prepare-build-machine
[
+ notify-heartbeat
[
builds/factor set-current-directory
new-code-available? [ build ] when
: remote-directory ( string -- string' )
[ upload-directory get ] dip "/" glue ;
-: remote ( string version -- string )
- remote-directory swap "/" glue ;
-
: platform ( builder -- string )
[ os>> ] [ cpu>> ] bi (platform) ;
] [ drop ] 2bi release-directory ;
: remote-binary-release-name ( version builder -- string )
- [ binary-release-name ] [ drop ] 2bi remote ;
+ binary-release-name remote-directory ;
: source-release-name ( version -- string )
[ "factor-src-" ".zip" surround ] keep release-directory ;
: remote-source-release-name ( version -- string )
- [ source-release-name ] keep remote ;
+ source-release-name remote-directory ;
: make-release-directory ( version -- )
"Creating release directory..." print flush
- [ "mkdir -p " % "" release-directory % "\n" % ] "" make
+ [ "mkdir -p " % "" release-directory remote-directory % "\n" % ] "" make
execute-on-server ;
: tweet-release ( version announcement-url -- )
! Copyright (C) 2010 Erik Charlebois.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.libraries alien.syntax classes.struct
-combinators system alien.accessors byte-arrays kernel ;
+USING: alien alien.c-types alien.libraries alien.syntax
+classes.struct combinators system alien.accessors byte-arrays
+kernel ;
IN: opencl.ffi
<< "opencl" {
bindings
-untested
+not tested
! Copyright (C) 2010 Erik Charlebois.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.accessors alien.c-types arrays
-byte-arrays combinators combinators.smart continuations destructors
-fry io.encodings.ascii io.encodings.string kernel libc locals macros
-math math.order multiline opencl.ffi prettyprint sequences
-specialized-arrays typed variants namespaces ;
+USING: accessors alien alien.c-types arrays byte-arrays combinators
+combinators.smart destructors io.encodings.ascii io.encodings.string
+kernel libc locals math namespaces opencl.ffi sequences shuffle
+specialized-arrays variants ;
IN: opencl
SPECIALIZED-ARRAYS: void* char size_t ;
: cl-not-null ( err -- )
dup f = [ cl-error ] [ drop ] if ; inline
+
+: info-data-size ( handle name info-quot -- size_t )
+ [ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop *size_t ; inline
+
+: info-data-bytes ( handle name info-quot size -- bytes )
+ swap [ dup <byte-array> f ] dip [ call cl-success ] 3keep 2drop ; inline
+
+: info ( handle name info-quot lift-quot -- value )
+ [ 3dup info-data-size info-data-bytes ] dip call ; inline
+
+: 2info-data-size ( handle1 handle2 name info-quot -- size_t )
+ [ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop *size_t ; inline
-MACRO: info ( info-quot lift-quot -- quot )
- [ dup ] dip '[ 2dup 0 f 0 <size_t> _ '[ _ call cl-success ] keep
- *size_t dup <byte-array> _ '[ f _ call cl-success ] keep
- _ call ] ;
-
-MACRO: 2info ( info-quot lift-quot -- quot )
- [ dup ] dip '[ 3dup 0 f 0 <size_t> _ '[ _ call cl-success ] keep
- *size_t dup <byte-array> _ '[ f _ call cl-success ] keep
- _ call ] ;
-
+: 2info-data-bytes ( handle1 handle2 name info-quot size -- bytes )
+ swap [ dup <byte-array> f ] dip [ call cl-success ] 3keep 2drop ; inline
+
+: 2info ( handle1 handle2 name info_quot lift_quot -- value )
+ [ 4dup 2info-data-size 2info-data-bytes ] dip call ; inline
+
: info-bool ( handle name quot -- ? )
[ *uint CL_TRUE = ] info ; inline
SYMBOLS: cl-current-context cl-current-queue cl-current-device ;
<PRIVATE
+
: (current-cl-context) ( -- cl-context )
cl-current-context get ; inline
} case ; inline
: platform-info-string ( handle name -- string )
- [ clGetPlatformInfo ] info-string ; inline
+ [ clGetPlatformInfo ] info-string ;
: platform-info ( id -- profile version name vendor extensions )
{
} case ; inline
: device-info-bool ( handle name -- ? )
- [ clGetDeviceInfo ] info-bool ; inline
+ [ clGetDeviceInfo ] info-bool ;
: device-info-ulong ( handle name -- ulong )
- [ clGetDeviceInfo ] info-ulong ; inline
+ [ clGetDeviceInfo ] info-ulong ;
: device-info-uint ( handle name -- uint )
- [ clGetDeviceInfo ] info-uint ; inline
+ [ clGetDeviceInfo ] info-uint ;
: device-info-string ( handle name -- string )
- [ clGetDeviceInfo ] info-string ; inline
+ [ clGetDeviceInfo ] info-string ;
: device-info-size_t ( handle name -- size_t )
- [ clGetDeviceInfo ] info-size_t ; inline
+ [ clGetDeviceInfo ] info-size_t ;
: device-info-size_t-array ( handle name -- size_t-array )
- [ clGetDeviceInfo ] info-size_t-array ; inline
+ [ clGetDeviceInfo ] info-size_t-array ;
: device-info ( device-id -- device )
dup {
] 2bi ; inline
: command-queue-info-ulong ( handle name -- ulong )
- [ clGetCommandQueueInfo ] info-ulong ; inline
+ [ clGetCommandQueueInfo ] info-ulong ;
: sampler-info-bool ( handle name -- ? )
- [ clGetSamplerInfo ] info-bool ; inline
+ [ clGetSamplerInfo ] info-bool ;
: sampler-info-uint ( handle name -- uint )
- [ clGetSamplerInfo ] info-uint ; inline
+ [ clGetSamplerInfo ] info-uint ;
: program-build-info-string ( program-handle device-handle name -- string )
- [ clGetProgramBuildInfo ] 2info-string ; inline
+ [ clGetProgramBuildInfo ] 2info-string ;
: program-build-log ( program-handle device-handle -- string )
- CL_PROGRAM_BUILD_LOG program-build-info-string ; inline
+ CL_PROGRAM_BUILD_LOG program-build-info-string ;
: strings>char*-array ( strings -- char*-array )
[ ascii encode dup length dup malloc [ cl-not-null ]
- keep &free [ -rot memcpy ] keep ] void*-array{ } map-as ; inline
+ keep &free [ -rot memcpy ] keep ] void*-array{ } map-as ;
: (program) ( cl-context sources -- program-handle )
[ handle>> ] dip [
} case ;
: kernel-info-string ( handle name -- string )
- [ clGetKernelInfo ] info-string ; inline
+ [ clGetKernelInfo ] info-string ;
: kernel-info-uint ( handle name -- uint )
- [ clGetKernelInfo ] info-uint ; inline
+ [ clGetKernelInfo ] info-uint ;
: kernel-work-group-info-size_t ( handle1 handle2 name -- size_t )
- [ clGetKernelWorkGroupInfo ] 2info-size_t ; inline
+ [ clGetKernelWorkGroupInfo ] 2info-size_t ;
: event-info-uint ( handle name -- uint )
- [ clGetEventInfo ] info-uint ; inline
+ [ clGetEventInfo ] info-uint ;
: event-info-int ( handle name -- int )
- [ clGetEventInfo ] info-int ; inline
+ [ clGetEventInfo ] info-int ;
: cl_command_type>command-type ( cl_command-type -- command-type )
{
} case ; inline
: profiling-info-ulong ( handle name -- ulong )
- [ clGetEventProfilingInfo ] info-ulong ; inline
-
+ [ clGetEventProfilingInfo ] info-ulong ;
: bind-kernel-arg-buffer ( kernel index buffer -- )
[ handle>> ] [ cl_mem heap-size ] [ handle>> <void*> ] tri*
cl-kernel new-disposable swap >>handle ; inline
: cl-kernel-name ( kernel -- string )
- handle>> CL_KERNEL_FUNCTION_NAME kernel-info-string ; inline
+ handle>> CL_KERNEL_FUNCTION_NAME kernel-info-string ;
: cl-kernel-arity ( kernel -- arity )
- handle>> CL_KERNEL_NUM_ARGS kernel-info-uint ; inline
+ handle>> CL_KERNEL_NUM_ARGS kernel-info-uint ;
: cl-kernel-local-size ( kernel -- size )
(current-cl-device) [ handle>> ] bi@ CL_KERNEL_WORK_GROUP_SIZE kernel-work-group-info-size_t ; inline
bindings
-untested
+not tested
: <make-release-action> ( -- action )
<page-action>
- [ { { "version" [ v-one-line ] } } validate-params ] >>validate
+ [
+ {
+ { "version" [ v-one-line ] }
+ { "announcement-url" [ v-url ] }
+ } validate-params
+ ] >>validate
[
[
"version" value "announcement-url" value do-release
if(obj.type_p(QUOTATION_TYPE))
{
char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame,this);
- char *quot_entry_point = (char *)(frame_code(frame) + 1);
+ char *quot_entry_point = (char *)frame_code(frame)->entry_point();
return tag_fixnum(quot_code_offset_to_scan(
obj.value(),(cell)(return_addr - quot_entry_point)));
if(feof(file))
{
byte_array *new_buf = allot_byte_array(c);
- memcpy(new_buf + 1, buf.untagged() + 1,c);
+ memcpy(new_buf->data<char>(), buf->data<char>(),c);
buf = new_buf;
}
ctx->replace(allot_float(bignum_to_float(ctx->peek())));
}
-void factor_vm::primitive_float_to_str()
+void factor_vm::primitive_format_float()
{
- byte_array *array = allot_byte_array(33);
- SNPRINTF((char *)(array + 1),32,"%.16g",untag_float_check(ctx->pop()));
+ byte_array *array = allot_byte_array(100);
+ char *format = alien_offset(ctx->pop());
+ double value = untag_float_check(ctx->pop());
+ SNPRINTF(array->data<char>(),99,format,value);
ctx->push(tag<byte_array>(array));
}
_(float_subtract) \
_(float_to_bignum) \
_(float_to_fixnum) \
- _(float_to_str) \
_(fopen) \
+ _(format_float) \
_(fputc) \
_(fread) \
_(fseek) \
cell unbox_array_size_slow();
void primitive_fixnum_to_float();
void primitive_bignum_to_float();
- void primitive_float_to_str();
+ void primitive_format_float();
void primitive_float_eq();
void primitive_float_add();
void primitive_float_subtract();
projects / factor.git / commitdiff