LD = ld
EXECUTABLE = factor
-VERSION = 0.91
+VERSION = 0.92
IMAGE = factor.image
BUNDLE = Factor.app
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 ;
[ 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
: c-bool> ( int -- ? )
zero? not ;
-: >c-array ( seq type word -- )
- >r >r dup length dup r> <c-array> dup -roll r>
- [ execute ] 2curry 2each ; inline
+: >c-array ( seq type word -- byte-array )
+ [ [ dup length ] dip <c-array> ] dip
+ [ [ execute ] 2curry each-index ] 2keep drop ; inline
: >c-array-quot ( type vocab -- quot )
dupd set-nth-word [ >c-array ] 2curry ;
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 )
: data-base 1024 ; inline
-: userenv-size 64 ; inline
+: userenv-size 70 ; inline
: header-size 10 ; inline
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
{ 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 ;
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 '
\ 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
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 ;
! 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.
{ "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
tools.test vectors words quotations classes classes.algebra\r
classes.private classes.union classes.mixin classes.predicate\r
vectors definitions source-files compiler.units growable\r
-random inference effects kernel.private sbufs math.order ;\r
+random inference effects kernel.private sbufs math.order\r
+classes.tuple ;\r
IN: classes.algebra.tests\r
\r
\ class< must-infer\r
generic-class flatten-class\r
] unit-test\r
\r
+[ \ + flatten-class ] must-fail\r
+\r
INTERSECTION: empty-intersection ;\r
\r
[ t ] [ object empty-intersection class<= ] unit-test\r
! Copyright (C) 2004, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel classes classes.builtin combinators accessors\r
-sequences arrays vectors assocs namespaces words sorting layouts\r
-math hashtables kernel.private sets math.order ;\r
+USING: kernel classes combinators accessors sequences arrays\r
+vectors assocs namespaces words sorting layouts math hashtables\r
+kernel.private sets math.order ;\r
IN: classes.algebra\r
\r
+TUPLE: anonymous-union members ;\r
+\r
+C: <anonymous-union> anonymous-union\r
+\r
+TUPLE: anonymous-intersection participants ;\r
+\r
+C: <anonymous-intersection> anonymous-intersection\r
+\r
+TUPLE: anonymous-complement class ;\r
+\r
+C: <anonymous-complement> anonymous-complement\r
+\r
: 2cache ( key1 key2 assoc quot -- value )\r
>r >r 2array r> [ first2 ] r> compose cache ; inline\r
\r
: class-not ( class -- complement )\r
class-not-cache get [ (class-not) ] cache ;\r
\r
-DEFER: (classes-intersect?) ( first second -- ? )\r
+GENERIC: (classes-intersect?) ( first second -- ? )\r
+\r
+: normalize-class ( class -- class' )\r
+ {\r
+ { [ dup members ] [ members <anonymous-union> ] }\r
+ { [ dup participants ] [ participants <anonymous-intersection> ] }\r
+ [ ]\r
+ } cond ;\r
\r
: classes-intersect? ( first second -- ? )\r
- classes-intersect-cache get [ (classes-intersect?) ] 2cache ;\r
+ classes-intersect-cache get [\r
+ normalize-class (classes-intersect?)\r
+ ] 2cache ;\r
\r
DEFER: (class-and)\r
\r
: class-or ( first second -- class )\r
class-or-cache get [ (class-or) ] 2cache ;\r
\r
-TUPLE: anonymous-union members ;\r
-\r
-C: <anonymous-union> anonymous-union\r
-\r
-TUPLE: anonymous-intersection participants ;\r
-\r
-C: <anonymous-intersection> anonymous-intersection\r
-\r
-TUPLE: anonymous-complement class ;\r
-\r
-C: <anonymous-complement> anonymous-complement\r
-\r
: superclass<= ( first second -- ? )\r
>r superclass r> class<= ;\r
\r
: anonymous-complement<= ( first second -- ? )\r
[ class>> ] bi@ swap class<= ;\r
\r
-: normalize-class ( class -- class' )\r
- {\r
- { [ dup members ] [ members <anonymous-union> ] }\r
- { [ dup participants ] [ participants <anonymous-intersection> ] }\r
- [ ]\r
- } cond ;\r
-\r
: normalize-complement ( class -- class' )\r
class>> normalize-class {\r
{ [ dup anonymous-union? ] [\r
} cond\r
] if ;\r
\r
-: anonymous-union-intersect? ( first second -- ? )\r
+M: anonymous-union (classes-intersect?)\r
members>> [ classes-intersect? ] with contains? ;\r
\r
-: anonymous-intersection-intersect? ( first second -- ? )\r
+M: anonymous-intersection (classes-intersect?)\r
participants>> [ classes-intersect? ] with all? ;\r
\r
-: anonymous-complement-intersect? ( first second -- ? )\r
+M: anonymous-complement (classes-intersect?)\r
class>> class<= not ;\r
\r
-: tuple-class-intersect? ( first second -- ? )\r
- {\r
- { [ over tuple eq? ] [ 2drop t ] }\r
- { [ over builtin-class? ] [ 2drop f ] }\r
- { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }\r
- [ swap classes-intersect? ]\r
- } cond ;\r
-\r
-: builtin-class-intersect? ( first second -- ? )\r
- {\r
- { [ 2dup eq? ] [ 2drop t ] }\r
- { [ over builtin-class? ] [ 2drop f ] }\r
- [ swap classes-intersect? ]\r
- } cond ;\r
-\r
-: (classes-intersect?) ( first second -- ? )\r
- normalize-class {\r
- { [ dup anonymous-union? ] [ anonymous-union-intersect? ] }\r
- { [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] }\r
- { [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] }\r
- { [ dup tuple-class? ] [ tuple-class-intersect? ] }\r
- { [ dup builtin-class? ] [ builtin-class-intersect? ] }\r
- { [ dup superclass ] [ superclass classes-intersect? ] }\r
- } cond ;\r
-\r
: anonymous-union-and ( first second -- class )\r
members>> [ class-and ] with map <anonymous-union> ;\r
\r
tuck [ class<= ] with all? [ peek ] [ drop f ] if\r
] if ;\r
\r
-DEFER: (flatten-class)\r
-DEFER: flatten-builtin-class\r
-\r
-: flatten-intersection-class ( class -- )\r
- participants [ flatten-builtin-class ] map\r
- dup empty? [\r
- drop builtins get [ (flatten-class) ] each\r
- ] [\r
- unclip [ assoc-intersect ] reduce [ swap set ] assoc-each\r
- ] if ;\r
+GENERIC: (flatten-class) ( class -- )\r
\r
-: (flatten-class) ( class -- )\r
- {\r
- { [ dup tuple-class? ] [ dup set ] }\r
- { [ dup builtin-class? ] [ dup set ] }\r
- { [ dup members ] [ members [ (flatten-class) ] each ] }\r
- { [ dup participants ] [ flatten-intersection-class ] }\r
- { [ dup superclass ] [ superclass (flatten-class) ] }\r
- [ drop ]\r
- } cond ;\r
+M: anonymous-union (flatten-class)\r
+ members>> [ (flatten-class) ] each ;\r
\r
: flatten-class ( class -- assoc )\r
[ (flatten-class) ] H{ } make-assoc ;\r
flatten-builtin-class keys\r
[ "type" word-prop ] map natural-sort ;\r
\r
-: class-tags ( class -- tag/f )\r
+: class-tags ( class -- seq )\r
class-types [\r
dup num-tags get >=\r
[ drop \ hi-tag tag-number ] when\r
] map prune ;\r
+\r
+: class-tag ( class -- tag/f )\r
+ class-tags dup length 1 = [ first ] [ drop f ] if ;\r
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes words kernel kernel.private namespaces
-sequences math math.private ;
+USING: accessors classes classes.algebra words kernel
+kernel.private namespaces sequences math math.private
+combinators assocs ;
IN: classes.builtin
SYMBOL: builtins
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 ;
{ $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." } ;
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 )
! 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
M: intersection-class instance?
"participants" word-prop [ instance? ] with all? ;
+
+M: intersection-class (flatten-class)
+ participants <anonymous-intersection> (flatten-class) ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes kernel namespaces words sequences quotations
-arrays kernel.private assocs combinators ;
+USING: classes classes.algebra kernel namespaces words sequences
+quotations arrays kernel.private assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class
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? ;
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." }
[ 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 ;
USING: arrays definitions hashtables kernel kernel.private math
namespaces sequences sequences.private strings vectors words
quotations memory combinators generic classes classes.algebra
-classes.private slots.deprecated slots.private slots
-compiler.units math.private accessors assocs effects ;
+classes.builtin classes.private slots.deprecated slots.private
+slots compiler.units math.private accessors assocs effects ;
IN: classes.tuple
+PREDICATE: tuple-class < class
+ "metaclass" word-prop tuple-class eq? ;
+
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: not-a-tuple object ;
: 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 )
: 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 )
: 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 ]
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 ;
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 ;
] 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 ]
! 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
M: union-class instance?
"members" word-prop [ instance? ] with contains? ;
+
+M: union-class (flatten-class)
+ members <anonymous-union> (flatten-class) ;
IN: compiler.tests
USE: vocabs.loader
-"parser" reload
-"sequences" reload
-"kernel" reload
+! "parser" reload
+! "sequences" reload
+! "kernel" reload
: 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 ;
: struct-types&offset ( struct-type -- pairs )
struct-type-fields [
- [ type>> ] [ offset>> ] bi 2array
+ [ class>> ] [ offset>> ] bi 2array
] map ;
: split-struct ( pairs -- seq )
: temp-reg ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
: ds-reg ( -- reg ) R14 ;
+: rs-reg ( -- reg ) R15 ;
: fixnum>slot@ ( -- ) ;
: rex-length ( -- n ) 1 ;
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
nl
"The following restarts are available:" print
nl
- dup length [ restart. ] 2each
+ [ restart. ] each-index
] if ;
: print-error ( error -- )
: queue-compile ( word -- )
{
- { [ dup compiled get key? ] [ drop ] }
- { [ dup inlined-block? ] [ drop ] }
- { [ dup primitive? ] [ drop ] }
- [ compile-queue get push-front ]
- } cond ;
+ { [ dup "forgotten" word-prop ] [ ] }
+ { [ dup compiled get key? ] [ ] }
+ { [ dup inlined-block? ] [ ] }
+ { [ dup primitive? ] [ ] }
+ [ dup compile-queue get push-front ]
+ } cond drop ;
: maybe-compile ( word -- )
dup compiled>> [ drop ] [ queue-compile ] if ;
! 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
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 ;
[ 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 ;
USING: accessors alien arrays definitions generic generic.standard
generic.math assocs hashtables io kernel math namespaces parser
prettyprint sequences strings tools.test vectors words
-quotations classes classes.algebra continuations layouts
-classes.union sorting compiler.units ;
+quotations classes classes.algebra classes.tuple continuations
+layouts classes.union sorting compiler.units ;
IN: generic.tests
GENERIC: foobar ( x -- y )
-USING: assocs kernel namespaces quotations generic math
-sequences combinators words classes.algebra ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel kernel.private namespaces quotations
+generic math sequences combinators words classes.algebra arrays
+;
IN: generic.standard.engines
SYMBOL: default
SYMBOL: assumed
+SYMBOL: (dispatch#)
GENERIC: engine>quot ( engine -- quot )
-M: quotation engine>quot ;
-
-M: method-body engine>quot 1quotation ;
-
: engines>quots ( assoc -- assoc' )
[ engine>quot ] assoc-map ;
: 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 )
r> execute r> pick set-at
] if ; inline
-SYMBOL: (dispatch#)
-
: (picker) ( n -- quot )
{
{ 0 [ [ dup ] ] }
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: generic.standard.engines generic namespaces kernel
-sequences classes.algebra accessors words combinators
-assocs ;
+kernel.private sequences classes.algebra accessors words
+combinators assocs arrays ;
IN: generic.standard.engines.predicate
TUPLE: predicate-dispatch-engine methods ;
: sort-methods ( assoc -- assoc' )
>alist [ keys sort-classes ] keep extract-keys ;
+: methods-with-default ( engine -- assoc )
+ methods>> clone default get object bootstrap-word pick set-at ;
+
M: predicate-dispatch-engine engine>quot
- methods>> clone
- default get object bootstrap-word pick set-at engines>quots
- sort-methods prune-redundant-predicates
- class-predicates alist>quot ;
+ methods-with-default
+ engines>quots
+ sort-methods
+ prune-redundant-predicates
+ class-predicates
+ alist>quot ;
"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
: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
-: tuple-layout-superclasses ( obj -- array )
- { tuple } declare
- 1 slot { tuple-layout } declare
- 4 slot { array } declare ; inline
+: tuple-layout-superclasses% ( -- )
+ [
+ { tuple } declare
+ 1 slot { tuple-layout } declare
+ 4 slot { array } declare
+ ] % ; inline
: tuple-dispatch-engine-body ( engine -- quot )
[
picker %
- [ tuple-layout-superclasses ] %
+ tuple-layout-superclasses%
[ n>> array-nth% ]
[
methods>> [
] [
[
picker %
- [ tuple-layout-superclasses ] %
+ tuple-layout-superclasses%
[ n>> array-nth% ]
[
methods>> [
: >=-case-quot ( alist -- quot )
default get [ drop ] prepend swap
- [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
+ [
+ [ [ dup ] swap [ fixnum>= ] curry compose ]
+ [ [ drop ] prepose ]
+ bi* [ ] like
+ ] assoc-map
alist>quot ;
-: tuple-layout-echelon ( obj -- array )
- { tuple } declare
- 1 slot { tuple-layout } declare
- 5 slot ; inline
+: tuple-layout-echelon% ( -- )
+ [
+ { tuple } declare
+ 1 slot { tuple-layout } declare
+ 5 slot
+ ] % ; inline
M: tuple-dispatch-engine engine>quot
[
picker %
- [ tuple-layout-echelon ] %
+ tuple-layout-echelon%
[
tuple assumed set
echelons>> dup empty? [
\ 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
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
{
] [ ] 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 # ;
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
M: hook-combination dispatch# drop 0 ;
+M: hook-combination method-declaration 2drop [ ] ;
+
M: hook-generic extra-values drop 1 ;
M: hook-generic effective-method
: stdin-handle 11 getenv ;
: stdout-handle 12 getenv ;
-: stderr-handle 38 getenv ;
+: stderr-handle 61 getenv ;
M: object (init-stdio)
stdin-handle <c-reader>
: 2keep ( x y quot -- x y ) 2over 2slip ; inline
-: 3keep ( x y z quot -- x y z )
- >r 3dup r> -roll 3slip ; inline
+: 3keep ( x y z quot -- x y z ) >r 3dup r> -roll 3slip ; inline
! Cleavers
: bi ( x p q -- )
! 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 } ;
: 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
: 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*
2drop f
] if ;
-: splice-word-def ( #call word -- node )
- dup +inlined+ depends-on
- dup def>> swap 1array splice-quot ;
+: already-inlined? ( #call -- ? )
+ [ param>> ] [ history>> ] bi memq? ;
: optimistic-inline ( #call -- node )
- dup node-param over node-history memq? [
- drop t
- ] [
- dup node-param splice-word-def
+ dup already-inlined? [ drop t ] [
+ dup param>> dup def>> splice-word-def
] if ;
: should-inline? ( word -- ? )
flat-length 11 <= ;
: method-body-inline? ( #call -- ? )
- node-param dup method-body? [ should-inline? ] [ drop f ] if ;
+ param>> dup [ method-body? ] [ "default" word-prop not ] bi and
+ [ should-inline? ] [ drop f ] if ;
M: #call optimize-node*
{
{ + { { 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 }
} [
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce\r
] if ;\r
\r
-: tag-specializer ( quot -- newquot )\r
- [\r
- [ dup tag ] %\r
- num-tags get swap <array> ,\r
- \ dispatch ,\r
- ] [ ] make ;\r
-\r
: specializer-cases ( quot word -- default alist )\r
dup [ array? ] all? [ 1array ] unless [\r
[ make-specializer ] keep\r
method-declaration [ declare ] curry prepend ;\r
\r
: specialize-quot ( quot specializer -- quot' )\r
- dup { number } = [\r
- drop tag-specializer\r
- ] [\r
- specializer-cases alist>quot\r
- ] if ;\r
+ specializer-cases alist>quot ;\r
\r
: standard-method? ( method -- ? )\r
dup method-body? [\r
$nl
"For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
{ $example "3 [ . ] each" "0\n1\n2" }
-"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link 2each } ":"
-{ $example "{ \"a\" \"b\" \"c\" } dup length [\n \"Index: \" write . \"Element: \" write .\n] 2each" "Index: 0\nElement: \"a\"\nIndex: 1\nElement: \"b\"\nIndex: 2\nElement: \"c\"" }
+"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
+$nl
"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ;
ARTICLE: "sequences-access" "Accessing sequence elements"
: 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 ;
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"
continuation state runnable
mailbox variables sleep-entry ;
-: self ( -- thread ) 40 getenv ; inline
+: self ( -- thread ) 63 getenv ; inline
! Thread-local storage
: tnamespace ( -- assoc )
: tchange ( key quot -- )
tnamespace swap change-at ; inline
-: threads 41 getenv ;
+: threads 64 getenv ;
: thread ( id -- thread ) threads at ;
: unregister-thread ( thread -- )
check-registered id>> threads delete-at ;
-: set-self ( thread -- ) 40 setenv ; inline
+: set-self ( thread -- ) 63 setenv ; inline
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
<PRIVATE
: init-threads ( -- )
- H{ } clone 41 setenv
- <dlist> 42 setenv
- <min-heap> 43 setenv
+ H{ } clone 64 setenv
+ <dlist> 65 setenv
+ <min-heap> 66 setenv
initial-thread global
[ drop f "Initial" <thread> ] cache
<box> >>continuation
\r
HELP: later\r
{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } }\r
-{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ;\r
+{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;\r
\r
HELP: cancel-alarm\r
{ $values { "alarm" alarm } }\r
<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? ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-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 ;
+++ /dev/null
-Non-core array words
+++ /dev/null
-collections
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
USING: tools.test math prettyprint kernel io arrays vectors sequences
- arrays.lib bake bake.fry ;
+ generalizations bake bake.fry ;
IN: bake.fry.tests
-USING: classes kernel sequences vocabs math ;
+USING: classes classes.tuple kernel sequences vocabs math ;
IN: benchmark.dispatch1
GENERIC: g ( obj -- obj )
-USING: classes kernel sequences vocabs math ;\r
+USING: classes classes.tuple kernel sequences vocabs math ;\r
IN: benchmark.dispatch5\r
\r
MIXIN: g\r
[ -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
[ ?{
] 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
! 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
: ?{ ( parsed -- parsed )
\ } [ >bit-array ] parse-literal ; parsing
-: integer>bit-array ( int -- bit-array )
- [ log2 1+ <bit-array> 0 ] keep
- [ dup zero? not ] [
- [ -8 shift ] [ 255 bitand ] bi
- -roll [ [ >r underlying>> r> set-alien-unsigned-1 ] 2keep 1+ ] dip
- ] [ ] while
- 2drop ;
+:: integer>bit-array ( n -- bit-array )
+ n zero? [ 0 <bit-array> ] [
+ [let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
+ [ n' zero? not ] [
+ n' out underlying>> i 255 bitand set-alien-unsigned-1
+ n' -8 shift n'!
+ i 1+ i!
+ ] [ ] while
+ out
+ ]
+ ] if ;
: bit-array>integer ( bit-array -- int )
0 swap underlying>> [ length ] keep [
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:
: 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
M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
-GENERIC: days-in-month ( obj -- n )
+: (days-in-month) ( year month -- n )
+ dup 2 = [ drop leap-year? 29 28 ? ] [ nip day-counts nth ] if ;
-M: array days-in-month ( obj -- n )
- first2 dup 2 = [
- drop leap-year? 29 28 ?
- ] [
- nip day-counts nth
- ] if ;
-
-M: timestamp days-in-month ( timestamp -- n )
- >date< drop 2array days-in-month ;
-
-GENERIC: day-of-week ( obj -- n )
+: days-in-month ( timestamp -- n )
+ >date< drop (days-in-month) ;
-M: timestamp day-of-week ( timestamp -- n )
+: day-of-week ( timestamp -- n )
>date< zeller-congruence ;
-M: array day-of-week ( array -- n )
- first3 zeller-congruence ;
-
-GENERIC: day-of-year ( obj -- n )
-
-M: array day-of-year ( array -- n )
- first3
- 3dup day-counts rot head-slice sum +
- swap leap-year? [
- -roll
- pick 3 1 <date> >r <date> r>
+:: (day-of-year) ( year month day -- n )
+ day-counts month head-slice sum day +
+ year leap-year? [
+ year month day <date>
+ year 3 1 <date>
after=? [ 1+ ] when
- ] [
- >r 3drop r>
- ] if ;
+ ] when ;
-M: timestamp day-of-year ( timestamp -- n )
- >date< 3array day-of-year ;
+: day-of-year ( timestamp -- n )
+ >date< (day-of-year) ;
: day-offset ( timestamp m -- timestamp n )
over day-of-week - ; inline
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" ] }
\r
M: array month. ( pair -- )\r
first2\r
- [ month-names nth write bl number>string print ] 2keep\r
- [ 1 zeller-congruence ] 2keep\r
- 2array days-in-month day-abbreviations2 " " join print\r
+ [ month-names nth write bl number>string print ]\r
+ [ 1 zeller-congruence ]\r
+ [ (days-in-month) day-abbreviations2 " " join print ] 2tri\r
over " " <repetition> concat write\r
[\r
[ 1+ day. ] keep\r
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.parser models sequences
-ui ui.gadgets ui.gadgets.frames
-ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders ui.render
-;
+USING: kernel math math.functions math.parser models
+models.filter models.range models.compose sequences ui
+ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
+ui.gadgets.sliders ui.render ;
IN: color-picker
! Simple example demonstrating the use of models.
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 ;"
--- /dev/null
+
+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*
+
-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
"[ 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." } ;
[ 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
! 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
! 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
USING: kernel combinators quotations arrays sequences assocs
- locals shuffle macros fry ;
+ locals generalizations macros fry ;
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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+Alfredo Beaumont
--- /dev/null
+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"
\ No newline at end of file
--- /dev/null
+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
\ No newline at end of file
--- /dev/null
+! 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 ;
\ No newline at end of file
--- /dev/null
+Ctags generator
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
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
! ] 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
[ 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
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors parser generic kernel classes words slots assocs
-sequences arrays vectors definitions prettyprint
-math hashtables sets macros namespaces ;
+USING: accessors parser generic kernel classes classes.tuple
+words slots assocs sequences arrays vectors definitions
+prettyprint math hashtables sets macros namespaces ;
IN: delegate
: protocol-words ( protocol -- words )
USING: words kernel sequences combinators.lib locals\r
locals.private accessors parser namespaces continuations\r
-summary definitions arrays.lib arrays ;\r
+summary definitions generalizations arrays ;\r
IN: descriptive\r
\r
ERROR: descriptive-error args underlying word ;\r
permit-id get realm get name>> permit-id-key <cookie>\r
"$login-realm" resolve-base-path >>path\r
realm get\r
- [ timeout>> from-now >>expires ]\r
[ domain>> >>domain ]\r
[ secure>> >>secure ]\r
- tri ;\r
+ bi ;\r
\r
: put-permit-cookie ( response -- response' )\r
<permit-cookie> put-cookie ;\r
new
swap >>responder
20 minutes >>timeout ; inline
-
+
: touch-state ( state manager -- )
- timeout>> from-now >>expires drop ;
+ timeout>> hence >>expires drop ;
: <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' )
--- /dev/null
+! Copyright (C) 2007 Chris Double.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: help.syntax help.markup kernel sequences quotations\r
+math ;\r
+IN: generalizations\r
+\r
+HELP: npick\r
+{ $values { "n" integer } }\r
+{ $description "A generalization of " { $link dup } ", "\r
+{ $link over } " and " { $link pick } " that can work "\r
+"for any stack depth. The nth item down the stack will be copied and "\r
+"placed on the top of the stack."\r
+}\r
+{ $examples\r
+ { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }\r
+}\r
+{ $see-also dup over pick } ;\r
+\r
+HELP: ndup\r
+{ $values { "n" integer } }\r
+{ $description "A generalization of " { $link dup } ", "\r
+{ $link 2dup } " and " { $link 3dup } " that can work "\r
+"for any number of items. The n topmost items on the stack will be copied and "\r
+"placed on the top of the stack."\r
+}\r
+{ $examples\r
+ { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }\r
+}\r
+{ $see-also dup 2dup 3dup } ;\r
+\r
+HELP: nnip\r
+{ $values { "n" integer } }\r
+{ $description "A generalization of " { $link nip } " and " { $link 2nip }\r
+" that can work "\r
+"for any number of items."\r
+}\r
+{ $examples\r
+ { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" }\r
+}\r
+{ $see-also nip 2nip } ;\r
+\r
+HELP: ndrop\r
+{ $values { "n" integer } }\r
+{ $description "A generalization of " { $link drop }\r
+" that can work "\r
+"for any number of items."\r
+}\r
+{ $examples\r
+ { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" }\r
+}\r
+{ $see-also drop 2drop 3drop } ;\r
+\r
+HELP: nrot\r
+{ $values { "n" integer } }\r
+{ $description "A generalization of " { $link rot } " that works for any "\r
+"number of items on the stack. "\r
+}\r
+{ $examples\r
+ { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }\r
+}\r
+{ $see-also rot -nrot } ;\r
+\r
+HELP: -nrot\r
+{ $values { "n" integer } }\r
+{ $description "A generalization of " { $link -rot } " that works for any "\r
+"number of items on the stack. "\r
+}\r
+{ $examples\r
+ { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }\r
+}\r
+{ $see-also rot nrot } ;\r
+\r
+HELP: nrev\r
+{ $values { "n" integer } }\r
+{ $description "A generalization of " { $link spin } " that reverses any number of items at the top of the stack."\r
+}\r
+{ $examples\r
+ { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrev .s" "4\n3\n2\n1" }\r
+}\r
+{ $see-also rot nrot } ;\r
+\r
+HELP: ndip\r
+{ $values { "quot" quotation } { "n" number } }\r
+{ $description "A generalization of " { $link dip } " that can work " \r
+"for any stack depth. The quotation will be called with a stack that "\r
+"has 'n' items removed first. The 'n' items are then put back on the "\r
+"stack. The quotation can consume and produce any number of items."\r
+} \r
+{ $examples\r
+ { $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }\r
+ { $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }\r
+}\r
+{ $see-also dip 2dip } ;\r
+\r
+HELP: nslip\r
+{ $values { "n" number } }\r
+{ $description "A generalization of " { $link slip } " that can work " \r
+"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "\r
+"removed from the stack, the quotation called, and the items restored."\r
+} \r
+{ $examples\r
+ { $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }\r
+}\r
+{ $see-also slip nkeep } ;\r
+\r
+HELP: nkeep\r
+{ $values { "quot" quotation } { "n" number } }\r
+{ $description "A generalization of " { $link keep } " that can work " \r
+"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "\r
+"saved, the quotation called, and the items restored."\r
+} \r
+{ $examples\r
+ { $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" }\r
+}\r
+{ $see-also keep nslip } ;\r
+\r
+ARTICLE: "generalizations" "Generalized shuffle words and combinators"\r
+"A number of stack shuffling words and combinators for use in "\r
+"macros where the arity of the input quotations depends on an "\r
+"input parameter."\r
+{ $subsection narray }\r
+{ $subsection ndup }\r
+{ $subsection npick }\r
+{ $subsection nrot }\r
+{ $subsection -nrot }\r
+{ $subsection nnip }\r
+{ $subsection ndrop }\r
+{ $subsection nrev }\r
+{ $subsection ndip }\r
+{ $subsection nslip }\r
+{ $subsection nkeep }\r
+{ $subsection ncurry } \r
+{ $subsection nwith } \r
+{ $subsection napply } ;\r
+\r
+ABOUT: "generalizations"\r
--- /dev/null
+USING: tools.test generalizations kernel math arrays sequences ;\r
+IN: generalizations.tests\r
+\r
+{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test\r
+{ 1 2 3 4 2 } [ 1 2 3 4 3 npick ] unit-test\r
+{ 1 2 3 4 3 } [ 1 2 3 4 2 npick ] unit-test\r
+{ 1 2 3 4 4 } [ 1 2 3 4 1 npick ] unit-test\r
+[ 1 1 ndup ] must-infer\r
+{ 1 1 } [ 1 1 ndup ] unit-test\r
+{ 1 2 1 2 } [ 1 2 2 ndup ] unit-test\r
+{ 1 2 3 1 2 3 } [ 1 2 3 3 ndup ] unit-test\r
+{ 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4 ndup ] unit-test\r
+[ 1 2 2 nrot ] must-infer\r
+{ 2 1 } [ 1 2 2 nrot ] unit-test\r
+{ 2 3 1 } [ 1 2 3 3 nrot ] unit-test\r
+{ 2 3 4 1 } [ 1 2 3 4 4 nrot ] unit-test\r
+[ 1 2 2 -nrot ] must-infer\r
+{ 2 1 } [ 1 2 2 -nrot ] unit-test\r
+{ 3 1 2 } [ 1 2 3 3 -nrot ] unit-test\r
+{ 4 1 2 3 } [ 1 2 3 4 4 -nrot ] unit-test\r
+[ 1 2 3 4 3 nnip ] must-infer\r
+{ 4 } [ 1 2 3 4 3 nnip ] unit-test\r
+[ 1 2 3 4 4 ndrop ] must-infer\r
+{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test\r
+\r
+[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer\r
+{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test\r
+[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer\r
+{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test\r
+[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test\r
+[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test\r
+[ [ dup 2^ 2array ] 5 napply ] must-infer\r
+\r
+[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test\r
--- /dev/null
+! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel sequences sequences.private namespaces math math.ranges\r
+combinators macros quotations fry locals arrays ;\r
+IN: generalizations\r
+\r
+MACRO: narray ( n -- quot )\r
+ dup [ f <array> ] curry\r
+ swap <reversed> [\r
+ [ swap [ set-nth-unsafe ] keep ] curry\r
+ ] map concat append ;\r
+\r
+MACRO: npick ( n -- )\r
+ 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;\r
+\r
+MACRO: ndup ( n -- )\r
+ dup '[ , npick ] n*quot ;\r
+\r
+MACRO: nrot ( n -- )\r
+ 1- dup saver swap [ r> swap ] n*quot append ;\r
+\r
+MACRO: -nrot ( n -- )\r
+ 1- dup [ swap >r ] n*quot swap restorer append ;\r
+\r
+MACRO: ndrop ( n -- )\r
+ [ drop ] n*quot ;\r
+\r
+: nnip ( n -- )\r
+ swap >r ndrop r> ; inline\r
+\r
+MACRO: ntuck ( n -- )\r
+ 2 + [ dupd -nrot ] curry ;\r
+\r
+MACRO: nrev ( n -- quot )\r
+ 1 [a,b] [ '[ , -nrot ] ] map concat ;\r
+\r
+MACRO: ndip ( quot n -- )\r
+ dup saver -rot restorer 3append ;\r
+\r
+MACRO: nslip ( n -- )\r
+ dup saver [ call ] rot restorer 3append ;\r
+\r
+MACRO: nkeep ( n -- )\r
+ [ ] [ 1+ ] [ ] tri\r
+ '[ [ , ndup ] dip , -nrot , nslip ] ;\r
+\r
+MACRO: ncurry ( n -- ) [ curry ] n*quot ;\r
+\r
+MACRO:: nwith ( quot n -- )\r
+ [let | n' [ n 1+ ] |\r
+ [ n' -nrot [ n' nrot quot call ] n ncurry ] ] ;\r
+\r
+MACRO: napply ( n -- )\r
+ 2 [a,b]\r
+ [ [ 1- ] keep '[ , ntuck , nslip ] ]\r
+ map concat >quotation [ call ] append ;\r
USING: assocs html.parser kernel math sequences strings ascii
-arrays shuffle unicode.case namespaces splitting http
-sequences.lib accessors io combinators http.client urls ;
+arrays generalizations shuffle unicode.case namespaces splitting
+http sequences.lib accessors io combinators http.client urls ;
IN: html.parser.analyzer
TUPLE: link attributes clickable ;
! 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
: check-pool ( pool -- )
dup check-disposed
dup expired>> expired? [
- ALIEN: 31337 >>expired
+ 31337 <alien> >>expired
connections>> delete-all
] [ drop ] if ;
} 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
} 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 ;
: 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 -- )
: make-FileArgs ( port -- <FileArgs> )
{
+ [ handle>> check-disposed ]
[ handle>> handle>> ]
[ buffer>> ]
[ buffer>> buffer-length ]
] 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 ;
-USING: io.backend kernel continuations sequences ;\r
+USING: io.backend kernel continuations sequences\r
+system vocabs.loader combinators ;\r
IN: io.windows.privileges\r
\r
HOOK: set-privilege io-backend ( name ? -- ) inline\r
: with-privileges ( seq quot -- )\r
over [ [ t set-privilege ] each ] curry compose\r
swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline\r
+\r
+{\r
+ { [ os winnt? ] [ "io.windows.nt.privileges" require ] }\r
+ { [ os wince? ] [ "io.windows.ce.privileges" require ] }\r
+} cond\r
[ 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)
[ laplacian-kernel ] bigraded-laplacian ;
: bigraded-basis. ( seq -- )
- dup length [
+ [
"=== U-degree " write .
- dup length [
+ [
" === Z-degree " write pprint
": dimension " write dup length .
[ " " write alt. ] each
- ] 2each
- ] 2each ;
+ ] each-index
+ ] each-index ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel math io calendar calendar.format
-calendar.model arrays models namespaces ui.gadgets
-ui.gadgets.labels
-ui.gadgets.theme ui ;
+calendar.model arrays models models.filter namespaces ui.gadgets
+ui.gadgets.labels ui.gadgets.theme ui ;
IN: lcd
: lcd-digit ( row digit -- str )
USING: logging.server sequences namespaces concurrency.messaging\r
words kernel arrays shuffle tools.annotations\r
prettyprint.config prettyprint debugger io.streams.string\r
-splitting continuations effects arrays.lib parser strings\r
+splitting continuations effects generalizations parser strings\r
quotations fry symbols accessors ;\r
IN: logging\r
\r
--- /dev/null
+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 ) ;
+
--- /dev/null
+Low-level bindings to the C Basic Linear Algebra Subroutines (BLAS) library
--- /dev/null
+math
+bindings
--- /dev/null
+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" } "." } ;
+
--- /dev/null
+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
+
--- /dev/null
+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&& ;
+
--- /dev/null
+BLAS level 2 and 3 matrix-vector and matrix-matrix operations
--- /dev/null
+math
+bindings
--- /dev/null
+Literal syntax for BLAS vectors and matrices
--- /dev/null
+USING: help.markup help.syntax math.blas.matrices math.blas.vectors multiline ;
+IN: math.blas.syntax
+
+ARTICLE: "math.blas.syntax" "BLAS interface literal syntax"
+"Vectors:"
+{ $subsection POSTPONE: svector{ }
+{ $subsection POSTPONE: dvector{ }
+{ $subsection POSTPONE: cvector{ }
+{ $subsection POSTPONE: zvector{ }
+"Matrices:"
+{ $subsection POSTPONE: smatrix{ }
+{ $subsection POSTPONE: dmatrix{ }
+{ $subsection POSTPONE: cmatrix{ }
+{ $subsection POSTPONE: zmatrix{ } ;
+
+ABOUT: "math.blas.syntax"
+
+HELP: svector{
+{ $syntax "svector{ 1.0 -2.0 3.0 }" }
+{ $description "Construct a literal " { $link float-blas-vector } "." } ;
+
+HELP: dvector{
+{ $syntax "dvector{ 1.0 -2.0 3.0 }" }
+{ $description "Construct a literal " { $link double-blas-vector } "." } ;
+
+HELP: cvector{
+{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
+{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ;
+
+HELP: zvector{
+{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
+{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ;
+
+{
+ POSTPONE: svector{ POSTPONE: dvector{
+ POSTPONE: cvector{ POSTPONE: zvector{
+} related-words
+
+HELP: smatrix{
+{ $syntax <" smatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 1.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ { 0.0 0.0 0.0 1.0 }
+} "> }
+{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+HELP: dmatrix{
+{ $syntax <" dmatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 1.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ { 0.0 0.0 0.0 1.0 }
+} "> }
+{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+HELP: cmatrix{
+{ $syntax <" cmatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 -1.0 3.0 }
+ { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
+} "> }
+{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+HELP: zmatrix{
+{ $syntax <" zmatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 -1.0 3.0 }
+ { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
+} "> }
+{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+{
+ POSTPONE: smatrix{ POSTPONE: dmatrix{
+ POSTPONE: cmatrix{ POSTPONE: zmatrix{
+} related-words
--- /dev/null
+USING: kernel math.blas.matrices math.blas.vectors parser ;
+IN: math.blas.syntax
+
+: svector{ ( accum -- accum )
+ \ } [ >float-blas-vector ] parse-literal ; parsing
+: dvector{ ( accum -- accum )
+ \ } [ >double-blas-vector ] parse-literal ; parsing
+: cvector{ ( accum -- accum )
+ \ } [ >float-complex-blas-vector ] parse-literal ; parsing
+: zvector{ ( accum -- accum )
+ \ } [ >double-complex-blas-vector ] parse-literal ; parsing
+
+: smatrix{ ( accum -- accum )
+ \ } [ >float-blas-matrix ] parse-literal ; parsing
+: dmatrix{ ( accum -- accum )
+ \ } [ >double-blas-matrix ] parse-literal ; parsing
+: cmatrix{ ( accum -- accum )
+ \ } [ >float-complex-blas-matrix ] parse-literal ; parsing
+: zmatrix{ ( accum -- accum )
+ \ } [ >double-complex-blas-matrix ] parse-literal ; parsing
--- /dev/null
+BLAS level 1 vector operations
--- /dev/null
+USING: alien byte-arrays help.markup help.syntax sequences ;
+IN: math.blas.vectors
+
+ARTICLE: "math.blas.vectors" "BLAS interface vector operations"
+"Slicing vectors:"
+{ $subsection Vsub }
+"Taking the norm (magnitude) of a vector:"
+{ $subsection Vnorm }
+"Summing and taking the maximum of elements:"
+{ $subsection Vasum }
+{ $subsection Viamax }
+{ $subsection Vamax }
+"Scalar-vector products:"
+{ $subsection n*V-in-place }
+{ $subsection n*V }
+{ $subsection V*n }
+{ $subsection V/n }
+{ $subsection Vneg }
+"Vector addition:"
+{ $subsection n*V+V-in-place }
+{ $subsection n*V+V }
+{ $subsection V+ }
+{ $subsection V- }
+"Vector inner products:"
+{ $subsection V. }
+{ $subsection V.conj } ;
+
+ABOUT: "math.blas.vectors"
+
+HELP: blas-vector-base
+{ $class-description "The base class for all BLAS vector types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:"
+{ $list
+ { { $link float-blas-vector } }
+ { { $link double-blas-vector } }
+ { { $link float-complex-blas-vector } }
+ { { $link double-complex-blas-vector } }
+}
+"All of these subclasses share the same tuple layout:"
+{ $list
+ { { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" }
+ { { $snippet "length" } " indicates the length of the vector;" }
+ { "and " { $snippet "inc" } " indicates the distance, in elements, between elements." }
+} } ;
+
+HELP: float-blas-vector
+{ $class-description "A vector of single-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+HELP: double-blas-vector
+{ $class-description "A vector of double-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+HELP: float-complex-blas-vector
+{ $class-description "A vector 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-vector-base } "." } ;
+HELP: double-complex-blas-vector
+{ $class-description "A vector 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-vector-base } "." } ;
+
+HELP: n*V+V-in-place
+{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Calculate the vector sum " { $snippet "αx + y" } " and replace the existing contents of y with the result. Corresponds to the xAXPY routines in BLAS." }
+{ $side-effects "y" } ;
+
+HELP: n*V-in-place
+{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and replace the existing contents of x with the result. Corresponds to the xSCAL routines in BLAS." }
+{ $side-effects "x" } ;
+
+HELP: V.
+{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Calculate the inner product " { $snippet "x⋅y" } ". Corresponds to the xDOT and xDOTU routines in BLAS." } ;
+
+HELP: V.conj
+{ $values { "x" "a complex BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a complex BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Calculate the conjugate inner product " { $snippet "x̅⋅y" } ". Corresponds to the xDOTC routines in BLAS." } ;
+
+HELP: Vnorm
+{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Calculate the norm-2, i.e., the magnitude or absolute value, of " { $snippet "x" } " (" { $snippet "‖x‖₂" } "). Corresponds to the xNRM2 routines in BLAS." } ;
+
+HELP: Vasum
+{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Calculate the sum of the norm-1s of the elements of " { $snippet "x" } " (" { $snippet "Σ ‖xᵢ‖₁" } "). Corresponds to the xASUM routines in BLAS." } ;
+
+HELP: Vswap
+{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Swap the contents of " { $snippet "x" } " and " { $snippet "y" } " in place. Corresponds to the xSWAP routines in BLAS." }
+{ $side-effects "x" "y" } ;
+
+HELP: Viamax
+{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Return the index of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the smallest index. Corresponds to the IxAMAX routines in BLAS." } ;
+
+HELP: Vamax
+{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the first element. Corresponds to the IxAMAX routines in BLAS." } ;
+
+{ Viamax Vamax } related-words
+
+HELP: <zero-vector>
+{ $values { "exemplar" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Return a vector of zeros with the same length and element type as " { $snippet "v" } ". The vector is constructed with an " { $snippet "inc" } " of zero, so it is not suitable for receiving results from BLAS functions; it is intended to be used as a term in other vector calculations. To construct an empty vector that can be used to receive results, see " { $link <empty-vector> } "." } ;
+
+HELP: n*V+V
+{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Calculate the vector sum " { $snippet "αx + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
+
+HELP: n*V
+{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
+
+HELP: V+
+{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Calculate the vector sum " { $snippet "x + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
+
+HELP: V-
+{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Calculate the vector difference " { $snippet "x – y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
+
+HELP: Vneg
+{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $description "Negate the elements of " { $snippet "x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result." } ;
+
+HELP: V*n
+{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "alpha" "a number" } }
+{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
+
+HELP: V/n
+{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "alpha" "a number" } }
+{ $description "Calculate the scalar-vector product " { $snippet "(1/α)x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
+
+{ n*V+V-in-place n*V-in-place n*V+V n*V V+ V- Vneg V*n V/n } related-words
+
+HELP: Vsub
+{ $values { "v" "a BLAS vector inheriting from " { $link blas-vector-base } } { "start" "The index of the first element of the slice" } { "length" "The length of the slice" } }
+{ $description "Slice a subvector out of " { $snippet "v" } " with the given length. The subvector will share storage with the parent vector." } ;
--- /dev/null
+USING: kernel math.blas.vectors math.blas.syntax sequences tools.test ;
+IN: math.blas.vectors.tests
+
+! clone
+
+[ svector{ 1.0 2.0 3.0 } ] [ svector{ 1.0 2.0 3.0 } clone ] unit-test
+[ f ] [ svector{ 1.0 2.0 3.0 } dup clone eq? ] unit-test
+[ dvector{ 1.0 2.0 3.0 } ] [ dvector{ 1.0 2.0 3.0 } clone ] unit-test
+[ f ] [ dvector{ 1.0 2.0 3.0 } dup clone eq? ] unit-test
+[ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } ] [ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } clone ] unit-test
+[ f ] [ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } dup clone eq? ] unit-test
+[ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } ] [ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } clone ] unit-test
+[ f ] [ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } dup clone eq? ] unit-test
+
+! nth
+
+[ 1.0 ] [ 2 svector{ 3.0 2.0 1.0 } nth ] unit-test
+[ 1.0 ] [ 2 dvector{ 3.0 2.0 1.0 } nth ] unit-test
+
+[ C{ 1.0 2.0 } ]
+[ 2 cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } nth ] unit-test
+
+[ C{ 1.0 2.0 } ]
+[ 2 zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } nth ] unit-test
+
+! set-nth
+
+[ svector{ 3.0 2.0 0.0 } ] [ 0.0 2 svector{ 3.0 2.0 1.0 } [ set-nth ] keep ] unit-test
+[ dvector{ 3.0 2.0 0.0 } ] [ 0.0 2 dvector{ 3.0 2.0 1.0 } [ set-nth ] keep ] unit-test
+
+[ cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 3.0 4.0 } } ] [
+ C{ 3.0 4.0 } 2
+ cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } }
+ [ set-nth ] keep
+] unit-test
+[ zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 3.0 4.0 } } ] [
+ C{ 3.0 4.0 } 2
+ zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } }
+ [ set-nth ] keep
+] unit-test
+
+! V+
+
+[ svector{ 11.0 22.0 } ] [ svector{ 1.0 2.0 } svector{ 10.0 20.0 } V+ ] unit-test
+[ dvector{ 11.0 22.0 } ] [ dvector{ 1.0 2.0 } dvector{ 10.0 20.0 } V+ ] unit-test
+
+[ cvector{ 11.0 C{ 22.0 33.0 } } ]
+[ cvector{ 1.0 C{ 2.0 3.0 } } cvector{ 10.0 C{ 20.0 30.0 } } V+ ]
+unit-test
+
+[ zvector{ 11.0 C{ 22.0 33.0 } } ]
+[ zvector{ 1.0 C{ 2.0 3.0 } } zvector{ 10.0 C{ 20.0 30.0 } } V+ ]
+unit-test
+
+! V-
+
+[ svector{ 9.0 18.0 } ] [ svector{ 10.0 20.0 } svector{ 1.0 2.0 } V- ] unit-test
+[ dvector{ 9.0 18.0 } ] [ dvector{ 10.0 20.0 } dvector{ 1.0 2.0 } V- ] unit-test
+
+[ cvector{ 9.0 C{ 18.0 27.0 } } ]
+[ cvector{ 10.0 C{ 20.0 30.0 } } cvector{ 1.0 C{ 2.0 3.0 } } V- ]
+unit-test
+
+[ zvector{ 9.0 C{ 18.0 27.0 } } ]
+[ zvector{ 10.0 C{ 20.0 30.0 } } zvector{ 1.0 C{ 2.0 3.0 } } V- ]
+unit-test
+
+! Vneg
+
+[ svector{ 1.0 -2.0 } ] [ svector{ -1.0 2.0 } Vneg ] unit-test
+[ dvector{ 1.0 -2.0 } ] [ dvector{ -1.0 2.0 } Vneg ] unit-test
+
+[ cvector{ 1.0 C{ -2.0 3.0 } } ] [ cvector{ -1.0 C{ 2.0 -3.0 } } Vneg ] unit-test
+[ zvector{ 1.0 C{ -2.0 3.0 } } ] [ zvector{ -1.0 C{ 2.0 -3.0 } } Vneg ] unit-test
+
+! n*V
+
+[ svector{ 100.0 200.0 } ] [ 10.0 svector{ 10.0 20.0 } n*V ] unit-test
+[ dvector{ 100.0 200.0 } ] [ 10.0 dvector{ 10.0 20.0 } n*V ] unit-test
+
+[ cvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
+[ C{ 10.0 2.0 } cvector{ 2.0 C{ 1.0 1.0 } } n*V ]
+unit-test
+
+[ zvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
+[ C{ 10.0 2.0 } zvector{ 2.0 C{ 1.0 1.0 } } n*V ]
+unit-test
+
+! V*n
+
+[ svector{ 100.0 200.0 } ] [ svector{ 10.0 20.0 } 10.0 V*n ] unit-test
+[ dvector{ 100.0 200.0 } ] [ dvector{ 10.0 20.0 } 10.0 V*n ] unit-test
+
+[ cvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
+[ cvector{ 2.0 C{ 1.0 1.0 } } C{ 10.0 2.0 } V*n ]
+unit-test
+
+[ zvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
+[ zvector{ 2.0 C{ 1.0 1.0 } } C{ 10.0 2.0 } V*n ]
+unit-test
+
+! V/n
+
+[ svector{ 1.0 2.0 } ] [ svector{ 4.0 8.0 } 4.0 V/n ] unit-test
+[ dvector{ 1.0 2.0 } ] [ dvector{ 4.0 8.0 } 4.0 V/n ] unit-test
+
+[ cvector{ 2.0 1.0 } ]
+[ cvector{ C{ 16.0 4.0 } C{ 8.0 2.0 } } C{ 8.0 2.0 } V/n ]
+unit-test
+
+[ cvector{ 2.0 1.0 } ]
+[ cvector{ C{ 16.0 4.0 } C{ 8.0 2.0 } } C{ 8.0 2.0 } V/n ]
+unit-test
+
+! V.
+
+[ 7.0 ] [ svector{ 1.0 2.5 } svector{ 2.0 2.0 } V. ] unit-test
+[ 7.0 ] [ dvector{ 1.0 2.5 } dvector{ 2.0 2.0 } V. ] unit-test
+[ C{ 7.0 7.0 } ] [ cvector{ C{ 1.0 1.0 } 2.5 } cvector{ 2.0 C{ 2.0 2.0 } } V. ] unit-test
+[ C{ 7.0 7.0 } ] [ zvector{ C{ 1.0 1.0 } 2.5 } zvector{ 2.0 C{ 2.0 2.0 } } V. ] unit-test
+
+! V.conj
+
+[ C{ 7.0 3.0 } ] [ cvector{ C{ 1.0 1.0 } 2.5 } cvector{ 2.0 C{ 2.0 2.0 } } V.conj ] unit-test
+[ C{ 7.0 3.0 } ] [ zvector{ C{ 1.0 1.0 } 2.5 } zvector{ 2.0 C{ 2.0 2.0 } } V.conj ] unit-test
+
+! Vnorm
+
+[ 5.0 ] [ svector{ 3.0 4.0 } Vnorm ] unit-test
+[ 5.0 ] [ dvector{ 3.0 4.0 } Vnorm ] unit-test
+
+[ 13.0 ] [ cvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test
+[ 13.0 ] [ zvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test
+
+! Vasum
+
+[ 6.0 ] [ svector{ 1.0 2.0 -3.0 } Vasum ] unit-test
+[ 6.0 ] [ dvector{ 1.0 2.0 -3.0 } Vasum ] unit-test
+
+[ 15.0 ] [ cvector{ 1.0 C{ -2.0 3.0 } C{ 4.0 -5.0 } } Vasum ] unit-test
+[ 15.0 ] [ zvector{ 1.0 C{ -2.0 3.0 } C{ 4.0 -5.0 } } Vasum ] unit-test
+
+! Vswap
+
+[ svector{ 2.0 2.0 } svector{ 1.0 1.0 } ]
+[ svector{ 1.0 1.0 } svector{ 2.0 2.0 } Vswap ]
+unit-test
+
+[ dvector{ 2.0 2.0 } dvector{ 1.0 1.0 } ]
+[ dvector{ 1.0 1.0 } dvector{ 2.0 2.0 } Vswap ]
+unit-test
+
+[ cvector{ 2.0 C{ 2.0 2.0 } } cvector{ C{ 1.0 1.0 } 1.0 } ]
+[ cvector{ C{ 1.0 1.0 } 1.0 } cvector{ 2.0 C{ 2.0 2.0 } } Vswap ]
+unit-test
+
+[ zvector{ 2.0 C{ 2.0 2.0 } } zvector{ C{ 1.0 1.0 } 1.0 } ]
+[ zvector{ C{ 1.0 1.0 } 1.0 } zvector{ 2.0 C{ 2.0 2.0 } } Vswap ]
+unit-test
+
+! Viamax
+
+[ 3 ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } Viamax ] unit-test
+[ 3 ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } Viamax ] unit-test
+[ 0 ] [ cvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Viamax ] unit-test
+[ 0 ] [ zvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Viamax ] unit-test
+
+! Vamax
+
+[ -6.0 ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } Vamax ] unit-test
+[ -6.0 ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } Vamax ] unit-test
+[ C{ 2.0 -5.0 } ] [ cvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test
+[ C{ 2.0 -5.0 } ] [ zvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test
+
+! Vsub
+
+[ svector{ -5.0 4.0 -6.0 } ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } 1 3 Vsub ] unit-test
+[ dvector{ -5.0 4.0 -6.0 } ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } 1 3 Vsub ] unit-test
+[ cvector{ -5.0 C{ 4.0 3.0 } -6.0 } ] [ cvector{ 1.0 -5.0 C{ 4.0 3.0 } -6.0 -1.0 } 1 3 Vsub ] unit-test
+[ zvector{ -5.0 C{ 4.0 3.0 } -6.0 } ] [ zvector{ 1.0 -5.0 C{ 4.0 3.0 } -6.0 -1.0 } 1 3 Vsub ] unit-test
--- /dev/null
+USING: accessors alien alien.c-types arrays byte-arrays combinators
+combinators.short-circuit fry kernel macros math math.blas.cblas
+math.complex math.functions math.order multi-methods qualified
+sequences sequences.private generalizations ;
+QUALIFIED: syntax
+IN: math.blas.vectors
+
+TUPLE: blas-vector-base data length inc ;
+TUPLE: float-blas-vector < blas-vector-base ;
+TUPLE: double-blas-vector < blas-vector-base ;
+TUPLE: float-complex-blas-vector < blas-vector-base ;
+TUPLE: double-complex-blas-vector < blas-vector-base ;
+
+INSTANCE: float-blas-vector sequence
+INSTANCE: double-blas-vector sequence
+INSTANCE: float-complex-blas-vector sequence
+INSTANCE: double-complex-blas-vector sequence
+
+C: <float-blas-vector> float-blas-vector
+C: <double-blas-vector> double-blas-vector
+C: <float-complex-blas-vector> float-complex-blas-vector
+C: <double-complex-blas-vector> double-complex-blas-vector
+
+GENERIC: n*V+V-in-place ( alpha x y -- y=alpha*x+y )
+GENERIC: n*V-in-place ( alpha x -- x=alpha*x )
+
+GENERIC: V. ( x y -- x.y )
+GENERIC: V.conj ( x y -- xconj.y )
+GENERIC: Vnorm ( x -- norm )
+GENERIC: Vasum ( x -- sum )
+GENERIC: Vswap ( x y -- x=y y=x )
+
+GENERIC: Viamax ( x -- max-i )
+
+GENERIC: element-type ( v -- type )
+
+METHOD: element-type { float-blas-vector }
+ drop "float" ;
+METHOD: element-type { double-blas-vector }
+ drop "double" ;
+METHOD: element-type { float-complex-blas-vector }
+ drop "CBLAS_C" ;
+METHOD: element-type { double-complex-blas-vector }
+ drop "CBLAS_Z" ;
+
+<PRIVATE
+
+GENERIC: (blas-vector-like) ( data length inc exemplar -- vector )
+
+METHOD: (blas-vector-like) { object object object float-blas-vector }
+ drop <float-blas-vector> ;
+METHOD: (blas-vector-like) { object object object double-blas-vector }
+ drop <double-blas-vector> ;
+METHOD: (blas-vector-like) { object object object float-complex-blas-vector }
+ drop <float-complex-blas-vector> ;
+METHOD: (blas-vector-like) { object object object double-complex-blas-vector }
+ drop <double-complex-blas-vector> ;
+
+: (prepare-copy) ( v element-size -- length v-data v-inc v-dest-data v-dest-inc )
+ [ [ length>> ] [ data>> ] [ inc>> ] tri ] dip
+ 4 npick * <byte-array>
+ 1 ;
+
+MACRO: (do-copy) ( copy make-vector -- )
+ '[ over 6 npick , 2dip 1 @ ] ;
+
+: (prepare-swap) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc v1 v2 )
+ [
+ [ [ length>> ] bi@ min ]
+ [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
+ ] 2keep ;
+
+: (prepare-axpy) ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc v2 )
+ [
+ [ [ length>> ] bi@ min swap ]
+ [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
+ ] keep ;
+
+: (prepare-scal) ( n v -- length n v-data v-inc v )
+ [ [ length>> swap ] [ data>> ] [ inc>> ] tri ] keep ;
+
+: (prepare-dot) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc )
+ [ [ length>> ] bi@ min ]
+ [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi ;
+
+: (prepare-nrm2) ( v -- length v1-data v1-inc )
+ [ length>> ] [ data>> ] [ inc>> ] tri ;
+
+: (flatten-complex-sequence) ( seq -- seq' )
+ [ [ real-part ] [ imaginary-part ] bi 2array ] map concat ;
+
+: (>c-complex) ( complex -- alien )
+ [ real-part ] [ imaginary-part ] bi 2array >c-float-array ;
+: (>z-complex) ( complex -- alien )
+ [ real-part ] [ imaginary-part ] bi 2array >c-double-array ;
+
+: (c-complex>) ( alien -- complex )
+ 2 c-float-array> first2 rect> ;
+: (z-complex>) ( alien -- complex )
+ 2 c-double-array> first2 rect> ;
+
+: (prepare-nth) ( n v -- n*inc v-data )
+ [ inc>> ] [ data>> ] bi [ * ] dip ;
+
+MACRO: (complex-nth) ( nth-quot -- )
+ '[
+ [ 2 * dup 1+ ] dip
+ , curry bi@ rect>
+ ] ;
+
+: (c-complex-nth) ( n alien -- complex )
+ [ float-nth ] (complex-nth) ;
+: (z-complex-nth) ( n alien -- complex )
+ [ double-nth ] (complex-nth) ;
+
+MACRO: (set-complex-nth) ( set-nth-quot -- )
+ '[
+ [
+ [ [ real-part ] [ imaginary-part ] bi ]
+ [ 2 * dup 1+ ] bi*
+ swapd
+ ] dip
+ , curry 2bi@
+ ] ;
+
+: (set-c-complex-nth) ( complex n alien -- )
+ [ set-float-nth ] (set-complex-nth) ;
+: (set-z-complex-nth) ( complex n alien -- )
+ [ set-double-nth ] (set-complex-nth) ;
+
+PRIVATE>
+
+: <zero-vector> ( exemplar -- zero )
+ [ element-type <c-object> ]
+ [ length>> 0 ]
+ [ (blas-vector-like) ] tri ;
+
+: <empty-vector> ( length exemplar -- vector )
+ [ element-type <c-array> ]
+ [ 1 swap ] 2bi
+ (blas-vector-like) ;
+
+syntax:M: blas-vector-base length
+ length>> ;
+
+syntax:M: float-blas-vector nth-unsafe
+ (prepare-nth) float-nth ;
+syntax:M: float-blas-vector set-nth-unsafe
+ (prepare-nth) set-float-nth ;
+
+syntax:M: double-blas-vector nth-unsafe
+ (prepare-nth) double-nth ;
+syntax:M: double-blas-vector set-nth-unsafe
+ (prepare-nth) set-double-nth ;
+
+syntax:M: float-complex-blas-vector nth-unsafe
+ (prepare-nth) (c-complex-nth) ;
+syntax:M: float-complex-blas-vector set-nth-unsafe
+ (prepare-nth) (set-c-complex-nth) ;
+
+syntax:M: double-complex-blas-vector nth-unsafe
+ (prepare-nth) (z-complex-nth) ;
+syntax:M: double-complex-blas-vector set-nth-unsafe
+ (prepare-nth) (set-z-complex-nth) ;
+
+syntax:M: blas-vector-base equal?
+ {
+ [ [ length ] bi@ = ]
+ [ [ = ] 2all? ]
+ } 2&& ;
+
+: >float-blas-vector ( seq -- v )
+ [ >c-float-array ] [ length ] bi 1 <float-blas-vector> ;
+: >double-blas-vector ( seq -- v )
+ [ >c-double-array ] [ length ] bi 1 <double-blas-vector> ;
+: >float-complex-blas-vector ( seq -- v )
+ [ (flatten-complex-sequence) >c-float-array ] [ length ] bi
+ 1 <float-complex-blas-vector> ;
+: >double-complex-blas-vector ( seq -- v )
+ [ (flatten-complex-sequence) >c-double-array ] [ length ] bi
+ 1 <double-complex-blas-vector> ;
+
+syntax:M: float-blas-vector clone
+ "float" heap-size (prepare-copy)
+ [ cblas_scopy ] [ <float-blas-vector> ] (do-copy) ;
+syntax:M: double-blas-vector clone
+ "double" heap-size (prepare-copy)
+ [ cblas_dcopy ] [ <double-blas-vector> ] (do-copy) ;
+syntax:M: float-complex-blas-vector clone
+ "CBLAS_C" heap-size (prepare-copy)
+ [ cblas_ccopy ] [ <float-complex-blas-vector> ] (do-copy) ;
+syntax:M: double-complex-blas-vector clone
+ "CBLAS_Z" heap-size (prepare-copy)
+ [ cblas_zcopy ] [ <double-complex-blas-vector> ] (do-copy) ;
+
+METHOD: Vswap { float-blas-vector float-blas-vector }
+ (prepare-swap) [ cblas_sswap ] 2dip ;
+METHOD: Vswap { double-blas-vector double-blas-vector }
+ (prepare-swap) [ cblas_dswap ] 2dip ;
+METHOD: Vswap { float-complex-blas-vector float-complex-blas-vector }
+ (prepare-swap) [ cblas_cswap ] 2dip ;
+METHOD: Vswap { double-complex-blas-vector double-complex-blas-vector }
+ (prepare-swap) [ cblas_zswap ] 2dip ;
+
+METHOD: n*V+V-in-place { real float-blas-vector float-blas-vector }
+ (prepare-axpy) [ cblas_saxpy ] dip ;
+METHOD: n*V+V-in-place { real double-blas-vector double-blas-vector }
+ (prepare-axpy) [ cblas_daxpy ] dip ;
+METHOD: n*V+V-in-place { number float-complex-blas-vector float-complex-blas-vector }
+ [ (>c-complex) ] 2dip
+ (prepare-axpy) [ cblas_caxpy ] dip ;
+METHOD: n*V+V-in-place { number double-complex-blas-vector double-complex-blas-vector }
+ [ (>z-complex) ] 2dip
+ (prepare-axpy) [ cblas_zaxpy ] dip ;
+
+METHOD: n*V-in-place { real float-blas-vector }
+ (prepare-scal) [ cblas_sscal ] dip ;
+METHOD: n*V-in-place { real double-blas-vector }
+ (prepare-scal) [ cblas_dscal ] dip ;
+METHOD: n*V-in-place { number float-complex-blas-vector }
+ [ (>c-complex) ] dip
+ (prepare-scal) [ cblas_cscal ] dip ;
+METHOD: n*V-in-place { number double-complex-blas-vector }
+ [ (>z-complex) ] dip
+ (prepare-scal) [ cblas_zscal ] dip ;
+
+: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V-in-place ; inline
+: n*V ( alpha x -- alpha*x ) clone n*V-in-place ; inline
+
+: V+ ( x y -- x+y )
+ 1.0 -rot n*V+V ; inline
+: V- ( x y -- x-y )
+ -1.0 spin n*V+V ; inline
+
+: Vneg ( x -- -x )
+ -1.0 swap n*V ; inline
+
+: V*n ( x alpha -- x*alpha )
+ swap n*V ; inline
+: V/n ( x alpha -- x/alpha )
+ recip swap n*V ; inline
+
+METHOD: V. { float-blas-vector float-blas-vector }
+ (prepare-dot) cblas_sdot ;
+METHOD: V. { double-blas-vector double-blas-vector }
+ (prepare-dot) cblas_ddot ;
+METHOD: V. { float-complex-blas-vector float-complex-blas-vector }
+ (prepare-dot)
+ "CBLAS_C" <c-object> [ cblas_cdotu_sub ] keep (c-complex>) ;
+METHOD: V. { double-complex-blas-vector double-complex-blas-vector }
+ (prepare-dot)
+ "CBLAS_Z" <c-object> [ cblas_zdotu_sub ] keep (z-complex>) ;
+
+METHOD: V.conj { float-complex-blas-vector float-complex-blas-vector }
+ (prepare-dot)
+ "CBLAS_C" <c-object> [ cblas_cdotc_sub ] keep (c-complex>) ;
+METHOD: V.conj { double-complex-blas-vector double-complex-blas-vector }
+ (prepare-dot)
+ "CBLAS_Z" <c-object> [ cblas_zdotc_sub ] keep (z-complex>) ;
+
+METHOD: Vnorm { float-blas-vector }
+ (prepare-nrm2) cblas_snrm2 ;
+METHOD: Vnorm { double-blas-vector }
+ (prepare-nrm2) cblas_dnrm2 ;
+METHOD: Vnorm { float-complex-blas-vector }
+ (prepare-nrm2) cblas_scnrm2 ;
+METHOD: Vnorm { double-complex-blas-vector }
+ (prepare-nrm2) cblas_dznrm2 ;
+
+METHOD: Vasum { float-blas-vector }
+ (prepare-nrm2) cblas_sasum ;
+METHOD: Vasum { double-blas-vector }
+ (prepare-nrm2) cblas_dasum ;
+METHOD: Vasum { float-complex-blas-vector }
+ (prepare-nrm2) cblas_scasum ;
+METHOD: Vasum { double-complex-blas-vector }
+ (prepare-nrm2) cblas_dzasum ;
+
+METHOD: Viamax { float-blas-vector }
+ (prepare-nrm2) cblas_isamax ;
+METHOD: Viamax { double-blas-vector }
+ (prepare-nrm2) cblas_idamax ;
+METHOD: Viamax { float-complex-blas-vector }
+ (prepare-nrm2) cblas_icamax ;
+METHOD: Viamax { double-complex-blas-vector }
+ (prepare-nrm2) cblas_izamax ;
+
+: Vamax ( x -- max )
+ [ Viamax ] keep nth ; inline
+
+: Vsub ( v start length -- vsub )
+ rot [
+ [
+ nip [ inc>> ] [ element-type heap-size ] [ data>> ] tri
+ [ * * ] dip <displaced-alien>
+ ] [ swap 2nip ] [ 2nip inc>> ] 3tri
+ ] keep (blas-vector-like) ;
: normalize ( u -- v ) dup norm v/n ;
: set-axis ( u v axis -- w )
- dup length [ >r zero? 2over ? r> swap nth ] 2map 2nip ;
+ [ >r zero? 2over ? r> swap nth ] map-index 2nip ;
HINTS: vneg { array } ;
HINTS: norm-sq { array } ;
--- /dev/null
+USING: help.syntax help.markup kernel math classes classes.tuple\r
+calendar models ;\r
+IN: models.compose\r
+\r
+HELP: compose\r
+{ $class-description "Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence. Composed models are automatically updated when underlying models change. Composed models are constructed by " { $link <compose> } "."\r
+$nl\r
+"A composed model whose children are all " { $link "models-range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." }\r
+{ $examples\r
+ "The following code displays a pair of sliders, and an updating label showing their current values:"\r
+ { $code\r
+ "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;"\r
+ ": <funny-slider> <x-slider> 100 over set-slider-max ;"\r
+ "<funny-slider> <funny-slider> 2array"\r
+ "dup make-pile gadget."\r
+ "dup [ gadget-model ] map <compose> [ unparse ] <filter>"\r
+ "<label-control> gadget."\r
+ }\r
+} ;\r
+\r
+HELP: <compose>\r
+{ $values { "models" "a sequence of models" } { "compose" "a new " { $link compose } } }\r
+{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping " { $link model-value } " over the given sequence of models." }\r
+{ $examples "See the example in the documentation for " { $link compose } "." } ;\r
+\r
+ARTICLE: "models-compose" "Composed models"\r
+"Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence."\r
+{ $subsection compose }\r
+{ $subsection <compose> } ;\r
+\r
+ABOUT: "models-compose"\r
--- /dev/null
+IN: models.compose.tests\r
+USING: arrays generic kernel math models namespaces sequences assocs\r
+tools.test models.compose ;\r
+\r
+! Test compose\r
+[ ] [\r
+ 1 <model> "a" set\r
+ 2 <model> "b" set\r
+ "a" get "b" get 2array <compose> "c" set\r
+] unit-test\r
+\r
+[ ] [ "c" get activate-model ] unit-test\r
+\r
+[ { 1 2 } ] [ "c" get model-value ] unit-test\r
+\r
+[ ] [ 3 "b" get set-model ] unit-test\r
+\r
+[ { 1 3 } ] [ "c" get model-value ] unit-test\r
+\r
+[ ] [ { 4 5 } "c" get set-model ] unit-test\r
+\r
+[ { 4 5 } ] [ "c" get model-value ] unit-test\r
+\r
+[ ] [ "c" get deactivate-model ] unit-test\r
--- /dev/null
+USING: models kernel sequences ;\r
+IN: models.compose\r
+\r
+TUPLE: compose ;\r
+\r
+: <compose> ( models -- compose )\r
+ f compose construct-model\r
+ swap clone over set-model-dependencies ;\r
+\r
+: composed-value >r model-dependencies r> map ; inline\r
+\r
+: set-composed-value >r model-dependencies r> 2each ; inline\r
+\r
+M: compose model-changed\r
+ nip\r
+ dup [ model-value ] composed-value swap delegate set-model ;\r
+\r
+M: compose model-activated dup model-changed ;\r
+\r
+M: compose update-model\r
+ dup model-value swap [ set-model ] set-composed-value ;\r
+\r
+M: compose range-value\r
+ [ range-value ] composed-value ;\r
+\r
+M: compose range-page-value\r
+ [ range-page-value ] composed-value ;\r
+\r
+M: compose range-min-value\r
+ [ range-min-value ] composed-value ;\r
+\r
+M: compose range-max-value\r
+ [ range-max-value ] composed-value ;\r
+\r
+M: compose range-max-value*\r
+ [ range-max-value* ] composed-value ;\r
+\r
+M: compose set-range-value\r
+ [ clamp-value ] keep\r
+ [ set-range-value ] set-composed-value ;\r
+\r
+M: compose set-range-page-value\r
+ [ set-range-page-value ] set-composed-value ;\r
+\r
+M: compose set-range-min-value\r
+ [ set-range-min-value ] set-composed-value ;\r
+\r
+M: compose set-range-max-value\r
+ [ set-range-max-value ] set-composed-value ;\r
--- /dev/null
+USING: help.syntax help.markup kernel math classes classes.tuple\r
+calendar models ;\r
+IN: models.delay\r
+\r
+HELP: delay\r
+{ $class-description "Delay models have the same value as their underlying model, however the value only changes after a timer expires. If the underlying model's value changes again before the timer expires, the timer restarts. Delay models are constructed by " { $link <delay> } "." }\r
+{ $examples\r
+ "The following code displays a sliders and a label which is updated half a second after the slider stops changing:"\r
+ { $code\r
+ "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;"\r
+ ": <funny-slider>"\r
+ " 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"\r
+ "<funny-slider> dup gadget."\r
+ "gadget-model 1/2 seconds <delay> [ number>string ] <filter>"\r
+ "<label-control> gadget."\r
+ }\r
+} ;\r
+\r
+HELP: <delay>\r
+{ $values { "model" model } { "timeout" duration } { "delay" delay } }\r
+{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }\r
+{ $examples "See the example in the documentation for " { $link delay } "." } ;\r
+\r
+ARTICLE: "models-delay" "Delay models"\r
+"Delay models are used to implement delayed updating of gadgets in response to user input."\r
+{ $subsection delay }\r
+{ $subsection <delay> } ;\r
+\r
+ABOUT: "models-delay"\r
--- /dev/null
+USING: kernel models alarms ;\r
+IN: models.delay\r
+\r
+TUPLE: delay model timeout alarm ;\r
+\r
+: update-delay-model ( delay -- )\r
+ dup delay-model model-value swap set-model ;\r
+\r
+: <delay> ( model timeout -- delay )\r
+ f delay construct-model\r
+ [ set-delay-timeout ] keep\r
+ [ set-delay-model ] 2keep\r
+ [ add-dependency ] keep ;\r
+\r
+: cancel-delay ( delay -- )\r
+ delay-alarm [ cancel-alarm ] when* ;\r
+\r
+: start-delay ( delay -- )\r
+ dup [ f over set-delay-alarm update-delay-model ] curry\r
+ over delay-timeout later\r
+ swap set-delay-alarm ;\r
+\r
+M: delay model-changed nip dup cancel-delay start-delay ;\r
+\r
+M: delay model-activated update-delay-model ;\r
--- /dev/null
+USING: help.syntax help.markup kernel math classes classes.tuple\r
+calendar models ;\r
+IN: models.filter\r
+\r
+HELP: filter\r
+{ $class-description "Filter model values are computed by applying a quotation to the value of another model. Filters are automatically updated when the underlying model changes. Filters are constructed by " { $link <filter> } "." }\r
+{ $examples\r
+ "The following code displays a label showing the result of applying " { $link sq } " to the value 5:"\r
+ { $code\r
+ "USING: models ui.gadgets.labels ui.gadgets.panes ;"\r
+ "5 <model> [ sq ] <filter> [ number>string ] <filter>"\r
+ "<label-control> gadget."\r
+ }\r
+ "An exercise for the reader is to keep the original model around on the stack, and change its value to 6, observing that the label will immediately display 36."\r
+} ;\r
+\r
+HELP: <filter>\r
+{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "filter" "a new " { $link filter } } }\r
+{ $description "Creates a new instance of " { $link filter } ". The value of the new filter model is computed by applying the quotation to the value." }\r
+{ $examples "See the example in the documentation for " { $link filter } "." } ;\r
+\r
+ARTICLE: "models-filter" "Filter models"\r
+"Filter model values are computed by applying a quotation to the value of another model."\r
+{ $subsection filter }\r
+{ $subsection <filter> } ;\r
+\r
+ABOUT: "models-filter"\r
--- /dev/null
+IN: models.filter.tests\r
+USING: arrays generic kernel math models namespaces sequences assocs\r
+tools.test models.filter ;\r
+\r
+! Test multiple filters\r
+3 <model> "x" set\r
+"x" get [ 2 * ] <filter> dup "z" set\r
+[ 1+ ] <filter> "y" set\r
+[ ] [ "y" get activate-model ] unit-test\r
+[ t ] [ "z" get "x" get model-connections memq? ] unit-test\r
+[ 7 ] [ "y" get model-value ] unit-test\r
+[ ] [ 4 "x" get set-model ] unit-test\r
+[ 9 ] [ "y" get model-value ] unit-test\r
+[ ] [ "y" get deactivate-model ] unit-test\r
+[ f ] [ "z" get "x" get model-connections memq? ] unit-test\r
+\r
+3 <model> "x" set\r
+"x" get [ sq ] <filter> "y" set\r
+\r
+4 "x" get set-model\r
+\r
+"y" get activate-model\r
+[ 16 ] [ "y" get model-value ] unit-test\r
+"y" get deactivate-model\r
--- /dev/null
+USING: models kernel ;\r
+IN: models.filter\r
+\r
+TUPLE: filter model quot ;\r
+\r
+: <filter> ( model quot -- filter )\r
+ f filter construct-model\r
+ [ set-filter-quot ] keep\r
+ [ set-filter-model ] 2keep\r
+ [ add-dependency ] keep ;\r
+\r
+M: filter model-changed\r
+ swap model-value over filter-quot call\r
+ swap set-model ;\r
+\r
+M: filter model-activated dup filter-model swap model-changed ;\r
--- /dev/null
+USING: help.syntax help.markup kernel math classes classes.tuple\r
+calendar models ;\r
+IN: models.history\r
+\r
+HELP: history\r
+{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link <history> } "." } ;\r
+\r
+HELP: <history>\r
+{ $values { "value" object } { "history" "a new " { $link history } } }\r
+{ $description "Creates a new history model with an initial value." } ;\r
+\r
+{ <history> add-history go-back go-forward } related-words\r
+\r
+HELP: go-back\r
+{ $values { "history" history } }\r
+{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;\r
+\r
+HELP: go-forward\r
+{ $values { "history" history } }\r
+{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;\r
+\r
+HELP: add-history\r
+{ $values { "history" history } }\r
+{ $description "Adds the current value to the history." } ;\r
+\r
+ARTICLE: "models-history" "History models"\r
+"History models record previous values."\r
+{ $subsection history }\r
+{ $subsection <history> }\r
+"Recording history:"\r
+{ $subsection add-history }\r
+"Navigating the history:"\r
+{ $subsection go-back }\r
+{ $subsection go-forward } ;\r
+\r
+ABOUT: "models-history"\r
--- /dev/null
+IN: models.history.tests\r
+USING: arrays generic kernel math models namespaces sequences assocs\r
+tools.test models.history ;\r
+\r
+f <history> "history" set\r
+\r
+"history" get add-history\r
+\r
+[ t ] [ "history" get history-back empty? ] unit-test\r
+[ t ] [ "history" get history-forward empty? ] unit-test\r
+\r
+"history" get add-history\r
+3 "history" get set-model\r
+\r
+[ t ] [ "history" get history-back empty? ] unit-test\r
+[ t ] [ "history" get history-forward empty? ] unit-test\r
+\r
+"history" get add-history\r
+4 "history" get set-model\r
+\r
+[ f ] [ "history" get history-back empty? ] unit-test\r
+[ t ] [ "history" get history-forward empty? ] unit-test\r
+\r
+"history" get go-back\r
+\r
+[ 3 ] [ "history" get model-value ] unit-test\r
+\r
+[ t ] [ "history" get history-back empty? ] unit-test\r
+[ f ] [ "history" get history-forward empty? ] unit-test\r
+\r
+"history" get go-forward\r
+\r
+[ 4 ] [ "history" get model-value ] unit-test\r
+\r
+[ f ] [ "history" get history-back empty? ] unit-test\r
+[ t ] [ "history" get history-forward empty? ] unit-test\r
+\r
--- /dev/null
+USING: kernel models sequences ;\r
+IN: models.history\r
+\r
+TUPLE: history back forward ;\r
+\r
+: reset-history ( history -- )\r
+ V{ } clone over set-history-back\r
+ V{ } clone swap set-history-forward ;\r
+\r
+: <history> ( value -- history )\r
+ history construct-model dup reset-history ;\r
+\r
+: (add-history) ( history to -- )\r
+ swap model-value dup [ swap push ] [ 2drop ] if ;\r
+\r
+: go-back/forward ( history to from -- )\r
+ dup empty?\r
+ [ 3drop ]\r
+ [ >r dupd (add-history) r> pop swap set-model ] if ;\r
+\r
+: go-back ( history -- )\r
+ dup history-forward over history-back go-back/forward ;\r
+\r
+: go-forward ( history -- )\r
+ dup history-back over history-forward go-back/forward ;\r
+\r
+: add-history ( history -- )\r
+ dup history-forward delete-all\r
+ dup history-back (add-history) ;\r
--- /dev/null
+IN: models.mapping.tests\r
+USING: arrays generic kernel math models namespaces sequences assocs\r
+tools.test models.mapping ;\r
+\r
+! Test mapping\r
+[ ] [\r
+ [\r
+ 1 <model> "one" set\r
+ 2 <model> "two" set\r
+ ] H{ } make-assoc\r
+ <mapping> "m" set\r
+] unit-test\r
+\r
+[ ] [ "m" get activate-model ] unit-test\r
+\r
+[ H{ { "one" 1 } { "two" 2 } } ] [\r
+ "m" get model-value\r
+] unit-test\r
+\r
+[ ] [\r
+ H{ { "one" 3 } { "two" 4 } } \r
+ "m" get set-model\r
+] unit-test\r
+\r
+[ H{ { "one" 3 } { "two" 4 } } ] [\r
+ "m" get model-value\r
+] unit-test\r
+\r
+[ H{ { "one" 5 } { "two" 4 } } ] [\r
+ 5 "one" "m" get mapping-assoc at set-model\r
+ "m" get model-value\r
+] unit-test\r
+\r
+[ ] [ "m" get deactivate-model ] unit-test\r
--- /dev/null
+USING: models kernel assocs ;\r
+IN: models.mapping\r
+\r
+TUPLE: mapping assoc ;\r
+\r
+: <mapping> ( models -- mapping )\r
+ f mapping construct-model\r
+ over values over set-model-dependencies\r
+ tuck set-mapping-assoc ;\r
+\r
+M: mapping model-changed\r
+ nip\r
+ dup mapping-assoc [ model-value ] assoc-map\r
+ swap delegate set-model ;\r
+\r
+M: mapping model-activated dup model-changed ;\r
+\r
+M: mapping update-model\r
+ dup model-value swap mapping-assoc\r
+ [ swapd at set-model ] curry assoc-each ;\r
HELP: model
{ $class-description "A mutable cell holding a single value. When the value is changed, a sequence of connected objects are notified. Models have the following slots:"
{ $list
- { { $link model-value } " - the value of the model. Use " { $link set-model } " to change the value." }
- { { $link model-connections } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
- { { $link model-dependencies } " - a sequence of models which should have this model added to their sequence of connections when activated." }
- { { $link model-ref } " - a reference count tracking the number of models which depend on this one." }
+ { { $snippet "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
+ { { $snippet "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
+ { { $snippet "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
+ { { $snippet "ref" } " - a reference count tracking the number of models which depend on this one." }
}
"Other classes may delegate to " { $link model } "."
} ;
{ $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value without notifying any observers registered with " { $link add-connection } "." }
{ $notes "There are very few reasons for user code to call this word. Instead, call " { $link change-model } ", which notifies observers." } ;
-HELP: filter
-{ $class-description "Filter model values are computed by applying a quotation to the value of another model. Filters are automatically updated when the underlying model changes. Filters are constructed by " { $link <filter> } "." }
-{ $examples
- "The following code displays a label showing the result of applying " { $link sq } " to the value 5:"
- { $code
- "USING: models ui.gadgets.labels ui.gadgets.panes ;"
- "5 <model> [ sq ] <filter> [ number>string ] <filter>"
- "<label-control> gadget."
- }
- "An exercise for the reader is to keep the original model around on the stack, and change its value to 6, observing that the label will immediately display 36."
-} ;
-
-HELP: <filter>
-{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "filter" "a new " { $link filter } } }
-{ $description "Creates a new instance of " { $link filter } ". The value of the new filter model is computed by applying the quotation to the value." }
-{ $examples "See the example in the documentation for " { $link filter } "." } ;
-
-HELP: compose
-{ $class-description "Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence. Composed models are automatically updated when underlying models change. Composed models are constructed by " { $link <compose> } "."
-$nl
-"A composed model whose children are all " { $link "models-range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." }
-{ $examples
- "The following code displays a pair of sliders, and an updating label showing their current values:"
- { $code
- "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;"
- ": <funny-slider> <x-slider> 100 over set-slider-max ;"
- "<funny-slider> <funny-slider> 2array"
- "dup make-pile gadget."
- "dup [ gadget-model ] map <compose> [ unparse ] <filter>"
- "<label-control> gadget."
- }
-} ;
-
-HELP: <compose>
-{ $values { "models" "a sequence of models" } { "compose" "a new " { $link compose } } }
-{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping " { $link model-value } " over the given sequence of models." }
-{ $examples "See the example in the documentation for " { $link compose } "." } ;
-
-HELP: history
-{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link <history> } "." } ;
-
-HELP: <history>
-{ $values { "value" object } { "history" "a new " { $link history } } }
-{ $description "Creates a new history model with an initial value." } ;
-
-{ <history> add-history go-back go-forward } related-words
-
-HELP: go-back
-{ $values { "history" history } }
-{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
-
-HELP: go-forward
-{ $values { "history" history } }
-{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
-
-HELP: add-history
-{ $values { "history" history } }
-{ $description "Adds the current value to the history." } ;
-
-HELP: delay
-{ $class-description "Delay models have the same value as their underlying model, however the value only changes after a timer expires. If the underlying model's value changes again before the timer expires, the timer restarts. Delay models are constructed by " { $link <delay> } "." }
-{ $examples
- "The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
- { $code
- "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;"
- ": <funny-slider>"
- " 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
- "<funny-slider> dup gadget."
- "gadget-model 1/2 seconds <delay> [ number>string ] <filter>"
- "<label-control> gadget."
- }
-} ;
-
-HELP: <delay>
-{ $values { "model" model } { "timeout" duration } { "delay" delay } }
-{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
-{ $examples "See the example in the documentation for " { $link delay } "." } ;
-
HELP: range-value
{ $values { "model" model } { "value" object } }
{ $contract "Outputs the current value of a range model." } ;
{ $description "Sets the maximum value of a range model." }
{ $side-effects "model" } ;
-HELP: range
-{ $class-description "Range models implement the " { $link "range-model-protocol" } " with real numbers as the minimum, current, maximum, and page size. Range models are created with " { $link <range> } "." }
-{ $notes { $link "ui.gadgets.sliders" } " use range models." } ;
-
-HELP: range-model
-{ $values { "range" range } { "model" model } }
-{ $description "Outputs a model holding a range model's current value." }
-{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
-
-HELP: range-min
-{ $values { "range" range } { "model" model } }
-{ $description "Outputs a model holding a range model's minimum value." }
-{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
-
-HELP: range-max
-{ $values { "range" range } { "model" model } }
-{ $description "Outputs a model holding a range model's maximum value." }
-{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
-
-HELP: range-page
-{ $values { "range" range } { "model" model } }
-{ $description "Outputs a model holding a range model's page size." }
-{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
-
-HELP: move-by
-{ $values { "amount" real } { "range" range } }
-{ $description "Adds a number to a range model's current value." }
-{ $side-effects "range" } ;
-
-HELP: move-by-page
-{ $values { "amount" real } { "range" range } }
-{ $description "Adds a multiple of the page size to a range model's current value." }
-{ $side-effects "range" } ;
-
ARTICLE: "models" "Models"
"The " { $vocab-link "models" } " vocabulary provides basic support for dataflow programming. A model is an observable value. Changing a model's value notifies other objects which depend on the model automatically, and models may depend on each other's values."
$nl
"When using models which are not associated with controls (or when unit testing controls), you must activate and deactivate models manually:"
{ $subsection activate-model }
{ $subsection deactivate-model }
-"Special types of models:"
-{ $subsection "models-filter" }
-{ $subsection "models-compose" }
-{ $subsection "models-history" }
-{ $subsection "models-delay" }
-{ $subsection "models-range" }
{ $subsection "models-impl" } ;
-ARTICLE: "models-filter" "Filter models"
-"Filter model values are computed by applying a quotation to the value of another model."
-{ $subsection filter }
-{ $subsection <filter> } ;
-
-ARTICLE: "models-compose" "Composed models"
-"Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence."
-{ $subsection compose }
-{ $subsection <compose> } ;
-
-ARTICLE: "models-history" "History models"
-"History models record previous values."
-{ $subsection history }
-{ $subsection <history> }
-"Recording history:"
-{ $subsection add-history }
-"Navigating the history:"
-{ $subsection go-back }
-{ $subsection go-forward } ;
-
-ARTICLE: "models-delay" "Delay models"
-"Delay models are used to implement delayed updating of gadgets in response to user input."
-{ $subsection delay }
-{ $subsection <delay> } ;
-
-ARTICLE: "models-range" "Range models"
-"Range models ensure their value is a real number within a fixed range."
-{ $subsection range }
-{ $subsection <range> }
-"Range models conform to a protocol for getting and setting the current value, as well as the endpoints of the range."
-{ $subsection "range-model-protocol" } ;
-
-ARTICLE: "range-model-protocol" "Range model protocol"
-"The range model protocol is implemented by the " { $link range } " and " { $link compose } " classes. User-defined models may implement it too."
-{ $subsection range-value }
-{ $subsection range-page-value }
-{ $subsection range-min-value }
-{ $subsection range-max-value }
-{ $subsection range-max-value* }
-{ $subsection set-range-value }
-{ $subsection set-range-page-value }
-{ $subsection set-range-min-value }
-{ $subsection set-range-max-value } ;
-
ARTICLE: "models-impl" "Implementing models"
-"New types of models can be defined, along the lines of " { $link filter } " and such."
+"New types of models can be defined, for example see " { $vocab-link "models.filter" } "."
$nl
"Models can execute hooks when activated:"
{ $subsection model-activated }
IN: models.tests
-USING: arrays generic kernel math models namespaces sequences assocs
+USING: arrays generic kernel math models models.compose
+namespaces sequences assocs
tools.test ;
TUPLE: model-tester hit? ;
"tester" get
"model-c" get model-value
] unit-test
-
-f <history> "history" set
-
-"history" get add-history
-
-[ t ] [ "history" get history-back empty? ] unit-test
-[ t ] [ "history" get history-forward empty? ] unit-test
-
-"history" get add-history
-3 "history" get set-model
-
-[ t ] [ "history" get history-back empty? ] unit-test
-[ t ] [ "history" get history-forward empty? ] unit-test
-
-"history" get add-history
-4 "history" get set-model
-
-[ f ] [ "history" get history-back empty? ] unit-test
-[ t ] [ "history" get history-forward empty? ] unit-test
-
-"history" get go-back
-
-[ 3 ] [ "history" get model-value ] unit-test
-
-[ t ] [ "history" get history-back empty? ] unit-test
-[ f ] [ "history" get history-forward empty? ] unit-test
-
-"history" get go-forward
-
-[ 4 ] [ "history" get model-value ] unit-test
-
-[ f ] [ "history" get history-back empty? ] unit-test
-[ t ] [ "history" get history-forward empty? ] unit-test
-
-! Test multiple filters
-3 <model> "x" set
-"x" get [ 2 * ] <filter> dup "z" set
-[ 1+ ] <filter> "y" set
-[ ] [ "y" get activate-model ] unit-test
-[ t ] [ "z" get "x" get model-connections memq? ] unit-test
-[ 7 ] [ "y" get model-value ] unit-test
-[ ] [ 4 "x" get set-model ] unit-test
-[ 9 ] [ "y" get model-value ] unit-test
-[ ] [ "y" get deactivate-model ] unit-test
-[ f ] [ "z" get "x" get model-connections memq? ] unit-test
-
-3 <model> "x" set
-"x" get [ sq ] <filter> "y" set
-
-4 "x" get set-model
-
-"y" get activate-model
-[ 16 ] [ "y" get model-value ] unit-test
-"y" get deactivate-model
-
-! Test compose
-[ ] [
- 1 <model> "a" set
- 2 <model> "b" set
- "a" get "b" get 2array <compose> "c" set
-] unit-test
-
-[ ] [ "c" get activate-model ] unit-test
-
-[ { 1 2 } ] [ "c" get model-value ] unit-test
-
-[ ] [ 3 "b" get set-model ] unit-test
-
-[ { 1 3 } ] [ "c" get model-value ] unit-test
-
-[ ] [ { 4 5 } "c" get set-model ] unit-test
-
-[ { 4 5 } ] [ "c" get model-value ] unit-test
-
-[ ] [ "c" get deactivate-model ] unit-test
-
-! Test mapping
-[ ] [
- [
- 1 <model> "one" set
- 2 <model> "two" set
- ] H{ } make-assoc
- <mapping> "m" set
-] unit-test
-
-[ ] [ "m" get activate-model ] unit-test
-
-[ H{ { "one" 1 } { "two" 2 } } ] [
- "m" get model-value
-] unit-test
-
-[ ] [
- H{ { "one" 3 } { "two" 4 } }
- "m" get set-model
-] unit-test
-
-[ H{ { "one" 3 } { "two" 4 } } ] [
- "m" get model-value
-] unit-test
-
-[ H{ { "one" 5 } { "two" 4 } } ] [
- 5 "one" "m" get mapping-assoc at set-model
- "m" get model-value
-] unit-test
-
-[ ] [ "m" get deactivate-model ] unit-test
-
-! Test <range>
-: setup-range 0 0 0 255 <range> ;
-
-! clamp-value should not go past range ends
-[ 0 ] [ -10 setup-range clamp-value ] unit-test
-[ 255 ] [ 2000 setup-range clamp-value ] unit-test
-[ 14 ] [ 14 setup-range clamp-value ] unit-test
-
-! range min/max/page values should be correct
-[ 0 ] [ setup-range range-page-value ] unit-test
-[ 0 ] [ setup-range range-min-value ] unit-test
-[ 255 ] [ setup-range range-max-value ] unit-test
-
-! should be able to set the value within the range and get back
-[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test
-[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test
-[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test
-
-! should be able to change the range min/max/page value
-[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test
-[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test
-[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test
-
-! should be able to move by positive and negative values
-[ 30 ] [ setup-range 30 over move-by range-value ] unit-test
-[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test
-
-! should be able to move by a page of 10
-[ 10 ] [
- setup-range 10 over set-range-page-value
- 1 over move-by-page range-value
-] unit-test
-
-
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: generic kernel math sequences arrays assocs alarms
-calendar math.order ;
+USING: accessors generic kernel math sequences arrays assocs
+alarms calendar math.order ;
IN: models
TUPLE: model < identity-tuple
value connections dependencies ref locked? ;
+: new-model ( value class -- model )
+ new
+ swap >>value
+ V{ } clone >>connections
+ V{ } clone >>dependencies
+ 0 >>ref ; inline
+
: <model> ( value -- model )
- V{ } clone V{ } clone 0 f model boa ;
+ model new-model ;
M: model hashcode* drop model hashcode* ;
: construct-model ( value class -- instance )
>r <model> { set-delegate } r> construct ; inline
-TUPLE: filter model quot ;
-
-: <filter> ( model quot -- filter )
- f filter construct-model
- [ set-filter-quot ] keep
- [ set-filter-model ] 2keep
- [ add-dependency ] keep ;
-
-M: filter model-changed
- swap model-value over filter-quot call
- swap set-model ;
-
-M: filter model-activated dup filter-model swap model-changed ;
-
-TUPLE: compose ;
-
-: <compose> ( models -- compose )
- f compose construct-model
- swap clone over set-model-dependencies ;
-
-: composed-value >r model-dependencies r> map ; inline
-
-: set-composed-value >r model-dependencies r> 2each ; inline
-
-M: compose model-changed
- nip
- dup [ model-value ] composed-value swap delegate set-model ;
-
-M: compose model-activated dup model-changed ;
-
-M: compose update-model
- dup model-value swap [ set-model ] set-composed-value ;
-
-TUPLE: mapping assoc ;
-
-: <mapping> ( models -- mapping )
- f mapping construct-model
- over values over set-model-dependencies
- tuck set-mapping-assoc ;
-
-M: mapping model-changed
- nip
- dup mapping-assoc [ model-value ] assoc-map
- swap delegate set-model ;
-
-M: mapping model-activated dup model-changed ;
-
-M: mapping update-model
- dup model-value swap mapping-assoc
- [ swapd at set-model ] curry assoc-each ;
-
-TUPLE: history back forward ;
-
-: reset-history ( history -- )
- V{ } clone over set-history-back
- V{ } clone swap set-history-forward ;
-
-: <history> ( value -- history )
- history construct-model dup reset-history ;
-
-: (add-history) ( history to -- )
- swap model-value dup [ swap push ] [ 2drop ] if ;
-
-: go-back/forward ( history to from -- )
- dup empty?
- [ 3drop ]
- [ >r dupd (add-history) r> pop swap set-model ] if ;
-
-: go-back ( history -- )
- dup history-forward over history-back go-back/forward ;
-
-: go-forward ( history -- )
- dup history-back over history-forward go-back/forward ;
-
-: add-history ( history -- )
- dup history-forward delete-all
- dup history-back (add-history) ;
-
-TUPLE: delay model timeout alarm ;
-
-: update-delay-model ( delay -- )
- dup delay-model model-value swap set-model ;
-
-: <delay> ( model timeout -- delay )
- f delay construct-model
- [ set-delay-timeout ] keep
- [ set-delay-model ] 2keep
- [ add-dependency ] keep ;
-
-: cancel-delay ( delay -- )
- delay-alarm [ cancel-alarm ] when* ;
-
-: start-delay ( delay -- )
- dup [ f over set-delay-alarm update-delay-model ] curry
- over delay-timeout later
- swap set-delay-alarm ;
-
-M: delay model-changed nip dup cancel-delay start-delay ;
-
-M: delay model-activated update-delay-model ;
-
GENERIC: range-value ( model -- value )
GENERIC: range-page-value ( model -- value )
GENERIC: range-min-value ( model -- value )
GENERIC: set-range-min-value ( value model -- )
GENERIC: set-range-max-value ( value model -- )
-TUPLE: range ;
-
-: <range> ( value min max page -- range )
- 4array [ <model> ] map <compose>
- { set-delegate } range construct ;
-
-: range-model ( range -- model ) model-dependencies first ;
-: range-page ( range -- model ) model-dependencies second ;
-: range-min ( range -- model ) model-dependencies third ;
-: range-max ( range -- model ) model-dependencies fourth ;
-
: clamp-value ( value range -- newvalue )
[ range-min-value max ] keep
range-max-value* min ;
-
-M: range range-value
- [ range-model model-value ] keep clamp-value ;
-
-M: range range-page-value range-page model-value ;
-
-M: range range-min-value range-min model-value ;
-
-M: range range-max-value range-max model-value ;
-
-M: range range-max-value*
- dup range-max-value swap range-page-value [-] ;
-
-M: range set-range-value
- [ clamp-value ] keep range-model set-model ;
-
-M: range set-range-page-value range-page set-model ;
-
-M: range set-range-min-value range-min set-model ;
-
-M: range set-range-max-value range-max set-model ;
-
-M: compose range-value
- [ range-value ] composed-value ;
-
-M: compose range-page-value
- [ range-page-value ] composed-value ;
-
-M: compose range-min-value
- [ range-min-value ] composed-value ;
-
-M: compose range-max-value
- [ range-max-value ] composed-value ;
-
-M: compose range-max-value*
- [ range-max-value* ] composed-value ;
-
-M: compose set-range-value
- [ clamp-value ] keep
- [ set-range-value ] set-composed-value ;
-
-M: compose set-range-page-value
- [ set-range-page-value ] set-composed-value ;
-
-M: compose set-range-min-value
- [ set-range-min-value ] set-composed-value ;
-
-M: compose set-range-max-value
- [ set-range-max-value ] set-composed-value ;
-
-: move-by ( amount range -- )
- [ range-value + ] keep set-range-value ;
-
-: move-by-page ( amount range -- )
- [ range-page-value * ] keep move-by ;
--- /dev/null
+USING: help.syntax help.markup kernel math classes classes.tuple\r
+calendar models ;\r
+IN: models.range\r
+\r
+HELP: range\r
+{ $class-description "Range models implement the " { $link "range-model-protocol" } " with real numbers as the minimum, current, maximum, and page size. Range models are created with " { $link <range> } "." }\r
+{ $notes { $link "ui.gadgets.sliders" } " use range models." } ;\r
+\r
+HELP: range-model\r
+{ $values { "range" range } { "model" model } }\r
+{ $description "Outputs a model holding a range model's current value." }\r
+{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;\r
+\r
+HELP: range-min\r
+{ $values { "range" range } { "model" model } }\r
+{ $description "Outputs a model holding a range model's minimum value." }\r
+{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;\r
+\r
+HELP: range-max\r
+{ $values { "range" range } { "model" model } }\r
+{ $description "Outputs a model holding a range model's maximum value." }\r
+{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;\r
+\r
+HELP: range-page\r
+{ $values { "range" range } { "model" model } }\r
+{ $description "Outputs a model holding a range model's page size." }\r
+{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;\r
+\r
+HELP: move-by\r
+{ $values { "amount" real } { "range" range } }\r
+{ $description "Adds a number to a range model's current value." }\r
+{ $side-effects "range" } ;\r
+\r
+HELP: move-by-page\r
+{ $values { "amount" real } { "range" range } }\r
+{ $description "Adds a multiple of the page size to a range model's current value." }\r
+{ $side-effects "range" } ;\r
+\r
+ARTICLE: "models-range" "Range models"\r
+"Range models ensure their value is a real number within a fixed range."\r
+{ $subsection range }\r
+{ $subsection <range> }\r
+"Range models conform to a protocol for getting and setting the current value, as well as the endpoints of the range."\r
+{ $subsection "range-model-protocol" } ;\r
+\r
+ARTICLE: "range-model-protocol" "Range model protocol"\r
+"The range model protocol is implemented by the " { $link range } " and " { $link compose } " classes. User-defined models may implement it too."\r
+{ $subsection range-value }\r
+{ $subsection range-page-value } \r
+{ $subsection range-min-value } \r
+{ $subsection range-max-value } \r
+{ $subsection range-max-value* } \r
+{ $subsection set-range-value } \r
+{ $subsection set-range-page-value } \r
+{ $subsection set-range-min-value } \r
+{ $subsection set-range-max-value } ;\r
+\r
+ABOUT: "models-range"\r
--- /dev/null
+IN: models.range.tests\r
+USING: arrays generic kernel math models namespaces sequences assocs\r
+tools.test models.range ;\r
+\r
+! Test <range> \r
+: setup-range 0 0 0 255 <range> ;\r
+\r
+! clamp-value should not go past range ends\r
+[ 0 ] [ -10 setup-range clamp-value ] unit-test\r
+[ 255 ] [ 2000 setup-range clamp-value ] unit-test\r
+[ 14 ] [ 14 setup-range clamp-value ] unit-test\r
+\r
+! range min/max/page values should be correct\r
+[ 0 ] [ setup-range range-page-value ] unit-test\r
+[ 0 ] [ setup-range range-min-value ] unit-test\r
+[ 255 ] [ setup-range range-max-value ] unit-test\r
+\r
+! should be able to set the value within the range and get back\r
+[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test\r
+[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test\r
+[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test\r
+\r
+! should be able to change the range min/max/page value\r
+[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test\r
+[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test\r
+[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test\r
+\r
+! should be able to move by positive and negative values\r
+[ 30 ] [ setup-range 30 over move-by range-value ] unit-test\r
+[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test\r
+\r
+! should be able to move by a page of 10\r
+[ 10 ] [ \r
+ setup-range 10 over set-range-page-value \r
+ 1 over move-by-page range-value \r
+] unit-test\r
--- /dev/null
+USING: kernel models arrays sequences math math.order\r
+models.compose ;\r
+IN: models.range\r
+\r
+TUPLE: range ;\r
+\r
+: <range> ( value min max page -- range )\r
+ 4array [ <model> ] map <compose>\r
+ { set-delegate } range construct ;\r
+\r
+: range-model ( range -- model ) model-dependencies first ;\r
+: range-page ( range -- model ) model-dependencies second ;\r
+: range-min ( range -- model ) model-dependencies third ;\r
+: range-max ( range -- model ) model-dependencies fourth ;\r
+\r
+M: range range-value\r
+ [ range-model model-value ] keep clamp-value ;\r
+\r
+M: range range-page-value range-page model-value ;\r
+\r
+M: range range-min-value range-min model-value ;\r
+\r
+M: range range-max-value range-max model-value ;\r
+\r
+M: range range-max-value*\r
+ dup range-max-value swap range-page-value [-] ;\r
+\r
+M: range set-range-value\r
+ [ clamp-value ] keep range-model set-model ;\r
+\r
+M: range set-range-page-value range-page set-model ;\r
+\r
+M: range set-range-min-value range-min set-model ;\r
+\r
+M: range set-range-max-value range-max set-model ;\r
+\r
+: move-by ( amount range -- )\r
+ [ range-value + ] keep set-range-value ;\r
+\r
+: move-by-page ( amount range -- )\r
+ [ range-page-value * ] keep move-by ;\r
USING: kernel io parser lexer words namespaces quotations arrays assocs sequences
- splitting grouping math shuffle ;
+ splitting grouping math generalizations ;
IN: mortar
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences vectors classes classes.algebra
combinators arrays words assocs parser namespaces definitions
-prettyprint prettyprint.backend quotations arrays.lib
+prettyprint prettyprint.backend quotations generalizations
debugger io compiler.units kernel.private effects accessors
hashtables sorting shuffle math.order sets ;
IN: multi-methods
: prepend! ( a b -- ba ) over append 0 pick copy ;
: prepended! ( a b -- ) over append 0 rot copy ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: insert ( seq i obj -- seq ) >r cut r> prefix append ;
+
+: splice ( seq i seq -- seq ) >r cut r> prepend append ;
\ No newline at end of file
HELP: persistent-vector
{ $class-description "The class of persistent vectors." } ;
-HELP: pempty
-{ $values { "pvec" persistent-vector } }
-{ $description "Outputs an empty " { $link persistent-vector } "." } ;
-
ARTICLE: "persistent-vectors" "Persistent vectors"
"A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time."
$nl
{ $subsection new-nth }
{ $subsection ppush }
{ $subsection ppop }
-"The empty persistent vector, used for building up all other persistent vectors:"
-{ $subsection pempty }
"Converting a sequence into a persistent vector:"
{ $subsection >persistent-vector }
"Persistent vectors have a literal syntax:"
{ $subsection POSTPONE: PV{ }
+"The empty persistent vector, written " { $snippet "PV{ }" } ", is used for building up all other persistent vectors."
+$nl
"This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ;
ABOUT: "persistent-vectors"
IN: persistent-vectors.tests
-USING: tools.test persistent-vectors sequences kernel arrays
-random namespaces vectors math math.order ;
+USING: accessors tools.test persistent-vectors sequences kernel
+arrays random namespaces vectors math math.order ;
\ new-nth must-infer
\ ppush must-infer
\ ppop must-infer
-[ 0 ] [ pempty length ] unit-test
+[ 0 ] [ PV{ } length ] unit-test
-[ 1 ] [ 3 pempty ppush length ] unit-test
+[ 1 ] [ 3 PV{ } ppush length ] unit-test
-[ 3 ] [ 3 pempty ppush first ] unit-test
+[ 3 ] [ 3 PV{ } ppush first ] unit-test
[ PV{ 3 1 3 3 7 } ] [
- pempty { 3 1 3 3 7 } [ swap ppush ] each
+ PV{ } { 3 1 3 3 7 } [ swap ppush ] each
] unit-test
[ { 3 1 3 3 7 } ] [
- pempty { 3 1 3 3 7 } [ swap ppush ] each >array
+ PV{ } { 3 1 3 3 7 } [ swap ppush ] each >array
] unit-test
{ 100 1060 2000 10000 100000 1000000 } [
[ ] [ PV{ } 10000 [ push/pop-test ] times drop ] unit-test
+[ PV{ } ] [
+ PV{ }
+ 10000 [ 1 swap ppush ] times
+ 10000 [ ppop ] times
+] unit-test
+
+[ t ] [
+ 10000 >persistent-vector 752 [ ppop ] times dup length sequence=
+] unit-test
+
[ t ] [
100 [
drop
combinators combinators.short-circuit parser prettyprint.backend ;
IN: persistent-vectors
+<PRIVATE
+
+TUPLE: node { children array } { level fixnum } ;
+
+PRIVATE>
+
ERROR: empty-error pvec ;
GENERIC: ppush ( val seq -- seq' )
M: sequence new-nth clone [ set-nth ] keep ;
-TUPLE: persistent-vector count root tail ;
+TUPLE: persistent-vector
+{ count fixnum }
+{ root node initial: T{ node f { } 1 } }
+{ tail node initial: T{ node f { } 0 } } ;
M: persistent-vector length count>> ;
-<PRIVATE
-
-TUPLE: node children level ;
-
: node-size 32 ; inline
: node-mask node-size mod ; inline
: node-shift -5 * shift ; inline
: node-nth ( i node -- obj )
- [ node-mask ] [ children>> ] bi* nth ; inline
+ [ node-mask ] [ children>> ] bi* nth ;
: body-nth ( i node -- i node' )
dup level>> [
dupd [ level>> node-shift ] keep node-nth
- ] times ; inline
+ ] times ;
: tail-offset ( pvec -- n )
[ count>> ] [ tail>> children>> length ] bi - ;
children>> length node-size = ;
: 1node ( val level -- node )
- node new
- swap >>level
- swap 1array >>children ;
+ [ 1array ] dip node boa ;
: 2node ( first second -- node )
[ 2array ] [ drop level>> 1+ ] 2bi node boa ;
] if
] if ;
+! The pop code is really convoluted. I don't understand Rich Hickey's
+! original code. It uses a 'Box' out parameter which is passed around
+! inside a recursive function, and gets mutated along the way to boot.
+! Super-confusing.
: ppop-tail ( pvec -- pvec' )
[ clone [ ppop ] change-children ] change-tail ;
: (ppop-new-tail) ( root -- root' tail' )
dup level>> 1 > [
- dup children>> peek (ppop-new-tail) over
- [ [ swap node-set-last ] dip ]
- [ 2drop ppop-contraction ]
- if
+ dup children>> peek (ppop-new-tail) [
+ dup
+ [ swap node-set-last ]
+ [ drop ppop-contraction drop ]
+ if
+ ] dip
] [
ppop-contraction
] if ;
PRIVATE>
-: pempty ( -- pvec )
- T{ persistent-vector f 0 T{ node f { } 1 } T{ node f { } 0 } } ; inline
-
M: persistent-vector ppop ( pvec -- pvec' )
dup count>> {
{ 0 [ empty-error ] }
- { 1 [ drop pempty ] }
+ { 1 [ drop T{ persistent-vector } ] }
[
[
clone
} case ;
M: persistent-vector like
- drop pempty [ swap ppush ] reduce ;
+ drop T{ persistent-vector } [ swap ppush ] reduce ;
M: persistent-vector equal?
over persistent-vector? [ sequence= ] [ 2drop f ] if ;
-: >persistent-vector ( seq -- pvec ) pempty like ; inline
+: >persistent-vector ( seq -- pvec )
+ T{ persistent-vector } like ;
: PV{ \ } [ >persistent-vector ] parse-literal ; parsing
USING: kernel namespaces threads combinators sequences arrays
math math.functions math.ranges random
- opengl.gl opengl.glu vars multi-methods shuffle
+ opengl.gl opengl.glu vars multi-methods generalizations shuffle
ui
ui.gestures
ui.gadgets
-USING: accessors assocs math kernel shuffle combinators.lib\r
+USING: accessors assocs math kernel shuffle generalizations\r
words quotations arrays combinators sequences math.vectors\r
io.styles prettyprint vocabs sorting io generic locals.private\r
-math.statistics math.order ;\r
+math.statistics math.order combinators.lib ;\r
IN: reports.noise\r
\r
: badness ( word -- n )\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors assocs words sequences arrays compiler\r
tools.time io.styles io prettyprint vocabs kernel sorting\r
-generator optimizer math math.order ;\r
+generator optimizer math math.order math.statistics combinators ;\r
IN: report.optimizer\r
\r
: count-optimization-passes ( nodes n -- n )\r
>r optimize-1\r
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;\r
\r
-: results\r
- [ [ second ] prepose compare ] curry sort 20 tail*\r
- print\r
+: table. ( alist -- )\r
+ 20 short tail*\r
standard-table-style\r
[\r
[ [ [ pprint-cell ] each ] with-row ] each\r
- ] tabular-output ; inline\r
+ ] tabular-output ;\r
+\r
+: results ( results quot title -- )\r
+ print\r
+ [ second ] prepose\r
+ [ [ compare ] curry sort table. ]\r
+ [\r
+ map\r
+ [ "Mean: " write mean >float . ]\r
+ [ "Median: " write median >float . ]\r
+ [ "Standard deviation: " write std >float . ]\r
+ tri\r
+ ] 2bi ; inline\r
\r
: optimizer-measurements ( -- alist )\r
all-words [ compiled>> ] filter\r
] { } map>assoc ;\r
\r
: optimizer-measurements. ( alist -- )\r
- [ [ first ] "Worst number of optimizer passes:" results ]\r
- [ [ second ] "Worst compile times:" results ] bi ;\r
+ {\r
+ [ [ first ] "Optimizer passes:" results ]\r
+ [ [ second ] "Compile times:" results ]\r
+ } cleave ;\r
\r
: optimizer-report ( -- )\r
optimizer-measurements optimizer-measurements. ;\r
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions
arrays math.parser math.private sorting strings ascii macros
-assocs.lib quotations hashtables math.order locals ;
+assocs.lib quotations hashtables math.order locals
+generalizations ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
concat >quotation
[ drop ] compose ;
-: prepare-index ( seq quot -- seq n quot )
- >r dup length r> ; inline
-
-: each-index ( seq quot -- )
- #! quot: ( elt index -- )
- prepare-index 2each ; inline
-
-: map-index ( seq quot -- )
- #! quot: ( elt index -- obj )
- prepare-index 2map ; inline
-
-: reduce-index ( seq identity quot -- )
- #! quot: ( prev elt index -- next )
- swapd each-index ; inline
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: each-percent ( seq quot -- )
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup kernel sequences ;
-IN: shuffle
-
-HELP: npick
-{ $values { "n" "a number" } }
-{ $description "A generalisation 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 shuffle ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }
-}
-{ $see-also dup over pick } ;
-
-HELP: ndup
-{ $values { "n" "a number" } }
-{ $description "A generalisation 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 shuffle ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }
-}
-{ $see-also dup 2dup 3dup } ;
-
-HELP: nnip
-{ $values { "n" "a number" } }
-{ $description "A generalisation of " { $link nip } " and " { $link 2nip }
-" that can work "
-"for any number of items."
-}
-{ $examples
- { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 nnip .s" "4" }
-}
-{ $see-also nip 2nip } ;
-
-HELP: ndrop
-{ $values { "n" "a number" } }
-{ $description "A generalisation of " { $link drop }
-" that can work "
-"for any number of items."
-}
-{ $examples
- { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 ndrop .s" "1" }
-}
-{ $see-also drop 2drop 3drop } ;
-
-HELP: nrot
-{ $values { "n" "a number" } }
-{ $description "A generalisation of " { $link rot } " that works for any "
-"number of items on the stack. "
-}
-{ $examples
- { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }
-}
-{ $see-also rot -nrot } ;
-
-HELP: -nrot
-{ $values { "n" "a number" } }
-{ $description "A generalisation of " { $link -rot } " that works for any "
-"number of items on the stack. "
-}
-{ $examples
- { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }
-}
-{ $see-also rot nrot } ;
-
-ARTICLE: { "shuffle" "overview" } "Extra shuffle words"
-"A number of stack shuffling words for those rare times when you "
-"need to deal with tricky stack situations and can't refactor the "
-"code to work around it."
-{ $subsection ndup }
-{ $subsection npick }
-{ $subsection nrot }
-{ $subsection -nrot }
-{ $subsection nnip }
-{ $subsection ndrop } ;
-
-IN: shuffle
-ABOUT: { "shuffle" "overview" }
\ No newline at end of file
-USING: arrays shuffle kernel math tools.test inference words ;
+USING: shuffle tools.test ;
[ 8 ] [ 5 6 7 8 3nip ] unit-test
-{ 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
-{ t } [ [ 1 1 ndup ] infer >boolean ] unit-test
-{ 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
-{ t } [ [ 1 2 2 nrot ] infer >boolean ] unit-test
-{ 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
-{ t } [ [ 1 2 2 -nrot ] infer >boolean ] unit-test
-{ 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
-{ t } [ [ 1 2 3 4 3 nnip ] infer >boolean ] unit-test
-{ 4 } [ 1 2 3 4 3 nnip ] unit-test
-{ t } [ [ 1 2 3 4 4 ndrop ] infer >boolean ] unit-test
-{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test
[ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test
! Copyright (C) 2007 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences namespaces math inference.transforms
- combinators macros quotations math.ranges fry ;
+USING: kernel generalizations ;
IN: shuffle
-MACRO: npick ( n -- ) 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
-
-MACRO: ndup ( n -- ) dup [ npick ] curry 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 + '[ dup , -nrot ] ;
-
: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
: nipd ( a b c -- b c ) rot drop ; inline
: 4drop ( a b c d -- ) 3drop drop ; inline
: tuckd ( x y z -- z x y z ) 2 ntuck ; inline
-
-MACRO: nrev ( n -- quot )
- [ 1+ ] map
- reverse
- [ [ -nrot ] curry ] map concat ;
USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers
opengl multiline ui.gadgets accessors sequences ui.render ui math
-arrays arrays.lib combinators ;
+arrays generalizations combinators ;
IN: spheres
STRING: plane-vertex-shader
USING: kernel combinators sequences arrays math math.vectors
- shuffle vars ;
+ generalizations vars ;
IN: springies
dup tetris-gadget-tetris maybe-update relayout-1 ;
M: tetris-gadget graft* ( gadget -- )
- dup [ tick ] curry 100 milliseconds from-now 100 milliseconds add-alarm
+ dup [ tick ] curry 100 milliseconds every
swap set-tetris-gadget-alarm ;
M: tetris-gadget ungraft* ( gadget -- )
] with-directory ;\r
\r
: small-enough? ( n -- ? )\r
- >r "test.image" temp-file file-info size>> r> <= ;\r
+ >r "test.image" temp-file file-info size>> r> cell 4 / * <= ;\r
\r
[ ] [ "hello-world" shake-and-bake ] unit-test\r
\r
-[ t ] [\r
- cell 8 = 8 5 ? 100000 * small-enough?\r
-] unit-test\r
+[ t ] [ 500000 small-enough? ] unit-test\r
\r
[ ] [ "sudoku" shake-and-bake ] unit-test\r
\r
-[ t ] [\r
- cell 8 = 20 10 ? 100000 * small-enough?\r
-] unit-test\r
+[ t ] [ 800000 small-enough? ] unit-test\r
\r
[ ] [ "hello-ui" shake-and-bake ] unit-test\r
\r
+[ t ] [ 1300000 small-enough? ] unit-test\r
+\r
[ "staging.math-compiler-ui-strip.image" ] [\r
"hello-ui" deploy-config\r
[ bootstrap-profile staging-image-name file-name ] bind\r
] unit-test\r
\r
-[ t ] [\r
- cell 8 = 35 17 ? 100000 * small-enough?\r
-] unit-test\r
-\r
[ ] [ "maze" shake-and-bake ] unit-test\r
\r
-[ t ] [\r
- cell 8 = 30 15 ? 100000 * small-enough?\r
-] unit-test\r
+[ t ] [ 1200000 small-enough? ] unit-test\r
+\r
+[ ] [ "tetris" shake-and-bake ] unit-test\r
+\r
+[ t ] [ 1500000 small-enough? ] unit-test\r
\r
[ ] [ "bunny" shake-and-bake ] unit-test\r
\r
-[ t ] [\r
- cell 8 = 50 30 ? 100000 * small-enough?\r
-] unit-test\r
+[ t ] [ 2500000 small-enough? ] unit-test\r
\r
{\r
"tools.deploy.test.1"\r
assocs kernel parser lexer strings.parser tools.deploy.config
vocabs sequences words words.private memory kernel.private
continuations io prettyprint vocabs.loader debugger system
-strings sets ;
+strings sets vectors quotations byte-arrays ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
[
[
props>> swap
- '[ drop , member? not ] assoc-filter
- sift-assoc f assoc-like
+ '[ drop , member? not ] assoc-filter sift-assoc
+ dup assoc-empty? [ drop f ] [ >alist >vector ] if
] keep (>>props)
] with each ;
"compiled-uses"
"constraints"
"declared-effect"
+ "default"
+ "default-method"
"default-output-classes"
+ "derived-from"
"identities"
"if-intrinsics"
"infer"
"loc"
"members"
"methods"
+ "method-class"
+ "method-generic"
"combination"
"cannot-infer"
- "default-method"
+ "no-compile"
"optimizer-hooks"
"output-classes"
"participants"
"predicate"
"predicate-definition"
"predicating"
+ "tuple-dispatch-generic"
"slots"
"slot-names"
"specializer"
strip-prettyprint? [
{
+ "break-before"
+ "break-after"
"delimiter"
"flushable"
"foldable"
21 setenv
] [ drop ] if ;
+: compress ( pred string -- )
+ "Compressing " prepend show
+ instances
+ dup H{ } clone [ [ ] cache ] curry map
+ become ; inline
+
+: compress-byte-arrays ( -- )
+ [ byte-array? ] "byte arrays" compress ;
+
+: compress-quotations ( -- )
+ [ quotation? ] "quotations" compress ;
+
+: compress-strings ( -- )
+ [ string? ] "strings" compress ;
+
: finish-deploy ( final-image -- )
"Finishing up" show
>r { } set-datastack r>
{ } set-retainstack
V{ } set-namestack
V{ } set-catchstack
-
"Saving final image" show
[ save-image-and-exit ] call-clear ;
deploy-vocab get vocab-main set-boot-quot*
stripped-word-props >r
stripped-globals strip-globals
- r> strip-words ;
+ r> strip-words
+ compress-byte-arrays
+ compress-quotations
+ compress-strings ;
: (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave
[ [ write-cell ] each ] with-row ;
: (data-room.) ( -- )
- data-room 2 <groups> dup length [
+ data-room 2 <groups> [
[ first2 ] [ number>string "Generation " prepend ] bi*
write-total/used/free
- ] 2each
+ ] each-index
"Decks" write-total
"Cards" write-total ;
IN: tools.profiler.tests
USING: accessors tools.profiler tools.test kernel memory math
-threads alien tools.profiler.private sequences ;
+threads alien tools.profiler.private sequences compiler.units ;
[ t ] [
\ length counter>>
[ 1 ] [ \ foobaz counter>> ] unit-test
[ 2 ] [ \ fooblah counter>> ] unit-test
+
+: recompile-while-profiling-test ( -- ) ;
+
+[ ] [
+ [
+ 333 [ recompile-while-profiling-test ] times
+ { recompile-while-profiling-test } compile
+ 333 [ recompile-while-profiling-test ] times
+ ] profile
+] unit-test
+
+[ 666 ] [ \ recompile-while-profiling-test counter>> ] unit-test
USING: tools.walker io io.streams.string kernel math
math.private namespaces prettyprint sequences tools.test
-continuations math.parser threads arrays tools.walker.debug ;
+continuations math.parser threads arrays tools.walker.debug
+generic.standard sequences.private kernel.private ;
IN: tools.walker.tests
[ { } ] [
[ 5 6 number= ] test-walker
] unit-test
+[ { 0 } ] [
+ [ 0 { array-capacity } declare ] test-walker
+] unit-test
+
[ { f } ] [
[ "XYZ" "XYZ" mismatch ] test-walker
] unit-test
[ { 6 } ]
[ [ [ 3 throw ] [ 2 * ] recover ] test-walker ] unit-test
+[ { T{ no-method f + nth } } ]
+[ [ [ 0 \ + nth ] [ ] recover ] test-walker ] unit-test
+
[ { } ] [
[ "a" "b" set "c" "d" set [ ] test-walker ] with-scope
] unit-test
USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
-sequences.private assocs models arrays accessors
+sequences.private assocs models models.filter arrays accessors
generic generic.standard definitions ;
IN: tools.walker
: (step-into-continuation) ( -- )
continuation callstack >>call break ;
+: (step-into-call-next-method) ( class generic -- )
+ next-method-quot (step-into-quot) ;
+
! Messages sent to walker thread
SYMBOL: step
SYMBOL: step-out
{ if [ (step-into-if) ] }
{ dispatch [ (step-into-dispatch) ] }
{ continuation [ (step-into-continuation) ] }
+ { (call-next-method) [ (step-into-call-next-method) ] }
} [ "step-into" set-word-prop ] assoc-each
{
IN: ui.gadgets.scrollers.tests
-USING: ui.gadgets ui.gadgets.scrollers
-namespaces tools.test kernel models ui.gadgets.viewports
+USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test
+kernel models models.compose models.range ui.gadgets.viewports
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
ui.gadgets.sliders math math.vectors arrays sequences
tools.test.ui ;
USING: accessors arrays ui.gadgets ui.gadgets.viewports
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
-models combinators math.vectors classes.tuple ;
+models models.range models.compose
+combinators math.vectors classes.tuple ;
IN: ui.gadgets.scrollers
TUPLE: scroller viewport x y follows ;
-USING: help.markup help.syntax ui.gadgets models ;
+USING: help.markup help.syntax ui.gadgets models models.range ;
IN: ui.gadgets.sliders
HELP: elevator
USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
ui.gadgets.frames ui.gadgets.grids math.order
ui.gadgets.theme ui.render kernel math namespaces sequences
-vectors models math.vectors math.functions quotations colors ;
+vectors models models.range math.vectors math.functions
+quotations colors ;
IN: ui.gadgets.sliders
TUPLE: elevator direction ;
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors models sequences ui.gadgets.labels
-ui.gadgets.theme ui.gadgets.tracks ui.gadgets.worlds ui.gadgets
-ui kernel calendar ;
+USING: accessors models models.delay models.filter
+sequences ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
+ui.gadgets.worlds ui.gadgets ui kernel calendar ;
IN: ui.gadgets.status-bar
: <status-bar> ( model -- gadget )
: start-drag-timer ( -- )
hand-buttons get-global empty? [
[ drag-gesture ]
- 300 milliseconds from-now
+ 300 milliseconds hence
100 milliseconds
add-alarm drag-timer get-global >box
] when ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: debugger ui.tools.workspace help help.topics kernel
-models ui.commands ui.gadgets ui.gadgets.panes
+models models.history ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
ui.gadgets.buttons compiler.units assocs words vocabs
accessors ;
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: ui.gadgets colors kernel ui.render namespaces
-models sequences ui.gadgets.buttons
+models models.mapping sequences ui.gadgets.buttons
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators continuations documents
hashtables io io.styles kernel math math.order math.vectors
-models namespaces parser lexer prettyprint quotations sequences
-strings threads listener classes.tuple ui.commands ui.gadgets
-ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
-ui.gestures definitions calendar concurrency.flags
-concurrency.mailboxes ui.tools.workspace accessors sets
-destructors ;
+models models.delay namespaces parser lexer prettyprint
+quotations sequences strings threads listener classes.tuple
+ui.commands ui.gadgets ui.gadgets.editors
+ui.gadgets.presentations ui.gadgets.worlds ui.gestures
+definitions calendar concurrency.flags concurrency.mailboxes
+ui.tools.workspace accessors sets destructors ;
IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs ui.tools.interactor ui.tools.listener
ui.tools.workspace help help.topics io.files io.styles kernel
-models namespaces prettyprint quotations sequences sorting
-source-files definitions strings tools.completion tools.crossref
-classes.tuple ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
-ui.gestures ui.operations vocabs words vocabs.loader
-tools.vocabs unicode.case calendar ui ;
+models models.delay models.filter namespaces prettyprint
+quotations sequences sorting source-files definitions strings
+tools.completion tools.crossref classes.tuple ui.commands
+ui.gadgets ui.gadgets.editors ui.gadgets.lists
+ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
+vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
+;
IN: ui.tools.search
TUPLE: live-search field list ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel concurrency.messaging inspector ui.tools.listener
ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar
-ui.gadgets.tracks ui.commands ui.gadgets models
+ui.gadgets.tracks ui.commands ui.gadgets models models.filter
ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
namespaces tools.walker assocs combinators ;
IN: ui.tools.walker
wParam keystroke>gesture <key-up>
hWnd window-focus send-gesture drop ;
-: set-window-active ( hwnd uMsg wParam lParam ? -- n )
- >r 4dup r> 2nip nip
- swap window set-world-active? DefWindowProc ;
+:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
+ ? hwnd window set-world-active?
+ hwnd uMsg wParam lParam DefWindowProc ;
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
{
>r [ first ] [ ] bi r> exec-with-env ;
: with-fork ( child parent -- )
- fork-process dup zero? -roll swap curry if ; inline
+ [ [ fork-process dup zero? ] dip [ drop ] prepose ] dip
+ if ; inline
: SIGKILL 9 ; inline
: SIGTERM 15 ; inline
USING: alien alien.c-types alien.syntax kernel libc structs sequences
continuations byte-arrays strings
math namespaces system combinators vocabs.loader qualified
- accessors inference macros locals shuffle arrays.lib
+ accessors inference macros locals generalizations
unix.types debugger io prettyprint ;
IN: unix
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Planet Factor Administration</t:title>
+ <t:title>Concatenative Planet: Administration</t:title>
<ul>
<t:bind-each t:name="blogroll">
<li>
- <t:a t:href="$planet-factor/admin/edit-blog" t:query="id">
+ <t:a t:href="$planet/admin/edit-blog" t:query="id">
<t:label t:name="name" />
</t:a>
</li>
</ul>
<div>
- <t:a t:href="$planet-factor/admin/new-blog">Add Blog</t:a>
- | <t:button t:action="$planet-factor/admin/update" class="link-button link">Update</t:button>
+ <t:a t:href="$planet/admin/new-blog">Add Blog</t:a>
+ | <t:button t:action="$planet/admin/update" class="link-button link">Update</t:button>
</div>
</t:chloe>
<t:title>Edit Blog</t:title>
- <t:form t:action="$planet-factor/admin/edit-blog" t:for="id">
+ <t:form t:action="$planet/admin/edit-blog" t:for="id">
<table>
</t:form>
- <t:button t:action="$planet-factor/admin/delete-blog" t:for="id" class="link-button link">Delete</t:button>
+ <t:button t:action="$planet/admin/delete-blog" t:for="id" class="link-button link">Delete</t:button>
</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:bind-each t:name="postings">
-
- <p class="news">
- <strong><t:label t:name="title" /></strong> <br/>
- <t:a value="link" class="more">Read More...</t:a>
- </p>
-
- </t:bind-each>
-
-</t:chloe>
<t:title>Edit Blog</t:title>
- <t:form t:action="$planet-factor/admin/new-blog">
+ <t:form t:action="$planet/admin/new-blog">
<table>
<t:style t:include="resource:extra/webapps/planet/planet.css" />
<div class="navbar">
- <t:a t:href="$planet-factor/list">Front Page</t:a>
- | <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
- | <t:a t:href="$planet-factor/admin">Admin</t:a>
+ <t:a t:href="$planet/list">Front Page</t:a>
+ | <t:a t:href="$planet/feed.xml">Atom Feed</t:a>
+ | <t:a t:href="$planet/admin">Admin</t:a>
<t:if t:code="furnace.auth:logged-in?">
<t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
furnace.syndication ;
IN: webapps.planet
-TUPLE: planet-factor < dispatcher ;
+TUPLE: planet < dispatcher ;
-SYMBOL: can-administer-planet-factor?
+SYMBOL: can-administer-planet?
-can-administer-planet-factor? define-capability
+can-administer-planet? define-capability
-TUPLE: planet-factor-admin < dispatcher ;
+TUPLE: planet-admin < dispatcher ;
TUPLE: blog id name www-url feed-url ;
: <edit-blogroll-action> ( -- action )
<page-action>
[ blogroll "blogroll" set-value ] >>init
- { planet-factor "admin" } >>template ;
+ { planet "admin" } >>template ;
: <planet-action> ( -- action )
<page-action>
postings "postings" set-value
] >>init
- { planet-factor "planet" } >>template ;
+ { planet "planet" } >>template ;
: <planet-feed-action> ( -- action )
<feed-action>
[ "Planet Factor" ] >>title
- [ URL" $planet-factor" ] >>url
+ [ URL" $planet" ] >>url
[ postings ] >>entries ;
:: <posting> ( entry name -- entry' )
<action>
[
update-cached-postings
- URL" $planet-factor/admin" <redirect>
+ URL" $planet/admin" <redirect>
] >>submit ;
: <delete-blog-action> ( -- action )
[
"id" value <blog> delete-tuples
- URL" $planet-factor/admin" <redirect>
+ URL" $planet/admin" <redirect>
] >>submit ;
: validate-blog ( -- )
: <new-blog-action> ( -- action )
<page-action>
- { planet-factor "new-blog" } >>template
+ { planet "new-blog" } >>template
[ validate-blog ] >>validate
[ insert-tuple ]
[
<url>
- "$planet-factor/admin/edit-blog" >>path
+ "$planet/admin/edit-blog" >>path
swap id>> "id" set-query-param
<redirect>
]
"id" value <blog> select-tuple from-object
] >>init
- { planet-factor "edit-blog" } >>template
+ { planet "edit-blog" } >>template
[
validate-integer-id
[ update-tuple ]
[
<url>
- "$planet-factor/admin" >>path
+ "$planet/admin" >>path
swap id>> "id" set-query-param
<redirect>
]
tri
] >>submit ;
-: <planet-factor-admin> ( -- responder )
- planet-factor-admin new-dispatcher
+: <planet-admin> ( -- responder )
+ planet-admin new-dispatcher
<edit-blogroll-action> "blogroll" add-main-responder
<update-action> "update" add-responder
<new-blog-action> "new-blog" add-responder
<delete-blog-action> "delete-blog" add-responder
<protected>
"administer Planet Factor" >>description
- { can-administer-planet-factor? } >>capabilities ;
+ { can-administer-planet? } >>capabilities ;
-: <planet-factor> ( -- responder )
- planet-factor new-dispatcher
+: <planet> ( -- responder )
+ planet new-dispatcher
<planet-action> "list" add-main-responder
<planet-feed-action> "feed.xml" add-responder
- <planet-factor-admin> "admin" add-responder
+ <planet-admin> "admin" add-responder
<boilerplate>
- { planet-factor "planet-common" } >>template ;
+ { planet "planet-common" } >>template ;
: start-update-task ( db params -- )
'[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Planet Factor</t:title>
+ <t:title>Concatenative Planet</t:title>
<table width="100%" cellpadding="10">
<tr>
--- /dev/null
+Look at the source to this page by clicking *Edit* to compare the farkup language with resulting output.
+
+= level 1 heading =
+
+== level 2 heading ==
+
+=== level 3 heading ===
+
+==== level 4 heading ====
+
+Here is a paragraph of text, with _emphasized_ and *strong* text, together with an inline %code snippet%. Did you know that E=mc^2^, and L~2~ spaces are cool? Of course, if you want to include \_ special \* characters \^ you \~ can \% do that, too.
+
+You can make [[Wiki Links]] just like that, as well as links to external sites: [[http://sbcl.sourceforge.net]]. [[Factor|Custom link text]] can be used [[http://www.apple.com|with both types of links]].
+
+Images can be embedded in the text:
+
+[[image:http://factorcode.org/graphics/logo.png]]
+
+- a list
+- with three
+- items
+
+|a table|with|four|columns|
+|and|two|rows|...|
+
+Here is some code:
+
+[{HAI
+CAN HAS STDIO?
+VISIBLE "HAI WORLD!"
+KTHXBYE}]
+
+There is syntax highlighting various languages, too:
+
+[factor{PEG: parse-request-line ( string -- triple )
+ #! Triple is { method url version }
+ [
+ 'space' ,
+ 'http-method' ,
+ 'space' ,
+ 'url' ,
+ 'space' ,
+ 'http-version' ,
+ 'space' ,
+ ] seq* just ;}]
+
+Some Java:
+
+[java{/**
+ * Returns the extension of the specified filename, or an empty
+ * string if there is none.
+ * @param path The path
+ */
+public static String getFileExtension(String path)
+{
+ int fsIndex = getLastSeparatorIndex(path);
+ int index = path.lastIndexOf('.');
+ // there could be a dot in the path and no file extension
+ if(index == -1 || index < fsIndex )
+ return "";
+ else
+ return path.substring(index);
+}}]
--- /dev/null
+Congratulations, you are now running your very own Wiki.
+
+You can now click *Edit* below and begin editing the content of the [[Front Page]]. This Wiki uses [[Farkup]] to mark up text.
+
+Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.
<t:a t:href="$wiki">Front Page</t:a>
| <t:a t:href="$wiki/articles">All Articles</t:a>
| <t:a t:href="$wiki/changes">Recent Changes</t:a>
+ | <t:a t:href="$wiki/random">Random Article</t:a>
<t:if t:code="furnace.auth:logged-in?">
</td>
</t:if>
</tr>
+
+ <tr>
+ <td>
+ <t:bind t:name="footer">
+ <small>
+ <t:farkup t:name="content" />
+ </small>
+ </t:bind>
+ </td>
+ </tr>
</table>
</t:chloe>
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel hashtables calendar
+USING: accessors kernel hashtables calendar random assocs
namespaces splitting sequences sorting math.order present
+io.files io.encodings.ascii
syndication
html.components html.forms
http.server
{ wiki "view" } >>template ;
+: <random-article-action> ( -- action )
+ <action>
+ [
+ article new select-tuples random
+ [ title>> ] [ "Front Page" ] if*
+ view-url <redirect>
+ ] >>display ;
+
: amend-article ( revision article -- )
swap id>> >>revision update-tuple ;
{ wiki "page-common" } >>template ;
: init-sidebar ( -- )
- "Sidebar" latest-revision [
- "sidebar" [ from-object ] nest-form
- ] when* ;
+ "Sidebar" latest-revision [ "sidebar" [ from-object ] nest-form ] when*
+ "Footer" latest-revision [ "footer" [ from-object ] nest-form ] when* ;
: <wiki> ( -- dispatcher )
wiki new-dispatcher
<main-article-action> <article-boilerplate> "" add-responder
<view-article-action> <article-boilerplate> "view" add-responder
<view-revision-action> <article-boilerplate> "revision" add-responder
+ <random-article-action> "random" add-responder
<list-revisions-action> <article-boilerplate> "revisions" add-responder
<list-revisions-feed-action> "revisions.atom" add-responder
<diff-action> <article-boilerplate> "diff" add-responder
<boilerplate>
[ init-sidebar ] >>init
{ wiki "wiki-common" } >>template ;
+
+: init-wiki ( -- )
+ "resource:extra/webapps/wiki/initial-content" directory* keys
+ [
+ [ ascii file-contents ] [ file-name "." split1 drop ] bi
+ f <revision>
+ swap >>title
+ swap >>content
+ "slava" >>author
+ now >>date
+ add-revision
+ ] each ;
webapps.user-admin ;
IN: websites.concatenative
-: test-db ( -- db params ) "resource:test.db" sqlite-db ;
+: test-db ( -- params db ) "resource:test.db" sqlite-db ;
: init-factor-db ( -- )
test-db [
<blogs> "blogs" add-responder
<todo-list> "todo" add-responder
<pastebin> "pastebin" add-responder
- <planet-factor> "planet" add-responder
+ <planet> "planet" add-responder
<wiki> "wiki" add-responder
<wee-url> "wee-url" add-responder
<user-admin> "user-admin" add-responder
USING: kernel windows.com windows.com.syntax windows.ole32
-alien alien.syntax tools.test libc alien.c-types arrays.lib
+alien alien.syntax tools.test libc alien.c-types
namespaces arrays continuations accessors math windows.com.wrapper
windows.com.wrapper.private destructors effects ;
IN: windows.com.tests
USING: alien alien.c-types effects kernel windows.ole32
-parser lexer splitting grouping sequences.lib sequences namespaces
-assocs quotations shuffle accessors words macros alien.syntax
+parser lexer splitting grouping sequences namespaces
+assocs quotations generalizations accessors words macros alien.syntax
fry arrays ;
IN: windows.com.syntax
\r
HELP: <com-wrapper>\r
{ $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } }\r
-{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "<com-wrapper>" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper objects and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" }\r
+{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "<com-wrapper>" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper object and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" }\r
{ $code <"\r
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}\r
HRESULT returnOK ( )\r
{ $description "Allocates a COM object using the implementations in the " { $snippet "wrapper" } " object for the vtables and " { $snippet "object" } " for the \"this\" parameter. The COM object is allocated on the heap with an initial reference count of 1. The object will automatically deallocate itself when its reference count reaches 0 as a result of calling " { $link IUnknown::Release } " or " { $link com-release } " on it.\n\nNote that if " { $snippet "wrapper" } " implements multiple interfaces, you cannot count on the returned COM object pointer implementing any particular interface beyond " { $snippet "IUnknown" } ". You will need to use " { $link com-query-interface } " or " { $link IUnknown::QueryInterface } " to ask the object for the particular interface you need." } ;\r
\r
HELP: com-wrapper\r
-{ $class-description "The tuple class used to store COM wrapper information. Objects of this class should be treated as opaque by user code. A com-wrapper can be constructed using the " { $link <com-wrapper> } " constructor and applied to a Factor object using " { $link com-wrap } "." } ;\r
+{ $class-description "The tuple class used to store COM wrapper information. Objects of this class should be treated as opaque by user code. A com-wrapper can be constructed using the " { $link <com-wrapper> } " constructor and applied to a Factor object using " { $link com-wrap } ". When no longer needed, release the com-wrapper's internally allocated data with " { $link dispose } "." } ;\r
USING: alien alien.c-types windows.com.syntax
windows.com.syntax.private windows.com continuations kernel
-sequences.lib namespaces windows.ole32 libc vocabs
-assocs accessors arrays sequences quotations combinators
-math words compiler.units destructors fry
-math.parser combinators.lib ;
+namespaces windows.ole32 libc vocabs assocs accessors arrays
+sequences quotations combinators math words compiler.units
+destructors fry math.parser generalizations ;
IN: windows.com.wrapper
TUPLE: com-wrapper vtbls disposed ;
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax parser namespaces kernel math
-windows.types shuffle math.bitfields alias ;
+windows.types generalizations math.bitfields alias ;
IN: windows.user32
! HKL for ActivateKeyboardLayout
! FUNCTION: SetWindowPlacement
FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ;
-: HWND_BOTTOM ALIEN: 1 ;
-: HWND_NOTOPMOST ALIEN: -2 ;
-: HWND_TOP ALIEN: 0 ;
-: HWND_TOPMOST ALIEN: -1 ;
+: HWND_BOTTOM ( -- alien ) 1 <alien> ;
+: HWND_NOTOPMOST ( -- alien ) -2 <alien> ;
+: HWND_TOP ( -- alien ) 0 <alien> ;
+: HWND_TOPMOST ( -- alien ) -1 <alien> ;
! FUNCTION: SetWindowRgn
! FUNCTION: SetWindowsHookA
T{ extra-attrs f 1 32 V{ T{ name f "" "foo" f } }
} "<?xml version='1.1' foo='bar'?><x/>" xml-error-test
T{ bad-version f 1 28 "5 million" } "<?xml version='5 million'?><x/>" xml-error-test
-T{ notags f 1 0 } "" xml-error-test
+T{ notags f } "" xml-error-test
T{ multitags } "<x/><y/>" xml-error-test
T{ bad-prolog f 1 26 T{ prolog f "1.0" "UTF-8" f }
} "<x/><?xml version='1.0'?>" xml-error-test
T{ employee f "Jane" "CFO" }
}
"PUBLIC"
- "This is a great company"
}
] [
"resource:extra/xmode/utilities/test.xml"
(defvar factor-mode-syntax-table nil
"Syntax table used while in Factor mode.")
+(defcustom factor-display-compilation-output t
+ "Display the REPL buffer before compiling files."
+ :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
+ :group 'factor)
+
+
(if factor-mode-syntax-table
()
(let ((i 0))
(defun factor-run-file ()
(interactive)
+ (when (and (buffer-modified-p)
+ (y-or-n-p (format "Save file %s? " (buffer-file-name))))
+ (save-buffer))
+ (when factor-display-compilation-output
+ (factor-display-output-buffer))
(comint-send-string "*factor*" (format "\"%s\"" (buffer-file-name)))
(comint-send-string "*factor*" " run-file\n"))
+(defun factor-display-output-buffer ()
+ (with-current-buffer "*factor*"
+ (goto-char (point-max))
+ (unless (get-buffer-window (current-buffer) t)
+ (display-buffer (current-buffer) t))))
+
;; (defun factor-send-region (start end)
;; (interactive "r")
;; (comint-send-region "*factor*" start end)
{
F_ALIEN *delegate_alien = untag_object(delegate);
displacement += delegate_alien->displacement;
- alien->alien = F;
+ alien->alien = delegate_alien->alien;
}
else
alien->alien = delegate;
/* Dump all code blocks for debugging */
void dump_heap(F_HEAP *heap)
{
+ CELL size = 0;
+
F_BLOCK *scan = first_block(heap);
while(scan)
status = "free";
break;
case B_ALLOCATED:
+ size += object_size(block_to_compiled(scan)->relocation);
status = "allocated";
break;
case B_MARKED:
+ size += object_size(block_to_compiled(scan)->relocation);
status = "marked";
break;
default:
scan = next_block(heap,scan);
}
+
+ printf("%ld bytes of relocation data\n",size);
}
/* Compute where each block is going to go, after compaction */
void safe_read(int fd, void *data, size_t size)
{
- if(read(fd,data,size) != size)
- fatal_error("error reading fd",errno);
+ ssize_t bytes = read(fd,data,size);
+ if(bytes < 0)
+ {
+ if(errno == EINTR)
+ safe_read(fd,data,size);
+ else
+ fatal_error("error reading fd",errno);
+ }
+ else if(bytes != size)
+ fatal_error("unexpected eof on fd",bytes);
}
void *stdin_loop(void *arg)
for(;;)
{
- size_t bytes = read(0,buf,sizeof(buf));
+ ssize_t bytes = read(0,buf,sizeof(buf));
if(bytes < 0)
{
if(errno == EINTR)
#define OPEN_WRITE(path) fopen(path,"wb")
#define FPRINTF(stream,format,arg) fprintf(stream,format,arg)
+void start_thread(void *(*start_routine)(void *));
+
void init_ffi(void);
void ffi_dlopen(F_DLL *dll);
void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);
/* If we just enabled the profiler, reset call count */
if(profiling_p)
{
- word->counter = tag_fixnum(0);
-
if(!word->profiling)
{
REGISTER_UNTAGGED(word);
for(i = 0; i < length; i++)
{
F_WORD *word = untag_word(array_nth(untag_array(words),i));
+ if(profiling)
+ word->counter = tag_fixnum(0);
update_word_xt(word);
}
&& array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD];
}
+bool jit_ignore_declare_p(F_ARRAY *array, CELL i)
+{
+ return (i + 1) < array_capacity(array)
+ && type_of(array_nth(array,i)) == ARRAY_TYPE
+ && array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD];
+}
+
F_ARRAY *code_to_emit(CELL name)
{
return untag_object(array_nth(untag_object(userenv[name]),0));
for(i = 0; i < length - 1; i++)
{
- if(type_of(array_nth(array,i)) == WORD_TYPE)
- return true;
+ CELL obj = array_nth(array,i);
+ if(type_of(obj) == WORD_TYPE)
+ {
+ if(obj != userenv[JIT_TAG_WORD]
+ && obj != userenv[JIT_EQP_WORD]
+ && obj != userenv[JIT_SLOT_WORD]
+ && obj != userenv[JIT_DROP_WORD]
+ && obj != userenv[JIT_DUP_WORD]
+ && obj != userenv[JIT_TO_R_WORD]
+ && obj != userenv[JIT_FROM_R_WORD]
+ && obj != userenv[JIT_SWAP_WORD]
+ && obj != userenv[JIT_OVER_WORD]
+ && obj != userenv[JIT_FIXNUM_MINUS_WORD]
+ && obj != userenv[JIT_FIXNUM_GE_WORD])
+ {
+ return true;
+ }
+ }
}
return false;
switch(type_of(obj))
{
case WORD_TYPE:
- /* Emit the epilog before the primitive call gate
- so that we save the C stack pointer minus the
- current stack frame. */
- word = untag_object(obj);
+ /* Intrinsics */
+ if(obj == userenv[JIT_TAG_WORD])
+ {
+ EMIT(JIT_TAG,0);
+ }
+ else if(obj == userenv[JIT_EQP_WORD])
+ {
+ GROWABLE_ARRAY_ADD(literals,T);
+ EMIT(JIT_EQP,literals_count - 1);
+ }
+ else if(obj == userenv[JIT_SLOT_WORD])
+ {
+ EMIT(JIT_SLOT,0);
+ }
+ else if(obj == userenv[JIT_DROP_WORD])
+ {
+ EMIT(JIT_DROP,0);
+ }
+ else if(obj == userenv[JIT_DUP_WORD])
+ {
+ EMIT(JIT_DUP,0);
+ }
+ else if(obj == userenv[JIT_TO_R_WORD])
+ {
+ EMIT(JIT_TO_R,0);
+ }
+ else if(obj == userenv[JIT_FROM_R_WORD])
+ {
+ EMIT(JIT_FROM_R,0);
+ }
+ else if(obj == userenv[JIT_SWAP_WORD])
+ {
+ EMIT(JIT_SWAP,0);
+ }
+ else if(obj == userenv[JIT_OVER_WORD])
+ {
+ EMIT(JIT_OVER,0);
+ }
+ else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
+ {
+ EMIT(JIT_FIXNUM_MINUS,0);
+ }
+ else if(obj == userenv[JIT_FIXNUM_GE_WORD])
+ {
+ GROWABLE_ARRAY_ADD(literals,T);
+ EMIT(JIT_FIXNUM_GE,literals_count - 1);
+ }
+ else
+ {
+ /* Emit the epilog before the primitive call gate
+ so that we save the C stack pointer minus the
+ current stack frame. */
+ word = untag_object(obj);
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- if(i == length - 1)
- {
- if(stack_frame)
- EMIT(JIT_EPILOG,0);
+ if(i == length - 1)
+ {
+ if(stack_frame)
+ EMIT(JIT_EPILOG,0);
- EMIT(JIT_WORD_JUMP,literals_count - 1);
+ EMIT(JIT_WORD_JUMP,literals_count - 1);
- tail_call = true;
+ tail_call = true;
+ }
+ else
+ EMIT(JIT_WORD_CALL,literals_count - 1);
}
- else
- EMIT(JIT_WORD_CALL,literals_count - 1);
break;
case WRAPPER_TYPE:
wrapper = untag_object(obj);
tail_call = true;
break;
}
+ else if(jit_ignore_declare_p(untag_object(array),i))
+ {
+ i++;
+ break;
+ }
default:
GROWABLE_ARRAY_ADD(literals,obj);
EMIT(JIT_PUSH_LITERAL,literals_count - 1);
for(i = 0; i < length; i++)
{
CELL obj = array_nth(untag_object(array),i);
- F_WORD *word;
switch(type_of(obj))
{
case WORD_TYPE:
- word = untag_object(obj);
-
- if(i == length - 1)
+ /* Intrinsics */
+ if(obj == userenv[JIT_TAG_WORD])
+ COUNT(JIT_TAG,i)
+ else if(obj == userenv[JIT_EQP_WORD])
+ COUNT(JIT_EQP,i)
+ else if(obj == userenv[JIT_SLOT_WORD])
+ COUNT(JIT_SLOT,i)
+ else if(obj == userenv[JIT_DROP_WORD])
+ COUNT(JIT_DROP,i)
+ else if(obj == userenv[JIT_DUP_WORD])
+ COUNT(JIT_DUP,i)
+ else if(obj == userenv[JIT_TO_R_WORD])
+ COUNT(JIT_TO_R,i)
+ else if(obj == userenv[JIT_FROM_R_WORD])
+ COUNT(JIT_FROM_R,i)
+ else if(obj == userenv[JIT_SWAP_WORD])
+ COUNT(JIT_SWAP,i)
+ else if(obj == userenv[JIT_OVER_WORD])
+ COUNT(JIT_OVER,i)
+ else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
+ COUNT(JIT_FIXNUM_MINUS,i)
+ else if(obj == userenv[JIT_FIXNUM_GE_WORD])
+ COUNT(JIT_FIXNUM_GE,i)
+ else
{
- if(stack_frame)
- COUNT(JIT_EPILOG,i);
-
- COUNT(JIT_WORD_JUMP,i)
-
- tail_call = true;
+ if(i == length - 1)
+ {
+ if(stack_frame)
+ COUNT(JIT_EPILOG,i);
+
+ COUNT(JIT_WORD_JUMP,i)
+
+ tail_call = true;
+ }
+ else
+ COUNT(JIT_WORD_CALL,i)
}
- else
- COUNT(JIT_WORD_CALL,i)
break;
case WRAPPER_TYPE:
COUNT(JIT_PUSH_LITERAL,i)
tail_call = true;
break;
}
+ if(jit_ignore_declare_p(untag_object(array),i))
+ {
+ if(offset == 0) return i;
+
+ i++;
+
+ break;
+ }
default:
COUNT(JIT_PUSH_LITERAL,i)
break;
-#define USER_ENV 64
+#define USER_ENV 70
typedef enum {
NAMESTACK_ENV, /* used by library only */
JIT_EPILOG,
JIT_RETURN,
JIT_PROFILING,
-
- STACK_TRACES_ENV = 36,
-
- UNDEFINED_ENV = 37, /* default quotation for undefined words */
-
- STDERR_ENV = 38, /* stderr FILE* handle */
-
- STAGE2_ENV = 39, /* have we bootstrapped? */
-
- CURRENT_THREAD_ENV = 40,
-
- THREADS_ENV = 41,
- RUN_QUEUE_ENV = 42,
- SLEEP_QUEUE_ENV = 43,
+ JIT_TAG,
+ JIT_TAG_WORD,
+ JIT_EQP,
+ JIT_EQP_WORD,
+ JIT_SLOT,
+ JIT_SLOT_WORD,
+ JIT_DECLARE_WORD,
+ JIT_DROP,
+ JIT_DROP_WORD,
+ JIT_DUP,
+ JIT_DUP_WORD,
+ JIT_TO_R,
+ JIT_TO_R_WORD,
+ JIT_FROM_R,
+ JIT_FROM_R_WORD,
+ JIT_SWAP,
+ JIT_SWAP_WORD,
+ JIT_OVER,
+ JIT_OVER_WORD,
+ JIT_FIXNUM_MINUS,
+ JIT_FIXNUM_MINUS_WORD,
+ JIT_FIXNUM_GE,
+ JIT_FIXNUM_GE_WORD,
+
+ STACK_TRACES_ENV = 59,
+
+ UNDEFINED_ENV = 60, /* default quotation for undefined words */
+
+ STDERR_ENV = 61, /* stderr FILE* handle */
+
+ STAGE2_ENV = 62, /* have we bootstrapped? */
+
+ CURRENT_THREAD_ENV = 63,
+
+ THREADS_ENV = 64,
+ RUN_QUEUE_ENV = 65,
+ SLEEP_QUEUE_ENV = 66,
} F_ENVTYPE;
#define FIRST_SAVE_ENV BOOT_ENV
projects / factor.git / commitdiff