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

Makefile

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

core/alien/alien-tests.factor

@@ -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

core/alien/c-types/c-types.factor

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

core/bootstrap/image/image.factor

@@ -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 ;
 

core/bootstrap/primitives.factor

@@ -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

core/classes/algebra/algebra-tests.factor

@@ -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

core/classes/algebra/algebra.factor

@@ -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
+USING: kernel classes combinators accessors sequences arrays
-sequences arrays vectors assocs namespaces words sorting layouts
+vectors assocs namespaces words sorting layouts math hashtables
-math hashtables kernel.private sets math.order ;
+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)
+GENERIC: (flatten-class) ( class -- )
-DEFER: flatten-builtin-class
 
-: flatten-intersection-class ( class -- )
+M: anonymous-union (flatten-class)
-    participants [ flatten-builtin-class ] map
+    members>> [ (flatten-class) ] each ;
-    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 ;
 
 : 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 ;

core/classes/builtin/builtin.factor

@@ -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
+USING: accessors classes classes.algebra words kernel
-sequences math math.private ;
+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 ;

core/classes/classes-docs.factor

@@ -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." } ;
 

core/classes/classes.factor

@@ -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 )

core/classes/intersection/intersection.factor

@@ -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) ;

core/classes/predicate/predicate.factor

@@ -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
+USING: classes classes.algebra kernel namespaces words sequences
-arrays kernel.private assocs combinators ;
+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? ;

core/classes/tuple/tuple-docs.factor

@@ -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." }

core/classes/tuple/tuple-tests.factor

@@ -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 ;
 

core/classes/tuple/tuple.factor

@@ -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
+classes.builtin classes.private slots.deprecated slots.private
-compiler.units math.private accessors assocs effects ;
+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 ]

core/classes/union/union.factor

@@ -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) ;

core/compiler/tests/reload.factor

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

core/cpu/x86/32/bootstrap.factor

@@ -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 ;
 

core/cpu/x86/64/64.factor

@@ -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 )

core/cpu/x86/64/bootstrap.factor

@@ -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 ;
 

core/cpu/x86/bootstrap.factor

@@ -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

core/debugger/debugger.factor

@@ -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 -- )

core/generator/generator.factor

@@ -13,11 +13,12 @@ SYMBOL: compiled
 
 : queue-compile ( word -- )
     {
-        { [ dup compiled get key? ] [ drop ] }
+        { [ dup "forgotten" word-prop ] [ ] }
-        { [ dup inlined-block? ] [ drop ] }
+        { [ dup compiled get key? ] [ ] }
-        { [ dup primitive? ] [ drop ] }
+        { [ dup inlined-block? ] [ ] }
-        [ compile-queue get push-front ]
+        { [ dup primitive? ] [ ] }
-    } cond ;
+        [ 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

core/generator/registers/registers.factor

@@ -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 ;
 

core/generic/generic-tests.factor

@@ -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
+quotations classes classes.algebra classes.tuple continuations
-classes.union sorting compiler.units ;
+layouts classes.union sorting compiler.units ;
 IN: generic.tests
 
 GENERIC: foobar ( x -- y )

core/generic/standard/engines/engines.factor

@@ -1,16 +1,16 @@
-USING: assocs kernel namespaces quotations generic math
+! Copyright (C) 2008 Slava Pestov.
-sequences combinators words classes.algebra ;
+! 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 ] ] }

core/generic/standard/engines/predicate/predicate.factor

@@ -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
+kernel.private sequences classes.algebra accessors words
-assocs ;
+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
+    methods-with-default
-    default get object bootstrap-word pick set-at engines>quots
+    engines>quots
-    sort-methods prune-redundant-predicates
+    sort-methods
-    class-predicates alist>quot ;
+    prune-redundant-predicates
+    class-predicates
+    alist>quot ;

core/generic/standard/engines/tag/tag.factor

@@ -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

core/generic/standard/engines/tuple/tuple.factor

@@ -80,15 +80,17 @@ M: engine-word irrelevant? drop t ;
 
 : array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
 
-: tuple-layout-superclasses ( obj -- array )
+: tuple-layout-superclasses% ( -- )
-    { tuple } declare
+    [
-    1 slot { tuple-layout } declare
+        { tuple } declare
-    4 slot { array } declare ; inline
+        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-layout-echelon% ( -- )
-    { tuple } declare
+    [
-    1 slot { tuple-layout } declare
+        { tuple } declare
-    5 slot ; inline
+        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? [

core/generic/standard/standard-tests.factor

@@ -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

core/generic/standard/standard.factor

@@ -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

core/io/streams/c/c.factor

@@ -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>

core/kernel/kernel.factor

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

core/math/intervals/intervals.factor

@@ -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

core/optimizer/inlining/inlining.factor

@@ -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 )
+: already-inlined? ( #call -- ? )
-    dup +inlined+ depends-on
+    [ param>> ] [ history>> ] bi memq? ;
-    dup def>> swap 1array splice-quot ;
 
 : optimistic-inline ( #call -- node )
-    dup node-param over node-history memq? [
+    dup already-inlined? [ drop t ] [
-        drop t
+        dup param>> dup def>> splice-word-def
-    ] [
-        dup node-param 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*
     {

core/optimizer/math/math.factor

@@ -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 }
 } [

core/optimizer/specializers/specializers.factor

@@ -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 } = [
+    specializer-cases alist>quot ;
-        drop tag-specializer
-    ] [
-        specializer-cases alist>quot
-    ] if ;
 
 : standard-method? ( method -- ? )
     dup method-body? [

core/sequences/sequences-docs.factor

@@ -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 } ":"
+"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 } "."
-{ $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\"" }
+$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"

core/sequences/sequences.factor

@@ -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 ;
 

core/slots/slots-docs.factor

@@ -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"

core/threads/threads.factor

@@ -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
+    H{ } clone 64 setenv
-    <dlist> 42 setenv
+    <dlist> 65 setenv
-    <min-heap> 43 setenv
+    <min-heap> 66 setenv
     initial-thread global
     [ drop f "Initial" <thread> ] cache
     <box> >>continuation

extra/alarms/alarms-docs.factor

@@ -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 } }

extra/alarms/alarms.factor

@@ -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? ;

extra/arrays/lib/authors.txt

@@ -1 +0,0 @@
-Eduardo Cavazos

extra/arrays/lib/lib.factor

@@ -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 ;

extra/arrays/lib/summary.txt

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

extra/arrays/lib/tags.txt

@@ -1 +0,0 @@
-collections

extra/bake/bake.factor

@@ -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
 

extra/bake/fry/fry-tests.factor

@@ -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
 

extra/benchmark/dispatch1/dispatch1.factor

@@ -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 )

extra/benchmark/dispatch5/dispatch5.factor

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

extra/bit-arrays/bit-arrays-tests.factor

@@ -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

extra/bit-arrays/bit-arrays.factor

@@ -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 ) 
+:: integer>bit-array ( n -- bit-array ) 
-    [ log2 1+ <bit-array> 0 ] keep
+    n zero? [ 0 <bit-array> ] [
-    [ dup zero? not ] [
+        [let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
-        [ -8 shift ] [ 255 bitand ] bi
+            [ n' zero? not ] [
-        -roll [ [ >r underlying>> r> set-alien-unsigned-1 ] 2keep 1+ ] dip
+                n' out underlying>> i 255 bitand set-alien-unsigned-1
-    ] [ ] while
+                n' -8 shift n'!
-    2drop ;
+                i 1+ i!
+            ] [ ] while
+            out
+        ]
+    ] if ;
 
 : bit-array>integer ( bit-array -- int )
     0 swap underlying>> [ length ] keep [

extra/bitfields/bitfields.factor

@@ -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:

extra/calendar/calendar.factor

@@ -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 )
+: days-in-month ( timestamp -- n )
-    first2 dup 2 = [
+    >date< drop (days-in-month) ;
-        drop leap-year? 29 28 ?
-    ] [
-        nip day-counts nth
-    ] if ;
 
-M: timestamp days-in-month ( timestamp -- n )
+: day-of-week ( timestamp -- n )
-    >date< drop 2array days-in-month ;
-
-GENERIC: day-of-week ( obj -- n )
-
-M: timestamp day-of-week ( timestamp -- n )
     >date< zeller-congruence ;
 
-M: array day-of-week ( array -- n )
+:: (day-of-year) ( year month day -- n )
-    first3 zeller-congruence ;
+    day-counts month head-slice sum day +
-
+    year leap-year? [
-GENERIC: day-of-year ( obj -- n )
+        year month day <date>
-
+        year 3 1 <date>
-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>
         after=? [ 1+ ] when
-    ] [
+    ] when ;
-        >r 3drop r>
-    ] if ;
 
-M: timestamp day-of-year ( timestamp -- n )
+: day-of-year ( timestamp -- n )
-    >date< 3array day-of-year ;
+    >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" ] }

extra/calendar/format/format.factor

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

extra/color-picker/color-picker.factor

@@ -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
+USING: kernel math math.functions math.parser models
-ui ui.gadgets ui.gadgets.frames
+models.filter models.range models.compose sequences ui
-ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders ui.render
+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.

extra/columns/columns-docs.factor

@@ -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 ;"

extra/combinators/cleave/cleave-tests.factor

@@ -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*
+

extra/combinators/cleave/cleave.factor

@@ -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

extra/combinators/lib/lib-docs.factor

@@ -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." } ;

extra/combinators/lib/lib-tests.factor

@@ -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

extra/combinators/lib/lib.factor

@@ -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
 

extra/combinators/short-circuit/short-circuit.factor

@@ -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 ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

extra/ctags/authors.txt

@@ -0,0 +1 @@
+Alfredo Beaumont

extra/ctags/ctags-docs.factor

@@ -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"

extra/ctags/ctags-tests.factor

@@ -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

extra/ctags/ctags.factor

@@ -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 ;

extra/ctags/summary.txt

@@ -0,0 +1 @@
+Ctags generator

extra/db/pools/pools-tests.factor

@@ -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

extra/db/tuples/tuples-tests.factor

@@ -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

extra/delegate/delegate.factor

@@ -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
+USING: accessors parser generic kernel classes classes.tuple
-sequences arrays vectors definitions prettyprint
+words slots assocs sequences arrays vectors definitions
-math hashtables sets macros namespaces ;
+prettyprint math hashtables sets macros namespaces ;
 IN: delegate
 
 : protocol-words ( protocol -- words )

extra/descriptive/descriptive.factor

@@ -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 ;

extra/furnace/auth/login/login.factor

@@ -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 ;

extra/furnace/cache/cache.factor

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

extra/furnace/sessions/sessions.factor

@@ -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' )

extra/generalizations/generalizations-docs.factor

@@ -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"

extra/generalizations/generalizations-tests.factor

@@ -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

extra/generalizations/generalizations.factor

@@ -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 ;

extra/html/parser/analyzer/analyzer.factor

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

extra/inverse/inverse.factor

@@ -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
 

extra/io/pools/pools.factor

@@ -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 ;
 

extra/io/unix/backend/backend.factor

@@ -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 -- )

extra/io/windows/files/files.factor

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

extra/io/windows/nt/backend/backend.factor

@@ -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 ;

extra/io/windows/privileges/privileges.factor

@@ -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

extra/koszul/koszul.factor

@@ -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
+        ] each-index
-    ] 2each ;
+    ] each-index ;

extra/lcd/lcd.factor

@@ -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
+calendar.model arrays models models.filter namespaces ui.gadgets
-ui.gadgets.labels
+ui.gadgets.labels ui.gadgets.theme ui ;
-ui.gadgets.theme ui ;
 IN: lcd
 
 : lcd-digit ( row digit -- str )

extra/logging/logging.factor

@@ -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
 

extra/math/blas/cblas/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/math/blas/cblas/cblas.factor

@@ -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 ) ;
+

extra/math/blas/cblas/summary.txt

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

extra/math/blas/cblas/tags.txt

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

extra/math/blas/matrices/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/math/blas/matrices/matrices-docs.factor

@@ -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" } "." } ;
+

extra/math/blas/matrices/matrices-tests.factor

@@ -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
+

extra/math/blas/matrices/matrices.factor

@@ -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&& ;
+

extra/math/blas/matrices/summary.txt

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

extra/math/blas/matrices/tags.txt

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

extra/math/blas/syntax/authors.txt

@@ -0,0 +1 @@
+Joe Groff