USING: alien alien.syntax alien.c-types kernel tools.test
-sequences system libc alien.strings io.encodings.utf8 ;
+sequences system libc alien.strings io.encodings.utf8
+math.constants ;
IN: alien.c-types.tests
CONSTANT: xyz 123
os windows? cpu x86.64? and [
[ -2147467259 ] [ 2147500037 <long> *long ] unit-test
] when
+
+[ 0 ] [ -10 uchar c-type-clamp ] unit-test
+[ 12 ] [ 12 uchar c-type-clamp ] unit-test
+[ -10 ] [ -10 char c-type-clamp ] unit-test
+[ 127 ] [ 230 char c-type-clamp ] unit-test
+[ t ] [ pi dup float c-type-clamp = ] unit-test
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private math
-namespaces make parser sequences strings words splitting math.parser
-cpu.architecture alien alien.accessors alien.strings quotations
-layouts system compiler.units io io.files io.encodings.binary
-io.streams.memory accessors combinators effects continuations fry
-classes vocabs vocabs.loader words.symbol ;
+math.order math.parser namespaces make parser sequences strings
+words splitting cpu.architecture alien alien.accessors
+alien.strings quotations layouts system compiler.units io
+io.files io.encodings.binary io.streams.memory accessors
+combinators effects continuations fry classes vocabs
+vocabs.loader words.symbol ;
QUALIFIED: math
IN: alien.c-types
\ ulong \ size_t typedef
] with-compilation-unit
+M: char-16-rep rep-component-type drop char ;
+M: uchar-16-rep rep-component-type drop uchar ;
+M: short-8-rep rep-component-type drop short ;
+M: ushort-8-rep rep-component-type drop ushort ;
+M: int-4-rep rep-component-type drop int ;
+M: uint-4-rep rep-component-type drop uint ;
+M: longlong-2-rep rep-component-type drop longlong ;
+M: ulonglong-2-rep rep-component-type drop ulonglong ;
+M: float-4-rep rep-component-type drop float ;
+M: double-2-rep rep-component-type drop double ;
+
+: (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
+: unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
+: (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
+: signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
+
+: c-type-interval ( c-type -- from to )
+ {
+ { [ dup { float double } memq? ] [ drop -1/0. 1/0. ] }
+ { [ dup { char short int long longlong } memq? ] [ signed-interval ] }
+ { [ dup { uchar ushort uint ulong ulonglong } memq? ] [ unsigned-interval ] }
+ } cond ; foldable
+
+: c-type-clamp ( value c-type -- value' ) c-type-interval clamp ; inline
-! Copyright (C) 2008 Slava Pestov
+! copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays alien.c-types alien.data kernel
continuations destructors sequences io openssl openssl.libcrypto
: <evp-md-context> ( -- ctx )
evp-md-context new-disposable
- EVP_MD_CTX <struct> dup EVP_MD_CTX_init >>handle ;
+ EVP_MD_CTX_create >>handle ;
M: evp-md-context dispose*
- handle>> EVP_MD_CTX_cleanup drop ;
+ handle>> EVP_MD_CTX_destroy ;
: with-evp-md-context ( quot -- )
maybe-init-ssl [ <evp-md-context> ] dip with-disposal ; inline
assocs byte-arrays classes.struct classes.tuple.private
combinators compiler.tree.debugger compiler.units destructors
io.encodings.utf8 io.pathnames io.streams.string kernel libc
-literals math mirrors multiline namespaces prettyprint
+literals math mirrors namespaces prettyprint
prettyprint.config see sequences specialized-arrays system
tools.test parser lexer eval layouts ;
FROM: math => float ;
] with-scope
] unit-test
-[ <" USING: alien.c-types classes.struct ;
+[ "USING: alien.c-types classes.struct ;
IN: classes.struct.tests
STRUCT: struct-test-foo
{ x char initial: 0 } { y int initial: 123 } { z bool } ;
-"> ]
+" ]
[ [ struct-test-foo see ] with-string-writer ] unit-test
-[ <" USING: alien.c-types classes.struct ;
+[ "USING: alien.c-types classes.struct ;
IN: classes.struct.tests
UNION-STRUCT: struct-test-float-and-bits
{ f float initial: 0.0 } { bits uint initial: 0 } ;
-"> ]
+" ]
[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
[ {
[ <struct> ] [ struct-slots ] bi
[ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
+M: struct-class initial-value* <struct> ; inline
+
! Struct slot accessors
GENERIC: struct-slot-values ( struct -- sequence )
M: struct-class writer-quot
nip (writer-quot) ;
+: offset-of ( field struct -- offset )
+ struct-slots slot-named offset>> ; inline
+
! c-types
TUPLE: struct-c-type < abstract-c-type
! class definition
<PRIVATE
+GENERIC: binary-zero? ( value -- ? )
+
+M: object binary-zero? drop f ;
+M: f binary-zero? drop t ;
+M: number binary-zero? zero? ;
+M: struct binary-zero?
+ [ byte-length iota ] [ >c-ptr ] bi
+ [ <displaced-alien> *uchar zero? ] curry all? ;
+
+: struct-needs-prototype? ( class -- ? )
+ struct-slots [ initial>> binary-zero? ] all? not ;
+
: make-struct-prototype ( class -- prototype )
- [ "struct-size" word-prop <byte-array> ]
- [ memory>struct ]
- [ struct-slots ] tri
- [
- [ initial>> ]
- [ (writer-quot) ] bi
- over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
- ] each ;
+ dup struct-needs-prototype? [
+ [ "struct-size" word-prop <byte-array> ]
+ [ memory>struct ]
+ [ struct-slots ] tri
+ [
+ [ initial>> ]
+ [ (writer-quot) ] bi
+ over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
+ ] each
+ ] [ drop f ] if ;
: (struct-methods) ( class -- )
[ (define-struct-slot-values-method) ]
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations math sequences
-multiline stack-checker ;
+stack-checker ;
IN: combinators.smart
HELP: input<sequence
{ $description "Infers the number or outputs from the quotation and constructs an array from those outputs." }
{ $examples
{ $example
- <" USING: combinators combinators.smart math prettyprint ;
+ "USING: combinators combinators.smart math prettyprint ;
9 [
{ [ 1 - ] [ 1 + ] [ sq ] } cleave
-] output>array .">
+] output>array ."
"{ 8 10 81 }"
}
} ;
use: src1 src2
literal: rep ;
+PURE-INSN: ##saturated-add-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##add-sub-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
PURE-INSN: ##sub-vector
def: dst
use: src1 src2
literal: rep ;
+PURE-INSN: ##saturated-sub-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
PURE-INSN: ##mul-vector
def: dst
use: src1 src2
literal: rep ;
+PURE-INSN: ##saturated-mul-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
PURE-INSN: ##div-vector
def: dst
use: src1 src2
use: src1 src2
literal: rep ;
-PURE-INSN: ##sqrt-vector
+PURE-INSN: ##horizontal-add-vector
+def: dst/scalar-rep
+use: src
+literal: rep ;
+
+PURE-INSN: ##abs-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##horizontal-add-vector
-def: dst/scalar-rep
+PURE-INSN: ##sqrt-vector
+def: dst
use: src
literal: rep ;
+PURE-INSN: ##and-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##or-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##xor-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
! Boxing and unboxing aliens
PURE-INSN: ##box-alien
def: dst/int-rep
{ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
} enable-intrinsics ;
-: enable-sse2-simd ( -- )
+: enable-simd ( -- )
{
{ math.vectors.simd.intrinsics:assert-positive [ drop ] }
{ math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vs+) [ [ ^^saturated-add-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-v+-) [ [ ^^add-sub-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vs-) [ [ ^^saturated-sub-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vabs) [ [ ^^abs-vector ] emit-unary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
{ math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
+ { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] }
{ math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] }
} enable-intrinsics ;
-: enable-sse3-simd ( -- )
- {
- { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
- } enable-intrinsics ;
-
: emit-intrinsic ( node word -- )
"intrinsic" word-prop call( node -- ) ;
: remove-pending ( live-interval -- )
vreg>> pending-interval-assoc get delete-at ;
+ERROR: bad-vreg vreg ;
+
: (vreg>reg) ( vreg pending -- reg )
! If a live vreg is not in the pending set, then it must
! have been spilled.
- ?at [ spill-slots get at <spill-slot> ] unless ;
+ ?at [ spill-slots get ?at [ <spill-slot> ] [ bad-vreg ] if ] unless ;
: vreg>reg ( vreg -- reg )
pending-interval-assoc get (vreg>reg) ;
: end-block ( bb -- )
[ live-out vregs>regs ] keep register-live-outs get set-at ;
-ERROR: bad-vreg vreg ;
-
: vreg-at-start ( vreg bb -- state )
register-live-ins get at ?at [ bad-vreg ] unless ;
compiler.cfg.linearization.order ;
IN: compiler.cfg.linear-scan.numbering
-: number-instructions ( rpo -- )
- linearization-order 0 [
- instructions>> [
- [ (>>insn#) ] [ drop 2 + ] 2bi
- ] each
- ] reduce drop ;
+ERROR: already-numbered insn ;
+
+: number-instruction ( n insn -- n' )
+ [ nip dup insn#>> [ already-numbered ] [ drop ] if ]
+ [ (>>insn#) ]
+ [ drop 2 + ]
+ 2tri ;
+
+: number-instructions ( cfg -- )
+ linearization-order
+ 0 [ instructions>> [ number-instruction ] each ] reduce
+ drop ;
SYMBOL: check-numbering?
--- /dev/null
+USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization.order
+kernel accessors sequences sets tools.test namespaces ;
+IN: compiler.cfg.linearization.order.tests
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+0 { 1 1 } edges
+1 2 edge
+
+[ t ] [ cfg new 0 get >>entry linearization-order [ id>> ] map all-unique? ] unit-test
USING: accessors assocs deques dlists kernel make sorting
namespaces sequences combinators combinators.short-circuit
fry math sets compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg.loop-detection ;
+compiler.cfg.loop-detection compiler.cfg.predecessors ;
IN: compiler.cfg.linearization.order
! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
successors>> <reversed> [ loop-nesting-at ] sort-with ;
: process-block ( bb -- )
- [ , ]
- [ visited get conjoin ]
- [ sorted-successors [ process-successor ] each ]
- tri ;
+ dup visited? [ drop ] [
+ [ , ]
+ [ visited get conjoin ]
+ [ sorted-successors [ process-successor ] each ]
+ tri
+ ] if ;
: (linearization-order) ( cfg -- bbs )
init-linearization-order
PRIVATE>
: linearization-order ( cfg -- bbs )
- needs-post-order needs-loops
+ needs-post-order needs-loops needs-predecessors
dup linear-order>> [ ] [
dup (linearization-order)
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel locals fry
+USING: accessors assocs kernel locals fry sequences
cpu.architecture
compiler.cfg.rpo
+compiler.cfg.def-use
compiler.cfg.utilities
compiler.cfg.registers
compiler.cfg.instructions
! selection, so it must keep track of representations when introducing
! new values.
+: insert-copy? ( bb vreg -- ? )
+ ! If the last instruction defines a value (which means it is
+ ! ##fixnum-add, ##fixnum-sub or ##fixnum-mul) then we don't
+ ! need to insert a copy since in fact doing so will result
+ ! in incorrect code.
+ [ instructions>> last defs-vreg ] dip eq? not ;
+
:: insert-copy ( bb src rep -- bb dst )
- rep next-vreg-rep :> dst
- bb [ dst src rep src rep-of emit-conversion ] add-instructions
- bb dst ;
+ bb src insert-copy? [
+ rep next-vreg-rep :> dst
+ bb [ dst src rep src rep-of emit-conversion ] add-instructions
+ bb dst
+ ] [ bb src ] if ;
: convert-phi ( ##phi -- )
dup dst>> rep-of '[ [ _ insert-copy ] assoc-map ] change-inputs drop ;
##min-float
##max-float
##add-vector
+ ##saturated-add-vector
+ ##add-sub-vector
##sub-vector
+ ##saturated-sub-vector
##mul-vector
+ ##saturated-mul-vector
##div-vector
##min-vector
- ##max-vector ;
+ ##max-vector
+ ##and-vector
+ ##or-vector
+ ##xor-vector ;
GENERIC: convert-two-operand* ( insn -- )
CODEGEN: ##gather-vector-4 %gather-vector-4
CODEGEN: ##box-vector %box-vector
CODEGEN: ##add-vector %add-vector
+CODEGEN: ##saturated-add-vector %saturated-add-vector
+CODEGEN: ##add-sub-vector %add-sub-vector
CODEGEN: ##sub-vector %sub-vector
+CODEGEN: ##saturated-sub-vector %saturated-sub-vector
CODEGEN: ##mul-vector %mul-vector
+CODEGEN: ##saturated-mul-vector %saturated-mul-vector
CODEGEN: ##div-vector %div-vector
CODEGEN: ##min-vector %min-vector
CODEGEN: ##max-vector %max-vector
CODEGEN: ##sqrt-vector %sqrt-vector
CODEGEN: ##horizontal-add-vector %horizontal-add-vector
+CODEGEN: ##abs-vector %abs-vector
+CODEGEN: ##and-vector %and-vector
+CODEGEN: ##or-vector %or-vector
+CODEGEN: ##xor-vector %xor-vector
CODEGEN: ##box-alien %box-alien
CODEGEN: ##box-displaced-alien %box-displaced-alien
CODEGEN: ##unbox-alien %unbox-alien
namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make alien.c-types combinators.short-circuit
-math.order math.libm math.parser ;
+math.order math.libm math.parser alien.c-types ;
FROM: math => float ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
[ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test
+
+! Bug in linearization
+[ 283686952174081 ] [
+ B{ 1 1 1 1 } [
+ { byte-array } declare
+ [ 0 2 ] dip
+ [
+ [ drop ] 2dip
+ [
+ swap 1 < [ [ ] dip ] [ [ ] dip ] if
+ 0 alien-signed-4
+ ] curry dup bi *
+ ] curry each-integer
+ ] compile-call
+] unit-test
+
+TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-only } ;
+
+[ 2 ] [
+ little-endian?
+ T{ myseq f B{ 1 0 0 0 } B{ 1 0 0 0 } }
+ T{ myseq f B{ 0 0 0 1 } B{ 0 0 0 1 } } ?
+ [
+ { myseq } declare
+ [ 0 2 ] dip dup
+ [
+ [
+ over 1 < [ underlying1>> ] [ [ 1 - ] dip underlying2>> ] if
+ swap 4 * >fixnum alien-signed-4
+ ] bi-curry@ bi * +
+ ] 2curry each-integer
+ ] compile-call
+] unit-test
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel classes.mixin arrays ;
IN: compiler.tests.folding
[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: math arrays ;
+ "USING: math arrays ;
IN: compiler.tests.folding
GENERIC: foldable-generic ( a -- b ) foldable
- M: integer foldable-generic f <array> ;
- "> eval( -- )
+ M: integer foldable-generic f <array> ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USING: math arrays ;
+ "USING: math arrays ;
IN: compiler.tests.folding
- : fold-test ( -- x ) 10 foldable-generic ;
- "> eval( -- )
+ : fold-test ( -- x ) 10 foldable-generic ;"
+ eval( -- )
] unit-test
[ t ] [
compile-cfg ;
: compile-test-bb ( insns -- result )
- V{ T{ ##prologue } T{ ##branch } } 0 test-bb
+ V{ T{ ##prologue } T{ ##branch } } [ clone ] map 0 test-bb
V{
T{ ##inc-d f 1 }
T{ ##replace f 0 D 0 }
[ t ] [
V{
T{ ##load-reference f 0 { t f t } }
- T{ ##slot-imm f 0 0 2 $[ array tag-number ] 2 }
+ T{ ##slot-imm f 0 0 2 $[ array tag-number ] }
} compile-test-bb
] unit-test
[ t ] [ \ <tuple>-regression optimized? ] unit-test
-GENERIC: foozul ( a -- b )
-M: reversed foozul ;
-M: integer foozul ;
-M: slice foozul ;
-
-[ t ] [
- reversed \ foozul specific-method
- reversed \ foozul method
- eq?
-] unit-test
-
! regression
: constant-fold-2 ( -- value ) f ; foldable
: constant-fold-3 ( -- value ) 4 ; foldable
-USING: eval tools.test compiler.units vocabs multiline words
-kernel ;
+USING: eval tools.test compiler.units vocabs words kernel ;
IN: compiler.tests.redefine10
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math classes ;
+ "USING: kernel math classes ;
IN: compiler.tests.redefine10
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
- : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
- "> eval( -- )
+ : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: math
+ "USE: math
IN: compiler.tests.redefine10
- INSTANCE: float my-mixin
- "> eval( -- )
+ INSTANCE: float my-mixin"
+ eval( -- )
] unit-test
[ 2.0 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel classes.mixin arrays ;
IN: compiler.tests.redefine11
[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math classes arrays ;
+ "USING: kernel math classes arrays ;
IN: compiler.tests.redefine11
MIXIN: my-mixin
INSTANCE: array my-mixin
GENERIC: my-generic ( a -- b )
M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ;
- : my-inline ( -- b ) { } my-generic ;
- "> eval( -- )
+ : my-inline ( -- b ) { } my-generic ;"
+ eval( -- )
] unit-test
[ ] [
-USING: eval tools.test compiler.units vocabs multiline words
-kernel ;
+USING: eval tools.test compiler.units vocabs words kernel ;
IN: compiler.tests.redefine5
! Regression: if dispatch was eliminated but method was not inlined,
[ "compiler.tests.redefine5" forget-vocab ] with-compilation-unit
[ ] [
- <"
- USING: sorting kernel math.order ;
+ "USING: sorting kernel math.order ;
IN: compiler.tests.redefine5
GENERIC: my-generic ( a -- b )
M: object my-generic [ <=> ] sort ;
- : my-inline ( a -- b ) my-generic ;
- "> eval( -- )
+ : my-inline ( a -- b ) my-generic ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: kernel
+ "USE: kernel
IN: compiler.tests.redefine5
TUPLE: my-tuple ;
- M: my-tuple my-generic drop 0 ;
- "> eval( -- )
+ M: my-tuple my-generic drop 0 ;" eval( -- )
] unit-test
[ 0 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel ;
IN: compiler.tests.redefine6
[ ] [ [ "compiler.tests.redefine6" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel kernel.private ;
+ "USING: kernel kernel.private ;
IN: compiler.tests.redefine6
GENERIC: my-generic ( a -- b )
MIXIN: my-mixin
M: my-mixin my-generic drop 0 ;
- : my-inline ( a -- b ) { my-mixin } declare my-generic ;
- "> eval( -- )
+ : my-inline ( a -- b ) { my-mixin } declare my-generic ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USING: kernel ;
+ "USING: kernel ;
IN: compiler.tests.redefine6
TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ;
- INSTANCE: my-tuple my-mixin
- "> eval( -- )
+ INSTANCE: my-tuple my-mixin"
+ eval( -- )
] unit-test
[ 1 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel ;
IN: compiler.tests.redefine7
[ ] [ [ "compiler.tests.redefine7" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math ;
+ "USING: kernel math ;
IN: compiler.tests.redefine7
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
- : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
- "> eval( -- )
+ : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: math
+ "USE: math
IN: compiler.tests.redefine7
- INSTANCE: float my-mixin
- "> eval( -- )
+ INSTANCE: float my-mixin"
+ eval( -- )
] unit-test
[ 2.0 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel ;
IN: compiler.tests.redefine8
[ ] [ [ "compiler.tests.redefine8" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math math.order sorting ;
+ "USING: kernel math math.order sorting ;
IN: compiler.tests.redefine8
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
GENERIC: my-generic ( a -- b )
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
- M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
- "> eval( -- )
+ M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: math
+ "USE: math
IN: compiler.tests.redefine8
- INSTANCE: float my-mixin
- "> eval( -- )
+ INSTANCE: float my-mixin"
+ eval( -- )
] unit-test
[ 2.0 ] [
-USING: eval tools.test compiler.units vocabs multiline words
+USING: eval tools.test compiler.units vocabs words
kernel generic.math ;
IN: compiler.tests.redefine9
[ ] [ [ "compiler.tests.redefine9" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
- <"
- USING: kernel math math.order sorting ;
+ "USING: kernel math math.order sorting ;
IN: compiler.tests.redefine9
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
GENERIC: my-generic ( a -- b )
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
- M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
- "> eval( -- )
+ M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;"
+ eval( -- )
] unit-test
[ ] [
- <"
- USE: math
+ "USE: math
IN: compiler.tests.redefine9
TUPLE: my-tuple ;
- INSTANCE: my-tuple my-mixin
- "> eval( -- )
+ INSTANCE: my-tuple my-mixin"
+ eval( -- )
] unit-test
[
! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel sequences assocs accessors namespaces
math.intervals arrays classes.algebra combinators columns
-stack-checker.branches
+stack-checker.branches locals
compiler.utilities
compiler.tree
compiler.tree.combinators
[ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ]
bi ;
+:: update-constraints ( new old -- )
+ new [| key value | key old [ value append ] change-at ] assoc-each ;
+
+: include-child-constraints ( i -- )
+ infer-children-data get nth constraints swap at last
+ constraints get last update-constraints ;
+
: branch-phi-constraints ( output values booleans -- )
{
{
swap t-->
]
}
- ! {
- ! { { t f } { } }
- ! [ B
- ! first
- ! [ [ =t ] bi@ <--> ]
- ! [ [ =f ] bi@ <--> ] 2bi /\
- ! ]
- ! }
- ! {
- ! { { } { t f } }
- ! [
- ! second
- ! [ [ =t ] bi@ <--> ]
- ! [ [ =f ] bi@ <--> ] 2bi /\
- ! ]
- ! }
+ {
+ { { t f } { } }
+ [
+ first
+ [ [ =t ] bi@ <--> ]
+ [ [ =f ] bi@ <--> ] 2bi /\
+ 0 include-child-constraints
+ ]
+ }
+ {
+ { { } { t f } }
+ [
+ second
+ [ [ =t ] bi@ <--> ]
+ [ [ =f ] bi@ <--> ] 2bi /\
+ 1 include-child-constraints
+ ]
+ }
[ 3drop f ]
} case assume ;
] 3each
] [ drop ] if ;
-M: #phi propagate-around ( #phi -- )
- [ propagate-before ] [ propagate-after ] bi ;
-
M: #branch propagate-around
dup live-branches >>live-branches
[ infer-children ] [ annotate-node ] bi ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs math math.intervals kernel accessors
sequences namespaces classes classes.algebra
-combinators words
+combinators words combinators.short-circuit
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.copy ;
! Boolean constraints
TUPLE: true-constraint value ;
-: =t ( value -- constriant ) resolve-copy true-constraint boa ;
+: =t ( value -- constraint ) resolve-copy true-constraint boa ;
+
+: follow-implications ( constraint -- )
+ constraints get assoc-stack [ assume ] when* ;
M: true-constraint assume*
[ \ f class-not <class-info> swap value>> refine-value-info ]
- [ constraints get assoc-stack [ assume ] when* ]
+ [ follow-implications ]
bi ;
M: true-constraint satisfied?
- value>> value-info class>> true-class? ;
+ value>> value-info class>>
+ { [ true-class? ] [ null-class? not ] } 1&& ;
TUPLE: false-constraint value ;
M: false-constraint assume*
[ \ f <class-info> swap value>> refine-value-info ]
- [ constraints get assoc-stack [ assume ] when* ]
+ [ follow-implications ]
bi ;
M: false-constraint satisfied?
- value>> value-info class>> false-class? ;
+ value>> value-info class>>
+ { [ false-class? ] [ null-class? not ] } 1&& ;
! Class constraints
TUPLE: class-constraint value class ;
C: --> implication
-: assume-implication ( p q -- )
+: assume-implication ( q p -- )
[ constraints get [ assoc-stack swap suffix ] 2keep last set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
: refine-value-info ( info value -- )
resolve-copy value-infos get
- [ assoc-stack value-info-intersect ] 2keep
+ [ assoc-stack [ value-info-intersect ] when* ] 2keep
last set-at ;
: value-literal ( value -- obj ? )
2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> dup ] dip
- specific-method
+ method-for-class
] if
] if ;
compiler.tree.propagation.call-effect
compiler.tree.propagation.transforms
compiler.tree.propagation.simd ;
+FROM: alien.c-types => (signed-interval) (unsigned-interval) ;
IN: compiler.tree.propagation.known-words
{ + - * / }
alien-unsigned-8
} [
dup name>> {
- {
- [ "alien-signed-" ?head ]
- [ string>number 8 * 1 - 2^ dup neg swap 1 - [a,b] ]
- }
- {
- [ "alien-unsigned-" ?head ]
- [ string>number 8 * 2^ 1 - 0 swap [a,b] ]
- }
- } cond
+ { [ "alien-signed-" ?head ] [ string>number (signed-interval) ] }
+ { [ "alien-unsigned-" ?head ] [ string>number (unsigned-interval) ] }
+ } cond [a,b]
[ fits-in-fixnum? fixnum integer ? ] keep <class/interval-info>
'[ 2drop _ ] "outputs" set-word-prop
] each
[ { word object } declare equal? ] final-classes
] unit-test
-! [ V{ string } ] [
-! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
-! ] unit-test
+[ V{ string } ] [
+ [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
+] unit-test
-! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
+[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
-! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
+[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
-! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
+[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
-! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
+[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
! generalize-counter-interval wasn't being called in all the right places.
! bug found by littledan
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors byte-arrays combinators fry
+USING: accessors byte-arrays combinators fry sequences
compiler.tree.propagation.info cpu.architecture kernel words math
math.intervals math.vectors.simd.intrinsics ;
IN: compiler.tree.propagation.simd
-\ (simd-v+) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-v-) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-v*) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-v/) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-vmin) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-vmax) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-vsqrt) { byte-array } "default-output-classes" set-word-prop
+{
+ (simd-v+)
+ (simd-v-)
+ (simd-v+-)
+ (simd-v*)
+ (simd-v/)
+ (simd-vmin)
+ (simd-vmax)
+ (simd-sum)
+ (simd-vabs)
+ (simd-vsqrt)
+ (simd-vbitand)
+ (simd-vbitor)
+ (simd-vbitxor)
+ (simd-broadcast)
+ (simd-gather-2)
+ (simd-gather-4)
+ alien-vector
+} [ { byte-array } "default-output-classes" set-word-prop ] each
\ (simd-sum) [
nip dup literal?>> [
literal>> scalar-rep-of {
{ float-rep [ float ] }
{ double-rep [ float ] }
+ { int-rep [ integer ] }
} case
] [ drop real ] if
<class-info>
] "outputs" set-word-prop
-\ (simd-broadcast) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-gather-2) { byte-array } "default-output-classes" set-word-prop
-
-\ (simd-gather-4) { byte-array } "default-output-classes" set-word-prop
-
\ assert-positive [
real [0,inf] <class/interval-info> value-info-intersect
] "outputs" set-word-prop
-\ alien-vector { byte-array } "default-output-classes" set-word-prop
-
! If SIMD is not available, inline alien-vector and set-alien-vector
! to get a speedup
: inline-unless-intrinsic ( word -- )
! If first input has a known type and second input is an
! object, we convert this to [ swap equal? ].
in-d>> first2 value-info class>> object class= [
- value-info class>> \ equal? specific-method
+ value-info class>> \ equal? method-for-class
[ swap equal? ] f ?
] [ drop f ] if
] "custom-inlining" set-word-prop
! On x86, floating point registers are really vector registers
SINGLETONS:
-float-4-rep
-double-2-rep
char-16-rep
uchar-16-rep
short-8-rep
ushort-8-rep
int-4-rep
-uint-4-rep ;
+uint-4-rep
+longlong-2-rep
+ulonglong-2-rep ;
-UNION: vector-rep
+SINGLETONS:
float-4-rep
-double-2-rep
+double-2-rep ;
+
+UNION: int-vector-rep
char-16-rep
uchar-16-rep
short-8-rep
ushort-8-rep
int-4-rep
-uint-4-rep ;
+uint-4-rep
+longlong-2-rep
+ulonglong-2-rep ;
+
+UNION: float-vector-rep
+float-4-rep
+double-2-rep ;
+
+UNION: vector-rep
+int-vector-rep
+float-vector-rep ;
UNION: representation
any-rep
M: stack-params rep-size drop cell ;
M: vector-rep rep-size drop 16 ;
+GENERIC: rep-component-type ( rep -- n )
+
+! Methods defined in alien.c-types
+
GENERIC: scalar-rep-of ( rep -- rep' )
M: float-4-rep scalar-rep-of drop float-rep ;
M: double-2-rep scalar-rep-of drop double-rep ;
+M: int-vector-rep scalar-rep-of drop int-rep ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
HOOK: %broadcast-vector cpu ( dst src rep -- )
HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- )
HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
-
HOOK: %add-vector cpu ( dst src1 src2 rep -- )
+HOOK: %saturated-add-vector cpu ( dst src1 src2 rep -- )
+HOOK: %add-sub-vector cpu ( dst src1 src2 rep -- )
HOOK: %sub-vector cpu ( dst src1 src2 rep -- )
+HOOK: %saturated-sub-vector cpu ( dst src1 src2 rep -- )
HOOK: %mul-vector cpu ( dst src1 src2 rep -- )
+HOOK: %saturated-mul-vector cpu ( dst src1 src2 rep -- )
HOOK: %div-vector cpu ( dst src1 src2 rep -- )
HOOK: %min-vector cpu ( dst src1 src2 rep -- )
HOOK: %max-vector cpu ( dst src1 src2 rep -- )
HOOK: %sqrt-vector cpu ( dst src rep -- )
HOOK: %horizontal-add-vector cpu ( dst src rep -- )
+HOOK: %abs-vector cpu ( dst src rep -- )
+HOOK: %and-vector cpu ( dst src1 src2 rep -- )
+HOOK: %or-vector cpu ( dst src1 src2 rep -- )
+HOOK: %xor-vector cpu ( dst src1 src2 rep -- )
+
+HOOK: %broadcast-vector-reps cpu ( -- reps )
+HOOK: %gather-vector-2-reps cpu ( -- reps )
+HOOK: %gather-vector-4-reps cpu ( -- reps )
+HOOK: %add-vector-reps cpu ( -- reps )
+HOOK: %saturated-add-vector-reps cpu ( -- reps )
+HOOK: %add-sub-vector-reps cpu ( -- reps )
+HOOK: %sub-vector-reps cpu ( -- reps )
+HOOK: %saturated-sub-vector-reps cpu ( -- reps )
+HOOK: %mul-vector-reps cpu ( -- reps )
+HOOK: %saturated-mul-vector-reps cpu ( -- reps )
+HOOK: %div-vector-reps cpu ( -- reps )
+HOOK: %min-vector-reps cpu ( -- reps )
+HOOK: %max-vector-reps cpu ( -- reps )
+HOOK: %sqrt-vector-reps cpu ( -- reps )
+HOOK: %horizontal-add-vector-reps cpu ( -- reps )
+HOOK: %abs-vector-reps cpu ( -- reps )
+HOOK: %and-vector-reps cpu ( -- reps )
+HOOK: %or-vector-reps cpu ( -- reps )
+HOOK: %xor-vector-reps cpu ( -- reps )
HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
compiler.cfg.stack-frame compiler.cfg.build-stack-frame
compiler.units compiler.constants compiler.codegen vm ;
FROM: cpu.ppc.assembler => B ;
+FROM: layouts => cell ;
FROM: math => float ;
IN: cpu.ppc
dst 1 4 scratch@ LWZ ;
M: ppc %copy ( dst src rep -- )
- {
- { int-rep [ MR ] }
- { double-rep [ FMR ] }
- } case ;
+ 2over eq? [ 3drop ] [
+ {
+ { int-rep [ MR ] }
+ { double-rep [ FMR ] }
+ } case
+ ] if ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
[ float-regs param-regs nth 1 ] [ n>> spill@ ] bi* LFD ;
: float-function-return ( reg -- )
- float-regs return-reg 2dup = [ 2drop ] [ FMR ] if ;
+ float-regs return-reg double-rep %copy ;
M:: ppc %unary-float-function ( dst src func -- )
0 src float-function-param
dst float-function-return ;
! Internal format is always double-precision on PowerPC
-M: ppc %single>double-float FMR ;
-
-M: ppc %double>single-float FMR ;
+M: ppc %single>double-float double-rep %copy ;
+M: ppc %double>single-float double-rep %copy ;
+
+! VMX/AltiVec not supported yet
+M: %broadcast-vector-reps drop { } ;
+M: %gather-vector-2-reps drop { } ;
+M: %gather-vector-4-reps drop { } ;
+M: %add-vector-reps drop { } ;
+M: %saturated-add-vector-reps drop { } ;
+M: %add-sub-vector-reps drop { } ;
+M: %sub-vector-reps drop { } ;
+M: %saturated-sub-vector-reps drop { } ;
+M: %mul-vector-reps drop { } ;
+M: %saturated-mul-vector-reps drop { } ;
+M: %div-vector-reps drop { } ;
+M: %min-vector-reps drop { } ;
+M: %max-vector-reps drop { } ;
+M: %sqrt-vector-reps drop { } ;
+M: %horizontal-add-vector-reps drop { } ;
+M: %abs-vector-reps drop { } ;
+M: %and-vector-reps drop { } ;
+M: %or-vector-reps drop { } ;
+M: %xor-vector-reps drop { } ;
M: ppc %unbox-alien ( dst src -- )
alien-offset LWZ ;
4 "double" c-type (>>align)
] unless
-"cpu.x86.features" require
+check-sse
{ [ over integer? ] [ R11 swap MOV param@ R11 MOV ] }
} cond ;
-M: x86 %save-param-reg [ param@ ] 2dip copy-register ;
+M: x86 %save-param-reg [ param@ ] 2dip %copy ;
-M: x86 %load-param-reg [ swap param@ ] dip copy-register ;
+M: x86 %load-param-reg [ swap param@ ] dip %copy ;
: with-return-regs ( quot -- )
[
[ [ 0 ] dip reg-class-of param-reg ]
[ reg-class-of return-reg ]
[ ]
- tri copy-register ;
+ tri %copy ;
[ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ;
: float-function-return ( reg -- )
- float-regs return-reg double-rep copy-register ;
+ float-regs return-reg double-rep %copy ;
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
{ [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
} cond
-"cpu.x86.features" require
+check-sse
M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
! MOV where the src is immediate.
+<PRIVATE
+
GENERIC: (MOV-I) ( src dst -- )
M: register (MOV-I) t HEX: b8 short-operand cell, ;
M: operand (MOV-I)
{ BIN: 000 t HEX: c6 }
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
+PRIVATE>
+
GENERIC: MOV ( dst src -- )
M: immediate MOV swap (MOV-I) ;
M: operand MOV HEX: 88 2-operand ;
M: integer CALL HEX: e8 , 4, ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
+<PRIVATE
+
GENERIC# JUMPcc 1 ( addr opcode -- )
M: integer JUMPcc extended-opcode, 4, ;
+PRIVATE>
+
: JO ( dst -- ) HEX: 80 JUMPcc ;
: JNO ( dst -- ) HEX: 81 JUMPcc ;
: JB ( dst -- ) HEX: 82 JUMPcc ;
: CDQ ( -- ) HEX: 99 , ;
: CQO ( -- ) HEX: 48 , CDQ ;
+<PRIVATE
+
: (SHIFT) ( dst src op -- )
over CL eq? [
nip t HEX: d3 3array 1-operand
swapd t HEX: c0 3array immediate-1
] if ; inline
+PRIVATE>
+
: ROL ( dst n -- ) BIN: 000 (SHIFT) ;
: ROR ( dst n -- ) BIN: 001 (SHIFT) ;
: RCL ( dst n -- ) BIN: 010 (SHIFT) ;
--- /dev/null
+Slava Pestov
+Joe Groff
--- /dev/null
+x86 registers and memory operands
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel math math.order math.parser namespaces
-alien.c-types alien.syntax combinators locals init io cpu.x86
+USING: system kernel memoize math math.order math.parser
+namespaces alien.c-types alien.syntax combinators locals init io
compiler compiler.units accessors ;
IN: cpu.x86.features
PRIVATE>
-ALIAS: sse-version sse_version
+MEMO: sse-version ( -- n )
+ sse_version
+ "sse-version" get string>number [ min ] when* ;
+
+[ \ sse-version reset-memoized ] "cpu.x86.features" add-init-hook
+
+: sse? ( -- ? ) sse-version 10 >= ;
+: sse2? ( -- ? ) sse-version 20 >= ;
+: sse3? ( -- ? ) sse-version 30 >= ;
+: ssse3? ( -- ? ) sse-version 33 >= ;
+: sse4.1? ( -- ? ) sse-version 41 >= ;
+: sse4.2? ( -- ? ) sse-version 42 >= ;
: sse-string ( version -- string )
{
: count-instructions ( quot -- n )
instruction-count [ call ] dip instruction-count swap - ; inline
-
-USING: cpu.x86.features cpu.x86.features.private ;
-
-:: install-sse-check ( version -- )
- [
- sse-version version < [
- "This image was built to use " write
- version sse-string write
- " but your CPU only supports " write
- sse-version sse-string write "." print
- "You will need to bootstrap Factor again." print
- flush
- 1 exit
- ] when
- ] "cpu.x86" add-init-hook ;
-
-: enable-sse ( version -- )
- {
- { 00 [ ] }
- { 10 [ ] }
- { 20 [ enable-sse2 ] }
- { 30 [ enable-sse3 ] }
- { 33 [ enable-sse3 ] }
- { 41 [ enable-sse3 ] }
- { 42 [ enable-sse3 ] }
- } case ;
-
-[ { sse_version } compile ] with-optimizer
-
-"Checking for multimedia extensions: " write sse-version
-"sse-version" get [ string>number min ] when*
-[ sse-string write " detected" print ]
-[ install-sse-check ]
-[ enable-sse ] tri
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
-cpu.architecture kernel kernel.private math memory namespaces make
-sequences words system layouts combinators math.order fry locals
-compiler.constants vm byte-arrays
+cpu.x86.features cpu.x86.features.private cpu.architecture kernel
+kernel.private math memory namespaces make sequences words system
+layouts combinators math.order fry locals compiler.constants
+byte-arrays io macros quotations compiler compiler.units init vm
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
M: double-2-rep copy-register* drop MOVUPD ;
M: vector-rep copy-register* drop MOVDQU ;
-: copy-register ( dst src rep -- )
+M: x86 %copy ( dst src rep -- )
2over eq? [ 3drop ] [ copy-register* ] if ;
-M: x86 %copy ( dst src rep -- ) copy-register ;
-
:: overflow-template ( label dst src1 src2 insn -- )
src1 src2 insn call
label JO ; inline
dst rep rep-size 2 cells + byte-array temp %allot
16 tag-fixnum dst 1 byte-array tag-number %set-slot-imm
dst byte-array-offset [+]
- src rep copy-register ;
+ src rep %copy ;
M:: x86 %unbox-vector ( dst src rep -- )
dst src byte-array-offset [+]
- rep copy-register ;
+ rep %copy ;
+
+MACRO: available-reps ( alist -- )
+ ! Each SSE version adds new representations and supports
+ ! all old ones
+ unzip { } [ append ] accumulate rest swap suffix
+ [ [ 1quotation ] map ] bi@ zip
+ reverse [ { } ] suffix
+ '[ _ cond ] ;
M: x86 %broadcast-vector ( dst src rep -- )
{
- { float-4-rep [ [ MOVSS ] [ drop dup 0 SHUFPS ] 2bi ] }
- { double-2-rep [ [ MOVSD ] [ drop dup UNPCKLPD ] 2bi ] }
+ { float-4-rep [ [ float-4-rep %copy ] [ drop dup 0 SHUFPS ] 2bi ] }
+ { double-2-rep [ [ double-2-rep %copy ] [ drop dup UNPCKLPD ] 2bi ] }
} case ;
+M: x86 %broadcast-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep } }
+ } available-reps ;
+
M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
rep {
{
float-4-rep
[
- dst src1 MOVSS
+ dst src1 float-4-rep %copy
dst src2 UNPCKLPS
src3 src4 UNPCKLPS
dst src3 MOVLHPS
}
} case ;
+M: x86 %gather-vector-4-reps
+ {
+ { sse? { float-4-rep } }
+ } available-reps ;
+
M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
rep {
{
double-2-rep
[
- dst src1 MOVSD
+ dst src1 double-2-rep %copy
dst src2 UNPCKLPD
]
}
} case ;
+M: x86 %gather-vector-2-reps
+ {
+ { sse2? { double-2-rep } }
+ } available-reps ;
+
M: x86 %add-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ ADDPS ] }
{ ushort-8-rep [ PADDW ] }
{ int-4-rep [ PADDD ] }
{ uint-4-rep [ PADDD ] }
+ { longlong-2-rep [ PADDQ ] }
+ { ulonglong-2-rep [ PADDQ ] }
+ } case drop ;
+
+M: x86 %add-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %saturated-add-vector ( dst src1 src2 rep -- )
+ {
+ { char-16-rep [ PADDSB ] }
+ { uchar-16-rep [ PADDUSB ] }
+ { short-8-rep [ PADDSW ] }
+ { ushort-8-rep [ PADDUSW ] }
+ } case drop ;
+
+M: x86 %saturated-add-vector-reps
+ {
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
+ } available-reps ;
+
+M: x86 %add-sub-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ ADDSUBPS ] }
+ { double-2-rep [ ADDSUBPD ] }
} case drop ;
+M: x86 %add-sub-vector-reps
+ {
+ { sse3? { float-4-rep double-2-rep } }
+ } available-reps ;
+
M: x86 %sub-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ SUBPS ] }
{ ushort-8-rep [ PSUBW ] }
{ int-4-rep [ PSUBD ] }
{ uint-4-rep [ PSUBD ] }
+ { longlong-2-rep [ PSUBQ ] }
+ { ulonglong-2-rep [ PSUBQ ] }
} case drop ;
+M: x86 %sub-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %saturated-sub-vector ( dst src1 src2 rep -- )
+ {
+ { char-16-rep [ PSUBSB ] }
+ { uchar-16-rep [ PSUBUSB ] }
+ { short-8-rep [ PSUBSW ] }
+ { ushort-8-rep [ PSUBUSW ] }
+ } case drop ;
+
+M: x86 %saturated-sub-vector-reps
+ {
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
+ } available-reps ;
+
M: x86 %mul-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ MULPS ] }
{ double-2-rep [ MULPD ] }
- { int-4-rep [ PMULLW ] }
+ { short-8-rep [ PMULLW ] }
+ { ushort-8-rep [ PMULLW ] }
+ { int-4-rep [ PMULLD ] }
+ { uint-4-rep [ PMULLD ] }
} case drop ;
+M: x86 %mul-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep short-8-rep ushort-8-rep } }
+ { sse4.1? { int-4-rep uint-4-rep } }
+ } available-reps ;
+
+M: x86 %saturated-mul-vector-reps
+ ! No multiplication with saturation on x86
+ { } ;
+
M: x86 %div-vector ( dst src1 src2 rep -- )
{
{ float-4-rep [ DIVPS ] }
{ double-2-rep [ DIVPD ] }
} case drop ;
+M: x86 %div-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep } }
+ } available-reps ;
+
M: x86 %min-vector ( dst src1 src2 rep -- )
{
+ { char-16-rep [ PMINSB ] }
+ { uchar-16-rep [ PMINUB ] }
+ { short-8-rep [ PMINSW ] }
+ { ushort-8-rep [ PMINUW ] }
+ { int-4-rep [ PMINSD ] }
+ { uint-4-rep [ PMINUD ] }
{ float-4-rep [ MINPS ] }
{ double-2-rep [ MINPD ] }
} case drop ;
+M: x86 %min-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
+ } available-reps ;
+
M: x86 %max-vector ( dst src1 src2 rep -- )
{
+ { char-16-rep [ PMAXSB ] }
+ { uchar-16-rep [ PMAXUB ] }
+ { short-8-rep [ PMAXSW ] }
+ { ushort-8-rep [ PMAXUW ] }
+ { int-4-rep [ PMAXSD ] }
+ { uint-4-rep [ PMAXUD ] }
{ float-4-rep [ MAXPS ] }
{ double-2-rep [ MAXPD ] }
} case drop ;
+M: x86 %max-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
+ } available-reps ;
+
+M: x86 %horizontal-add-vector ( dst src rep -- )
+ {
+ { float-4-rep [ [ float-4-rep %copy ] [ HADDPS ] [ HADDPS ] 2tri ] }
+ { double-2-rep [ [ double-2-rep %copy ] [ HADDPD ] 2bi ] }
+ } case ;
+
+M: x86 %horizontal-add-vector-reps
+ {
+ { sse3? { float-4-rep double-2-rep } }
+ } available-reps ;
+
+M: x86 %abs-vector ( dst src rep -- )
+ {
+ { char-16-rep [ PABSB ] }
+ { short-8-rep [ PABSW ] }
+ { int-4-rep [ PABSD ] }
+ } case ;
+
+M: x86 %abs-vector-reps
+ {
+ { ssse3? { char-16-rep short-8-rep int-4-rep } }
+ } available-reps ;
+
M: x86 %sqrt-vector ( dst src rep -- )
{
{ float-4-rep [ SQRTPS ] }
{ double-2-rep [ SQRTPD ] }
} case ;
-M: x86 %horizontal-add-vector ( dst src rep -- )
+M: x86 %sqrt-vector-reps
{
- { float-4-rep [ [ MOVAPS ] [ HADDPS ] [ HADDPS ] 2tri ] }
- { double-2-rep [ [ MOVAPD ] [ HADDPD ] 2bi ] }
- } case ;
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep } }
+ } available-reps ;
+
+M: x86 %and-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ ANDPS ] }
+ { double-2-rep [ ANDPD ] }
+ [ drop PAND ]
+ } case drop ;
+
+M: x86 %and-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %or-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ ORPS ] }
+ { double-2-rep [ ORPD ] }
+ [ drop POR ]
+ } case drop ;
+
+M: x86 %or-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %xor-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ XORPS ] }
+ { double-2-rep [ XORPD ] }
+ [ drop PXOR ]
+ } case drop ;
+
+M: x86 %xor-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
M: x86 %unbox-alien ( dst src -- )
alien-offset [+] MOV ;
[ quot call ] with-save/restore
] if ; inline
-: ?MOV ( dst src -- )
- 2dup = [ 2drop ] [ MOV ] if ; inline
-
M:: x86 %string-nth ( dst src index temp -- )
! We request a small-reg of size 8 since those of size 16 are
! a superset.
! Compute code point
new-dst temp XOR
"end" resolve-label
- dst new-dst ?MOV
+ dst new-dst int-rep %copy
] with-small-register ;
M:: x86 %set-string-nth-fast ( ch str index temp -- )
ch { index str temp } 8 [| new-ch |
- new-ch ch ?MOV
+ new-ch ch int-rep %copy
temp str index [+] LEA
temp string-offset [+] new-ch 8-bit-version-of MOV
] with-small-register ;
dst { src } size [| new-dst |
new-dst dup size n-bit-version-of dup src [] MOV
quot call
- dst new-dst ?MOV
+ dst new-dst int-rep %copy
] with-small-register ; inline
: %alien-unsigned-getter ( dst src size -- )
M: x86 %alien-cell [] MOV ;
M: x86 %alien-float [] MOVSS ;
M: x86 %alien-double [] MOVSD ;
-M: x86 %alien-vector [ [] ] dip copy-register ;
+M: x86 %alien-vector [ [] ] dip %copy ;
:: %alien-integer-setter ( ptr value size -- )
value { ptr } size [| new-value |
- new-value value ?MOV
+ new-value value int-rep %copy
ptr [] new-value size n-bit-version-of MOV
] with-small-register ; inline
M: x86 %set-alien-cell [ [] ] dip MOV ;
M: x86 %set-alien-float [ [] ] dip MOVSS ;
M: x86 %set-alien-double [ [] ] dip MOVSD ;
-M: x86 %set-alien-vector [ [] ] 2dip copy-register ;
+M: x86 %set-alien-vector [ [] ] 2dip %copy ;
: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
\ UCOMISD (%compare-float-branch) ;
M:: x86 %spill ( src rep n -- )
- n spill@ src rep copy-register ;
+ n spill@ src rep %copy ;
M:: x86 %reload ( dst rep n -- )
- dst n spill@ rep copy-register ;
+ dst n spill@ rep %copy ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
#! set up by the caller.
stack-frame get total-size>> + stack@ ;
-: enable-sse2 ( -- )
- enable-float-intrinsics
- enable-fsqrt
- enable-float-min/max
- enable-sse2-simd ;
+enable-simd
+enable-min/max
+enable-fixnum-log2
-: enable-sse3 ( -- )
- enable-sse2
- enable-sse3-simd ;
+:: install-sse2-check ( -- )
+ [
+ sse-version 20 < [
+ "This image was built to use SSE2 but your CPU does not support it." print
+ "You will need to bootstrap Factor again." print
+ flush
+ 1 exit
+ ] when
+ ] "cpu.x86" add-init-hook ;
+
+: enable-sse2 ( version -- )
+ 20 >= [
+ enable-float-intrinsics
+ enable-fsqrt
+ enable-float-min/max
+ install-sse2-check
+ ] when ;
-enable-min/max
-enable-fixnum-log2
\ No newline at end of file
+: check-sse ( -- )
+ [ { sse_version } compile ] with-optimizer
+ "Checking for multimedia extensions: " write sse-version
+ [ sse-string write " detected" print ] [ enable-sse2 ] bi ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel help.markup help.syntax sequences
-alien assocs strings math multiline quotations db.private ;
+alien assocs strings math quotations db.private ;
IN: db
HELP: db-connection
{ $subsection sql-query }
"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
-{ $code <"
+{ $code """
USING: db.sqlite db io.files io.files.temp ;
: with-book-db ( quot -- )
- "book.db" temp-file <sqlite-db> swap with-db ; inline"> }
+ "book.db" temp-file <sqlite-db> swap with-db ; inline" }
"Now let's create the table manually:"
-{ $code <" "create table books
+{ $code " "create table books
(id integer primary key, title text, author text, date_published timestamp,
edition integer, cover_price double, condition text)"
- [ sql-command ] with-book-db"> }
+ [ sql-command ] with-book-db""" }
"Time to insert some books:"
-{ $code <"
+{ $code """
"insert into books
(title, author, date_published, edition, cover_price, condition)
values('Factor for Sheeple', 'Mister Stacky Pants', date('now'), 1, 13.37, 'mint')"
-[ sql-command ] with-book-db"> }
+[ sql-command ] with-book-db""" }
"Now let's select the book:"
-{ $code <"
-"select id, title, cover_price from books;" [ sql-query ] with-book-db "> }
+{ $code """
+"select id, title, cover_price from books;" [ sql-query ] with-book-db""" }
"Notice that the result of this query is a Factor array containing the database rows as arrays of strings. We would have to convert the " { $snippet "cover_price" } " from a string to a number in order to use it in a calculation." $nl
"In conclusion, this method of accessing a database is supported, but it is fairly low-level and generally specific to a single database. The " { $vocab-link "db.tuples" } " vocabulary is a good alternative to writing SQL by hand." ;
"Make a " { $snippet "with-" } " combinator to open and close a database so that resources are not leaked." $nl
"SQLite example combinator:"
-{ $code <"
+{ $code """
USING: db.sqlite db io.files io.files.temp ;
: with-sqlite-db ( quot -- )
- "my-database.db" temp-file <sqlite-db> swap with-db ; inline"> }
+ "my-database.db" temp-file <sqlite-db> swap with-db ; inline""" }
"PostgreSQL example combinator:"
-{ $code <" USING: db.postgresql db ;
+{ $code """USING: db.postgresql db ;
: with-postgresql-db ( quot -- )
<postgresql-db>
"localhost" >>host
"erg" >>username
"secrets?" >>password
"factor-test" >>database
- swap with-db ; inline">
+ swap with-db ; inline"""
} ;
ABOUT: "db"
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
math.intervals io nmake accessors vectors math.ranges random
math.bitwise db.queries destructors db.tuples.private interpolate
-io.streams.string multiline make db.private sequences.deep
+io.streams.string make db.private sequences.deep
db.errors.sqlite ;
IN: db.sqlite
: insert-trigger ( -- string )
[
- <"
+ """
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: insert-trigger-not-null ( -- string )
[
- <"
+ """
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
WHERE NEW.${table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: update-trigger ( -- string )
[
- <"
+ """
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: update-trigger-not-null ( -- string )
[
- <"
+ """
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
WHERE NEW.${table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: delete-trigger-restrict ( -- string )
[
- <"
+ """
CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: delete-trigger-cascade ( -- string )
[
- <"
+ """
CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
END;
- "> interpolate
+ """ interpolate
] with-string-writer ;
: can-be-null? ( -- ? )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes help.markup help.syntax io.streams.string kernel
-quotations sequences strings multiline math db.types
-db.tuples.private db ;
+quotations sequences strings math db.types db.tuples.private db ;
IN: db.tuples
HELP: random-id-generator
"The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl
"To actually bind the tuple slots to the database types, we'll use " { $link define-persistent } "."
{ $code
-<" USING: db.tuples db.types ;
+"""USING: db.tuples db.types ;
book "BOOK"
{
{ "id" "ID" +db-assigned-id+ }
{ "edition" "EDITION" INTEGER }
{ "cover-price" "COVER_PRICE" DOUBLE }
{ "condition" "CONDITION" VARCHAR }
-} define-persistent "> }
+} define-persistent""" }
"That's all we'll have to do with the database for this tutorial. Now let's make a book."
-{ $code <" USING: calendar namespaces ;
+{ $code """USING: calendar namespaces ;
T{ book
{ title "Factor for Sheeple" }
{ author "Mister Stacky Pants" }
{ edition 1 }
{ cover-price 13.37 }
} book set
-"> }
+""" }
"Now we've created a book. Let's save it to the database."
-{ $code <" USING: db db.sqlite fry io.files ;
+{ $code """USING: db db.sqlite fry io.files ;
: with-book-tutorial ( quot -- )
'[ "book-tutorial.db" temp-file <sqlite-db> _ with-db ] call ;
book recreate-table
book get insert-tuple
] with-book-tutorial
-"> }
+""" }
"Is it really there?"
-{ $code <" [
+{ $code """[
T{ book { title "Factor for Sheeple" } } select-tuples .
-] with-book-tutorial "> }
+] with-book-tutorial""" }
"Oops, we spilled some orange juice on the book cover."
-{ $code <" book get "Small orange juice stain on cover" >>condition "> }
+{ $code """book get "Small orange juice stain on cover" >>condition""" }
"Now let's save the modified book."
-{ $code <" [
+{ $code """[
book get update-tuple
-] with-book-tutorial "> }
+] with-book-tutorial""" }
"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
-{ $code <" [
+{ $code """[
T{ book { title "Factor for Sheeple" } } select-tuples
-] with-book-tutorial "> }
+] with-book-tutorial""" }
"Let's drop the table because we're done."
-{ $code <" [
+{ $code """[
book drop-table
-] with-book-tutorial "> }
+] with-book-tutorial""" }
"To summarize, the steps for using Factor's tuple database are:"
{ $list
"Make a new tuple to represent your data"
M: bad-effect summary
drop "Bad stack effect declaration" ;
-M: bad-escape summary drop "Bad escape code" ;
+M: bad-escape error.
+ "Bad escape code: \\" write
+ char>> 1string print ;
M: bad-literal-tuple summary drop "Bad literal tuple" ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs classes.predicate fry generic io.pathnames kernel
-macros sequences vocabs words words.symbol words.constant
-lexer parser help.topics help.markup namespaces sorting ;
+USING: assocs classes.predicate fry generic help.topics
+io.pathnames kernel lexer macros namespaces parser sequences
+vocabs words words.constant words.symbol ;
IN: definitions.icons
GENERIC: definition-icon ( definition -- path )
ICON: runnable-vocab runnable-vocab
ICON: vocab open-vocab
ICON: vocab-link unopen-vocab
-
-: $definition-icons ( element -- )
- drop
- icons get >alist sort-keys
- [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
- { "" "Definition class" } prefix
- $table ;
\ No newline at end of file
! Replacing a method definition with a consultation would cause problems
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USE: kernel
- M: a-tuple do-me drop ; "> <string-reader> "delegate-test" parse-stream
+ M: a-tuple do-me drop ;" <string-reader> "delegate-test" parse-stream
] unit-test
[ ] [ T{ a-tuple } do-me ] unit-test
! Change method definition to consultation
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USE: kernel
USE: delegate
- CONSULT: silly-protocol a-tuple drop f ; "> <string-reader> "delegate-test" parse-stream
+ CONSULT: silly-protocol a-tuple drop f ; " <string-reader> "delegate-test" parse-stream
] unit-test
! Method should be there
! Now try removing the consulation
[ [ ] ] [
- <" IN: delegate.tests "> <string-reader> "delegate-test" parse-stream
+ "IN: delegate.tests" <string-reader> "delegate-test" parse-stream
] unit-test
! Method should be gone
[ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USING: accessors delegate ;
TUPLE: slot-protocol-test-3 x ;
-CONSULT: y>> slot-protocol-test-3 x>> ;">
+CONSULT: y>> slot-protocol-test-3 x>> ;"
<string-reader> "delegate-test-1" parse-stream
] unit-test
[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
[ [ ] ] [
- <" IN: delegate.tests
-TUPLE: slot-protocol-test-3 x y ;">
+ "IN: delegate.tests
+TUPLE: slot-protocol-test-3 x y ;"
<string-reader> "delegate-test-1" parse-stream
] unit-test
! We want to be able to override methods after consultation
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USING: delegate kernel sequences delegate.protocols accessors ;
TUPLE: override-method-test seq ;
CONSULT: sequence-protocol override-method-test seq>> ;
- M: override-method-test like drop ; ">
+ M: override-method-test like drop ; "
<string-reader> "delegate-test-2" parse-stream
] unit-test
! See if removing a consultation updates protocol-consult word prop
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USING: accessors delegate delegate.protocols ;
TUPLE: seq-delegate seq ;
- CONSULT: sequence-protocol seq-delegate seq>> ;">
+ CONSULT: sequence-protocol seq-delegate seq>> ;"
<string-reader> "remove-consult-test" parse-stream
] unit-test
] unit-test
[ [ ] ] [
- <" IN: delegate.tests
+ "IN: delegate.tests
USING: delegate delegate.protocols ;
- TUPLE: seq-delegate seq ;">
+ TUPLE: seq-delegate seq ;"
<string-reader> "remove-consult-test" parse-stream
] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test namespaces documents documents.elements multiline ;
+USING: tools.test namespaces documents documents.elements ;
IN: document.elements.tests
SYMBOL: doc
! page-elt
<document> doc set
-<" First line
+"First line
Second line
Third line
Fourth line
Fifth line
-Sixth line"> doc get set-doc-string
+Sixth line" doc get set-doc-string
[ { 0 0 } ] [ { 3 3 } doc get 4 <page-elt> prev-elt ] unit-test
[ { 1 2 } ] [ { 5 2 } doc get 4 <page-elt> prev-elt ] unit-test
! Does replacing an ordinary word with a functor-generated one work?
[ [ ] ] [
- <" IN: functors.tests
+ "IN: functors.tests
TUPLE: some-tuple ;
: some-word ( -- ) ;
GENERIC: some-generic ( a -- b )
M: some-tuple some-generic ;
- SYMBOL: some-symbol
- "> <string-reader> "functors-test" parse-stream
+ SYMBOL: some-symbol" <string-reader> "functors-test" parse-stream
] unit-test
: test-redefinition ( -- )
;FUNCTOR
[ [ ] ] [
- <" IN: functors.tests
- << "some" redefine-test >>
- "> <string-reader> "functors-test" parse-stream
+ """IN: functors.tests
+ << "some" redefine-test >>""" <string-reader> "functors-test" parse-stream
] unit-test
test-redefinition
USING: assocs classes help.markup help.syntax io.streams.string
http http.server.dispatchers http.server.responses
-furnace.redirection strings multiline html.forms ;
+furnace.redirection strings html.forms ;
IN: furnace.actions
HELP: <action>
{ $examples
"A simple validator from " { $vocab-link "webapps.todo" } "; this word is invoked from the " { $slot "validate" } " quotation of action for editing a todo list item:"
{ $code
- <" : validate-todo ( -- )
+ """: validate-todo ( -- )
{
{ "summary" [ v-one-line ] }
{ "priority" [ v-integer 0 v-min-value 10 v-max-value ] }
{ "description" [ v-required ] }
- } validate-params ;">
+ } validate-params ;"""
}
} ;
+USING: help.markup help.syntax db ;
IN: furnace.alloy
-USING: help.markup help.syntax db multiline ;
HELP: init-furnace-tables
{ $description "Initializes database tables used by asides, conversations and session management. This word must be invoked inside a " { $link with-db } " scope." } ;
{ $examples
"The " { $vocab-link "webapps.counter" } " vocabulary uses an alloy to configure the counter:"
{ $code
- <" : counter-db ( -- db ) "counter.db" <sqlite-db> ;
+ """: counter-db ( -- db ) "counter.db" <sqlite-db> ;
: run-counter ( -- )
<counter-app>
counter-db <alloy>
main-responder set-global
- 8080 httpd ;">
+ 8080 httpd ;"""
}
} ;
USING: assocs classes help.markup help.syntax kernel
quotations strings words words.symbol furnace.auth.providers.db
checksums.sha furnace.auth.providers math byte-arrays
-http multiline ;
+http ;
IN: furnace.auth
HELP: <protected>
ARTICLE: "furnace.auth.example" "Furnace authentication example"
"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message “You must log in to view your todo list”:"
{ $code
- "view your todo list" >>description">
+ "view your todo list" >>description"""
}
"The " { $vocab-link "webapps.wiki" } " vocabulary defines a mix of protected and unprotected actions. One example of a protected action is that for deleting wiki pages, an action normally reserved for administrators. This action is protected with the following code:"
{ $code
"delete wiki articles" >>description
- { can-delete-wiki-articles? } >>capabilities">
+ { can-delete-wiki-articles? } >>capabilities"""
}
"The " { $vocab-link "websites.concatenative" } " vocabulary wraps all of its responders, including the wiki, in a login authentication realm:"
{ $code
-<" : <login-config> ( responder -- responder' )
+""": <login-config> ( responder -- responder' )
"Factor website" <login-realm>
"Factor website" >>name
allow-registration
allow-password-recovery
allow-edit-profile
- allow-deactivation ;">
+ allow-deactivation ;"""
} ;
ARTICLE: "furnace.auth" "Furnace authentication"
ARTICLE: "grouping" "Groups and clumps"
"Splitting a sequence into disjoint, fixed-length subsequences:"
-{ $subsection group }
+{ $subsections group }
"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
-{ $subsection groups }
-{ $subsection <groups> }
-{ $subsection <sliced-groups> }
+{ $subsections groups <groups> <sliced-groups> }
"Splitting a sequence into overlapping, fixed-length subsequences:"
-{ $subsection clump }
+{ $subsections clump }
"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
-{ $subsection clumps }
-{ $subsection <clumps> }
-{ $subsection <sliced-clumps> }
+{ $subsections clumps <clumps> <sliced-clumps> }
"The difference can be summarized as the following:"
{ $list
{ "With groups, the subsequences form the original sequence when concatenated:"
}
}
}
+$nl
"A combinator built using clumps:"
-{ $subsection monotonic? }
+{ $subsections monotonic? }
"Testing how elements are related:"
-{ $subsection all-eq? }
-{ $subsection all-equal? } ;
+{ $subsections all-eq? all-equal? } ;
ABOUT: "grouping"
USING: help.markup help.syntax io kernel math parser
prettyprint sequences vocabs.loader namespaces stack-checker
-help command-line multiline see ;
+help command-line see ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
{ $heading "Example: ls" }
"Here is an example implementing a simplified version of the Unix " { $snippet "ls" } " command in Factor:"
{ $code
- <" USING: command-line namespaces io io.files
+ """USING: command-line namespaces io io.files
io.pathnames tools.files sequences kernel ;
command-line get [
dup length 1 = [ first directory. ] [
[ [ nl write ":" print ] [ directory. ] bi ] each
] if
-] if-empty">
+] if-empty"""
}
"You can put it in a file named " { $snippet "ls.factor" } ", and then run it, to list the " { $snippet "/usr/bin" } " directory for example:"
{ $code "./factor ls.factor /usr/bin" }
{ $heading "Example: grep" }
"The following is a more complicated example, implementing something like the Unix " { $snippet "grep" } " command:"
-{ $code <" USING: kernel fry io io.files io.encodings.ascii sequences
+{ $code """USING: kernel fry io io.files io.encodings.ascii sequences
regexp command-line namespaces ;
IN: grep
] [
[ grep-file ] with each
] if-empty
-] if-empty"> }
+] if-empty""" }
"You can run it like so,"
{ $code "./factor grep.factor '.*hello.*' myfile.txt" }
"You'll notice this script takes a while to start. This is because it is loading and compiling the " { $vocab-link "regexp" } " vocabulary every time. To speed up startup, load the vocabulary into your image, and save the image:"
collect-elements [ >link ] map ;
: article-children ( topic -- seq )
- { $subsection } article-links ;
+ { $subsection $subsections } article-links ;
: help-path ( topic -- seq )
[ article-parent ] follow rest ;
HELP: $subsection
{ $values { "element" "a markup element of the form " { $snippet "{ topic }" } } }
-{ $description "Prints a large clickable link to the help topic named by the first string element of " { $snippet "element" } "." }
+{ $description "Prints a large clickable link to the help topic named by the first item in " { $snippet "element" } ". The link is printed along with its associated definition icon." }
{ $examples
- { $code "{ $subsection \"sequences\" }" }
+ { $markup-example { $subsection "sequences" } }
+ { $markup-example { $subsection nth } }
+ { $markup-example { $subsection each } }
+} ;
+
+HELP: $subsections
+{ $values { "children" "a " { $link sequence } " of one or more " { $link topic } "s or, in the case of a help article, the article's string name." } }
+{ $description "Prints a large clickable link for each of the listed help topics in " { $snippet "children" } ". The link is printed along with its associated definition icon." }
+{ $examples
+ { $markup-example { $subsections "sequences" nth each } }
+} ;
+
+{ $subsection $subsections $link } related-words
+
+HELP: $vocab-subsection
+{ $values { "element" "a markup element of the form " { $snippet "{ title vocab }" } } }
+{ $description "Prints a large clickable link for " { $snippet "vocab" } ". If " { $snippet "vocab" } " has a main help article, the link will point at that article and the " { $snippet "title" } " input will be ignored. Otherwise, the link text will be taken from " { $snippet "title" } " and point to " { $snippet "vocab" } "'s automatically generated documentation."
+$nl
+"The link will be printed along with its associated definition icon." }
+{ $examples
+ { $markup-example { $vocab-subsection "SQLite" "db.sqlite" } }
+ { $markup-example { $vocab-subsection "Alien" "alien" } }
} ;
HELP: $index
: print-topic ( topic -- )
>link
last-element off
- [ $title ] [ article-content print-content nl ] bi ;
+ [ $title ] [ nl article-content print-content nl ] bi ;
SYMBOL: help-hook
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays definitions generic io kernel assocs
-hashtables namespaces make parser prettyprint sequences strings
-io.styles vectors words math sorting splitting classes slots fry
-sets vocabs help.stylesheet help.topics vocabs.loader quotations
-combinators see present ;
+USING: accessors arrays assocs classes colors.constants
+combinators definitions definitions.icons effects fry generic
+hashtables help.stylesheet help.topics io io.styles kernel make
+math namespaces parser present prettyprint
+prettyprint.stylesheet quotations see sequences sets slots
+sorting splitting strings vectors vocabs vocabs.loader words ;
FROM: prettyprint.sections => with-pprint ;
IN: help.markup
] ($span) ;
: $nl ( children -- )
- nl nl drop ;
+ nl last-block? [ nl ] unless drop ;
! Some blocks
: ($heading) ( children quot -- )
: write-link ( string object -- )
link-style get [ write-object ] with-style ;
-: ($link) ( article -- )
- [ [ article-name ] [ >link ] bi write-link ] ($span) ;
+: link-icon ( topic -- )
+ definition-icon 1array $image ;
-: $link ( element -- )
- first ($link) ;
-
-: ($definition-link) ( word -- )
+: link-text ( topic -- )
[ article-name ] keep write-link ;
-: $definition-link ( element -- )
- first ($definition-link) ;
+: link-effect ( topic -- )
+ dup word? [
+ stack-effect [ effect>string ] [ effect-style ] bi
+ [ write ] with-style
+ ] [ drop ] if ;
+
+: inter-cleave ( x seq between -- )
+ [ [ call( x -- ) ] with ] dip swap interleave ; inline
+
+: (($link)) ( topic words -- )
+ [ dup topic? [ >link ] unless ] dip
+ [ [ bl ] inter-cleave ] ($span) ; inline
+
+: ($link) ( topic -- )
+ { [ link-text ] } (($link)) ;
+
+: $link ( element -- ) first ($link) ;
+
+: ($long-link) ( topic -- )
+ { [ link-text ] [ link-effect ] } (($link)) ;
+
+: $long-link ( element -- ) first ($long-link) ;
+
+: ($pretty-link) ( topic -- )
+ { [ link-icon ] [ link-text ] } (($link)) ;
+
+: $pretty-link ( element -- ) first ($pretty-link) ;
-: ($long-link) ( object -- )
- [ article-title ] [ >link ] bi write-link ;
+: ($long-pretty-link) ( topic -- )
+ { [ link-icon ] [ link-text ] [ link-effect ] } (($link)) ;
-: $long-link ( object -- )
- first ($long-link) ;
+: $long-pretty-link ( element -- ) first ($long-pretty-link) ;
+
+: <$pretty-link> ( definition -- element )
+ 1array \ $pretty-link prefix ;
: ($subsection) ( element quot -- )
[
- subsection-style get [
- bullet get write bl
- call
- ] with-style
+ subsection-style get [ call ] with-style
] ($block) ; inline
+: $subsection* ( topic -- )
+ [
+ [ ($long-pretty-link) ] with-scope
+ ] ($subsection) ;
+
+: $subsections ( children -- )
+ [ $subsection* ] each nl ;
+
: $subsection ( element -- )
- [ first ($long-link) ] ($subsection) ;
+ first $subsection* ;
: ($vocab-link) ( text vocab -- )
>vocab-link write-link ;
: $vocab-subsection ( element -- )
[
- first2 dup vocab-help dup [
- 2nip ($long-link)
- ] [
- drop ($vocab-link)
- ] if
+ first2 dup vocab-help
+ [ 2nip ($long-pretty-link) ]
+ [ [ >vocab-link link-icon bl ] [ ($vocab-link) ] bi ]
+ if*
] ($subsection) ;
: $vocab-link ( element -- )
: <$snippet> ( str -- element )
1array \ $snippet prefix ;
+
+: $definition-icons ( element -- )
+ drop
+ icons get >alist sort-keys
+ [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
+ { "" "Definition class" } prefix
+ $table ;
\ No newline at end of file
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple classes.union combinators
-definitions effects fry generic help help.markup help.stylesheet
-help.topics io io.files io.pathnames io.styles kernel macros
-make namespaces prettyprint sequences sets sorting summary
-vocabs vocabs.files vocabs.hierarchy vocabs.loader
-vocabs.metadata words words.symbol definitions.icons ;
+effects fry generic help help.markup help.stylesheet
+help.topics io io.pathnames io.styles kernel macros make
+namespaces sequences sorting summary vocabs vocabs.files
+vocabs.hierarchy vocabs.loader vocabs.metadata words
+words.symbol ;
FROM: vocabs.hierarchy => child-vocabs ;
IN: help.vocabs
: about ( vocab -- )
[ require ] [ vocab help ] bi ;
-: $pretty-link ( element -- )
- [ first definition-icon 1array $image " " print-element ]
- [ $definition-link ]
- bi ;
-
-: <$pretty-link> ( definition -- element )
- 1array \ $pretty-link prefix ;
-
: vocab-row ( vocab -- row )
[ <$pretty-link> ] [ vocab-summary ] bi 2array ;
: simple-link ( xml url -- xml' )
url-encode swap [XML <a href=<->><-></a> XML] ;
+
+: simple-image ( url -- xml )
+ url-encode [XML <img src=<-> /> XML] ;
\ No newline at end of file
[ H{ } [ ] with-nesting nl ] make-html-string
] unit-test
-[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
\ No newline at end of file
+[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
+
+[ "<img src=\"/icons/class-word.tiff\"/>" ] [
+ [
+ "text"
+ { { image "vocab:definitions/icons/class-word.tiff" } }
+ format
+ ] make-html-string
+] unit-test
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel assocs io io.styles math math.order math.parser
-sequences strings make words combinators macros xml.syntax html fry
-destructors ;
+USING: accessors assocs combinators destructors fry html io
+io.backend io.pathnames io.styles kernel macros make math
+math.order math.parser namespaces sequences strings words
+splitting xml xml.syntax ;
IN: html.streams
GENERIC: url-of ( object -- url )
: emit-html ( quot stream -- )
dip data>> push ; inline
+: image-path ( path -- images-path )
+ "vocab:definitions/icons/" ?head [ "/icons/" prepend ] when ;
+
+: img-tag ( xml style -- xml )
+ image swap at [ nip image-path simple-image ] when* ;
+
: format-html-span ( string style stream -- )
- [ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ]
- emit-html ;
+ [
+ {
+ [ span-tag ]
+ [ href-link-tag ]
+ [ object-link-tag ]
+ [ img-tag ]
+ } cleave
+ ] emit-html ;
TUPLE: html-span-stream < html-sub-stream ;
USING: io io.files io.streams.string io.encodings.utf8
-html.templates html.templates.fhtml kernel multiline
+html.templates html.templates.fhtml kernel
tools.test sequences parser splitting prettyprint ;
IN: html.templates.fhtml.tests
[
[ ] [
- <"
- <%
+ """<%
IN: html.templates.fhtml.tests
: test-word ( -- ) ;
- %>
- "> parse-template drop
+ %>""" parse-template drop
] unit-test
] with-file-vocabs
-USING: help.markup help.syntax http.server.static multiline ;
+USING: help.markup help.syntax http.server.static ;
IN: http.server.cgi
HELP: enable-cgi
{ $description "Enables the responder to serve " { $snippet ".cgi" } " scripts by executing them as per the CGI specification." }
{ $examples
{ $code
- <" <dispatcher>
- "/var/www/cgi/" <static> enable-cgi "cgi-bin" add-responder" ">
+ """<dispatcher>
+ "/var/www/cgi/" <static> enable-cgi "cgi-bin" add-responder"""
}
}
{ $side-effects "responder" } ;
-! Copyright (C) 2008 Your name.
+! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes help.markup help.syntax io.streams.string
-multiline ;
+USING: classes help.markup help.syntax io.streams.string ;
IN: http.server.dispatchers
HELP: new-dispatcher
ARTICLE: "http.server.dispatchers.example" "HTTP dispatcher examples"
{ $heading "Simple pathname dispatcher" }
{ $code
- <" <dispatcher>
+ """<dispatcher>
<new-action> "new" add-responder
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<list-action> "" add-responder
-main-responder set-global">
+main-responder set-global"""
}
"In the above example, visiting any URL other than " { $snippet "/new" } ", " { $snippet "/edit" } ", " { $snippet "/delete" } ", or " { $snippet "/" } " will result in a 404 error."
{ $heading "Another pathname dispatcher" }
"On the other hand, suppose we wanted to route all unrecognized paths to a “view” action:"
{ $code
- <" <dispatcher>
+ """<dispatcher>
<new-action> "new" add-responder
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<view-action> >>default
-main-responder set-global">
+main-responder set-global"""
}
"The " { $slot "default" } " slot holds a responder to which all unrecognized paths are sent to."
{ $heading "Dispatcher subclassing example" }
{ $code
- <" TUPLE: golf-courses < dispatcher ;
+ """TUPLE: golf-courses < dispatcher ;
: <golf-courses> ( -- golf-courses )
golf-courses new-dispatcher ;
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<list-action> "" add-responder
-main-responder set-global">
+main-responder set-global"""
}
"The action templates can now emit links to responder-relative URLs prefixed by " { $snippet "$golf-courses/" } "."
{ $heading "Virtual hosting example" }
{ $code
- <" <vhost-dispatcher>
+ """<vhost-dispatcher>
<casino> "concatenative-casino.com" add-responder
<dating> "raptor-dating.com" add-responder
-main-responder set-global">
+main-responder set-global"""
}
"Note that the virtual host dispatcher strips off a " { $snippet "www." } " prefix, so " { $snippet "www.concatenative-casino.com" } " would be routed to the " { $snippet "<casino>" } " responder instead of receiving a 404." ;
H{ } describe
H{ } describe
-[ "fixnum instance\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test
+[ "fixnum\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test
[ ] [ H{ } clone inspect ] unit-test
-USING: arrays json.reader kernel multiline strings tools.test
+USING: arrays json.reader kernel strings tools.test
hashtables json ;
IN: json.reader.tests
! feature to get
{ -0.0 } [ "-0.0" json> ] unit-test
-{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test
-{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test
+{ " fuzzy pickles " } [ """ " fuzzy pickles " """ json> ] unit-test
+{ "while 1:\n\tpass" } [ """ "while 1:\n\tpass" """ json> ] unit-test
! unicode is allowed in json
-{ "ß∂¬ƒ˚∆" } [ <" "ß∂¬ƒ˚∆""> json> ] unit-test
-{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
-{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
+{ "ß∂¬ƒ˚∆" } [ """ "ß∂¬ƒ˚∆"""" json> ] unit-test
+{ 8 9 10 12 13 34 47 92 } >string 1array [ """ "\\b\\t\\n\\f\\r\\"\\/\\\\" """ json> ] unit-test
+{ HEX: abcd } >string 1array [ """ "\\uaBCd" """ json> ] unit-test
{ H{ { "a" { } } { "b" 123 } } } [ "{\"a\":[],\"b\":123}" json> ] unit-test
{ { } } [ "[]" json> ] unit-test
-{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
+{ { 1 "two" 3.0 } } [ """ [1, "two", 3.0] """ json> ] unit-test
{ H{ } } [ "{}" json> ] unit-test
! the returned hashtable should be different every time
{ H{ } } [ "key" "value" "{}" json> ?set-at "{}" json> nip ] unit-test
-{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test
+{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ """ { "US$":1.00, "EU\\u20AC":1.50 } """ json> ] unit-test
{ H{
{ "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } }
{ "prime" { 2 3 5 7 11 13 } }
-} } [ <" {
+} } [ """ {
"fib": [1, 1, 2, 3, 5, 8,
{ "etc":"etc" } ],
"prime":
11,
13
] }
-"> json> ] unit-test
+""" json> ] unit-test
{ 0 } [ " 0" json> ] unit-test
{ 0 } [ "0 " json> ] unit-test
-USING: json.writer tools.test multiline json.reader json ;
+USING: json.writer tools.test json.reader json ;
IN: json.writer.tests
{ "false" } [ f >json ] unit-test
{ "102.5" } [ 102.5 >json ] unit-test
{ "[1,\"two\",3.0]" } [ { 1 "two" 3.0 } >json ] unit-test
-{ <" {"US$":1.0,"EU€":1.5}"> } [ H{ { "US$" 1.0 } { "EU€" 1.5 } } >json ] unit-test
+{ """{"US$":1.0,"EU€":1.5}""" } [ H{ { "US$" 1.0 } { "EU€" 1.5 } } >json ] unit-test
! Random symbols are written simply as strings
SYMBOL: testSymbol
-{ <" "testSymbol""> } [ testSymbol >json ] unit-test
+{ """"testSymbol"""" } [ testSymbol >json ] unit-test
-[ { 0.5 } ] [ { 1/2 } >json json> ] unit-test
\ No newline at end of file
+[ { 0.5 } ] [ { 1/2 } >json json> ] unit-test
{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
{ $examples
- { $example <"
+ { $example """
USING: kernel literals prettyprint ;
IN: scratchpad
CONSTANT: five 5
{ $ five } .
- "> "{ 5 }" }
+ """ "{ 5 }" }
- { $example <"
+ { $example """
USING: kernel literals prettyprint ;
IN: scratchpad
: seven-eleven ( -- a b ) 7 11 ;
{ $ seven-eleven } .
- "> "{ 7 11 }" }
+ """ "{ 7 11 }" }
} ;
{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." }
{ $examples
- { $example <"
+ { $example """
USING: kernel literals math prettyprint ;
IN: scratchpad
<< CONSTANT: five 5 >>
{ $[ five dup 1 + dup 2 + ] } .
- "> "{ 5 6 8 }" }
+ """ "{ 5 6 8 }" }
} ;
{ $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
{ $examples
- { $example <"
+ { $example """
USING: kernel literals math prettyprint ;
IN: scratchpad
CONSTANT: five 5
CONSTANT: six 6
${ five six 7 } .
- "> "{ 5 6 7 }"
+ """ "{ 5 6 7 }"
}
} ;
ARTICLE: "literals" "Interpolating code results into literal values"
"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
-{ $example <"
+{ $example """
USE: literals
IN: scratchpad
CONSTANT: five 5
{ $ five $[ five dup 1 + dup 2 + ] } .
- "> "{ 5 5 6 8 }" }
+ """ "{ 5 5 6 8 }" }
{ $subsection POSTPONE: $ }
{ $subsection POSTPONE: $[ }
{ $subsection POSTPONE: ${ }
-USING: alien.fortran help.markup help.syntax math.blas.config multiline ;
+USING: alien.fortran help.markup help.syntax math.blas.config ;
IN: math.blas.config
ARTICLE: "math.blas.config" "Configuring the BLAS interface"
{ $subsection blas-library }
{ $subsection blas-fortran-abi }
"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:"
-{ $code <"
+{ $code """
USING: math.blas.config namespaces ;
"X:\\path\\to\\acml.dll" blas-library set-global
intel-windows-abi blas-fortran-abi set-global
-"> }
+""" }
"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded."
;
-USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings multiline ;
+USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ;
IN: math.blas.matrices
ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
{ $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ;
HELP: smatrix{
-{ $syntax <" 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{
+{ $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{
+{ $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 complex-float-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{
+{ $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 complex-double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
{
-USING: help.markup help.syntax kernel math math.order multiline sequences ;
+USING: help.markup help.syntax kernel math math.order sequences ;
IN: math.combinatorics
HELP: factorial
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ."
-<" {
+"""{
{ "a" "b" }
{ "a" "c" }
{ "a" "d" }
{ "b" "c" }
{ "b" "d" }
{ "c" "d" }
-}"> } } ;
+}""" } } ;
HELP: each-combination
{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } }
set_x87_env ;
M: x86 (fp-env-registers)
- sse-version 20 >=
- [ <sse-env> <x87-env> 2array ]
- [ <x87-env> 1array ] if ;
+ sse2? [ <sse-env> <x87-env> 2array ] [ <x87-env> 1array ] if ;
CONSTANT: sse-exception-flag-bits HEX: 3f
CONSTANT: sse-exception-flag>bit
IN: math.functions
ARTICLE: "integer-functions" "Integer functions"
-{ $subsection align }
-{ $subsection gcd }
-{ $subsection log2 }
-{ $subsection next-power-of-2 }
+{ $subsections
+ align
+ gcd
+ log2
+ next-power-of-2
+}
"Modular exponentiation:"
-{ $subsection ^mod }
-{ $subsection mod-inv }
+{ $subsections ^mod mod-inv }
"Tests:"
-{ $subsection power-of-2? }
-{ $subsection even? }
-{ $subsection odd? }
-{ $subsection divisor? } ;
+{ $subsections
+ power-of-2?
+ even?
+ odd?
+ divisor?
+} ;
ARTICLE: "arithmetic-functions" "Arithmetic functions"
"Computing additive and multiplicative inverses:"
-{ $subsection neg }
-{ $subsection recip }
+{ $subsections neg recip }
"Complex conjugation:"
-{ $subsection conjugate }
+{ $subsections conjugate }
"Tests:"
-{ $subsection zero? }
-{ $subsection between? }
+{ $subsections zero? between? }
"Control flow:"
-{ $subsection if-zero }
-{ $subsection when-zero }
-{ $subsection unless-zero }
+{ $subsections
+ if-zero
+ when-zero
+ unless-zero
+}
"Sign:"
-{ $subsection sgn }
+{ $subsections sgn }
"Rounding:"
-{ $subsection ceiling }
-{ $subsection floor }
-{ $subsection truncate }
-{ $subsection round }
+{ $subsections
+ ceiling
+ floor
+ truncate
+ round
+}
"Inexact comparison:"
-{ $subsection ~ }
+{ $subsections ~ }
"Numbers implement the " { $link "math.order" } ", therefore operations such as " { $link min } " and " { $link max } " can be used with numbers." ;
ARTICLE: "power-functions" "Powers and logarithms"
"Squares:"
-{ $subsection sq }
-{ $subsection sqrt }
+{ $subsections sq sqrt }
"Exponential and natural logarithm:"
-{ $subsection exp }
-{ $subsection cis }
-{ $subsection log }
+{ $subsections exp cis log }
"Other logarithms:"
-{ $subsection log1+ }
-{ $subsection log10 }
+{ $subsection log1+ log10 }
"Raising a number to a power:"
-{ $subsection ^ }
-{ $subsection 10^ }
+{ $subsections ^ 10^ }
"Converting between rectangular and polar form:"
-{ $subsection abs }
-{ $subsection absq }
-{ $subsection arg }
-{ $subsection >polar }
-{ $subsection polar> } ;
+{ $subsections
+ abs
+ absq
+ arg
+ >polar
+ polar>
+} ;
ARTICLE: "trig-hyp-functions" "Trigonometric and hyperbolic functions"
"Trigonometric functions:"
-{ $subsection cos }
-{ $subsection sin }
-{ $subsection tan }
+{ $subsections cos sin tan }
"Reciprocals:"
-{ $subsection sec }
-{ $subsection cosec }
-{ $subsection cot }
+{ $subsections sec cosec cot }
"Inverses:"
-{ $subsection acos }
-{ $subsection asin }
-{ $subsection atan }
+{ $subsections acos asin atan }
"Inverse reciprocals:"
-{ $subsection asec }
-{ $subsection acosec }
-{ $subsection acot }
+{ $subsections asec acosec acot }
"Hyperbolic functions:"
-{ $subsection cosh }
-{ $subsection sinh }
-{ $subsection tanh }
+{ $subsections cosh sinh tanh }
"Reciprocals:"
-{ $subsection sech }
-{ $subsection cosech }
-{ $subsection coth }
+{ $subsections sech cosech coth }
"Inverses:"
-{ $subsection acosh }
-{ $subsection asinh }
-{ $subsection atanh }
+{ $subsections acosh asinh atanh }
"Inverse reciprocals:"
-{ $subsection asech }
-{ $subsection acosech }
-{ $subsection acoth } ;
+{ $subsections asech acosech acoth } ;
ARTICLE: "math-functions" "Mathematical functions"
-{ $subsection "integer-functions" }
-{ $subsection "arithmetic-functions" }
-{ $subsection "power-functions" }
-{ $subsection "trig-hyp-functions" } ;
+{ $subsections
+ "integer-functions"
+ "arithmetic-functions"
+ "power-functions"
+ "trig-hyp-functions"
+} ;
ABOUT: "math-functions"
[ t ] [ 4.0000001 4.0000001 .000001 ~ ] unit-test
[ f ] [ -4.0000001 4.0000001 .00001 ~ ] unit-test
[ t ] [ -.0000000000001 0 .0000000001 ~ ] unit-test
+[ t ] [ 100 101 -.9 ~ ] unit-test
+[ f ] [ 100 120 -.09 ~ ] unit-test
+[ t ] [ 0 0 -.9 ~ ] unit-test
+[ f ] [ 0 10 -.9 ~ ] unit-test
! Lets get the argument order correct, eh?
[ 0.0 ] [ 0.0 1.0 fatan2 ] unit-test
[ - abs ] dip < ;
: ~rel ( x y epsilon -- ? )
- [ [ - abs ] 2keep [ abs ] bi@ + ] dip * < ;
+ [ [ - abs ] 2keep [ abs ] bi@ + ] dip * <= ;
: ~ ( x y epsilon -- ? )
{
{ [ 2over [ fp-nan? ] either? ] [ 3drop f ] }
{ [ dup zero? ] [ drop number= ] }
- { [ dup 0 < ] [ ~rel ] }
+ { [ dup 0 < ] [ neg ~rel ] }
[ ~abs ]
} cond ;
: math-both-known? ( word left right -- ? )
3dup math-op
[ 2drop 2drop t ]
- [ drop math-class-max swap specific-method >boolean ] if ;
+ [ drop math-class-max swap method-for-class >boolean ] if ;
: (derived-ops) ( word assoc -- words )
swap '[ swap first _ eq? nip ] assoc-filter ;
+++ /dev/null
-USING: cpu.architecture math.vectors.simd
-math.vectors.simd.intrinsics accessors math.vectors.simd.alien
-kernel classes.struct tools.test compiler sequences byte-arrays
-alien math kernel.private specialized-arrays combinators ;
-SPECIALIZED-ARRAY: float
-IN: math.vectors.simd.alien.tests
-
-! Vector alien intrinsics
-[ float-4{ 1 2 3 4 } ] [
- [
- float-4{ 1 2 3 4 }
- underlying>> 0 float-4-rep alien-vector
- ] compile-call float-4 boa
-] unit-test
-
-[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
- 16 [ 1 ] B{ } replicate-as 16 <byte-array>
- [
- 0 [
- { byte-array c-ptr fixnum } declare
- float-4-rep set-alien-vector
- ] compile-call
- ] keep
-] unit-test
-
-[ float-array{ 1 2 3 4 } ] [
- [
- float-array{ 1 2 3 4 } underlying>>
- float-array{ 4 3 2 1 } clone
- [ underlying>> 0 float-4-rep set-alien-vector ] keep
- ] compile-call
-] unit-test
-
-STRUCT: simd-struct
-{ x float-4 }
-{ y double-2 }
-{ z double-4 }
-{ w float-8 } ;
-
-[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
-
-[
- float-4{ 1 2 3 4 }
- double-2{ 2 1 }
- double-4{ 4 3 2 1 }
- float-8{ 1 2 3 4 5 6 7 8 }
-] [
- simd-struct <struct>
- float-4{ 1 2 3 4 } >>x
- double-2{ 2 1 } >>y
- double-4{ 4 3 2 1 } >>z
- float-8{ 1 2 3 4 5 6 7 8 } >>w
- { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
-] unit-test
-
-[
- float-4{ 1 2 3 4 }
- double-2{ 2 1 }
- double-4{ 4 3 2 1 }
- float-8{ 1 2 3 4 5 6 7 8 }
-] [
- [
- simd-struct <struct>
- float-4{ 1 2 3 4 } >>x
- double-2{ 2 1 } >>y
- double-4{ 4 3 2 1 } >>z
- float-8{ 1 2 3 4 5 6 7 8 } >>w
- { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
- ] compile-call
-] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien accessors alien.c-types byte-arrays compiler.units
-cpu.architecture locals kernel math math.vectors.simd
-math.vectors.simd.intrinsics ;
-IN: math.vectors.simd.alien
-
-:: define-simd-128-type ( class rep -- )
- <c-type>
- byte-array >>class
- class >>boxed-class
- [ rep alien-vector class boa ] >>getter
- [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
- 16 >>size
- 8 >>align
- rep >>rep
- class name>> typedef ;
-
-:: define-simd-256-type ( class rep -- )
- <c-type>
- class >>class
- class >>boxed-class
- [
- [ rep alien-vector ]
- [ 16 + >fixnum rep alien-vector ] 2bi
- class boa
- ] >>getter
- [
- [ [ underlying1>> ] 2dip rep set-alien-vector ]
- [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ]
- 3bi
- ] >>setter
- 32 >>size
- 8 >>align
- rep >>rep
- class name>> typedef ;
-[
- float-4 float-4-rep define-simd-128-type
- double-2 double-2-rep define-simd-128-type
- float-8 float-4-rep define-simd-256-type
- double-4 double-2-rep define-simd-256-type
-] with-compilation-unit
+++ /dev/null
-Slava Pestov
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types byte-arrays classes functors
-kernel math parser prettyprint.custom sequences
-sequences.private literals ;
+USING: accessors alien.c-types assocs byte-arrays classes
+effects fry functors generalizations kernel literals locals
+math math.functions math.vectors math.vectors.simd.intrinsics
+math.vectors.specialization parser prettyprint.custom sequences
+sequences.private strings words definitions macros cpu.architecture
+namespaces arrays quotations ;
+QUALIFIED-WITH: math m
IN: math.vectors.simd.functor
ERROR: bad-length got expected ;
-FUNCTOR: define-simd-128 ( T -- )
+MACRO: simd-boa ( rep class -- simd-array )
+ [ rep-components ] [ new ] bi* '[ _ _ nsequence ] ;
+
+:: define-boa-custom-inlining ( word rep class -- )
+ word [
+ drop
+ rep rep rep-gather-word supported-simd-op? [
+ [ rep (simd-boa) class boa ]
+ ] [ word def>> ] if
+ ] "custom-inlining" set-word-prop ;
+
+: simd-with ( rep class x -- simd-array )
+ [ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline
+
+:: define-with-custom-inlining ( word rep class -- )
+ word [
+ drop
+ rep \ (simd-broadcast) supported-simd-op? [
+ [ rep rep-coerce rep (simd-broadcast) class boa ]
+ ] [ word def>> ] if
+ ] "custom-inlining" set-word-prop ;
+
+: boa-effect ( rep n -- effect )
+ [ rep-components ] dip *
+ [ CHAR: a + 1string ] map
+ { "simd-vector" } <effect> ;
+
+: supported-simd-ops ( assoc rep -- assoc' )
+ [ simd-ops get ] dip
+ '[ nip _ swap supported-simd-op? ] assoc-filter
+ '[ drop _ key? ] assoc-filter ;
+
+ERROR: bad-schema schema ;
+
+: low-level-ops ( box-quot: ( inputs... simd-op -- outputs... ) -- alist )
+ [ simd-ops get ] dip '[
+ 1quotation
+ over word-schema _ ?at [ bad-schema ] unless
+ [ ] 2sequence
+ ] assoc-map ;
+
+:: high-level-ops ( ctor elt-class -- assoc )
+ ! Some SIMD operations are defined in terms of others.
+ {
+ { vneg [ [ dup v- ] keep v- ] }
+ { n+v [ [ ctor execute ] dip v+ ] }
+ { v+n [ ctor execute v+ ] }
+ { n-v [ [ ctor execute ] dip v- ] }
+ { v-n [ ctor execute v- ] }
+ { n*v [ [ ctor execute ] dip v* ] }
+ { v*n [ ctor execute v* ] }
+ { n/v [ [ ctor execute ] dip v/ ] }
+ { v/n [ ctor execute v/ ] }
+ { norm-sq [ dup v. assert-positive ] }
+ { norm [ norm-sq sqrt ] }
+ { normalize [ dup norm v/n ] }
+ }
+ ! To compute dot product and distance with integer vectors, we
+ ! have to do things less efficiently, with integer overflow checks,
+ ! in the general case.
+ elt-class m:float = [
+ {
+ { distance [ v- norm ] }
+ { v. [ v* sum ] }
+ } append
+ ] when ;
+
+:: simd-vector-words ( class ctor rep vv->v v->v v->n -- )
+ rep rep-component-type c-type-boxed-class :> elt-class
+ class
+ elt-class
+ {
+ { { +vector+ +vector+ -> +vector+ } vv->v }
+ { { +vector+ -> +vector+ } v->v }
+ { { +vector+ -> +scalar+ } v->n }
+ { { +vector+ -> +nonnegative+ } v->n }
+ } low-level-ops
+ rep supported-simd-ops
+ ctor elt-class high-level-ops assoc-union
+ specialize-vector-words ;
+
+:: define-simd-128-type ( class rep -- )
+ <c-type>
+ byte-array >>class
+ class >>boxed-class
+ [ rep alien-vector class boa ] >>getter
+ [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
+ 16 >>size
+ 8 >>align
+ rep >>rep
+ class typedef ;
-T-TYPE IS ${T}
+FUNCTOR: define-simd-128 ( T -- )
-N [ 16 T-TYPE heap-size /i ]
+N [ 16 T heap-size /i ]
A DEFINES-CLASS ${T}-${N}
+A-boa DEFINES ${A}-boa
+A-with DEFINES ${A}-with
>A DEFINES >${A}
A{ DEFINES ${A}{
-NTH [ T-TYPE dup c-type-getter-boxer array-accessor ]
-SET-NTH [ T-TYPE dup c-setter array-accessor ]
+NTH [ T dup c-type-getter-boxer array-accessor ]
+SET-NTH [ T dup c-setter array-accessor ]
-A-rep IS ${A}-rep
+A-rep [ A name>> "-rep" append "cpu.architecture" lookup ]
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-v->v-op DEFINES-PRIVATE ${A}-v->v-op
A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
WHERE
M: A byte-length underlying>> length ; inline
+M: A element-type drop A-rep rep-component-type ;
+
M: A pprint-delims drop \ A{ \ } ;
M: A >pprint-sequence ;
SYNTAX: A{ \ } [ >A ] parse-literal ;
+: A-with ( x -- simd-array ) [ A-rep A ] dip simd-with ;
+
+\ A-with \ A-rep \ A define-with-custom-inlining
+
+\ A-boa [ \ A-rep \ A simd-boa ] \ A-rep 1 boa-effect define-declared
+
+\ A-rep rep-gather-word [
+ \ A-boa \ A-rep \ A define-boa-custom-inlining
+] when
+
INSTANCE: A sequence
<PRIVATE
: A-vv->v-op ( v1 v2 quot -- v3 )
[ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline
+: A-v->v-op ( v1 quot -- v2 )
+ [ underlying>> A-rep ] dip call \ A boa ; inline
+
: A-v->n-op ( v quot -- n )
[ underlying>> A-rep ] dip call ; inline
+\ A \ A-with \ A-rep \ A-vv->v-op \ A-v->v-op \ A-v->n-op simd-vector-words
+\ A \ A-rep define-simd-128-type
+
PRIVATE>
;FUNCTOR
! Synthesize 256-bit vectors from a pair of 128-bit vectors
-FUNCTOR: define-simd-256 ( T -- )
+SLOT: underlying1
+SLOT: underlying2
-T-TYPE IS ${T}
+:: define-simd-256-type ( class rep -- )
+ <c-type>
+ class >>class
+ class >>boxed-class
+ [
+ [ rep alien-vector ]
+ [ 16 + >fixnum rep alien-vector ] 2bi
+ class boa
+ ] >>getter
+ [
+ [ [ underlying1>> ] 2dip rep set-alien-vector ]
+ [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ]
+ 3bi
+ ] >>setter
+ 32 >>size
+ 8 >>align
+ rep >>rep
+ class typedef ;
-N [ 32 T-TYPE heap-size /i ]
+FUNCTOR: define-simd-256 ( T -- )
+
+N [ 32 T heap-size /i ]
N/2 [ N 2 / ]
A/2 IS ${T}-${N/2}
+A/2-boa IS ${A/2}-boa
+A/2-with IS ${A/2}-with
A DEFINES-CLASS ${T}-${N}
+A-boa DEFINES ${A}-boa
+A-with DEFINES ${A}-with
>A DEFINES >${A}
A{ DEFINES ${A}{
A-deref DEFINES-PRIVATE ${A}-deref
-A-rep IS ${A/2}-rep
+A-rep [ A/2 name>> "-rep" append "cpu.architecture" lookup ]
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-v->v-op DEFINES-PRIVATE ${A}-v->v-op
A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
WHERE
M: A byte-length drop 32 ; inline
+M: A element-type drop A-rep rep-component-type ;
+
SYNTAX: A{ \ } [ >A ] parse-literal ;
M: A pprint-delims drop \ A{ \ } ;
M: A pprint* pprint-object ;
+: A-with ( x -- simd-array )
+ [ A/2-with ] [ A/2-with ] bi [ underlying>> ] bi@
+ \ A boa ; inline
+
+: A-boa ( ... -- simd-array )
+ [ A/2-boa ] N/2 ndip A/2-boa [ underlying>> ] bi@
+ \ A boa ; inline
+
+\ A-rep 2 boa-effect \ A-boa set-stack-effect
+
INSTANCE: A sequence
: A-vv->v-op ( v1 v2 quot -- v3 )
[ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
\ A boa ; inline
-: A-v->n-op ( v1 combine-quot reduce-quot -- v2 )
- [ [ [ underlying1>> ] [ underlying2>> ] bi A-rep ] dip call A-rep ]
- dip call ; inline
+: A-v->v-op ( v1 combine-quot -- v2 )
+ [ [ underlying1>> A-rep ] dip call ]
+ [ [ underlying2>> A-rep ] dip call ] 2bi
+ \ A boa ; inline
+
+: A-v->n-op ( v1 combine-quot -- v2 )
+ [ [ underlying1>> ] [ underlying2>> ] bi A-rep (simd-v+) A-rep ] dip call ; inline
+
+\ A \ A-with \ A-rep \ A-vv->v-op \ A-v->v-op \ A-v->n-op simd-vector-words
+\ A \ A-rep define-simd-256-type
;FUNCTOR
--- /dev/null
+IN: math.vectors.simd.intrinsics.tests
+USING: math.vectors.simd.intrinsics cpu.architecture tools.test ;
+
+[ 16 ] [ uchar-16-rep rep-components ] unit-test
+[ 16 ] [ char-16-rep rep-components ] unit-test
+[ 8 ] [ ushort-8-rep rep-components ] unit-test
+[ 8 ] [ short-8-rep rep-components ] unit-test
+[ 4 ] [ uint-4-rep rep-components ] unit-test
+[ 4 ] [ int-4-rep rep-components ] unit-test
+[ 4 ] [ float-4-rep rep-components ] unit-test
+[ 2 ] [ double-2-rep rep-components ] unit-test
+
+{ 4 1 } [ uint-4-rep (simd-boa) ] must-infer-as
+{ 4 1 } [ int-4-rep (simd-boa) ] must-infer-as
+{ 4 1 } [ float-4-rep (simd-boa) ] must-infer-as
+{ 2 1 } [ double-2-rep (simd-boa) ] must-infer-as
+
+
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien alien.data cpu.architecture libc ;
+USING: alien alien.c-types alien.data assocs combinators
+cpu.architecture fry generalizations kernel libc macros math
+sequences effects accessors namespaces lexer parser vocabs.parser
+words arrays math.vectors ;
IN: math.vectors.simd.intrinsics
ERROR: bad-simd-call ;
-: (simd-v+) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-v-) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-v*) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-v/) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-vmin) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-vmax) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-vsqrt) ( v1 v2 rep -- v3 ) bad-simd-call ;
-: (simd-sum) ( v1 rep -- v2 ) bad-simd-call ;
+<<
+
+: simd-effect ( word -- effect )
+ stack-effect [ in>> "rep" suffix ] [ out>> ] bi <effect> ;
+
+SYMBOL: simd-ops
+
+V{ } clone simd-ops set-global
+
+SYNTAX: SIMD-OP:
+ scan-word dup name>> "(simd-" ")" surround create-in
+ [ nip [ bad-simd-call ] define ]
+ [ [ simd-effect ] dip set-stack-effect ]
+ [ 2array simd-ops get push ]
+ 2tri ;
+
+>>
+
+SIMD-OP: v+
+SIMD-OP: v-
+SIMD-OP: v+-
+SIMD-OP: vs+
+SIMD-OP: vs-
+SIMD-OP: vs*
+SIMD-OP: v*
+SIMD-OP: v/
+SIMD-OP: vmin
+SIMD-OP: vmax
+SIMD-OP: vsqrt
+SIMD-OP: sum
+SIMD-OP: vabs
+SIMD-OP: vbitand
+SIMD-OP: vbitor
+SIMD-OP: vbitxor
+
: (simd-broadcast) ( x rep -- v ) bad-simd-call ;
: (simd-gather-2) ( a b rep -- v ) bad-simd-call ;
: (simd-gather-4) ( a b c d rep -- v ) bad-simd-call ;
! Inefficient version for when intrinsics are missing
[ swap <displaced-alien> swap ] dip rep-size memcpy ;
+<<
+
+: rep-components ( rep -- n )
+ 16 swap rep-component-type heap-size /i ; foldable
+
+: rep-coercer ( rep -- quot )
+ {
+ { [ dup int-vector-rep? ] [ [ >fixnum ] ] }
+ { [ dup float-vector-rep? ] [ [ >float ] ] }
+ } cond nip ; foldable
+
+: rep-coerce ( value rep -- value' )
+ rep-coercer call( value -- value' ) ; inline
+
+CONSTANT: rep-gather-words
+ {
+ { 2 (simd-gather-2) }
+ { 4 (simd-gather-4) }
+ }
+
+: rep-gather-word ( rep -- word )
+ rep-components rep-gather-words at ;
+
+>>
+
+MACRO: (simd-boa) ( rep -- quot )
+ {
+ [ rep-coercer ]
+ [ rep-components ]
+ [ ]
+ [ rep-gather-word ]
+ } cleave
+ '[ _ _ napply _ _ execute ] ;
+
+GENERIC# supported-simd-op? 1 ( rep intrinsic -- ? )
+
+M: vector-rep supported-simd-op?
+ {
+ { \ (simd-v+) [ %add-vector-reps ] }
+ { \ (simd-vs+) [ %saturated-add-vector-reps ] }
+ { \ (simd-v+-) [ %add-sub-vector-reps ] }
+ { \ (simd-v-) [ %sub-vector-reps ] }
+ { \ (simd-vs-) [ %saturated-sub-vector-reps ] }
+ { \ (simd-v*) [ %mul-vector-reps ] }
+ { \ (simd-vs*) [ %saturated-mul-vector-reps ] }
+ { \ (simd-v/) [ %div-vector-reps ] }
+ { \ (simd-vmin) [ %min-vector-reps ] }
+ { \ (simd-vmax) [ %max-vector-reps ] }
+ { \ (simd-vsqrt) [ %sqrt-vector-reps ] }
+ { \ (simd-sum) [ %horizontal-add-vector-reps ] }
+ { \ (simd-vabs) [ %abs-vector-reps ] }
+ { \ (simd-vbitand) [ %and-vector-reps ] }
+ { \ (simd-vbitor) [ %or-vector-reps ] }
+ { \ (simd-vbitxor) [ %xor-vector-reps ] }
+ { \ (simd-broadcast) [ %broadcast-vector-reps ] }
+ { \ (simd-gather-2) [ %gather-vector-2-reps ] }
+ { \ (simd-gather-4) [ %gather-vector-4-reps ] }
+ } case member? ;
-USING: help.markup help.syntax sequences math math.vectors
-multiline kernel.private classes.tuple.private
-math.vectors.simd.intrinsics cpu.architecture ;
+USING: classes.tuple.private cpu.architecture help.markup
+help.syntax kernel.private math math.vectors
+math.vectors.simd.intrinsics sequences ;
IN: math.vectors.simd
ARTICLE: "math.vectors.simd.intro" "Introduction to SIMD support"
"There should never be any reason to use " { $link "math.vectors.simd.intrinsics" } " directly, but they too have a straightforward, but lower-level, interface." ;
ARTICLE: "math.vectors.simd.support" "Supported SIMD instruction sets and operations"
-"At present, the SIMD support makes use of SSE2 and a few SSE3 instructions on x86 CPUs."
+"At present, the SIMD support makes use of a subset of SSE up to SSE4.1. The subset used depends on the current CPU type."
$nl
-"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } ". If SSE3 is not available, software fallbacks are used for " { $link sum } " and related words, decreasing performance."
+"SSE1 only supports single-precision SIMD (" { $snippet "float-4" } " and " { $snippet "float-8" } ")."
$nl
-"On PowerPC, or older x86 chips without SSE2, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance."
+"SSE2 introduces double-precision SIMD (" { $snippet "double-2" } " and " { $snippet "double-4" } ") and integer SIMD (all types). Integer SIMD in missing a few features, in particular the " { $link vmin } " and " { $link vmax } " operations only work on " { $snippet "uchar-16" } " and " { $snippet "short-8" } "."
+$nl
+"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } "."
+$nl
+"SSSE3 introduces " { $link vabs } " for " { $snippet "char-16" } ", " { $snippet "short-8" } " and " { $snippet "int-4" } "."
+$nl
+"SSE4.1 introduces " { $link vmin } " and " { $link vmax } " for all remaining integer types."
+$nl
+"On PowerPC, or older x86 chips without SSE, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance."
$nl
"The primities in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary do not have software fallbacks, but they should not be called directly in any case." ;
ARTICLE: "math.vectors.simd.types" "SIMD vector types"
-"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type such as " { $snippet "float" } " or " { $snippet "double" } ", and " { $snippet "count" } " is a vector dimension, such as 2, 4, or 8."
-$nl
-"The following vector types are defined:"
-{ $subsection float-4 }
-{ $subsection double-2 }
-{ $subsection float-8 }
-{ $subsection double-4 }
-"For each vector type, several words are defined:"
+"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type and " { $snippet "count" } " is a vector dimension."
+$nl
+"To use a SIMD vector type, a parsing word is used to generate the relevant code and bring it into the vocabulary search path; this is the same idea as with " { $link "specialized-arrays" } ":"
+{ $subsection POSTPONE: SIMD: }
+"The following vector types are supported:"
+{ $code
+ "char-16"
+ "uchar-16"
+ "char-32"
+ "uchar-32"
+ "short-8"
+ "ushort-8"
+ "short-16"
+ "ushort-16"
+ "int-4"
+ "uint-4"
+ "int-8"
+ "uint-8"
+ "longlong-2"
+ "ulonglong-2"
+ "longlong-4"
+ "ulonglong-4"
+ "float-4"
+ "float-8"
+ "double-2"
+ "double-4"
+} ;
+
+ARTICLE: "math.vectors.simd.words" "SIMD vector words"
+"For each SIMD vector type, several words are defined:"
{ $table
{ "Word" "Stack effect" "Description" }
{ { $snippet "type-with" } { $snippet "( x -- simd-array )" } "creates a new instance where all components are set to a single scalar" }
{ { $snippet ">type" } { $snippet "( seq -- simd-array )" } "creates a new instance initialized with the elements of an existing sequence, which must have the correct length" }
{ { $snippet "type{" } { $snippet "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" }
}
-"The " { $link float-4 } " and " { $link double-2 } " types correspond to 128-bit vector registers. The " { $link float-8 } " and " { $link double-4 } " types are not directly supported in hardware, and instead unbox to a pair of 128-bit vector registers."
-$nl
-"Operations on " { $link float-4 } " instances:"
-{ $subsection float-4-with }
-{ $subsection float-4-boa }
-{ $subsection POSTPONE: float-4{ }
-"Operations on " { $link double-2 } " instances:"
-{ $subsection double-2-with }
-{ $subsection double-2-boa }
-{ $subsection POSTPONE: double-2{ }
-"Operations on " { $link float-8 } " instances:"
-{ $subsection float-8-with }
-{ $subsection float-8-boa }
-{ $subsection POSTPONE: float-8{ }
-"Operations on " { $link double-4 } " instances:"
-{ $subsection double-4-with }
-{ $subsection double-4-boa }
-{ $subsection POSTPONE: double-4{ }
"To actually perform vector arithmetic on SIMD vectors, use " { $link "math-vectors" } " words."
{ $see-also "c-types-specs" } ;
$nl
"For example, in the following, no SIMD operations are used at all, because the compiler's propagation pass does not consider dynamic variable usage:"
{ $code
-<" USING: compiler.tree.debugger math.vectors
+"""USING: compiler.tree.debugger math.vectors
math.vectors.simd ;
SYMBOLS: x y ;
double-4{ 1.5 2.0 3.7 0.4 } x set
double-4{ 1.5 2.0 3.7 0.4 } y set
x get y get v+
-] optimizer-report."> }
+] optimizer-report.""" }
"The following word benefits from SIMD optimization, because it begins with an unsafe declaration:"
{ $code
-<" USING: compiler.tree.debugger kernel.private
+"""USING: compiler.tree.debugger kernel.private
math.vectors math.vectors.simd ;
+SIMD: float
+IN: simd-demo
: interpolate ( v a b -- w )
{ float-4 float-4 float-4 } declare
[ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
-\ interpolate optimizer-report. "> }
+\ interpolate optimizer-report.""" }
"Note that using " { $link declare } " is not recommended. Safer ways of getting type information for the input parameters to a word include defining methods on a generic word (the value being dispatched upon has a statically known type in the method body), as well as using " { $link "hints" } " and " { $link POSTPONE: inline } " declarations."
$nl
"Here is a better version of the " { $snippet "interpolate" } " words above that uses hints:"
{ $code
-<" USING: compiler.tree.debugger hints
+"""USING: compiler.tree.debugger hints
math.vectors math.vectors.simd ;
+SIMD: float
+IN: simd-demo
: interpolate ( v a b -- w )
[ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
HINTS: interpolate float-4 float-4 float-4 ;
-\ interpolate optimizer-report. "> }
+\ interpolate optimizer-report. """ }
"This time, the optimizer report lists calls to both SIMD primitives and high-level vector words, because hints cause two code paths to be generated. The " { $snippet "optimized." } " word can be used to make sure that the fast code path consists entirely of calls to primitives."
$nl
"If the " { $snippet "interpolate" } " word was to be used in several places with different types of vectors, it would be best to declare it " { $link POSTPONE: inline } "."
$nl
"In the " { $snippet "interpolate" } " word, there is still a call to the " { $link <tuple-boa> } " primitive, because the return value at the end is being boxed on the heap. In the next example, no memory allocation occurs at all because the SIMD vectors are stored inside a struct class (see " { $link "classes.struct" } "); also note the use of inlining:"
{ $code
-<" USING: compiler.tree.debugger math.vectors math.vectors.simd ;
+"""USING: compiler.tree.debugger math.vectors math.vectors.simd ;
+SIMD: float
IN: simd-demo
STRUCT: actor
[ >float ] dip
[ update-velocity ] [ update-position ] 2bi ;
-M\ actor advance optimized.">
+M\ actor advance optimized."""
}
"The " { $vocab-link "compiler.cfg.debugger" } " vocabulary can give a lower-level picture of the generated code, that includes register assignments and other low-level details. To look at low-level optimizer output, call " { $snippet "test-mr mr." } " on a word or quotation:"
{ $code
-<" USE: compiler.tree.debugger
+"""USE: compiler.tree.debugger
-M\ actor advance test-mr mr."> }
+M\ actor advance test-mr mr.""" }
"An example of a high-performance algorithm that uses SIMD primitives can be found in the " { $vocab-link "benchmark.nbody-simd" } " vocabulary." ;
ARTICLE: "math.vectors.simd.intrinsics" "Low-level SIMD primitives"
}
"The compiler converts " { $link "math-vectors" } " into SIMD primitives automatically in cases where it is safe; this means that the input types are known to be SIMD vectors, and the CPU supports SIMD."
$nl
-"It is best to avoid calling these primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "."
-{ $subsection (simd-v+) }
-{ $subsection (simd-v-) }
-{ $subsection (simd-v/) }
-{ $subsection (simd-vmin) }
-{ $subsection (simd-vmax) }
-{ $subsection (simd-vsqrt) }
-{ $subsection (simd-sum) }
-{ $subsection (simd-broadcast) }
-{ $subsection (simd-gather-2) }
-{ $subsection (simd-gather-4) }
+"It is best to avoid calling SIMD primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "."
+$nl
"There are two primitives which are used to implement accessing SIMD vector fields of " { $link "classes.struct" } ":"
{ $subsection alien-vector }
{ $subsection set-alien-vector }
"For the most part, the above primitives correspond directly to vector arithmetic words. They take a representation parameter, which is one of the singleton members of the " { $link vector-rep } " union in the " { $vocab-link "cpu.architecture" } " vocabulary." ;
ARTICLE: "math.vectors.simd.alien" "SIMD data in struct classes"
-"Struct classes may contain fields which store SIMD data; use one of the following C type names:"
-{ $code
-<" float-4
-double-2
-float-8
-double-4"> }
-"Passing SIMD data as function parameters is not yet supported." ;
+"Struct classes may contain fields which store SIMD data; for each SIMD vector type listed in " { $snippet "math.vectors.simd.types" } " there is a C type with the same name."
+$nl
+"Only SIMD struct fields are allowed at the moment; passing SIMD data as function parameters is not yet supported." ;
+
+ARTICLE: "math.vectors.simd.accuracy" "Numerical accuracy of SIMD primitives"
+"No guarantees are made that " { $vocab-link "math.vectors.simd" } " words will give identical results on different SSE versions, or between the hardware intrinsics and the software fallbacks."
+$nl
+"In particular, horizontal operations on " { $snippet "float-4" } " and " { $snippet "float-8" } " are affected by this. They are computed with lower precision in intrinsics than the software fallback. Horizontal opeartions include anything involving adding together the components of a vector, such as " { $link sum } " or " { $link normalize } "." ;
ARTICLE: "math.vectors.simd" "Hardware vector arithmetic (SIMD)"
"The " { $vocab-link "math.vectors.simd" } " vocabulary extends the " { $vocab-link "math.vectors" } " vocabulary to support efficient vector arithmetic on small, fixed-size vectors."
{ $subsection "math.vectors.simd.intro" }
{ $subsection "math.vectors.simd.types" }
+{ $subsection "math.vectors.simd.words" }
{ $subsection "math.vectors.simd.support" }
+{ $subsection "math.vectors.simd.accuracy" }
{ $subsection "math.vectors.simd.efficiency" }
{ $subsection "math.vectors.simd.alien" }
{ $subsection "math.vectors.simd.intrinsics" } ;
-! ! ! float-4
-
-HELP: float-4
-{ $class-description "A sequence of four single-precision floating point values. New instances can be created with " { $link float-4-with } " or " { $link float-4-boa } "." } ;
-
-HELP: float-4-with
-{ $values { "x" float } { "simd-array" float-4 } }
-{ $description "Creates a new vector with all four components equal to a scalar." } ;
-
-HELP: float-4-boa
-{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" float-4 } }
-{ $description "Creates a new vector from four scalar components." } ;
-
-HELP: float-4{
-{ $syntax "float-4{ a b c d }" }
-{ $description "Literal syntax for a " { $link float-4 } "." } ;
-
-! ! ! double-2
-
-HELP: double-2
-{ $class-description "A sequence of two double-precision floating point values. New instances can be created with " { $link double-2-with } " or " { $link double-2-boa } "." } ;
-
-HELP: double-2-with
-{ $values { "x" float } { "simd-array" double-2 } }
-{ $description "Creates a new vector with both components equal to a scalar." } ;
-
-HELP: double-2-boa
-{ $values { "a" float } { "b" float } { "simd-array" double-2 } }
-{ $description "Creates a new vector from two scalar components." } ;
-
-HELP: double-2{
-{ $syntax "double-2{ a b }" }
-{ $description "Literal syntax for a " { $link double-2 } "." } ;
-
-! ! ! float-8
-
-HELP: float-8
-{ $class-description "A sequence of eight single-precision floating point values. New instances can be created with " { $link float-8-with } " or " { $link float-8-boa } "." } ;
-
-HELP: float-8-with
-{ $values { "x" float } { "simd-array" float-8 } }
-{ $description "Creates a new vector with all eight components equal to a scalar." } ;
-
-HELP: float-8-boa
-{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "e" float } { "f" float } { "g" float } { "h" float } { "simd-array" float-8 } }
-{ $description "Creates a new vector from eight scalar components." } ;
-
-HELP: float-8{
-{ $syntax "float-8{ a b c d e f g h }" }
-{ $description "Literal syntax for a " { $link float-8 } "." } ;
-
-! ! ! double-4
-
-HELP: double-4
-{ $class-description "A sequence of four double-precision floating point values. New instances can be created with " { $link double-4-with } " or " { $link double-4-boa } "." } ;
-
-HELP: double-4-with
-{ $values { "x" float } { "simd-array" double-4 } }
-{ $description "Creates a new vector with all four components equal to a scalar." } ;
-
-HELP: double-4-boa
-{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" double-4 } }
-{ $description "Creates a new vector from four scalar components." } ;
-
-HELP: double-4{
-{ $syntax "double-4{ a b c d }" }
-{ $description "Literal syntax for a " { $link double-4 } "." } ;
+HELP: SIMD:
+{ $syntax "SIMD: type" }
+{ $values { "type" "a scalar C type" } }
+{ $description "Defines 128-bit and 256-bit SIMD arrays for holding elements of " { $snippet "type" } " into the vocabulary search path. The possible type/length combinations are listed in " { $link "math.vectors.simd.types" } " and the generated words are documented in " { $link "math.vectors.simd.words" } "." } ;
ABOUT: "math.vectors.simd"
+USING: accessors arrays classes compiler compiler.tree.debugger
+effects fry io kernel kernel.private math math.functions
+math.private math.vectors math.vectors.simd
+math.vectors.simd.private prettyprint random sequences system
+tools.test vocabs assocs compiler.cfg.debugger words
+locals math.vectors.specialization combinators cpu.architecture
+math.vectors.simd.intrinsics namespaces byte-arrays alien
+specialized-arrays classes.struct eval ;
+FROM: alien.c-types => c-type-boxed-class ;
+SPECIALIZED-ARRAY: float
+SIMD: char
+SIMD: uchar
+SIMD: short
+SIMD: ushort
+SIMD: int
+SIMD: uint
+SIMD: longlong
+SIMD: ulonglong
+SIMD: float
+SIMD: double
IN: math.vectors.simd.tests
-USING: math math.vectors.simd math.vectors.simd.private
-math.vectors math.functions math.private kernel.private compiler
-sequences tools.test compiler.tree.debugger accessors kernel
-system ;
-[ float-4{ 0 0 0 0 } ] [ float-4 new ] unit-test
+! Make sure the functor doesn't generate bogus vocabularies
+2 [ [ "USE: math.vectors.simd SIMD: rubinius" eval( -- ) ] must-fail ] times
-[ float-4{ 0 0 0 0 } ] [ [ float-4 new ] compile-call ] unit-test
+[ f ] [ "math.vectors.simd.instances.rubinius" vocab ] unit-test
+! Test type propagation
[ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test
[ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test
-[ float-4{ 12 12 12 12 } ] [
- 12 [ float-4-with ] compile-call
-] unit-test
-
-[ float-4{ 1 2 3 4 } ] [
- 1 2 3 4 [ float-4-boa ] compile-call
-] unit-test
-
-[ float-4{ 11 22 33 44 } ] [
- float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
- [ { float-4 float-4 } declare v+ ] compile-call
-] unit-test
-
-[ float-4{ -9 -18 -27 -36 } ] [
- float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
- [ { float-4 float-4 } declare v- ] compile-call
-] unit-test
-
-[ float-4{ 10 40 90 160 } ] [
- float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
- [ { float-4 float-4 } declare v* ] compile-call
-] unit-test
-
-[ float-4{ 10 100 1000 10000 } ] [
- float-4{ 100 2000 30000 400000 } float-4{ 10 20 30 40 }
- [ { float-4 float-4 } declare v/ ] compile-call
-] unit-test
-
-[ float-4{ -10 -20 -30 -40 } ] [
- float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
- [ { float-4 float-4 } declare vmin ] compile-call
-] unit-test
-
-[ float-4{ 10 20 30 40 } ] [
- float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
- [ { float-4 float-4 } declare vmax ] compile-call
-] unit-test
-
-[ 10.0 ] [
- float-4{ 1 2 3 4 }
- [ { float-4 } declare sum ] compile-call
-] unit-test
+[ V{ float-4 } ] [ [ { float-4 } declare normalize ] final-classes ] unit-test
-[ 13.0 ] [
- float-4{ 1 2 3 4 }
- [ { float-4 } declare sum 3.0 + ] compile-call
-] unit-test
+[ V{ float-4 } ] [ [ { float-4 float-4 } declare v+ ] final-classes ] unit-test
-[ 8.0 ] [
- float-4{ 1 2 3 4 } float-4{ 2 0 2 0 }
- [ { float-4 float-4 } declare v. ] compile-call
-] unit-test
+! Test puns; only on x86
+cpu x86? [
+ [ double-2{ 4 1024 } ] [
+ float-4{ 0 1 0 2 }
+ [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
+ ] unit-test
+
+ [ 33.0 ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call
+ ] unit-test
+] when
-[ float-4{ 5 10 15 20 } ] [
- 5.0 float-4{ 1 2 3 4 }
- [ { float float-4 } declare n*v ] compile-call
+! Fuzz testing
+CONSTANT: simd-classes
+ {
+ char-16
+ uchar-16
+ char-32
+ uchar-32
+ short-8
+ ushort-8
+ short-16
+ ushort-16
+ int-4
+ uint-4
+ int-8
+ uint-8
+ longlong-2
+ ulonglong-2
+ longlong-4
+ ulonglong-4
+ float-4
+ float-8
+ double-2
+ double-4
+ }
+
+: with-ctors ( -- seq )
+ simd-classes [ [ name>> "-with" append ] [ vocabulary>> ] bi lookup ] map ;
+
+: boa-ctors ( -- seq )
+ simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup ] map ;
+
+: check-optimizer ( seq inputs quot eq-quot -- )
+ '[
+ @
+ [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
+ [ [ call ] dip call ]
+ [ [ call ] dip compile-call ] 2tri @ not
+ ] filter ; inline
+
+"== Checking -new constructors" print
+
+[ { } ] [
+ simd-classes [ [ [ ] ] dip '[ _ new ] ] [ = ] check-optimizer
+] unit-test
+
+[ { } ] [
+ simd-classes [ '[ _ new ] compile-call [ zero? ] all? not ] filter
+] unit-test
+
+"== Checking -with constructors" print
+
+[ { } ] [
+ with-ctors [
+ [ 1000 random '[ _ ] ] dip '[ { fixnum } declare _ execute ]
+ ] [ = ] check-optimizer
+] unit-test
+
+"== Checking -boa constructors" print
+
+[ { } ] [
+ boa-ctors [
+ dup stack-effect in>> length
+ [ nip [ 1000 random ] [ ] replicate-as ]
+ [ fixnum <array> swap '[ _ declare _ execute ] ]
+ 2bi
+ ] [ = ] check-optimizer
+] unit-test
+
+"== Checking vector operations" print
+
+: random-vector ( class -- vec )
+ new [ drop 1000 random ] map ;
+
+:: check-vector-op ( word inputs class elt-class -- inputs quot )
+ inputs [
+ [
+ {
+ { +vector+ [ class random-vector ] }
+ { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
+ } case
+ ] [ ] map-as
+ ] [
+ [
+ {
+ { +vector+ [ class ] }
+ { +scalar+ [ elt-class ] }
+ } case
+ ] map
+ ] bi
+ word '[ _ declare _ execute ] ;
+
+: remove-float-words ( alist -- alist' )
+ [ drop { vsqrt n/v v/n v/ normalize } member? not ] assoc-filter ;
+
+: ops-to-check ( elt-class -- alist )
+ [ vector-words >alist ] dip
+ float = [ remove-float-words ] unless ;
+
+: check-vector-ops ( class elt-class compare-quot -- )
+ [
+ [ nip ops-to-check ] 2keep
+ '[ first2 inputs _ _ check-vector-op ]
+ ] dip check-optimizer ; inline
+
+: approx= ( x y -- ? )
+ {
+ { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
+ { [ 2dup [ sequence? ] both? ] [
+ [
+ {
+ { [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
+ { [ 2dup [ fp-nan? ] either? not ] [ -1.e8 ~ ] }
+ } cond
+ ] 2all?
+ ] }
+ } cond ;
+
+: simd-classes&reps ( -- alist )
+ simd-classes [
+ {
+ { [ dup name>> "float" head? ] [ float [ approx= ] ] }
+ { [ dup name>> "double" tail? ] [ float [ = ] ] }
+ [ fixnum [ = ] ]
+ } cond 3array
+ ] map ;
+
+simd-classes&reps [
+ [ [ { } ] ] dip first3 '[ _ _ _ check-vector-ops ] unit-test
+] each
+
+! Other regressions
+[ 8000000 ] [
+ int-8{ 1000 1000 1000 1000 1000 1000 1000 1000 }
+ [ { int-8 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
+] unit-test
+
+! Vector alien intrinsics
+[ float-4{ 1 2 3 4 } ] [
+ [
+ float-4{ 1 2 3 4 }
+ underlying>> 0 float-4-rep alien-vector
+ ] compile-call float-4 boa
] unit-test
-[ float-4{ 5 10 15 20 } ] [
- float-4{ 1 2 3 4 } 5.0
- [ { float float-4 } declare v*n ] compile-call
+[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
+ 16 [ 1 ] B{ } replicate-as 16 <byte-array>
+ [
+ 0 [
+ { byte-array c-ptr fixnum } declare
+ float-4-rep set-alien-vector
+ ] compile-call
+ ] keep
] unit-test
-[ float-4{ 10 5 2 5 } ] [
- 10.0 float-4{ 1 2 5 2 }
- [ { float float-4 } declare n/v ] compile-call
+[ float-array{ 1 2 3 4 } ] [
+ [
+ float-array{ 1 2 3 4 } underlying>>
+ float-array{ 4 3 2 1 } clone
+ [ underlying>> 0 float-4-rep set-alien-vector ] keep
+ ] compile-call
] unit-test
-[ float-4{ 0.5 1 1.5 2 } ] [
- float-4{ 1 2 3 4 } 2
- [ { float float-4 } declare v/n ] compile-call
-] unit-test
+STRUCT: simd-struct
+{ x float-4 }
+{ y double-2 }
+{ z double-4 }
+{ w float-8 } ;
-[ float-4{ 1 0 0 0 } ] [
- float-4{ 10 0 0 0 }
- [ { float-4 } declare normalize ] compile-call
-] unit-test
+[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
-[ 30.0 ] [
+[
float-4{ 1 2 3 4 }
- [ { float-4 } declare norm-sq ] compile-call
-] unit-test
-
-[ t ] [
- float-4{ 1 0 0 0 }
- float-4{ 0 1 0 0 }
- [ { float-4 float-4 } declare distance ] compile-call
- 2 sqrt 1.0e-6 ~
-] unit-test
-
-[ double-2{ 12 12 } ] [
- 12 [ double-2-with ] compile-call
-] unit-test
-
-[ double-2{ 1 2 } ] [
- 1 2 [ double-2-boa ] compile-call
-] unit-test
-
-[ double-2{ 11 22 } ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v+ ] compile-call
-] unit-test
-
-[ double-2{ -9 -18 } ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v- ] compile-call
-] unit-test
-
-[ double-2{ 10 40 } ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v* ] compile-call
-] unit-test
-
-[ double-2{ 10 100 } ] [
- double-2{ 100 2000 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v/ ] compile-call
-] unit-test
-
-[ double-2{ -10 -20 } ] [
- double-2{ -10 20 } double-2{ 10 -20 }
- [ { double-2 double-2 } declare vmin ] compile-call
-] unit-test
-
-[ double-2{ 10 20 } ] [
- double-2{ -10 20 } double-2{ 10 -20 }
- [ { double-2 double-2 } declare vmax ] compile-call
-] unit-test
-
-[ 3.0 ] [
- double-2{ 1 2 }
- [ { double-2 } declare sum ] compile-call
-] unit-test
-
-[ 7.0 ] [
- double-2{ 1 2 }
- [ { double-2 } declare sum 4.0 + ] compile-call
-] unit-test
-
-[ 16.0 ] [
- double-2{ 1 2 } double-2{ 2 7 }
- [ { double-2 double-2 } declare v. ] compile-call
-] unit-test
-
-[ double-2{ 5 10 } ] [
- 5.0 double-2{ 1 2 }
- [ { float double-2 } declare n*v ] compile-call
-] unit-test
-
-[ double-2{ 5 10 } ] [
- double-2{ 1 2 } 5.0
- [ { float double-2 } declare v*n ] compile-call
-] unit-test
-
-[ double-2{ 10 5 } ] [
- 10.0 double-2{ 1 2 }
- [ { float double-2 } declare n/v ] compile-call
-] unit-test
-
-[ double-2{ 0.5 1 } ] [
- double-2{ 1 2 } 2
- [ { float double-2 } declare v/n ] compile-call
-] unit-test
-
-[ double-2{ 0 0 } ] [ double-2 new ] unit-test
-
-[ double-2{ 1 0 } ] [
- double-2{ 10 0 }
- [ { double-2 } declare normalize ] compile-call
-] unit-test
-
-[ 5.0 ] [
- double-2{ 1 2 }
- [ { double-2 } declare norm-sq ] compile-call
-] unit-test
-
-[ t ] [
- double-2{ 1 0 }
- double-2{ 0 1 }
- [ { double-2 double-2 } declare distance ] compile-call
- 2 sqrt 1.0e-6 ~
-] unit-test
-
-[ double-4{ 0 0 0 0 } ] [ double-4 new ] unit-test
-
-[ double-4{ 1 2 3 4 } ] [
- 1 2 3 4 double-4-boa
-] unit-test
-
-[ double-4{ 1 1 1 1 } ] [
- 1 double-4-with
-] unit-test
-
-[ double-4{ 0 1 2 3 } ] [
- 1 double-4-with [ * ] map-index
-] unit-test
-
-[ V{ float } ] [ [ { double-4 } declare norm-sq ] final-classes ] unit-test
-
-[ V{ float } ] [ [ { double-4 } declare norm ] final-classes ] unit-test
-
-[ double-4{ 12 12 12 12 } ] [
- 12 [ double-4-with ] compile-call
-] unit-test
-
-[ double-4{ 1 2 3 4 } ] [
- 1 2 3 4 [ double-4-boa ] compile-call
-] unit-test
-
-[ double-4{ 11 22 33 44 } ] [
- double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
- [ { double-4 double-4 } declare v+ ] compile-call
-] unit-test
-
-[ double-4{ -9 -18 -27 -36 } ] [
- double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
- [ { double-4 double-4 } declare v- ] compile-call
-] unit-test
-
-[ double-4{ 10 40 90 160 } ] [
- double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
- [ { double-4 double-4 } declare v* ] compile-call
-] unit-test
-
-[ double-4{ 10 100 1000 10000 } ] [
- double-4{ 100 2000 30000 400000 } double-4{ 10 20 30 40 }
- [ { double-4 double-4 } declare v/ ] compile-call
-] unit-test
-
-[ double-4{ -10 -20 -30 -40 } ] [
- double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
- [ { double-4 double-4 } declare vmin ] compile-call
-] unit-test
-
-[ double-4{ 10 20 30 40 } ] [
- double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
- [ { double-4 double-4 } declare vmax ] compile-call
-] unit-test
-
-[ 10.0 ] [
- double-4{ 1 2 3 4 }
- [ { double-4 } declare sum ] compile-call
-] unit-test
-
-[ 13.0 ] [
- double-4{ 1 2 3 4 }
- [ { double-4 } declare sum 3.0 + ] compile-call
-] unit-test
-
-[ 8.0 ] [
- double-4{ 1 2 3 4 } double-4{ 2 0 2 0 }
- [ { double-4 double-4 } declare v. ] compile-call
-] unit-test
-
-[ double-4{ 5 10 15 20 } ] [
- 5.0 double-4{ 1 2 3 4 }
- [ { float double-4 } declare n*v ] compile-call
-] unit-test
-
-[ double-4{ 5 10 15 20 } ] [
- double-4{ 1 2 3 4 } 5.0
- [ { float double-4 } declare v*n ] compile-call
-] unit-test
-
-[ double-4{ 10 5 2 5 } ] [
- 10.0 double-4{ 1 2 5 2 }
- [ { float double-4 } declare n/v ] compile-call
-] unit-test
-
-[ double-4{ 0.5 1 1.5 2 } ] [
- double-4{ 1 2 3 4 } 2
- [ { float double-4 } declare v/n ] compile-call
-] unit-test
-
-[ double-4{ 1 0 0 0 } ] [
- double-4{ 10 0 0 0 }
- [ { double-4 } declare normalize ] compile-call
-] unit-test
-
-[ 30.0 ] [
- double-4{ 1 2 3 4 }
- [ { double-4 } declare norm-sq ] compile-call
-] unit-test
-
-[ t ] [
- double-4{ 1 0 0 0 }
- double-4{ 0 1 0 0 }
- [ { double-4 double-4 } declare distance ] compile-call
- 2 sqrt 1.0e-6 ~
-] unit-test
-
-[ float-8{ 0 0 0 0 0 0 0 0 } ] [ float-8 new ] unit-test
-
-[ float-8{ 0 0 0 0 0 0 0 0 } ] [ [ float-8 new ] compile-call ] unit-test
-
-[ float-8{ 1 1 1 1 1 1 1 1 } ] [ 1 float-8-with ] unit-test
-
-[ float-8{ 1 1 1 1 1 1 1 1 } ] [ [ 1 float-8-with ] compile-call ] unit-test
-
-[ float-8{ 1 2 3 4 5 6 7 8 } ] [ 1 2 3 4 5 6 7 8 float-8-boa ] unit-test
-
-[ float-8{ 1 2 3 4 5 6 7 8 } ] [ [ 1 2 3 4 5 6 7 8 float-8-boa ] compile-call ] unit-test
-
-[ float-8{ 3 6 9 12 15 18 21 24 } ] [
+ double-2{ 2 1 }
+ double-4{ 4 3 2 1 }
float-8{ 1 2 3 4 5 6 7 8 }
- float-8{ 2 4 6 8 10 12 14 16 }
- [ { float-8 float-8 } declare v+ ] compile-call
+] [
+ simd-struct <struct>
+ float-4{ 1 2 3 4 } >>x
+ double-2{ 2 1 } >>y
+ double-4{ 4 3 2 1 } >>z
+ float-8{ 1 2 3 4 5 6 7 8 } >>w
+ { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
] unit-test
-[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+[
+ float-4{ 1 2 3 4 }
+ double-2{ 2 1 }
+ double-4{ 4 3 2 1 }
float-8{ 1 2 3 4 5 6 7 8 }
- float-8{ 2 4 6 8 10 12 14 16 }
- [ { float-8 float-8 } declare v- ] compile-call
-] unit-test
-
-[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
- -0.5
- float-8{ 2 4 6 8 10 12 14 16 }
- [ { float float-8 } declare n*v ] compile-call
-] unit-test
-
-[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
- float-8{ 2 4 6 8 10 12 14 16 }
- -0.5
- [ { float-8 float } declare v*n ] compile-call
-] unit-test
-
-[ float-8{ 256 128 64 32 16 8 4 2 } ] [
- 256.0
- float-8{ 1 2 4 8 16 32 64 128 }
- [ { float float-8 } declare n/v ] compile-call
-] unit-test
-
-[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
- float-8{ 2 4 6 8 10 12 14 16 }
- -2.0
- [ { float-8 float } declare v/n ] compile-call
-] unit-test
-
-! Test puns; only on x86
-cpu x86? [
- [ double-2{ 4 1024 } ] [
- float-4{ 0 1 0 2 }
- [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
- ] unit-test
-
- [ 33.0 ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call
- ] unit-test
-] when
+] [
+ [
+ simd-struct <struct>
+ float-4{ 1 2 3 4 } >>x
+ double-2{ 2 1 } >>y
+ double-4{ 4 3 2 1 } >>z
+ float-8{ 1 2 3 4 5 6 7 8 } >>w
+ { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
+ ] compile-call
+] unit-test
+
+[ ] [ char-16 new 1array stack. ] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types byte-arrays cpu.architecture
-kernel math math.functions math.vectors
-math.vectors.simd.functor math.vectors.simd.intrinsics
-math.vectors.specialization parser prettyprint.custom sequences
-sequences.private locals assocs words fry ;
-FROM: alien.c-types => float ;
-QUALIFIED-WITH: math m
+USING: alien.c-types combinators fry kernel lexer math math.parser
+math.vectors.simd.functor sequences splitting vocabs.generated
+vocabs.loader vocabs.parser words ;
+QUALIFIED-WITH: alien.c-types c
IN: math.vectors.simd
-<<
-
-DEFER: float-4
-DEFER: double-2
-DEFER: float-8
-DEFER: double-4
-
-"double" define-simd-128
-"float" define-simd-128
-"double" define-simd-256
-"float" define-simd-256
-
->>
-
-: float-4-with ( x -- simd-array )
- [ 4 ] dip >float '[ _ ] \ float-4 new replicate-as ;
-
-: float-4-boa ( a b c d -- simd-array )
- \ float-4 new 4sequence ;
-
-: double-2-with ( x -- simd-array )
- [ 2 ] dip >float '[ _ ] \ double-2 new replicate-as ;
-
-: double-2-boa ( a b -- simd-array )
- \ double-2 new 2sequence ;
-
-! More efficient expansions for the above, used when SIMD is
-! actually available.
-
-<<
-
-\ float-4-with [
- drop
- \ (simd-broadcast) "intrinsic" word-prop [
- [ >float float-4-rep (simd-broadcast) \ float-4 boa ]
- ] [ \ float-4-with def>> ] if
-] "custom-inlining" set-word-prop
-
-\ float-4-boa [
- drop
- \ (simd-gather-4) "intrinsic" word-prop [
- [| a b c d |
- a >float b >float c >float d >float
- float-4-rep (simd-gather-4) \ float-4 boa
- ]
- ] [ \ float-4-boa def>> ] if
-] "custom-inlining" set-word-prop
-
-\ double-2-with [
- drop
- \ (simd-broadcast) "intrinsic" word-prop [
- [ >float double-2-rep (simd-broadcast) \ double-2 boa ]
- ] [ \ double-2-with def>> ] if
-] "custom-inlining" set-word-prop
-
-\ double-2-boa [
- drop
- \ (simd-gather-4) "intrinsic" word-prop [
- [ [ >float ] bi@ double-2-rep (simd-gather-2) \ double-2 boa ]
- ] [ \ double-2-boa def>> ] if
-] "custom-inlining" set-word-prop
-
->>
-
-: float-8-with ( x -- simd-array )
- [ float-4-with ] [ float-4-with ] bi [ underlying>> ] bi@
- \ float-8 boa ; inline
-
-:: float-8-boa ( a b c d e f g h -- simd-array )
- a b c d float-4-boa
- e f g h float-4-boa
- [ underlying>> ] bi@
- \ float-8 boa ; inline
-
-: double-4-with ( x -- simd-array )
- [ double-2-with ] [ double-2-with ] bi [ underlying>> ] bi@
- \ double-4 boa ; inline
-
-:: double-4-boa ( a b c d -- simd-array )
- a b double-2-boa
- c d double-2-boa
- [ underlying>> ] bi@
- \ double-4 boa ; inline
-
-<<
+ERROR: bad-base-type type ;
<PRIVATE
-! Filter out operations that are not available, eg horizontal adds
-! on SSE2. Fallback code in math.vectors is used in that case.
-
-: supported-simd-ops ( assoc -- assoc' )
- {
- { v+ (simd-v+) }
- { v- (simd-v-) }
- { v* (simd-v*) }
- { v/ (simd-v/) }
- { vmin (simd-vmin) }
- { vmax (simd-vmax) }
- { sum (simd-sum) }
- } [ nip "intrinsic" word-prop ] assoc-filter
- '[ drop _ key? ] assoc-filter ;
-
-! Some SIMD operations are defined in terms of others.
+: simd-vocab ( base-type -- vocab )
+ "math.vectors.simd.instances." prepend ;
-:: high-level-ops ( ctor -- assoc )
+: parse-base-type ( string -- c-type )
{
- { vneg [ [ dup v- ] keep v- ] }
- { v. [ v* sum ] }
- { n+v [ [ ctor execute ] dip v+ ] }
- { v+n [ ctor execute v+ ] }
- { n-v [ [ ctor execute ] dip v- ] }
- { v-n [ ctor execute v- ] }
- { n*v [ [ ctor execute ] dip v* ] }
- { v*n [ ctor execute v* ] }
- { n/v [ [ ctor execute ] dip v/ ] }
- { v/n [ ctor execute v/ ] }
- { norm-sq [ dup v. assert-positive ] }
- { norm [ norm-sq sqrt ] }
- { normalize [ dup norm v/n ] }
- { distance [ v- norm ] }
- } ;
-
-:: simd-vector-words ( class ctor elt-type assoc -- )
- class elt-type assoc supported-simd-ops ctor high-level-ops assoc-union
- specialize-vector-words ;
+ { "char" [ c:char ] }
+ { "uchar" [ c:uchar ] }
+ { "short" [ c:short ] }
+ { "ushort" [ c:ushort ] }
+ { "int" [ c:int ] }
+ { "uint" [ c:uint ] }
+ { "longlong" [ c:longlong ] }
+ { "ulonglong" [ c:ulonglong ] }
+ { "float" [ c:float ] }
+ { "double" [ c:double ] }
+ [ bad-base-type ]
+ } case ;
PRIVATE>
-\ float-4 \ float-4-with m:float H{
- { v+ [ [ (simd-v+) ] float-4-vv->v-op ] }
- { v- [ [ (simd-v-) ] float-4-vv->v-op ] }
- { v* [ [ (simd-v*) ] float-4-vv->v-op ] }
- { v/ [ [ (simd-v/) ] float-4-vv->v-op ] }
- { vmin [ [ (simd-vmin) ] float-4-vv->v-op ] }
- { vmax [ [ (simd-vmax) ] float-4-vv->v-op ] }
- { sum [ [ (simd-sum) ] float-4-v->n-op ] }
-} simd-vector-words
-
-\ double-2 \ double-2-with m:float H{
- { v+ [ [ (simd-v+) ] double-2-vv->v-op ] }
- { v- [ [ (simd-v-) ] double-2-vv->v-op ] }
- { v* [ [ (simd-v*) ] double-2-vv->v-op ] }
- { v/ [ [ (simd-v/) ] double-2-vv->v-op ] }
- { vmin [ [ (simd-vmin) ] double-2-vv->v-op ] }
- { vmax [ [ (simd-vmax) ] double-2-vv->v-op ] }
- { sum [ [ (simd-sum) ] double-2-v->n-op ] }
-} simd-vector-words
-
-\ float-8 \ float-8-with m:float H{
- { v+ [ [ (simd-v+) ] float-8-vv->v-op ] }
- { v- [ [ (simd-v-) ] float-8-vv->v-op ] }
- { v* [ [ (simd-v*) ] float-8-vv->v-op ] }
- { v/ [ [ (simd-v/) ] float-8-vv->v-op ] }
- { vmin [ [ (simd-vmin) ] float-8-vv->v-op ] }
- { vmax [ [ (simd-vmax) ] float-8-vv->v-op ] }
- { sum [ [ (simd-sum) ] [ + ] float-8-v->n-op ] }
-} simd-vector-words
-
-\ double-4 \ double-4-with m:float H{
- { v+ [ [ (simd-v+) ] double-4-vv->v-op ] }
- { v- [ [ (simd-v-) ] double-4-vv->v-op ] }
- { v* [ [ (simd-v*) ] double-4-vv->v-op ] }
- { v/ [ [ (simd-v/) ] double-4-vv->v-op ] }
- { vmin [ [ (simd-vmin) ] double-4-vv->v-op ] }
- { vmax [ [ (simd-vmax) ] double-4-vv->v-op ] }
- { sum [ [ (simd-v+) ] [ (simd-sum) ] double-4-v->n-op ] }
-} simd-vector-words
-
->>
-
-USE: vocabs.loader
+: define-simd-vocab ( type -- vocab )
+ [ simd-vocab ] keep '[
+ _ parse-base-type
+ [ define-simd-128 ]
+ [ define-simd-256 ] bi
+ ] generate-vocab ;
-"math.vectors.simd.alien" require
+SYNTAX: SIMD:
+ scan define-simd-vocab use-vocab ;
--- /dev/null
+Single-instruction-multiple-data parallel vector operations
{ norm-sq { +vector+ -> +nonnegative+ } }
{ normalize { +vector+ -> +vector+ } }
{ v* { +vector+ +vector+ -> +vector+ } }
+ { vs* { +vector+ +vector+ -> +vector+ } }
{ v*n { +vector+ +scalar+ -> +vector+ } }
{ v+ { +vector+ +vector+ -> +vector+ } }
+ { vs+ { +vector+ +vector+ -> +vector+ } }
+ { v+- { +vector+ +vector+ -> +vector+ } }
{ v+n { +vector+ +scalar+ -> +vector+ } }
{ v- { +vector+ +vector+ -> +vector+ } }
+ { vs- { +vector+ +vector+ -> +vector+ } }
{ v-n { +vector+ +scalar+ -> +vector+ } }
{ v. { +vector+ +vector+ -> +scalar+ } }
{ v/ { +vector+ +vector+ -> +vector+ } }
{ vneg { +vector+ -> +vector+ } }
{ vtruncate { +vector+ -> +vector+ } }
{ sum { +vector+ -> +scalar+ } }
+ { vabs { +vector+ -> +vector+ } }
+ { vsqrt { +vector+ -> +vector+ } }
+ { vbitand { +vector+ +vector+ -> +vector+ } }
+ { vbitor { +vector+ +vector+ -> +vector+ } }
+ { vbitxor { +vector+ +vector+ -> +vector+ } }
}
PREDICATE: vector-word < word vector-words key? ;
-USING: help.markup help.syntax math sequences ;
+USING: help.markup help.syntax math math.functions sequences ;
IN: math.vectors
ARTICLE: "math-vectors" "Vector arithmetic"
{ $subsection n+v }
{ $subsection v-n }
{ $subsection n-v }
-"Combining two vectors to form another vector with " { $link 2map } ":"
+"Vector unary operations:"
+{ $subsection vneg }
+{ $subsection vabs }
+{ $subsection vsqrt }
+{ $subsection vfloor }
+{ $subsection vceiling }
+{ $subsection vtruncate }
+"Vector/vector binary operations:"
{ $subsection v+ }
{ $subsection v- }
+{ $subsection v+- }
{ $subsection v* }
{ $subsection v/ }
+"Saturated arithmetic (only on " { $link "specialized-arrays" } "):"
+{ $subsection vs+ }
+{ $subsection vs- }
+{ $subsection vs* }
+"Comparisons:"
{ $subsection vmax }
{ $subsection vmin }
+"Bitwise operations:"
+{ $subsection vbitand }
+{ $subsection vbitor }
+{ $subsection vbitxor }
"Inner product and norm:"
{ $subsection v. }
{ $subsection norm }
{ $subsection norm-sq }
-{ $subsection normalize } ;
+{ $subsection normalize }
+"Comparing vectors:"
+{ $subsection distance }
+{ $subsection v~ }
+"Other functions:"
+{ $subsection vsupremum }
+{ $subsection vinfimum }
+{ $subsection trilerp }
+{ $subsection bilerp }
+{ $subsection vlerp }
+{ $subsection vnlerp }
+{ $subsection vbilerp } ;
ABOUT: "math-vectors"
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
{ $description "Negates each element of " { $snippet "u" } "." } ;
+HELP: vabs
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of non-negative real numbers" } }
+{ $description "Takes the absolute value of each element of " { $snippet "u" } "." } ;
+
+HELP: vsqrt
+{ $values { "u" "a sequence of non-negative real numbers" } { "v" "a sequence of non-negative real numbers" } }
+{ $description "Takes the square root of each element of " { $snippet "u" } "." }
+{ $warning "For performance reasons, this does not work with negative inputs, unlike " { $link sqrt } "." } ;
+
+HELP: vfloor
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } }
+{ $description "Takes the " { $link floor } " of each element of " { $snippet "u" } "." } ;
+
+HELP: vceiling
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } }
+{ $description "Takes the " { $link ceiling } " of each element of " { $snippet "u" } "." } ;
+
+HELP: vtruncate
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } }
+{ $description "Truncates each element of " { $snippet "u" } "." } ;
+
+HELP: n+v
+{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
+{ $description "Adds " { $snippet "n" } " to each element of " { $snippet "u" } "." } ;
+
+HELP: v+n
+{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } }
+{ $description "Adds " { $snippet "n" } " to each element of " { $snippet "u" } "." } ;
+
+HELP: n-v
+{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
+{ $description "Subtracts each element of " { $snippet "u" } " from " { $snippet "n" } "." } ;
+
+HELP: v-n
+{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } }
+{ $description "Subtracts " { $snippet "n" } " from each element of " { $snippet "u" } "." } ;
+
HELP: n*v
{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
{ $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ;
HELP: n/v
{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
-{ $description "Divides " { $snippet "n" } " by each element of " { $snippet "u" } "." } ;
+{ $description "Divides " { $snippet "n" } " by each element of " { $snippet "u" } "." }
+{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ;
HELP: v/n
{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } }
-{ $description "Divides each element of " { $snippet "u" } " by " { $snippet "n" } "." } ;
+{ $description "Divides each element of " { $snippet "u" } " by " { $snippet "n" } "." }
+{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ;
HELP: v+
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
{ $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise." } ;
+HELP: v+-
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Adds and subtracts alternate elements of " { $snippet "v" } " and " { $snippet "u" } " component-wise." }
+{ $examples
+ { $example
+ "USING: math.vectors prettyprint ;"
+ "{ 1 2 3 } { 2 3 2 } v+- ."
+ "{ -1 5 1 }"
+ }
+} ;
+
HELP: [v-]
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
{ $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise; any components which become negative are set to zero." } ;
HELP: v/
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
{ $description "Divides " { $snippet "u" } " by " { $snippet "v" } " component-wise." }
-{ $errors "Throws an error if an integer division by zero occurs." } ;
+{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ;
HELP: vmax
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
{ $description "Computes the real-valued dot product." }
{ $notes
"This word can also take complex number sequences as input, however mathematically it will compute the wrong result. The complex-valued dot product is defined differently:"
- { $snippet "0 [ conjugate * + ] 2reduce" }
+ { $code "0 [ conjugate * + ] 2reduce" }
+} ;
+
+HELP: vs+
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Adds " { $snippet "u" } " and " { $snippet "v" } " component-wise with saturation." }
+{ $examples
+ "With saturation:"
+ { $example
+ "USING: math.vectors prettyprint specialized-arrays ;"
+ "SPECIALIZED-ARRAY: uchar"
+ "uchar-array{ 100 200 150 } uchar-array{ 70 70 70 } vs+ ."
+ "uchar-array{ 170 255 220 }"
+ }
+ "Without saturation:"
+ { $example
+ "USING: math.vectors prettyprint specialized-arrays ;"
+ "SPECIALIZED-ARRAY: uchar"
+ "uchar-array{ 100 200 150 } uchar-array{ 70 70 70 } v+ ."
+ "uchar-array{ 170 14 220 }"
+ }
} ;
+HELP: vs-
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise with saturation." } ;
+
+HELP: vs*
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Multiplies " { $snippet "u" } " and " { $snippet "v" } " component-wise with saturation." } ;
+
+HELP: vbitand
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
+{ $description "Takes the bitwise and of " { $snippet "u" } " and " { $snippet "v" } " component-wise." }
+{ $notes "Unlike " { $link bitand } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
+
+HELP: vbitor
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
+{ $description "Takes the bitwise or of " { $snippet "u" } " and " { $snippet "v" } " component-wise." }
+{ $notes "Unlike " { $link bitor } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
+
+HELP: vbitxor
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
+{ $description "Takes the bitwise exclusive or of " { $snippet "u" } " and " { $snippet "v" } " component-wise." }
+{ $notes "Unlike " { $link bitxor } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
+
HELP: norm-sq
{ $values { "v" "a sequence of numbers" } { "x" "a non-negative real number" } }
{ $description "Computes the squared length of a mathematical vector." } ;
{ $values { "u" "a sequence of numbers, not all zero" } { "v" "a sequence of numbers" } }
{ $description "Outputs a vector with the same direction as " { $snippet "u" } " but length 1." } ;
+HELP: distance
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "x" "a non-negative real number" } }
+{ $description "Outputs the Euclidean distance between two vectors." } ;
+
HELP: set-axis
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "axis" "a sequence of 0/1" } { "w" "a sequence of numbers" } }
{ $description "Using " { $snippet "w" } " as a template, creates a new sequence containing corresponding elements from " { $snippet "u" } " in place of 0, and corresponding elements from " { $snippet "v" } " in place of 1." }
{ 2map v+ v- v* v/ } related-words
{ 2reduce v. } related-words
+
+{ vs+ vs- vs* } related-words
[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test
-[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test
\ No newline at end of file
+[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test
+
+[ { 0 3 2 5 4 } ] [ { 1 2 3 4 5 } { 1 1 1 1 1 } v+- ] unit-test
\ No newline at end of file
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences math math.functions hints
-math.order ;
+USING: arrays alien.c-types kernel sequences math math.functions
+hints math.order math.libm fry combinators ;
+QUALIFIED-WITH: alien.c-types c
IN: math.vectors
+GENERIC: element-type ( obj -- c-type )
+
: vneg ( u -- v ) [ neg ] map ;
: v+n ( u n -- v ) [ + ] curry map ;
: vmax ( u v -- w ) [ max ] 2map ;
: vmin ( u v -- w ) [ min ] 2map ;
-: vfloor ( v -- _v_ ) [ floor ] map ;
-: vceiling ( v -- ^v^ ) [ ceiling ] map ;
-: vtruncate ( v -- -v- ) [ truncate ] map ;
+: v+- ( u v -- w )
+ [ t ] 2dip
+ [ [ not ] 2dip pick [ + ] [ - ] if ] 2map
+ nip ;
+
+<PRIVATE
+
+: 2saturate-map ( u v quot -- w )
+ pick element-type '[ @ _ c-type-clamp ] 2map ; inline
+
+PRIVATE>
+
+: vs+ ( u v -- w ) [ + ] 2saturate-map ;
+: vs- ( u v -- w ) [ - ] 2saturate-map ;
+: vs* ( u v -- w ) [ * ] 2saturate-map ;
+
+: vabs ( u -- v ) [ abs ] map ;
+: vsqrt ( u -- v ) [ >float fsqrt ] map ;
+
+<PRIVATE
+
+: fp-bitwise-op ( x y seq quot -- z )
+ swap element-type {
+ { c:double [ [ [ double>bits ] bi@ ] dip call bits>double ] }
+ { c:float [ [ [ float>bits ] bi@ ] dip call bits>float ] }
+ [ drop call ]
+ } case ; inline
+
+PRIVATE>
+
+: vbitand ( u v -- w ) over '[ _ [ bitand ] fp-bitwise-op ] 2map ;
+: vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ;
+: vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ;
+
+: vfloor ( u -- v ) [ floor ] map ;
+: vceiling ( u -- v ) [ ceiling ] map ;
+: vtruncate ( u -- v ) [ truncate ] map ;
: vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ;
: vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ;
{ $syntax "STRING: name\nfoo\n;" }
{ $description "Forms a multiline string literal, or 'here document' stored in the word called name. A semicolon is used to signify the end, and that semicolon must be on a line by itself, not preceeded or followed by any whitespace. The string will have newlines in between lines but not at the end, unless there is a blank line before the semicolon." } ;
-HELP: <"
-{ $syntax "<\" text \">" }
-{ $description "This forms a multiline string literal ending in \">. Unlike the " { $link POSTPONE: STRING: } " form, you can end it in the middle of a line. This construct is non-nesting. In the example above, the string would be parsed as \"text\"." } ;
-
HELP: /*
{ $syntax "/* comment */" }
{ $description "Provides C-like comments that can span multiple lines. One caveat is that " { $snippet "/*" } " and " { $snippet "*/" } " are still tokens and must not abut the comment text itself." }
}
} ;
-{ POSTPONE: <" POSTPONE: STRING: } related-words
-
HELP: parse-multiline-string
{ $values { "end-text" "a string delineating the end" } { "str" "the parsed string" } }
{ $description "Parses the input stream until the " { $snippet "end-text" } " is reached and returns the parsed text as a string." }
-{ $notes "Used to implement " { $link POSTPONE: /* } " and " { $link POSTPONE: <" } "." } ;
+{ $notes "Used to implement " { $link POSTPONE: /* } "." } ;
ARTICLE: "multiline" "Multiline"
"Multiline strings:"
{ $subsection POSTPONE: STRING: }
-{ $subsection POSTPONE: <" }
{ $subsection POSTPONE: HEREDOC: }
{ $subsection POSTPONE: DELIMITED: }
"Multiline comments:"
;
[ "foo\nbar\n" ] [ test-it ] unit-test
-[ "foo\nbar\n" ] [ <" foo
-bar
-"> ] unit-test
-
-[ "hello\nworld" ] [ <" hello
-world"> ] unit-test
-
-[ "hello" "world" ] [ <" hello"> <" world"> ] unit-test
-
-[ "\nhi" ] [ <"
-hi"> ] unit-test
! HEREDOC:
: parse-multiline-string ( end-text -- str )
1 (parse-multiline-string) ;
-SYNTAX: <"
- "\">" parse-multiline-string parsed ;
-
-SYNTAX: <'
- "'>" parse-multiline-string parsed ;
-
-SYNTAX: {'
- "'}" parse-multiline-string parsed ;
-
-SYNTAX: {"
- "\"}" parse-multiline-string parsed ;
-
SYNTAX: /* "*/" parse-multiline-string drop ;
SYNTAX: HEREDOC:
USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs ;
+opengl.gl assocs ;
IN: opengl.capabilities
HELP: gl-version
{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } ". Elements of " { $snippet "extensions" } " can be sequences, in which case true will be returned if any one of the extensions in the subsequence are available." }
{ $examples "Testing for framebuffer object and pixel buffer support:"
- { $code <" {
+ { $code """{
{ "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" }
"GL_ARB_pixel_buffer_object"
-} has-gl-extensions? "> }
+} has-gl-extensions?""" }
} ;
HELP: has-gl-version-or-extensions?
! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax multiline tools.continuations ;
+USING: help.markup help.syntax tools.continuations ;
IN: opengl.debug
HELP: G
{ $description "Makes the OpenGL context associated with " { $link G-world } " active for subsequent OpenGL calls. This is intended to be used from the listener, where interactively entered OpenGL calls can be directed to any window. Note that the Factor UI resets the OpenGL context every time a window is updated, so every code snippet entered in the listener must be prefixed with " { $snippet "G" } " in this use case." }
-{ $examples { $code <" USING: opengl.debug ui ;
+{ $examples { $code """USING: opengl.debug ui ;
[ drop t ] find-window G-world set
G 0.0 0.0 1.0 1.0 glClearColor
-G GL_COLOR_BUFFER_BIT glClear
-"> } } ;
+G GL_COLOR_BUFFER_BIT glClear""" } } ;
HELP: F
{ $description "Flushes the OpenGL context associated with " { $link G-world } ", thereby committing any outstanding drawing operations." } ;
[ "USE: peg.ebnf [EBNF EBNF]" eval( -- ) ] must-fail
-[ <" USE: peg.ebnf [EBNF
+[ """USE: peg.ebnf [EBNF
lol = a
lol = b
- EBNF] "> eval( -- )
+ EBNF]""" eval( -- )
] [
error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
] must-fail-with
] when ;
: pprint-elements ( seq -- )
+ >array
do-length-limit
[ [ pprint* ] each ] dip
[ "~" swap number>string " more~" 3append text ] when* ;
! Copyright (C) 2009 Keith Lazuka.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs colors.constants combinators
+USING: assocs colors colors.constants combinators
combinators.short-circuit hashtables io.styles kernel literals
namespaces sequences words words.symbol ;
IN: prettyprint.stylesheet
dim-color colored-presentation-style ;
: effect-style ( effect -- style )
- COLOR: DarkGreen colored-presentation-style ;
+ 0 0.2 0 1 <rgba> colored-presentation-style
+ { { font-style plain } } assoc-union ;
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test quoted-printable multiline io.encodings.string
+USING: tools.test quoted-printable io.encodings.string
sequences io.encodings.8-bit splitting kernel ;
IN: quoted-printable.tests
-[ <" José was the
+[ """José was the
person who knew how to write the letters:
ő and ü
-and we didn't know hów tö do thât"> ]
-[ <" Jos=E9 was the
+and we didn't know hów tö do thât""" ]
+[ """Jos=E9 was the
person who knew how to write the letters:
=F5 and =FC=20
and w=
-e didn't know h=F3w t=F6 do th=E2t"> quoted> latin2 decode ] unit-test
+e didn't know h=F3w t=F6 do th=E2t""" quoted> latin2 decode ] unit-test
-[ <" Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t"> ]
-[ <" José was the
+[ """Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t""" ]
+[ """José was the
person who knew how to write the letters:
ő and ü
-and we didn't know hów tö do thât"> latin2 encode >quoted ] unit-test
+and we didn't know hów tö do thât""" latin2 encode >quoted ] unit-test
: message ( -- str )
55 [ "hello" ] replicate concat ;
}
{ $description "Randomizes a sequence in-place with the Fisher-Yates algorithm and returns the sequence." } ;
+HELP: sample
+{ $values
+ { "seq" sequence } { "n" integer }
+ { "seq'" sequence }
+}
+{ $description "Takes " { $snippet "n" } " samples at random without replacement from a sequence. Throws an error if " { $snippet "n" } " is longer than the sequence." }
+{ $examples
+ { $unchecked-example "USING: random prettyprint ; { 1 2 3 } 2 sample ."
+ "{ 3 2 }"
+ }
+} ;
+
HELP: delete-random
{ $values
{ "seq" sequence }
{ $subsection "random-protocol" }
"Randomizing a sequence:"
{ $subsection randomize }
+"Sampling a sequences:"
+{ $subsection sample }
"Deleting a random element from a sequence:"
{ $subsection delete-random }
"Random numbers with " { $snippet "n" } " bits:"
[ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
[ 49 ] [ 50 random-bits* log2 ] unit-test
+
+[ { 1 2 } 3 sample ] [ too-many-samples? ] must-fail-with
+
+[ 3 ] [ { 1 2 3 4 } 3 sample prune length ] unit-test
+[ 99 ] [ 100 99 sample prune length ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel math namespaces sequences
-io.backend io.binary combinators system vocabs.loader
-summary math.bitwise byte-vectors fry byte-arrays
-math.ranges math.constants math.functions accessors ;
+USING: accessors alien.c-types assocs byte-arrays byte-vectors
+combinators fry io.backend io.binary kernel locals math
+math.bitwise math.constants math.functions math.ranges
+namespaces sequences sets summary system vocabs.loader ;
IN: random
SYMBOL: system-random-generator
[ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ]
while drop ;
+ERROR: too-many-samples seq n ;
+
+<PRIVATE
+
+:: next-sample ( length n seq hashtable -- elt )
+ n hashtable key? [
+ length n 1 + length mod seq hashtable next-sample
+ ] [
+ n hashtable conjoin
+ n seq nth
+ ] if ;
+
+PRIVATE>
+
+: sample ( seq n -- seq' )
+ 2dup [ length ] dip < [ too-many-samples ] when
+ swap [ length ] [ ] bi H{ } clone
+ '[ _ dup random _ _ next-sample ] replicate ;
+
: delete-random ( seq -- elt )
[ length random-integer ] keep [ nth ] 2keep delete-nth ;
ARTICLE: "regexp.combinators" "Regular expression combinators"
"The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This complements the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary."
-{ $subsection "regexp.combinators.intro" }
+{ $subsections "regexp.combinators.intro" }
"Basic combinators:"
-{ $subsection <literal> }
-{ $subsection <nothing> }
+{ $subsections <literal> <nothing> }
"Higher-order combinators for building new regular expressions from existing ones:"
-{ $subsection <or> }
-{ $subsection <and> }
-{ $subsection <not> }
-{ $subsection <sequence> }
-{ $subsection <zero-or-more> }
+{ $subsections
+ <or>
+ <and>
+ <not>
+ <sequence>
+ <zero-or-more>
+}
"Derived combinators implemented in terms of the above:"
-{ $subsection <one-or-more> }
+{ $subsections <one-or-more> }
"Setting options:"
-{ $subsection <option> } ;
+{ $subsections <option> } ;
HELP: <literal>
{ $values { "string" string } { "regexp" regexp } }
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings help.markup help.syntax math regexp.parser
-regexp.ast multiline ;
+regexp.ast ;
IN: regexp
ABOUT: "regexp"
ARTICLE: "regexp" "Regular expressions"
"The " { $vocab-link "regexp" } " vocabulary provides word for creating and using regular expressions."
-{ $subsection { "regexp" "intro" } }
+{ $subsections { "regexp" "intro" } }
"The class of regular expressions:"
-{ $subsection regexp }
+{ $subsections regexp }
"Basic usage:"
-{ $subsection { "regexp" "syntax" } }
-{ $subsection { "regexp" "options" } }
-{ $subsection { "regexp" "construction" } }
-{ $subsection { "regexp" "operations" } }
+{ $subsections
+ { "regexp" "syntax" }
+ { "regexp" "options" }
+ { "regexp" "construction" }
+ { "regexp" "operations" }
+}
"Advanced topics:"
{ $vocab-subsection "Regular expression combinators" "regexp.combinators" }
-{ $subsection { "regexp" "theory" } }
-{ $subsection { "regexp" "deploy" } } ;
+{ $subsections
+ { "regexp" "theory" }
+ { "regexp" "deploy" }
+} ;
ARTICLE: { "regexp" "intro" } "A quick introduction to regular expressions"
"Regular expressions are a terse way to do certain simple string processing tasks. For example, to replace all instances of " { $snippet "foo" } " in one string with " { $snippet "bar" } ", the following can be used:"
"The " { $snippet "+" } " operator matches one or more occurrences of the previous expression; in this case " { $snippet "o" } ". Another useful feature is alternation. Say we want to do this replacement with fooooo or boooo. Then we could use the code"
{ $code "R/ (f|b)oo+/ \"bar\" re-replace" }
"To search a file for all lines that match a given regular expression, you could use code like this:"
-{ $code <" "file.txt" ascii file-lines [ R/ (f|b)oo+/ re-contains? ] filter "> }
+{ $code """"file.txt" ascii file-lines [ R/ (f|b)oo+/ re-contains? ] filter""" }
"To test if a string in its entirety matches a regular expression, the following can be used:"
-{ $example <" USE: regexp "fooo" R/ (b|f)oo+/ matches? . "> "t" }
+{ $example """USE: regexp "fooo" R/ (b|f)oo+/ matches? .""" "t" }
"Regular expressions can't be used for all parsing tasks. For example, they are not powerful enough to match balancing parentheses." ;
ARTICLE: { "regexp" "construction" } "Constructing regular expressions"
"Most of the time, regular expressions are literals and the parsing word should be used, to construct them at parse time. This ensures that they are only compiled once, and gives parse time syntax checking."
-{ $subsection POSTPONE: R/ }
+{ $subsections POSTPONE: R/ }
"Sometimes, regular expressions need to be constructed at run time instead; for example, in a text editor, the user might input a regular expression to search for in a document."
-{ $subsection <regexp> }
-{ $subsection <optioned-regexp> }
+{ $subsections <regexp> <optioned-regexp> }
"Another approach is to use " { $vocab-link "regexp.combinators" } "." ;
ARTICLE: { "regexp" "syntax" } "Regular expression syntax"
ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions"
"Testing if a string matches a regular expression:"
-{ $subsection matches? }
+{ $subsections matches? }
"Finding a match inside a string:"
-{ $subsection re-contains? }
-{ $subsection first-match }
+{ $subsections re-contains? first-match }
"Finding all matches inside a string:"
-{ $subsection count-matches }
-{ $subsection all-matching-slices }
-{ $subsection all-matching-subseqs }
+{ $subsections
+ count-matches
+ all-matching-slices
+ all-matching-subseqs
+}
"Splitting a string into tokens delimited by a regular expression:"
-{ $subsection re-split }
+{ $subsections re-split }
"Replacing occurrences of a regular expression with a string:"
-{ $subsection re-replace } ;
+{ $subsections re-replace } ;
ARTICLE: { "regexp" "deploy" } "Regular expressions and the deploy tool"
"The " { $link "tools.deploy" } " tool has the option to strip out the optimizing compiler from the resulting image. Since regular expressions compile to Factor code, this creates a minor performance-related caveat."
-USING: help.markup help.syntax math multiline
+USING: help.markup help.syntax math
sequences sequences.complex-components ;
IN: sequences.complex-components
HELP: complex-components
{ $class-description "Sequence wrapper class that transforms a sequence of " { $link complex } " number values into a sequence of " { $link real } " values, interleaving the real and imaginary parts of the complex values in the original sequence." }
-{ $examples { $example <"
-USING: prettyprint sequences arrays sequences.complex-components ;
-{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> >array .
-"> "{ 1.0 -1.0 -2.0 0 3.0 1.0 }" } } ;
+{ $examples { $example """USING: prettyprint sequences arrays sequences.complex-components ;
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> >array ."""
+"{ 1.0 -1.0 -2.0 0 3.0 1.0 }" } } ;
HELP: <complex-components>
{ $values { "sequence" sequence } { "complex-components" complex-components } }
{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-components } " wrapper." }
{ $examples
-{ $example <"
-USING: prettyprint sequences arrays
+{ $example """USING: prettyprint sequences arrays
sequences.complex-components ;
-{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> third .
-"> "-2.0" }
-{ $example <"
-USING: prettyprint sequences arrays
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> third ."""
+"-2.0" }
+{ $example """USING: prettyprint sequences arrays
sequences.complex-components ;
-{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> fourth .
-"> "0" }
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> fourth ."""
+"0" }
} ;
{ complex-components <complex-components> } related-words
-USING: help.markup help.syntax math multiline
-sequences sequences.complex ;
+USING: help.markup help.syntax math sequences
+sequences.complex ;
IN: sequences.complex
ARTICLE: "sequences.complex" "Complex virtual sequences"
HELP: complex-sequence
{ $class-description "Sequence wrapper class that transforms a sequence of " { $link real } " number values into a sequence of " { $link complex } " values, treating the underlying sequence as pairs of alternating real and imaginary values." }
-{ $examples { $example <"
-USING: prettyprint specialized-arrays
+{ $examples { $example """USING: prettyprint specialized-arrays
sequences.complex sequences arrays ;
SPECIALIZED-ARRAY: double
-double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array .
-"> "{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ;
+double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array ."""
+"{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ;
HELP: <complex-sequence>
{ $values { "sequence" sequence } { "complex-sequence" complex-sequence } }
{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-sequence } "." }
-{ $examples { $example <"
-USING: prettyprint specialized-arrays
+{ $examples { $example """USING: prettyprint specialized-arrays
sequences.complex sequences arrays ;
SPECIALIZED-ARRAY: double
-double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second .
-"> "C{ -2.0 2.0 }" } } ;
+double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second ."""
+"C{ -2.0 2.0 }" } } ;
{ complex-sequence <complex-sequence> } related-words
kernel arrays combinators compiler compiler.units classes.struct
combinators.smart compiler.tree.debugger math libc destructors
sequences.private multiline eval words vocabs namespaces
-assocs prettyprint alien.data ;
+assocs prettyprint alien.data math.vectors ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: char
SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: ulonglong
+
+[ ulonglong ] [ ulonglong-array{ } element-type ] unit-test
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
] unit-test
[
- <"
+ """
IN: specialized-arrays.tests
USING: specialized-arrays ;
-SPECIALIZED-ARRAY: __does_not_exist__ "> eval( -- )
+SPECIALIZED-ARRAY: __does_not_exist__ """ eval( -- )
] must-fail
[ ] [
- <"
+ """
IN: specialized-arrays.tests
USING: classes.struct specialized-arrays ;
STRUCT: __does_not_exist__ { x int } ;
SPECIALIZED-ARRAY: __does_not_exist__
-"> eval( -- )
+""" eval( -- )
] unit-test
[ f ] [
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.data alien.parser assocs
-byte-arrays classes compiler.units functors kernel lexer libc math
-math.vectors.specialization namespaces parser prettyprint.custom
-sequences sequences.private strings summary vocabs vocabs.loader
-vocabs.parser words fry combinators ;
+USING: accessors alien alien.c-types alien.data alien.parser
+assocs byte-arrays classes compiler.units functors kernel lexer
+libc math math.vectors math.vectors.specialization namespaces
+parser prettyprint.custom sequences sequences.private strings
+summary vocabs vocabs.loader vocabs.parser vocabs.generated
+words fry combinators present ;
IN: specialized-arrays
MIXIN: specialized-array
: <direct-A> ( alien len -- specialized-array ) A boa ; inline
-: <A> ( n -- specialized-array ) [ T <underlying> ] keep <direct-A> ; inline
+: <A> ( n -- specialized-array ) [ \ T <underlying> ] keep <direct-A> ; inline
-: (A) ( n -- specialized-array ) [ T (underlying) ] keep <direct-A> ; inline
+: (A) ( n -- specialized-array ) [ \ T (underlying) ] keep <direct-A> ; inline
-: malloc-A ( len -- specialized-array ) [ T heap-size calloc ] keep <direct-A> ; inline
+: malloc-A ( len -- specialized-array ) [ \ T heap-size calloc ] keep <direct-A> ; inline
: byte-array>A ( byte-array -- specialized-array )
- dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
+ dup length \ T heap-size /mod 0 = [ drop \ T bad-byte-array-length ] unless
<direct-A> ; inline
M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
M: A resize
[
- [ T heap-size * ] [ underlying>> ] bi*
+ [ \ T heap-size * ] [ underlying>> ] bi*
resize-byte-array
] [ drop ] 2bi
<direct-A> ; inline
-M: A byte-length length T heap-size * ; inline
+M: A byte-length length \ T heap-size * ; inline
+
+M: A element-type drop \ T ; inline
M: A direct-array-syntax drop \ A@ ;
} cond ;
: underlying-type-name ( c-type -- name )
- underlying-type dup word? [ name>> ] when ;
+ underlying-type present ;
: specialized-array-vocab ( c-type -- vocab )
- "specialized-arrays.instances." prepend ;
+ present "specialized-arrays.instances." prepend ;
PRIVATE>
-: generate-vocab ( vocab-name quot -- vocab )
- [ dup vocab [ ] ] dip '[
- [
- [
- _ with-current-vocab
- ] with-compilation-unit
- ] keep
- ] ?if ; inline
-
: define-array-vocab ( type -- vocab )
- underlying-type-name
+ underlying-type
[ specialized-array-vocab ] [ '[ _ define-array ] ] bi
generate-vocab ;
}
"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-vectors.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-VECTOR: } ". This ensures that the vocabulary can get generated the first time it is needed." ;
-ARTICLE: "specialized-vector-c" "Passing specialized arrays to C functions"
-"Each specialized array has a " { $slot "underlying" } " slot holding a specialized array, which in turn has an " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized vector as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized vector." ;
+ARTICLE: "specialized-vector-c" "Passing specialized vectors to C functions"
+"Each specialized vector has a " { $slot "underlying" } " slot holding a specialized array, which in turn has an " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized vector as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized vector." ;
ARTICLE: "specialized-vectors" "Specialized vectors"
"The " { $vocab-link "specialized-vectors" } " vocabulary implements resizable sequence types for storing machine values in a space-efficient manner without boxing."
USING: accessors alien.c-types assocs compiler.units functors
growable kernel lexer namespaces parser prettyprint.custom
sequences specialized-arrays specialized-arrays.private strings
-vocabs vocabs.parser fry ;
+vocabs vocabs.parser vocabs.generated fry ;
QUALIFIED: vectors.functor
IN: specialized-vectors
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations classes sequences
-multiline ;
+USING: help.markup help.syntax kernel quotations classes sequences ;
IN: splitting.monotonic
HELP: monotonic-slice
{ $example
"USING: splitting.monotonic math prettyprint ;"
"{ 1 2 3 2 3 4 } [ < ] upward-slice monotonic-slice ."
- <" {
+ """{
T{ upward-slice
{ from 0 }
{ to 3 }
{ to 6 }
{ seq { 1 2 3 2 3 4 } }
}
-}">
+}"""
}
} ;
{ $example
"USING: splitting.monotonic math prettyprint ;"
"{ 1 2 3 3 2 1 } trends ."
- <" {
+ """{
T{ upward-slice
{ from 0 }
{ to 3 }
{ to 6 }
{ seq { 1 2 3 3 2 1 } }
}
-}">
+}"""
}
} ;
GENERIC: summary ( object -- string )
: object-summary ( object -- string )
- class name>> " instance" append ;
+ class name>> ;
M: object summary object-summary ;
"Printing messages when a word is called or returns:"
{ $subsection watch }
{ $subsection watch-vars }
-"Starting the walker when a word is called:"
-{ $subsection breakpoint }
-{ $subsection breakpoint-if }
"Timing words:"
{ $subsection reset-word-timing }
{ $subsection add-timing }
{ watch watch-vars reset } related-words
-HELP: breakpoint
-{ $values { "word" word } }
-{ $description "Annotates a word definition to enter the single stepper when executed." } ;
-
-HELP: breakpoint-if
-{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } }
-{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ;
-
HELP: reset
{ $values
{ "word" word } }
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math sorting words parser io summary
quotations sequences prettyprint continuations effects
-definitions compiler.units namespaces assocs tools.walker
-tools.time generic inspector fry tools.continuations
-locals generalizations macros ;
+definitions compiler.units namespaces assocs tools.time generic
+inspector fry locals generalizations macros ;
IN: tools.annotations
<PRIVATE
: watch-vars ( word vars -- )
dupd '[ [ _ _ ] dip (watch-vars) ] annotate ;
-: breakpoint ( word -- )
- [ add-breakpoint ] annotate ;
-
-: breakpoint-if ( word quot -- )
- '[ [ _ [ [ break ] when ] ] dip 3append ] annotate ;
-
SYMBOL: word-timing
word-timing [ H{ } clone ] initialize
synopsis-alist sort-keys definitions. ;
: usage. ( word -- )
- smart-usage sorted-definitions. ;
+ smart-usage
+ [ "No usages." print ] [ sorted-definitions. ] if-empty ;
: vocab-xref ( vocab quot -- vocabs )
[ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test tools.scaffold unicode.case kernel
-multiline tools.scaffold.private io.streams.string ;
+tools.scaffold.private io.streams.string ;
IN: tools.scaffold.tests
: undocumented-word ( obj1 obj2 -- obj3 obj4 )
[ >lower ] [ >upper ] bi* ;
[
-<" HELP: undocumented-word
+"""HELP: undocumented-word
{ $values
{ "obj1" object } { "obj2" object }
{ "obj3" object } { "obj4" object }
}
{ $description "" } ;
-">
+"""
]
[
[ \ undocumented-word (help.) ] with-string-writer
IN: tools.walker
-USING: help.syntax help.markup tools.continuations ;
+USING: help.syntax help.markup tools.continuations sequences math words ;
+
+HELP: breakpoint
+{ $values { "word" word } }
+{ $description "Annotates a word definition to enter the single stepper when executed." } ;
+
+HELP: breakpoint-if
+{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } }
+{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ;
HELP: B
-{ $description "An alias for " { $link break } ", defined in the " { $vocab-link "syntax" } " vocabulary so that it is always available." } ;
\ No newline at end of file
+{ $description "An alias for " { $link break } ", defined in the " { $vocab-link "syntax" } " vocabulary so that it is always available." } ;
+
+ARTICLE: "breakpoints" "Setting breakpoints"
+"In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words using words in the " { $vocab-link "tools.walker" } " vocabulary."
+$nl
+"Annotating a word with a breakpoint (see " { $link "tools.annotations" } "):"
+{ $subsection breakpoint }
+{ $subsection breakpoint-if }
+"Breakpoints can be inserted directly into code:"
+{ $subsection break }
+{ $subsection POSTPONE: B }
+"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link + } " will hang the UI." ;
+
+ABOUT: "breakpoints"
concurrency.messaging quotations kernel.private words
sequences.private assocs models models.arrow arrays accessors
generic generic.standard definitions make sbufs
-tools.continuations parser ;
+tools.continuations parser tools.annotations fry ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
"Walker on " self name>> append spawn
[ associate-thread ] keep ;
+: breakpoint ( word -- )
+ [ add-breakpoint ] annotate ;
+
+: breakpoint-if ( word quot -- )
+ '[ [ _ [ [ break ] when ] ] dip 3append ] annotate ;
+
! For convenience
IN: syntax
}
} ;
-HELP: command-string
-{ $values { "gesture" "a gesture" } { "command" "a command" } { "string" string } }
-{ $description "Outputs a string containing the command name followed by the gesture." }
-{ $examples
- { $unchecked-example
- "USING: io ui.commands ui.gestures ;"
- "IN: scratchpad"
- ": com-my-command ;"
- "T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write"
- "My Command (C+s)"
- }
-} ;
-
ARTICLE: "ui-commands" "Commands"
"Commands are an abstraction layered on top of gestures. Their main advantage is that they are identified by words and can be organized into " { $emphasis "command maps" } ". This allows easy construction of buttons and tool bars for invoking commands."
{ $subsection define-command }
M: word command-word ;
-M: f invoke-command ( target command -- ) 2drop ;
-
-: command-string ( gesture command -- string )
- [
- command-name %
- gesture>string [ " (" % % ")" % ] when*
- ] "" make ;
\ No newline at end of file
+M: f invoke-command ( target command -- ) 2drop ;
\ No newline at end of file
'[ _ _ invoke-command ] ;
: gesture>tooltip ( gesture -- str/f )
- dup [ gesture>string "Shortcut: " prepend ] when ;
+ gesture>string dup [ "Shortcut: " prepend ] when ;
: <command-button> ( target gesture command -- button )
swapd [ command-name swap ] keep command-button-quot
-USING: destructors help.markup help.syntax kernel math multiline sequences
+USING: destructors help.markup help.syntax kernel math sequences
vocabs vocabs.parser words namespaces ;
IN: ui.pixel-formats
{ $subsection samples }
{ $examples
"The following " { $link world } " subclass will request a double-buffered window with minimum 24-bit color and depth buffers, and will throw an error if the requirements aren't met:"
-{ $code <"
+{ $code """
USING: kernel ui.worlds ui.pixel-formats ;
IN: ui.pixel-formats.examples
[ color-bits pixel-format-attribute 24 < [ "Not enough color bits!" throw ] when ]
[ depth-bits pixel-format-attribute 24 < [ "Not enough depth bits!" throw ] when ]
tri ;
-"> } }
+""" } }
;
HELP: double-buffered
: slot-editor-window ( close-hook update-hook assoc key key-string -- )
[ <value-ref> <slot-editor> ] [ "Slot editor: " prepend ] bi*
- open-window ;
+ open-status-window ;
: com-edit-slot ( inspector -- )
[ close-window ] swap
M: vocab-completion row-color
drop vocab? COLOR: black COLOR: dark-gray ? ;
-: complete-IN:/USE:? ( tokens -- ? )
- 1 short head* 2 short tail* { "IN:" "USE:" } intersects? ;
+: complete-vocab? ( tokens -- ? )
+ 1 short head* 2 short tail*
+ { "IN:" "USE:" "UNUSE:" "QUALIFIED:" "QUALIFIED-WITH:" } intersects? ;
: chop-; ( seq -- seq' )
{ ";" } split1-last [ ] [ ] ?if ;
-: complete-USING:? ( tokens -- ? )
+: complete-vocab-list? ( tokens -- ? )
chop-; 1 short head* { "USING:" } intersects? ;
: complete-CHAR:? ( tokens -- ? )
: completion-mode ( interactor -- symbol )
[ manifest>> ] [ editor-caret ] [ model>> ] tri up-to-caret " \r\n" split
{
- { [ dup { [ complete-IN:/USE:? ] [ complete-USING:? ] } 1|| ] [ 2drop vocab-completion ] }
+ { [ dup { [ complete-vocab? ] [ complete-vocab-list? ] } 1|| ] [ 2drop vocab-completion ] }
{ [ dup complete-CHAR:? ] [ 2drop char-completion ] }
[ drop <word-completion> ]
} cond ;
{ $code "USE: threads" "[ \"ui.tools\" run ] in-thread" } ;
ARTICLE: "ui-shortcuts" "UI tool keyboard shortcuts"
-"Every UI tool has its own set of keyboard shortcuts; press " { $snippet "F1" } " inside a tool to see help. Some common shortcuts are also supported by all tools:"
+"Every UI tool has its own set of keyboard shortcuts. Mouse-over a toolbar button to see its shortcut, if any, in the status bar, or press " { $snippet "F1" } " to see a list of all shortcuts supported by the tool."
+$nl
+"Some common shortcuts are supported by all tools:"
{ $command-map tool "tool-switching" }
{ $command-map tool "common" } ;
$nl\r
"The " { $link com-back } " command travels backwards through time, and restore stacks. This does not undo side effects (modifying array entries, writing to files, formatting the hard drive, etc) and therefore can only be used reliably on referentially transparent code." ;\r
\r
-ARTICLE: "breakpoints" "Setting breakpoints"\r
-"In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words. See " { $link "tools.annotations" } "."\r
-$nl\r
-"Breakpoints can be inserted directly into code:"\r
-{ $subsection break }\r
-{ $subsection POSTPONE: B }\r
-"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link draw-gadget } " will hang the UI." ;\r
-\r
ARTICLE: "ui-walker" "UI walker"\r
"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."\r
$nl\r
+USING: strings help.markup help.syntax assocs ;
IN: urls.encoding
-USING: strings help.markup help.syntax assocs multiline ;
HELP: url-decode
{ $values { "str" string } { "decoded" string } }
"USING: prettyprint urls.encoding ;"
"\"gender=female&agefrom=22&ageto=28&location=Omaha+NE\""
"query>assoc ."
- <" H{
+ """H{
{ "gender" "female" }
{ "agefrom" "22" }
{ "ageto" "28" }
{ "location" "Omaha NE" }
-}">
+}"""
}
} ;
USING: assocs hashtables help.markup help.syntax
io.streams.string io.files io.pathnames kernel strings present
-math multiline ;
+math ;
IN: urls
HELP: url
}
{ $examples
{ $code
- <" USING: kernel http.client urls ;
+ """USING: kernel http.client urls ;
URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" clone
"concatenative programming (NSFW)" "query" set-query-param
"1" "adult_ok" set-query-param
-http-get">
+http-get"""
}
"(For a complete Yahoo! search web service implementation, see the " { $vocab-link "yahoo" } " vocabulary.)"
}
! Copyright (C) 2009 Phil Dawes.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.structs alien.syntax ;
+USING: classes.struct alien.syntax ;
IN: vm
TYPEDEF: void* cell
-C-STRUCT: zone
- { "cell" "start" }
- { "cell" "here" }
- { "cell" "size" }
- { "cell" "end" }
- ;
+STRUCT: zone
+ { start cell }
+ { here cell }
+ { size cell }
+ { end cell } ;
-C-STRUCT: vm
- { "context*" "stack_chain" }
- { "zone" "nursery" }
- { "cell" "cards_offset" }
- { "cell" "decks_offset" }
- { "cell[70]" "userenv" }
- ;
+STRUCT: vm
+ { stack_chain context* }
+ { nursery zone }
+ { cards_offset cell }
+ { decks_offset cell }
+ { userenv cell[70] } ;
-: vm-field-offset ( field -- offset ) "vm" offset-of ;
\ No newline at end of file
+: vm-field-offset ( field -- offset ) vm offset-of ; inline
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.units continuations fry kernel vocabs vocabs.parser ;
+IN: vocabs.generated
+
+: generate-vocab ( vocab-name quot -- vocab )
+ [ dup vocab [ ] ] dip '[
+ [
+ [
+ [ _ with-current-vocab ] [ ] [ forget-vocab ] cleanup
+ ] with-compilation-unit
+ ] keep
+ ] ?if ; inline
+USING: vocabs.prettyprint tools.test io.streams.string eval ;
IN: vocabs.prettyprint.tests
-USING: vocabs.prettyprint tools.test io.streams.string multiline eval ;
: manifest-test-1 ( -- string )
- <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+ """USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
- << manifest get pprint-manifest >> "> ;
+ << manifest get pprint-manifest >>""" ;
[
-<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;">
+"""USING: kernel namespaces vocabs.parser vocabs.prettyprint ;"""
]
[ [ manifest-test-1 eval( -- ) ] with-string-writer ] unit-test
: manifest-test-2 ( -- string )
- <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+ """USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
IN: vocabs.prettyprint.tests
- << manifest get pprint-manifest >> "> ;
+ << manifest get pprint-manifest >>""" ;
[
-<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
-IN: vocabs.prettyprint.tests">
+"""USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+IN: vocabs.prettyprint.tests"""
]
[ [ manifest-test-2 eval( -- ) ] with-string-writer ] unit-test
: manifest-test-3 ( -- string )
- <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+ """USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
FROM: math => + - ;
QUALIFIED: system
QUALIFIED-WITH: assocs a
EXCLUDE: parser => run-file ;
IN: vocabs.prettyprint.tests
- << manifest get pprint-manifest >> "> ;
+ << manifest get pprint-manifest >>""" ;
[
-<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+"""USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
FROM: math => + - ;
QUALIFIED: system
QUALIFIED-WITH: assocs a
EXCLUDE: parser => run-file ;
-IN: vocabs.prettyprint.tests">
+IN: vocabs.prettyprint.tests"""
]
-[ [ manifest-test-3 eval( -- ) ] with-string-writer ] unit-test
\ No newline at end of file
+[ [ manifest-test-3 eval( -- ) ] with-string-writer ] unit-test
-USING: help.markup help.syntax io kernel math quotations
-multiline ;
+USING: help.markup help.syntax io kernel math quotations ;
IN: windows.com.syntax
HELP: GUID:
{ $description "\nCreate a COM globally-unique identifier (GUID) literal at parse time, and push it onto the data stack." } ;
HELP: COM-INTERFACE:
-{ $syntax <"
-COM-INTERFACE: <interface> <parent> <iid>
+{ $syntax """COM-INTERFACE: <interface> <parent> <iid>
<function-1> ( <params1> )
<function-2> ( <params2> )
... ;
-"> }
+""" }
{ $description "\nFor the interface " { $snippet "<interface>" } ", a word " { $snippet "<interface>-iid ( -- iid )" } " is defined to push the interface GUID (IID) onto the stack. Words of the form " { $snippet "<interface>::<function>" } " are also defined to invoke each method, as well as the methods inherited from " { $snippet "<parent>" } ". A " { $snippet "<parent>" } " of " { $snippet "f" } " indicates that the interface is a root interface. (Note that COM conventions demand that all interfaces at least inherit from " { $snippet "IUnknown" } ".)\n\nExample:" }
-{ $code <"
+{ $code """
COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
ULONG AddRef ( )
COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
int getX ( )
void setX ( int newX ) ;
-"> } ;
+""" } ;
USING: help.markup help.syntax io kernel math quotations\r
-multiline alien windows.com windows.com.syntax continuations\r
+alien windows.com windows.com.syntax continuations\r
destructors ;\r
IN: windows.com.wrapper\r
\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 object and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" }\r
-{ $code <"\r
+{ $code """\r
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}\r
HRESULT returnOK ( )\r
HRESULT returnError ( ) ;\r
[ swap x>> + ] ! IUnrelated::xPlus\r
[ spin x>> * + ] ! IUnrealted::xMulAdd\r
} }\r
-} <com-wrapper>\r
-"> } ;\r
+} <com-wrapper>""" } ;\r
\r
HELP: com-wrap\r
{ $values { "object" "The factor object to wrap" } { "wrapper" "A " { $link com-wrapper } " object" } { "wrapped-object" "A COM object referencing " { $snippet "object" } } }\r
! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: wrap.strings tools.test multiline ;
+USING: wrap.strings tools.test ;
IN: wrap.strings.tests
[
- <" This is a
+ """This is a
long piece
of text
that we
wish to
-word wrap.">
+word wrap."""
] [
- <" This is a long piece of text that we wish to word wrap."> 10
+ """This is a long piece of text that we wish to word wrap.""" 10
wrap-string
] unit-test
[
- <" This is a
+ """ This is a
long piece
of text
that we
wish to
- word wrap.">
+ word wrap."""
] [
- <" This is a long piece of text that we wish to word wrap."> 12
+ """This is a long piece of text that we wish to word wrap.""" 12
" " wrap-indented-string
] unit-test
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax xml.data present multiline ;
+USING: help.markup help.syntax xml.data present ;
IN: xml.syntax
ABOUT: "xml.syntax"
$nl
"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
{ $example
-{" USING: splitting xml.writer xml.syntax ;
+"""USING: splitting xml.writer xml.syntax ;
"one two three" " " split
[ [XML <item><-></item> XML] ] map
-<XML <doc><-></doc> XML> pprint-xml"}
-{" <?xml version="1.0" encoding="UTF-8"?>
+<XML <doc><-></doc> XML> pprint-xml"""
+
+"""<?xml version="1.0" encoding="UTF-8"?>
<doc>
<item>
one
<item>
three
</item>
-</doc>"} }
+</doc>""" }
"Here is an example of the locals version:"
{ $example
-{" USING: locals urls xml.syntax xml.writer ;
+"""USING: locals urls xml.syntax xml.writer ;
[let |
number [ 3 ]
false [ f ]
url [ URL" http://factorcode.org/" ]
string [ "hello" ]
- word [ \ drop ] |
+ word [ \\ drop ] |
<XML
<x
number=<-number->
url=<-url->
string=<-string->
word=<-word-> />
- XML> pprint-xml ] "}
-{" <?xml version="1.0" encoding="UTF-8"?>
-<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} }
+ XML> pprint-xml
+]"""
+
+"""<?xml version="1.0" encoding="UTF-8"?>
+<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>""" }
"XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:"
-{ $example {" USING: xml.syntax inverse ;
+{ $example """USING: xml.syntax inverse ;
: dispatch ( xml -- string )
{
{ [ [XML <a><-></a> XML] ] [ "a" prepend ] }
{ [ [XML <b val='yes'/> XML] ] [ "yes" ] }
{ [ [XML <b val=<->/> XML] ] [ "no" prepend ] }
} switch ;
-[XML <a>pple</a> XML] dispatch write "} "apple" } ;
+[XML <a>pple</a> XML] dispatch write"""
+"apple" } ;
HELP: XML-NS:
{ $syntax "XML-NS: name http://url" }
[ extract-variables ] tri
] unit-test
-[ {" <?xml version="1.0" encoding="UTF-8"?>
+[ """<?xml version="1.0" encoding="UTF-8"?>
<x>
one
<b val="two"/>
y
<foo/>
-</x>"} ] [
+</x>""" ] [
[let* | a [ "one" ] c [ "two" ] x [ "y" ]
d [ [XML <-x-> <foo/> XML] ] |
<XML
]
] unit-test
-[ {" <?xml version="1.0" encoding="UTF-8"?>
+[ """<?xml version="1.0" encoding="UTF-8"?>
<doc>
<item>
one
<item>
three
</item>
-</doc>"} ] [
+</doc>""" ] [
"one two three" " " split
[ [XML <item><-></item> XML] ] map
<XML <doc><-></doc> XML> pprint-xml>string
] unit-test
-[ {" <?xml version="1.0" encoding="UTF-8"?>
-<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ]
+[ """<?xml version="1.0" encoding="UTF-8"?>
+<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>""" ]
[ 3 f "http://factorcode.org/" "hello" \ drop
<XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
pprint-xml>string ] unit-test
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax xml.data sequences strings multiline ;
+USING: help.markup help.syntax xml.data sequences strings ;
IN: xml.traversal
ABOUT: "xml.traversal"
ARTICLE: { "xml.traversal" "intro" } "An example of XML processing"
"To illustrate how to use the XML library, we develop a simple Atom parser in Factor. Atom is an XML-based syndication format, like RSS. To see the full version of what we develop here, look at " { $snippet "basis/syndication" } " at the " { $snippet "atom1.0" } " word. First, we want to load a file and get a DOM tree for it."
-{ $code <" "file.xml" file>xml "> }
+{ $code """"file.xml" file>xml""" }
"No encoding descriptor is needed, because XML files contain sufficient information to auto-detect the encoding. Next, we want to extract information from the tree. To get the title, we can use the following:"
-{ $code <" "title" tag-named children>string "> }
+{ $code """"title" tag-named children>string""" }
"The " { $link tag-named } " word finds the first tag named " { $snippet "title" } " in the top level (just under the main tag). Then, with a tag on the stack, its children are asserted to be a string, and the string is returned." $nl
"For a slightly more complicated example, we can look at how entries are parsed. To get a sequence of tags with the name " { $snippet "entry" } ":"
-{ $code <" "entry" tags-named "> }
+{ $code """"entry" tags-named""" }
"Imagine that, for each of these, we want to get the URL of the entry. In Atom, the URLs are in a " { $snippet "link" } " tag which is contained in the " { $snippet "entry" } " tag. There are multiple " { $snippet "link" } " tags, but one of them contains the attribute " { $snippet "rel=alternate" } ", and the " { $snippet "href" } " attribute has the URL. So, given an element of the sequence produced in the above quotation, we run the code:"
-{ $code <" "link" tags-named [ "rel" attr "alternate" = ] find nip "> }
+{ $code """"link" tags-named [ "rel" attr "alternate" = ] find nip """ }
"to get the link tag on the stack, and"
-{ $code <" "href" attr >url "> }
+{ $code """"href" attr >url """ }
"to extract the URL from it." ;
HELP: deep-tag-named
HELP: indenter
{ $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" }
-{ $example {" USING: xml.syntax xml.writer namespaces ;
-[XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable "} {"
+{ $example """USING: xml.syntax xml.writer namespaces ;
+[XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable """ """
<foo>
%%%%bar
-</foo>"} } ;
+</foo>""" } ;
HELP: sensitive-tags
{ $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" }
-{ $example {" USING: xml.syntax xml.writer namespaces ;
+{ $example """USING: xml.syntax xml.writer namespaces ;
[XML <html> <head> <title> something</title></head><body><pre>bing
bang
- bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {"
+ bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable"""
+"""
<html>
<head>
<title>
bang
bong</pre>
</body>
-</html>"} } ;
+</html>""" } ;
"<?xml version=\"1.0\" encoding=\"UTF-8\"?><x/>" reprints-same
-{" <?xml version="1.0" encoding="UTF-8"?>
+"""<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE foo [<!ENTITY foo "bar">]>
-<x>bar</x> "}
-{" <?xml version="1.0" encoding="UTF-8"?>
+<x>bar</x>"""
+"""<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE foo [<!ENTITY foo 'bar'>]>
-<x>&foo;</x> "} reprints-as
+<x>&foo;</x>""" reprints-as
-{" <?xml version="1.0" encoding="UTF-8"?>
+"""<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE foo [
<!ENTITY foo "bar">
<!ELEMENT br EMPTY>
]>
<x>
bar
-</x>"}
-{" <?xml version="1.0" encoding="UTF-8"?>
+</x>"""
+"""<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE foo [ <!ENTITY foo 'bar'> <!ELEMENT br EMPTY>
<!ATTLIST list
type (bullets|ordered|glossary) "ordered">
<!NOTATION foo bar> <?baz bing bang bong?>
<!--wtf-->
]>
-<x>&foo;</x>"} pprint-reprints-as
+<x>&foo;</x>""" pprint-reprints-as
[ t ] [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\" >" dup string>xml-chunk xml>string = ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
[XML <tr><td><-></td><td><-></td></tr> XML]
] map [XML <h2>Timings</h2> <table><-></table> XML]
pprint-xml
-] unit-test
\ No newline at end of file
+] unit-test
[ ] [ \ (load-mode) reset-memoized ] unit-test
[ ] [
- <" <style type="text/css" media="screen" >
- * {margin:0; padding:0; border:0;} ">
+ """<style type="text/css" media="screen" >
+ * {margin:0; padding:0; border:0;}"""
string-lines "html" htmlize-lines drop
] unit-test
[ ] [
"test.c"
- <" int x = "hi";
-/* a comment */ "> <string-reader> htmlize-stream
+ """int x = "hi";
+/* a comment */""" <string-reader> htmlize-stream
write-xml
] unit-test
[ ":foo" ] [
{ ":foo" } "factor" htmlize-lines xml>string
-] unit-test
\ No newline at end of file
+] unit-test
{ $subsection class-and }\r
{ $subsection class-or }\r
{ $subsection classes-intersect? }\r
-{ $subsection min-class }\r
"Low-level implementation detail:"\r
{ $subsection flatten-class }\r
{ $subsection flatten-builtin-class }\r
"Operations:"\r
{ $subsection class< }\r
{ $subsection sort-classes }\r
+{ $subsection smallest-class }\r
"Metaclass order:"\r
{ $subsection rank-class } ;\r
\r
{ $values { "first" class } { "second" class } { "?" "a boolean" } }\r
{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;\r
\r
-HELP: min-class\r
-{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }\r
-{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;\r
+HELP: smallest-class\r
+{ $values { "classes" "a sequence of class words" } { "class/f" { $maybe class } } }\r
+{ $description "Outputs a minimum class from the given sequence." } ;\r
classes.private classes.union classes.mixin classes.predicate\r
vectors source-files compiler.units growable random\r
stack-checker effects kernel.private sbufs math.order\r
-classes.tuple accessors ;\r
+classes.tuple accessors generic.private ;\r
IN: classes.algebra.tests\r
\r
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
] unit-test\r
\r
! Test method inlining\r
+[ real ] [ { real sequence } smallest-class ] unit-test\r
+[ real ] [ { sequence real } smallest-class ] unit-test\r
+\r
+: min-class ( class classes -- class/f )\r
+ interesting-classes smallest-class ;\r
+\r
[ f ] [ fixnum { } min-class ] unit-test\r
\r
[ string ] [\r
[ dup largest-class [ over delete-nth ] dip ]\r
produce nip ;\r
\r
-: min-class ( class seq -- class/f )\r
- over [ classes-intersect? ] curry filter\r
- [ drop f ] [\r
- [ nip ] [ [ class<= ] with all? ] 2bi [ last ] [ drop f ] if\r
+: smallest-class ( classes -- class/f )\r
+ [ f ] [\r
+ natural-sort <reversed>\r
+ [ ] [ [ class<= ] most ] map-reduce\r
] if-empty ;\r
\r
GENERIC: (flatten-class) ( class -- )\r
! So the user has some code...
[ ] [
- <" IN: classes.test.a
+ """IN: classes.test.a
GENERIC: g ( a -- b )
TUPLE: x ;
M: x g ;
- TUPLE: z < x ;"> <string-reader>
+ TUPLE: z < x ;""" <string-reader>
"class-intersect-no-method-a" parse-stream drop
] unit-test
! Note that q inlines M: x g ;
[ ] [
- <" IN: classes.test.b
+ """IN: classes.test.b
USE: classes.test.a
USE: kernel
- : q ( -- b ) z new g ;"> <string-reader>
+ : q ( -- b ) z new g ;""" <string-reader>
"class-intersect-no-method-b" parse-stream drop
] unit-test
! Now, the user removes the z class and adds a method,
[ ] [
- <" IN: classes.test.a
+ """IN: classes.test.a
GENERIC: g ( a -- b )
TUPLE: x ;
M: x g ;
TUPLE: j ;
- M: j g ;"> <string-reader>
+ M: j g ;""" <string-reader>
"class-intersect-no-method-a" parse-stream drop
] unit-test
! And changes the definition of q
[ ] [
- <" IN: classes.test.b
+ """IN: classes.test.b
USE: classes.test.a
USE: kernel
- : q ( -- b ) j new g ;"> <string-reader>
+ : q ( -- b ) j new g ;""" <string-reader>
"class-intersect-no-method-b" parse-stream drop
] unit-test
! Similar problem, but with anonymous classes
[ ] [
- <" IN: classes.test.c
+ """IN: classes.test.c
USE: kernel
GENERIC: g ( a -- b )
M: object g ;
- TUPLE: z ;"> <string-reader>
+ TUPLE: z ;""" <string-reader>
"class-intersect-no-method-c" parse-stream drop
] unit-test
[ ] [
- <" IN: classes.test.d
+ """IN: classes.test.d
USE: classes.test.c
USE: kernel
- : q ( a -- b ) dup z? [ g ] unless ;"> <string-reader>
+ : q ( a -- b ) dup z? [ g ] unless ;""" <string-reader>
"class-intersect-no-method-d" parse-stream drop
] unit-test
! Now, the user removes the z class and adds a method,
[ ] [
- <" IN: classes.test.c
+ """IN: classes.test.c
USE: kernel
GENERIC: g ( a -- b )
M: object g ;
TUPLE: j ;
- M: j g ;"> <string-reader>
+ M: j g ;""" <string-reader>
"class-intersect-no-method-c" parse-stream drop
] unit-test
"The cleave combinators apply multiple quotations to a single value."
$nl
"Two quotations:"
-{ $subsection bi }
-{ $subsection 2bi }
-{ $subsection 3bi }
+{ $subsections bi 2bi 3bi }
"Three quotations:"
-{ $subsection tri }
-{ $subsection 2tri }
-{ $subsection 3tri }
+{ $subsections tri 2tri 3tri }
"An array of quotations:"
-{ $subsection cleave }
-{ $subsection 2cleave }
-{ $subsection 3cleave }
+{ $subsection cleave 2cleave 3cleave }
+$nl
"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
{ $code
"! First alternative; uses keep"
"[ 2 * ] tri"
}
"The latter is more aesthetically pleasing than the former."
+$nl
{ $subsection "cleave-shuffle-equivalence" } ;
ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
"The spread combinators apply multiple quotations to multiple values. In this case, " { $snippet "*" } " suffix signify spreading."
$nl
"Two quotations:"
-{ $subsection bi* }
-{ $subsection 2bi* }
+{ $subsections bi* 2bi* }
"Three quotations:"
-{ $subsection tri* }
-{ $subsection 2tri* }
+{ $subsections tri* 2tri* }
"An array of quotations:"
-{ $subsection spread }
+{ $subsections spread }
"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
{ $code
"! First alternative; uses dip"
"[ 1 + ] [ 1 - ] [ 2 * ] tri*"
}
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
+$nl
{ $subsection "spread-shuffle-equivalence" } ;
ARTICLE: "apply-combinators" "Apply combinators"
"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
$nl
"Two quotations:"
-{ $subsection bi@ }
-{ $subsection 2bi@ }
+{ $subsections bi@ 2bi@ }
"Three quotations:"
-{ $subsection tri@ }
-{ $subsection 2tri@ }
+{ $subsections tri@ 2tri@ }
"A pair of utility words built from " { $link bi@ } ":"
-{ $subsection both? }
-{ $subsection either? } ;
+{ $subsections both? either? } ;
ARTICLE: "retainstack-combinators" "Retain stack combinators"
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
$nl
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
-{ $subsection dip }
-{ $subsection 2dip }
-{ $subsection 3dip }
-{ $subsection 4dip }
+{ $subsections dip 2dip 3dip 4dip }
"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
-{ $subsection keep }
-{ $subsection 2keep }
-{ $subsection 3keep } ;
+{ $subsections keep 2keep 3keep } ;
ARTICLE: "curried-dataflow" "Curried dataflow combinators"
"Curried cleave combinators:"
-{ $subsection bi-curry }
-{ $subsection tri-curry }
+{ $subsections bi-curry tri-curry }
"Curried spread combinators:"
-{ $subsection bi-curry* }
-{ $subsection tri-curry* }
+{ $subsections bi-curry* tri-curry* }
"Curried apply combinators:"
-{ $subsection bi-curry@ }
-{ $subsection tri-curry@ }
+{ $subsections bi-curry@ tri-curry@ }
{ $see-also "dataflow-combinators" } ;
ARTICLE: "compositional-examples" "Examples of compositional combinator usage"
ARTICLE: "compositional-combinators" "Compositional combinators"
"Certain combinators transform quotations to produce a new quotation."
-{ $subsection "compositional-examples" }
+{ $subsections "compositional-examples" }
"Fundamental operations:"
-{ $subsection curry }
-{ $subsection compose }
+{ $subsections curry compose }
"Derived operations:"
-{ $subsection 2curry }
-{ $subsection 3curry }
-{ $subsection with }
-{ $subsection prepose }
+{ $subsections 2curry 3curry with prepose }
"These operations run in constant time, and in many cases are optimized out altogether by the " { $link "compiler" } ". " { $link "fry" } " are an abstraction built on top of these operations, and code that uses this abstraction is often clearer than direct calls to the below words."
$nl
"Curried dataflow combinators can be used to build more complex dataflow by combining cleave, spread and apply patterns in various ways."
-{ $subsection "curried-dataflow" }
+{ $subsections "curried-dataflow" }
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } ". However, such runtime quotation manipulation will not be optimized by the optimizing compiler." ;
ARTICLE: "booleans" "Booleans"
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
-{ $subsection f }
-{ $subsection t }
+{ $subsections f t }
"A union class of the above:"
-{ $subsection boolean }
+{ $subsections boolean }
"There are some logical operations on booleans:"
-{ $subsection >boolean }
-{ $subsection not }
-{ $subsection and }
-{ $subsection or }
-{ $subsection xor }
+{ $subsections
+ >boolean
+ not
+ and
+ or
+ xor
+}
"Boolean values are most frequently used for " { $link "conditionals" } "."
{ $heading "The f object and f class" }
"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing."
ARTICLE: "conditionals" "Conditional combinators"
"The basic conditionals:"
-{ $subsection if }
-{ $subsection when }
-{ $subsection unless }
+{ $subsections if when unless }
"Forms abstracting a common stack shuffle pattern:"
-{ $subsection if* }
-{ $subsection when* }
-{ $subsection unless* }
+{ $subsections if* when* unless* }
"Another form abstracting a common stack shuffle pattern:"
-{ $subsection ?if }
+{ $subsections ?if }
"Sometimes instead of branching, you just need to pick one of two values:"
-{ $subsection ? }
+{ $subsections ? }
"Two combinators which abstract out nested chains of " { $link if } ":"
-{ $subsection cond }
-{ $subsection case }
+{ $subsections cond case }
{ $subsection "conditionals-boolean-equivalence" }
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
ARTICLE: "dataflow-combinators" "Data flow combinators"
"Data flow combinators pass values between quotations:"
-{ $subsection "retainstack-combinators" }
-{ $subsection "cleave-combinators" }
-{ $subsection "spread-combinators" }
-{ $subsection "apply-combinators" }
+{ $subsections
+ "retainstack-combinators"
+ "cleave-combinators"
+ "spread-combinators"
+ "apply-combinators"
+}
{ $see-also "curried-dataflow" } ;
ARTICLE: "combinators-quot" "Quotation construction utilities"
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
-{ $subsection cond>quot }
-{ $subsection case>quot }
-{ $subsection alist>quot } ;
+{ $subsections cond>quot case>quot alist>quot } ;
ARTICLE: "call-unsafe" "Unsafe combinators"
"Unsafe calls declare an effect statically without any runtime checking:"
-{ $subsection call-effect-unsafe }
-{ $subsection execute-effect-unsafe } ;
+{ $subsections call-effect-unsafe execute-effect-unsafe } ;
ARTICLE: "call" "Fundamental combinators"
"The most basic combinators are those that take either a quotation or word, and invoke it immediately."
"There are two sets of combinators; they differ in whether or not the stack effect of the expected code is declared."
$nl
"The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:"
-{ $subsection call }
-{ $subsection execute }
+{ $subsections call execute }
"The second set of combinators takes an effect declaration. Note that the opening parenthesis is actually part of the word name; these are parsing words, and they read a stack effect until the corresponding closing parenthesis. The stack effect of the quotation or word is then checked at runtime:"
-{ $subsection POSTPONE: call( }
-{ $subsection POSTPONE: execute( }
+{ $subsections POSTPONE: call( POSTPONE: execute( }
"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:"
-{ $subsection call-effect }
-{ $subsection execute-effect }
+{ $subsections call-effect execute-effect }
"The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "."
{ $subsection "call-unsafe" }
{ $see-also "effects" "inference" } ;
ARTICLE: "combinators" "Combinators"
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
-{ $subsection "call" }
-{ $subsection "dataflow-combinators" }
-{ $subsection "conditionals" }
-{ $subsection "looping-combinators" }
-{ $subsection "compositional-combinators" }
-{ $subsection "combinators.short-circuit" }
-{ $subsection "combinators.smart" }
+{ $subsections
+ "call"
+ "dataflow-combinators"
+ "conditionals"
+ "looping-combinators"
+ "compositional-combinators"
+ "combinators.short-circuit"
+ "combinators.smart"
+ "combinators-quot"
+ "generalizations"
+}
"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
-{ $subsection "combinators-quot" }
-{ $subsection "generalizations" }
{ $see-also "quotations" } ;
ABOUT: "combinators"
-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 classes.tuple continuations
-layouts classes.union sorting compiler.units eval multiline
-io.streams.string ;
+USING: accessors alien arrays assocs classes classes.algebra
+classes.tuple classes.union compiler.units continuations
+definitions eval generic generic.math generic.standard
+hashtables io io.streams.string kernel layouts math math.order
+namespaces parser prettyprint quotations sequences sorting
+strings tools.test vectors words ;
IN: generic.tests
GENERIC: foobar ( x -- y )
! erg's regression
[ ] [
- <"
- IN: compiler.tests
+ """IN: compiler.tests
GENERIC: jeah ( a -- b )
TUPLE: boii ;
M: boii jeah ;
GENERIC: jeah* ( a -- b )
- M: boii jeah* jeah ;
- "> eval( -- )
+ M: boii jeah* jeah ;""" eval( -- )
- <"
- IN: compiler.tests
- FORGET: boii
- "> eval( -- )
+ """IN: compiler.tests
+ FORGET: boii""" eval( -- )
- <"
- IN: compiler.tests
+ """IN: compiler.tests
TUPLE: boii ;
- M: boii jeah ;
- "> eval( -- )
+ M: boii jeah ;""" eval( -- )
] unit-test
! call-next-method cache test
[ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
[ { string } ] [ \ move-method-generic order ] unit-test
+
+GENERIC: foozul ( a -- b )
+M: reversed foozul ;
+M: integer foozul ;
+M: slice foozul ;
+
+[ t ] [
+ reversed \ foozul method-for-class
+ reversed \ foozul method
+ eq?
+] unit-test
+
+[ t ] [
+ fixnum \ <=> method-for-class
+ real \ <=> method
+ eq?
+] unit-test
: method ( class generic -- method/f )
"methods" word-prop at ;
+<PRIVATE
+
+: interesting-class? ( class1 class2 -- ? )
+ {
+ ! Case 1: no intersection. Discard and keep going
+ { [ 2dup classes-intersect? not ] [ 2drop t ] }
+ ! Case 2: class1 contained in class2. Add to
+ ! interesting set and keep going.
+ { [ 2dup class<= ] [ nip , t ] }
+ ! Case 3: class1 and class2 are incomparable. Give up
+ [ 2drop f ]
+ } cond ;
+
+: interesting-classes ( class classes -- interesting/f )
+ [ [ interesting-class? ] with all? ] { } make and ;
+
+PRIVATE>
+
+: method-classes ( generic -- classes )
+ "methods" word-prop keys ;
+
: order ( generic -- seq )
- "methods" word-prop keys sort-classes ;
+ method-classes sort-classes ;
+
+: nearest-class ( class generic -- class/f )
+ method-classes interesting-classes smallest-class ;
-: specific-method ( class generic -- method/f )
- [ nip ] [ order min-class ] 2bi
- dup [ swap method ] [ 2drop f ] if ;
+: method-for-class ( class generic -- method/f )
+ [ nip ] [ nearest-class ] 2bi dup [ swap method ] [ 2drop f ] if ;
GENERIC: effective-method ( generic -- method )
\ effective-method t "no-compile" set-word-prop
: next-method-class ( class generic -- class/f )
- order [ class<= ] with filter reverse dup length 1 =
- [ drop f ] [ second ] if ;
+ method-classes [ class< ] with filter smallest-class ;
: next-method ( class generic -- method/f )
[ next-method-class ] keep method ;
M: hook-generic definer drop \ HOOK: f ;
M: hook-generic effective-method
- [ "combination" word-prop var>> get ] keep (effective-method) ;
\ No newline at end of file
+ [ "combination" word-prop var>> get ] keep method-for-object ;
\ No newline at end of file
<PRIVATE
-: applicable-method ( generic class -- quot )
+: (math-method) ( generic class -- quot )
over method
[ 1quotation ]
[ default-math-method ] ?if ;
PRIVATE>
: object-method ( generic -- quot )
- object bootstrap-word applicable-method ;
+ object bootstrap-word (math-method) ;
: math-method ( word class1 class2 -- quot )
2dup and [
[ 2array [ declare ] curry nip ]
[ math-upgrade nip ]
- [ math-class-max over order min-class applicable-method ]
+ [ math-class-max over nearest-class (math-method) ]
3tri 3append
] [
2drop object-method
] [ 3drop f ] if
] with-combination ;
-: (effective-method) ( obj word -- method )
- [ [ order [ instance? ] with find-last nip ] keep method ]
+: method-for-object ( obj word -- method )
+ [ [ method-classes [ instance? ] with filter smallest-class ] keep method ]
[ "default-method" word-prop ]
bi or ;
M: standard-generic effective-method
[ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
- (effective-method) ;
+ method-for-object ;
: inline-cache-quot ( word methods miss-word -- quot )
[ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
{ $description "Converts a byte-array, interpreted as little-endian, into a bignum integer. User code should call " { $link le> } " or " { $link be> } " instead." } ;
ARTICLE: "division-by-zero" "Division by zero"
-"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value."
+"Behavior of division operations when a denominator of zero is used depends on the data types in question, as well as the platform being used."
+$nl
+"Floating point division only throws an error if the appropriate traps are enabled in the floating point environment. If traps are disabled, a Not-a-number value or an infinity is output, depending on whether the numerator is zero or non-zero."
+$nl
+"Floating point traps are disabled by default and the " { $vocab-link "math.floats.env" } " vocabulary provides words to enable them. Floating point division is performed by " { $link / } ", " { $link /f } " or " { $link mod } " if at least one of the two inputs is a float. Floating point division is always performed by " { $link /f } "."
$nl
"The behavior of integer division is hardware specific. On x86 processors, " { $link /i } " and " { $link mod } " raise an error if both inputs are integers and the denominator is zero. On PowerPC, integer division by zero yields a result of zero."
$nl
-"On the other hand, the " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ;
+"The " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ;
ARTICLE: "number-protocol" "Number protocol"
"Math operations obey certain numerical upgrade rules. If one of the inputs is a bignum and the other is a fixnum, the latter is first coerced to a bignum; if one of the inputs is a float, the other is coerced to a float."
{ $subsection > }
{ $subsection >= }
"Numbers can be compared for equality using " { $link = } ", or a less precise test which disregards types:"
-{ $subsection number= } ;
+{ $subsection number= }
+{ $see-also "math.floats.compare" } ;
ARTICLE: "modular-arithmetic" "Modular arithmetic"
{ $subsection mod }
"Integers can be converted to and from arbitrary bases. Floating point numbers can only be converted to and from base 10 and 16."
$nl
"Converting numbers to strings:"
-{ $subsection number>string }
-{ $subsection >bin }
-{ $subsection >oct }
-{ $subsection >hex }
-{ $subsection >base }
+{ $subsections
+ number>string
+ >bin
+ >oct
+ >hex
+ >base
+}
"Converting strings to numbers:"
-{ $subsection string>number }
-{ $subsection bin> }
-{ $subsection oct> }
-{ $subsection hex> }
-{ $subsection base> }
+{ $subsections
+ string>number
+ bin>
+ oct>
+ hex>
+ base>
+}
"You can also input literal numbers in a different base (" { $link "syntax-integers" } ")."
{ $see-also "prettyprint-numbers" } ;
ARTICLE: "sequence-protocol" "Sequence protocol"
"All sequences must be instances of a mixin class:"
-{ $subsection sequence }
-{ $subsection sequence? }
+{ $subsections sequence sequence? }
"All sequences must know their length:"
-{ $subsection length }
+{ $subsections length }
"At least one of the following two generic words must have a method for accessing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
-{ $subsection nth }
-{ $subsection nth-unsafe }
+{ $subsections nth nth-unsafe }
"Note that sequences are always indexed starting from zero."
$nl
"At least one of the following two generic words must have a method for storing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
-{ $subsection set-nth }
-{ $subsection set-nth-unsafe }
-"Note that even if the sequence is immutable, at least one of the generic words must be specialized, otherwise calling them will result in an infinite recursion. There is a standard word which throws an error indicating a sequence is immutable:"
-{ $subsection immutable }
+{ $subsections set-nth set-nth-unsafe }
+"If your sequence is immutable, then you must implement either " { $link set-nth } " or " { $link set-nth-unsafe } " to simply call " { $link immutable } " to signal an error."
+$nl
"The following two generic words are optional, as not all sequences are resizable:"
-{ $subsection set-length }
-{ $subsection lengthen }
+{ $subsections set-length lengthen }
"An optional generic word for creating sequences of the same class as a given sequence:"
-{ $subsection like }
+{ $subsections like }
"Optional generic words for optimization purposes:"
-{ $subsection new-sequence }
-{ $subsection new-resizable }
+{ $subsections new-sequence new-resizable }
{ $see-also "sequences-unsafe" } ;
ARTICLE: "virtual-sequences-protocol" "Virtual sequence protocol"
"Virtual sequences must know their length:"
-{ $subsection length }
+{ $subsections length }
"The underlying sequence to look up a value in:"
-{ $subsection virtual-seq }
+{ $subsections virtual-seq }
"The index of the value in the underlying sequence:"
-{ $subsection virtual@ } ;
+{ $subsections virtual@ } ;
ARTICLE: "virtual-sequences" "Virtual sequences"
"A virtual sequence is an implementation of the " { $link "sequence-protocol" } " which does not store its own elements, and instead computes them, either from scratch or by retrieving them from another sequence."
$nl
"Implementations include the following:"
-{ $list
- { $link reversed }
- { $link slice }
- { $link iota }
-}
-"Virtual sequences can be implemented with the " { $link "virtual-sequences-protocol" } ", by translating an index in the virtual sequence into an index in another sequence:"
-{ $subsection "virtual-sequences-protocol" } ;
+{ $subsections reversed slice iota }
+"Virtual sequences can be implemented with the " { $link "virtual-sequences-protocol" } ", by translating an index in the virtual sequence into an index in another sequence." ;
ARTICLE: "sequences-integers" "Counted loops"
"Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops."
"To reduce the boilerplate of checking if a sequence is empty, several combinators are provided."
$nl
"Checking if a sequence is empty:"
-{ $subsection if-empty }
-{ $subsection when-empty }
-{ $subsection unless-empty } ;
+{ $subsections if-empty when-empty unless-empty } ;
ARTICLE: "sequences-access" "Accessing sequence elements"
-{ $subsection ?nth }
+"Element access by index, without raising exceptions:"
+{ $subsections ?nth }
"Concise way of extracting one of the first four elements:"
-{ $subsection first }
-{ $subsection second }
-{ $subsection third }
-{ $subsection fourth }
+{ $subsections first second third fourth }
"Extracting the last element:"
-{ $subsection last }
+{ $subsections last }
"Unpacking sequences:"
-{ $subsection first2 }
-{ $subsection first3 }
-{ $subsection first4 }
+{ $subsections first2 first3 first4 }
{ $see-also nth } ;
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
-{ $subsection prefix }
-{ $subsection suffix }
+{ $subsections prefix suffix }
"Removing elements:"
-{ $subsection remove }
-{ $subsection remq }
-{ $subsection remove-nth } ;
+{ $subsections remove remq remove-nth } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
-{ $subsection repetition }
-{ $subsection <repetition> }
+{ $subsections repetition <repetition> }
"Reversing a sequence:"
-{ $subsection reverse }
+{ $subsections reverse }
"A " { $emphasis "reversal" } " presents a reversed view of an underlying sequence:"
-{ $subsection reversed }
-{ $subsection <reversed> }
+{ $subsections reversed <reversed> }
"Transposing a matrix:"
-{ $subsection flip } ;
+{ $subsections flip } ;
ARTICLE: "sequences-appending" "Appending sequences"
-{ $subsection append }
-{ $subsection append-as }
-{ $subsection prepend }
-{ $subsection 3append }
-{ $subsection 3append-as }
-{ $subsection surround }
-{ $subsection glue }
-{ $subsection concat }
-{ $subsection join }
+"Basic append operations:"
+{ $subsections
+ append
+ append-as
+ prepend
+ 3append
+ 3append-as
+ surround
+ glue
+}
+"Collapse a sequence unto itself:"
+{ $subsections concat join }
"A pair of words useful for aligning strings:"
-{ $subsection pad-head }
-{ $subsection pad-tail } ;
+{ $subsections pad-head pad-tail } ;
ARTICLE: "sequences-slices" "Subsequences and slices"
"There are two ways to extract a subrange of elements from a sequence. The first approach creates a new sequence of the same type as the input, which does not share storage with the underlying sequence. This takes time proportional to the number of elements being extracted. The second approach creates a " { $emphasis "slice" } ", which is a virtual sequence (see " { $link "virtual-sequences" } ") sharing storage with the original sequence. Slices are constructed in constant time."
}
{ $heading "Subsequence operations" }
"Extracting a subsequence:"
-{ $subsection subseq }
-{ $subsection head }
-{ $subsection tail }
-{ $subsection head* }
-{ $subsection tail* }
+{ $subsections
+ subseq
+ head
+ tail
+ head*
+ tail*
+}
"Removing the first or last element:"
-{ $subsection rest }
-{ $subsection but-last }
+{ $subsections rest but-last }
"Taking a sequence apart into a head and a tail:"
-{ $subsection unclip }
-{ $subsection unclip-last }
-{ $subsection cut }
-{ $subsection cut* }
+{ $subsections
+ unclip
+ unclip-last
+ cut
+ cut*
+}
{ $heading "Slice operations" }
"The slice data type:"
-{ $subsection slice }
-{ $subsection slice? }
+{ $subsections slice slice? }
"Extracting a slice:"
-{ $subsection <slice> }
-{ $subsection head-slice }
-{ $subsection tail-slice }
-{ $subsection head-slice* }
-{ $subsection tail-slice* }
+{ $subsections
+ <slice>
+ head-slice
+ tail-slice
+ head-slice*
+ tail-slice*
+}
"Removing the first or last element:"
-{ $subsection rest-slice }
-{ $subsection but-last-slice }
+{ $subsections rest-slice but-last-slice }
"Taking a sequence apart into a head and a tail:"
-{ $subsection unclip-slice }
-{ $subsection unclip-last-slice }
-{ $subsection cut-slice }
+{ $subsections unclip-slice unclip-last-slice cut-slice }
"A utility for words which use slices as iterators:"
-{ $subsection <flat-slice> }
+{ $subsections <flat-slice> }
"Replacing slices with new elements:"
-{ $subsection replace-slice } ;
+{ $subsections replace-slice } ;
ARTICLE: "sequences-combinators" "Sequence combinators"
"Iteration:"
-{ $subsection each }
-{ $subsection each-index }
-{ $subsection reduce }
-{ $subsection interleave }
-{ $subsection replicate }
-{ $subsection replicate-as }
+{ $subsections
+ each
+ each-index
+ reduce
+ interleave
+ replicate
+ replicate-as
+}
"Mapping:"
-{ $subsection map }
-{ $subsection map-as }
-{ $subsection map-index }
-{ $subsection map-reduce }
-{ $subsection accumulate }
-{ $subsection produce }
-{ $subsection produce-as }
+{ $subsections
+ map
+ map-as
+ map-index
+ map-reduce
+ accumulate
+ produce
+ produce-as
+}
"Filtering:"
-{ $subsection filter }
-{ $subsection partition }
+{ $subsections
+ filter
+ partition
+}
"Testing if a sequence contains elements satisfying a predicate:"
-{ $subsection any? }
-{ $subsection all? }
+{ $subsections
+ any?
+ all?
+}
+{ $heading "Related Articles" }
{ $subsection "sequence-2combinators" }
{ $subsection "sequence-3combinators" } ;
ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined."
-{ $subsection 2each }
-{ $subsection 2reduce }
-{ $subsection 2map }
-{ $subsection 2map-as }
-{ $subsection 2map-reduce }
-{ $subsection 2all? } ;
+{ $subsections
+ 2each
+ 2reduce
+ 2map
+ 2map-as
+ 2map-reduce
+ 2all?
+} ;
ARTICLE: "sequence-3combinators" "Triple-wise sequence combinators"
"There is a set of combinators which traverse three sequences triple-wise. If one sequence is shorter than the others, then only the prefix having the length of the minimum of the three is examined."
-{ $subsection 3each }
-{ $subsection 3map }
-{ $subsection 3map-as } ;
+{ $subsections 3each 3map 3map-as } ;
ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:"
-{ $subsection empty? }
+{ $subsections empty? }
"Testing indices:"
-{ $subsection bounds-check? }
+{ $subsections bounds-check? }
"Testing if a sequence contains an object:"
-{ $subsection member? }
-{ $subsection memq? }
+{ $subsections member? memq? }
"Testing if a sequence contains a subsequence:"
-{ $subsection head? }
-{ $subsection tail? }
-{ $subsection subseq? } ;
+{ $subsections head? tail? subseq? } ;
ARTICLE: "sequences-search" "Searching sequences"
"Finding the index of an element:"
-{ $subsection index }
-{ $subsection index-from }
-{ $subsection last-index }
-{ $subsection last-index-from }
+{ $subsections
+ index
+ index-from
+ last-index
+ last-index-from
+}
"Finding the start of a subsequence:"
-{ $subsection start }
-{ $subsection start* }
+{ $subsections start start* }
"Finding the index of an element satisfying a predicate:"
-{ $subsection find }
-{ $subsection find-from }
-{ $subsection find-last }
-{ $subsection find-last-from }
-{ $subsection map-find } ;
+{ $subsections
+ find
+ find-from
+ find-last
+ find-last-from
+ map-find
+} ;
ARTICLE: "sequences-trimming" "Trimming sequences"
"Trimming words:"
-{ $subsection trim }
-{ $subsection trim-head }
-{ $subsection trim-tail }
+{ $subsections trim trim-head trim-tail }
"Potentially more efficient trim:"
-{ $subsection trim-slice }
-{ $subsection trim-head-slice }
-{ $subsection trim-tail-slice } ;
+{ $subsections trim-slice trim-head-slice trim-tail-slice } ;
ARTICLE: "sequences-destructive-discussion" "When to use destructive operations"
"Constructive (non-destructive) operations should be preferred where possible because code without side-effects is usually more re-usable and easier to reason about. There are two main reasons to use destructive operations:"
"The second reason is much weaker than the first one. In particular, many combinators (see " { $link map } ", " { $link produce } " and " { $link "namespaces-make" } ") as well as more advanced data structures (such as " { $vocab-link "persistent.vectors" } ") alleviate the need for explicit use of side effects." ;
ARTICLE: "sequences-destructive" "Destructive operations"
-"These words modify their input, instead of creating a new sequence."
-{ $subsection "sequences-destructive-discussion" }
"Changing elements:"
-{ $subsection change-each }
-{ $subsection change-nth }
+{ $subsections change-each change-nth }
"Deleting elements:"
-{ $subsection delete }
-{ $subsection delq }
-{ $subsection delete-nth }
-{ $subsection delete-slice }
-{ $subsection delete-all }
-{ $subsection filter-here }
+{ $subsections
+ delete
+ delq
+ delete-nth
+ delete-slice
+ delete-all
+ filter-here
+}
"Other destructive words:"
-{ $subsection reverse-here }
-{ $subsection push-all }
-{ $subsection move }
-{ $subsection exchange }
-{ $subsection copy }
+{ $subsections
+ reverse-here
+ push-all
+ move
+ exchange
+ copy
+}
"Many operations have constructive and destructive variants:"
{ $table
{ "Constructive" "Destructive" }
{ { $link map } { $link change-each } }
{ { $link filter } { $link filter-here } }
}
-{ $see-also set-nth push pop "sequences-stacks" } ;
+{ $heading "Related Articles" }
+{ $subsection "sequences-destructive-discussion" }
+{ $subsection "sequences-stacks" }
+{ $see-also set-nth push pop } ;
ARTICLE: "sequences-stacks" "Treating sequences as stacks"
"The classical stack operations, modifying a sequence in place:"
-{ $subsection push }
-{ $subsection pop }
-{ $subsection pop* }
+{ $subsections push pop pop* }
{ $see-also empty? } ;
ARTICLE: "sequences-comparing" "Comparing sequences"
"Element equality testing:"
-{ $subsection sequence= }
-{ $subsection mismatch }
-{ $subsection drop-prefix }
-{ $subsection assert-sequence= }
+{ $subsections
+ sequence=
+ mismatch
+ drop-prefix
+ assert-sequence=
+}
"The " { $link <=> } " generic word performs lexicographic comparison when applied to sequences." ;
ARTICLE: "sequences-f" "The f object as a sequence"
"A " { $emphasis "sequence" } " is a finite, linearly-ordered collection of elements. Words for working with sequences are in the " { $vocab-link "sequences" } " vocabulary."
$nl
"Sequences implement a protocol:"
-{ $subsection "sequence-protocol" }
-{ $subsection "sequences-f" }
+{ $subsections
+ "sequence-protocol"
+ "sequences-f"
+}
"Sequence utility words can operate on any object whose class implements the sequence protocol. Most implementations are backed by storage. Some implementations obtain their elements from an underlying sequence, or compute them on the fly. These are known as " { $link "virtual-sequences" } "."
-{ $subsection "sequences-access" }
-{ $subsection "sequences-combinators" }
-{ $subsection "sequences-add-remove" }
-{ $subsection "sequences-appending" }
-{ $subsection "sequences-slices" }
-{ $subsection "sequences-reshape" }
-{ $subsection "sequences-tests" }
-{ $subsection "sequences-search" }
-{ $subsection "sequences-comparing" }
-{ $subsection "sequences-split" }
-{ $subsection "grouping" }
-{ $subsection "sequences-destructive" }
-{ $subsection "sequences-stacks" }
-{ $subsection "sequences-sorting" }
-{ $subsection "binary-search" }
-{ $subsection "sets" }
-{ $subsection "sequences-trimming" }
-{ $subsection "sequences.deep" }
+{ $subsections
+ "sequences-access"
+ "sequences-combinators"
+ "sequences-add-remove"
+ "sequences-appending"
+ "sequences-slices"
+ "sequences-reshape"
+ "sequences-tests"
+ "sequences-search"
+ "sequences-comparing"
+ "sequences-split"
+ "grouping"
+ "sequences-destructive"
+ "sequences-stacks"
+ "sequences-sorting"
+ "binary-search"
+ "sets"
+ "sequences-trimming"
+ "sequences.deep"
+}
"Using sequences for looping:"
-{ $subsection "sequences-integers" }
-{ $subsection "math.ranges" }
+{ $subsections
+ "sequences-integers"
+ "math.ranges"
+}
"Using sequences for control flow:"
-{ $subsection "sequences-if" }
+{ $subsections "sequences-if" }
"For inner loops:"
-{ $subsection "sequences-unsafe" } ;
+{ $subsections "sequences-unsafe" } ;
ABOUT: "sequences"
"Sorting combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
$nl
"Sorting a sequence with a custom comparator:"
-{ $subsection sort }
+{ $subsections sort }
"Sorting a sequence with common comparators:"
-{ $subsection sort-with }
-{ $subsection inv-sort-with }
-{ $subsection natural-sort }
-{ $subsection sort-keys }
-{ $subsection sort-values } ;
+{ $subsections
+ sort-with
+ inv-sort-with
+ natural-sort
+ sort-keys
+ sort-values
+} ;
ABOUT: "sequences-sorting"
+USING: accessors eval strings.parser strings.parser.private
+tools.test ;
IN: strings.parser.tests
-USING: strings.parser tools.test ;
[ "Hello\n\rworld" ] [ "Hello\\n\\rworld" unescape-string ] unit-test
+
+[ "Hello\n\rworld" ] [ "Hello\n\rworld" ] unit-test
+[ "Hello\n\rworld" ] [ """Hello\n\rworld""" ] unit-test
+[ "Hello\n\rworld\n" ] [ "Hello\n\rworld
+" ] unit-test
+[ "Hello\n\rworld" "hi" ] [ "Hello\n\rworld" "hi" ] unit-test
+[ "Hello\n\rworld" "hi" ] [ """Hello\n\rworld""" """hi""" ] unit-test
+[ "Hello\n\rworld\n" "hi" ] [ """Hello\n\rworld
+""" """hi""" ] unit-test
+[ "Hello\n\rworld\"" "hi" ] [ """Hello\n\rworld\"""" """hi""" ] unit-test
+
+[
+ "\"\"\"Hello\n\rworld\\\n\"\"\"" eval( -- obj )
+] [
+ error>> escaped-char-expected?
+] must-fail-with
+
+[
+ " \" abc \" "
+] [
+ "\"\"\" \" abc \" \"\"\"" eval( -- string )
+] unit-test
+
+[
+ "\"abc\""
+] [
+ "\"\"\"\"abc\"\"\"\"" eval( -- string )
+] unit-test
+
+
+[ "\"\\" ] [ "\"\\" ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs namespaces make splitting sequences
-strings math.parser lexer accessors ;
+USING: accessors assocs kernel lexer make math math.parser
+namespaces parser sequences splitting strings arrays
+math.order ;
IN: strings.parser
-ERROR: bad-escape ;
+ERROR: bad-escape char ;
: escape ( escape -- ch )
H{
{ CHAR: 0 CHAR: \0 }
{ CHAR: \\ CHAR: \\ }
{ CHAR: \" CHAR: \" }
- } at [ bad-escape ] unless* ;
+ } ?at [ bad-escape ] unless ;
SYMBOL: name>char-hook
unclip-slice escape swap
] if ;
+: (unescape-string) ( str -- )
+ CHAR: \\ over index dup [
+ cut-slice [ % ] dip rest-slice
+ next-escape [ , ] dip
+ (unescape-string)
+ ] [
+ drop %
+ ] if ;
+
+: unescape-string ( str -- str' )
+ [ (unescape-string) ] "" make ;
+
: (parse-string) ( str -- m )
dup [ "\"\\" member? ] find dup [
[ cut-slice [ % ] dip rest-slice ] dip
[ swap tail-slice (parse-string) ] "" make swap
] change-lexer-column ;
-: (unescape-string) ( str -- )
- CHAR: \\ over index dup [
- cut-slice [ % ] dip rest-slice
- next-escape [ , ] dip
- (unescape-string)
+<PRIVATE
+
+: lexer-before ( i -- before )
+ [
+ [
+ lexer get
+ [ column>> ] [ line-text>> ] bi
+ ] dip swap subseq
] [
- drop %
+ lexer get (>>column)
+ ] bi ;
+
+: find-next-token ( ch -- i elt )
+ CHAR: \ 2array
+ [ lexer get [ column>> ] [ line-text>> ] bi ] dip
+ [ member? ] curry find-from ;
+
+: rest-of-line ( lexer -- seq )
+ [ line-text>> ] [ column>> ] bi tail-slice ;
+
+: current-char ( lexer -- ch/f )
+ [ column>> ] [ line-text>> ] bi ?nth ;
+
+: advance-char ( lexer -- )
+ [ 1 + ] change-column drop ;
+
+ERROR: escaped-char-expected ;
+
+: next-char ( lexer -- ch )
+ dup still-parsing-line? [
+ [ current-char ] [ advance-char ] bi
+ ] [
+ escaped-char-expected
] if ;
-: unescape-string ( str -- str' )
- [ (unescape-string) ] "" make ;
+: next-line% ( lexer -- )
+ [ rest-of-line % ]
+ [ next-line "\n" % ] bi ;
+
+: rest-begins? ( string -- ? )
+ [
+ lexer get [ line-text>> ] [ column>> ] bi tail-slice
+ ] dip head? ;
+
+: advance-lexer ( n -- )
+ [ lexer get ] dip [ + ] curry change-column drop ; inline
+
+: take-double-quotes ( -- string )
+ lexer get dup current-char CHAR: " = [
+ [ ] [ column>> ] [ line-text>> ] tri
+ [ CHAR: " = not ] find-from drop [
+ swap column>> - CHAR: " <repetition>
+ ] [
+ rest-of-line
+ ] if*
+ ] [
+ drop f
+ ] if dup length advance-lexer ;
+
+: end-string-parse ( delimiter -- )
+ length 3 = [
+ take-double-quotes 3 tail %
+ ] [
+ lexer get advance-char
+ ] if ;
+
+DEFER: (parse-long-string)
+
+: parse-found-token ( i string token -- )
+ [ lexer-before % ] dip
+ CHAR: \ = [
+ lexer get [ next-char , ] [ next-char , ] bi (parse-long-string)
+ ] [
+ dup rest-begins? [
+ end-string-parse
+ ] [
+ lexer get next-char , (parse-long-string)
+ ] if
+ ] if ;
+
+ERROR: trailing-characters string ;
+
+: (parse-long-string) ( string -- )
+ lexer get still-parsing? [
+ dup first find-next-token [
+ parse-found-token
+ ] [
+ drop lexer get next-line%
+ (parse-long-string)
+ ] if*
+ ] [
+ unexpected-eof
+ ] if ;
+
+PRIVATE>
+
+: parse-long-string ( string -- string' )
+ [ (parse-long-string) ] "" make ;
+
+: parse-multiline-string ( -- string )
+ lexer get rest-of-line "\"\"" head? [
+ lexer get [ 2 + ] change-column drop
+ "\"\"\""
+ ] [
+ "\""
+ ] if parse-long-string unescape-string ;
M: string equal?
over string? [
- over hashcode over hashcode eq?
+ 2dup [ hashcode ] bi@ eq?
[ sequence= ] [ 2drop f ] if
] [
2drop f
} ;
HELP: "
-{ $syntax "\"string...\"" }
+{ $syntax "\"string...\"" "\"\"\"string...\"\"\"" }
{ $values { "string" "literal and escaped characters" } }
-{ $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", and appends the resulting string to the parse tree. String literals cannot span multiple lines. Strings containing the " { $link POSTPONE: " } " character and various other special characters can be read by inserting " { $link "escape" } "." }
+{ $description "Reads from the input string until the next occurrence of " { $snippet "\"" } " or " { $snippet "\"\"\"" } ", and appends the resulting string to the parse tree. String literals can span multiple lines. Various special characters can be read by inserting " { $link "escape" } ". For triple quoted strings, the double-quote character does not require escaping." }
{ $examples
- "A string with a newline in it:"
- { $example "USE: io" "\"Hello\\nworld\" print" "Hello\nworld" }
- "A string with a named Unicode code point:"
- { $example "USE: io" "\"\\u{greek-capital-letter-sigma}\" print" "\u{greek-capital-letter-sigma}" }
+ "A string with an escaped newline in it:"
+ { $example "USE: io" "\"Hello\\nworld\" print" "Hello\nworld" }
+ "A string with an actual newline in it:"
+ { $example "USE: io" "\"Hello\nworld\" print" "Hello\nworld" }
+ "A string with a named Unicode code point:"
+ { $example "USE: io" "\"\\u{greek-capital-letter-sigma}\" print" "\u{greek-capital-letter-sigma}" }
+ "A triple-quoted string:"
+ { $example "USE: io \"\"\"Teach a man to \"fish\"...\nand fish will go extinct\"\"\" print" """Teach a man to \"fish\"...
+and fish will go extinct""" }
} ;
HELP: SBUF"
} cond parsed
] define-core-syntax
- "\"" [ parse-string parsed ] define-core-syntax
+ "\"" [ parse-multiline-string parsed ] define-core-syntax
"SBUF\"" [
lexer get skip-blank parse-string >sbuf parsed
! Copyright (C) 2008 Jean-François Bigot.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations strings multiline ;
+USING: help.markup help.syntax kernel quotations strings ;
IN: 4DNav
$nl
"An example is:"
-{ $code <"
+{ $code """
<model>
<space>
<dimension>4</dimension>
</light>
<color>0.8,0.9,0.9</color>
</space>
-</model> "> } ;
+</model>""" } ;
ARTICLE: "TODO" "Todo"
{ $list
! Copyright (C) 2008 Jeff Bigot\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax multiline ;\r
+USING: help.markup help.syntax ;\r
IN: adsoda\r
\r
! --------------------------------------------------------------\r
;\r
\r
ARTICLE: { "adsoda" "light" } "ADSODA : lights"\r
-{ $code <"\r
+{ $code """\r
! HELP: light position color\r
! <light> ( -- tuple ) light new ;\r
! light est un vecteur avec 3 variables pour les couleurs\n\r
if (cRed > 1.0) cRed = 1.0;\r
if (cGreen > 1.0) cGreen = 1.0;\r
if (cBlue > 1.0) cBlue = 1.0;\r
-"> }\r
+""" }\r
;\r
\r
\r
math.functions math.vectors math.vectors.simd prettyprint
combinators.smart sequences hints classes.struct
specialized-arrays ;
+SIMD: double
IN: benchmark.nbody-simd
: solar-mass ( -- x ) 4 pi sq * ; inline
io.encodings.binary kernel math math.constants math.functions
math.vectors math.vectors.simd math.parser make sequences
sequences.private words hints classes.struct ;
+SIMD: double
IN: benchmark.raytracer-simd
! parameters
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io math math.functions math.parser math.vectors
math.vectors.simd sequences specialized-arrays ;
+SIMD: float
SPECIALIZED-ARRAY: float-4
IN: benchmark.simd-1
] [
number-of-requests
[ read1 write1 flush ] times
- counter get count-down
] if
] with-stream
] curry "Client handler" spawn drop server-loop ;
: clients ( n -- )
dup pprint " clients: " write [
<promise> port-promise set
- dup 2 * <count-down> counter set
+ dup <count-down> counter set
[ simple-server ] "Simple server" spawn drop
yield yield
[ [ simple-client ] "Simple client" spawn drop ] times
! See http://factorcode.org/license.txt for BSD license
USING: brainfuck kernel io.streams.string math math.parser math.ranges
-multiline quotations sequences tools.test ;
+quotations sequences tools.test ;
+IN: brainfuck.tests
[ "+" run-brainfuck ] must-infer
! Hello World!
-[ "Hello World!\n" ] [ <" ++++++++++[>+++++++>++++++++++>+++>+<<<<-]
+[ "Hello World!\n" ] [ """++++++++++[>+++++++>++++++++++>+++>+<<<<-]
>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.
- ------.--------.>+.>. "> get-brainfuck ] unit-test
+ ------.--------.>+.>.""" get-brainfuck ] unit-test
! Addition (single-digit)
! Multiplication (single-digit)
-[ "8\0" ] [ "24" [ <" ,>,>++++++++[<------<------>>-]
+[ "8\0" ] [ "24" [ """,>,>++++++++[<------<------>>-]
<<[>[>+>+<<-]>>[<<+>>-]<<<-]
- >>>++++++[<++++++++>-],<.>. ">
+ >>>++++++[<++++++++>-],<.>."""
get-brainfuck ] with-string-reader ] unit-test
! Division (single-digit, integer)
-[ "3" ] [ "62" [ <" ,>,>++++++[-<--------<-------->>]
+[ "3" ] [ "62" [ """,>,>++++++[-<--------<-------->>]
<<[
>[->+>+<<]
>[-<<-
<<[-<<+>>]
<<<]
>[-]>>>>[-<<<<<+>>>>>]
- <<<<++++++[-<++++++++>]<. ">
+ <<<<++++++[-<++++++++>]<."""
get-brainfuck ] with-string-reader ] unit-test
! Uppercase
! Squares of numbers from 0 to 100
100 [0,b] [ dup * number>string ] map "\n" join "\n" append 1quotation
-[ <" ++++[>+++++<-]>[<+++++>-]+<+[
+[ """++++[>+++++<-]>[<+++++>-]+<+[
>[>+>+<<-]++>>[<<+>>-]>>>[-]++>[-]+
>>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]
<<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>
- [-[<->-]+[<<<]]<[>+<-]>]<<-]<<-] ">
+ [-[<->-]+[<<<]]<[>+<-]>]<<-]<<-]"""
get-brainfuck ] unit-test
--- /dev/null
+IN: compiler.graphviz.tests
+USING: compiler.graphviz io.files kernel tools.test ;
+
+[ t ] [ [ [ 1 ] [ 2 ] if ] render-cfg exists? ] unit-test
+[ t ] [ [ [ 1 ] [ 2 ] if ] render-dom exists? ] unit-test
+[ t ] [ [ [ 1 ] [ 2 ] if ] render-call-graph exists? ] unit-test
"}" ,
] { } make , ; inline
-: render-graph ( quot -- )
+: render-graph ( quot -- name )
{ } make
"cfg" ".dot" make-unique-file
dup "Wrote " prepend print
[ [ concat ] dip ascii set-file-lines ]
[ { "dot" "-Tpng" "-O" } swap suffix try-process ]
- [ ".png" append "open" swap 2array try-process ]
+ [ ".png" append ]
tri ; inline
+: display-graph ( name -- )
+ "open" swap 2array try-process ;
+
: attrs>string ( seq -- str )
[ "" ] [ "," join "[" "]" surround ] if-empty ;
: optimized-cfg ( quot -- cfgs )
{
{ [ dup cfg? ] [ 1array ] }
- { [ dup quotation? ] [ test-cfg [ optimize-cfg ] map ] }
- { [ dup word? ] [ test-cfg [ optimize-cfg ] map ] }
+ { [ dup quotation? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
+ { [ dup word? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
[ ]
} cond ;
-: render-cfg ( cfg -- )
+: render-cfg ( cfg -- name )
optimized-cfg [ cfgs ] render-graph ;
: dom-trees ( cfgs -- )
] over cfg-title graph,
] each ;
-: render-dom ( cfg -- )
+: render-dom ( cfg -- name )
optimized-cfg [ dom-trees ] render-graph ;
SYMBOL: word-counts
H{ } clone vertex-names set
[ "ROOT" ] dip (call-graph-edges) ;
-: render-call-graph ( tree -- )
+: render-call-graph ( tree -- name )
dup quotation? [ build-tree ] when
analyze-recursive drop
[ [ call-graph get call-graph-edges ] "Call graph" graph, ]
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations decimals grouping kernel locals math
+math.functions math.order math.ratios prettyprint random
+sequences tools.test ;
+IN: decimals.tests
+
+[ t ] [
+ D: 12.34 D: 00012.34000 =
+] unit-test
+
+: random-test-int ( -- n )
+ 10 random 2 random 0 = [ neg ] when ;
+
+: random-test-decimal ( -- decimal )
+ random-test-int random-test-int <decimal> ;
+
+ERROR: decimal-test-failure D1 D2 quot ;
+
+:: (test-decimal-op) ( D1 D2 quot1 quot2 -- ? )
+ D1 D2
+ quot1 [ decimal>ratio >float ] compose
+ [ [ decimal>ratio ] bi@ quot2 call( obj obj -- obj ) >float ] 2bi -.1 ~
+ [ t ] [ D1 D2 quot1 decimal-test-failure ] if ; inline
+
+: test-decimal-op ( quot1 quot2 -- ? )
+ [ random-test-decimal random-test-decimal ] 2dip (test-decimal-op) ; inline
+
+[ t ] [ 1000 [ drop [ D+ ] [ + ] test-decimal-op ] all? ] unit-test
+[ t ] [ 1000 [ drop [ D- ] [ - ] test-decimal-op ] all? ] unit-test
+[ t ] [ 1000 [ drop [ D* ] [ * ] test-decimal-op ] all? ] unit-test
+[ t ] [
+ 1000 [
+ drop
+ [ [ 100 D/ ] [ /f ] test-decimal-op ]
+ [ { "kernel-error" 4 f f } = ] recover
+ ] all?
+] unit-test
+
+[ t ] [
+ { D: 0. D: .0 D: 0.0 D: 00.00 D: . } all-equal?
+] unit-test
+
+[ t ] [ T{ decimal f 90 0 } T{ decimal f 9 1 } = ] unit-test
+
+[ t ] [ D: 1 D: 2 before? ] unit-test
+[ f ] [ D: 2 D: 2 before? ] unit-test
+[ f ] [ D: 3 D: 2 before? ] unit-test
+[ f ] [ D: -1 D: -2 before? ] unit-test
+[ f ] [ D: -2 D: -2 before? ] unit-test
+[ t ] [ D: -3 D: -2 before? ] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel lexer math
+math.functions math.parser parser sequences splitting
+locals math.order ;
+IN: decimals
+
+TUPLE: decimal { mantissa read-only } { exponent read-only } ;
+
+: <decimal> ( mantissa exponent -- decimal ) decimal boa ;
+
+: >decimal< ( decimal -- mantissa exponent )
+ [ mantissa>> ] [ exponent>> ] bi ; inline
+
+: string>decimal ( string -- decimal )
+ "." split1
+ [ [ CHAR: 0 = ] trim-head [ "0" ] when-empty ]
+ [ [ CHAR: 0 = ] trim-tail [ "" ] when-empty ] bi*
+ [ append string>number ] [ nip length neg ] 2bi <decimal> ;
+
+: parse-decimal ( -- decimal ) scan string>decimal ;
+
+SYNTAX: D: parse-decimal parsed ;
+
+: decimal>ratio ( decimal -- ratio ) >decimal< 10^ * ;
+: decimal>float ( decimal -- ratio ) decimal>ratio >float ;
+
+: scale-mantissas ( D1 D2 -- m1 m2 exp )
+ [ [ mantissa>> ] bi@ ]
+ [
+ [ exponent>> ] bi@
+ [
+ - dup 0 <
+ [ neg 10^ * t ]
+ [ 10^ [ * ] curry dip f ] if
+ ] [ ? ] 2bi
+ ] 2bi ;
+
+: scale-decimals ( D1 D2 -- D1' D2' )
+ [ drop ]
+ [ scale-mantissas <decimal> nip ] 2bi ;
+
+ERROR: decimal-types-expected d1 d2 ;
+
+: guard-decimals ( obj1 obj2 -- D1 D2 )
+ 2dup [ decimal? ] both?
+ [ decimal-types-expected ] unless ;
+
+M: decimal equal?
+ {
+ [ [ decimal? ] both? ]
+ [
+ scale-decimals
+ {
+ [ [ mantissa>> ] bi@ = ]
+ [ [ exponent>> ] bi@ = ]
+ } 2&&
+ ]
+ } 2&& ;
+
+M: decimal before?
+ guard-decimals scale-decimals
+ [ mantissa>> ] bi@ < ;
+
+: D-abs ( D -- D' )
+ [ mantissa>> abs ] [ exponent>> ] bi <decimal> ;
+
+: D+ ( D1 D2 -- D3 )
+ guard-decimals scale-mantissas [ + ] dip <decimal> ;
+
+: D- ( D1 D2 -- D3 )
+ guard-decimals scale-mantissas [ - ] dip <decimal> ;
+
+: D* ( D1 D2 -- D3 )
+ guard-decimals [ >decimal< ] bi@ swapd + [ * ] dip <decimal> ;
+
+:: D/ ( D1 D2 a -- D3 )
+ D1 D2 guard-decimals 2drop
+ D1 >decimal< :> e1 :> m1
+ D2 >decimal< :> e2 :> m2
+ m1 a 10^ *
+ m2 /i
+
+ e1
+ e2 a + - <decimal> ;
! (c)2009 Joe Groff bsd license
USING: alien alien.syntax byte-arrays classes gpu.buffers
gpu.framebuffers gpu.shaders gpu.textures help.markup
-help.syntax images kernel math multiline sequences
+help.syntax images kernel math sequences
specialized-arrays strings ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: int
{ $description "Constructs a " { $link multi-index-range } " tuple." } ;
HELP: UNIFORM-TUPLE:
-{ $syntax <" UNIFORM-TUPLE: class-name
+{ $syntax """UNIFORM-TUPLE: class-name
{ "slot" uniform-type dimension }
{ "slot" uniform-type dimension }
...
- { "slot" uniform-type dimension } ; "> }
+ { "slot" uniform-type dimension } ;""" }
{ $description "Defines a new " { $link uniform-tuple } " class. Tuples of the new class can be used as the " { $snippet "uniforms" } " slot of a " { $link render-set } " in order to set the uniform parameters of the active shader program. The " { $link uniform-type } " of each slot defines the component type, and the " { $snippet "dimension" } " specifies an array length if not " { $link f } "."
$nl
"Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:"
{ $description "Defines a new " { $link shader } " of kind " { $link shader-kind } " named " { $snippet "shader-name" } ". The shader will read its source code from " { $snippet "filename" } " in the current Factor source file's directory." } ;
HELP: GLSL-SHADER:
-{ $syntax <" GLSL-SHADER-FILE: shader-name shader-kind
+{ $syntax """GLSL-SHADER-FILE: shader-name shader-kind
shader source
-; "> }
+;""" }
{ $description "Defines a new " { $link shader } " of kind " { $link shader-kind } " named " { $snippet "shader-name" } ". The shader will read its source code from the current Factor source file between the " { $snippet "GLSL-SHADER:" } " line and the first subsequent line with a single semicolon on it." } ;
HELP: VERTEX-FORMAT:
-{ $syntax <" VERTEX-FORMAT: format-name
+{ $syntax """VERTEX-FORMAT: format-name
{ "attribute"/f component-type dimension normalize? }
{ "attribute"/f component-type dimension normalize? }
...
- { "attribute"/f component-type dimension normalize? } ; "> }
+ { "attribute"/f component-type dimension normalize? } ;""" }
{ $description "Defines a new binary " { $link vertex-format } " for structuring vertex data stored in " { $link buffer } "s. Each " { $snippet "attribute" } " name either corresponds to an input parameter of a vertex shader, or is " { $link f } " to include padding in the vertex format. The " { $link component-type } " determines the format of the components, and the " { $snippet "dimension" } " determines the number of components. If the " { $snippet "component-type" } " is an integer type and " { $snippet "normalize?" } " is true, the component values will be scaled to the range 0.0 to 1.0 when fed to the vertex shader; otherwise, they will be cast to floats retaining their integral values." } ;
HELP: VERTEX-STRUCT:
-{ $syntax <" VERTEX-STRUCT: struct-name format-name "> }
+{ $syntax """VERTEX-STRUCT: struct-name format-name""" }
{ $description "Defines a struct class (like " { $link POSTPONE: STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
{ POSTPONE: GLSL-PROGRAM: POSTPONE: GLSL-SHADER-FILE: POSTPONE: GLSL-SHADER: } related-words
USING: multiline gpu.shaders gpu.shaders.private tools.test ;
IN: gpu.shaders.tests
-[ <" ERROR: foo.factor:20: Bad command or filename
+[ """ERROR: foo.factor:20: Bad command or filename
INFO: foo.factor:30: The operation completed successfully
-NOT:A:LOG:LINE "> ]
+NOT:A:LOG:LINE""" ]
[ T{ shader { filename "foo.factor" } { line 19 } }
-<" ERROR: 0:1: Bad command or filename
+"""ERROR: 0:1: Bad command or filename
INFO: 0:11: The operation completed successfully
-NOT:A:LOG:LINE "> replace-log-line-numbers ] unit-test
+NOT:A:LOG:LINE""" replace-log-line-numbers ] unit-test
! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax kernel math math.rectangles multiline sequences ;
+USING: help.markup help.syntax kernel math math.rectangles
+sequences ;
IN: gpu.state
HELP: <blend-mode>
{ { $link func-one-minus-constant-alpha } " returns one minus the alpha component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
}
"A typical transparency effect will use the values:"
-{ $code <" T{ blend-mode
+{ $code """T{ blend-mode
{ equation eq-add }
{ source-function func-source-alpha }
{ dest-function func-one-minus-source-alpha }
-} "> }
+}""" }
} } ;
HELP: blend-state
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slides help.markup math math.private kernel sequences
+slots.private ;
+IN: jvm-summit-talk
+
+CONSTANT: jvm-summit-slides
+{
+ { $slide "Factor language implementation"
+ "Goals: expressiveness, metaprogramming, performance"
+ "We want a language for anything from scripting DSLs to high-performance numerics"
+ "I assume you know a bit about compiler implementation: parser -> frontend -> optimizer -> codegen"
+ { "This is " { $strong "not" } " a talk about the Factor language" }
+ { "Go to " { $url "http://factorcode.org" } " to learn the language" }
+ }
+ { $slide "Why are dynamic languages slow?"
+ "Branching and indirection!"
+ "Runtime type checks and dispatch"
+ "Integer overflow checks"
+ "Boxed integers and floats"
+ "Lots of allocation of temporary objects"
+ }
+ { $slide "Interactive development"
+ "Code can be reloaded at any time"
+ "Class hierarchy might change"
+ "Slots may be added and removed"
+ "Functions might be redefined"
+ }
+ { $slide "Factor's solution"
+ "Factor implements most of the library in Factor"
+ "Library contains very generic, high-level code"
+ "Always compiles to native code"
+ "Compiler removes unused generality from high-level code"
+ "Inlining, specialization, partial evaluation"
+ "And deoptimize when assumptions change"
+ }
+ { $slide "Introduction: SSA form"
+ "Every identifier only has one global definition"
+ {
+ "Not SSA:"
+ { $code
+ "x = 1"
+ "y = 2"
+ "x = x + y"
+ "if(z < 0)"
+ " t = x + y"
+ "else"
+ " t = x - y"
+ "print(t)"
+ }
+ }
+ }
+ { $slide "Introduction: SSA form"
+ "Rename re-definitions and subsequent usages"
+ {
+ "Still not SSA:"
+ { $code
+ "x = 1"
+ "y = 2"
+ "x1 = x + y"
+ "if(z < 0)"
+ " t = x1 + y"
+ "else"
+ " t = x1 - y"
+ "print(t)"
+ }
+ }
+ }
+ { $slide "Introduction: SSA form"
+ "Introduce “φ functions” at control-flow merge points"
+ {
+ "This is SSA:"
+ { $code
+ "x = 1"
+ "y = 2"
+ "x1 = x + y"
+ "if(z < 0)"
+ " t1 = x1 + y"
+ "else"
+ " t2 = x1 - y"
+ "t3 = φ(t1,t2)"
+ "print(t3)"
+ }
+ }
+ }
+ { $slide "Why SSA form?"
+ {
+ "Def-use chains:"
+ { $list
+ "Defs-of: instructions that define a value"
+ "Uses-of: instructions that use a value"
+ }
+ "With SSA, defs-of has exactly one element"
+ }
+ }
+ { $slide "Def-use chains"
+ "Simpler def-use makes analysis more accurate."
+ {
+ "Non-SSA example:"
+ { $code
+ "if(x < 0)"
+ " s = new Circle"
+ " a = area(s1)"
+ "else"
+ " s = new Rectangle"
+ " a = area(s2)"
+ }
+ }
+ }
+ { $slide "Def-use chains"
+ {
+ "SSA example:"
+ { $code
+ "if(x < 0)"
+ " s1 = new Circle"
+ " a1 = area(s1)"
+ "else"
+ " s2 = new Rectangle"
+ " a2 = area(s2)"
+ "a = φ(a1,a2)"
+ }
+
+ }
+ }
+ { $slide "Factor compiler overview"
+ "High-level SSA IR constructed from stack code"
+ "High level optimizer transforms high-level IR"
+ "Low-level SSA IR is constructed from high-level IR"
+ "Low level optimizer transforms low-level IR"
+ "Register allocator runs on low-level IR"
+ "Machine IR is constructed from low-level IR"
+ "Code generation"
+ }
+ { $slide "High-level optimizer"
+ "Frontend: expands macros, inline higher order functions"
+ "Propagation: inline methods, constant folding"
+ "Escape analysis: unbox tuples"
+ "Dead code elimination: clean up"
+ }
+ { $slide "Higher-order functions"
+ "Almost all control flow is done with higher-order functions"
+ { { $link if } ", " { $link times } ", " { $link each } }
+ "Calling a block is an indirect jump"
+ "Solution: inline higher order functions at the call site"
+ "Inline the block body at the higher order call site in the function"
+ "Record inlining in deoptimization database"
+ }
+ { $slide "Generic functions"
+ "A generic function contains multiple method bodies"
+ "Dispatches on the class of argument(s)"
+ "In Factor, generic functions are single dispatch"
+ "Almost equivalent to message passing"
+ }
+ { $slide "Tuple slot access"
+ "Slot readers and writers are generic functions"
+ "Generated automatically when you define a tuple class"
+ { "The generated methods call " { $link slot } ", " { $link set-slot } " primitives" }
+ "These primitives are not type safe; the generic dispatch performs the type checking for us"
+ "If class of dispatch value known statically, inline method"
+ "This may result in more methods inlining from additional specialization"
+ }
+ { $slide "Generic arithmetic"
+ { { $link + } ", " { $link * } ", etc perform a double dispatch on arguments" }
+ { "Fixed-precision integers (" { $link fixnum } "s) upgrade to " { $link bignum } "s automatically" }
+ "Floats and complex numbers are boxed, heap-allocated"
+ "Propagation of classes helps for floats"
+ "But not for fixnums, because of overflow checks"
+ "So we also propagate integer intervals"
+ "Interval arithmetic: etc, [a,b] + [c,d] = [a+c,b+d]"
+ }
+ { $slide "Slot value propagation"
+ "Complex numbers are even trickier"
+ "We can have a complex number with integer components, float components"
+ "Even if we inline complex arithmetic methods, still dispatching on components"
+ "Solution: propagate slot info"
+ }
+ { $slide "Constrant propagation"
+ "Contrieved example:"
+ { $code
+ "x = •"
+ "b = isa(x,array)"
+ "if(b)"
+ " a = length(x)"
+ "else"
+ " b = length(x)"
+ "c = φ(a,b)"
+ }
+ { "We should be able to inline the call to " { $snippet "length" } " in the true branch" }
+ }
+ { $slide "Constrant propagation"
+ "We build a table:"
+ { $code
+ "b true => x is array"
+ "b false => x is ~array"
+ }
+ { "In true branch, apply all " { $snippet "b true" } " constraints" }
+ { "In false branch, apply all " { $snippet "b false" } " constraints" }
+ }
+ { $slide "Going further"
+ "High-level optimizer eliminates some dispatch overhead and allocation"
+ {
+ { "Let's take a look at the " { $link float+ } " primitive" }
+ { $list
+ "No type checking anymore... but"
+ "Loads two tagged pointers from operand stack"
+ "Unboxes floats"
+ "Adds two floats"
+ "Boxes float result and perform a GC check"
+ }
+ }
+ }
+ { $slide "Low-level optimizer"
+ "Frontend: construct LL SSA IR from HL SSA IR"
+ "Alias analysis: remove redundant slot loads/stores"
+ "Value numbering: simplify arithmetic"
+ "Representation selection: eliminate boxing"
+ "Dead code elimination: clean up"
+ "Register allocation"
+ }
+ { $slide "Constructing low-level IR"
+ { "Low-level IR is a " { $emphasis "control flow graph" } " of " { $emphasis "basic blocks" } }
+ "A basic block is a list of instructions"
+ "Register-based IR; infinite, uniform register file"
+ { "Instructions:"
+ { $list
+ "Subroutine calls"
+ "Machine arithmetic"
+ "Load/store values on operand stack"
+ "Box/unbox values"
+ }
+ }
+ }
+ { $slide "Inline allocation and GC checks"
+ {
+ "Allocation of small objects can be done in a few instructions:"
+ { $list
+ "Bump allocation pointer"
+ "Write object header"
+ "Fill in payload"
+ }
+ }
+ "Multiple allocations in the same basic block only need a single GC check; saves on a conditional branch"
+ }
+ { $slide "Alias analysis"
+ "Factor constructors are just ordinary functions"
+ { "They call a primitive constructor: " { $link new } }
+ "When a new object is constructed, it has to be initialized"
+ "... but the user's constructor probably fills in all the slots again with actual values"
+ "Local alias analysis eliminates redundant slot loads and stores"
+ }
+ { $slide "Value numbering"
+ { "A form of " { $emphasis "redundancy elimination" } }
+ "Requires use of SSA form in order to work"
+ "Define an equivalence relation over SSA values"
+ "Assign a “value number” to each SSA value"
+ "If two values have the same number, they will always be equal at runtime"
+ }
+ { $slide "Types of value numbering"
+ "Many variations: algebraic simplifications, various rewrite rules can be tacked on"
+ "Local value numbering: in basic blocks"
+ "Global value numbering: entire procedure"
+ "Factor only does local value numbering"
+ }
+ { $slide "Value graph and expressions"
+ { $table
+ {
+ {
+ "Basic block:"
+ { $code
+ "x = •"
+ "y = •"
+ "a = x + 1"
+ "b = a + 1"
+ "c = x + 2"
+ "d = b - c"
+ "e = y + d"
+ }
+ }
+ {
+ "Value numbers:"
+ { $code
+ "V1: •"
+ "V2: •"
+ "V3: 1"
+ "V4: 2"
+ "V5: (V1 + V3)"
+ "V6: (V5 + V3)"
+ "V7: (V3 + V4)"
+ "V8: (V6 - V7)"
+ "V9: (V2 + V8)"
+ }
+ }
+ }
+ }
+ }
+ { $slide "Expression simplification"
+ {
+ "Constant folding: if V1 and V2 are constants "
+ { $snippet "(V1 op V2)" }
+ " can be evaluated at compile-time"
+ }
+ {
+ "Reassociation: if V2 and V3 are constants "
+ { $code "((V1 op V2) op V3) => (V1 op (V2 op V3))" }
+ }
+ {
+ "Algebraic identities: if V2 is constant 0, "
+ { $code "(V1 + V2) => V1" }
+ }
+ {
+ "Strength reduction: if V2 is a constant power of two, "
+ { $code "(V1 * V2) => (V1 << log2(V2))" }
+ }
+ "etc, etc, etc"
+ }
+ { $slide "Representation selection overview"
+ "Floats and SIMD vectors need to be boxed"
+ "Representation: tagged pointer, unboxed float, unboxed SIMD value..."
+ "When IR is built, no boxing or unboxing instructions inserted"
+ "Representation selection pass makes IR consistent"
+ }
+ { $slide "Representation selection algorithm"
+ {
+ "For each SSA value:"
+ { $list
+ "Compute possible representations"
+ "Compute cost of each representation"
+ "Pick representation with minimum cost"
+ }
+ }
+ {
+ "For each instruction:"
+ { $list
+ "If it expects a value to be in a different representation, insert box or unbox code"
+ }
+ }
+ }
+ { $slide "Register allocation"
+ "Linear scan algorithm used in Java HotSpot Client"
+ "Described in Christian Wimmer's masters thesis"
+ "Works fine on x86-64, not too great on x86-32"
+ "Good enough since basic blocks tend to be short, with lots of procedure calls"
+ "Might switch to graph coloring eventually"
+ }
+ { $slide "Compiler tools"
+ "Printing high level IR"
+ "Printing low level IR"
+ "Disassembly"
+ "Display call tree"
+ "Display control flow graph"
+ "Display dominator tree"
+ }
+}
+
+: jvm-summit-talk ( -- )
+ jvm-summit-slides slides-window ;
+
+MAIN: jvm-summit-talk
--- /dev/null
+Slides from Slava's talk at JVM Language Summit 2009
destructors fry io io.encodings.utf8 kernel managed-server
namespaces parser sequences sorting splitting strings.parser
unicode.case unicode.categories calendar calendar.format
-locals multiline io.encodings.binary io.encodings.string
-prettyprint ;
+locals io.encodings.binary io.encodings.string prettyprint ;
IN: managed-server.chat
TUPLE: chat-server < managed-server ;
docs key chat-docs get set-at ;
[ handle-help ]
-<" Syntax: /help [command]
-Displays the documentation for a command.">
+"""Syntax: /help [command]
+Displays the documentation for a command."""
"help" add-command
[ drop clients keys [ "``" "''" surround ] map ", " join send-line ]
-<" Syntax: /who
-Shows the list of connected users.">
+"""Syntax: /who
+Shows the list of connected users."""
"who" add-command
[ drop gmt timestamp>rfc822 send-line ]
-<" Syntax: /time
-Returns the current GMT time."> "time" add-command
+"""Syntax: /time
+Returns the current GMT time.""" "time" add-command
[ handle-nick ]
-<" Syntax: /nick nickname
-Changes your nickname.">
+"""Syntax: /nick nickname
+Changes your nickname."""
"nick" add-command
[ handle-me ]
-<" Syntax: /me action">
+"""Syntax: /me action"""
"me" add-command
[ handle-quit ]
-<" Syntax: /quit [message]
-Disconnects a user from the chat server."> "quit" add-command
+"""Syntax: /quit [message]
+Disconnects a user from the chat server.""" "quit" add-command
: handle-command ( string -- )
dup " " split1 swap >lower commands get at* [
] with-scope
] unit-test
-[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" "-sse-version=30" } ] [
+[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [
[
"winnt" target-os set
"x86.32" target-cpu set
factor-vm ,
"-i=" boot-image-name append ,
"-no-user-init" ,
- target-cpu get { "x86.32" "x86.64" } member? [ "-sse-version=30" , ] when
] { } make ;
: boot ( -- )
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors eval kernel lexer nested-comments tools.test ;
+IN: nested-comments.tests
+
+! Correct
+[ ] [
+ "USE: nested-comments (* comment *)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment*)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment
+*)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment
+*)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment
+*)" eval( -- )
+] unit-test
+
+[ ] [
+ "USE: nested-comments (* comment
+ (* *)
+
+*)" eval( -- )
+] unit-test
+
+! Malformed
+[
+ "USE: nested-comments (* comment
+ (* *)" eval( -- )
+] [
+ error>> T{ unexpected f "*)" f } =
+] must-fail-with
-! by blei on #concatenative\r
+! Copyright (C) 2009 blei, Doug Coleman.\r
+! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel sequences math locals make multiline ;\r
IN: nested-comments\r
\r
-:: (subsequences-at) ( sseq seq n -- )\r
- sseq seq n start*\r
- [ dup , sseq length + [ sseq seq ] dip (subsequences-at) ]\r
- when* ;\r
+: (count-subsequences) ( count substring string n -- count' )\r
+ [ 2dup ] dip start* [\r
+ pick length +\r
+ [ 1 + ] 3dip (count-subsequences)\r
+ ] [\r
+ 2drop\r
+ ] if* ;\r
\r
-: subsequences-at ( sseq seq -- indices )\r
- [ 0 (subsequences-at) ] { } make ;\r
+: count-subsequences ( subseq seq -- n )\r
+ [ 0 ] 2dip 0 (count-subsequences) ;\r
\r
-: count-subsequences ( sseq seq -- i )\r
- subsequences-at length ;\r
+: parse-nestable-comment ( parsed-vector left-to-parse -- parsed-vector )\r
+ 1 - "*)" parse-multiline-string\r
+ [ "(*" ] dip\r
+ count-subsequences + dup 0 > [ parse-nestable-comment ] [ drop ] if ;\r
\r
-: parse-all-(* ( parsed-vector left-to-parse -- parsed-vector )\r
- 1 - "*)" parse-multiline-string [ "(*" ] dip\r
- count-subsequences + dup 0 > [ parse-all-(* ] [ drop ] if ;\r
-\r
-SYNTAX: (* 1 parse-all-(* ;
\ No newline at end of file
+SYNTAX: (* 1 parse-nestable-comment ;\r
{ $slide "Locals example"
"Area of a triangle using Heron's formula"
{ $code
- <" :: area ( a b c -- x )
+ """:: area ( a b c -- x )
a b c + + 2 / :> p
p
p a - *
p b - *
- p c - * sqrt ;">
+ p c - * sqrt ;"""
}
}
{ $slide "Previous example without locals"
"A bit unwieldy..."
{ $code
- <" : area ( a b c -- x )
+ """: area ( a b c -- x )
[ ] [ + + 2 / ] 3bi
[ '[ _ - ] tri@ ] [ neg ] bi
- * * * sqrt ;"> }
+ * * * sqrt ;""" }
}
{ $slide "More idiomatic version"
"But there's a trick: put the points in an array"
- { $code <" : v-n ( v n -- w ) '[ _ - ] map ;
+ { $code """: v-n ( v n -- w ) '[ _ - ] map ;
: area ( points -- x )
[ 0 suffix ] [ sum 2 / ] bi
- v-n product sqrt ;"> }
+ v-n product sqrt ;""" }
}
! { $slide "The parser"
! "All data types have a literal syntax"
}
{ $slide "This is hard with mainstream syntax!"
{ $code
- <" var customer = ...;
+ """var customer = ...;
var orders = (customer == null ? null : customer.orders);
var order = (orders == null ? null : orders[0]);
-var price = (order == null ? null : order.price);"> }
+var price = (order == null ? null : order.price);""" }
}
{ $slide "An ad-hoc solution"
"Something like..."
}
{ $slide "UI example"
{ $code
{ 5 5 } >>gap
1 >>fill
"Hello world!" <label> add-gadget
"Click me!" [ drop beep ]
<bevel-button> add-gadget
<editor> <scroller> add-gadget
-"UI test" open-window "> }
+"UI test" open-window""" }
}
{ $slide "Help system"
"Help markup is just literal data"
{ $syntax "a => b" }
{ $description "Constructs a two-element array from the objects immediately before and after the " { $snippet "=>" } ". This syntax can be used inside sequence and assoc literals." }
{ $examples
-{ $unchecked-example <" USING: pair-rocket prettyprint ;
+{ $unchecked-example """USING: pair-rocket prettyprint ;
-H{ "foo" => 1 "bar" => 2 } .
-"> <" H{ { "foo" 1 } { "bar" 2 } } "> }
+H{ "foo" => 1 "bar" => 2 } ."""
+"""H{ { "foo" 1 } { "bar" 2 } }""" }
}
;
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.javascript.ast peg.javascript.parser
- accessors multiline sequences math peg.ebnf ;
+ accessors sequences math peg.ebnf ;
IN: peg.javascript.parser.tests
{
] unit-test
{ t } [
-<"
+"""
var x=5
var y=10
-"> main \ javascript rule (parse) remaining>> length zero?
+""" main \ javascript rule (parse) remaining>> length zero?
] unit-test
{ t } [
-<"
+"""
function foldl(f, initial, seq) {
for(var i=0; i< seq.length; ++i)
initial = f(initial, seq[i]);
return initial;
-}"> main \ javascript rule (parse) remaining>> length zero?
+}""" main \ javascript rule (parse) remaining>> length zero?
] unit-test
{ t } [
-<"
+"""
ParseState.prototype.from = function(index) {
var r = new ParseState(this.input, this.index + index);
r.cache = this.cache;
r.length = this.length - index;
return r;
-}"> main \ javascript rule (parse) remaining>> length zero?
+}""" main \ javascript rule (parse) remaining>> length zero?
] unit-test
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf peg.pl0
- multiline sequences accessors ;
+ sequences accessors ;
IN: peg.pl0.tests
{ t } [
] unit-test
{ t } [
- <"
-VAR x, squ;
+"""VAR x, squ;
PROCEDURE square;
BEGIN
CALL square;
x := x + 1;
END
-END."> main \ pl0 rule (parse) remaining>> empty?
+END.""" main \ pl0 rule (parse) remaining>> empty?
] unit-test
{ f } [
- <"
+"""
CONST
m = 7,
n = 85;
y := 36;
CALL gcd;
END.
- "> main \ pl0 rule (parse) remaining>> empty?
-] unit-test
\ No newline at end of file
+""" main \ pl0 rule (parse) remaining>> empty?
+] unit-test
--- /dev/null
+USING: project-euler.072 tools.test ;
+IN: project-euler.072.tests
+
+[ 303963552391 ] [ euler072 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Guillaume Nargeot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.primes.factors math.ranges
+project-euler.common sequences ;
+IN: project-euler.072
+
+! http://projecteuler.net/index.php?section=problems&id=072
+
+! DESCRIPTION
+! -----------
+
+! Consider the fraction, n/d, where n and d are positive integers.
+! If n<d and HCF(n,d)=1, it is called a reduced proper fraction.
+
+! If we list the set of reduced proper fractions for d ≤ 8 in ascending order
+! of size, we get:
+
+! 1/8, 1/7, 1/6, 1/5, 1/4, 2/7, 1/3, 3/8, 2/5, 3/7, 1/2, 4/7, 3/5, 5/8, 2/3,
+! 5/7, 3/4, 4/5, 5/6, 6/7, 7/8
+
+! It can be seen that there are 21 elements in this set.
+
+! How many elements would be contained in the set of reduced proper fractions
+! for d ≤ 1,000,000?
+
+
+! SOLUTION
+! --------
+
+! The answer can be found by adding totient(n) for 2 ≤ n ≤ 1e6
+
+: euler072 ( -- answer )
+ 2 1000000 [a,b] [ totient ] [ + ] map-reduce ;
+
+! [ euler072 ] 100 ave-time
+! 5274 ms ave run time - 102.7 SD (100 trials)
+
+SOLUTION: euler072
--- /dev/null
+USING: project-euler.074 tools.test ;
+IN: project-euler.074.tests
+
+[ 402 ] [ euler074 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Guillaume Nargeot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs hashtables kernel math math.ranges
+project-euler.common sequences sets ;
+IN: project-euler.074
+
+! http://projecteuler.net/index.php?section=problems&id=074
+
+! DESCRIPTION
+! -----------
+
+! The number 145 is well known for the property that the sum of the factorial
+! of its digits is equal to 145:
+
+! 1! + 4! + 5! = 1 + 24 + 120 = 145
+
+! Perhaps less well known is 169, in that it produces the longest chain of
+! numbers that link back to 169; it turns out that there are only three such
+! loops that exist:
+
+! 169 → 363601 → 1454 → 169
+! 871 → 45361 → 871
+! 872 → 45362 → 872
+
+! It is not difficult to prove that EVERY starting number will eventually get
+! stuck in a loop. For example,
+
+! 69 → 363600 → 1454 → 169 → 363601 (→ 1454)
+! 78 → 45360 → 871 → 45361 (→ 871)
+! 540 → 145 (→ 145)
+
+! Starting with 69 produces a chain of five non-repeating terms, but the
+! longest non-repeating chain with a starting number below one million is sixty
+! terms.
+
+! How many chains, with a starting number below one million, contain exactly
+! sixty non-repeating terms?
+
+
+! SOLUTION
+! --------
+
+! Brute force
+
+<PRIVATE
+
+: digit-factorial ( n -- n! )
+ { 1 1 2 6 24 120 720 5040 40320 362880 } nth ;
+
+: digits-factorial-sum ( n -- n )
+ number>digits [ digit-factorial ] sigma ;
+
+: chain-length ( n -- n )
+ 61 <hashtable>
+ [ 2dup key? not ]
+ [ [ conjoin ] [ [ digits-factorial-sum ] dip ] 2bi ]
+ while nip assoc-size ;
+
+PRIVATE>
+
+: euler074 ( -- answer )
+ 1000000 [1,b] [ chain-length 60 = ] count ;
+
+! [ euler074 ] 10 ave-time
+! 25134 ms ave run time - 31.96 SD (10 trials)
+
+SOLUTION: euler074
+
! SOLUTION
! --------
-! A grid measuring x by y contains x * (x + 1) * y * (x + 1) rectangles.
+! A grid measuring x by y contains x * (x + 1) * y * (x + 1) / 4 rectangles.
<PRIVATE
area-of-nearest ;
! [ euler085 ] 100 ave-time
-! 2285 ms ave run time - 4.8 SD (100 trials)
+! 791 ms ave run time - 17.15 SD (100 trials)
SOLUTION: euler085
--- /dev/null
+USING: project-euler.124 tools.test ;
+IN: project-euler.124.tests
+
+[ 21417 ] [ euler124 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Guillaume Nargeot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math.primes.factors
+math.ranges project-euler.common sequences sorting ;
+IN: project-euler.124
+
+! http://projecteuler.net/index.php?section=problems&id=124
+
+! DESCRIPTION
+! -----------
+
+! The radical of n, rad(n), is the product of distinct prime factors of n.
+! For example, 504 = 2^3 × 3^2 × 7, so rad(504) = 2 × 3 × 7 = 42.
+
+! If we calculate rad(n) for 1 ≤ n ≤ 10, then sort them on rad(n),
+! and sorting on n if the radical values are equal, we get:
+
+! Unsorted Sorted
+! n rad(n) n rad(n) k
+! 1 1 1 1 1
+! 2 2 2 2 2
+! 3 3 4 2 3
+! 4 2 8 2 4
+! 5 5 3 3 5
+! 6 6 9 3 6
+! 7 7 5 5 7
+! 8 2 6 6 8
+! 9 3 7 7 9
+! 10 10 10 10 10
+
+! Let E(k) be the kth element in the sorted n column; for example,
+! E(4) = 8 and E(6) = 9.
+
+! If rad(n) is sorted for 1 ≤ n ≤ 100000, find E(10000).
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: rad ( n -- n )
+ unique-factors product ; inline
+
+: rads-upto ( n -- seq )
+ [0,b] [ dup rad 2array ] map ;
+
+: (euler124) ( -- seq )
+ 100000 rads-upto sort-values ;
+
+PRIVATE>
+
+: euler124 ( -- answer )
+ 10000 (euler124) nth first ;
+
+! [ euler124 ] 100 ave-time
+! 373 ms ave run time - 17.61 SD (100 trials)
+
+! TODO: instead of the brute-force method, making the rad
+! array in the way of the sieve of eratosthene would scale
+! better on bigger values.
+
+SOLUTION: euler124
project-euler.049 project-euler.052 project-euler.053 project-euler.054
project-euler.055 project-euler.056 project-euler.057 project-euler.058
project-euler.059 project-euler.063 project-euler.067 project-euler.069
- project-euler.071 project-euler.073 project-euler.075 project-euler.076
- project-euler.079 project-euler.085 project-euler.092 project-euler.097
- project-euler.099 project-euler.100 project-euler.102 project-euler.112
- project-euler.116 project-euler.117 project-euler.134 project-euler.148
- project-euler.150 project-euler.151 project-euler.164 project-euler.169
- project-euler.173 project-euler.175 project-euler.186 project-euler.190
- project-euler.203 project-euler.215 ;
+ project-euler.071 project-euler.072 project-euler.073 project-euler.074
+ project-euler.075 project-euler.076 project-euler.079 project-euler.085
+ project-euler.092 project-euler.097 project-euler.099 project-euler.100
+ project-euler.102 project-euler.112 project-euler.116 project-euler.117
+ project-euler.124 project-euler.134 project-euler.148 project-euler.150
+ project-euler.151 project-euler.164 project-euler.169 project-euler.173
+ project-euler.175 project-euler.186 project-euler.190 project-euler.203
+ project-euler.215 ;
IN: project-euler
<PRIVATE
{ $syntax "qw{ lorem ipsum }" }
{ $description "Marks the beginning of a literal array of strings. Component strings are delimited by whitespace." }
{ $examples
-{ $unchecked-example <" USING: prettyprint qw ;
-qw{ pop quiz my hive of big wild ex tranny jocks } . ">
-<" { "pop" "quiz" "my" "hive" "of" "big" "wild" "ex" "tranny" "jocks" } "> }
+{ $unchecked-example """USING: prettyprint qw ;
+qw{ pop quiz my hive of big wild ex tranny jocks } ."""
+"""{ "pop" "quiz" "my" "hive" "of" "big" "wild" "ex" "tranny" "jocks" }""" }
} ;
+
+ARTICLE: "qw" "Quoted words"
+"The " { $vocab-link "qw" } " vocabulary offers a shorthand syntax for arrays-of-strings literals." $nl
+"Construct an array of strings:"
+{ $subsection POSTPONE: qw{ } ;
+
+ABOUT: "qw"
IN: roles
HELP: ROLE:
-{ $syntax <" ROLE: name slots... ;
+{ $syntax """ROLE: name slots... ;
ROLE: name < role slots... ;
-ROLE: name <{ roles... } slots... ; "> }
+ROLE: name <{ roles... } slots... ;""" }
{ $description "Defines a new " { $link role } ". " { $link tuple } " classes which inherit this role will contain the specified " { $snippet "slots" } " as well as the slots associated with the optional inherited " { $snippet "roles" } "."
$nl
"Slot specifiers take one of the following three forms:"
"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ;
HELP: TUPLE:
-{ $syntax <" TUPLE: name slots ;
+{ $syntax """TUPLE: name slots ;
TUPLE: name < estate slots ;
-TUPLE: name <{ estates... } slots... ; "> }
+TUPLE: name <{ estates... } slots... ;""" }
{ $description "Defines a new " { $link tuple } " class."
$nl
"The list of inherited " { $snippet "estates" } " is optional; a single tuple superclass and/or a set of " { $link role } "s can be specified. If no superclass is provided, it defaults to " { $link tuple } "."
--- /dev/null
+IN: rpn.tests
+USING: rpn lists tools.test ;
+
+[ { 2 } ] [ "4 2 -" rpn-parse rpn-eval list>array ] unit-test
\ No newline at end of file
GENERIC: eval-insn ( stack insn -- stack )
: binary-op ( stack quot: ( x y -- z ) -- stack )
- [ uncons uncons ] dip dip cons ; inline
+ [ uncons uncons [ swap ] dip ] dip dip cons ; inline
M: add-insn eval-insn drop [ + ] binary-op ;
M: sub-insn eval-insn drop [ - ] binary-op ;
: print-stack ( list -- )
[ number>string print ] leach ;
-: rpn-eval ( tokens -- )
- nil [ eval-insn ] foldl print-stack ;
+: rpn-eval ( tokens -- stack )
+ nil [ eval-insn ] foldl ;
: rpn ( -- )
"RPN> " write flush
- readln [ rpn-parse rpn-eval rpn ] when* ;
+ readln [ rpn-parse rpn-eval print-stack rpn ] when* ;
MAIN: rpn
! (c)2008 Joe Groff, see BSD license etc.
-USING: help.markup help.syntax kernel math multiline sequences ;
+USING: help.markup help.syntax kernel math sequences ;
IN: sequences.n-based
HELP: <n-based-assoc>
{ $values { "seq" sequence } { "base" integer } { "n-based-assoc" n-based-assoc } }
{ $description "Wraps " { $snippet "seq" } " in an " { $link n-based-assoc } " wrapper." }
{ $examples
-{ $example <"
+{ $example """
USING: assocs prettyprint kernel sequences.n-based ;
IN: scratchpad
} 1 <n-based-assoc> ;
10 months at .
-"> "\"October\"" } } ;
+""" "\"October\"" } } ;
HELP: n-based-assoc
{ $class-description "An adaptor class that allows a sequence to be treated as an assoc with non-zero-based keys." }
{ $examples
-{ $example <"
+{ $example """
USING: assocs prettyprint kernel sequences.n-based ;
IN: scratchpad
} 1 <n-based-assoc> ;
10 months at .
-"> "\"October\"" } } ;
+""" "\"October\"" } } ;
{ n-based-assoc <n-based-assoc> } related-words
! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax multiline quotations sequences ;
+USING: help.markup help.syntax quotations sequences ;
IN: sequences.product
HELP: product-sequence
{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
{ $examples
-{ $example <" USING: arrays prettyprint sequences.product ;
+{ $example """USING: arrays prettyprint sequences.product ;
{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
-"> <" {
+""" """{
{ 1 "a" }
{ 2 "a" }
{ 3 "a" }
{ 1 "c" }
{ 2 "c" }
{ 3 "c" }
-}"> } } ;
+}""" } } ;
HELP: <product-sequence>
{ $values { "sequences" sequence } { "product-sequence" product-sequence } }
{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
{ $examples
-{ $example <" USING: arrays prettyprint sequences.product ;
-{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
-"> <" {
+{ $example """USING: arrays prettyprint sequences.product ;
+{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array ."""
+"""{
{ 1 "a" }
{ 2 "a" }
{ 3 "a" }
{ 1 "c" }
{ 2 "c" }
{ 3 "c" }
-}"> } } ;
+}""" } } ;
{ product-sequence <product-sequence> } related-words
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: smtp namespaces accessors kernel arrays ;
+USING: smtp namespaces accessors kernel arrays site-watcher.db ;
IN: site-watcher.email
SYMBOL: site-watcher-from
pick [
[ <email> site-watcher-from get >>from ] 3dip
[ 1array >>to ] [ >>body ] [ >>subject ] tri* send-email
- ] [ 3drop ] if ;
\ No newline at end of file
+ ] [ 3drop ] if ;
ARTICLE: "spider-tutorial" "Spider tutorial"
"To create a new spider, call the " { $link <spider> } " word with a link to the site you wish to spider."
-{ $code <" "http://concatenative.org" <spider> "> }
+{ $code """"http://concatenative.org" <spider>""" }
"The max-depth is initialized to 0, which retrieves just the initial page. Let's initialize it to something more fun:"
-{ $code <" 1 >>max-depth "> }
+{ $code """1 >>max-depth""" }
"Now the spider will retrieve the first page and all the pages it links to in the same domain." $nl
"But suppose the front page contains thousands of links. To avoid grabbing them all, we can set " { $slot "max-count" } " to a reasonable limit."
-{ $code <" 10 >>max-count "> }
+{ $code """10 >>max-count""" }
"A timeout might keep the spider from hitting the server too hard:"
-{ $code <" USE: calendar 1.5 seconds >>sleep "> }
+{ $code """USE: calendar 1.5 seconds >>sleep""" }
"Since we happen to know that not all pages of a wiki are suitable for spidering, we will spider only the wiki view pages, not the edit or revisions pages. To do this, we add a filter through which new links are tested; links that pass the filter are added to the todo queue, while links that do not are discarded. You can add several filters to the filter array, but we'll just add a single one for now."
-{ $code <" { [ path>> "/wiki/view" head? ] } >>filters "> }
+{ $code """{ [ path>> "/wiki/view" head? ] } >>filters""" }
"Finally, to start the spider, call the " { $link run-spider } " word."
{ $code "run-spider" }
"The full code from the tutorial."
-{ $code <" USING: spider calendar sequences accessors ;
+{ $code """USING: spider calendar sequences accessors ;
: spider-concatenative ( -- spider )
"http://concatenative.org" <spider>
1 >>max-depth
10 >>max-count
1.5 seconds >>sleep
{ [ path>> "/wiki/view" head? ] } >>filters
- run-spider ;"> } ;
+ run-spider ;""" } ;
ARTICLE: "spider" "Spider"
"The " { $vocab-link "spider" } " vocabulary implements a simple web spider for retrieving sets of webpages."
! (c)2009 Joe Groff, see BSD license
USING: accessors arrays literals math math.affine-transforms
-math.functions multiline sequences svg tools.test xml xml.traversal ;
+math.functions sequences svg tools.test xml xml.traversal multiline ;
IN: svg.tests
{ 1.0 2.25 } { -3.0 4.0 } { 5.5 0.5 } <affine-transform> 1array [
T{ elliptical-arc f { 5.0 6.0 } 7.0 t f { 8.0 9.0 } f }
} ] [
- <"
+ """
M 1.0,+1 3,-10e-1 l 2 2, 2 -2, 2 2 v -9 1 H 9 8 z
M 0 0 C -4.0 0.0 -8.0 4.0 -8.0 8.0 -8.0 4.0 -12.0 8.0 -16.0 8.0
s 0.0,2.0 2.0,0.0
Q -2 0 0 -2 -3. 0 0 3
t 1 2 3 4
A 5 6 7 1 0 8 9
- "> svg-path>array
+ """ svg-path>array
] unit-test
STRING: test-svg-string
{ $slide "First, some examples"
{ $code "3 weeks ago noon monday ." }
{ $code "USE: roman 2009 >roman ." }
- { $code <" : average ( seq -- x )
- [ sum ] [ length ] bi / ;"> }
+ { $code """: average ( seq -- x )
+ [ sum ] [ length ] bi / ;""" }
{ $code "1 miles [ km ] undo >float ." }
{ $code "[ readln eval>string print t ] loop" }
}
{ $slide "XML Literals"
{ $code
- <" USING: splitting xml.writer xml.syntax ;
+ """USING: splitting xml.writer xml.syntax ;
{ "one" "two" "three" }
[ [XML <item><-></item> XML] ] map
-<XML <doc><-></doc> XML> pprint-xml">
+<XML <doc><-></doc> XML> pprint-xml"""
}
}
{ $slide "Differences between Factor and Lisp"
}
{ $slide "Object system example: shape protocol"
"In ~/factor/work/shapes/shapes.factor"
- { $code <" IN: shapes
+ { $code """IN: shapes
GENERIC: area ( shape -- x )
-GENERIC: perimeter ( shape -- x )">
+GENERIC: perimeter ( shape -- x )"""
}
}
{ $slide "Implementing the shape protocol: circles"
"In ~/factor/work/shapes/circle/circle.factor"
- { $code <" USING: shapes constructors math
+ { $code """USING: shapes constructors math
math.constants ;
IN: shapes.circle
TUPLE: circle radius ;
CONSTRUCTOR: circle ( radius -- obj ) ;
M: circle area radius>> sq pi * ;
-M: circle perimeter radius>> pi * 2 * ;">
+M: circle perimeter radius>> pi * 2 * ;"""
}
}
{ $slide "Dynamic variables"
"Implemented as a stack of hashtables"
{ "Useful words are " { $link get } ", " { $link set } }
"Input, output, error streams are stored in dynamic variables"
- { $code <" "Today is the first day of the rest of your life."
+ { $code """"Today is the first day of the rest of your life."
[
readln print
-] with-string-reader">
+] with-string-reader"""
}
}
{ $slide "The global namespace"
"The global namespace is just the namespace at the bottom of the namespace stack"
{ "Useful words are " { $link get-global } ", " { $link set-global } }
"Factor idiom for changing a particular namespace"
- { $code <" SYMBOL: king
-global [ "Henry VIII" king set ] bind">
+ { $code """SYMBOL: king
+global [ "Henry VIII" king set ] bind"""
}
{ $code "with-scope" }
{ $code "namestack" }
}
{ $slide "Hooks"
"Dispatch on a dynamic variable"
- { $code <" HOOK: computer-name os ( -- string )
+ { $code """HOOK: computer-name os ( -- string )
M: macosx computer-name uname first ;
macosx \ os set-global
-computer-name">
+computer-name"""
}
}
{ $slide "Interpolate"
"Replaces variables in a string"
{ $code
-<" "Dawg" "name" set
+""""Dawg" "name" set
"rims" "noun" set
"bling" "verb1" set
"roll" "verb2" set
[
"Sup ${name}, we heard you liked ${noun}, so we put ${noun} on your car so you can ${verb1} while you ${verb2}."
interpolate
-] with-string-writer print ">
+] with-string-writer print """
}
}
{ $slide "Sequence protocol"
{ $slide "Specialized arrays code"
"One line per array/vector"
{ "In ~/factor/basis/specialized-arrays/float/float.factor"
- { $code <" << "float" define-array >>"> }
+ { $code """<< "float" define-array >>""" }
}
{ "In ~/factor/basis/specialized-vectors/float/float.factor"
- { $code <" << "float" define-vector >>"> }
+ { $code """<< "float" define-vector >>""" }
}
}
}
{ $slide "Functor for sorting"
{ $code
- <" FUNCTOR: define-sorting ( NAME QUOT -- )
+ """FUNCTOR: define-sorting ( NAME QUOT -- )
NAME<=> DEFINES ${NAME}<=>
NAME>=< DEFINES ${NAME}>=<
: NAME>=< ( obj1 obj2 -- >=< )
NAME<=> invert-comparison ;
-;FUNCTOR">
+;FUNCTOR"""
}
}
{ $slide "Example of sorting functor"
- { $code <" USING: sorting.functor ;
-<< "length" [ length ] define-sorting >>">
+ { $code """USING: sorting.functor ;
+<< "length" [ length ] define-sorting >>"""
}
{ $code
- <" { { 1 2 3 } { 1 2 } { 1 } }
-[ length<=> ] sort">
+ """{ { 1 2 3 } { 1 2 } { 1 } }
+[ length<=> ] sort"""
}
}
{ $slide "Combinators"
}
{ $slide "Control flow: if"
{ $link if }
- { $code <" 10 random dup even? [ 2 / ] [ 1 - ] if"> }
+ { $code """10 random dup even? [ 2 / ] [ 1 - ] if""" }
{ $link when }
- { $code <" 10 random dup even? [ 2 / ] when"> }
+ { $code """10 random dup even? [ 2 / ] when""" }
{ $link unless }
- { $code <" 10 random dup even? [ 1 - ] unless"> }
+ { $code """10 random dup even? [ 1 - ] unless""" }
}
{ $slide "Control flow: case"
{ $link case }
- { $code <" ERROR: not-possible obj ;
+ { $code """ERROR: not-possible obj ;
10 random 5 <=> {
{ +lt+ [ "Less" ] }
{ +gt+ [ "More" ] }
{ +eq+ [ "Equal" ] }
[ not-possible ]
-} case">
+} case"""
}
}
{ $slide "Fry"
{ $slide "Locals example"
"Area of a triangle using Heron's formula"
{ $code
- <" :: area ( a b c -- x )
+ """:: area ( a b c -- x )
a b c + + 2 / :> p
p
p a - *
p b - *
- p c - * sqrt ;">
+ p c - * sqrt ;"""
}
}
{ $slide "Previous example without locals"
"A bit unwieldy..."
{ $code
- <" : area ( a b c -- x )
+ """: area ( a b c -- x )
[ ] [ + + 2 / ] 3bi
[ '[ _ - ] tri@ ] [ neg ] bi
- * * * sqrt ;"> }
+ * * * sqrt ;""" }
}
{ $slide "More idiomatic version"
"But there's a trick: put the lengths in an array"
- { $code <" : v-n ( v n -- w ) '[ _ - ] map ;
+ { $code """: v-n ( v n -- w ) '[ _ - ] map ;
: area ( seq -- x )
[ 0 suffix ] [ sum 2 / ] bi
- v-n product sqrt ;"> }
+ v-n product sqrt ;""" }
}
{ $slide "Implementing an abstraction"
{ "Suppose we want to get the price of the customer's first order, but any one of the steps along the way could be a nil value (" { $link f } " in Factor):" }
}
{ $slide "This is hard with mainstream syntax!"
{ $code
- <" var customer = ...;
+ """var customer = ...;
var orders = (customer == null ? null : customer.orders);
var order = (orders == null ? null : orders[0]);
-var price = (order == null ? null : order.price);"> }
+var price = (order == null ? null : order.price);""" }
}
{ $slide "An ad-hoc solution"
"Something like..."
{ $slide "A macro solution"
"Returns a quotation to the compiler"
"Constructed using map, fry, and concat"
- { $code <" MACRO: plox ( seq -- quot )
+ { $code """MACRO: plox ( seq -- quot )
[
'[ dup _ when ]
- ] map [ ] concat-as ;">
+ ] map [ ] concat-as ;"""
}
}
{ $slide "Macro example"
"Return the caaar of a sequence"
{ "Return " { $snippet f } " on failure" }
- { $code <" : caaar ( seq/f -- x/f )
+ { $code """: caaar ( seq/f -- x/f )
{
[ first ]
[ first ]
[ first ]
- } plox ;">
+ } plox ;"""
}
- { $code <" { { f } } caaar"> }
- { $code <" { { { 1 2 3 } } } caaar"> }
+ { $code """{ { f } } caaar""" }
+ { $code """{ { { 1 2 3 } } } caaar""" }
}
{ $slide "Smart combinators"
"Use stack checker to infer inputs and outputs"
{ $slide "Fibonacci"
"Not tail recursive"
"Call tree is huge"
- { $code <" : fib ( n -- x )
+ { $code """: fib ( n -- x )
dup 1 <= [
[ 1 - fib ] [ 2 - fib ] bi +
- ] unless ;">
+ ] unless ;"""
}
{ $code "36 iota [ fib ] map ." }
}
{ $slide "Memoized Fibonacci"
"Change one word and it's efficient"
- { $code <" MEMO: fib ( n -- x )
+ { $code """MEMO: fib ( n -- x )
dup 1 <= [
[ 1 - fib ] [ 2 - fib ] bi +
- ] unless ;">
+ ] unless ;"""
}
{ $code "36 iota [ fib ] map ." }
}
{ $slide "Example in C"
{ $code
-<" void do_stuff()
+"""void do_stuff()
{
void *obj1, *obj2;
if(!(*obj1 = malloc(256))) goto end;
cleanup2: free(*obj2);
cleanup1: free(*obj1);
end: return;
-}">
+}"""
}
}
{ $slide "Example: allocating and disposing two buffers"
- { $code <" : do-stuff ( -- )
+ { $code """: do-stuff ( -- )
[
256 malloc &free
256 malloc &free
... work goes here ...
- ] with-destructors ;">
+ ] with-destructors ;"""
}
}
{ $slide "Example: allocating two buffers for later"
- { $code <" : do-stuff ( -- )
+ { $code """: do-stuff ( -- )
[
256 malloc |free
256 malloc |free
... work goes here ...
- ] with-destructors ;">
+ ] with-destructors ;"""
}
}
{ $slide "Example: disposing of an output port"
- { $code <" M: output-port dispose*
+ { $code """M: output-port dispose*
[
{
[ handle>> &dispose drop ]
[ port-flush ]
[ handle>> shutdown ]
} cleave
- ] with-destructors ;">
+ ] with-destructors ;"""
}
}
{ $slide "Rapid application development"
}
{ $slide "The essence of Factor"
"Nicely named words abstract away the stack, leaving readable code"
- { $code <" : surround ( seq left right -- seq' )
- swapd 3append ;">
+ { $code """: surround ( seq left right -- seq' )
+ swapd 3append ;"""
}
- { $code <" : glue ( left right middle -- seq' )
- swap 3append ;">
+ { $code """: glue ( left right middle -- seq' )
+ swap 3append ;"""
}
{ $code HEREDOC: xyz
"a" "b" "c" 3append
-"a" "<" ">" surround
+"a" """""""" surround
"a" "b" ", " glue
xyz
}
"Handles C structures, C types, callbacks"
"Used extensively in the Windows and Unix backends"
{ $code
- <" FUNCTION: double pow ( double x, double y ) ;
-2 5.0 pow .">
+ """FUNCTION: double pow ( double x, double y ) ;
+2 5.0 pow ."""
}
}
{ $slide "Windows win32 example"
{ $code
-<" M: windows gmt-offset
+"""M: windows gmt-offset
( -- hours minutes seconds )
"TIME_ZONE_INFORMATION" <c-object>
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_STANDARD [
TIME_ZONE_INFORMATION-Bias
] }
- } case neg 60 /mod 0 ;">
+ } case neg 60 /mod 0 ;"""
}
}
{ $slide "Struct and function"
- { $code <" C-STRUCT: TIME_ZONE_INFORMATION
+ { $code """C-STRUCT: TIME_ZONE_INFORMATION
{ "LONG" "Bias" }
{ { "WCHAR" 32 } "StandardName" }
{ "SYSTEMTIME" "StandardDate" }
{ "LONG" "StandardBias" }
{ { "WCHAR" 32 } "DaylightName" }
{ "SYSTEMTIME" "DaylightDate" }
- { "LONG" "DaylightBias" } ;">
+ { "LONG" "DaylightBias" } ;"""
}
- { $code <" FUNCTION: DWORD GetTimeZoneInformation (
+ { $code """FUNCTION: DWORD GetTimeZoneInformation (
LPTIME_ZONE_INFORMATION
lpTimeZoneInformation
-) ;">
+) ;"""
}
}
{ $slide "Cocoa FFI"
- { $code <" IMPORT: NSAlert [
+ { $code """IMPORT: NSAlert [
NSAlert -> new
[ -> retain ] [
"Raptor" <CFString> &CFRelease
"Look out!" <CFString> &CFRelease
-> setInformativeText:
] tri -> runModal drop
-] with-destructors">
+] with-destructors"""
}
}
{ $slide "Deployment demo"
IN: variants
HELP: VARIANT:
-{ $syntax <"
+{ $syntax """
VARIANT: class-name
singleton
singleton
.
.
.
- ; "> }
+ ; """ }
{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
-{ $examples { $code <"
+{ $examples { $code """
USING: kernel variants ;
IN: scratchpad
nil
cons: { { first object } { rest list } }
;
-"> } } ;
+""" } } ;
HELP: match
{ $values { "branches" array } }
{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
-{ $examples { $example <"
+{ $examples { $example """
USING: kernel math prettyprint variants ;
IN: scratchpad
} match ;
1 2 3 4 nil <cons> <cons> <cons> <cons> list-length .
-"> "4" } } ;
+""" "4" } } ;
HELP: unboa
{ $values { "class" class } }
help-webapp new-dispatcher
<main-action> "" add-responder
over <search-action> "search" add-responder
- swap <static> "content" add-responder ;
+ swap <static> "content" add-responder
+ "resource:basis/definitions/icons/" <static> "icons" add-responder ;
DEF(bool,sse_version,(void)):
mov $0x1,RETURN_REG
cpuid
- /* test $0x100000,%ecx
+ test $0x100000,%ecx
jnz sse_42
test $0x80000,%ecx
jnz sse_41
test $0x200,%ecx
- jnz ssse_3 */
+ jnz ssse_3
test $0x1,%ecx
jnz sse_3
test $0x4000000,%edx
projects / factor.git / commitdiff