Merge branch 'master' of git://repo.or.cz/factor/jcg
U-VICTORIA\Administrator
commit
196e9d6884
|
|
@ -29,7 +29,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
|
|||
writer>> swap "writing" set-word-prop ;
|
||||
|
||||
: reader-word ( class name vocab -- word )
|
||||
[ "-" swap 3append ] dip create ;
|
||||
[ "-" glue ] dip create ;
|
||||
|
||||
: writer-word ( class name vocab -- word )
|
||||
[ [ swap "set-" % % "-" % % ] "" make ] dip create ;
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ IN: compiler.tree.builder
|
|||
: build-tree-with ( in-stack quot -- nodes out-stack )
|
||||
#! Not safe to call from inference transforms.
|
||||
[
|
||||
[ >vector meta-d set ]
|
||||
[ >vector \ meta-d set ]
|
||||
[ f initial-recursive-state infer-quot ] bi*
|
||||
] with-tree-builder nip
|
||||
unclip-last in-d>> ;
|
||||
|
|
|
|||
|
|
@ -20,6 +20,10 @@ SYMBOL: node-count
|
|||
: count-nodes ( nodes -- )
|
||||
0 swap [ drop 1+ ] each-node node-count set ;
|
||||
|
||||
! We try not to inline the same word too many times, to avoid
|
||||
! combinatorial explosion
|
||||
SYMBOL: inlining-count
|
||||
|
||||
! Splicing nodes
|
||||
GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
|
||||
|
||||
|
|
@ -120,17 +124,25 @@ DEFER: (flat-length)
|
|||
bi and
|
||||
] contains? ;
|
||||
|
||||
: node-count-bias ( -- n )
|
||||
45 node-count get [-] 8 /i ;
|
||||
|
||||
: body-length-bias ( word -- n )
|
||||
[ flat-length ] [ inlining-count get at 0 or 2/ 1+ ] bi *
|
||||
24 swap [-] 4 /i ;
|
||||
|
||||
: inlining-rank ( #call word -- n )
|
||||
[ classes-known? 2 0 ? ]
|
||||
[
|
||||
{
|
||||
[ drop node-count get 45 swap [-] 8 /i ]
|
||||
[ flat-length 24 swap [-] 4 /i ]
|
||||
[ body-length-bias ]
|
||||
[ "default" word-prop -4 0 ? ]
|
||||
[ "specializer" word-prop 1 0 ? ]
|
||||
[ method-body? 1 0 ? ]
|
||||
} cleave
|
||||
] bi* + + + + + ;
|
||||
node-count-bias
|
||||
loop-nesting get 0 or 2 *
|
||||
] bi* + + + + + + ;
|
||||
|
||||
: should-inline? ( #call word -- ? )
|
||||
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
|
||||
|
|
@ -138,12 +150,12 @@ DEFER: (flat-length)
|
|||
SYMBOL: history
|
||||
|
||||
: remember-inlining ( word -- )
|
||||
history [ swap suffix ] change ;
|
||||
[ [ 1 ] dip inlining-count get at+ ]
|
||||
[ history [ swap suffix ] change ]
|
||||
bi ;
|
||||
|
||||
: inline-word-def ( #call word quot -- ? )
|
||||
over history get memq? [
|
||||
3drop f
|
||||
] [
|
||||
over history get memq? [ 3drop f ] [
|
||||
[
|
||||
swap remember-inlining
|
||||
dupd splicing-nodes >>body
|
||||
|
|
|
|||
|
|
@ -6,6 +6,8 @@ compiler.tree.propagation.copy
|
|||
compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.nodes
|
||||
|
||||
SYMBOL: loop-nesting
|
||||
|
||||
GENERIC: propagate-before ( node -- )
|
||||
|
||||
GENERIC: propagate-after ( node -- )
|
||||
|
|
|
|||
|
|
@ -19,5 +19,6 @@ IN: compiler.tree.propagation
|
|||
H{ } clone copies set
|
||||
H{ } clone 1array value-infos set
|
||||
H{ } clone 1array constraints set
|
||||
H{ } clone inlining-count set
|
||||
dup count-nodes
|
||||
dup (propagate) ;
|
||||
|
|
|
|||
|
|
@ -55,6 +55,8 @@ IN: compiler.tree.propagation.recursive
|
|||
M: #recursive propagate-around ( #recursive -- )
|
||||
constraints [ H{ } clone suffix ] change
|
||||
[
|
||||
loop-nesting inc
|
||||
|
||||
constraints [ but-last H{ } clone suffix ] change
|
||||
|
||||
child>>
|
||||
|
|
@ -62,6 +64,8 @@ M: #recursive propagate-around ( #recursive -- )
|
|||
[ first propagate-recursive-phi ]
|
||||
[ (propagate) ]
|
||||
tri
|
||||
|
||||
loop-nesting dec
|
||||
] until-fixed-point ;
|
||||
|
||||
: recursive-phi-infos ( node -- infos )
|
||||
|
|
|
|||
|
|
@ -266,8 +266,8 @@ M: postgresql-db persistent-table ( -- hashtable )
|
|||
ERROR: no-compound-found string object ;
|
||||
M: postgresql-db compound ( string object -- string' )
|
||||
over {
|
||||
{ "default" [ first number>string join-space ] }
|
||||
{ "varchar" [ first number>string paren append ] }
|
||||
{ "default" [ first number>string " " glue ] }
|
||||
{ "varchar" [ first number>string "(" ")" surround append ] }
|
||||
{ "references" [ >reference-string ] }
|
||||
[ drop no-compound-found ]
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -162,22 +162,19 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
|
|||
where-clause
|
||||
] query-make ;
|
||||
|
||||
: splice ( string1 string2 string3 -- string )
|
||||
swap 3append ;
|
||||
|
||||
: do-group ( tuple groups -- )
|
||||
dup string? [ 1array ] when
|
||||
[ ", " join " group by " splice ] curry change-sql drop ;
|
||||
[ ", " join " group by " glue ] curry change-sql drop ;
|
||||
|
||||
: do-order ( tuple order -- )
|
||||
dup string? [ 1array ] when
|
||||
[ ", " join " order by " splice ] curry change-sql drop ;
|
||||
[ ", " join " order by " glue ] curry change-sql drop ;
|
||||
|
||||
: do-offset ( tuple n -- )
|
||||
[ number>string " offset " splice ] curry change-sql drop ;
|
||||
[ number>string " offset " glue ] curry change-sql drop ;
|
||||
|
||||
: do-limit ( tuple n -- )
|
||||
[ number>string " limit " splice ] curry change-sql drop ;
|
||||
[ number>string " limit " glue ] curry change-sql drop ;
|
||||
|
||||
: make-query* ( tuple query -- tuple' )
|
||||
dupd
|
||||
|
|
|
|||
|
|
@ -308,7 +308,7 @@ M: sqlite-db persistent-table ( -- assoc )
|
|||
|
||||
M: sqlite-db compound ( string seq -- new-string )
|
||||
over {
|
||||
{ "default" [ first number>string join-space ] }
|
||||
{ "default" [ first number>string " " glue ] }
|
||||
{ "references" [
|
||||
[ >reference-string ] keep
|
||||
first2 [ "foreign-table" set ]
|
||||
|
|
|
|||
|
|
@ -147,12 +147,6 @@ HELP: get-slot-named
|
|||
{ "value" "the value stored in the slot" } }
|
||||
{ $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ;
|
||||
|
||||
HELP: join-space
|
||||
{ $values
|
||||
{ "string1" string } { "string2" string }
|
||||
{ "new-string" null } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: literal-bind
|
||||
{ $description "" } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -158,12 +158,6 @@ ERROR: no-sql-type type ;
|
|||
modifiers>> [ lookup-modifier ] map " " join
|
||||
[ "" ] [ " " prepend ] if-empty ;
|
||||
|
||||
: join-space ( string1 string2 -- new-string )
|
||||
" " swap 3append ;
|
||||
|
||||
: paren ( string -- new-string )
|
||||
"(" swap ")" 3append ;
|
||||
|
||||
HOOK: bind% db ( spec -- )
|
||||
HOOK: bind# db ( spec obj -- )
|
||||
|
||||
|
|
@ -171,7 +165,7 @@ ERROR: no-column column ;
|
|||
|
||||
: >reference-string ( string pair -- string )
|
||||
first2
|
||||
[ [ unparse join-space ] [ db-columns ] bi ] dip
|
||||
[ [ unparse " " glue ] [ db-columns ] bi ] dip
|
||||
swap [ column-name>> = ] with find nip
|
||||
[ no-column ] unless*
|
||||
column-name>> paren append ;
|
||||
column-name>> "(" ")" surround append ;
|
||||
|
|
|
|||
|
|
@ -14,7 +14,10 @@ IN: editors.scite
|
|||
|
||||
: scite-path ( -- path )
|
||||
\ scite-path get-global [
|
||||
program-files "wscite\\SciTE.exe" append-path
|
||||
program-files "ScITE Source Code Editor\\SciTE.exe" append-path
|
||||
dup exists? [
|
||||
drop program-files "wscite\\SciTE.exe" append-path
|
||||
] unless
|
||||
] unless* ;
|
||||
|
||||
: scite-command ( file line -- cmd )
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ HOOK: (set-os-envs) os ( seq -- )
|
|||
(os-envs) [ "=" split1 ] H{ } map>assoc ;
|
||||
|
||||
: set-os-envs ( assoc -- )
|
||||
[ "=" swap 3append ] { } assoc>map (set-os-envs) ;
|
||||
[ "=" glue ] { } assoc>map (set-os-envs) ;
|
||||
|
||||
{
|
||||
{ [ os unix? ] [ "environment.unix" require ] }
|
||||
|
|
|
|||
|
|
@ -7,8 +7,7 @@ namespaces make sequences ftp io.unix.launcher.parser
|
|||
unicode.case splitting assocs classes io.servers.connection
|
||||
destructors calendar io.timeouts io.streams.duplex threads
|
||||
continuations math concurrency.promises byte-arrays
|
||||
io.backend sequences.lib tools.hexdump tools.files
|
||||
io.streams.string ;
|
||||
io.backend tools.hexdump tools.files io.streams.string ;
|
||||
IN: ftp.server
|
||||
|
||||
TUPLE: ftp-client url mode state command-promise user password ;
|
||||
|
|
@ -231,7 +230,7 @@ M: ftp-put service-command ( stream obj -- )
|
|||
expect-connection
|
||||
[
|
||||
"Entering Passive Mode (127,0,0,1," %
|
||||
port>bytes [ number>string ] bi@ "," splice %
|
||||
port>bytes [ number>string ] bi@ "," glue %
|
||||
")" %
|
||||
] "" make 227 swap server-response ;
|
||||
|
||||
|
|
@ -17,7 +17,7 @@ IN: functors
|
|||
scan-param parsed
|
||||
scan {
|
||||
{ ";" [ tuple parsed f parsed ] }
|
||||
{ "<" [ scan-param [ parse-tuple-slots ] { } make parsed ] }
|
||||
{ "<" [ scan-param parsed [ parse-tuple-slots ] { } make parsed ] }
|
||||
[
|
||||
[ tuple parsed ] dip
|
||||
[ parse-slot-name [ parse-tuple-slots ] when ] { }
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ http.server.redirection http.server.remapping ;
|
|||
IN: furnace.utilities
|
||||
|
||||
: word>string ( word -- string )
|
||||
[ vocabulary>> ] [ name>> ] bi ":" swap 3append ;
|
||||
[ vocabulary>> ] [ name>> ] bi ":" glue ;
|
||||
|
||||
: words>strings ( seq -- seq' )
|
||||
[ word>string ] map ;
|
||||
|
|
|
|||
|
|
@ -111,7 +111,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
|
|||
{ [ dup real? ] [ number>string ] }
|
||||
[ ]
|
||||
} cond
|
||||
[ check-cookie-string ] bi@ "=" swap 3append ,
|
||||
[ check-cookie-string ] bi@ "=" glue ,
|
||||
]
|
||||
} case ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,22 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test interpolate ;
|
||||
USING: interpolate io.streams.string namespaces tools.test locals ;
|
||||
IN: interpolate.tests
|
||||
|
||||
[ "Hello, Jane." ] [
|
||||
"Jane" "name" set
|
||||
[ "Hello, ${name}." interpolate ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ "Sup Dawg, we heard you liked rims, so we put rims on your rims so you can roll while you roll." ] [
|
||||
"Dawg" "name" set
|
||||
"rims" "noun" set
|
||||
"roll" "verb" set
|
||||
[ "Sup ${name}, we heard you liked ${noun}, so we put ${noun} on your ${noun} so you can ${verb} while you ${verb}." interpolate ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ "Oops, I accidentally the whole economy..." ] [
|
||||
[let | noun [ "economy" ] |
|
||||
[ I[ Oops, I accidentally the whole ${noun}...]I ] with-string-writer
|
||||
]
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,21 +1,40 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io kernel macros make multiline namespaces parser
|
||||
peg.ebnf present sequences strings ;
|
||||
present sequences strings splitting fry accessors ;
|
||||
IN: interpolate
|
||||
|
||||
MACRO: interpolate ( string -- )
|
||||
[EBNF
|
||||
var = "${" [^}]+ "}" => [[ second >string [ get present write ] curry ]]
|
||||
text = [^$]+ => [[ >string [ write ] curry ]]
|
||||
interpolate = (var|text)* => [[ [ ] join ]]
|
||||
EBNF] ;
|
||||
TUPLE: interpolate-var name ;
|
||||
|
||||
EBNF: interpolate-locals
|
||||
var = "${" [^}]+ "}" => [[ [ second >string search , [ present write ] % ] [ ] make ]]
|
||||
text = [^$]+ => [[ [ >string , [ write ] % ] [ ] make ]]
|
||||
interpolate = (var|text)* => [[ [ ] join ]]
|
||||
;EBNF
|
||||
: (parse-interpolate) ( string -- )
|
||||
[
|
||||
"${" split1-slice [ >string , ] [
|
||||
[
|
||||
"}" split1-slice
|
||||
[ >string interpolate-var boa , ]
|
||||
[ (parse-interpolate) ] bi*
|
||||
] when*
|
||||
] bi*
|
||||
] unless-empty ;
|
||||
|
||||
: parse-interpolate ( string -- seq )
|
||||
[ (parse-interpolate) ] { } make ;
|
||||
|
||||
MACRO: interpolate ( string -- )
|
||||
parse-interpolate [
|
||||
dup interpolate-var?
|
||||
[ name>> '[ _ get present write ] ]
|
||||
[ '[ _ write ] ]
|
||||
if
|
||||
] map [ ] join ;
|
||||
|
||||
: interpolate-locals ( string -- quot )
|
||||
parse-interpolate [
|
||||
dup interpolate-var?
|
||||
[ name>> search '[ _ present write ] ]
|
||||
[ '[ _ write ] ]
|
||||
if
|
||||
] map [ ] join ;
|
||||
|
||||
: I[ "]I" parse-multiline-string
|
||||
interpolate-locals parsed \ call parsed ; parsing
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.bitwise combinators.lib math.parser
|
||||
random sequences sequences.lib continuations namespaces
|
||||
USING: kernel math math.bitwise math.parser
|
||||
random sequences continuations namespaces
|
||||
io.files io arrays io.files.unique.backend system
|
||||
combinators vocabs.loader fry ;
|
||||
IN: io.files.unique
|
||||
|
|
@ -29,7 +29,7 @@ PRIVATE>
|
|||
: make-unique-file ( prefix suffix -- path )
|
||||
temporary-path -rot
|
||||
[
|
||||
unique-length get random-name swap 3append append-path
|
||||
unique-length get random-name glue append-path
|
||||
dup (make-unique-file)
|
||||
] 3curry unique-retries get retry ;
|
||||
|
||||
|
|
@ -79,7 +79,7 @@ M: threaded-server handle-client* handler>> call ;
|
|||
\ handle-client ERROR add-error-logging
|
||||
|
||||
: thread-name ( server-name addrspec -- string )
|
||||
unparse-short " connection from " swap 3append ;
|
||||
unparse-short " connection from " glue ;
|
||||
|
||||
: accept-connection ( threaded-server -- )
|
||||
[ accept ] [ addr>> ] bi
|
||||
|
|
|
|||
|
|
@ -115,7 +115,7 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ;
|
|||
: pad-inet6 ( string1 string2 -- seq )
|
||||
2dup [ length ] bi@ + 8 swap -
|
||||
dup 0 < [ "More than 8 components" throw ] when
|
||||
<byte-array> swap 3append ;
|
||||
<byte-array> glue ;
|
||||
|
||||
: inet6-bytes ( seq -- bytes )
|
||||
[ 2 >be ] { } map-as concat >byte-array ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: alien.syntax kernel unix.stat math unix
|
|||
combinators system io.backend accessors alien.c-types
|
||||
io.encodings.utf8 alien.strings unix.types io.unix.files
|
||||
io.files unix.statvfs.netbsd unix.getfsstat.netbsd
|
||||
grouping sequences ;
|
||||
grouping sequences io.encodings.utf8 ;
|
||||
IN: io.unix.files.netbsd
|
||||
|
||||
TUPLE: netbsd-file-system-info < unix-file-system-info
|
||||
|
|
@ -40,13 +40,13 @@ M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-inf
|
|||
[ statvfs-f_namemax >>name-max ]
|
||||
[ statvfs-f_owner >>owner ]
|
||||
! [ statvfs-f_spare >>spare ]
|
||||
[ statvfs-f_fstypename alien>native-string >>type ]
|
||||
[ statvfs-f_mntonname alien>native-string >>mount-point ]
|
||||
[ statvfs-f_mntfromname alien>native-string >>device-name ]
|
||||
[ statvfs-f_fstypename utf8 alien>string >>type ]
|
||||
[ statvfs-f_mntonname utf8 alien>string >>mount-point ]
|
||||
[ statvfs-f_mntfromname utf8 alien>string >>device-name ]
|
||||
} cleave ;
|
||||
|
||||
M: netbsd file-systems ( -- array )
|
||||
f 0 0 getvfsstat dup io-error
|
||||
"statvfs" <c-array> dup dup length 0 getvfsstat io-error
|
||||
"statvfs" heap-size group
|
||||
[ statvfs-f_mntonname alien>native-string file-system-info ] map ;
|
||||
[ statvfs-f_mntonname utf8 alien>string file-system-info ] map ;
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ USE: unix
|
|||
command>> dup string? [ tokenize-command ] when ;
|
||||
|
||||
: assoc>env ( assoc -- env )
|
||||
[ "=" swap 3append ] { } assoc>map ;
|
||||
[ "=" glue ] { } assoc>map ;
|
||||
|
||||
: setup-priority ( process -- process )
|
||||
dup priority>> [
|
||||
|
|
|
|||
|
|
@ -1,8 +0,0 @@
|
|||
USING: io io.mmap io.files kernel tools.test continuations
|
||||
sequences io.encodings.ascii accessors ;
|
||||
IN: io.windows.mmap.tests
|
||||
|
||||
[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test
|
||||
[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
|
||||
[ ] [ "mmap-grow-test.txt" temp-file 100 [ [ ] change-each ] with-mapped-file ] unit-test
|
||||
[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
|
||||
|
|
@ -3,13 +3,14 @@ IN: math.statistics
|
|||
|
||||
HELP: geometric-mean
|
||||
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
|
||||
{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." }
|
||||
{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." }
|
||||
{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
|
||||
{ $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ;
|
||||
|
||||
HELP: harmonic-mean
|
||||
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
|
||||
{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
|
||||
{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
|
||||
{ $notes "Positive reals only." }
|
||||
{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } }
|
||||
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
|
||||
|
||||
|
|
@ -36,21 +37,21 @@ HELP: range
|
|||
|
||||
HELP: std
|
||||
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
|
||||
{ $description "Computes the standard deviation of " { $snippet "seq" } " by squaring the variance of the sequence. It measures how widely spread the values in a sequence are about the mean." }
|
||||
{ $description "Computes the standard deviation of " { $snippet "seq" } ", which is the square root of the variance. It measures how widely spread the values in a sequence are about the mean." }
|
||||
{ $examples
|
||||
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" }
|
||||
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ;
|
||||
|
||||
HELP: ste
|
||||
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
|
||||
{ $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." }
|
||||
{ $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." }
|
||||
{ $examples
|
||||
{ $example "USING: math.statistics prettyprint ;" "{ -2 2 } ste ." "2.0" }
|
||||
{ $example "USING: math.statistics prettyprint ;" "{ -2 2 2 } ste ." "1.333333333333333" } } ;
|
||||
|
||||
HELP: var
|
||||
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
|
||||
{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." }
|
||||
{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." }
|
||||
{ $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." }
|
||||
{ $examples
|
||||
{ $example "USING: math.statistics prettyprint ;" "{ 1 } var ." "0" }
|
||||
|
|
@ -5,20 +5,15 @@ USING: arrays combinators kernel math math.analysis math.functions sequences
|
|||
IN: math.statistics
|
||||
|
||||
: mean ( seq -- n )
|
||||
#! arithmetic mean, sum divided by length
|
||||
[ sum ] [ length ] bi / ;
|
||||
|
||||
: geometric-mean ( seq -- n )
|
||||
#! geometric mean, nth root of product
|
||||
[ length ] [ product ] bi nth-root ;
|
||||
|
||||
: harmonic-mean ( seq -- n )
|
||||
#! harmonic mean, reciprocal of sum of reciprocals.
|
||||
#! positive reals only
|
||||
[ recip ] sigma recip ;
|
||||
|
||||
: median ( seq -- n )
|
||||
#! middle number if odd, avg of two middle numbers if even
|
||||
natural-sort dup length even? [
|
||||
[ midpoint@ dup 1- 2array ] keep nths mean
|
||||
] [
|
||||
|
|
@ -26,11 +21,10 @@ IN: math.statistics
|
|||
] if ;
|
||||
|
||||
: range ( seq -- n )
|
||||
#! max - min
|
||||
minmax swap - ;
|
||||
|
||||
: var ( seq -- x )
|
||||
#! variance, normalize by N-1
|
||||
#! normalize by N-1
|
||||
dup length 1 <= [
|
||||
drop 0
|
||||
] [
|
||||
|
|
@ -39,11 +33,9 @@ IN: math.statistics
|
|||
] if ;
|
||||
|
||||
: std ( seq -- x )
|
||||
#! standard deviation, sqrt of variance
|
||||
var sqrt ;
|
||||
|
||||
: ste ( seq -- x )
|
||||
#! standard error, standard deviation / sqrt ( length of sequence )
|
||||
[ std ] [ length ] bi sqrt / ;
|
||||
|
||||
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
|
||||
|
|
@ -129,7 +129,7 @@ SYMBOL: ->
|
|||
: remove-breakpoints ( quot pos -- quot' )
|
||||
over quotation? [
|
||||
1+ cut [ (remove-breakpoints) ] bi@
|
||||
[ -> ] swap 3append
|
||||
[ -> ] glue
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -15,11 +15,14 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
|
|||
: mt-m 397 ; inline
|
||||
: mt-a HEX: 9908b0df ; inline
|
||||
|
||||
: mersenne-wrap ( n -- n' )
|
||||
dup mt-n > [ mt-n - ] when ; inline
|
||||
|
||||
: wrap-nth ( n seq -- obj )
|
||||
[ length mod ] keep nth-unsafe ; inline
|
||||
[ mersenne-wrap ] dip nth-unsafe ; inline
|
||||
|
||||
: set-wrap-nth ( obj n seq -- )
|
||||
[ length mod ] keep set-nth-unsafe ; inline
|
||||
[ mersenne-wrap ] dip set-nth-unsafe ; inline
|
||||
|
||||
: calculate-y ( n seq -- y )
|
||||
[ wrap-nth 31 mask-bit ]
|
||||
|
|
@ -50,7 +53,7 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
|
|||
|
||||
: init-mt-seq ( seed -- seq )
|
||||
32 bits mt-n <uint-array>
|
||||
[ set-first ] [ init-mt-rest ] [ ] tri ;
|
||||
[ set-first ] [ init-mt-rest ] [ ] tri ; inline
|
||||
|
||||
: mt-temper ( y -- yt )
|
||||
dup -11 shift bitxor
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ SET-NTH [ T dup c-setter array-accessor ]
|
|||
WHERE
|
||||
|
||||
TUPLE: A
|
||||
{ underlying alien read-only }
|
||||
{ underlying c-ptr read-only }
|
||||
{ length fixnum read-only } ;
|
||||
|
||||
: <A> ( alien len -- direct-array ) A boa ; inline
|
||||
|
|
|
|||
|
|
@ -3,20 +3,21 @@ stack-checker.state sequences ;
|
|||
IN: stack-checker.backend.tests
|
||||
|
||||
[ ] [
|
||||
V{ } clone meta-d set
|
||||
V{ } clone meta-r set
|
||||
V{ } clone \ meta-d set
|
||||
V{ } clone \ meta-r set
|
||||
V{ } clone \ literals set
|
||||
0 d-in set
|
||||
] unit-test
|
||||
|
||||
[ 0 ] [ 0 ensure-d length ] unit-test
|
||||
|
||||
[ 2 ] [ 2 ensure-d length ] unit-test
|
||||
[ 2 ] [ meta-d get length ] unit-test
|
||||
[ 2 ] [ meta-d length ] unit-test
|
||||
|
||||
[ 3 ] [ 3 ensure-d length ] unit-test
|
||||
[ 3 ] [ meta-d get length ] unit-test
|
||||
[ 3 ] [ meta-d length ] unit-test
|
||||
|
||||
[ 1 ] [ 1 ensure-d length ] unit-test
|
||||
[ 3 ] [ meta-d get length ] unit-test
|
||||
[ 3 ] [ meta-d length ] unit-test
|
||||
|
||||
[ ] [ 1 consume-d drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -9,10 +9,10 @@ stack-checker.visitor stack-checker.errors
|
|||
stack-checker.values stack-checker.recursive-state ;
|
||||
IN: stack-checker.backend
|
||||
|
||||
: push-d ( obj -- ) meta-d get push ;
|
||||
: push-d ( obj -- ) meta-d push ;
|
||||
|
||||
: pop-d ( -- obj )
|
||||
meta-d get [
|
||||
meta-d [
|
||||
<value> dup 1array #introduce, d-in inc
|
||||
] [ pop ] if-empty ;
|
||||
|
||||
|
|
@ -22,46 +22,52 @@ IN: stack-checker.backend
|
|||
[ <value> ] replicate ;
|
||||
|
||||
: ensure-d ( n -- values )
|
||||
meta-d get 2dup length > [
|
||||
meta-d 2dup length > [
|
||||
2dup
|
||||
[ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
|
||||
[ length d-in +@ ] [ #introduce, ] [ meta-d get push-all ] tri
|
||||
meta-d get push-all
|
||||
[ length d-in +@ ] [ #introduce, ] [ meta-d push-all ] tri
|
||||
meta-d push-all
|
||||
] when swap tail* ;
|
||||
|
||||
: shorten-by ( n seq -- )
|
||||
[ length swap - ] keep shorten ; inline
|
||||
|
||||
: consume-d ( n -- seq )
|
||||
[ ensure-d ] [ meta-d get shorten-by ] bi ;
|
||||
[ ensure-d ] [ meta-d shorten-by ] bi ;
|
||||
|
||||
: output-d ( values -- ) meta-d get push-all ;
|
||||
: output-d ( values -- ) meta-d push-all ;
|
||||
|
||||
: produce-d ( n -- values )
|
||||
make-values dup meta-d get push-all ;
|
||||
make-values dup meta-d push-all ;
|
||||
|
||||
: push-r ( obj -- ) meta-r get push ;
|
||||
: push-r ( obj -- ) meta-r push ;
|
||||
|
||||
: pop-r ( -- obj )
|
||||
meta-r get dup empty?
|
||||
: pop-r ( -- obj )
|
||||
meta-r dup empty?
|
||||
[ too-many-r> inference-error ] [ pop ] if ;
|
||||
|
||||
: consume-r ( n -- seq )
|
||||
meta-r get 2dup length >
|
||||
meta-r 2dup length >
|
||||
[ too-many-r> inference-error ] when
|
||||
[ swap tail* ] [ shorten-by ] 2bi ;
|
||||
|
||||
: output-r ( seq -- ) meta-r get push-all ;
|
||||
|
||||
: pop-literal ( -- rstate obj )
|
||||
pop-d
|
||||
[ 1array #drop, ]
|
||||
[ literal [ recursion>> ] [ value>> ] bi ] bi ;
|
||||
|
||||
GENERIC: apply-object ( obj -- )
|
||||
: output-r ( seq -- ) meta-r push-all ;
|
||||
|
||||
: push-literal ( obj -- )
|
||||
dup <literal> make-known [ nip push-d ] [ #push, ] 2bi ;
|
||||
literals get push ;
|
||||
|
||||
: pop-literal ( -- rstate obj )
|
||||
literals get [
|
||||
pop-d
|
||||
[ 1array #drop, ]
|
||||
[ literal [ recursion>> ] [ value>> ] bi ] bi
|
||||
] [ pop recursive-state get swap ] if-empty ;
|
||||
|
||||
: literals-available? ( n -- literals ? )
|
||||
literals get 2dup length <=
|
||||
[ [ swap tail* ] [ shorten-by ] 2bi t ] [ 2drop f f ] if ;
|
||||
|
||||
GENERIC: apply-object ( obj -- )
|
||||
|
||||
M: wrapper apply-object
|
||||
wrapped>>
|
||||
|
|
@ -72,10 +78,17 @@ M: wrapper apply-object
|
|||
M: object apply-object push-literal ;
|
||||
|
||||
: terminate ( -- )
|
||||
terminated? on meta-d get clone meta-r get clone #terminate, ;
|
||||
terminated? on meta-d clone meta-r clone #terminate, ;
|
||||
|
||||
: check->r ( -- )
|
||||
meta-r empty? [ \ too-many->r inference-error ] unless ;
|
||||
|
||||
: infer-quot-here ( quot -- )
|
||||
[ apply-object terminated? get not ] all? drop ;
|
||||
meta-r [
|
||||
V{ } clone \ meta-r set
|
||||
[ apply-object terminated? get not ] all?
|
||||
[ commit-literals check->r ] [ literals get delete-all ] if
|
||||
] dip \ meta-r set ;
|
||||
|
||||
: infer-quot ( quot rstate -- )
|
||||
recursive-state get [
|
||||
|
|
@ -103,10 +116,10 @@ M: object apply-object push-literal ;
|
|||
] if ;
|
||||
|
||||
: infer->r ( n -- )
|
||||
consume-d dup copy-values [ #>r, ] [ nip output-r ] 2bi ;
|
||||
consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ;
|
||||
|
||||
: infer-r> ( n -- )
|
||||
consume-r dup copy-values [ #r>, ] [ nip output-d ] 2bi ;
|
||||
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
|
||||
|
||||
: undo-infer ( -- )
|
||||
recorded get [ f "inferred-effect" set-word-prop ] each ;
|
||||
|
|
@ -127,13 +140,8 @@ M: object apply-object push-literal ;
|
|||
: infer-word-def ( word -- )
|
||||
[ specialized-def ] [ add-recursive-state ] bi infer-quot ;
|
||||
|
||||
: check->r ( -- )
|
||||
meta-r get empty? terminated? get or
|
||||
[ \ too-many->r inference-error ] unless ;
|
||||
|
||||
: end-infer ( -- )
|
||||
check->r
|
||||
meta-d get clone #return, ;
|
||||
meta-d clone #return, ;
|
||||
|
||||
: effect-required? ( word -- ? )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -57,9 +57,9 @@ SYMBOL: quotations
|
|||
branch-variable ;
|
||||
|
||||
: datastack-phi ( seq -- phi-in phi-out )
|
||||
[ d-in branch-variable ] [ meta-d active-variable ] bi
|
||||
[ d-in branch-variable ] [ \ meta-d active-variable ] bi
|
||||
unify-branches
|
||||
[ d-in set ] [ ] [ dup >vector meta-d set ] tri* ;
|
||||
[ d-in set ] [ ] [ dup >vector \ meta-d set ] tri* ;
|
||||
|
||||
: terminated-phi ( seq -- terminated )
|
||||
terminated? branch-variable ;
|
||||
|
|
@ -74,17 +74,25 @@ SYMBOL: quotations
|
|||
tri ;
|
||||
|
||||
: copy-inference ( -- )
|
||||
meta-d [ clone ] change
|
||||
V{ } clone meta-r set
|
||||
\ meta-d [ clone ] change
|
||||
literals [ clone ] change
|
||||
d-in [ ] change ;
|
||||
|
||||
: infer-branch ( literal -- namespace )
|
||||
GENERIC: infer-branch ( literal -- namespace )
|
||||
|
||||
M: literal infer-branch
|
||||
[
|
||||
copy-inference
|
||||
nest-visitor
|
||||
[ value>> quotation set ] [ infer-literal-quot ] bi
|
||||
check->r
|
||||
] H{ } make-assoc ; inline
|
||||
] H{ } make-assoc ;
|
||||
|
||||
M: callable infer-branch
|
||||
[
|
||||
copy-inference
|
||||
nest-visitor
|
||||
[ quotation set ] [ infer-quot-here ] bi
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: infer-branches ( branches -- input children data )
|
||||
[ pop-d ] dip
|
||||
|
|
@ -96,16 +104,19 @@ SYMBOL: quotations
|
|||
[ first2 #if, ] dip compute-phi-function ;
|
||||
|
||||
: infer-if ( -- )
|
||||
2 consume-d
|
||||
dup [ known [ curried? ] [ composed? ] bi or ] contains? [
|
||||
output-d
|
||||
[ rot [ drop call ] [ nip call ] if ]
|
||||
infer-quot-here
|
||||
2 literals-available? [
|
||||
(infer-if)
|
||||
] [
|
||||
[ #drop, ] [ [ literal ] map (infer-if) ] bi
|
||||
drop 2 consume-d
|
||||
dup [ known [ curried? ] [ composed? ] bi or ] contains? [
|
||||
output-d
|
||||
[ rot [ drop call ] [ nip call ] if ]
|
||||
infer-quot-here
|
||||
] [
|
||||
[ #drop, ] [ [ literal ] map (infer-if) ] bi
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: infer-dispatch ( -- )
|
||||
pop-literal nip [ <literal> ] map
|
||||
infer-branches
|
||||
pop-literal nip infer-branches
|
||||
[ #dispatch, ] dip compute-phi-function ;
|
||||
|
|
|
|||
|
|
@ -51,14 +51,14 @@ SYMBOL: enter-out
|
|||
: prepare-stack ( word -- )
|
||||
required-stack-effect in>>
|
||||
[ length ensure-d drop ] [
|
||||
meta-d get clone enter-in set
|
||||
meta-d get swap make-copies enter-out set
|
||||
meta-d clone enter-in set
|
||||
meta-d swap make-copies enter-out set
|
||||
] bi ;
|
||||
|
||||
: emit-enter-recursive ( label -- )
|
||||
enter-out get >>enter-out
|
||||
enter-in get enter-out get #enter-recursive,
|
||||
enter-out get >vector meta-d set ;
|
||||
enter-out get >vector \ meta-d set ;
|
||||
|
||||
: entry-stack-height ( label -- stack )
|
||||
enter-out>> length ;
|
||||
|
|
@ -77,7 +77,7 @@ SYMBOL: enter-out
|
|||
|
||||
: end-recursive-word ( word label -- )
|
||||
[ check-return ]
|
||||
[ meta-d get dup copy-values dup meta-d set #return-recursive, ]
|
||||
[ meta-d dup copy-values dup \ meta-d set #return-recursive, ]
|
||||
bi ;
|
||||
|
||||
: recursive-word-inputs ( label -- n )
|
||||
|
|
@ -95,10 +95,8 @@ SYMBOL: enter-out
|
|||
[ nip ]
|
||||
2tri
|
||||
|
||||
check->r
|
||||
|
||||
dup recursive-word-inputs
|
||||
meta-d get
|
||||
meta-d
|
||||
stack-visitor get
|
||||
terminated? get
|
||||
] with-scope ;
|
||||
|
|
@ -116,7 +114,7 @@ SYMBOL: enter-out
|
|||
swap word>> required-stack-effect in>> length tail* ;
|
||||
|
||||
: call-site-stack ( label -- stack )
|
||||
meta-d get trim-stack ;
|
||||
meta-d trim-stack ;
|
||||
|
||||
: trimmed-enter-out ( label -- stack )
|
||||
dup enter-out>> trim-stack ;
|
||||
|
|
@ -131,7 +129,7 @@ SYMBOL: enter-out
|
|||
|
||||
: adjust-stack-effect ( effect -- effect' )
|
||||
[ in>> ] [ out>> ] bi
|
||||
meta-d get length pick length [-]
|
||||
meta-d length pick length [-]
|
||||
object <repetition> '[ _ prepend ] bi@
|
||||
<effect> ;
|
||||
|
||||
|
|
@ -142,6 +140,7 @@ SYMBOL: enter-out
|
|||
] [ drop undeclared-recursion-error inference-error ] if ;
|
||||
|
||||
: inline-word ( word -- )
|
||||
commit-literals
|
||||
[ inlined-dependency depends-on ]
|
||||
[
|
||||
dup inline-recursive-label [
|
||||
|
|
|
|||
|
|
@ -63,7 +63,9 @@ IN: stack-checker.known-words
|
|||
|
||||
GENERIC: infer-call* ( value known -- )
|
||||
|
||||
: infer-call ( value -- ) dup known infer-call* ;
|
||||
: (infer-call) ( value -- ) dup known infer-call* ;
|
||||
|
||||
: infer-call ( -- ) pop-d (infer-call) ;
|
||||
|
||||
M: literal infer-call*
|
||||
[ 1array #drop, ] [ infer-literal-quot ] bi* ;
|
||||
|
|
@ -73,7 +75,7 @@ M: curried infer-call*
|
|||
[ uncurry ] infer-quot-here
|
||||
[ quot>> known pop-d [ set-known ] keep ]
|
||||
[ obj>> known pop-d [ set-known ] keep ] bi
|
||||
push-d infer-call ;
|
||||
push-d (infer-call) ;
|
||||
|
||||
M: composed infer-call*
|
||||
swap push-d
|
||||
|
|
@ -81,20 +83,41 @@ M: composed infer-call*
|
|||
[ quot2>> known pop-d [ set-known ] keep ]
|
||||
[ quot1>> known pop-d [ set-known ] keep ] bi
|
||||
push-d push-d
|
||||
1 infer->r pop-d infer-call
|
||||
terminated? get [ 1 infer-r> pop-d infer-call ] unless ;
|
||||
1 infer->r infer-call
|
||||
terminated? get [ 1 infer-r> infer-call ] unless ;
|
||||
|
||||
M: object infer-call*
|
||||
\ literal-expected inference-warning ;
|
||||
|
||||
: infer-slip ( -- )
|
||||
1 infer->r pop-d infer-call 1 infer-r> ;
|
||||
1 infer->r infer-call 1 infer-r> ;
|
||||
|
||||
: infer-2slip ( -- )
|
||||
2 infer->r pop-d infer-call 2 infer-r> ;
|
||||
2 infer->r infer-call 2 infer-r> ;
|
||||
|
||||
: infer-3slip ( -- )
|
||||
3 infer->r pop-d infer-call 3 infer-r> ;
|
||||
3 infer->r infer-call 3 infer-r> ;
|
||||
|
||||
: infer-dip ( -- )
|
||||
commit-literals
|
||||
literals get
|
||||
[ \ dip def>> infer-quot-here ]
|
||||
[ pop 1 infer->r infer-quot-here 1 infer-r> ]
|
||||
if-empty ;
|
||||
|
||||
: infer-2dip ( -- )
|
||||
commit-literals
|
||||
literals get
|
||||
[ \ 2dip def>> infer-quot-here ]
|
||||
[ pop 2 infer->r infer-quot-here 2 infer-r> ]
|
||||
if-empty ;
|
||||
|
||||
: infer-3dip ( -- )
|
||||
commit-literals
|
||||
literals get
|
||||
[ \ 3dip def>> infer-quot-here ]
|
||||
[ pop 3 infer->r infer-quot-here 3 infer-r> ]
|
||||
if-empty ;
|
||||
|
||||
: infer-curry ( -- )
|
||||
2 consume-d
|
||||
|
|
@ -157,11 +180,14 @@ M: object infer-call*
|
|||
{ \ >r [ 1 infer->r ] }
|
||||
{ \ r> [ 1 infer-r> ] }
|
||||
{ \ declare [ infer-declare ] }
|
||||
{ \ call [ pop-d infer-call ] }
|
||||
{ \ (call) [ pop-d infer-call ] }
|
||||
{ \ call [ infer-call ] }
|
||||
{ \ (call) [ infer-call ] }
|
||||
{ \ slip [ infer-slip ] }
|
||||
{ \ 2slip [ infer-2slip ] }
|
||||
{ \ 3slip [ infer-3slip ] }
|
||||
{ \ dip [ infer-dip ] }
|
||||
{ \ 2dip [ infer-2dip ] }
|
||||
{ \ 3dip [ infer-3dip ] }
|
||||
{ \ curry [ infer-curry ] }
|
||||
{ \ compose [ infer-compose ] }
|
||||
{ \ execute [ infer-execute ] }
|
||||
|
|
@ -190,10 +216,10 @@ M: object infer-call*
|
|||
"local-word-def" word-prop infer-quot-here ;
|
||||
|
||||
{
|
||||
>r r> declare call (call) slip 2slip 3slip curry compose
|
||||
execute (execute) if dispatch <tuple-boa> (throw)
|
||||
load-locals get-local drop-locals do-primitive alien-invoke
|
||||
alien-indirect alien-callback
|
||||
>r r> declare call (call) slip 2slip 3slip dip 2dip 3dip
|
||||
curry compose execute (execute) if dispatch <tuple-boa>
|
||||
(throw) load-locals get-local drop-locals do-primitive
|
||||
alien-invoke alien-indirect alien-callback
|
||||
} [ t "special" set-word-prop ] each
|
||||
|
||||
{ call execute dispatch load-locals get-local drop-locals }
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs arrays namespaces sequences kernel definitions
|
||||
math effects accessors words fry classes.algebra
|
||||
compiler.units ;
|
||||
compiler.units stack-checker.values stack-checker.visitor ;
|
||||
IN: stack-checker.state
|
||||
|
||||
! Did the current control-flow path throw an error?
|
||||
|
|
@ -11,23 +11,40 @@ SYMBOL: terminated?
|
|||
! Number of inputs current word expects from the stack
|
||||
SYMBOL: d-in
|
||||
|
||||
DEFER: commit-literals
|
||||
|
||||
! Compile-time data stack
|
||||
SYMBOL: meta-d
|
||||
: meta-d ( -- stack ) commit-literals \ meta-d get ;
|
||||
|
||||
! Compile-time retain stack
|
||||
SYMBOL: meta-r
|
||||
: meta-r ( -- stack ) \ meta-r get ;
|
||||
|
||||
: current-stack-height ( -- n ) meta-d get length d-in get - ;
|
||||
! Uncommitted literals. This is a form of local dead-code
|
||||
! elimination; the goal is to reduce the number of IR nodes
|
||||
! which get constructed. Technically it is redundant since
|
||||
! we do global DCE later, but it speeds up compile time.
|
||||
SYMBOL: literals
|
||||
|
||||
: (push-literal) ( obj -- )
|
||||
dup <literal> make-known
|
||||
[ nip \ meta-d get push ] [ #push, ] 2bi ;
|
||||
|
||||
: commit-literals ( -- )
|
||||
literals get [
|
||||
[ [ (push-literal) ] each ] [ delete-all ] bi
|
||||
] unless-empty ;
|
||||
|
||||
: current-stack-height ( -- n ) meta-d length d-in get - ;
|
||||
|
||||
: current-effect ( -- effect )
|
||||
d-in get
|
||||
meta-d get length <effect>
|
||||
meta-d length <effect>
|
||||
terminated? get >>terminated? ;
|
||||
|
||||
: init-inference ( -- )
|
||||
terminated? off
|
||||
V{ } clone meta-d set
|
||||
V{ } clone meta-r set
|
||||
V{ } clone \ meta-d set
|
||||
V{ } clone literals set
|
||||
0 d-in set ;
|
||||
|
||||
! Words that the current quotation depends on
|
||||
|
|
|
|||
|
|
@ -19,11 +19,8 @@ IN: stack-checker.transforms
|
|||
rot with-datastack first2
|
||||
dup [
|
||||
[
|
||||
[ drop ] [
|
||||
[ length meta-d get '[ _ pop* ] times ]
|
||||
[ #drop, ]
|
||||
bi
|
||||
] bi*
|
||||
[ drop ]
|
||||
[ [ length meta-d shorten-by ] [ #drop, ] bi ] bi*
|
||||
] 2dip
|
||||
swap infer-quot
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: tools.memory
|
|||
|
||||
: write-size ( n -- )
|
||||
number>string
|
||||
dup length 4 > [ 3 cut* "," swap 3append ] when
|
||||
dup length 4 > [ 3 cut* "," glue ] when
|
||||
" KB" append write-cell ;
|
||||
|
||||
: write-total/used/free ( free total str -- )
|
||||
|
|
|
|||
|
|
@ -238,7 +238,7 @@ M: vocab-link summary vocab-summary ;
|
|||
vocab-dir append-path dup exists?
|
||||
[ subdirs ] [ drop { } ] if
|
||||
] keep [
|
||||
swap [ "." swap 3append ] with map
|
||||
swap [ "." glue ] with map
|
||||
] unless-empty ;
|
||||
|
||||
: vocabs-in-dir ( root name -- )
|
||||
|
|
|
|||
|
|
@ -126,7 +126,7 @@ SYMBOL: +stopped+
|
|||
[
|
||||
2dup length = [ nip [ break ] append ] [
|
||||
2dup nth \ break = [ nip ] [
|
||||
swap 1+ cut [ break ] swap 3append
|
||||
swap 1+ cut [ break ] glue
|
||||
] if
|
||||
] if
|
||||
] change-frame ;
|
||||
|
|
|
|||
|
|
@ -72,7 +72,7 @@ VALUE: grapheme-table
|
|||
grapheme-table nth nth not ;
|
||||
|
||||
: chars ( i str n -- str[i] str[i+n] )
|
||||
swap >r dupd + r> [ ?nth ] curry bi@ ;
|
||||
swap [ dupd + ] dip [ ?nth ] curry bi@ ;
|
||||
|
||||
: find-index ( seq quot -- i ) find drop ; inline
|
||||
: find-last-index ( seq quot -- i ) find-last drop ; inline
|
||||
|
|
|
|||
|
|
@ -124,7 +124,7 @@ PRIVATE>
|
|||
[ zero? ] tri@ and and ;
|
||||
|
||||
: filter-ignorable ( weights -- weights' )
|
||||
>r f r> [
|
||||
f swap [
|
||||
tuck primary>> zero? and
|
||||
[ swap ignorable?>> or ]
|
||||
[ swap completely-ignorable? or not ] 2bi
|
||||
|
|
|
|||
|
|
@ -91,6 +91,6 @@ PRIVATE>
|
|||
[
|
||||
[
|
||||
[ url-encode ] dip
|
||||
[ url-encode "=" swap 3append , ] with each
|
||||
[ url-encode "=" glue , ] with each
|
||||
] assoc-each
|
||||
] { } make "&" join ;
|
||||
|
|
|
|||
|
|
@ -315,10 +315,10 @@ C-STRUCT: MEMORY_BASIC_INFORMATION
|
|||
{ "DWORD" "type" } ;
|
||||
|
||||
C-STRUCT: GUID
|
||||
{ "ulong" "Data1" }
|
||||
{ "ushort" "Data2" }
|
||||
{ "ushort" "Data3" }
|
||||
{ { "uchar" 8 } "Data4" } ;
|
||||
{ "ULONG" "Data1" }
|
||||
{ "WORD" "Data2" }
|
||||
{ "WORD" "Data3" }
|
||||
{ { "UCHAR" 8 } "Data4" } ;
|
||||
|
||||
|
||||
: SE_CREATE_TOKEN_NAME "SeCreateTokenPrivilege" ;
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ TYPEDEF: long* LPLONG
|
|||
TYPEDEF: long LONG_PTR
|
||||
TYPEDEF: long* PLONG_PTR
|
||||
|
||||
TYPEDEF: int ULONG
|
||||
TYPEDEF: uint ULONG
|
||||
TYPEDEF: void* ULONG_PTR
|
||||
TYPEDEF: void* PULONG_PTR
|
||||
|
||||
|
|
|
|||
|
|
@ -79,6 +79,7 @@ $nl
|
|||
{ $subsection continue-with }
|
||||
"Continuations as control-flow:"
|
||||
{ $subsection attempt-all }
|
||||
{ $subsection retry }
|
||||
{ $subsection with-return }
|
||||
"Reflecting the datastack:"
|
||||
{ $subsection with-datastack }
|
||||
|
|
@ -237,6 +238,20 @@ HELP: attempt-all
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: retry
|
||||
{ $values
|
||||
{ "quot" quotation } { "n" null }
|
||||
}
|
||||
{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." }
|
||||
{ $examples
|
||||
{ $unchecked-example "USING: continuations math prettyprint ;"
|
||||
"[ 5 random 0 = ] retry t"
|
||||
"t"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ attempt-all retry } related-words
|
||||
|
||||
HELP: return
|
||||
{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -154,6 +154,8 @@ ERROR: attempt-all-error ;
|
|||
] { } make peek swap [ rethrow ] when
|
||||
] if ; inline
|
||||
|
||||
: retry ( quot: ( -- ? ) n -- ) swap [ drop ] prepose attempt-all ; inline
|
||||
|
||||
TUPLE: condition error restarts continuation ;
|
||||
|
||||
C: <condition> condition ( error restarts cc -- condition )
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ GENERIC: effect>string ( obj -- str )
|
|||
M: string effect>string ;
|
||||
M: word effect>string name>> ;
|
||||
M: integer effect>string number>string ;
|
||||
M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
|
||||
M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
|
||||
|
||||
: stack-picture ( seq -- string )
|
||||
dup integer? [ "object" <repetition> ] when
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ TUPLE: check-method class generic ;
|
|||
3tri ; inline
|
||||
|
||||
: method-word-name ( class word -- string )
|
||||
[ name>> ] bi@ "=>" swap 3append ;
|
||||
[ name>> ] bi@ "=>" glue ;
|
||||
|
||||
PREDICATE: method-body < word
|
||||
"method-generic" word-prop >boolean ;
|
||||
|
|
|
|||
|
|
@ -758,12 +758,10 @@ $nl
|
|||
"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
|
||||
{ $code
|
||||
"! First alternative; uses dip"
|
||||
"[ [ 1 + ] dip 1 - dip ] 2 *"
|
||||
"[ [ 1 + ] dip 1 - ] dip 2 *"
|
||||
"! Second alternative: uses tri*"
|
||||
"[ 1 + ] [ 1 - ] [ 2 * ] tri*"
|
||||
}
|
||||
|
||||
$nl
|
||||
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
|
||||
{ $subsection "spread-shuffle-equivalence" } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -52,7 +52,9 @@ DEFER: if
|
|||
: ?if ( default cond true false -- )
|
||||
pick [ roll 2drop call ] [ 2nip call ] if ; inline
|
||||
|
||||
! Slippers
|
||||
! Slippers and dippers.
|
||||
! Not declared inline because the compiler special-cases them
|
||||
|
||||
: slip ( quot x -- x )
|
||||
#! 'slip' and 'dip' can be defined in terms of each other
|
||||
#! because the JIT special-cases a 'dip' preceeded by
|
||||
|
|
@ -71,11 +73,11 @@ DEFER: if
|
|||
#! a literal quotation.
|
||||
[ call ] 3dip ;
|
||||
|
||||
: dip ( x quot -- x ) swap slip ; inline
|
||||
: dip ( x quot -- x ) swap slip ;
|
||||
|
||||
: 2dip ( x y quot -- x y ) -rot 2slip ; inline
|
||||
: 2dip ( x y quot -- x y ) -rot 2slip ;
|
||||
|
||||
: 3dip ( x y z quot -- x y z ) -roll 3slip ; inline
|
||||
: 3dip ( x y z quot -- x y z ) -roll 3slip ;
|
||||
|
||||
! Keepers
|
||||
: keep ( x quot -- x ) over slip ; inline
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ ARTICLE: "floats" "Floats"
|
|||
"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximation" } ". While rationals can grow to any required precision, floating point numbers are fixed-width, and manipulating them is usually faster than manipulating ratios or bignums (but slower than manipulating fixnums). Floating point numbers are often used to represent irrational numbers, which have no exact representation as a ratio of two integers."
|
||||
$nl
|
||||
"Introducing a floating point number in a computation forces the result to be expressed in floating point."
|
||||
{ $example "5/4 1/2 + ." "7/4" }
|
||||
{ $example "5/4 1/2 + ." "1+3/4" }
|
||||
{ $example "5/4 0.5 + ." "1.75" }
|
||||
"Integers and rationals can be converted to floats:"
|
||||
{ $subsection >float }
|
||||
|
|
|
|||
|
|
@ -128,7 +128,7 @@ M: ratio >base
|
|||
[
|
||||
[ numerator (>base) ]
|
||||
[ denominator (>base) ] bi
|
||||
"/" swap 3append
|
||||
"/" glue
|
||||
] bi* append
|
||||
negative? get [ CHAR: - prefix ] when
|
||||
] with-radix ;
|
||||
|
|
|
|||
|
|
@ -714,6 +714,26 @@ HELP: 3append
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: surround
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } }
|
||||
{ $description "Outputs a new sequence with " { $snippet "seq1" } " inserted between " { $snippet "seq2" } " and " { $snippet "seq3" } "." }
|
||||
{ $examples
|
||||
{ $example "USING: sequences prettyprint ;"
|
||||
"\"sssssh\" \"(\" \")\" surround ."
|
||||
"\"(sssssh)\""
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: glue
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } }
|
||||
{ $description "Outputs a new sequence with " { $snippet "seq3" } " inserted between " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
|
||||
{ $examples
|
||||
{ $example "USING: sequences prettyprint ;"
|
||||
"\"a\" \"b\" \",\" glue ."
|
||||
"\"a,b\""
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: subseq
|
||||
{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "subseq" "a new sequence" } }
|
||||
{ $description "Outputs a new sequence consisting of all elements starting from and including " { $snippet "from" } ", and up to but not including " { $snippet "to" } "." }
|
||||
|
|
@ -1348,6 +1368,8 @@ ARTICLE: "sequences-appending" "Appending sequences"
|
|||
{ $subsection append }
|
||||
{ $subsection prepend }
|
||||
{ $subsection 3append }
|
||||
{ $subsection surround }
|
||||
{ $subsection glue }
|
||||
{ $subsection concat }
|
||||
{ $subsection join }
|
||||
"A pair of words useful for aligning strings:"
|
||||
|
|
|
|||
|
|
@ -268,3 +268,6 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
|
|||
[ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] unit-test
|
||||
|
||||
[ V{ 0 2 } ] [ "a" { "a" "b" "a" } indices ] unit-test
|
||||
|
||||
[ "a,b" ] [ "a" "b" "," glue ] unit-test
|
||||
[ "(abc)" ] [ "abc" "(" ")" surround ] unit-test
|
||||
|
|
|
|||
|
|
@ -317,6 +317,10 @@ PRIVATE>
|
|||
|
||||
: 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ;
|
||||
|
||||
: surround ( seq1 seq2 seq3 -- newseq ) swapd 3append ; inline
|
||||
|
||||
: glue ( seq1 seq2 seq3 -- newseq ) swap 3append ; inline
|
||||
|
||||
: change-nth ( i seq quot -- )
|
||||
[ [ nth ] dip call ] 3keep drop set-nth ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: benchmark.knucleotide
|
|||
"." split1 rot
|
||||
over length over <
|
||||
[ CHAR: 0 pad-right ]
|
||||
[ head ] if "." swap 3append ;
|
||||
[ head ] if "." glue ;
|
||||
|
||||
: discard-lines ( -- )
|
||||
readln
|
||||
|
|
|
|||
|
|
@ -80,7 +80,7 @@ M: check< summary drop "Number exceeds upper bound" ;
|
|||
[ ":" split1 string>number [ dup length ] unless* ] { } map>assoc ;
|
||||
|
||||
: define-slots ( prefix names quots -- )
|
||||
>r [ "-" swap 3append create-in ] with map r>
|
||||
>r [ "-" glue create-in ] with map r>
|
||||
[ define ] 2each ;
|
||||
|
||||
: define-accessors ( classname slots -- )
|
||||
|
|
|
|||
|
|
@ -135,9 +135,6 @@ MACRO: multikeep ( word out-indexes -- ... )
|
|||
r> [ drop \ r> , ] each
|
||||
] [ ] make ;
|
||||
|
||||
: retry ( quot n -- )
|
||||
[ drop ] rot compose attempt-all ; inline
|
||||
|
||||
: do-while ( pred body tail -- )
|
||||
[ tuck 2slip ] dip while ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -285,7 +285,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
|||
[ get-label ]
|
||||
[ skip-label get-name ]
|
||||
2bi
|
||||
"." swap 3append
|
||||
"." glue
|
||||
]
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: hardware-info.windows.ce
|
|||
: memory-status ( -- MEMORYSTATUS )
|
||||
"MEMORYSTATUS" <c-object>
|
||||
"MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
|
||||
[ GlobalMemoryStatus ] keep ;
|
||||
dup GlobalMemoryStatus ;
|
||||
|
||||
M: wince cpus ( -- n ) 1 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,18 +1,16 @@
|
|||
USING: alien alien.c-types alien.strings
|
||||
kernel libc math namespaces hardware-info.backend
|
||||
windows windows.advapi32 windows.kernel32 system ;
|
||||
hardware-info.windows windows windows.advapi32
|
||||
windows.kernel32 system byte-arrays ;
|
||||
IN: hardware-info.windows.nt
|
||||
|
||||
: system-info ( -- SYSTEM_INFO )
|
||||
"SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
|
||||
|
||||
M: winnt cpus ( -- n )
|
||||
system-info SYSTEM_INFO-dwNumberOfProcessors ;
|
||||
|
||||
: memory-status ( -- MEMORYSTATUSEX )
|
||||
"MEMORYSTATUSEX" <c-object>
|
||||
"MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
|
||||
[ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ;
|
||||
dup GlobalMemoryStatusEx win32-error=0/f ;
|
||||
|
||||
M: winnt memory-load ( -- n )
|
||||
memory-status MEMORYSTATUSEX-dwMemoryLoad ;
|
||||
|
|
@ -35,21 +33,12 @@ M: winnt total-virtual-mem ( -- n )
|
|||
M: winnt available-virtual-mem ( -- n )
|
||||
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
|
||||
|
||||
: pull-win32-string ( alien -- string )
|
||||
[ utf16n alien>string ] keep free ;
|
||||
|
||||
: computer-name ( -- string )
|
||||
MAX_COMPUTERNAME_LENGTH 1+ [ malloc ] keep
|
||||
<int> dupd GetComputerName zero? [
|
||||
free win32-error f
|
||||
] [
|
||||
pull-win32-string
|
||||
] if ;
|
||||
MAX_COMPUTERNAME_LENGTH 1+
|
||||
[ <byte-array> dup ] keep <uint>
|
||||
GetComputerName win32-error=0/f alien>native-string ;
|
||||
|
||||
: username ( -- string )
|
||||
UNLEN 1+ [ malloc ] keep
|
||||
<int> dupd GetUserName zero? [
|
||||
free win32-error f
|
||||
] [
|
||||
pull-win32-string
|
||||
] if ;
|
||||
UNLEN 1+
|
||||
[ <byte-array> dup ] keep <uint>
|
||||
GetUserName win32-error=0/f alien>native-string ;
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ IN: hardware-info.windows
|
|||
: os-version ( -- os-version )
|
||||
"OSVERSIONINFO" <c-object>
|
||||
"OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize
|
||||
[ GetVersionEx ] keep swap zero? [ win32-error ] when ;
|
||||
dup GetVersionEx win32-error=0/f ;
|
||||
|
||||
: windows-major ( -- n )
|
||||
os-version OSVERSIONINFO-dwMajorVersion ;
|
||||
|
|
@ -36,7 +36,7 @@ IN: hardware-info.windows
|
|||
os-version OSVERSIONINFO-dwPlatformId ;
|
||||
|
||||
: windows-service-pack ( -- string )
|
||||
os-version OSVERSIONINFO-szCSDVersion utf16n alien>string ;
|
||||
os-version OSVERSIONINFO-szCSDVersion alien>native-string ;
|
||||
|
||||
: feature-present? ( n -- ? )
|
||||
IsProcessorFeaturePresent zero? not ;
|
||||
|
|
@ -51,8 +51,8 @@ IN: hardware-info.windows
|
|||
"ushort" <c-array> ;
|
||||
|
||||
: get-directory ( word -- str )
|
||||
>r MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd r>
|
||||
execute win32-error=0/f utf16n alien>string ; inline
|
||||
[ MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd ] dip
|
||||
execute win32-error=0/f alien>native-string ; inline
|
||||
|
||||
: windows-directory ( -- str )
|
||||
\ GetWindowsDirectory get-directory ;
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ M: object handle-message drop ;
|
|||
"git-log" ,
|
||||
"--no-merges" ,
|
||||
"--pretty=format:%h %an: %s" ,
|
||||
".." swap 3append ,
|
||||
".." glue ,
|
||||
] { } make
|
||||
latin1 [ input-stream get lines ] with-process-reader ;
|
||||
|
||||
|
|
|
|||
|
|
@ -34,10 +34,10 @@ TYPEDEF: int CBLAS_SIDE
|
|||
|
||||
TYPEDEF: int CBLAS_INDEX
|
||||
|
||||
C-STRUCT: CBLAS_C
|
||||
C-STRUCT: float-complex
|
||||
{ "float" "real" }
|
||||
{ "float" "imag" } ;
|
||||
C-STRUCT: CBLAS_Z
|
||||
C-STRUCT: double-complex
|
||||
{ "double" "real" }
|
||||
{ "double" "imag" } ;
|
||||
|
||||
|
|
@ -53,14 +53,14 @@ FUNCTION: double cblas_ddot
|
|||
( int N, double* X, int incX, double* Y, int incY ) ;
|
||||
|
||||
FUNCTION: void cblas_cdotu_sub
|
||||
( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotu ) ;
|
||||
( int N, void* X, int incX, void* Y, int incY, void* dotu ) ;
|
||||
FUNCTION: void cblas_cdotc_sub
|
||||
( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotc ) ;
|
||||
( int N, void* X, int incX, void* Y, int incY, void* dotc ) ;
|
||||
|
||||
FUNCTION: void cblas_zdotu_sub
|
||||
( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotu ) ;
|
||||
( int N, void* X, int incX, void* Y, int incY, void* dotu ) ;
|
||||
FUNCTION: void cblas_zdotc_sub
|
||||
( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotc ) ;
|
||||
( int N, void* X, int incX, void* Y, int incY, void* dotc ) ;
|
||||
|
||||
FUNCTION: float cblas_snrm2
|
||||
( int N, float* X, int incX ) ;
|
||||
|
|
@ -73,23 +73,23 @@ FUNCTION: double cblas_dasum
|
|||
( int N, double* X, int incX ) ;
|
||||
|
||||
FUNCTION: float cblas_scnrm2
|
||||
( int N, CBLAS_C* X, int incX ) ;
|
||||
( int N, void* X, int incX ) ;
|
||||
FUNCTION: float cblas_scasum
|
||||
( int N, CBLAS_C* X, int incX ) ;
|
||||
( int N, void* X, int incX ) ;
|
||||
|
||||
FUNCTION: double cblas_dznrm2
|
||||
( int N, CBLAS_Z* X, int incX ) ;
|
||||
( int N, void* X, int incX ) ;
|
||||
FUNCTION: double cblas_dzasum
|
||||
( int N, CBLAS_Z* X, int incX ) ;
|
||||
( int N, void* X, int incX ) ;
|
||||
|
||||
FUNCTION: CBLAS_INDEX cblas_isamax
|
||||
( int N, float* X, int incX ) ;
|
||||
FUNCTION: CBLAS_INDEX cblas_idamax
|
||||
( int N, double* X, int incX ) ;
|
||||
FUNCTION: CBLAS_INDEX cblas_icamax
|
||||
( int N, CBLAS_C* X, int incX ) ;
|
||||
( int N, void* X, int incX ) ;
|
||||
FUNCTION: CBLAS_INDEX cblas_izamax
|
||||
( int N, CBLAS_Z* X, int incX ) ;
|
||||
( int N, void* X, int incX ) ;
|
||||
|
||||
FUNCTION: void cblas_sswap
|
||||
( int N, float* X, int incX, float* Y, int incY ) ;
|
||||
|
|
@ -106,31 +106,31 @@ FUNCTION: void cblas_daxpy
|
|||
( int N, double alpha, double* X, int incX, double* Y, int incY ) ;
|
||||
|
||||
FUNCTION: void cblas_cswap
|
||||
( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
|
||||
( int N, void* X, int incX, void* Y, int incY ) ;
|
||||
FUNCTION: void cblas_ccopy
|
||||
( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
|
||||
( int N, void* X, int incX, void* Y, int incY ) ;
|
||||
FUNCTION: void cblas_caxpy
|
||||
( int N, CBLAS_C* alpha, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
|
||||
( int N, void* alpha, void* X, int incX, void* Y, int incY ) ;
|
||||
|
||||
FUNCTION: void cblas_zswap
|
||||
( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
|
||||
( int N, void* X, int incX, void* Y, int incY ) ;
|
||||
FUNCTION: void cblas_zcopy
|
||||
( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
|
||||
( int N, void* X, int incX, void* Y, int incY ) ;
|
||||
FUNCTION: void cblas_zaxpy
|
||||
( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
|
||||
( int N, void* alpha, void* X, int incX, void* Y, int incY ) ;
|
||||
|
||||
FUNCTION: void cblas_sscal
|
||||
( int N, float alpha, float* X, int incX ) ;
|
||||
FUNCTION: void cblas_dscal
|
||||
( int N, double alpha, double* X, int incX ) ;
|
||||
FUNCTION: void cblas_cscal
|
||||
( int N, CBLAS_C* alpha, CBLAS_C* X, int incX ) ;
|
||||
( int N, void* alpha, void* X, int incX ) ;
|
||||
FUNCTION: void cblas_zscal
|
||||
( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX ) ;
|
||||
( int N, void* alpha, void* X, int incX ) ;
|
||||
FUNCTION: void cblas_csscal
|
||||
( int N, float alpha, CBLAS_C* X, int incX ) ;
|
||||
( int N, float alpha, void* X, int incX ) ;
|
||||
FUNCTION: void cblas_zdscal
|
||||
( int N, double alpha, CBLAS_Z* X, int incX ) ;
|
||||
( int N, double alpha, void* X, int incX ) ;
|
||||
|
||||
FUNCTION: void cblas_srotg
|
||||
( float* a, float* b, float* c, float* s ) ;
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ HELP: blas-matrix-base
|
|||
}
|
||||
"All of these subclasses share the same tuple layout:"
|
||||
{ $list
|
||||
{ { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed, column-major array of float, double, float complex, or double complex values;" }
|
||||
{ { $snippet "underlying" } " contains an alien pointer referencing or byte-array containing a packed, column-major array of float, double, float complex, or double complex values;" }
|
||||
{ { $snippet "ld" } " indicates the distance, in elements, between matrix columns;" }
|
||||
{ { $snippet "rows" } " and " { $snippet "cols" } " indicate the number of significant rows and columns in the matrix;" }
|
||||
{ "and " { $snippet "transpose" } ", if set to a true value, indicates that the matrix should be treated as transposed relative to its in-memory representation." }
|
||||
|
|
|
|||
|
|
@ -1,31 +1,13 @@
|
|||
USING: accessors alien alien.c-types arrays byte-arrays combinators
|
||||
combinators.lib combinators.short-circuit fry kernel locals macros
|
||||
combinators.short-circuit fry kernel locals macros
|
||||
math math.blas.cblas math.blas.vectors math.blas.vectors.private
|
||||
math.complex math.functions math.order multi-methods qualified
|
||||
sequences sequences.merged sequences.private generalizations
|
||||
shuffle symbols speicalized-arrays.float specialized-arrays.double ;
|
||||
QUALIFIED: syntax
|
||||
math.complex math.functions math.order functors words
|
||||
sequences sequences.merged sequences.private shuffle symbols
|
||||
specialized-arrays.direct.float specialized-arrays.direct.double
|
||||
specialized-arrays.float specialized-arrays.double ;
|
||||
IN: math.blas.matrices
|
||||
|
||||
TUPLE: blas-matrix-base data ld rows cols transpose ;
|
||||
TUPLE: float-blas-matrix < blas-matrix-base ;
|
||||
TUPLE: double-blas-matrix < blas-matrix-base ;
|
||||
TUPLE: float-complex-blas-matrix < blas-matrix-base ;
|
||||
TUPLE: double-complex-blas-matrix < blas-matrix-base ;
|
||||
|
||||
C: <float-blas-matrix> float-blas-matrix
|
||||
C: <double-blas-matrix> double-blas-matrix
|
||||
C: <float-complex-blas-matrix> float-complex-blas-matrix
|
||||
C: <double-complex-blas-matrix> double-complex-blas-matrix
|
||||
|
||||
METHOD: element-type { float-blas-matrix }
|
||||
drop "float" ;
|
||||
METHOD: element-type { double-blas-matrix }
|
||||
drop "double" ;
|
||||
METHOD: element-type { float-complex-blas-matrix }
|
||||
drop "CBLAS_C" ;
|
||||
METHOD: element-type { double-complex-blas-matrix }
|
||||
drop "CBLAS_Z" ;
|
||||
TUPLE: blas-matrix-base underlying ld rows cols transpose ;
|
||||
|
||||
: Mtransposed? ( matrix -- ? )
|
||||
transpose>> ; inline
|
||||
|
|
@ -34,6 +16,11 @@ METHOD: element-type { double-complex-blas-matrix }
|
|||
: Mheight ( matrix -- height )
|
||||
dup Mtransposed? [ cols>> ] [ rows>> ] if ; inline
|
||||
|
||||
GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y )
|
||||
GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A )
|
||||
GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A )
|
||||
GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (blas-transpose) ( matrix -- integer )
|
||||
|
|
@ -41,53 +28,29 @@ METHOD: element-type { double-complex-blas-matrix }
|
|||
|
||||
GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
|
||||
|
||||
METHOD: (blas-matrix-like) { object object object object object float-blas-matrix }
|
||||
drop <float-blas-matrix> ;
|
||||
METHOD: (blas-matrix-like) { object object object object object double-blas-matrix }
|
||||
drop <double-blas-matrix> ;
|
||||
METHOD: (blas-matrix-like) { object object object object object float-complex-blas-matrix }
|
||||
drop <float-complex-blas-matrix> ;
|
||||
METHOD: (blas-matrix-like) { object object object object object double-complex-blas-matrix }
|
||||
drop <double-complex-blas-matrix> ;
|
||||
|
||||
METHOD: (blas-matrix-like) { object object object object object float-blas-vector }
|
||||
drop <float-blas-matrix> ;
|
||||
METHOD: (blas-matrix-like) { object object object object object double-blas-vector }
|
||||
drop <double-blas-matrix> ;
|
||||
METHOD: (blas-matrix-like) { object object object object object float-complex-blas-vector }
|
||||
drop <float-complex-blas-matrix> ;
|
||||
METHOD: (blas-matrix-like) { object object object object object double-complex-blas-vector }
|
||||
drop <double-complex-blas-matrix> ;
|
||||
|
||||
METHOD: (blas-vector-like) { object object object float-blas-matrix }
|
||||
drop <float-blas-vector> ;
|
||||
METHOD: (blas-vector-like) { object object object double-blas-matrix }
|
||||
drop <double-blas-vector> ;
|
||||
METHOD: (blas-vector-like) { object object object float-complex-blas-matrix }
|
||||
drop <float-complex-blas-vector> ;
|
||||
METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
|
||||
drop <double-complex-blas-vector> ;
|
||||
|
||||
: (validate-gemv) ( A x y -- )
|
||||
{
|
||||
[ drop [ Mwidth ] [ length>> ] bi* = ]
|
||||
[ nip [ Mheight ] [ length>> ] bi* = ]
|
||||
} 3&&
|
||||
[ "Mismatched matrix and vectors in matrix-vector multiplication" throw ] unless ;
|
||||
[ "Mismatched matrix and vectors in matrix-vector multiplication" throw ]
|
||||
unless ;
|
||||
|
||||
:: (prepare-gemv) ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc y )
|
||||
:: (prepare-gemv)
|
||||
( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc
|
||||
y )
|
||||
A x y (validate-gemv)
|
||||
CblasColMajor
|
||||
A (blas-transpose)
|
||||
A rows>>
|
||||
A cols>>
|
||||
alpha >c-arg call
|
||||
A data>>
|
||||
A underlying>>
|
||||
A ld>>
|
||||
x data>>
|
||||
x underlying>>
|
||||
x inc>>
|
||||
beta >c-arg call
|
||||
y data>>
|
||||
y underlying>>
|
||||
y inc>>
|
||||
y ; inline
|
||||
|
||||
|
|
@ -96,19 +59,22 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
|
|||
[ nip [ length>> ] [ Mheight ] bi* = ]
|
||||
[ nipd [ length>> ] [ Mwidth ] bi* = ]
|
||||
} 3&&
|
||||
[ "Mismatched vertices and matrix in vector outer product" throw ] unless ;
|
||||
[ "Mismatched vertices and matrix in vector outer product" throw ]
|
||||
unless ;
|
||||
|
||||
:: (prepare-ger) ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld A )
|
||||
:: (prepare-ger)
|
||||
( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld
|
||||
A )
|
||||
x y A (validate-ger)
|
||||
CblasColMajor
|
||||
A rows>>
|
||||
A cols>>
|
||||
alpha >c-arg call
|
||||
x data>>
|
||||
x underlying>>
|
||||
x inc>>
|
||||
y data>>
|
||||
y underlying>>
|
||||
y inc>>
|
||||
A data>>
|
||||
A underlying>>
|
||||
A ld>>
|
||||
A f >>transpose ; inline
|
||||
|
||||
|
|
@ -117,9 +83,13 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
|
|||
[ drop [ Mwidth ] [ Mheight ] bi* = ]
|
||||
[ nip [ Mheight ] bi@ = ]
|
||||
[ nipd [ Mwidth ] bi@ = ]
|
||||
} 3&& [ "Mismatched matrices in matrix multiplication" throw ] unless ;
|
||||
} 3&&
|
||||
[ "Mismatched matrices in matrix multiplication" throw ]
|
||||
unless ;
|
||||
|
||||
:: (prepare-gemm) ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld C )
|
||||
:: (prepare-gemm)
|
||||
( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld
|
||||
C )
|
||||
A B C (validate-gemm)
|
||||
CblasColMajor
|
||||
A (blas-transpose)
|
||||
|
|
@ -128,12 +98,12 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
|
|||
C cols>>
|
||||
A Mwidth
|
||||
alpha >c-arg call
|
||||
A data>>
|
||||
A underlying>>
|
||||
A ld>>
|
||||
B data>>
|
||||
B underlying>>
|
||||
B ld>>
|
||||
beta >c-arg call
|
||||
C data>>
|
||||
C underlying>>
|
||||
C ld>>
|
||||
C f >>transpose ; inline
|
||||
|
||||
|
|
@ -142,65 +112,22 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: >float-blas-matrix ( arrays -- matrix )
|
||||
[ >float-array underlying>> ] (>matrix) <float-blas-matrix> ;
|
||||
: >double-blas-matrix ( arrays -- matrix )
|
||||
[ >double-array underlying>> ] (>matrix) <double-blas-matrix> ;
|
||||
: >float-complex-blas-matrix ( arrays -- matrix )
|
||||
[ (flatten-complex-sequence) >float-array underlying>> ] (>matrix)
|
||||
<float-complex-blas-matrix> ;
|
||||
: >double-complex-blas-matrix ( arrays -- matrix )
|
||||
[ (flatten-complex-sequence) >double-array underlying>> ] (>matrix)
|
||||
<double-complex-blas-matrix> ;
|
||||
|
||||
GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y )
|
||||
GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A )
|
||||
GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A )
|
||||
GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C )
|
||||
|
||||
METHOD: n*M.V+n*V! { real float-blas-matrix float-blas-vector real float-blas-vector }
|
||||
[ ] (prepare-gemv) [ cblas_sgemv ] dip ;
|
||||
METHOD: n*M.V+n*V! { real double-blas-matrix double-blas-vector real double-blas-vector }
|
||||
[ ] (prepare-gemv) [ cblas_dgemv ] dip ;
|
||||
METHOD: n*M.V+n*V! { number float-complex-blas-matrix float-complex-blas-vector number float-complex-blas-vector }
|
||||
[ (>c-complex) ] (prepare-gemv) [ cblas_cgemv ] dip ;
|
||||
METHOD: n*M.V+n*V! { number double-complex-blas-matrix double-complex-blas-vector number double-complex-blas-vector }
|
||||
[ (>z-complex) ] (prepare-gemv) [ cblas_zgemv ] dip ;
|
||||
|
||||
METHOD: n*V(*)V+M! { real float-blas-vector float-blas-vector float-blas-matrix }
|
||||
[ ] (prepare-ger) [ cblas_sger ] dip ;
|
||||
METHOD: n*V(*)V+M! { real double-blas-vector double-blas-vector double-blas-matrix }
|
||||
[ ] (prepare-ger) [ cblas_dger ] dip ;
|
||||
METHOD: n*V(*)V+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
|
||||
[ (>c-complex) ] (prepare-ger) [ cblas_cgeru ] dip ;
|
||||
METHOD: n*V(*)V+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
|
||||
[ (>z-complex) ] (prepare-ger) [ cblas_zgeru ] dip ;
|
||||
|
||||
METHOD: n*V(*)Vconj+M! { real float-blas-vector float-blas-vector float-blas-matrix }
|
||||
[ ] (prepare-ger) [ cblas_sger ] dip ;
|
||||
METHOD: n*V(*)Vconj+M! { real double-blas-vector double-blas-vector double-blas-matrix }
|
||||
[ ] (prepare-ger) [ cblas_dger ] dip ;
|
||||
METHOD: n*V(*)Vconj+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
|
||||
[ (>c-complex) ] (prepare-ger) [ cblas_cgerc ] dip ;
|
||||
METHOD: n*V(*)Vconj+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
|
||||
[ (>z-complex) ] (prepare-ger) [ cblas_zgerc ] dip ;
|
||||
|
||||
METHOD: n*M.M+n*M! { real float-blas-matrix float-blas-matrix real float-blas-matrix }
|
||||
[ ] (prepare-gemm) [ cblas_sgemm ] dip ;
|
||||
METHOD: n*M.M+n*M! { real double-blas-matrix double-blas-matrix real double-blas-matrix }
|
||||
[ ] (prepare-gemm) [ cblas_dgemm ] dip ;
|
||||
METHOD: n*M.M+n*M! { number float-complex-blas-matrix float-complex-blas-matrix number float-complex-blas-matrix }
|
||||
[ (>c-complex) ] (prepare-gemm) [ cblas_cgemm ] dip ;
|
||||
METHOD: n*M.M+n*M! { number double-complex-blas-matrix double-complex-blas-matrix number double-complex-blas-matrix }
|
||||
[ (>z-complex) ] (prepare-gemm) [ cblas_zgemm ] dip ;
|
||||
|
||||
! XXX should do a dense clone
|
||||
syntax:M: blas-matrix-base clone
|
||||
M: blas-matrix-base clone
|
||||
[
|
||||
[
|
||||
{ [ data>> ] [ ld>> ] [ cols>> ] [ element-type heap-size ] } cleave
|
||||
* * memory>byte-array
|
||||
] [ { [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> ] } cleave ] bi
|
||||
[ {
|
||||
[ underlying>> ]
|
||||
[ ld>> ]
|
||||
[ cols>> ]
|
||||
[ element-type heap-size ]
|
||||
} cleave * * memory>byte-array ]
|
||||
[ {
|
||||
[ ld>> ]
|
||||
[ rows>> ]
|
||||
[ cols>> ]
|
||||
[ transpose>> ]
|
||||
} cleave ]
|
||||
bi
|
||||
] keep (blas-matrix-like) ;
|
||||
|
||||
! XXX try rounding stride to next 128 bit bound for better vectorizin'
|
||||
|
|
@ -246,29 +173,31 @@ syntax:M: blas-matrix-base clone
|
|||
|
||||
:: (Msub) ( matrix row col height width -- data ld rows cols )
|
||||
matrix ld>> col * row + matrix element-type heap-size *
|
||||
matrix data>> <displaced-alien>
|
||||
matrix underlying>> <displaced-alien>
|
||||
matrix ld>>
|
||||
height
|
||||
width ;
|
||||
|
||||
: Msub ( matrix row col height width -- sub )
|
||||
5 npick dup transpose>>
|
||||
[ nip [ [ swap ] 2dip swap ] when (Msub) ] 2keep
|
||||
swap (blas-matrix-like) ;
|
||||
:: Msub ( matrix row col height width -- sub )
|
||||
matrix dup transpose>>
|
||||
[ col row width height ]
|
||||
[ row col height width ] if (Msub)
|
||||
matrix transpose>> matrix (blas-matrix-like) ;
|
||||
|
||||
TUPLE: blas-matrix-rowcol-sequence parent inc rowcol-length rowcol-jump length ;
|
||||
TUPLE: blas-matrix-rowcol-sequence
|
||||
parent inc rowcol-length rowcol-jump length ;
|
||||
C: <blas-matrix-rowcol-sequence> blas-matrix-rowcol-sequence
|
||||
|
||||
INSTANCE: blas-matrix-rowcol-sequence sequence
|
||||
|
||||
syntax:M: blas-matrix-rowcol-sequence length
|
||||
M: blas-matrix-rowcol-sequence length
|
||||
length>> ;
|
||||
syntax:M: blas-matrix-rowcol-sequence nth-unsafe
|
||||
M: blas-matrix-rowcol-sequence nth-unsafe
|
||||
{
|
||||
[
|
||||
[ rowcol-jump>> ]
|
||||
[ parent>> element-type heap-size ]
|
||||
[ parent>> data>> ] tri
|
||||
[ parent>> underlying>> ] tri
|
||||
[ * * ] dip <displaced-alien>
|
||||
]
|
||||
[ rowcol-length>> ]
|
||||
|
|
@ -277,11 +206,11 @@ syntax:M: blas-matrix-rowcol-sequence nth-unsafe
|
|||
} cleave (blas-vector-like) ;
|
||||
|
||||
: (Mcols) ( A -- columns )
|
||||
{ [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] } cleave
|
||||
<blas-matrix-rowcol-sequence> ;
|
||||
{ [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] }
|
||||
cleave <blas-matrix-rowcol-sequence> ;
|
||||
: (Mrows) ( A -- rows )
|
||||
{ [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] } cleave
|
||||
<blas-matrix-rowcol-sequence> ;
|
||||
{ [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] }
|
||||
cleave <blas-matrix-rowcol-sequence> ;
|
||||
|
||||
: Mrows ( A -- rows )
|
||||
dup transpose>> [ (Mcols) ] [ (Mrows) ] if ;
|
||||
|
|
@ -300,11 +229,79 @@ syntax:M: blas-matrix-rowcol-sequence nth-unsafe
|
|||
recip swap n*M ; inline
|
||||
|
||||
: Mtranspose ( matrix -- matrix^T )
|
||||
[ { [ data>> ] [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> not ] } cleave ] keep (blas-matrix-like) ;
|
||||
[ {
|
||||
[ underlying>> ]
|
||||
[ ld>> ] [ rows>> ]
|
||||
[ cols>> ]
|
||||
[ transpose>> not ]
|
||||
} cleave ] keep (blas-matrix-like) ;
|
||||
|
||||
syntax:M: blas-matrix-base equal?
|
||||
M: blas-matrix-base equal?
|
||||
{
|
||||
[ [ Mwidth ] bi@ = ]
|
||||
[ [ Mcols ] bi@ [ = ] 2all? ]
|
||||
} 2&& ;
|
||||
|
||||
<<
|
||||
|
||||
FUNCTOR: (define-blas-matrix) ( TYPE T U C -- )
|
||||
|
||||
VECTOR IS ${TYPE}-blas-vector
|
||||
<VECTOR> IS <${TYPE}-blas-vector>
|
||||
>ARRAY IS >${TYPE}-array
|
||||
TYPE>ARG IS ${TYPE}>arg
|
||||
XGEMV IS cblas_${T}gemv
|
||||
XGEMM IS cblas_${T}gemm
|
||||
XGERU IS cblas_${T}ger${U}
|
||||
XGERC IS cblas_${T}ger${C}
|
||||
|
||||
MATRIX DEFINES ${TYPE}-blas-matrix
|
||||
<MATRIX> DEFINES <${TYPE}-blas-matrix>
|
||||
>MATRIX DEFINES >${TYPE}-blas-matrix
|
||||
|
||||
WHERE
|
||||
|
||||
TUPLE: MATRIX < blas-matrix-base ;
|
||||
: <MATRIX> ( underlying ld rows cols transpose -- matrix )
|
||||
MATRIX boa ; inline
|
||||
|
||||
M: MATRIX element-type
|
||||
drop TYPE ;
|
||||
M: MATRIX (blas-matrix-like)
|
||||
drop <MATRIX> execute ;
|
||||
M: VECTOR (blas-matrix-like)
|
||||
drop <MATRIX> execute ;
|
||||
M: MATRIX (blas-vector-like)
|
||||
drop <VECTOR> execute ;
|
||||
|
||||
: >MATRIX ( arrays -- matrix )
|
||||
[ >ARRAY execute underlying>> ] (>matrix)
|
||||
<MATRIX> execute ;
|
||||
|
||||
M: VECTOR n*M.V+n*V!
|
||||
[ TYPE>ARG execute ] (prepare-gemv)
|
||||
[ XGEMV execute ] dip ;
|
||||
M: MATRIX n*M.M+n*M!
|
||||
[ TYPE>ARG execute ] (prepare-gemm)
|
||||
[ XGEMM execute ] dip ;
|
||||
M: MATRIX n*V(*)V+M!
|
||||
[ TYPE>ARG execute ] (prepare-ger)
|
||||
[ XGERU execute ] dip ;
|
||||
M: MATRIX n*V(*)Vconj+M!
|
||||
[ TYPE>ARG execute ] (prepare-ger)
|
||||
[ XGERC execute ] dip ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
||||
: define-real-blas-matrix ( TYPE T -- )
|
||||
"" "" (define-blas-matrix) ;
|
||||
: define-complex-blas-matrix ( TYPE T -- )
|
||||
"u" "c" (define-blas-matrix) ;
|
||||
|
||||
"float" "s" define-real-blas-matrix
|
||||
"double" "d" define-real-blas-matrix
|
||||
"float-complex" "c" define-complex-blas-matrix
|
||||
"double-complex" "z" define-complex-blas-matrix
|
||||
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel math.blas.matrices math.blas.vectors parser
|
||||
USING: kernel math.blas.vectors math.blas.matrices parser
|
||||
arrays prettyprint.backend sequences ;
|
||||
IN: math.blas.syntax
|
||||
|
||||
|
|
@ -20,15 +20,23 @@ IN: math.blas.syntax
|
|||
: zmatrix{
|
||||
\ } [ >double-complex-blas-matrix ] parse-literal ; parsing
|
||||
|
||||
M: float-blas-vector pprint-delims drop \ svector{ \ } ;
|
||||
M: double-blas-vector pprint-delims drop \ dvector{ \ } ;
|
||||
M: float-complex-blas-vector pprint-delims drop \ cvector{ \ } ;
|
||||
M: double-complex-blas-vector pprint-delims drop \ zvector{ \ } ;
|
||||
M: float-blas-vector pprint-delims
|
||||
drop \ svector{ \ } ;
|
||||
M: double-blas-vector pprint-delims
|
||||
drop \ dvector{ \ } ;
|
||||
M: float-complex-blas-vector pprint-delims
|
||||
drop \ cvector{ \ } ;
|
||||
M: double-complex-blas-vector pprint-delims
|
||||
drop \ zvector{ \ } ;
|
||||
|
||||
M: float-blas-matrix pprint-delims drop \ smatrix{ \ } ;
|
||||
M: double-blas-matrix pprint-delims drop \ dmatrix{ \ } ;
|
||||
M: float-complex-blas-matrix pprint-delims drop \ cmatrix{ \ } ;
|
||||
M: double-complex-blas-matrix pprint-delims drop \ zmatrix{ \ } ;
|
||||
M: float-blas-matrix pprint-delims
|
||||
drop \ smatrix{ \ } ;
|
||||
M: double-blas-matrix pprint-delims
|
||||
drop \ dmatrix{ \ } ;
|
||||
M: float-complex-blas-matrix pprint-delims
|
||||
drop \ cmatrix{ \ } ;
|
||||
M: double-complex-blas-matrix pprint-delims
|
||||
drop \ zmatrix{ \ } ;
|
||||
|
||||
M: blas-vector-base >pprint-sequence ;
|
||||
M: blas-vector-base pprint* pprint-object ;
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ HELP: blas-vector-base
|
|||
}
|
||||
"All of these subclasses share the same tuple layout:"
|
||||
{ $list
|
||||
{ { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" }
|
||||
{ { $snippet "underlying" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" }
|
||||
{ { $snippet "length" } " indicates the length of the vector;" }
|
||||
{ "and " { $snippet "inc" } " indicates the distance, in elements, between elements." }
|
||||
} } ;
|
||||
|
|
|
|||
|
|
@ -1,231 +1,77 @@
|
|||
USING: accessors alien alien.c-types arrays byte-arrays combinators
|
||||
combinators.short-circuit fry kernel macros math math.blas.cblas
|
||||
math.complex math.functions math.order multi-methods qualified
|
||||
sequences sequences.private generalizations
|
||||
combinators.short-circuit fry kernel math math.blas.cblas
|
||||
math.complex math.functions math.order sequences.complex
|
||||
sequences.complex-components sequences sequences.private
|
||||
functors words locals
|
||||
specialized-arrays.float specialized-arrays.double
|
||||
specialized-arrays.direct.float specialized-arrays.direct.double ;
|
||||
QUALIFIED: syntax
|
||||
IN: math.blas.vectors
|
||||
|
||||
TUPLE: blas-vector-base data length inc ;
|
||||
TUPLE: float-blas-vector < blas-vector-base ;
|
||||
TUPLE: double-blas-vector < blas-vector-base ;
|
||||
TUPLE: float-complex-blas-vector < blas-vector-base ;
|
||||
TUPLE: double-complex-blas-vector < blas-vector-base ;
|
||||
TUPLE: blas-vector-base underlying length inc ;
|
||||
|
||||
INSTANCE: float-blas-vector sequence
|
||||
INSTANCE: double-blas-vector sequence
|
||||
INSTANCE: float-complex-blas-vector sequence
|
||||
INSTANCE: double-complex-blas-vector sequence
|
||||
INSTANCE: blas-vector-base virtual-sequence
|
||||
|
||||
C: <float-blas-vector> float-blas-vector
|
||||
C: <double-blas-vector> double-blas-vector
|
||||
C: <float-complex-blas-vector> float-complex-blas-vector
|
||||
C: <double-complex-blas-vector> double-complex-blas-vector
|
||||
GENERIC: element-type ( v -- type )
|
||||
|
||||
GENERIC: n*V+V! ( alpha x y -- y=alpha*x+y )
|
||||
GENERIC: n*V! ( alpha x -- x=alpha*x )
|
||||
|
||||
GENERIC: V. ( x y -- x.y )
|
||||
GENERIC: V.conj ( x y -- xconj.y )
|
||||
GENERIC: Vnorm ( x -- norm )
|
||||
GENERIC: Vasum ( x -- sum )
|
||||
GENERIC: Vswap ( x y -- x=y y=x )
|
||||
|
||||
GENERIC: Viamax ( x -- max-i )
|
||||
|
||||
GENERIC: element-type ( v -- type )
|
||||
|
||||
METHOD: element-type { float-blas-vector }
|
||||
drop "float" ;
|
||||
METHOD: element-type { double-blas-vector }
|
||||
drop "double" ;
|
||||
METHOD: element-type { float-complex-blas-vector }
|
||||
drop "CBLAS_C" ;
|
||||
METHOD: element-type { double-complex-blas-vector }
|
||||
drop "CBLAS_Z" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: (blas-vector-like) ( data length inc exemplar -- vector )
|
||||
|
||||
METHOD: (blas-vector-like) { object object object float-blas-vector }
|
||||
drop <float-blas-vector> ;
|
||||
METHOD: (blas-vector-like) { object object object double-blas-vector }
|
||||
drop <double-blas-vector> ;
|
||||
METHOD: (blas-vector-like) { object object object float-complex-blas-vector }
|
||||
drop <float-complex-blas-vector> ;
|
||||
METHOD: (blas-vector-like) { object object object double-complex-blas-vector }
|
||||
drop <double-complex-blas-vector> ;
|
||||
GENERIC: (blas-direct-array) ( blas-vector -- direct-array )
|
||||
|
||||
: (prepare-copy) ( v element-size -- length v-data v-inc v-dest-data v-dest-inc )
|
||||
[ [ length>> ] [ data>> ] [ inc>> ] tri ] dip
|
||||
4 npick * <byte-array>
|
||||
1 ;
|
||||
: shorter-length ( v1 v2 -- length )
|
||||
[ length>> ] bi@ min ; inline
|
||||
: data-and-inc ( v -- data inc )
|
||||
[ underlying>> ] [ inc>> ] bi ; inline
|
||||
: datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc )
|
||||
[ data-and-inc ] bi@ ; inline
|
||||
|
||||
MACRO: (do-copy) ( copy make-vector -- )
|
||||
'[ over 6 npick _ 2dip 1 @ ] ;
|
||||
:: (prepare-copy)
|
||||
( v element-size -- length v-data v-inc v-dest-data v-dest-inc
|
||||
copy-data copy-length copy-inc )
|
||||
v [ length>> ] [ data-and-inc ] bi
|
||||
v length>> element-size * <byte-array>
|
||||
1
|
||||
over v length>> 1 ;
|
||||
|
||||
: (prepare-swap) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc v1 v2 )
|
||||
[
|
||||
[ [ length>> ] bi@ min ]
|
||||
[ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
|
||||
] 2keep ;
|
||||
: (prepare-swap)
|
||||
( v1 v2 -- length v1-data v1-inc v2-data v2-inc
|
||||
v1 v2 )
|
||||
[ shorter-length ] [ datas-and-incs ] [ ] 2tri ;
|
||||
|
||||
: (prepare-axpy) ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc v2 )
|
||||
[
|
||||
[ [ length>> ] bi@ min swap ]
|
||||
[ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
|
||||
] keep ;
|
||||
:: (prepare-axpy)
|
||||
( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc
|
||||
v2 )
|
||||
v1 v2 shorter-length
|
||||
n
|
||||
v1 v2 datas-and-incs
|
||||
v2 ;
|
||||
|
||||
: (prepare-scal) ( n v -- length n v-data v-inc v )
|
||||
[ [ length>> swap ] [ data>> ] [ inc>> ] tri ] keep ;
|
||||
:: (prepare-scal)
|
||||
( n v -- length n v-data v-inc
|
||||
v )
|
||||
v length>>
|
||||
n
|
||||
v data-and-inc
|
||||
v ;
|
||||
|
||||
: (prepare-dot) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc )
|
||||
[ [ length>> ] bi@ min ]
|
||||
[ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi ;
|
||||
[ shorter-length ] [ datas-and-incs ] 2bi ;
|
||||
|
||||
: (prepare-nrm2) ( v -- length v1-data v1-inc )
|
||||
[ length>> ] [ data>> ] [ inc>> ] tri ;
|
||||
|
||||
: (flatten-complex-sequence) ( seq -- seq' )
|
||||
[ [ real-part ] [ imaginary-part ] bi 2array ] map concat ;
|
||||
|
||||
: (>c-complex) ( complex -- alien )
|
||||
[ real-part ] [ imaginary-part ] bi float-array{ } 2sequence underlying>> ;
|
||||
: (>z-complex) ( complex -- alien )
|
||||
[ real-part ] [ imaginary-part ] bi double-array{ } 2sequence underlying>> ;
|
||||
|
||||
: (c-complex>) ( alien -- complex )
|
||||
2 <direct-float-array> first2 rect> ;
|
||||
: (z-complex>) ( alien -- complex )
|
||||
2 <direct-double-array> first2 rect> ;
|
||||
|
||||
: (prepare-nth) ( n v -- n*inc v-data )
|
||||
[ inc>> ] [ data>> ] bi [ * ] dip ;
|
||||
|
||||
MACRO: (complex-nth) ( nth-quot -- )
|
||||
'[
|
||||
[ 2 * dup 1+ ] dip
|
||||
_ curry bi@ rect>
|
||||
] ;
|
||||
|
||||
: (c-complex-nth) ( n alien -- complex )
|
||||
[ float-nth ] (complex-nth) ;
|
||||
: (z-complex-nth) ( n alien -- complex )
|
||||
[ double-nth ] (complex-nth) ;
|
||||
|
||||
MACRO: (set-complex-nth) ( set-nth-quot -- )
|
||||
'[
|
||||
[
|
||||
[ [ real-part ] [ imaginary-part ] bi ]
|
||||
[ 2 * dup 1+ ] bi*
|
||||
swapd
|
||||
] dip
|
||||
_ curry 2bi@
|
||||
] ;
|
||||
|
||||
: (set-c-complex-nth) ( complex n alien -- )
|
||||
[ set-float-nth ] (set-complex-nth) ;
|
||||
: (set-z-complex-nth) ( complex n alien -- )
|
||||
[ set-double-nth ] (set-complex-nth) ;
|
||||
: (prepare-nrm2) ( v -- length data inc )
|
||||
[ length>> ] [ data-and-inc ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <zero-vector> ( exemplar -- zero )
|
||||
[ element-type <c-object> ]
|
||||
[ length>> 0 ]
|
||||
[ (blas-vector-like) ] tri ;
|
||||
|
||||
: <empty-vector> ( length exemplar -- vector )
|
||||
[ element-type <c-array> ]
|
||||
[ 1 swap ] 2bi
|
||||
(blas-vector-like) ;
|
||||
|
||||
syntax:M: blas-vector-base length
|
||||
length>> ;
|
||||
|
||||
syntax:M: float-blas-vector nth-unsafe
|
||||
(prepare-nth) float-nth ;
|
||||
syntax:M: float-blas-vector set-nth-unsafe
|
||||
(prepare-nth) set-float-nth ;
|
||||
|
||||
syntax:M: double-blas-vector nth-unsafe
|
||||
(prepare-nth) double-nth ;
|
||||
syntax:M: double-blas-vector set-nth-unsafe
|
||||
(prepare-nth) set-double-nth ;
|
||||
|
||||
syntax:M: float-complex-blas-vector nth-unsafe
|
||||
(prepare-nth) (c-complex-nth) ;
|
||||
syntax:M: float-complex-blas-vector set-nth-unsafe
|
||||
(prepare-nth) (set-c-complex-nth) ;
|
||||
|
||||
syntax:M: double-complex-blas-vector nth-unsafe
|
||||
(prepare-nth) (z-complex-nth) ;
|
||||
syntax:M: double-complex-blas-vector set-nth-unsafe
|
||||
(prepare-nth) (set-z-complex-nth) ;
|
||||
|
||||
syntax:M: blas-vector-base equal?
|
||||
{
|
||||
[ [ length ] bi@ = ]
|
||||
[ [ = ] 2all? ]
|
||||
} 2&& ;
|
||||
|
||||
: >float-blas-vector ( seq -- v )
|
||||
[ >float-array underlying>> ] [ length ] bi 1 <float-blas-vector> ;
|
||||
: >double-blas-vector ( seq -- v )
|
||||
[ >double-array underlying>> ] [ length ] bi 1 <double-blas-vector> ;
|
||||
: >float-complex-blas-vector ( seq -- v )
|
||||
[ (flatten-complex-sequence) >float-array underlying>> ] [ length ] bi
|
||||
1 <float-complex-blas-vector> ;
|
||||
: >double-complex-blas-vector ( seq -- v )
|
||||
[ (flatten-complex-sequence) >double-array underlying>> ] [ length ] bi
|
||||
1 <double-complex-blas-vector> ;
|
||||
|
||||
syntax:M: float-blas-vector clone
|
||||
"float" heap-size (prepare-copy)
|
||||
[ cblas_scopy ] [ <float-blas-vector> ] (do-copy) ;
|
||||
syntax:M: double-blas-vector clone
|
||||
"double" heap-size (prepare-copy)
|
||||
[ cblas_dcopy ] [ <double-blas-vector> ] (do-copy) ;
|
||||
syntax:M: float-complex-blas-vector clone
|
||||
"CBLAS_C" heap-size (prepare-copy)
|
||||
[ cblas_ccopy ] [ <float-complex-blas-vector> ] (do-copy) ;
|
||||
syntax:M: double-complex-blas-vector clone
|
||||
"CBLAS_Z" heap-size (prepare-copy)
|
||||
[ cblas_zcopy ] [ <double-complex-blas-vector> ] (do-copy) ;
|
||||
|
||||
METHOD: Vswap { float-blas-vector float-blas-vector }
|
||||
(prepare-swap) [ cblas_sswap ] 2dip ;
|
||||
METHOD: Vswap { double-blas-vector double-blas-vector }
|
||||
(prepare-swap) [ cblas_dswap ] 2dip ;
|
||||
METHOD: Vswap { float-complex-blas-vector float-complex-blas-vector }
|
||||
(prepare-swap) [ cblas_cswap ] 2dip ;
|
||||
METHOD: Vswap { double-complex-blas-vector double-complex-blas-vector }
|
||||
(prepare-swap) [ cblas_zswap ] 2dip ;
|
||||
|
||||
METHOD: n*V+V! { real float-blas-vector float-blas-vector }
|
||||
(prepare-axpy) [ cblas_saxpy ] dip ;
|
||||
METHOD: n*V+V! { real double-blas-vector double-blas-vector }
|
||||
(prepare-axpy) [ cblas_daxpy ] dip ;
|
||||
METHOD: n*V+V! { number float-complex-blas-vector float-complex-blas-vector }
|
||||
[ (>c-complex) ] 2dip
|
||||
(prepare-axpy) [ cblas_caxpy ] dip ;
|
||||
METHOD: n*V+V! { number double-complex-blas-vector double-complex-blas-vector }
|
||||
[ (>z-complex) ] 2dip
|
||||
(prepare-axpy) [ cblas_zaxpy ] dip ;
|
||||
|
||||
METHOD: n*V! { real float-blas-vector }
|
||||
(prepare-scal) [ cblas_sscal ] dip ;
|
||||
METHOD: n*V! { real double-blas-vector }
|
||||
(prepare-scal) [ cblas_dscal ] dip ;
|
||||
METHOD: n*V! { number float-complex-blas-vector }
|
||||
[ (>c-complex) ] dip
|
||||
(prepare-scal) [ cblas_cscal ] dip ;
|
||||
METHOD: n*V! { number double-complex-blas-vector }
|
||||
[ (>z-complex) ] dip
|
||||
(prepare-scal) [ cblas_zscal ] dip ;
|
||||
|
||||
: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
|
||||
: n*V ( alpha x -- alpha*x ) clone n*V! ; inline
|
||||
|
||||
|
|
@ -242,62 +88,185 @@ METHOD: n*V! { number double-complex-blas-vector }
|
|||
: V/n ( x alpha -- x/alpha )
|
||||
recip swap n*V ; inline
|
||||
|
||||
METHOD: V. { float-blas-vector float-blas-vector }
|
||||
(prepare-dot) cblas_sdot ;
|
||||
METHOD: V. { double-blas-vector double-blas-vector }
|
||||
(prepare-dot) cblas_ddot ;
|
||||
METHOD: V. { float-complex-blas-vector float-complex-blas-vector }
|
||||
(prepare-dot)
|
||||
"CBLAS_C" <c-object> [ cblas_cdotu_sub ] keep (c-complex>) ;
|
||||
METHOD: V. { double-complex-blas-vector double-complex-blas-vector }
|
||||
(prepare-dot)
|
||||
"CBLAS_Z" <c-object> [ cblas_zdotu_sub ] keep (z-complex>) ;
|
||||
|
||||
METHOD: V.conj { float-blas-vector float-blas-vector }
|
||||
(prepare-dot) cblas_sdot ;
|
||||
METHOD: V.conj { double-blas-vector double-blas-vector }
|
||||
(prepare-dot) cblas_ddot ;
|
||||
METHOD: V.conj { float-complex-blas-vector float-complex-blas-vector }
|
||||
(prepare-dot)
|
||||
"CBLAS_C" <c-object> [ cblas_cdotc_sub ] keep (c-complex>) ;
|
||||
METHOD: V.conj { double-complex-blas-vector double-complex-blas-vector }
|
||||
(prepare-dot)
|
||||
"CBLAS_Z" <c-object> [ cblas_zdotc_sub ] keep (z-complex>) ;
|
||||
|
||||
METHOD: Vnorm { float-blas-vector }
|
||||
(prepare-nrm2) cblas_snrm2 ;
|
||||
METHOD: Vnorm { double-blas-vector }
|
||||
(prepare-nrm2) cblas_dnrm2 ;
|
||||
METHOD: Vnorm { float-complex-blas-vector }
|
||||
(prepare-nrm2) cblas_scnrm2 ;
|
||||
METHOD: Vnorm { double-complex-blas-vector }
|
||||
(prepare-nrm2) cblas_dznrm2 ;
|
||||
|
||||
METHOD: Vasum { float-blas-vector }
|
||||
(prepare-nrm2) cblas_sasum ;
|
||||
METHOD: Vasum { double-blas-vector }
|
||||
(prepare-nrm2) cblas_dasum ;
|
||||
METHOD: Vasum { float-complex-blas-vector }
|
||||
(prepare-nrm2) cblas_scasum ;
|
||||
METHOD: Vasum { double-complex-blas-vector }
|
||||
(prepare-nrm2) cblas_dzasum ;
|
||||
|
||||
METHOD: Viamax { float-blas-vector }
|
||||
(prepare-nrm2) cblas_isamax ;
|
||||
METHOD: Viamax { double-blas-vector }
|
||||
(prepare-nrm2) cblas_idamax ;
|
||||
METHOD: Viamax { float-complex-blas-vector }
|
||||
(prepare-nrm2) cblas_icamax ;
|
||||
METHOD: Viamax { double-complex-blas-vector }
|
||||
(prepare-nrm2) cblas_izamax ;
|
||||
|
||||
: Vamax ( x -- max )
|
||||
[ Viamax ] keep nth ; inline
|
||||
|
||||
: Vsub ( v start length -- sub )
|
||||
rot [
|
||||
[
|
||||
nip [ inc>> ] [ element-type heap-size ] [ data>> ] tri
|
||||
[ * * ] dip <displaced-alien>
|
||||
] [ swap 2nip ] [ 2nip inc>> ] 3tri
|
||||
] keep (blas-vector-like) ;
|
||||
:: Vsub ( v start length -- sub )
|
||||
v inc>> start * v element-type heap-size *
|
||||
v underlying>> <displaced-alien>
|
||||
length v inc>> v (blas-vector-like) ;
|
||||
|
||||
: <zero-vector> ( exemplar -- zero )
|
||||
[ element-type <c-object> ]
|
||||
[ length>> 0 ]
|
||||
[ (blas-vector-like) ] tri ;
|
||||
|
||||
: <empty-vector> ( length exemplar -- vector )
|
||||
[ element-type <c-array> ]
|
||||
[ 1 swap ] 2bi
|
||||
(blas-vector-like) ;
|
||||
|
||||
M: blas-vector-base equal?
|
||||
{
|
||||
[ [ length ] bi@ = ]
|
||||
[ [ = ] 2all? ]
|
||||
} 2&& ;
|
||||
|
||||
M: blas-vector-base length
|
||||
length>> ;
|
||||
M: blas-vector-base virtual-seq
|
||||
(blas-direct-array) ;
|
||||
M: blas-vector-base virtual@
|
||||
[ inc>> * ] [ nip (blas-direct-array) ] 2bi ;
|
||||
|
||||
: float>arg ( f -- f ) ; inline
|
||||
: double>arg ( f -- f ) ; inline
|
||||
: arg>float ( f -- f ) ; inline
|
||||
: arg>double ( f -- f ) ; inline
|
||||
|
||||
<<
|
||||
|
||||
FUNCTOR: (define-blas-vector) ( TYPE T -- )
|
||||
|
||||
<DIRECT-ARRAY> IS <direct-${TYPE}-array>
|
||||
>ARRAY IS >${TYPE}-array
|
||||
XCOPY IS cblas_${T}copy
|
||||
XSWAP IS cblas_${T}swap
|
||||
IXAMAX IS cblas_i${T}amax
|
||||
|
||||
VECTOR DEFINES ${TYPE}-blas-vector
|
||||
<VECTOR> DEFINES <${TYPE}-blas-vector>
|
||||
>VECTOR DEFINES >${TYPE}-blas-vector
|
||||
|
||||
WHERE
|
||||
|
||||
TUPLE: VECTOR < blas-vector-base ;
|
||||
: <VECTOR> ( underlying length inc -- vector ) VECTOR boa ; inline
|
||||
|
||||
: >VECTOR ( seq -- v )
|
||||
[ >ARRAY execute underlying>> ] [ length ] bi 1 <VECTOR> execute ;
|
||||
|
||||
M: VECTOR clone
|
||||
TYPE heap-size (prepare-copy)
|
||||
[ XCOPY execute ] 3dip <VECTOR> execute ;
|
||||
|
||||
M: VECTOR element-type
|
||||
drop TYPE ;
|
||||
M: VECTOR Vswap
|
||||
(prepare-swap) [ XSWAP execute ] 2dip ;
|
||||
M: VECTOR Viamax
|
||||
(prepare-nrm2) IXAMAX execute ;
|
||||
|
||||
M: VECTOR (blas-vector-like)
|
||||
drop <VECTOR> execute ;
|
||||
|
||||
M: VECTOR (blas-direct-array)
|
||||
[ underlying>> ]
|
||||
[ [ length>> ] [ inc>> ] bi * ] bi
|
||||
<DIRECT-ARRAY> execute ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
||||
FUNCTOR: (define-real-blas-vector) ( TYPE T -- )
|
||||
|
||||
VECTOR IS ${TYPE}-blas-vector
|
||||
XDOT IS cblas_${T}dot
|
||||
XNRM2 IS cblas_${T}nrm2
|
||||
XASUM IS cblas_${T}asum
|
||||
XAXPY IS cblas_${T}axpy
|
||||
XSCAL IS cblas_${T}scal
|
||||
|
||||
WHERE
|
||||
|
||||
M: VECTOR V.
|
||||
(prepare-dot) XDOT execute ;
|
||||
M: VECTOR V.conj
|
||||
(prepare-dot) XDOT execute ;
|
||||
M: VECTOR Vnorm
|
||||
(prepare-nrm2) XNRM2 execute ;
|
||||
M: VECTOR Vasum
|
||||
(prepare-nrm2) XASUM execute ;
|
||||
M: VECTOR n*V+V!
|
||||
(prepare-axpy) [ XAXPY execute ] dip ;
|
||||
M: VECTOR n*V!
|
||||
(prepare-scal) [ XSCAL execute ] dip ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
||||
FUNCTOR: (define-complex-helpers) ( TYPE -- )
|
||||
|
||||
<DIRECT-COMPLEX-ARRAY> DEFINES <direct-${TYPE}-complex-array>
|
||||
>COMPLEX-ARRAY DEFINES >${TYPE}-complex-array
|
||||
ARG>COMPLEX DEFINES arg>${TYPE}-complex
|
||||
COMPLEX>ARG DEFINES ${TYPE}-complex>arg
|
||||
<DIRECT-ARRAY> IS <direct-${TYPE}-array>
|
||||
>ARRAY IS >${TYPE}-array
|
||||
|
||||
WHERE
|
||||
|
||||
: <DIRECT-COMPLEX-ARRAY> ( alien len -- sequence )
|
||||
1 shift <DIRECT-ARRAY> execute <complex-sequence> ;
|
||||
: >COMPLEX-ARRAY ( sequence -- sequence )
|
||||
<complex-components> >ARRAY execute ;
|
||||
: COMPLEX>ARG ( complex -- alien )
|
||||
>rect 2array >ARRAY execute underlying>> ;
|
||||
: ARG>COMPLEX ( alien -- complex )
|
||||
2 <DIRECT-ARRAY> execute first2 rect> ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
||||
FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- )
|
||||
|
||||
VECTOR IS ${TYPE}-blas-vector
|
||||
XDOTU_SUB IS cblas_${C}dotu_sub
|
||||
XDOTC_SUB IS cblas_${C}dotc_sub
|
||||
XXNRM2 IS cblas_${S}${C}nrm2
|
||||
XXASUM IS cblas_${S}${C}asum
|
||||
XAXPY IS cblas_${C}axpy
|
||||
XSCAL IS cblas_${C}scal
|
||||
TYPE>ARG IS ${TYPE}>arg
|
||||
ARG>TYPE IS arg>${TYPE}
|
||||
|
||||
WHERE
|
||||
|
||||
M: VECTOR V.
|
||||
(prepare-dot) TYPE <c-object>
|
||||
[ XDOTU_SUB execute ] keep
|
||||
ARG>TYPE execute ;
|
||||
M: VECTOR V.conj
|
||||
(prepare-dot) TYPE <c-object>
|
||||
[ XDOTC_SUB execute ] keep
|
||||
ARG>TYPE execute ;
|
||||
M: VECTOR Vnorm
|
||||
(prepare-nrm2) XXNRM2 execute ;
|
||||
M: VECTOR Vasum
|
||||
(prepare-nrm2) XXASUM execute ;
|
||||
M: VECTOR n*V+V!
|
||||
[ TYPE>ARG execute ] 2dip
|
||||
(prepare-axpy) [ XAXPY execute ] dip ;
|
||||
M: VECTOR n*V!
|
||||
[ TYPE>ARG execute ] dip
|
||||
(prepare-scal) [ XSCAL execute ] dip ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
||||
: define-real-blas-vector ( TYPE T -- )
|
||||
[ (define-blas-vector) ]
|
||||
[ (define-real-blas-vector) ] 2bi ;
|
||||
:: define-complex-blas-vector ( TYPE C S -- )
|
||||
TYPE (define-complex-helpers)
|
||||
TYPE "-complex" append
|
||||
[ C (define-blas-vector) ]
|
||||
[ C S (define-complex-blas-vector) ] bi ;
|
||||
|
||||
"float" "s" define-real-blas-vector
|
||||
"double" "d" define-real-blas-vector
|
||||
"float" "c" "s" define-complex-blas-vector
|
||||
"double" "z" "d" define-complex-blas-vector
|
||||
|
||||
>>
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,15 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test math.floating-point math.constants kernel ;
|
||||
USING: tools.test math.floating-point math.constants kernel
|
||||
math.constants fry sequences kernel math ;
|
||||
IN: math.floating-point.tests
|
||||
|
||||
[ t ] [ pi >double< >double pi = ] unit-test
|
||||
[ t ] [ -1.0 >double< >double -1.0 = ] unit-test
|
||||
|
||||
[ t ] [ 1/0. infinity? ] unit-test
|
||||
[ t ] [ -1/0. infinity? ] unit-test
|
||||
[ f ] [ 0/0. infinity? ] unit-test
|
||||
[ f ] [ 10. infinity? ] unit-test
|
||||
[ f ] [ -10. infinity? ] unit-test
|
||||
[ f ] [ 0. infinity? ] unit-test
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue