steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
U-WSCHLIEP-PC\wschliep 2008-07-08 20:12:54 -04:00
parent 9f002ca524 7c76046d3b
commit 4d3b5aacb4
193 changed files with 4560 additions and 1217 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -3,7 +3,7 @@ AR = ar
LD = ld
EXECUTABLE = factor
VERSION = 0.91
VERSION = 0.92
IMAGE = factor.image
BUNDLE = Factor.app

6
core/alien/alien-tests.factor
View File

@ -1,5 +1,5 @@
IN: alien.tests
USING: alien alien.accessors alien.syntax byte-arrays arrays
USING: accessors alien alien.accessors alien.syntax byte-arrays arrays
kernel kernel.private namespaces tools.test sequences libc math
system prettyprint layouts ;
@ -65,6 +65,10 @@ cell 8 = [
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> pinned-c-ptr? ] unit-test
[ t ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> underlying>> byte-array? ] unit-test
[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test

6
core/alien/c-types/c-types.factor
View File

@ -198,9 +198,9 @@ M: long-long-type box-return ( type -- )
: c-bool> ( int -- ? )
zero? not ;
: >c-array ( seq type word -- )
>r >r dup length dup r> <c-array> dup -roll r>
[ execute ] 2curry 2each ; inline
: >c-array ( seq type word -- byte-array )
[ [ dup length ] dip <c-array> ] dip
[ [ execute ] 2curry each-index ] 2keep drop ; inline
: >c-array-quot ( type vocab -- quot )
dupd set-nth-word [ >c-array ] 2curry ;

93
core/bootstrap/image/image.factor
View File

@ -8,7 +8,7 @@ grouping growable classes classes.builtin classes.tuple
classes.tuple.private words.private io.binary io.files vocabs
vocabs.loader source-files definitions debugger
quotations.private sequences.private combinators
io.encodings.binary math.order accessors ;
io.encodings.binary math.order math.private accessors slots.private ;
IN: bootstrap.image
: my-arch ( -- arch )
@ -75,7 +75,7 @@ SYMBOL: objects
: data-base 1024 ; inline
: userenv-size 64 ; inline
: userenv-size 70 ; inline
: header-size 10 ; inline
@ -118,6 +118,29 @@ SYMBOL: jit-dispatch
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
SYMBOL: jit-tag
SYMBOL: jit-tag-word
SYMBOL: jit-eq?
SYMBOL: jit-eq?-word
SYMBOL: jit-slot
SYMBOL: jit-slot-word
SYMBOL: jit-declare-word
SYMBOL: jit-drop
SYMBOL: jit-drop-word
SYMBOL: jit-dup
SYMBOL: jit-dup-word
SYMBOL: jit->r
SYMBOL: jit->r-word
SYMBOL: jit-r>
SYMBOL: jit-r>-word
SYMBOL: jit-swap
SYMBOL: jit-swap-word
SYMBOL: jit-over
SYMBOL: jit-over-word
SYMBOL: jit-fixnum-fast
SYMBOL: jit-fixnum-fast-word
SYMBOL: jit-fixnum>=
SYMBOL: jit-fixnum>=-word
! Default definition for undefined words
SYMBOL: undefined-quot
@ -140,7 +163,30 @@ SYMBOL: undefined-quot
{ jit-epilog 33 }
{ jit-return 34 }
{ jit-profiling 35 }
{ undefined-quot 37 }
{ jit-tag 36 }
{ jit-tag-word 37 }
{ jit-eq? 38 }
{ jit-eq?-word 39 }
{ jit-slot 40 }
{ jit-slot-word 41 }
{ jit-declare-word 42 }
{ jit-drop 43 }
{ jit-drop-word 44 }
{ jit-dup 45 }
{ jit-dup-word 46 }
{ jit->r 47 }
{ jit->r-word 48 }
{ jit-r> 49 }
{ jit-r>-word 50 }
{ jit-swap 51 }
{ jit-swap-word 52 }
{ jit-over 53 }
{ jit-over-word 54 }
{ jit-fixnum-fast 55 }
{ jit-fixnum-fast-word 56 }
{ jit-fixnum>= 57 }
{ jit-fixnum>=-word 58 }
{ undefined-quot 60 }
} at header-size + ;
: emit ( cell -- ) image get push ;
@ -228,6 +274,12 @@ M: fixnum '
bootstrap-most-positive-fixnum between?
[ tag-fixnum ] [ >bignum ' ] if ;
TUPLE: fake-bignum n ;
C: <fake-bignum> fake-bignum
M: fake-bignum ' n>> tag-fixnum ;
! Floats
M: float '
@ -408,6 +460,18 @@ M: quotation '
\ if jit-if-word set
\ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set
\ tag jit-tag-word set
\ eq? jit-eq?-word set
\ slot jit-slot-word set
\ declare jit-declare-word set
\ drop jit-drop-word set
\ dup jit-dup-word set
\ >r jit->r-word set
\ r> jit-r>-word set
\ swap jit-swap-word set
\ over jit-over-word set
\ fixnum-fast jit-fixnum-fast-word set
\ fixnum>= jit-fixnum>=-word set
[ undefined ] undefined-quot set
{
jit-code-format
@ -424,6 +488,29 @@ M: quotation '
jit-epilog
jit-return
jit-profiling
jit-tag
jit-tag-word
jit-eq?
jit-eq?-word
jit-slot
jit-slot-word
jit-declare-word
jit-drop
jit-drop-word
jit-dup
jit-dup-word
jit->r
jit->r-word
jit-r>
jit-r>-word
jit-swap
jit-swap-word
jit-over
jit-over-word
jit-fixnum-fast
jit-fixnum-fast-word
jit-fixnum>=
jit-fixnum>=-word
undefined-quot
} [ emit-userenv ] each ;

4
core/bootstrap/primitives.factor
View File

@ -181,7 +181,7 @@ define-union-class
! A predicate class used for declarations
"array-capacity" "sequences.private" create
"fixnum" "math" lookup
0 bootstrap-max-array-capacity [ between? ] 2curry
0 bootstrap-max-array-capacity <fake-bignum> [ between? ] 2curry
define-predicate-class
! Catch-all class for providing a default method.
@ -512,7 +512,7 @@ tuple
{ "unimplemented" "kernel.private" }
{ "gc-reset" "memory" }
}
dup length [ >r first2 r> make-primitive ] 2each
[ >r first2 r> make-primitive ] each-index
! Bump build number
"build" "kernel" create build 1+ 1quotation define

5
core/classes/algebra/algebra-tests.factor
View File

@ -3,7 +3,8 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random inference effects kernel.private sbufs math.order ;
random inference effects kernel.private sbufs math.order
classes.tuple ;
IN: classes.algebra.tests
\ class< must-infer
@ -287,6 +288,8 @@ INTERSECTION: generic-class generic class ;
generic-class flatten-class
] unit-test
[ \ + flatten-class ] must-fail
INTERSECTION: empty-intersection ;
[ t ] [ object empty-intersection class<= ] unit-test

108
core/classes/algebra/algebra.factor
View File

@ -1,10 +1,22 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes classes.builtin combinators accessors
sequences arrays vectors assocs namespaces words sorting layouts
math hashtables kernel.private sets math.order ;
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
kernel.private sets math.order ;
IN: classes.algebra
TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection participants ;
C: <anonymous-intersection> anonymous-intersection
TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement
: 2cache ( key1 key2 assoc quot -- value )
>r >r 2array r> [ first2 ] r> compose cache ; inline
@ -18,10 +30,19 @@ DEFER: (class-not)
: class-not ( class -- complement )
class-not-cache get [ (class-not) ] cache ;
DEFER: (classes-intersect?) ( first second -- ? )
GENERIC: (classes-intersect?) ( first second -- ? )
: normalize-class ( class -- class' )
{
{ [ dup members ] [ members <anonymous-union> ] }
{ [ dup participants ] [ participants <anonymous-intersection> ] }
[ ]
} cond ;
: classes-intersect? ( first second -- ? )
classes-intersect-cache get [ (classes-intersect?) ] 2cache ;
classes-intersect-cache get [
normalize-class (classes-intersect?)
] 2cache ;
DEFER: (class-and)
@ -33,18 +54,6 @@ DEFER: (class-or)
: class-or ( first second -- class )
class-or-cache get [ (class-or) ] 2cache ;
TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection participants ;
C: <anonymous-intersection> anonymous-intersection
TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement
: superclass<= ( first second -- ? )
>r superclass r> class<= ;
@ -63,13 +72,6 @@ C: <anonymous-complement> anonymous-complement
: anonymous-complement<= ( first second -- ? )
[ class>> ] bi@ swap class<= ;
: normalize-class ( class -- class' )
{
{ [ dup members ] [ members <anonymous-union> ] }
{ [ dup participants ] [ participants <anonymous-intersection> ] }
[ ]
} cond ;
: normalize-complement ( class -- class' )
class>> normalize-class {
{ [ dup anonymous-union? ] [
@ -116,40 +118,15 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
} cond
] if ;
: anonymous-union-intersect? ( first second -- ? )
M: anonymous-union (classes-intersect?)
members>> [ classes-intersect? ] with contains? ;
: anonymous-intersection-intersect? ( first second -- ? )
M: anonymous-intersection (classes-intersect?)
participants>> [ classes-intersect? ] with all? ;
: anonymous-complement-intersect? ( first second -- ? )
M: anonymous-complement (classes-intersect?)
class>> class<= not ;
: tuple-class-intersect? ( first second -- ? )
{
{ [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
[ swap classes-intersect? ]
} cond ;
: builtin-class-intersect? ( first second -- ? )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
[ swap classes-intersect? ]
} cond ;
: (classes-intersect?) ( first second -- ? )
normalize-class {
{ [ dup anonymous-union? ] [ anonymous-union-intersect? ] }
{ [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] }
{ [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] }
{ [ dup tuple-class? ] [ tuple-class-intersect? ] }
{ [ dup builtin-class? ] [ builtin-class-intersect? ] }
{ [ dup superclass ] [ superclass classes-intersect? ] }
} cond ;
: anonymous-union-and ( first second -- class )
members>> [ class-and ] with map <anonymous-union> ;
@ -225,26 +202,10 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
tuck [ class<= ] with all? [ peek ] [ drop f ] if
] if ;
DEFER: (flatten-class)
DEFER: flatten-builtin-class
GENERIC: (flatten-class) ( class -- )
: flatten-intersection-class ( class -- )
participants [ flatten-builtin-class ] map
dup empty? [
drop builtins get [ (flatten-class) ] each
] [
unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
] if ;
: (flatten-class) ( class -- )
{
{ [ dup tuple-class? ] [ dup set ] }
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup participants ] [ flatten-intersection-class ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
[ drop ]
} cond ;
M: anonymous-union (flatten-class)
members>> [ (flatten-class) ] each ;
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
@ -258,8 +219,11 @@ DEFER: flatten-builtin-class
flatten-builtin-class keys
[ "type" word-prop ] map natural-sort ;
: class-tags ( class -- tag/f )
: class-tags ( class -- seq )
class-types [
dup num-tags get >=
[ drop \ hi-tag tag-number ] when
] map prune ;
: class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ;

25
core/classes/builtin/builtin.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes words kernel kernel.private namespaces
sequences math math.private ;
USING: accessors classes classes.algebra words kernel
kernel.private namespaces sequences math math.private
combinators assocs ;
IN: classes.builtin
SYMBOL: builtins
@ -31,3 +32,23 @@ M: builtin-class rank-class drop 0 ;
M: builtin-class instance?
class>type builtin-instance? ;
M: builtin-class (flatten-class) dup set ;
M: builtin-class (classes-intersect?)
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
[ swap classes-intersect? ]
} cond ;
M: anonymous-intersection (flatten-class)
participants>> [ flatten-builtin-class ] map
dup empty? [
drop builtins get sift [ (flatten-class) ] each
] [
unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
] if ;
M: anonymous-complement (flatten-class)
drop builtins get sift [ (flatten-class) ] each ;

4
core/classes/classes-docs.factor
View File

@ -65,10 +65,6 @@ HELP: classes
{ $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ;
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: update-map
{ $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;

3
core/classes/classes.factor
View File

@ -32,9 +32,6 @@ SYMBOL: implementors-map
PREDICATE: class < word
"class" word-prop ;
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) implementors-map get keys ;
: predicate-word ( word -- predicate )

5
core/classes/intersection/intersection.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
namespaces arrays math quotations ;
classes.algebra classes.builtin namespaces arrays math quotations ;
IN: classes.intersection
PREDICATE: intersection-class < class
@ -31,3 +31,6 @@ M: intersection-class rank-class drop 2 ;
M: intersection-class instance?
"participants" word-prop [ instance? ] with all? ;
M: intersection-class (flatten-class)
participants <anonymous-intersection> (flatten-class) ;

10
core/classes/predicate/predicate.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel namespaces words sequences quotations
arrays kernel.private assocs combinators ;
USING: classes classes.algebra kernel namespaces words sequences
quotations arrays kernel.private assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class
@ -51,3 +51,9 @@ M: predicate-class rank-class drop 1 ;
M: predicate-class instance?
2dup superclass instance?
[ predicate-instance? ] [ 2drop f ] if ;
M: predicate-class (flatten-class)
superclass (flatten-class) ;
M: predicate-class (classes-intersect?)
superclass classes-intersect? ;

4
core/classes/tuple/tuple-docs.factor
View File

@ -332,6 +332,10 @@ $nl
ABOUT: "tuples"
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes.tuple prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }

2
core/classes/tuple/tuple-tests.factor
View File

@ -657,6 +657,8 @@ TUPLE: boa-coercer-test { x array-capacity } ;
[ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class ] unit-test
[ T{ boa-coercer-test f 0 } ] [ T{ boa-coercer-test } ] unit-test
! Test error classes
ERROR: error-class-test a b c ;

53
core/classes/tuple/tuple.factor
View File

@ -3,10 +3,13 @@
USING: arrays definitions hashtables kernel kernel.private math
namespaces sequences sequences.private strings vectors words
quotations memory combinators generic classes classes.algebra
classes.private slots.deprecated slots.private slots
compiler.units math.private accessors assocs effects ;
classes.builtin classes.private slots.deprecated slots.private
slots compiler.units math.private accessors assocs effects ;
IN: classes.tuple
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: not-a-tuple object ;
@ -14,6 +17,9 @@ ERROR: not-a-tuple object ;
: check-tuple ( object -- tuple )
dup tuple? [ not-a-tuple ] unless ; inline
: all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ;
<PRIVATE
: (tuple) ( layout -- tuple )
@ -43,6 +49,20 @@ ERROR: not-a-tuple object ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
: check-slots ( seq class -- seq class )
[ ] [
2dup all-slots [
class>> 2dup instance?
[ 2drop ] [ bad-slot-value ] if
] 2each
] if-bootstrapping ; inline
: initial-values ( class -- slots )
all-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
PRIVATE>
: tuple>array ( tuple -- array )
@ -53,21 +73,10 @@ PRIVATE>
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
: all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ;
: check-slots ( seq class -- seq class )
[ ] [
2dup all-slots [
class>> 2dup instance?
[ 2drop ] [ bad-slot-value ] if
] 2each
] if-bootstrapping ; inline
GENERIC: slots>tuple ( seq class -- tuple )
M: tuple-class slots>tuple
check-slots
check-slots pad-slots
tuple-layout <tuple> [
[ tuple-size ]
[ [ set-array-nth ] curry ]
@ -135,7 +144,8 @@ ERROR: bad-superclass class ;
dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype )
[ all-slots [ initial>> ] map ] keep slots>tuple ;
[ initial-values ] keep
over [ ] all? [ 2drop f ] [ slots>tuple ] if ;
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;
@ -289,6 +299,16 @@ M: tuple-class rank-class drop 0 ;
M: tuple-class instance?
dup tuple-layout echelon>> tuple-instance? ;
M: tuple-class (flatten-class) dup set ;
M: tuple-class (classes-intersect?)
{
{ [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
[ swap classes-intersect? ]
} cond ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;
@ -304,7 +324,8 @@ M: tuple hashcode*
] recursive-hashcode ;
M: tuple-class new
"prototype" word-prop (clone) ;
dup "prototype" word-prop
[ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa
[ "boa-check" word-prop call ]

5
core/classes/union/union.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
namespaces arrays math quotations ;
classes.algebra namespaces arrays math quotations ;
IN: classes.union
PREDICATE: union-class < class
@ -32,3 +32,6 @@ M: union-class rank-class drop 2 ;
M: union-class instance?
"members" word-prop [ instance? ] with contains? ;
M: union-class (flatten-class)
members <anonymous-union> (flatten-class) ;

6
core/compiler/tests/reload.factor
View File

@ -1,6 +1,6 @@
IN: compiler.tests
USE: vocabs.loader
"parser" reload
"sequences" reload
"kernel" reload
! "parser" reload
! "sequences" reload
! "kernel" reload

1
core/cpu/x86/32/bootstrap.factor
View File

@ -11,6 +11,7 @@ IN: bootstrap.x86
: temp-reg ( -- reg ) EBX ;
: stack-reg ( -- reg ) ESP ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
: fixnum>slot@ ( -- ) arg0 1 SAR ;
: rex-length ( -- n ) 0 ;

2
core/cpu/x86/64/64.factor
View File

@ -178,7 +178,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
: struct-types&offset ( struct-type -- pairs )
struct-type-fields [
[ type>> ] [ offset>> ] bi 2array
[ class>> ] [ offset>> ] bi 2array
] map ;
: split-struct ( pairs -- seq )

1
core/cpu/x86/64/bootstrap.factor
View File

@ -11,6 +11,7 @@ IN: bootstrap.x86
: temp-reg ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
: ds-reg ( -- reg ) R14 ;
: rs-reg ( -- reg ) R15 ;
: fixnum>slot@ ( -- ) ;
: rex-length ( -- n ) 1 ;

84
core/cpu/x86/bootstrap.factor
View File

@ -74,6 +74,90 @@ big-endian off
arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
[
arg1 ds-reg [] MOV ! load from stack
arg1 tag-mask get AND ! compute tag
arg1 tag-bits get SHL ! tag the tag
ds-reg [] arg1 MOV ! push to stack
] f f f jit-tag jit-define
: jit-compare ( -- )
arg1 0 MOV ! load t
arg1 dup [] MOV
temp-reg \ f tag-number MOV ! load f
arg0 ds-reg [] MOV ! load first value
ds-reg bootstrap-cell SUB ! adjust stack pointer
ds-reg [] arg0 CMP ! compare with second value
;
[
jit-compare
arg1 temp-reg CMOVNE ! not equal?
ds-reg [] arg1 MOV ! store
] rc-absolute-cell rt-literal 1 rex-length + jit-eq? jit-define
[
arg0 ds-reg [] MOV ! load slot number
ds-reg bootstrap-cell SUB ! adjust stack pointer
arg1 ds-reg [] MOV ! load object
fixnum>slot@ ! turn slot number into offset
arg1 tag-bits get SHR ! mask off tag
arg1 tag-bits get SHL
arg0 arg1 arg0 [+] MOV ! load slot value
ds-reg [] arg0 MOV ! push to stack
] f f f jit-slot jit-define
[
ds-reg bootstrap-cell SUB
] f f f jit-drop jit-define
[
arg0 ds-reg [] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
] f f f jit-dup jit-define
[
rs-reg bootstrap-cell ADD
arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
rs-reg [] arg0 MOV
] f f f jit->r jit-define
[
ds-reg bootstrap-cell ADD
arg0 rs-reg [] MOV
rs-reg bootstrap-cell SUB
ds-reg [] arg0 MOV
] f f f jit-r> jit-define
[
arg0 ds-reg [] MOV
arg1 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell neg [+] arg0 MOV
ds-reg [] arg1 MOV
] f f f jit-swap jit-define
[
arg0 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
] f f f jit-over jit-define
[
arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
arg1 ds-reg [] MOV
arg1 arg0 SUB
ds-reg [] arg1 MOV
] f f f jit-fixnum-fast jit-define
[
jit-compare
arg1 temp-reg CMOVL ! not equal?
ds-reg [] arg1 MOV ! store
] rc-absolute-cell rt-literal 1 rex-length + jit-fixnum>= jit-define
[
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
] f f f jit-epilog jit-define

2
core/debugger/debugger.factor
View File

@ -52,7 +52,7 @@ M: string error. print ;
nl
"The following restarts are available:" print
nl
dup length [ restart. ] 2each
[ restart. ] each-index
] if ;
: print-error ( error -- )

13
core/generator/generator.factor
View File

@ -13,11 +13,12 @@ SYMBOL: compiled
: queue-compile ( word -- )
{
{ [ dup compiled get key? ] [ drop ] }
{ [ dup inlined-block? ] [ drop ] }
{ [ dup primitive? ] [ drop ] }
[ compile-queue get push-front ]
} cond ;
{ [ dup "forgotten" word-prop ] [ ] }
{ [ dup compiled get key? ] [ ] }
{ [ dup inlined-block? ] [ ] }
{ [ dup primitive? ] [ ] }
[ dup compile-queue get push-front ]
} cond drop ;
: maybe-compile ( word -- )
dup compiled>> [ drop ] [ queue-compile ] if ;
@ -31,7 +32,7 @@ SYMBOL: compiling-loops
! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 36 getenv ;
: compiled-stack-traces? ( -- ? ) 59 getenv ;
: begin-compiling ( word label -- )
H{ } clone compiling-loops set

7
core/generator/registers/registers.factor
View File

@ -562,13 +562,10 @@ M: loc lazy-store
2drop t
] if ;
: class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ;
: class-matches? ( actual expected -- ? )
{
{ f [ drop t ] }
{ known-tag [ class-tag >boolean ] }
{ known-tag [ dup [ class-tag >boolean ] when ] }
[ class<= ]
} case ;
@ -639,7 +636,7 @@ PRIVATE>
[ second template-matches? ] find nip ;
: operand-tag ( operand -- tag/f )
operand-class class-tag ;
operand-class dup [ class-tag ] when ;
UNION: immediate fixnum POSTPONE: f ;

4
core/generic/generic-tests.factor
View File

@ -1,8 +1,8 @@
USING: accessors alien arrays definitions generic generic.standard
generic.math assocs hashtables io kernel math namespaces parser
prettyprint sequences strings tools.test vectors words
quotations classes classes.algebra continuations layouts
classes.union sorting compiler.units ;
quotations classes classes.algebra classes.tuple continuations
layouts classes.union sorting compiler.units ;
IN: generic.tests
GENERIC: foobar ( x -- y )

20
core/generic/standard/engines/engines.factor
View File

@ -1,16 +1,16 @@
USING: assocs kernel namespaces quotations generic math
sequences combinators words classes.algebra ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel kernel.private namespaces quotations
generic math sequences combinators words classes.algebra arrays
;
IN: generic.standard.engines
SYMBOL: default
SYMBOL: assumed
SYMBOL: (dispatch#)
GENERIC: engine>quot ( engine -- quot )
M: quotation engine>quot ;
M: method-body engine>quot 1quotation ;
: engines>quots ( assoc -- assoc' )
[ engine>quot ] assoc-map ;
@ -22,7 +22,11 @@ M: method-body engine>quot 1quotation ;
: linear-dispatch-quot ( alist -- quot )
default get [ drop ] prepend swap
[ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map
[
[ [ dup ] swap [ eq? ] curry compose ]
[ [ drop ] prepose ]
bi* [ ] like
] assoc-map
alist>quot ;
: split-methods ( assoc class -- first second )
@ -36,8 +40,6 @@ M: method-body engine>quot 1quotation ;
r> execute r> pick set-at
] if ; inline
SYMBOL: (dispatch#)
: (picker) ( n -- quot )
{
{ 0 [ [ dup ] ] }

19
core/generic/standard/engines/predicate/predicate.factor
View File

@ -1,6 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: generic.standard.engines generic namespaces kernel
sequences classes.algebra accessors words combinators
assocs ;
kernel.private sequences classes.algebra accessors words
combinators assocs arrays ;
IN: generic.standard.engines.predicate
TUPLE: predicate-dispatch-engine methods ;
@ -24,8 +26,13 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
: sort-methods ( assoc -- assoc' )
>alist [ keys sort-classes ] keep extract-keys ;
: methods-with-default ( engine -- assoc )
methods>> clone default get object bootstrap-word pick set-at ;
M: predicate-dispatch-engine engine>quot
methods>> clone
default get object bootstrap-word pick set-at engines>quots
sort-methods prune-redundant-predicates
class-predicates alist>quot ;
methods-with-default
engines>quots
sort-methods
prune-redundant-predicates
class-predicates
alist>quot ;

2
core/generic/standard/engines/tag/tag.factor
View File

@ -44,7 +44,7 @@ C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
"type" word-prop num-tags get - ;
: hi-tag-quot ( -- quot )
[ hi-tag ] num-tags get [ fixnum-fast ] curry compose ;
[ 0 slot ] num-tags get [ fixnum-fast ] curry compose ;
M: hi-tag-dispatch-engine engine>quot
methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map

32
core/generic/standard/engines/tuple/tuple.factor
View File

@ -80,15 +80,17 @@ M: engine-word irrelevant? drop t ;
: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
: tuple-layout-superclasses ( obj -- array )
{ tuple } declare
1 slot { tuple-layout } declare
4 slot { array } declare ; inline
: tuple-layout-superclasses% ( -- )
[
{ tuple } declare
1 slot { tuple-layout } declare
4 slot { array } declare
] % ; inline
: tuple-dispatch-engine-body ( engine -- quot )
[
picker %
[ tuple-layout-superclasses ] %
tuple-layout-superclasses%
[ n>> array-nth% ]
[
methods>> [
@ -106,7 +108,7 @@ M: echelon-dispatch-engine engine>quot
] [
[
picker %
[ tuple-layout-superclasses ] %
tuple-layout-superclasses%
[ n>> array-nth% ]
[
methods>> [
@ -120,18 +122,24 @@ M: echelon-dispatch-engine engine>quot
: >=-case-quot ( alist -- quot )
default get [ drop ] prepend swap
[ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
[
[ [ dup ] swap [ fixnum>= ] curry compose ]
[ [ drop ] prepose ]
bi* [ ] like
] assoc-map
alist>quot ;
: tuple-layout-echelon ( obj -- array )
{ tuple } declare
1 slot { tuple-layout } declare
5 slot ; inline
: tuple-layout-echelon% ( -- )
[
{ tuple } declare
1 slot { tuple-layout } declare
5 slot
] % ; inline
M: tuple-dispatch-engine engine>quot
[
picker %
[ tuple-layout-echelon ] %
tuple-layout-echelon%
[
tuple assumed set
echelons>> dup empty? [

8
core/generic/standard/standard-tests.factor
View File

@ -309,3 +309,11 @@ M: xref-tuple-2 xref-test (xref-test) ;
\ xref-test
\ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
] unit-test
[ t ] [
{ } \ nth effective-method nip \ sequence \ nth method eq?
] unit-test
[ t ] [
\ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
] unit-test

20
core/generic/standard/standard.factor
View File

@ -10,7 +10,16 @@ IN: generic.standard
GENERIC: dispatch# ( word -- n )
M: word dispatch# "combination" word-prop dispatch# ;
M: generic dispatch#
"combination" word-prop dispatch# ;
GENERIC: method-declaration ( class generic -- quot )
M: generic method-declaration
"combination" word-prop method-declaration ;
M: quotation engine>quot
assumed get generic get method-declaration prepend ;
: unpickers
{
@ -105,7 +114,9 @@ ERROR: no-next-method class generic ;
] [ ] make ;
: single-effective-method ( obj word -- method )
[ order [ instance? ] with find-last nip ] keep method ;
[ [ order [ instance? ] with find-last nip ] keep method ]
[ "default-method" word-prop ]
bi or ;
TUPLE: standard-combination # ;
@ -133,6 +144,9 @@ M: standard-combination perform-combination
M: standard-combination dispatch# #>> ;
M: standard-combination method-declaration
dispatch# object <array> swap prefix [ declare ] curry [ ] like ;
M: standard-combination next-method-quot*
[
single-next-method-quot picker prepend
@ -155,6 +169,8 @@ PREDICATE: hook-generic < generic
M: hook-combination dispatch# drop 0 ;
M: hook-combination method-declaration 2drop [ ] ;
M: hook-generic extra-values drop 1 ;
M: hook-generic effective-method

2
core/io/streams/c/c.factor
View File

@ -58,7 +58,7 @@ M: object init-io ;
: stdin-handle 11 getenv ;
: stdout-handle 12 getenv ;
: stderr-handle 38 getenv ;
: stderr-handle 61 getenv ;
M: object (init-stdio)
stdin-handle <c-reader>

3
core/kernel/kernel.factor
View File

@ -64,8 +64,7 @@ DEFER: if
: 2keep ( x y quot -- x y ) 2over 2slip ; inline
: 3keep ( x y z quot -- x y z )
>r 3dup r> -roll 3slip ; inline
: 3keep ( x y z quot -- x y z ) >r 3dup r> -roll 3slip ; inline
! Cleavers
: bi ( x p q -- )

7
core/math/intervals/intervals.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: accessors kernel sequences arrays math math.order
combinators ;
combinators generic ;
IN: math.intervals
TUPLE: interval { from read-only } { to read-only } ;
@ -177,6 +177,11 @@ C: <interval> interval
: interval/ ( i1 i2 -- i3 )
[ [ / ] interval-op ] interval-division-op ;
: interval/-safe ( i1 i2 -- i3 )
#! Just a hack to make the compiler work if bootstrap.math
#! is not loaded.
\ integer \ / method [ interval/ ] [ 2drop f ] if ;
: interval/i ( i1 i2 -- i3 )
[
[ [ /i ] interval-op ] interval-integer-op

18
core/optimizer/inlining/inlining.factor
View File

@ -191,6 +191,10 @@ DEFER: (flat-length)
: apply-identities ( node -- node/f )
dup find-identity f splice-quot ;
: splice-word-def ( #call word def -- node )
[ drop +inlined+ depends-on ] [ swap 1array ] 2bi
splice-quot ;
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
>r node-input-classes r> specialized-length tail*
@ -199,22 +203,20 @@ DEFER: (flat-length)
2drop f
] if ;
: splice-word-def ( #call word -- node )
dup +inlined+ depends-on
dup def>> swap 1array splice-quot ;
: already-inlined? ( #call -- ? )
[ param>> ] [ history>> ] bi memq? ;
: optimistic-inline ( #call -- node )
dup node-param over node-history memq? [
drop t
] [
dup node-param splice-word-def
dup already-inlined? [ drop t ] [
dup param>> dup def>> splice-word-def
] if ;
: should-inline? ( word -- ? )
flat-length 11 <= ;
: method-body-inline? ( #call -- ? )
node-param dup method-body? [ should-inline? ] [ drop f ] if ;
param>> dup [ method-body? ] [ "default" word-prop not ] bi and
[ should-inline? ] [ drop f ] if ;
M: #call optimize-node*
{

2
core/optimizer/math/math.factor
View File

@ -158,7 +158,7 @@ optimizer.math.partial generic.standard system accessors ;
{ + { { fixnum integer } } interval+ }
{ - { { fixnum integer } } interval- }
{ * { { fixnum integer } } interval* }
{ / { { fixnum rational } { integer rational } } interval/ }
{ / { { fixnum rational } { integer rational } } interval/-safe }
{ /i { { fixnum integer } } interval/i }
{ shift { { fixnum integer } } interval-shift-safe }
} [

13
core/optimizer/specializers/specializers.factor
View File

@ -18,13 +18,6 @@ IN: optimizer.specializers
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
: tag-specializer ( quot -- newquot )
[
[ dup tag ] %
num-tags get swap <array> ,
\ dispatch ,
] [ ] make ;
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
@ -39,11 +32,7 @@ IN: optimizer.specializers
method-declaration [ declare ] curry prepend ;
: specialize-quot ( quot specializer -- quot' )
dup { number } = [
drop tag-specializer
] [
specializer-cases alist>quot
] if ;
specializer-cases alist>quot ;
: standard-method? ( method -- ? )
dup method-body? [

4
core/sequences/sequences-docs.factor
View File

@ -43,8 +43,8 @@ ARTICLE: "sequences-integers" "Integer sequences and counted loops"
$nl
"For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
{ $example "3 [ . ] each" "0\n1\n2" }
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link 2each } ":"
{ $example "{ \"a\" \"b\" \"c\" } dup length [\n \"Index: \" write . \"Element: \" write .\n] 2each" "Index: 0\nElement: \"a\"\nIndex: 1\nElement: \"b\"\nIndex: 2\nElement: \"c\"" }
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
$nl
"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ;
ARTICLE: "sequences-access" "Accessing sequence elements"

12
core/sequences/sequences.factor
View File

@ -426,6 +426,18 @@ PRIVATE>
: follow ( obj quot -- seq )
>r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
: prepare-index ( seq quot -- seq n quot )
>r dup length r> ; inline
: each-index ( seq quot -- )
prepare-index 2each ; inline
: map-index ( seq quot -- )
prepare-index 2map ; inline
: reduce-index ( seq identity quot -- )
swapd each-index ; inline
: index ( obj seq -- n )
[ = ] with find drop ;

2
core/slots/slots-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax generic kernel.private parser
words kernel quotations namespaces sequences words arrays
effects generic.standard classes.builtin
slots.private classes strings math assocs byte-arrays alien
math ;
math classes.tuple ;
IN: slots
ARTICLE: "accessors" "Slot accessors"

16
core/threads/threads.factor
View File

@ -15,7 +15,7 @@ id
continuation state runnable
mailbox variables sleep-entry ;
: self ( -- thread ) 40 getenv ; inline
: self ( -- thread ) 63 getenv ; inline
! Thread-local storage
: tnamespace ( -- assoc )
@ -30,7 +30,7 @@ mailbox variables sleep-entry ;
: tchange ( key quot -- )
tnamespace swap change-at ; inline
: threads 41 getenv ;
: threads 64 getenv ;
: thread ( id -- thread ) threads at ;
@ -53,7 +53,7 @@ mailbox variables sleep-entry ;
: unregister-thread ( thread -- )
check-registered id>> threads delete-at ;
: set-self ( thread -- ) 40 setenv ; inline
: set-self ( thread -- ) 63 setenv ; inline
PRIVATE>
@ -68,9 +68,9 @@ PRIVATE>
: <thread> ( quot name -- thread )
\ thread new-thread ;
: run-queue 42 getenv ;
: run-queue 65 getenv ;
: sleep-queue 43 getenv ;
: sleep-queue 66 getenv ;
: resume ( thread -- )
f >>state
@ -207,9 +207,9 @@ GENERIC: error-in-thread ( error thread -- )
<PRIVATE
: init-threads ( -- )
H{ } clone 41 setenv
<dlist> 42 setenv
<min-heap> 43 setenv
H{ } clone 64 setenv
<dlist> 65 setenv
<min-heap> 66 setenv
initial-thread global
[ drop f "Initial" <thread> ] cache
<box> >>continuation

2
extra/alarms/alarms-docs.factor
View File

@ -10,7 +10,7 @@ HELP: add-alarm
HELP: later
{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } }
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ;
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;
HELP: cancel-alarm
{ $values { "alarm" alarm } }

4
extra/alarms/alarms.factor
View File

@ -82,10 +82,10 @@ PRIVATE>
<alarm> [ register-alarm ] keep ;
: later ( quot dt -- alarm )
from-now f add-alarm ;
hence f add-alarm ;
: every ( quot dt -- alarm )
[ from-now ] keep add-alarm ;
[ hence ] keep add-alarm ;
: cancel-alarm ( alarm -- )
alarm-entry [ alarms get-global heap-delete ] if-box? ;

1
extra/arrays/lib/authors.txt
View File

@ -1 +0,0 @@
Eduardo Cavazos

10
extra/arrays/lib/lib.factor
View File

@ -1,10 +0,0 @@
USING: kernel arrays sequences sequences.private macros ;
IN: arrays.lib
MACRO: narray ( n -- quot )
dup [ f <array> ] curry
swap <reversed> [
[ swap [ set-nth-unsafe ] keep ] curry
] map concat append ;

1
extra/arrays/lib/summary.txt
View File

@ -1 +0,0 @@
Non-core array words

1
extra/arrays/lib/tags.txt
View File

@ -1 +0,0 @@
collections

2
extra/bake/bake.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
USING: kernel parser namespaces sequences quotations arrays vectors splitting
words math
macros arrays.lib combinators.lib combinators.conditional newfx ;
macros generalizations combinators.lib combinators.conditional newfx ;
IN: bake

2
extra/bake/fry/fry-tests.factor
View File

@ -1,6 +1,6 @@
USING: tools.test math prettyprint kernel io arrays vectors sequences
arrays.lib bake bake.fry ;
generalizations bake bake.fry ;
IN: bake.fry.tests

2
extra/benchmark/dispatch1/dispatch1.factor
View File

@ -1,4 +1,4 @@
USING: classes kernel sequences vocabs math ;
USING: classes classes.tuple kernel sequences vocabs math ;
IN: benchmark.dispatch1
GENERIC: g ( obj -- obj )

2
extra/benchmark/dispatch5/dispatch5.factor
View File

@ -1,4 +1,4 @@
USING: classes kernel sequences vocabs math ;
USING: classes classes.tuple kernel sequences vocabs math ;
IN: benchmark.dispatch5
MIXIN: g

2
extra/bit-arrays/bit-arrays-tests.factor
View File

@ -56,6 +56,7 @@ IN: bit-arrays.tests
[ -10 ?{ } resize ] must-fail
[ -1 integer>bit-array ] must-fail
[ ?{ } ] [ 0 integer>bit-array ] unit-test
[ ?{ f t } ] [ 2 integer>bit-array ] unit-test
[ ?{ t t t t t t t t t } ] [ 511 integer>bit-array ] unit-test
[ ?{
@ -68,6 +69,7 @@ IN: bit-arrays.tests
] unit-test
[ 14 ] [ ?{ f t t t } bit-array>integer ] unit-test
[ 0 ] [ ?{ } bit-array>integer ] unit-test
[ HEX: ffffffffffffffffffffffffffffffff ] [ ?{
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t

20
extra/bit-arrays/bit-arrays.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types accessors math alien.accessors kernel
kernel.private sequences sequences.private byte-arrays
kernel.private locals sequences sequences.private byte-arrays
parser prettyprint.backend ;
IN: bit-arrays
@ -72,13 +72,17 @@ M: bit-array byte-length length 7 + -3 shift ;
: ?{ ( parsed -- parsed )
\ } [ >bit-array ] parse-literal ; parsing
: integer>bit-array ( int -- bit-array )
[ log2 1+ <bit-array> 0 ] keep
[ dup zero? not ] [
[ -8 shift ] [ 255 bitand ] bi
-roll [ [ >r underlying>> r> set-alien-unsigned-1 ] 2keep 1+ ] dip
] [ ] while
2drop ;
:: integer>bit-array ( n -- bit-array )
n zero? [ 0 <bit-array> ] [
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
[ n' zero? not ] [
n' out underlying>> i 255 bitand set-alien-unsigned-1
n' -8 shift n'!
i 1+ i!
] [ ] while
out
]
] if ;
: bit-array>integer ( bit-array -- int )
0 swap underlying>> [ length ] keep [

2
extra/bitfields/bitfields.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: parser lexer kernel math sequences namespaces assocs summary
words splitting math.parser arrays sequences.next mirrors
shuffle compiler.units ;
generalizations compiler.units ;
IN: bitfields
! Example:

46
extra/calendar/calendar.factor
View File

@ -284,7 +284,7 @@ MEMO: unix-1970 ( -- timestamp )
: now ( -- timestamp ) gmt >local-time ;
: from-now ( dt -- timestamp ) now swap time+ ;
: hence ( dt -- timestamp ) now swap time+ ;
: ago ( dt -- timestamp ) now swap time- ;
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
@ -303,41 +303,25 @@ GENERIC: days-in-year ( obj -- n )
M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
GENERIC: days-in-month ( obj -- n )
: (days-in-month) ( year month -- n )
dup 2 = [ drop leap-year? 29 28 ? ] [ nip day-counts nth ] if ;
M: array days-in-month ( obj -- n )
first2 dup 2 = [
drop leap-year? 29 28 ?
] [
nip day-counts nth
] if ;
: days-in-month ( timestamp -- n )
>date< drop (days-in-month) ;
M: timestamp days-in-month ( timestamp -- n )
>date< drop 2array days-in-month ;
GENERIC: day-of-week ( obj -- n )
M: timestamp day-of-week ( timestamp -- n )
: day-of-week ( timestamp -- n )
>date< zeller-congruence ;
M: array day-of-week ( array -- n )
first3 zeller-congruence ;
GENERIC: day-of-year ( obj -- n )
M: array day-of-year ( array -- n )
first3
3dup day-counts rot head-slice sum +
swap leap-year? [
-roll
pick 3 1 <date> >r <date> r>
:: (day-of-year) ( year month day -- n )
day-counts month head-slice sum day +
year leap-year? [
year month day <date>
year 3 1 <date>
after=? [ 1+ ] when
] [
>r 3drop r>
] if ;
] when ;
M: timestamp day-of-year ( timestamp -- n )
>date< 3array day-of-year ;
: day-of-year ( timestamp -- n )
>date< (day-of-year) ;
: day-offset ( timestamp m -- timestamp n )
over day-of-week - ; inline
@ -373,7 +357,7 @@ M: timestamp day-of-year ( timestamp -- n )
M: timestamp sleep-until timestamp>millis sleep-until ;
M: duration sleep from-now sleep-until ;
M: duration sleep hence sleep-until ;
{
{ [ os unix? ] [ "calendar.unix" ] }

6
extra/calendar/format/format.factor
View File

@ -57,9 +57,9 @@ GENERIC: month. ( obj -- )
M: array month. ( pair -- )
first2
[ month-names nth write bl number>string print ] 2keep
[ 1 zeller-congruence ] 2keep
2array days-in-month day-abbreviations2 " " join print
[ month-names nth write bl number>string print ]
[ 1 zeller-congruence ]
[ (days-in-month) day-abbreviations2 " " join print ] 2tri
over " " <repetition> concat write
[
[ 1+ day. ] keep

10
extra/color-picker/color-picker.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.parser models sequences
ui ui.gadgets ui.gadgets.frames
ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders ui.render
;
USING: kernel math math.functions math.parser models
models.filter models.range models.compose sequences ui
ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
ui.gadgets.sliders ui.render ;
IN: color-picker
! Simple example demonstrating the use of models.

2
extra/columns/columns-docs.factor
View File

@ -11,7 +11,7 @@ HELP: column
HELP: <column> ( seq n -- column )
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of " { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
{ $examples
{ $example
"USING: arrays prettyprint columns ;"

19
extra/combinators/cleave/cleave-tests.factor Normal file
View File

@ -0,0 +1,19 @@
USING: kernel math math.functions tools.test combinators.cleave ;
IN: combinators.cleave.tests
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: unit-test* ( input output -- ) swap unit-test ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ { [ 1 ] [ 2 ] [ 3 ] [ 4 ] } 0arr ] [ { 1 2 3 4 } ] unit-test*
[ 3 { 1+ 1- 2^ } 1arr ] [ { 4 2 8 } ] unit-test*
[ 3 4 { [ + ] [ - ] [ ^ ] } 2arr ] [ { 7 -1 81 } ] unit-test*
[ 1 2 3 { [ + + ] [ - - ] [ * * ] } 3arr ] [ { 6 2 6 } ] unit-test*

27
extra/combinators/cleave/cleave.factor Normal file → Executable file
View File

@ -1,17 +1,36 @@
USING: kernel arrays sequences macros combinators ;
USING: kernel combinators words quotations arrays sequences locals macros
shuffle combinators.lib generalizations fry ;
IN: combinators.cleave
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
: >quots ( seq -- seq ) [ >quot ] map ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: [ncleave] ( SEQ N -- quot )
SEQ >quots [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ;
MACRO: ncleave ( seq n -- quot ) [ncleave] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Cleave into array
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: words quotations fry arrays.lib ;
: [narr] ( seq n -- quot ) over length '[ , , ncleave , narray ] ;
: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
MACRO: narr ( seq n -- array ) [narr] ;
: >quots ( seq -- seq ) [ >quot ] map ;
MACRO: 0arr ( seq -- array ) 0 [narr] ;
MACRO: 1arr ( seq -- array ) 1 [narr] ;
MACRO: 2arr ( seq -- array ) 2 [narr] ;
MACRO: 3arr ( seq -- array ) 3 [narr] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: <arr> ( seq -- )
[ >quots ] [ length ] bi

43
extra/combinators/lib/lib-docs.factor
View File

@ -11,46 +11,3 @@ HELP: generate
"[ 20 random-prime ] [ 4 mod 3 = ] generate ."
"526367"
} ;
HELP: ndip
{ $values { "quot" quotation } { "n" number } }
{ $description "A generalisation of " { $link dip } " that can work "
"for any stack depth. The quotation will be called with a stack that "
"has 'n' items removed first. The 'n' items are then put back on the "
"stack. The quotation can consume and produce any number of items."
}
{ $examples
{ $example "USING: combinators.lib kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
{ $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
}
{ $see-also dip 2dip } ;
HELP: nslip
{ $values { "n" number } }
{ $description "A generalisation of " { $link slip } " that can work "
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
"removed from the stack, the quotation called, and the items restored."
}
{ $examples
{ $example "USING: combinators.lib prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }
}
{ $see-also slip nkeep } ;
HELP: nkeep
{ $values { "quot" quotation } { "n" number } }
{ $description "A generalisation of " { $link keep } " that can work "
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
"saved, the quotation called, and the items restored."
}
{ $examples
{ $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" }
}
{ $see-also keep nslip } ;
! HELP: &&
! { $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } }
! { $description "Calls each quotation in turn; outputs " { $link f } " if one of the quotations output " { $link f } ", otherwise outputs " { $link t } ". As soon as a quotation outputs " { $link f } ", evaluation stops and subsequent quotations are not called." } ;
! HELP: ||
! { $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } }
! { $description "Calls each quotation in turn; outputs " { $link t } " if one of the quotations output " { $link t } ", otherwise outputs " { $link f } ". As soon as a quotation outputs " { $link t } ", evaluation stops and subsequent quotations are not called." } ;

10
extra/combinators/lib/lib-tests.factor
View File

@ -5,16 +5,6 @@ IN: combinators.lib.tests
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
[ [ dup 2^ 2array ] 5 napply ] must-infer
[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test
[ { "foo" "xbarx" } ]
[
{ "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call

22
extra/combinators/lib/lib.factor
View File

@ -4,7 +4,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators fry namespaces quotations hashtables
sequences assocs arrays inference effects math math.ranges
arrays.lib shuffle macros continuations locals ;
generalizations macros continuations locals ;
IN: combinators.lib
@ -12,30 +12,10 @@ IN: combinators.lib
! Generalized versions of core combinators
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: ndip ( quot n -- ) dup saver -rot restorer 3append ;
MACRO: nslip ( n -- ) dup saver [ call ] rot restorer 3append ;
: 4slip ( quot a b c d -- a b c d ) 4 nslip ; inline
MACRO: nkeep ( n -- )
[ ] [ 1+ ] [ ] tri
'[ [ , ndup ] dip , -nrot , nslip ] ;
: 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline
MACRO: ncurry ( n -- ) [ curry ] n*quot ;
MACRO:: nwith ( quot n -- )
[let | n' [ n 1+ ] |
[ n' -nrot [ n' nrot quot call ] n ncurry ] ] ;
MACRO: napply ( n -- )
2 [a,b]
[ [ 1- ] [ ] bi
'[ , ntuck , nslip ] ]
map concat >quotation [ call ] append ;
: 2with ( param1 param2 obj quot -- obj curry )
with with ; inline

4
extra/combinators/short-circuit/short-circuit.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: kernel combinators quotations arrays sequences assocs
locals shuffle macros fry ;
locals generalizations macros fry ;
IN: combinators.short-circuit
@ -16,6 +16,7 @@ IN: combinators.short-circuit
MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ;
MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ;
MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ;
MACRO: 3&& ( quots -- quot ) 3 n&&-rewrite ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -29,5 +30,6 @@ MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ;
MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ;
MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ;
MACRO: 2|| ( quots -- quot ) 2 n||-rewrite ;
MACRO: 3|| ( quots -- quot ) 3 n||-rewrite ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

1
extra/ctags/authors.txt Normal file
View File

@ -0,0 +1 @@
Alfredo Beaumont

60
extra/ctags/ctags-docs.factor Normal file
View File

@ -0,0 +1,60 @@
USING: help.syntax help.markup kernel prettyprint sequences strings ;
IN: ctags
ARTICLE: "ctags" "Ctags file"
{ $emphasis "ctags" } " generates a index file of every factor word in ctags format as supported by vi and other editors. More information can be found at " { $url "http://en.wikipedia.org/wiki/Ctags" } "."
{ $subsection ctags }
{ $subsection ctags-write }
{ $subsection ctag-strings }
{ $subsection ctag } ;
HELP: ctags ( path -- )
{ $values { "path" "a pathname string" } }
{ $description "Generates a index file in ctags format and stores in " { $snippet "path" } "." }
{ $examples
{ $unchecked-example
"USING: ctags ;"
"\"tags\" ctags"
""
}
} ;
HELP: ctags-write ( seq path -- )
{ $values { "alist" "an association list" }
{ "path" "a pathname string" } }
{ $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" }
{ $examples
{ $unchecked-example
"USING: kernel ctags ;"
"{ { if { \"resource:extra/unix/unix.factor\" 91 } } } \"tags\" ctags-write"
""
}
}
{ $notes
{ $snippet "tags" } " file will contain a single line: if\\t/path/to/factor/extra/unix/unix.factor\\t91" } ;
HELP: ctag-strings ( alist -- seq )
{ $values { "alist" "an association list" }
{ "seq" sequence } }
{ $description "Converts an " { $snippet "alist" } " with ctag format (a word as key and a sequence whose first element is a resource name and a second element is a line number as value) in a " { $snippet "seq" } " of ctag strings." }
{ $examples
{ $unchecked-example
"USING: kernel ctags prettyprint ;"
"{ { if { \"resource:extra/unix/unix.factor\" 91 } } } ctag-strings ."
"{ \"if\\t/path/to/factor/extra/unix/unix.factor\\t91\" }"
}
} ;
HELP: ctag ( seq -- str )
{ $values { "seq" sequence }
{ "str" string } }
{ $description "Outputs a string " { $snippet "str" } " in ctag format for sequence with two elements, first one must be a valid word and second one a sequence whose first element is a resource name and second element is a line number" }
{ $examples
{ $unchecked-example
"USING: kernel ctags prettyprint ;"
"{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag ."
"\"if\\t/path/to/factor/extra/unix/unix.factor\\t91\""
}
} ;
ABOUT: "ctags"

12
extra/ctags/ctags-tests.factor Normal file
View File

@ -0,0 +1,12 @@
USING: kernel ctags tools.test io.backend sequences arrays prettyprint ;
IN: ctags.tests
[ t ] [
"if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append
{ if { "resource:extra/unix/unix.factor" 91 } } ctag =
] unit-test
[ t ] [
"if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append 1array
{ { if { "resource:extra/unix/unix.factor" 91 } } } ctag-strings =
] unit-test

37
extra/ctags/ctags.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2008 Alfredo Beaumont
! See http://factorcode.org/license.txt for BSD license.
! Simple Ctags generator
! Alfredo Beaumont <alfredo.beaumont@gmail.com>
USING: arrays kernel sequences io io.files io.backend
io.encodings.ascii math.parser vocabs definitions
namespaces words sorting ;
IN: ctags
: ctag ( seq -- str )
[
dup first ?word-name %
"\t" %
second dup first normalize-path %
"\t" %
second number>string %
] "" make ;
: ctag-strings ( seq1 -- seq2 )
{ } swap [ ctag suffix ] each ;
: ctags-write ( seq path -- )
[ ctag-strings ] dip ascii set-file-lines ;
: (ctags) ( -- seq )
{ } all-words [
dup where [
2array suffix
] [
drop
] if*
] each ;
: ctags ( path -- )
(ctags) sort-keys swap ctags-write ;

1
extra/ctags/summary.txt Normal file
View File

@ -0,0 +1 @@
Ctags generator

16
extra/db/pools/pools-tests.factor
View File

@ -1,8 +1,22 @@
IN: db.pools.tests
USING: db.pools tools.test ;
USING: db.pools tools.test continuations io.files namespaces
accessors kernel math destructors ;
\ <db-pool> must-infer
{ 2 0 } [ [ ] with-db-pool ] must-infer-as
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
! Test behavior after image save/load
USE: db.sqlite
[ "pool-test.db" temp-file delete-file ] ignore-errors
[ ] [ "pool-test.db" sqlite-db <db-pool> "pool" set ] unit-test
[ ] [ "pool" get expired>> t >>expired drop ] unit-test
[ ] [ 1000 [ "pool" get [ ] with-pooled-db ] times ] unit-test
[ ] [ "pool" get dispose ] unit-test

31
extra/db/tuples/tuples-tests.factor
View File

@ -4,7 +4,7 @@ USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitfields.lib
math.ranges strings sequences.lib urls ;
math.ranges strings sequences.lib urls fry ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
@ -201,10 +201,10 @@ TUPLE: annotation n paste-id summary author mode contents ;
! ] with-db
: test-sqlite ( quot -- )
>r "tuples-test.db" temp-file sqlite-db r> with-db ;
[ ] swap '[ "tuples-test.db" temp-file sqlite-db , with-db ] unit-test ;
: test-postgresql ( quot -- )
>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
[ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db , with-db ] unit-test ;
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
@ -463,6 +463,31 @@ fubbclass "FUBCLASS" { } define-persistent
[ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
[ test-db-inheritance ] test-sqlite
[ test-db-inheritance ] test-postgresql
TUPLE: string-encoding-test id string ;
string-encoding-test "STRING_ENCODING_TEST" {
{ "id" "ID" +db-assigned-id+ }
{ "string" "STRING" TEXT }
} define-persistent
: test-string-encoding ( -- )
[ ] [ string-encoding-test ensure-table ] unit-test
[ ] [
string-encoding-test new
"\u{copyright-sign}\u{bengali-letter-cha}" >>string
[ insert-tuple ] [ id>> "id" set ] bi
] unit-test
[ "\u{copyright-sign}\u{bengali-letter-cha}" ] [
string-encoding-test new "id" get >>id select-tuple string>>
] unit-test ;
[ test-string-encoding ] test-sqlite
[ test-string-encoding ] test-postgresql
! Don't comment these out. These words must infer
\ bind-tuple must-infer

6
extra/delegate/delegate.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes words slots assocs
sequences arrays vectors definitions prettyprint
math hashtables sets macros namespaces ;
USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions
prettyprint math hashtables sets macros namespaces ;
IN: delegate
: protocol-words ( protocol -- words )

2
extra/descriptive/descriptive.factor
View File

@ -1,6 +1,6 @@
USING: words kernel sequences combinators.lib locals
locals.private accessors parser namespaces continuations
summary definitions arrays.lib arrays ;
summary definitions generalizations arrays ;
IN: descriptive
ERROR: descriptive-error args underlying word ;

3
extra/furnace/auth/login/login.factor
View File

@ -40,10 +40,9 @@ M: login-realm modify-form ( responder -- )
permit-id get realm get name>> permit-id-key <cookie>
"$login-realm" resolve-base-path >>path
realm get
[ timeout>> from-now >>expires ]
[ domain>> >>domain ]
[ secure>> >>secure ]
tri ;
bi ;
: put-permit-cookie ( response -- response' )
<permit-cookie> put-cookie ;

4
extra/furnace/cache/cache.factor vendored
View File

@ -31,6 +31,6 @@ TUPLE: server-state-manager < filter-responder timeout ;
new
swap >>responder
20 minutes >>timeout ; inline
: touch-state ( state manager -- )
timeout>> from-now >>expires drop ;
timeout>> hence >>expires drop ;

1
extra/furnace/sessions/sessions.factor
View File

@ -116,7 +116,6 @@ M: session-saver dispose
: <session-cookie> ( -- cookie )
session get id>> session-id-key <cookie>
"$sessions" resolve-base-path >>path
sessions get timeout>> from-now >>expires
sessions get domain>> >>domain ;
: put-session-cookie ( response -- response' )

136
extra/generalizations/generalizations-docs.factor Executable file
View File

@ -0,0 +1,136 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup kernel sequences quotations
math ;
IN: generalizations
HELP: npick
{ $values { "n" integer } }
{ $description "A generalization of " { $link dup } ", "
{ $link over } " and " { $link pick } " that can work "
"for any stack depth. The nth item down the stack will be copied and "
"placed on the top of the stack."
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }
}
{ $see-also dup over pick } ;
HELP: ndup
{ $values { "n" integer } }
{ $description "A generalization of " { $link dup } ", "
{ $link 2dup } " and " { $link 3dup } " that can work "
"for any number of items. The n topmost items on the stack will be copied and "
"placed on the top of the stack."
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }
}
{ $see-also dup 2dup 3dup } ;
HELP: nnip
{ $values { "n" integer } }
{ $description "A generalization of " { $link nip } " and " { $link 2nip }
" that can work "
"for any number of items."
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" }
}
{ $see-also nip 2nip } ;
HELP: ndrop
{ $values { "n" integer } }
{ $description "A generalization of " { $link drop }
" that can work "
"for any number of items."
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" }
}
{ $see-also drop 2drop 3drop } ;
HELP: nrot
{ $values { "n" integer } }
{ $description "A generalization of " { $link rot } " that works for any "
"number of items on the stack. "
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }
}
{ $see-also rot -nrot } ;
HELP: -nrot
{ $values { "n" integer } }
{ $description "A generalization of " { $link -rot } " that works for any "
"number of items on the stack. "
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }
}
{ $see-also rot nrot } ;
HELP: nrev
{ $values { "n" integer } }
{ $description "A generalization of " { $link spin } " that reverses any number of items at the top of the stack."
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrev .s" "4\n3\n2\n1" }
}
{ $see-also rot nrot } ;
HELP: ndip
{ $values { "quot" quotation } { "n" number } }
{ $description "A generalization of " { $link dip } " that can work "
"for any stack depth. The quotation will be called with a stack that "
"has 'n' items removed first. The 'n' items are then put back on the "
"stack. The quotation can consume and produce any number of items."
}
{ $examples
{ $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
}
{ $see-also dip 2dip } ;
HELP: nslip
{ $values { "n" number } }
{ $description "A generalization of " { $link slip } " that can work "
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
"removed from the stack, the quotation called, and the items restored."
}
{ $examples
{ $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }
}
{ $see-also slip nkeep } ;
HELP: nkeep
{ $values { "quot" quotation } { "n" number } }
{ $description "A generalization of " { $link keep } " that can work "
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
"saved, the quotation called, and the items restored."
}
{ $examples
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" }
}
{ $see-also keep nslip } ;
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
"A number of stack shuffling words and combinators for use in "
"macros where the arity of the input quotations depends on an "
"input parameter."
{ $subsection narray }
{ $subsection ndup }
{ $subsection npick }
{ $subsection nrot }
{ $subsection -nrot }
{ $subsection nnip }
{ $subsection ndrop }
{ $subsection nrev }
{ $subsection ndip }
{ $subsection nslip }
{ $subsection nkeep }
{ $subsection ncurry }
{ $subsection nwith }
{ $subsection napply } ;
ABOUT: "generalizations"

34
extra/generalizations/generalizations-tests.factor Executable file
View File

@ -0,0 +1,34 @@
USING: tools.test generalizations kernel math arrays sequences ;
IN: generalizations.tests
{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test
{ 1 2 3 4 2 } [ 1 2 3 4 3 npick ] unit-test
{ 1 2 3 4 3 } [ 1 2 3 4 2 npick ] unit-test
{ 1 2 3 4 4 } [ 1 2 3 4 1 npick ] unit-test
[ 1 1 ndup ] must-infer
{ 1 1 } [ 1 1 ndup ] unit-test
{ 1 2 1 2 } [ 1 2 2 ndup ] unit-test
{ 1 2 3 1 2 3 } [ 1 2 3 3 ndup ] unit-test
{ 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4 ndup ] unit-test
[ 1 2 2 nrot ] must-infer
{ 2 1 } [ 1 2 2 nrot ] unit-test
{ 2 3 1 } [ 1 2 3 3 nrot ] unit-test
{ 2 3 4 1 } [ 1 2 3 4 4 nrot ] unit-test
[ 1 2 2 -nrot ] must-infer
{ 2 1 } [ 1 2 2 -nrot ] unit-test
{ 3 1 2 } [ 1 2 3 3 -nrot ] unit-test
{ 4 1 2 3 } [ 1 2 3 4 4 -nrot ] unit-test
[ 1 2 3 4 3 nnip ] must-infer
{ 4 } [ 1 2 3 4 3 nnip ] unit-test
[ 1 2 3 4 4 ndrop ] must-infer
{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test
[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
[ [ dup 2^ 2array ] 5 napply ] must-infer
[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test

56
extra/generalizations/generalizations.factor Executable file
View File

@ -0,0 +1,56 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private namespaces math math.ranges
combinators macros quotations fry locals arrays ;
IN: generalizations
MACRO: narray ( n -- quot )
dup [ f <array> ] curry
swap <reversed> [
[ swap [ set-nth-unsafe ] keep ] curry
] map concat append ;
MACRO: npick ( n -- )
1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
MACRO: ndup ( n -- )
dup '[ , npick ] n*quot ;
MACRO: nrot ( n -- )
1- dup saver swap [ r> swap ] n*quot append ;
MACRO: -nrot ( n -- )
1- dup [ swap >r ] n*quot swap restorer append ;
MACRO: ndrop ( n -- )
[ drop ] n*quot ;
: nnip ( n -- )
swap >r ndrop r> ; inline
MACRO: ntuck ( n -- )
2 + [ dupd -nrot ] curry ;
MACRO: nrev ( n -- quot )
1 [a,b] [ '[ , -nrot ] ] map concat ;
MACRO: ndip ( quot n -- )
dup saver -rot restorer 3append ;
MACRO: nslip ( n -- )
dup saver [ call ] rot restorer 3append ;
MACRO: nkeep ( n -- )
[ ] [ 1+ ] [ ] tri
'[ [ , ndup ] dip , -nrot , nslip ] ;
MACRO: ncurry ( n -- ) [ curry ] n*quot ;
MACRO:: nwith ( quot n -- )
[let | n' [ n 1+ ] |
[ n' -nrot [ n' nrot quot call ] n ncurry ] ] ;
MACRO: napply ( n -- )
2 [a,b]
[ [ 1- ] keep '[ , ntuck , nslip ] ]
map concat >quotation [ call ] append ;

4
extra/html/parser/analyzer/analyzer.factor
View File

@ -1,6 +1,6 @@
USING: assocs html.parser kernel math sequences strings ascii
arrays shuffle unicode.case namespaces splitting http
sequences.lib accessors io combinators http.client urls ;
arrays generalizations shuffle unicode.case namespaces splitting
http sequences.lib accessors io combinators http.client urls ;
IN: html.parser.analyzer
TUPLE: link attributes clickable ;

4
extra/inverse/inverse.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2007, 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel words summary slots quotations
sequences assocs math arrays inference effects shuffle
sequences assocs math arrays inference effects generalizations
continuations debugger classes.tuple namespaces vectors
bit-arrays byte-arrays strings sbufs math.functions macros
sequences.private combinators mirrors combinators.lib
sequences.private combinators mirrors
combinators.short-circuit ;
IN: inverse

2
extra/io/pools/pools.factor
View File

@ -9,7 +9,7 @@ TUPLE: pool connections disposed expired ;
: check-pool ( pool -- )
dup check-disposed
dup expired>> expired? [
ALIEN: 31337 >>expired
31337 <alien> >>expired
connections>> delete-all
] [ drop ] if ;

9
extra/io/unix/backend/backend.factor
View File

@ -125,7 +125,8 @@ M: fd refill
} cond ;
M: unix (wait-to-read) ( port -- )
dup dup handle>> refill dup
dup
dup handle>> dup check-disposed refill dup
[ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
! Writers
@ -144,7 +145,9 @@ M: fd drain
} cond ;
M: unix (wait-to-write) ( port -- )
dup dup handle>> drain dup [ wait-for-port ] [ 2drop ] if ;
dup
dup handle>> dup check-disposed drain
dup [ wait-for-port ] [ 2drop ] if ;
M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
@ -168,7 +171,7 @@ M: stdin dispose
: wait-for-stdin ( stdin -- n )
[ control>> CHAR: X over io:stream-write1 io:stream-flush ]
[ size>> "uint" heap-size swap io:stream-read *uint ]
[ size>> "ssize_t" heap-size swap io:stream-read *int ]
bi ;
:: refill-stdin ( buffer stdin size -- )

1
extra/io/windows/files/files.factor
View File

@ -61,6 +61,7 @@ C: <FileArgs> FileArgs
: make-FileArgs ( port -- <FileArgs> )
{
[ handle>> check-disposed ]
[ handle>> handle>> ]
[ buffer>> ]
[ buffer>> buffer-length ]

2
extra/io/windows/nt/backend/backend.factor
View File

@ -74,7 +74,7 @@ M: winnt add-completion ( win32-handle -- )
] if ;
M: win32-handle cancel-operation
handle>> CancelIo drop ;
[ check-disposed ] [ handle>> CancelIo drop ] bi ;
M: winnt io-multiplex ( ms -- )
handle-overlapped [ 0 io-multiplex ] when ;

8
extra/io/windows/privileges/privileges.factor
View File

@ -1,4 +1,5 @@
USING: io.backend kernel continuations sequences ;
USING: io.backend kernel continuations sequences
system vocabs.loader combinators ;
IN: io.windows.privileges
HOOK: set-privilege io-backend ( name ? -- ) inline
@ -6,3 +7,8 @@ HOOK: set-privilege io-backend ( name ? -- ) inline
: with-privileges ( seq quot -- )
over [ [ t set-privilege ] each ] curry compose
swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline
{
{ [ os winnt? ] [ "io.windows.nt.privileges" require ] }
{ [ os wince? ] [ "io.windows.ce.privileges" require ] }
} cond

12
extra/koszul/koszul.factor
View File

@ -257,11 +257,11 @@ DEFER: (d)
[ laplacian-kernel ] graded-laplacian ;
: graded-basis. ( seq -- )
dup length [
[
"=== Degree " write pprint
": dimension " write dup length .
[ alt. ] each
] 2each ;
] each-index ;
: bigraded-triple ( u-deg z-deg bigraded-basis -- triple )
#! d: C(u,z) ---> C(u+2,z-1)
@ -289,11 +289,11 @@ DEFER: (d)
[ laplacian-kernel ] bigraded-laplacian ;
: bigraded-basis. ( seq -- )
dup length [
[
"=== U-degree " write .
dup length [
[
" === Z-degree " write pprint
": dimension " write dup length .
[ " " write alt. ] each
] 2each
] 2each ;
] each-index
] each-index ;

7
extra/lcd/lcd.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel math io calendar calendar.format
calendar.model arrays models namespaces ui.gadgets
ui.gadgets.labels
ui.gadgets.theme ui ;
calendar.model arrays models models.filter namespaces ui.gadgets
ui.gadgets.labels ui.gadgets.theme ui ;
IN: lcd
: lcd-digit ( row digit -- str )

2
extra/logging/logging.factor
View File

@ -3,7 +3,7 @@
USING: logging.server sequences namespaces concurrency.messaging
words kernel arrays shuffle tools.annotations
prettyprint.config prettyprint debugger io.streams.string
splitting continuations effects arrays.lib parser strings
splitting continuations effects generalizations parser strings
quotations fry symbols accessors ;
IN: logging

1
extra/math/blas/cblas/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

557
extra/math/blas/cblas/cblas.factor Normal file
View File

@ -0,0 +1,557 @@
USING: alien alien.c-types alien.syntax kernel system combinators ;
IN: math.blas.cblas
<< "cblas" {
{ [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
{ [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
[ "libblas.so" "cdecl" add-library ]
} cond >>
LIBRARY: cblas
TYPEDEF: int CBLAS_ORDER
: CblasRowMajor 101 ; inline
: CblasColMajor 102 ; inline
TYPEDEF: int CBLAS_TRANSPOSE
: CblasNoTrans 111 ; inline
: CblasTrans 112 ; inline
: CblasConjTrans 113 ; inline
TYPEDEF: int CBLAS_UPLO
: CblasUpper 121 ; inline
: CblasLower 122 ; inline
TYPEDEF: int CBLAS_DIAG
: CblasNonUnit 131 ; inline
: CblasUnit 132 ; inline
TYPEDEF: int CBLAS_SIDE
: CblasLeft 141 ; inline
: CblasRight 142 ; inline
TYPEDEF: int CBLAS_INDEX
C-STRUCT: CBLAS_C
{ "float" "real" }
{ "float" "imag" } ;
C-STRUCT: CBLAS_Z
{ "double" "real" }
{ "double" "imag" } ;
! Level 1 BLAS (scalar-vector and vector-vector)
FUNCTION: float cblas_sdsdot
( int N, float alpha, float* X, int incX, float* Y, int incY ) ;
FUNCTION: double cblas_dsdot
( int N, float* X, int incX, float* Y, int incY ) ;
FUNCTION: float cblas_sdot
( int N, float* X, int incX, float* Y, int incY ) ;
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 ) ;
FUNCTION: void cblas_cdotc_sub
( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotc ) ;
FUNCTION: void cblas_zdotu_sub
( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotu ) ;
FUNCTION: void cblas_zdotc_sub
( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotc ) ;
FUNCTION: float cblas_snrm2
( int N, float* X, int incX ) ;
FUNCTION: float cblas_sasum
( int N, float* X, int incX ) ;
FUNCTION: double cblas_dnrm2
( int N, double* X, int incX ) ;
FUNCTION: double cblas_dasum
( int N, double* X, int incX ) ;
FUNCTION: float cblas_scnrm2
( int N, CBLAS_C* X, int incX ) ;
FUNCTION: float cblas_scasum
( int N, CBLAS_C* X, int incX ) ;
FUNCTION: double cblas_dznrm2
( int N, CBLAS_Z* X, int incX ) ;
FUNCTION: double cblas_dzasum
( int N, CBLAS_Z* 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 ) ;
FUNCTION: CBLAS_INDEX cblas_izamax
( int N, CBLAS_Z* X, int incX ) ;
FUNCTION: void cblas_sswap
( int N, float* X, int incX, float* Y, int incY ) ;
FUNCTION: void cblas_scopy
( int N, float* X, int incX, float* Y, int incY ) ;
FUNCTION: void cblas_saxpy
( int N, float alpha, float* X, int incX, float* Y, int incY ) ;
FUNCTION: void cblas_dswap
( int N, double* X, int incX, double* Y, int incY ) ;
FUNCTION: void cblas_dcopy
( int N, double* X, int incX, double* Y, int incY ) ;
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 ) ;
FUNCTION: void cblas_ccopy
( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
FUNCTION: void cblas_caxpy
( int N, CBLAS_C* alpha, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
FUNCTION: void cblas_zswap
( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
FUNCTION: void cblas_zcopy
( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
FUNCTION: void cblas_zaxpy
( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX, CBLAS_Z* 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 ) ;
FUNCTION: void cblas_zscal
( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX ) ;
FUNCTION: void cblas_csscal
( int N, float alpha, CBLAS_C* X, int incX ) ;
FUNCTION: void cblas_zdscal
( int N, double alpha, CBLAS_Z* X, int incX ) ;
FUNCTION: void cblas_srotg
( float* a, float* b, float* c, float* s ) ;
FUNCTION: void cblas_srotmg
( float* d1, float* d2, float* b1, float b2, float* P ) ;
FUNCTION: void cblas_srot
( int N, float* X, int incX, float* Y, int incY, float c, float s ) ;
FUNCTION: void cblas_srotm
( int N, float* X, int incX, float* Y, int incY, float* P ) ;
FUNCTION: void cblas_drotg
( double* a, double* b, double* c, double* s ) ;
FUNCTION: void cblas_drotmg
( double* d1, double* d2, double* b1, double b2, double* P ) ;
FUNCTION: void cblas_drot
( int N, double* X, int incX, double* Y, int incY, double c, double s ) ;
FUNCTION: void cblas_drotm
( int N, double* X, int incX, double* Y, int incY, double* P ) ;
! Level 2 BLAS (matrix-vector)
FUNCTION: void cblas_sgemv ( CBLAS_ORDER Order,
CBLAS_TRANSPOSE TransA, int M, int N,
float alpha, float* A, int lda,
float* X, int incX, float beta,
float* Y, int incY ) ;
FUNCTION: void cblas_sgbmv ( CBLAS_ORDER Order,
CBLAS_TRANSPOSE TransA, int M, int N,
int KL, int KU, float alpha,
float* A, int lda, float* X,
int incX, float beta, float* Y, int incY ) ;
FUNCTION: void cblas_strmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, float* A, int lda,
float* X, int incX ) ;
FUNCTION: void cblas_stbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, int K, float* A, int lda,
float* X, int incX ) ;
FUNCTION: void cblas_stpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, float* Ap, float* X, int incX ) ;
FUNCTION: void cblas_strsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, float* A, int lda, float* X,
int incX ) ;
FUNCTION: void cblas_stbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, int K, float* A, int lda,
float* X, int incX ) ;
FUNCTION: void cblas_stpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, float* Ap, float* X, int incX ) ;
FUNCTION: void cblas_dgemv ( CBLAS_ORDER Order,
CBLAS_TRANSPOSE TransA, int M, int N,
double alpha, double* A, int lda,
double* X, int incX, double beta,
double* Y, int incY ) ;
FUNCTION: void cblas_dgbmv ( CBLAS_ORDER Order,
CBLAS_TRANSPOSE TransA, int M, int N,
int KL, int KU, double alpha,
double* A, int lda, double* X,
int incX, double beta, double* Y, int incY ) ;
FUNCTION: void cblas_dtrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, double* A, int lda,
double* X, int incX ) ;
FUNCTION: void cblas_dtbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, int K, double* A, int lda,
double* X, int incX ) ;
FUNCTION: void cblas_dtpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, double* Ap, double* X, int incX ) ;
FUNCTION: void cblas_dtrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, double* A, int lda, double* X,
int incX ) ;
FUNCTION: void cblas_dtbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, int K, double* A, int lda,
double* X, int incX ) ;
FUNCTION: void cblas_dtpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, double* Ap, double* X, int incX ) ;
FUNCTION: void cblas_cgemv ( CBLAS_ORDER Order,
CBLAS_TRANSPOSE TransA, int M, int N,
void* alpha, void* A, int lda,
void* X, int incX, void* beta,
void* Y, int incY ) ;
FUNCTION: void cblas_cgbmv ( CBLAS_ORDER Order,
CBLAS_TRANSPOSE TransA, int M, int N,
int KL, int KU, void* alpha,
void* A, int lda, void* X,
int incX, void* beta, void* Y, int incY ) ;
FUNCTION: void cblas_ctrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, void* A, int lda,
void* X, int incX ) ;
FUNCTION: void cblas_ctbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, int K, void* A, int lda,
void* X, int incX ) ;
FUNCTION: void cblas_ctpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, void* Ap, void* X, int incX ) ;
FUNCTION: void cblas_ctrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, void* A, int lda, void* X,
int incX ) ;
FUNCTION: void cblas_ctbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, int K, void* A, int lda,
void* X, int incX ) ;
FUNCTION: void cblas_ctpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, void* Ap, void* X, int incX ) ;
FUNCTION: void cblas_zgemv ( CBLAS_ORDER Order,
CBLAS_TRANSPOSE TransA, int M, int N,
void* alpha, void* A, int lda,
void* X, int incX, void* beta,
void* Y, int incY ) ;
FUNCTION: void cblas_zgbmv ( CBLAS_ORDER Order,
CBLAS_TRANSPOSE TransA, int M, int N,
int KL, int KU, void* alpha,
void* A, int lda, void* X,
int incX, void* beta, void* Y, int incY ) ;
FUNCTION: void cblas_ztrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, void* A, int lda,
void* X, int incX ) ;
FUNCTION: void cblas_ztbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, int K, void* A, int lda,
void* X, int incX ) ;
FUNCTION: void cblas_ztpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, void* Ap, void* X, int incX ) ;
FUNCTION: void cblas_ztrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, void* A, int lda, void* X,
int incX ) ;
FUNCTION: void cblas_ztbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, int K, void* A, int lda,
void* X, int incX ) ;
FUNCTION: void cblas_ztpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
int N, void* Ap, void* X, int incX ) ;
FUNCTION: void cblas_ssymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, float alpha, float* A,
int lda, float* X, int incX,
float beta, float* Y, int incY ) ;
FUNCTION: void cblas_ssbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, int K, float alpha, float* A,
int lda, float* X, int incX,
float beta, float* Y, int incY ) ;
FUNCTION: void cblas_sspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, float alpha, float* Ap,
float* X, int incX,
float beta, float* Y, int incY ) ;
FUNCTION: void cblas_sger ( CBLAS_ORDER Order, int M, int N,
float alpha, float* X, int incX,
float* Y, int incY, float* A, int lda ) ;
FUNCTION: void cblas_ssyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, float alpha, float* X,
int incX, float* A, int lda ) ;
FUNCTION: void cblas_sspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, float alpha, float* X,
int incX, float* Ap ) ;
FUNCTION: void cblas_ssyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, float alpha, float* X,
int incX, float* Y, int incY, float* A,
int lda ) ;
FUNCTION: void cblas_sspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, float alpha, float* X,
int incX, float* Y, int incY, float* A ) ;
FUNCTION: void cblas_dsymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, double alpha, double* A,
int lda, double* X, int incX,
double beta, double* Y, int incY ) ;
FUNCTION: void cblas_dsbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, int K, double alpha, double* A,
int lda, double* X, int incX,
double beta, double* Y, int incY ) ;
FUNCTION: void cblas_dspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, double alpha, double* Ap,
double* X, int incX,
double beta, double* Y, int incY ) ;
FUNCTION: void cblas_dger ( CBLAS_ORDER Order, int M, int N,
double alpha, double* X, int incX,
double* Y, int incY, double* A, int lda ) ;
FUNCTION: void cblas_dsyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, double alpha, double* X,
int incX, double* A, int lda ) ;
FUNCTION: void cblas_dspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, double alpha, double* X,
int incX, double* Ap ) ;
FUNCTION: void cblas_dsyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, double alpha, double* X,
int incX, double* Y, int incY, double* A,
int lda ) ;
FUNCTION: void cblas_dspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, double alpha, double* X,
int incX, double* Y, int incY, double* A ) ;
FUNCTION: void cblas_chemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, void* alpha, void* A,
int lda, void* X, int incX,
void* beta, void* Y, int incY ) ;
FUNCTION: void cblas_chbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, int K, void* alpha, void* A,
int lda, void* X, int incX,
void* beta, void* Y, int incY ) ;
FUNCTION: void cblas_chpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, void* alpha, void* Ap,
void* X, int incX,
void* beta, void* Y, int incY ) ;
FUNCTION: void cblas_cgeru ( CBLAS_ORDER Order, int M, int N,
void* alpha, void* X, int incX,
void* Y, int incY, void* A, int lda ) ;
FUNCTION: void cblas_cgerc ( CBLAS_ORDER Order, int M, int N,
void* alpha, void* X, int incX,
void* Y, int incY, void* A, int lda ) ;
FUNCTION: void cblas_cher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, float alpha, void* X, int incX,
void* A, int lda ) ;
FUNCTION: void cblas_chpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, float alpha, void* X,
int incX, void* A ) ;
FUNCTION: void cblas_cher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
void* alpha, void* X, int incX,
void* Y, int incY, void* A, int lda ) ;
FUNCTION: void cblas_chpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
void* alpha, void* X, int incX,
void* Y, int incY, void* Ap ) ;
FUNCTION: void cblas_zhemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, void* alpha, void* A,
int lda, void* X, int incX,
void* beta, void* Y, int incY ) ;
FUNCTION: void cblas_zhbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, int K, void* alpha, void* A,
int lda, void* X, int incX,
void* beta, void* Y, int incY ) ;
FUNCTION: void cblas_zhpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, void* alpha, void* Ap,
void* X, int incX,
void* beta, void* Y, int incY ) ;
FUNCTION: void cblas_zgeru ( CBLAS_ORDER Order, int M, int N,
void* alpha, void* X, int incX,
void* Y, int incY, void* A, int lda ) ;
FUNCTION: void cblas_zgerc ( CBLAS_ORDER Order, int M, int N,
void* alpha, void* X, int incX,
void* Y, int incY, void* A, int lda ) ;
FUNCTION: void cblas_zher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, double alpha, void* X, int incX,
void* A, int lda ) ;
FUNCTION: void cblas_zhpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
int N, double alpha, void* X,
int incX, void* A ) ;
FUNCTION: void cblas_zher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
void* alpha, void* X, int incX,
void* Y, int incY, void* A, int lda ) ;
FUNCTION: void cblas_zhpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
void* alpha, void* X, int incX,
void* Y, int incY, void* Ap ) ;
! Level 3 BLAS (matrix-matrix)
FUNCTION: void cblas_sgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
CBLAS_TRANSPOSE TransB, int M, int N,
int K, float alpha, float* A,
int lda, float* B, int ldb,
float beta, float* C, int ldc ) ;
FUNCTION: void cblas_ssymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, int M, int N,
float alpha, float* A, int lda,
float* B, int ldb, float beta,
float* C, int ldc ) ;
FUNCTION: void cblas_ssyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE Trans, int N, int K,
float alpha, float* A, int lda,
float beta, float* C, int ldc ) ;
FUNCTION: void cblas_ssyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE Trans, int N, int K,
float alpha, float* A, int lda,
float* B, int ldb, float beta,
float* C, int ldc ) ;
FUNCTION: void cblas_strmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
CBLAS_DIAG Diag, int M, int N,
float alpha, float* A, int lda,
float* B, int ldb ) ;
FUNCTION: void cblas_strsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
CBLAS_DIAG Diag, int M, int N,
float alpha, float* A, int lda,
float* B, int ldb ) ;
FUNCTION: void cblas_dgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
CBLAS_TRANSPOSE TransB, int M, int N,
int K, double alpha, double* A,
int lda, double* B, int ldb,
double beta, double* C, int ldc ) ;
FUNCTION: void cblas_dsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, int M, int N,
double alpha, double* A, int lda,
double* B, int ldb, double beta,
double* C, int ldc ) ;
FUNCTION: void cblas_dsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE Trans, int N, int K,
double alpha, double* A, int lda,
double beta, double* C, int ldc ) ;
FUNCTION: void cblas_dsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE Trans, int N, int K,
double alpha, double* A, int lda,
double* B, int ldb, double beta,
double* C, int ldc ) ;
FUNCTION: void cblas_dtrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
CBLAS_DIAG Diag, int M, int N,
double alpha, double* A, int lda,
double* B, int ldb ) ;
FUNCTION: void cblas_dtrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
CBLAS_DIAG Diag, int M, int N,
double alpha, double* A, int lda,
double* B, int ldb ) ;
FUNCTION: void cblas_cgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
CBLAS_TRANSPOSE TransB, int M, int N,
int K, void* alpha, void* A,
int lda, void* B, int ldb,
void* beta, void* C, int ldc ) ;
FUNCTION: void cblas_csymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, int M, int N,
void* alpha, void* A, int lda,
void* B, int ldb, void* beta,
void* C, int ldc ) ;
FUNCTION: void cblas_csyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE Trans, int N, int K,
void* alpha, void* A, int lda,
void* beta, void* C, int ldc ) ;
FUNCTION: void cblas_csyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE Trans, int N, int K,
void* alpha, void* A, int lda,
void* B, int ldb, void* beta,
void* C, int ldc ) ;
FUNCTION: void cblas_ctrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
CBLAS_DIAG Diag, int M, int N,
void* alpha, void* A, int lda,
void* B, int ldb ) ;
FUNCTION: void cblas_ctrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
CBLAS_DIAG Diag, int M, int N,
void* alpha, void* A, int lda,
void* B, int ldb ) ;
FUNCTION: void cblas_zgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
CBLAS_TRANSPOSE TransB, int M, int N,
int K, void* alpha, void* A,
int lda, void* B, int ldb,
void* beta, void* C, int ldc ) ;
FUNCTION: void cblas_zsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, int M, int N,
void* alpha, void* A, int lda,
void* B, int ldb, void* beta,
void* C, int ldc ) ;
FUNCTION: void cblas_zsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE Trans, int N, int K,
void* alpha, void* A, int lda,
void* beta, void* C, int ldc ) ;
FUNCTION: void cblas_zsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE Trans, int N, int K,
void* alpha, void* A, int lda,
void* B, int ldb, void* beta,
void* C, int ldc ) ;
FUNCTION: void cblas_ztrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
CBLAS_DIAG Diag, int M, int N,
void* alpha, void* A, int lda,
void* B, int ldb ) ;
FUNCTION: void cblas_ztrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
CBLAS_DIAG Diag, int M, int N,
void* alpha, void* A, int lda,
void* B, int ldb ) ;
FUNCTION: void cblas_chemm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, int M, int N,
void* alpha, void* A, int lda,
void* B, int ldb, void* beta,
void* C, int ldc ) ;
FUNCTION: void cblas_cherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE Trans, int N, int K,
float alpha, void* A, int lda,
float beta, void* C, int ldc ) ;
FUNCTION: void cblas_cher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE Trans, int N, int K,
void* alpha, void* A, int lda,
void* B, int ldb, float beta,
void* C, int ldc ) ;
FUNCTION: void cblas_zhemm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
CBLAS_UPLO Uplo, int M, int N,
void* alpha, void* A, int lda,
void* B, int ldb, void* beta,
void* C, int ldc ) ;
FUNCTION: void cblas_zherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE Trans, int N, int K,
double alpha, void* A, int lda,
double beta, void* C, int ldc ) ;
FUNCTION: void cblas_zher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
CBLAS_TRANSPOSE Trans, int N, int K,
void* alpha, void* A, int lda,
void* B, int ldb, double beta,
void* C, int ldc ) ;

1
extra/math/blas/cblas/summary.txt Normal file
View File

@ -0,0 +1 @@
Low-level bindings to the C Basic Linear Algebra Subroutines (BLAS) library

2
extra/math/blas/cblas/tags.txt Normal file
View File

@ -0,0 +1,2 @@
math
bindings

1
extra/math/blas/matrices/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

235
extra/math/blas/matrices/matrices-docs.factor Normal file
View File

@ -0,0 +1,235 @@
USING: alien byte-arrays help.markup help.syntax math.blas.vectors sequences ;
IN: math.blas.matrices
ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
"Factor provides an interface to high-performance vector and matrix math routines available in the system's BLAS library. A set of specialized types are provided for handling packed, unboxed vector data:"
{ $subsection "math.blas-types" }
"Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:"
{ $subsection "math.blas.vectors" }
"Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
{ $subsection "math.blas.matrices" }
"The low-level BLAS C interface can be accessed directly through the " { $vocab-link "math.blas.cblas" } " vocabulary." ;
ARTICLE: "math.blas-types" "BLAS interface types"
"BLAS vectors come in single- and double-precision, real and complex flavors:"
{ $subsection float-blas-vector }
{ $subsection double-blas-vector }
{ $subsection float-complex-blas-vector }
{ $subsection double-complex-blas-vector }
"These vector types all follow the " { $link sequence } " protocol. In addition, there are corresponding types for matrix data:"
{ $subsection float-blas-matrix }
{ $subsection double-blas-matrix }
{ $subsection float-complex-blas-matrix }
{ $subsection double-complex-blas-matrix }
"Syntax words are provided for constructing literal vectors and matrices in the " { $vocab-link "math.blas.syntax" } " vocabulary:"
{ $subsection "math.blas.syntax" }
"There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:"
{ $subsection <float-blas-vector> }
{ $subsection <double-blas-vector> }
{ $subsection <float-complex-blas-vector> }
{ $subsection <double-complex-blas-vector> }
{ $subsection <float-blas-matrix> }
{ $subsection <double-blas-matrix> }
{ $subsection <float-complex-blas-matrix> }
{ $subsection <double-complex-blas-matrix> }
"For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:"
{ $subsection <empty-vector> }
{ $subsection <empty-matrix> } ;
ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
"Transposing and slicing matrices:"
{ $subsection Mtranspose }
{ $subsection Mrows }
{ $subsection Mcols }
{ $subsection Msub }
"Matrix-vector products:"
{ $subsection n*M.V+n*V-in-place }
{ $subsection n*M.V+n*V }
{ $subsection n*M.V }
{ $subsection M.V }
"Vector outer products:"
{ $subsection n*V(*)V+M-in-place }
{ $subsection n*V(*)Vconj+M-in-place }
{ $subsection n*V(*)V+M }
{ $subsection n*V(*)Vconj+M }
{ $subsection n*V(*)V }
{ $subsection n*V(*)Vconj }
{ $subsection V(*) }
{ $subsection V(*)conj }
"Matrix products:"
{ $subsection n*M.M+n*M-in-place }
{ $subsection n*M.M+n*M }
{ $subsection n*M.M }
{ $subsection M. }
"Scalar-matrix products:"
{ $subsection n*M-in-place }
{ $subsection n*M }
{ $subsection M*n }
{ $subsection M/n } ;
ABOUT: "math.blas.matrices"
HELP: blas-matrix-base
{ $class-description "The base class for all BLAS matrix types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:"
{ $list
{ { $link float-blas-matrix } }
{ { $link double-blas-matrix } }
{ { $link float-complex-blas-matrix } }
{ { $link double-complex-blas-matrix } }
}
"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 "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." }
} } ;
{ blas-vector-base blas-matrix-base } related-words
HELP: float-blas-matrix
{ $class-description "A matrix of single-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
HELP: double-blas-matrix
{ $class-description "A matrix of double-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
HELP: float-complex-blas-matrix
{ $class-description "A matrix of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
HELP: double-complex-blas-matrix
{ $class-description "A matrix of double-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
{
float-blas-matrix double-blas-matrix float-complex-blas-matrix double-complex-blas-matrix
float-blas-vector double-blas-vector float-complex-blas-vector double-complex-blas-vector
} related-words
HELP: Mwidth
{ $values { "matrix" "a BLAS matrix inherited from " { $link blas-matrix-base } } { "width" "The number of columns" } }
{ $description "Returns the number of columns in " { $snippet "matrix" } "." } ;
HELP: Mheight
{ $values { "matrix" "a BLAS matrix inherited from " { $link blas-matrix-base } } { "width" "The number of columns" } }
{ $description "Returns the number of rows in " { $snippet "matrix" } "." } ;
{ Mwidth Mheight } related-words
HELP: n*M.V+n*V-in-place
{ $values { "alpha" "a number" } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "beta" "a number" } { "y" "an M-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } ", and overwrite the current contents of " { $snippet "y" } " with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." }
{ $side-effects "y" } ;
HELP: n*V(*)V+M-in-place
{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGER and xGERU routines in BLAS." }
{ $side-effects "A" } ;
HELP: n*V(*)Vconj+M-in-place
{ $values { "alpha" "a number" } { "x" "an M-element complex BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element complex BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column complex BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGERC routines in BLAS." }
{ $side-effects "A" } ;
HELP: n*M.M+n*M-in-place
{ $values { "alpha" "a number" } { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "beta" "a number" } { "C" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." } ;
HELP: <empty-matrix>
{ $values { "rows" "the number of rows the new matrix will have" } { "cols" "the number of columns the new matrix will have" } { "exemplar" "A BLAS vector inherited from " { $link blas-vector-base } " or BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $description "Create a matrix of all zeros with the given dimensions and the same element type as " { $snippet "exemplar" } "." } ;
{ <zero-vector> <empty-vector> <empty-matrix> } related-words
HELP: n*M.V+n*V
{ $values { "alpha" "a number" } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "beta" "a number" } { "y" "an M-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". The returned vector will have the same length as " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." } ;
HELP: n*V(*)V+M
{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
HELP: n*V(*)Vconj+M
{ $values { "alpha" "a number" } { "x" "an M-element complex BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element complex BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column complex BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGERC routines in BLAS." } ;
HELP: n*M.M+n*M
{ $values { "alpha" "a number" } { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "beta" "a number" } { "C" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." } ;
HELP: n*M.V
{ $values { "alpha" "a number" } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $description "Calculate the matrix-vector product " { $snippet "αAx" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ;
HELP: M.V
{ $values { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $description "Calculate the matrix-vector product " { $snippet "Ax" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ;
{ n*M.V+n*V-in-place n*M.V+n*V n*M.V M.V } related-words
HELP: n*V(*)V
{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $description "Calculate the outer product " { $snippet "αx⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
HELP: n*V(*)Vconj
{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $description "Calculate the outer product " { $snippet "αx⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ;
HELP: V(*)
{ $values { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $description "Calculate the outer product " { $snippet "x⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
HELP: V(*)conj
{ $values { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $description "Calculate the conjugate outer product " { $snippet "x⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ;
{ n*V(*)V+M-in-place n*V(*)Vconj+M-in-place n*V(*)V+M n*V(*)Vconj+M n*V(*)V n*V(*)Vconj V(*) V(*)conj V. V.conj } related-words
HELP: n*M.M
{ $values { "alpha" "a number" } { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $description "Calculate the matrix product " { $snippet "αAB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ;
HELP: M.
{ $values { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $description "Calculate the matrix product " { $snippet "AB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ;
{ n*M.M+n*M-in-place n*M.M+n*M n*M.M M. } related-words
HELP: Msub
{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } { "row" "The topmost row of the slice" } { "col" "The leftmost column of the slice" } { "height" "The height of the slice" } { "width" "The width of the slice" } }
{ $description "Select a rectangular submatrix of " { $snippet "matrix" } " with the given dimensions. The returned submatrix will share the parent matrix's storage." } ;
HELP: Mrows
{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } }
{ $description "Return a sequence of BLAS vectors representing the rows of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ;
HELP: Mcols
{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } }
{ $description "Return a sequence of BLAS vectors representing the columns of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ;
HELP: n*M-in-place
{ $values { "n" "a number" } { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } }
{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and overwrite the current contents of A with the result." }
{ $side-effects "A" } ;
HELP: n*M
{ $values { "n" "a number" } { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } }
{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
HELP: M*n
{ $values { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } { "n" "a number" } }
{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
HELP: M/n
{ $values { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } { "n" "a number" } }
{ $description "Calculate the scalar-matrix product " { $snippet "(1/n)A" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
{ n*M-in-place n*M M*n M/n } related-words
HELP: Mtranspose
{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } }
{ $description "Returns the transpose of " { $snippet "matrix" } ". The returned matrix shares storage with the original matrix." } ;
HELP: element-type
{ $values { "v" "a BLAS vector inheriting from " { $link blas-vector-base } ", or a BLAS matrix inheriting from " { $link blas-matrix-base } } }
{ $description "Return the C type of the elements in the given BLAS vector or matrix." } ;
HELP: <empty-vector>
{ $values { "length" "The length of the new vector" } { "exemplar" "a BLAS vector inheriting from " { $link blas-vector-base } ", or a BLAS matrix inheriting from " { $link blas-matrix-base } } }
{ $description "Return a vector of zeros with the given length and the same element type as " { $snippet "v" } "." } ;

710
extra/math/blas/matrices/matrices-tests.factor Normal file
View File

@ -0,0 +1,710 @@
USING: kernel math.blas.matrices math.blas.vectors math.blas.syntax
sequences tools.test ;
IN: math.blas.matrices.tests
! clone
[ smatrix{
{ 1.0 2.0 3.0 }
{ 4.0 5.0 6.0 }
{ 7.0 8.0 9.0 }
} ] [
smatrix{
{ 1.0 2.0 3.0 }
{ 4.0 5.0 6.0 }
{ 7.0 8.0 9.0 }
} clone
] unit-test
[ f ] [
smatrix{
{ 1.0 2.0 3.0 }
{ 4.0 5.0 6.0 }
{ 7.0 8.0 9.0 }
} dup clone eq?
] unit-test
[ dmatrix{
{ 1.0 2.0 3.0 }
{ 4.0 5.0 6.0 }
{ 7.0 8.0 9.0 }
} ] [
dmatrix{
{ 1.0 2.0 3.0 }
{ 4.0 5.0 6.0 }
{ 7.0 8.0 9.0 }
} clone
] unit-test
[ f ] [
dmatrix{
{ 1.0 2.0 3.0 }
{ 4.0 5.0 6.0 }
{ 7.0 8.0 9.0 }
} dup clone eq?
] unit-test
[ cmatrix{
{ C{ 1.0 1.0 } 2.0 3.0 }
{ 4.0 C{ 5.0 2.0 } 6.0 }
{ 7.0 8.0 C{ 9.0 3.0 } }
} ] [
cmatrix{
{ C{ 1.0 1.0 } 2.0 3.0 }
{ 4.0 C{ 5.0 2.0 } 6.0 }
{ 7.0 8.0 C{ 9.0 3.0 } }
} clone
] unit-test
[ f ] [
cmatrix{
{ C{ 1.0 1.0 } 2.0 3.0 }
{ 4.0 C{ 5.0 2.0 } 6.0 }
{ 7.0 8.0 C{ 9.0 3.0 } }
} dup clone eq?
] unit-test
[ zmatrix{
{ C{ 1.0 1.0 } 2.0 3.0 }
{ 4.0 C{ 5.0 2.0 } 6.0 }
{ 7.0 8.0 C{ 9.0 3.0 } }
} ] [
zmatrix{
{ C{ 1.0 1.0 } 2.0 3.0 }
{ 4.0 C{ 5.0 2.0 } 6.0 }
{ 7.0 8.0 C{ 9.0 3.0 } }
} clone
] unit-test
[ f ] [
zmatrix{
{ C{ 1.0 1.0 } 2.0 3.0 }
{ 4.0 C{ 5.0 2.0 } 6.0 }
{ 7.0 8.0 C{ 9.0 3.0 } }
} dup clone eq?
] unit-test
! M.V
[ svector{ 3.0 1.0 6.0 } ] [
smatrix{
{ 0.0 1.0 0.0 1.0 }
{ -1.0 0.0 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
}
svector{ 1.0 2.0 3.0 1.0 }
M.V
] unit-test
[ svector{ -2.0 1.0 3.0 14.0 } ] [
smatrix{
{ 0.0 1.0 0.0 1.0 }
{ -1.0 0.0 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
} Mtranspose
svector{ 1.0 2.0 3.0 }
M.V
] unit-test
[ dvector{ 3.0 1.0 6.0 } ] [
dmatrix{
{ 0.0 1.0 0.0 1.0 }
{ -1.0 0.0 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
}
dvector{ 1.0 2.0 3.0 1.0 }
M.V
] unit-test
[ dvector{ -2.0 1.0 3.0 14.0 } ] [
dmatrix{
{ 0.0 1.0 0.0 1.0 }
{ -1.0 0.0 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
} Mtranspose
dvector{ 1.0 2.0 3.0 }
M.V
] unit-test
[ cvector{ 3.0 C{ 1.0 2.0 } 6.0 } ] [
cmatrix{
{ 0.0 1.0 0.0 1.0 }
{ -1.0 C{ 0.0 1.0 } 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
}
cvector{ 1.0 2.0 3.0 1.0 }
M.V
] unit-test
[ cvector{ -2.0 C{ 1.0 2.0 } 3.0 14.0 } ] [
cmatrix{
{ 0.0 1.0 0.0 1.0 }
{ -1.0 C{ 0.0 1.0 } 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
} Mtranspose
cvector{ 1.0 2.0 3.0 }
M.V
] unit-test
[ zvector{ 3.0 C{ 1.0 2.0 } 6.0 } ] [
zmatrix{
{ 0.0 1.0 0.0 1.0 }
{ -1.0 C{ 0.0 1.0 } 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
}
zvector{ 1.0 2.0 3.0 1.0 }
M.V
] unit-test
[ zvector{ -2.0 C{ 1.0 2.0 } 3.0 14.0 } ] [
zmatrix{
{ 0.0 1.0 0.0 1.0 }
{ -1.0 C{ 0.0 1.0 } 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
} Mtranspose
zvector{ 1.0 2.0 3.0 }
M.V
] unit-test
! V(*)
[ smatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 4.0 6.0 8.0 }
{ 3.0 6.0 9.0 12.0 }
} ] [
svector{ 1.0 2.0 3.0 } svector{ 1.0 2.0 3.0 4.0 } V(*)
] unit-test
[ dmatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 4.0 6.0 8.0 }
{ 3.0 6.0 9.0 12.0 }
} ] [
dvector{ 1.0 2.0 3.0 } dvector{ 1.0 2.0 3.0 4.0 } V(*)
] unit-test
[ cmatrix{
{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 }
{ 2.0 4.0 C{ 6.0 -6.0 } 8.0 }
{ C{ 3.0 3.0 } C{ 6.0 6.0 } 18.0 C{ 12.0 12.0 } }
} ] [
cvector{ 1.0 2.0 C{ 3.0 3.0 } } cvector{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 } V(*)
] unit-test
[ zmatrix{
{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 }
{ 2.0 4.0 C{ 6.0 -6.0 } 8.0 }
{ C{ 3.0 3.0 } C{ 6.0 6.0 } 18.0 C{ 12.0 12.0 } }
} ] [
zvector{ 1.0 2.0 C{ 3.0 3.0 } } zvector{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 } V(*)
] unit-test
! M.
[ smatrix{
{ 1.0 0.0 0.0 4.0 0.0 }
{ 0.0 0.0 -3.0 0.0 0.0 }
{ 0.0 4.0 0.0 0.0 10.0 }
{ 0.0 0.0 0.0 0.0 0.0 }
} ] [
smatrix{
{ 1.0 0.0 0.0 }
{ 0.0 0.0 -1.0 }
{ 0.0 2.0 0.0 }
{ 0.0 0.0 0.0 }
} smatrix{
{ 1.0 0.0 0.0 4.0 0.0 }
{ 0.0 2.0 0.0 0.0 5.0 }
{ 0.0 0.0 3.0 0.0 0.0 }
} M.
] unit-test
[ smatrix{
{ 1.0 0.0 0.0 0.0 }
{ 0.0 0.0 4.0 0.0 }
{ 0.0 -3.0 0.0 0.0 }
{ 4.0 0.0 0.0 0.0 }
{ 0.0 0.0 10.0 0.0 }
} ] [
smatrix{
{ 1.0 0.0 0.0 4.0 0.0 }
{ 0.0 2.0 0.0 0.0 5.0 }
{ 0.0 0.0 3.0 0.0 0.0 }
} Mtranspose smatrix{
{ 1.0 0.0 0.0 }
{ 0.0 0.0 -1.0 }
{ 0.0 2.0 0.0 }
{ 0.0 0.0 0.0 }
} Mtranspose M.
] unit-test
[ dmatrix{
{ 1.0 0.0 0.0 4.0 0.0 }
{ 0.0 0.0 -3.0 0.0 0.0 }
{ 0.0 4.0 0.0 0.0 10.0 }
{ 0.0 0.0 0.0 0.0 0.0 }
} ] [
dmatrix{
{ 1.0 0.0 0.0 }
{ 0.0 0.0 -1.0 }
{ 0.0 2.0 0.0 }
{ 0.0 0.0 0.0 }
} dmatrix{
{ 1.0 0.0 0.0 4.0 0.0 }
{ 0.0 2.0 0.0 0.0 5.0 }
{ 0.0 0.0 3.0 0.0 0.0 }
} M.
] unit-test
[ dmatrix{
{ 1.0 0.0 0.0 0.0 }
{ 0.0 0.0 4.0 0.0 }
{ 0.0 -3.0 0.0 0.0 }
{ 4.0 0.0 0.0 0.0 }
{ 0.0 0.0 10.0 0.0 }
} ] [
dmatrix{
{ 1.0 0.0 0.0 4.0 0.0 }
{ 0.0 2.0 0.0 0.0 5.0 }
{ 0.0 0.0 3.0 0.0 0.0 }
} Mtranspose dmatrix{
{ 1.0 0.0 0.0 }
{ 0.0 0.0 -1.0 }
{ 0.0 2.0 0.0 }
{ 0.0 0.0 0.0 }
} Mtranspose M.
] unit-test
[ cmatrix{
{ 1.0 0.0 0.0 4.0 0.0 }
{ 0.0 0.0 -3.0 0.0 0.0 }
{ 0.0 C{ 4.0 -4.0 } 0.0 0.0 10.0 }
{ 0.0 0.0 0.0 0.0 0.0 }
} ] [
cmatrix{
{ 1.0 0.0 0.0 }
{ 0.0 0.0 -1.0 }
{ 0.0 2.0 0.0 }
{ 0.0 0.0 0.0 }
} cmatrix{
{ 1.0 0.0 0.0 4.0 0.0 }
{ 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
{ 0.0 0.0 3.0 0.0 0.0 }
} M.
] unit-test
[ cmatrix{
{ 1.0 0.0 0.0 0.0 }
{ 0.0 0.0 C{ 4.0 -4.0 } 0.0 }
{ 0.0 -3.0 0.0 0.0 }
{ 4.0 0.0 0.0 0.0 }
{ 0.0 0.0 10.0 0.0 }
} ] [
cmatrix{
{ 1.0 0.0 0.0 4.0 0.0 }
{ 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
{ 0.0 0.0 3.0 0.0 0.0 }
} Mtranspose cmatrix{
{ 1.0 0.0 0.0 }
{ 0.0 0.0 -1.0 }
{ 0.0 2.0 0.0 }
{ 0.0 0.0 0.0 }
} Mtranspose M.
] unit-test
[ zmatrix{
{ 1.0 0.0 0.0 4.0 0.0 }
{ 0.0 0.0 -3.0 0.0 0.0 }
{ 0.0 C{ 4.0 -4.0 } 0.0 0.0 10.0 }
{ 0.0 0.0 0.0 0.0 0.0 }
} ] [
zmatrix{
{ 1.0 0.0 0.0 }
{ 0.0 0.0 -1.0 }
{ 0.0 2.0 0.0 }
{ 0.0 0.0 0.0 }
} zmatrix{
{ 1.0 0.0 0.0 4.0 0.0 }
{ 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
{ 0.0 0.0 3.0 0.0 0.0 }
} M.
] unit-test
[ zmatrix{
{ 1.0 0.0 0.0 0.0 }
{ 0.0 0.0 C{ 4.0 -4.0 } 0.0 }
{ 0.0 -3.0 0.0 0.0 }
{ 4.0 0.0 0.0 0.0 }
{ 0.0 0.0 10.0 0.0 }
} ] [
zmatrix{
{ 1.0 0.0 0.0 4.0 0.0 }
{ 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
{ 0.0 0.0 3.0 0.0 0.0 }
} Mtranspose zmatrix{
{ 1.0 0.0 0.0 }
{ 0.0 0.0 -1.0 }
{ 0.0 2.0 0.0 }
{ 0.0 0.0 0.0 }
} Mtranspose M.
] unit-test
! n*M
[ smatrix{
{ 2.0 0.0 }
{ 0.0 2.0 }
} ] [
2.0 smatrix{
{ 1.0 0.0 }
{ 0.0 1.0 }
} n*M
] unit-test
[ dmatrix{
{ 2.0 0.0 }
{ 0.0 2.0 }
} ] [
2.0 dmatrix{
{ 1.0 0.0 }
{ 0.0 1.0 }
} n*M
] unit-test
[ cmatrix{
{ C{ 2.0 1.0 } 0.0 }
{ 0.0 C{ -1.0 2.0 } }
} ] [
C{ 2.0 1.0 } cmatrix{
{ 1.0 0.0 }
{ 0.0 C{ 0.0 1.0 } }
} n*M
] unit-test
[ zmatrix{
{ C{ 2.0 1.0 } 0.0 }
{ 0.0 C{ -1.0 2.0 } }
} ] [
C{ 2.0 1.0 } zmatrix{
{ 1.0 0.0 }
{ 0.0 C{ 0.0 1.0 } }
} n*M
] unit-test
! Mrows, Mcols
[ svector{ 3.0 3.0 3.0 } ] [
2 smatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mcols nth
] unit-test
[ svector{ 3.0 2.0 3.0 4.0 } ] [
2 smatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mrows nth
] unit-test
[ 3 ] [
smatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mrows length
] unit-test
[ 4 ] [
smatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mcols length
] unit-test
[ svector{ 3.0 3.0 3.0 } ] [
2 smatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mtranspose Mrows nth
] unit-test
[ svector{ 3.0 2.0 3.0 4.0 } ] [
2 smatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mtranspose Mcols nth
] unit-test
[ 3 ] [
smatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mtranspose Mcols length
] unit-test
[ 4 ] [
smatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mtranspose Mrows length
] unit-test
[ dvector{ 3.0 3.0 3.0 } ] [
2 dmatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mcols nth
] unit-test
[ dvector{ 3.0 2.0 3.0 4.0 } ] [
2 dmatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mrows nth
] unit-test
[ 3 ] [
dmatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mrows length
] unit-test
[ 4 ] [
dmatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mcols length
] unit-test
[ dvector{ 3.0 3.0 3.0 } ] [
2 dmatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mtranspose Mrows nth
] unit-test
[ dvector{ 3.0 2.0 3.0 4.0 } ] [
2 dmatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mtranspose Mcols nth
] unit-test
[ 3 ] [
dmatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mtranspose Mcols length
] unit-test
[ 4 ] [
dmatrix{
{ 1.0 2.0 3.0 4.0 }
{ 2.0 2.0 3.0 4.0 }
{ 3.0 2.0 3.0 4.0 }
} Mtranspose Mrows length
] unit-test
[ cvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
2 cmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mcols nth
] unit-test
[ cvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
2 cmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mrows nth
] unit-test
[ 3 ] [
cmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mrows length
] unit-test
[ 4 ] [
cmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mcols length
] unit-test
[ cvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
2 cmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mtranspose Mrows nth
] unit-test
[ cvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
2 cmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mtranspose Mcols nth
] unit-test
[ 3 ] [
cmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mtranspose Mcols length
] unit-test
[ 4 ] [
cmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mtranspose Mrows length
] unit-test
[ zvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
2 zmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mcols nth
] unit-test
[ zvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
2 zmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mrows nth
] unit-test
[ 3 ] [
zmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mrows length
] unit-test
[ 4 ] [
zmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mcols length
] unit-test
[ zvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
2 zmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mtranspose Mrows nth
] unit-test
[ zvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
2 zmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mtranspose Mcols nth
] unit-test
[ 3 ] [
zmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mtranspose Mcols length
] unit-test
[ 4 ] [
zmatrix{
{ C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
{ C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
} Mtranspose Mrows length
] unit-test
! Msub
[ smatrix{
{ 3.0 2.0 1.0 }
{ 0.0 1.0 0.0 }
} ] [
smatrix{
{ 0.0 1.0 2.0 3.0 2.0 }
{ 1.0 0.0 3.0 2.0 1.0 }
{ 2.0 3.0 0.0 1.0 0.0 }
} 1 2 2 3 Msub
] unit-test
[ smatrix{
{ 3.0 0.0 }
{ 2.0 1.0 }
{ 1.0 0.0 }
} ] [
smatrix{
{ 0.0 1.0 2.0 3.0 2.0 }
{ 1.0 0.0 3.0 2.0 1.0 }
{ 2.0 3.0 0.0 1.0 0.0 }
} Mtranspose 2 1 3 2 Msub
] unit-test
[ dmatrix{
{ 3.0 2.0 1.0 }
{ 0.0 1.0 0.0 }
} ] [
dmatrix{
{ 0.0 1.0 2.0 3.0 2.0 }
{ 1.0 0.0 3.0 2.0 1.0 }
{ 2.0 3.0 0.0 1.0 0.0 }
} 1 2 2 3 Msub
] unit-test
[ dmatrix{
{ 3.0 0.0 }
{ 2.0 1.0 }
{ 1.0 0.0 }
} ] [
dmatrix{
{ 0.0 1.0 2.0 3.0 2.0 }
{ 1.0 0.0 3.0 2.0 1.0 }
{ 2.0 3.0 0.0 1.0 0.0 }
} Mtranspose 2 1 3 2 Msub
] unit-test
[ cmatrix{
{ C{ 3.0 3.0 } 2.0 1.0 }
{ 0.0 1.0 0.0 }
} ] [
cmatrix{
{ 0.0 1.0 2.0 3.0 2.0 }
{ 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
{ 2.0 3.0 0.0 1.0 0.0 }
} 1 2 2 3 Msub
] unit-test
[ cmatrix{
{ C{ 3.0 3.0 } 0.0 }
{ 2.0 1.0 }
{ 1.0 0.0 }
} ] [
cmatrix{
{ 0.0 1.0 2.0 3.0 2.0 }
{ 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
{ 2.0 3.0 0.0 1.0 0.0 }
} Mtranspose 2 1 3 2 Msub
] unit-test
[ zmatrix{
{ C{ 3.0 3.0 } 2.0 1.0 }
{ 0.0 1.0 0.0 }
} ] [
zmatrix{
{ 0.0 1.0 2.0 3.0 2.0 }
{ 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
{ 2.0 3.0 0.0 1.0 0.0 }
} 1 2 2 3 Msub
] unit-test
[ zmatrix{
{ C{ 3.0 3.0 } 0.0 }
{ 2.0 1.0 }
{ 1.0 0.0 }
} ] [
zmatrix{
{ 0.0 1.0 2.0 3.0 2.0 }
{ 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
{ 2.0 3.0 0.0 1.0 0.0 }
} Mtranspose 2 1 3 2 Msub
] unit-test

306
extra/math/blas/matrices/matrices.factor Executable file
View File

@ -0,0 +1,306 @@
USING: accessors alien alien.c-types arrays byte-arrays combinators
combinators.lib 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 ;
QUALIFIED: syntax
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" ;
: Mtransposed? ( matrix -- ? )
transpose>> ; inline
: Mwidth ( matrix -- width )
dup Mtransposed? [ rows>> ] [ cols>> ] if ; inline
: Mheight ( matrix -- height )
dup Mtransposed? [ cols>> ] [ rows>> ] if ; inline
<PRIVATE
: (blas-transpose) ( matrix -- integer )
transpose>> [ CblasTrans ] [ CblasNoTrans ] if ;
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 ;
:: (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 ld>>
x data>>
x inc>>
beta >c-arg call
y data>>
y inc>>
y ; inline
: (validate-ger) ( x y A -- )
{
[ nip [ length>> ] [ Mheight ] bi* = ]
[ nipd [ length>> ] [ Mwidth ] bi* = ]
} 3&&
[ "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 )
x y A (validate-ger)
CblasColMajor
A rows>>
A cols>>
alpha >c-arg call
x data>>
x inc>>
y data>>
y inc>>
A data>>
A ld>>
A f >>transpose ; inline
: (validate-gemm) ( A B C -- )
{
[ drop [ Mwidth ] [ Mheight ] bi* = ]
[ nip [ Mheight ] bi@ = ]
[ nipd [ Mwidth ] bi@ = ]
} 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 )
A B C (validate-gemm)
CblasColMajor
A (blas-transpose)
B (blas-transpose)
C rows>>
C cols>>
A Mwidth
alpha >c-arg call
A data>>
A ld>>
B data>>
B ld>>
beta >c-arg call
C data>>
C ld>>
C f >>transpose ; inline
: (>matrix) ( arrays >c-array -- c-array ld rows cols transpose )
'[ <merged> @ ] [ length dup ] [ first length ] tri f ; inline
PRIVATE>
: >float-blas-matrix ( arrays -- matrix )
[ >c-float-array ] (>matrix) <float-blas-matrix> ;
: >double-blas-matrix ( arrays -- matrix )
[ >c-double-array ] (>matrix) <double-blas-matrix> ;
: >float-complex-blas-matrix ( arrays -- matrix )
[ (flatten-complex-sequence) >c-float-array ] (>matrix)
<float-complex-blas-matrix> ;
: >double-complex-blas-matrix ( arrays -- matrix )
[ (flatten-complex-sequence) >c-double-array ] (>matrix)
<double-complex-blas-matrix> ;
GENERIC: n*M.V+n*V-in-place ( alpha A x beta y -- y=alpha*A.x+b*y )
GENERIC: n*V(*)V+M-in-place ( alpha x y A -- A=alpha*x(*)y+A )
GENERIC: n*V(*)Vconj+M-in-place ( alpha x y A -- A=alpha*x(*)yconj+A )
GENERIC: n*M.M+n*M-in-place ( alpha A B beta C -- C=alpha*A.B+beta*C )
METHOD: n*M.V+n*V-in-place { real float-blas-matrix float-blas-vector real float-blas-vector }
[ ] (prepare-gemv) [ cblas_sgemv ] dip ;
METHOD: n*M.V+n*V-in-place { real double-blas-matrix double-blas-vector real double-blas-vector }
[ ] (prepare-gemv) [ cblas_dgemv ] dip ;
METHOD: n*M.V+n*V-in-place { 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-in-place { 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-in-place { real float-blas-vector float-blas-vector float-blas-matrix }
[ ] (prepare-ger) [ cblas_sger ] dip ;
METHOD: n*V(*)V+M-in-place { real double-blas-vector double-blas-vector double-blas-matrix }
[ ] (prepare-ger) [ cblas_dger ] dip ;
METHOD: n*V(*)V+M-in-place { 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-in-place { 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-in-place { 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-in-place { 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-in-place { real float-blas-matrix float-blas-matrix real float-blas-matrix }
[ ] (prepare-gemm) [ cblas_sgemm ] dip ;
METHOD: n*M.M+n*M-in-place { real double-blas-matrix double-blas-matrix real double-blas-matrix }
[ ] (prepare-gemm) [ cblas_dgemm ] dip ;
METHOD: n*M.M+n*M-in-place { 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-in-place { 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
[
[
{ data>> ld>> cols>> element-type } get-slots
heap-size * * memory>byte-array
] [ { ld>> rows>> cols>> transpose>> } get-slots ] bi
] keep (blas-matrix-like) ;
! XXX try rounding stride to next 128 bit bound for better vectorizin'
: <empty-matrix> ( rows cols exemplar -- matrix )
[ element-type [ * ] dip <c-array> ]
[ 2drop ]
[ f swap (blas-matrix-like) ] 3tri ;
: n*M.V+n*V ( alpha A x beta y -- alpha*A.x+b*y )
clone n*M.V+n*V-in-place ;
: n*V(*)V+M ( alpha x y A -- alpha*x(*)y+A )
clone n*V(*)V+M-in-place ;
: n*V(*)Vconj+M ( alpha x y A -- alpha*x(*)yconj+A )
clone n*V(*)Vconj+M-in-place ;
: n*M.M+n*M ( alpha A B beta C -- alpha*A.B+beta*C )
clone n*M.M+n*M-in-place ;
: n*M.V ( alpha A x -- alpha*A.x )
1.0 2over [ Mheight ] dip <empty-vector>
n*M.V+n*V-in-place ; inline
: M.V ( A x -- A.x )
1.0 -rot n*M.V ; inline
: n*V(*)V ( n x y -- n*x(*)y )
2dup [ length>> ] bi@ pick <empty-matrix>
n*V(*)V+M-in-place ;
: n*V(*)Vconj ( n x y -- n*x(*)yconj )
2dup [ length>> ] bi@ pick <empty-matrix>
n*V(*)Vconj+M-in-place ;
: V(*) ( x y -- x(*)y )
1.0 -rot n*V(*)V ; inline
: V(*)conj ( x y -- x(*)yconj )
1.0 -rot n*V(*)Vconj ; inline
: n*M.M ( n A B -- n*A.B )
2dup [ Mheight ] [ Mwidth ] bi* pick <empty-matrix>
1.0 swap n*M.M+n*M-in-place ;
: M. ( A B -- A.B )
1.0 -rot n*M.M ; inline
:: (Msub) ( matrix row col height width -- data ld rows cols )
matrix ld>> col * row + matrix element-type heap-size *
matrix data>> <displaced-alien>
matrix ld>>
height
width ;
: Msub ( matrix row col height width -- submatrix )
5 npick dup transpose>>
[ nip [ [ swap ] 2dip swap ] when (Msub) ] 2keep
swap (blas-matrix-like) ;
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
length>> ;
syntax:M: blas-matrix-rowcol-sequence nth-unsafe
{
[
[ rowcol-jump>> ]
[ parent>> element-type heap-size ]
[ parent>> data>> ] tri
[ * * ] dip <displaced-alien>
]
[ rowcol-length>> ]
[ inc>> ]
[ parent>> ]
} cleave (blas-vector-like) ;
: (Mcols) ( A -- columns )
{ [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] } cleave
<blas-matrix-rowcol-sequence> ;
: (Mrows) ( A -- rows )
{ [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] } cleave
<blas-matrix-rowcol-sequence> ;
: Mrows ( A -- rows )
dup transpose>> [ (Mcols) ] [ (Mrows) ] if ;
: Mcols ( A -- rows )
dup transpose>> [ (Mrows) ] [ (Mcols) ] if ;
: n*M-in-place ( n A -- A=n*A )
[ (Mcols) [ n*V-in-place drop ] with each ] keep ;
: n*M ( n A -- n*A )
clone n*M-in-place ; inline
: M*n ( A n -- A*n )
swap n*M ; inline
: M/n ( A n -- A/n )
recip swap n*M ; inline
: Mtranspose ( matrix -- matrix^T )
[ { data>> ld>> rows>> cols>> transpose>> } get-slots not ] keep (blas-matrix-like) ;
syntax:M: blas-matrix-base equal?
{
[ [ Mwidth ] bi@ = ]
[ [ Mcols ] bi@ [ = ] 2all? ]
} 2&& ;

1
extra/math/blas/matrices/summary.txt Normal file
View File

@ -0,0 +1 @@
BLAS level 2 and 3 matrix-vector and matrix-matrix operations

2
extra/math/blas/matrices/tags.txt Normal file
View File

@ -0,0 +1,2 @@
math
bindings

1
extra/math/blas/syntax/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

Some files were not shown because too many files have changed in this diff Show More