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

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

db4
Guillaume Nargeot 2009-10-22 18:39:12 +09:00
parent 2d6e47d710 6c1a70c218
commit 10414e0183
161 changed files with 2322 additions and 1233 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
basis/alien/remote-control/remote-control.factor
View File

@ -1,18 +1,19 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.data alien.strings parser
threads words kernel.private kernel io.encodings.utf8 eval ;
USING: accessors alien alien.c-types alien.data alien.strings
parser threads words kernel.private kernel io.encodings.utf8
eval ;
IN: alien.remote-control
: eval-callback ( -- callback )
"void*" { "char*" } "cdecl"
void* { char* } "cdecl"
[ eval>string utf8 malloc-string ] alien-callback ;
: yield-callback ( -- callback )
"void" { } "cdecl" [ yield ] alien-callback ;
void { } "cdecl" [ yield ] alien-callback ;
: sleep-callback ( -- callback )
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
void { long } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
dup optimized? [ execute ] [ drop f ] if ; inline

4
basis/cocoa/callbacks/callbacks.factor
View File

@ -16,11 +16,11 @@ CLASS: {
{ +superclass+ "NSObject" }
}
{ "perform:" "void" { "id" "SEL" "id" }
{ "perform:" void { id SEL id }
[ 2drop callbacks get at try ]
}
{ "dealloc" "void" { "id" "SEL" }
{ "dealloc" void { id SEL }
[
drop
dup callbacks get delete-at

21
basis/cocoa/cocoa-tests.factor
View File

@ -1,6 +1,7 @@
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory
compiler.units math core-graphics.types ;
compiler kernel namespaces cocoa.classes cocoa.runtime
tools.test memory compiler.units math core-graphics.types ;
FROM: alien.c-types => int void ;
IN: cocoa.tests
CLASS: {
@ -8,8 +9,8 @@ CLASS: {
{ +name+ "Foo" }
} {
"foo:"
"void"
{ "id" "SEL" "NSRect" }
void
{ id SEL NSRect }
[ gc "x" set 2drop ]
} ;
@ -30,8 +31,8 @@ CLASS: {
{ +name+ "Bar" }
} {
"bar"
"NSRect"
{ "id" "SEL" }
NSRect
{ id SEL }
[ 2drop test-foo "x" get ]
} ;
@ -52,13 +53,13 @@ CLASS: {
{ +name+ "Bar" }
} {
"bar"
"NSRect"
{ "id" "SEL" }
NSRect
{ id SEL }
[ 2drop test-foo "x" get ]
} {
"babb"
"int"
{ "id" "SEL" "int" }
int
{ id SEL int }
[ 2nip sq ]
} ;

117
basis/cocoa/messages/messages.factor
View File

@ -2,10 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
classes.struct continuations combinators compiler compiler.alien
stack-checker kernel math namespaces make quotations sequences
strings words cocoa.runtime io macros memoize io.encodings.utf8
effects libc libc.private lexer init core-foundation fry
generalizations specialized-arrays ;
core-graphics.types stack-checker kernel math namespaces make
quotations sequences strings words cocoa.runtime cocoa.types io
macros memoize io.encodings.utf8 effects layouts libc
libc.private lexer init core-foundation fry generalizations
specialized-arrays ;
QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages
SPECIALIZED-ARRAY: void*
@ -98,75 +100,84 @@ class-init-hooks [ H{ } clone ] initialize
SYMBOL: objc>alien-types
H{
{ "c" "char" }
{ "i" "int" }
{ "s" "short" }
{ "C" "uchar" }
{ "I" "uint" }
{ "S" "ushort" }
{ "f" "float" }
{ "d" "double" }
{ "B" "bool" }
{ "v" "void" }
{ "*" "char*" }
{ "?" "unknown_type" }
{ "@" "id" }
{ "#" "Class" }
{ ":" "SEL" }
{ "c" c:char }
{ "i" c:int }
{ "s" c:short }
{ "C" c:uchar }
{ "I" c:uint }
{ "S" c:ushort }
{ "f" c:float }
{ "d" c:double }
{ "B" c:bool }
{ "v" c:void }
{ "*" c:char* }
{ "?" unknown_type }
{ "@" id }
{ "#" Class }
{ ":" SEL }
}
"ptrdiff_t" heap-size {
cell {
{ 4 [ H{
{ "l" "long" }
{ "q" "longlong" }
{ "L" "ulong" }
{ "Q" "ulonglong" }
{ "l" c:long }
{ "q" c:longlong }
{ "L" c:ulong }
{ "Q" c:ulonglong }
} ] }
{ 8 [ H{
{ "l" "long32" }
{ "q" "long" }
{ "L" "ulong32" }
{ "Q" "ulong" }
{ "l" long32 }
{ "q" long }
{ "L" ulong32 }
{ "Q" ulong }
} ] }
} case
assoc-union objc>alien-types set-global
SYMBOL: objc>struct-types
H{
{ "_NSPoint" NSPoint }
{ "NSPoint" NSPoint }
{ "CGPoint" NSPoint }
{ "_NSRect" NSRect }
{ "NSRect" NSRect }
{ "CGRect" NSRect }
{ "_NSSize" NSSize }
{ "NSSize" NSSize }
{ "CGSize" NSSize }
{ "_NSRange" NSRange }
{ "NSRange" NSRange }
} objc>struct-types set-global
! The transpose of the above map
SYMBOL: alien>objc-types
objc>alien-types get [ swap ] assoc-map
! A hack...
"ptrdiff_t" heap-size {
cell {
{ 4 [ H{
{ "NSPoint" "{_NSPoint=ff}" }
{ "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
{ "NSSize" "{_NSSize=ff}" }
{ "NSRange" "{_NSRange=II}" }
{ "NSInteger" "i" }
{ "NSUInteger" "I" }
{ "CGFloat" "f" }
{ NSPoint "{_NSPoint=ff}" }
{ NSRect "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
{ NSSize "{_NSSize=ff}" }
{ NSRange "{_NSRange=II}" }
{ NSInteger "i" }
{ NSUInteger "I" }
{ CGFloat "f" }
} ] }
{ 8 [ H{
{ "NSPoint" "{CGPoint=dd}" }
{ "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" }
{ "NSSize" "{CGSize=dd}" }
{ "NSRange" "{_NSRange=QQ}" }
{ "NSInteger" "q" }
{ "NSUInteger" "Q" }
{ "CGFloat" "d" }
{ NSPoint "{CGPoint=dd}" }
{ NSRect "{CGRect={CGPoint=dd}{CGSize=dd}}" }
{ NSSize "{CGSize=dd}" }
{ NSRange "{_NSRange=QQ}" }
{ NSInteger "q" }
{ NSUInteger "Q" }
{ CGFloat "d" }
} ] }
} case
assoc-union alien>objc-types set-global
: internal-cocoa-type? ( c-type -- ? )
[ "?" = ] [ first CHAR: _ = ] bi or ;
: warn-c-type ( c-type -- )
dup internal-cocoa-type?
[ drop ] [ "Warning: no such C type: " write print ] if ;
: objc-struct-type ( i string -- ctype )
[ CHAR: = ] 2keep index-from swap subseq
dup c-types get key? [ warn-c-type "void*" ] unless ;
objc>struct-types get at* [ drop void* ] unless ;
ERROR: no-objc-type name ;
@ -177,9 +188,9 @@ ERROR: no-objc-type name ;
: (parse-objc-type) ( i string -- ctype )
[ [ 1 + ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: ^ = ] [ 3drop void* ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
{ [ dup CHAR: [ = ] [ 3drop void* ] }
[ 2nip decode-type ]
} cond ;

7
basis/compiler/alien/alien.factor
View File

@ -9,10 +9,10 @@ IN: compiler.alien
: alien-parameters ( params -- seq )
dup parameters>>
swap return>> large-struct? [ "void*" prefix ] when ;
swap return>> large-struct? [ void* prefix ] when ;
: alien-return ( params -- ctype )
return>> dup large-struct? [ drop "void" ] when ;
return>> dup large-struct? [ drop void ] when ;
: c-type-stack-align ( type -- align )
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
@ -20,8 +20,7 @@ IN: compiler.alien
: parameter-align ( n type -- n delta )
[ c-type-stack-align align dup ] [ drop ] 2bi - ;
: parameter-sizes ( types -- total offsets )
#! Compute stack frame locations.
: parameter-offsets ( types -- total offsets )
[
0 [
[ parameter-align drop dup , ] keep stack-size +

4
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
View File

@ -27,7 +27,9 @@ M: ##call compute-stack-frame*
M: ##gc compute-stack-frame*
frame-required? on
stack-frame new swap tagged-values>> length cells >>gc-root-size
stack-frame new
swap tagged-values>> length cells >>gc-root-size
t >>calls-vm?
request-stack-frame ;
M: _spill-area-size compute-stack-frame*

9
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -6,6 +6,7 @@ compiler.cfg arrays locals byte-arrays kernel.private math
slots.private vectors sbufs strings math.partial-dispatch
hashtables assocs combinators.short-circuit
strings.private accessors compiler.cfg.instructions ;
FROM: alien.c-types => int ;
IN: compiler.cfg.builder.tests
! Just ensure that various CFGs build correctly.
@ -66,9 +67,9 @@ IN: compiler.cfg.builder.tests
[ [ t ] loop ]
[ [ dup ] loop ]
[ [ 2 ] [ 3 throw ] if 4 ]
[ "int" f "malloc" { "int" } alien-invoke ]
[ "int" { "int" } "cdecl" alien-indirect ]
[ "int" { "int" } "cdecl" [ ] alien-callback ]
[ int f "malloc" { int } alien-invoke ]
[ int { int } "cdecl" alien-indirect ]
[ int { int } "cdecl" [ ] alien-callback ]
[ swap - + * ]
[ swap slot ]
[ blahblah ]
@ -213,4 +214,4 @@ IN: compiler.cfg.builder.tests
] when
! Regression. Make sure everything is inlined correctly
[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test

3
basis/compiler/cfg/builder/builder.factor
View File

@ -212,7 +212,8 @@ M: #terminate emit-node drop ##no-tco end-basic-block ;
stack-frame new
swap
[ return>> return-size >>return ]
[ alien-parameters parameter-sizes drop >>params ] bi ;
[ alien-parameters parameter-offsets drop >>params ] bi
t >>calls-vm? ;
: alien-node-height ( params -- )
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;

4
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -163,8 +163,8 @@ IN: compiler.cfg.intrinsics
{ 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-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }

77
basis/compiler/cfg/intrinsics/simd/simd.factor
View File

@ -10,8 +10,8 @@ compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.intrinsics.alien
specialized-arrays ;
FROM: alien.c-types => heap-size char uchar float double ;
SPECIALIZED-ARRAYS: float double ;
FROM: alien.c-types => heap-size uchar ushort uint ulonglong float double ;
SPECIALIZED-ARRAYS: uchar ushort uint ulonglong float double ;
IN: compiler.cfg.intrinsics.simd
MACRO: check-elements ( quots -- )
@ -155,28 +155,79 @@ MACRO: if-literals-match ( quots -- )
[ ^^not-vector ]
[ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
:: (generate-compare-vector) ( src1 src2 rep {cc,swap} -- dst )
:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
{cc,swap} first2 :> swap? :> cc
swap?
[ src2 src1 rep cc ^^compare-vector ]
[ src1 src2 rep cc ^^compare-vector ] if ;
:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
rep orig-cc %compare-vector-ccs :> not? :> ccs
ccs empty?
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
[
ccs unclip :> first-cc :> rest-ccs
src1 src2 rep first-cc (generate-compare-vector) :> first-dst
src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst
rest-ccs first-dst
[ [ src1 src2 rep ] dip (generate-compare-vector) rep ^^or-vector ]
[ [ src1 src2 rep ] dip ((generate-compare-vector)) rep ^^or-vector ]
reduce
not? [ rep generate-not-vector ] when
] if ;
: sign-bit-mask ( rep -- byte-array )
unsign-rep {
{ char-16-rep [ uchar-array{
HEX: 80 HEX: 80 HEX: 80 HEX: 80
HEX: 80 HEX: 80 HEX: 80 HEX: 80
HEX: 80 HEX: 80 HEX: 80 HEX: 80
HEX: 80 HEX: 80 HEX: 80 HEX: 80
} underlying>> ] }
{ short-8-rep [ ushort-array{
HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
} underlying>> ] }
{ int-4-rep [ uint-array{
HEX: 8000,0000 HEX: 8000,0000
HEX: 8000,0000 HEX: 8000,0000
} underlying>> ] }
{ longlong-2-rep [ ulonglong-array{
HEX: 8000,0000,0000,0000
HEX: 8000,0000,0000,0000
} underlying>> ] }
} case ;
:: (generate-minmax-compare-vector) ( src1 src2 rep orig-cc -- dst )
orig-cc order-cc {
{ cc< [ src1 src2 rep ^^max-vector src1 rep cc/= (generate-compare-vector) ] }
{ cc<= [ src1 src2 rep ^^min-vector src1 rep cc= (generate-compare-vector) ] }
{ cc> [ src1 src2 rep ^^min-vector src1 rep cc/= (generate-compare-vector) ] }
{ cc>= [ src1 src2 rep ^^max-vector src1 rep cc= (generate-compare-vector) ] }
} case ;
:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
{
{
[ rep orig-cc %compare-vector-reps member? ]
[ src1 src2 rep orig-cc (generate-compare-vector) ]
}
{
[ rep %min-vector-reps member? ]
[ src1 src2 rep orig-cc (generate-minmax-compare-vector) ]
}
{
[ rep unsign-rep orig-cc %compare-vector-reps member? ]
[
rep sign-bit-mask ^^load-constant :> sign-bits
src1 sign-bits rep ^^xor-vector
src2 sign-bits rep ^^xor-vector
rep unsign-rep orig-cc (generate-compare-vector)
]
}
} cond ;
:: generate-unpack-vector-head ( src rep -- dst )
{
{
@ -265,3 +316,17 @@ MACRO: if-literals-match ( quots -- )
]
} cond ;
: generate-min-vector ( src1 src2 rep -- dst )
dup %min-vector-reps member?
[ ^^min-vector ] [
[ cc< generate-compare-vector ]
[ generate-blend-vector ] 3bi
] if ;
: generate-max-vector ( src1 src2 rep -- dst )
dup %max-vector-reps member?
[ ^^max-vector ] [
[ cc> generate-compare-vector ]
[ generate-blend-vector ] 3bi
] if ;

17
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences
classes.algebra locals compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
USING: layouts namespaces kernel accessors sequences math
classes.algebra locals combinators cpu.architecture
compiler.tree.propagation.info compiler.cfg.stacks
compiler.cfg.hats compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.utilities
compiler.cfg.builder.blocks compiler.constants ;
IN: compiler.cfg.intrinsics.slots
@ -22,11 +23,17 @@ IN: compiler.cfg.intrinsics.slots
[ [ second literal>> ] [ first value-tag ] bi ] bi*
^^slot-imm ;
: immediate-slot-offset? ( value-info -- ? )
literal>> {
{ [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
[ drop f ]
} cond ;
: emit-slot ( node -- )
dup node-input-infos
dup first value-tag [
nip
dup second value-info-small-fixnum?
dup second immediate-slot-offset?
[ (emit-slot-imm) ] [ (emit-slot) ] if
ds-push
] [ drop emit-primitive ] if ;
@ -61,7 +68,7 @@ IN: compiler.cfg.intrinsics.slots
dup node-input-infos
dup second value-tag [
nip
dup third value-info-small-fixnum?
dup third immediate-slot-offset?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ drop emit-primitive ] if ;

7
basis/compiler/cfg/stack-frame/stack-frame.factor
View File

@ -9,7 +9,8 @@ TUPLE: stack-frame
{ return integer }
{ total-size integer }
{ gc-root-size integer }
{ spill-area-size integer } ;
{ spill-area-size integer }
{ calls-vm? boolean } ;
! Stack frame utilities
: param-base ( -- n )
@ -35,7 +36,9 @@ TUPLE: stack-frame
: max-stack-frame ( frame1 frame2 -- frame3 )
[ stack-frame new ] 2dip
{
[ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ]
[ [ gc-root-size>> ] bi@ max >>gc-root-size ]
2tri ;
[ [ calls-vm?>> ] bi@ or >>calls-vm? ]
} 2cleave ;

91
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -13,11 +13,18 @@ compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify ;
IN: compiler.cfg.value-numbering.rewrite
: vreg-small-constant? ( vreg -- ? )
: vreg-immediate-arithmetic? ( vreg -- ? )
vreg>expr {
[ constant-expr? ]
[ value>> fixnum? ]
[ value>> small-enough? ]
[ value>> immediate-arithmetic? ]
} 1&& ;
: vreg-immediate-bitwise? ( vreg -- ? )
vreg>expr {
[ constant-expr? ]
[ value>> fixnum? ]
[ value>> immediate-bitwise? ]
} 1&& ;
! Outputs f to mean no change
@ -174,8 +181,8 @@ M: ##compare-imm-branch rewrite
M: ##compare-branch rewrite
{
{ [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
{ [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
{ [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm-branch ] }
{ [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm-branch ] }
{ [ dup self-compare? ] [ rewrite-self-compare-branch ] }
[ drop f ]
} cond ;
@ -205,8 +212,8 @@ M: ##compare-branch rewrite
M: ##compare rewrite
{
{ [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
{ [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
{ [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm ] }
{ [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm ] }
{ [ dup self-compare? ] [ rewrite-self-compare ] }
[ drop f ]
} cond ;
@ -264,6 +271,19 @@ M: ##neg rewrite
M: ##not rewrite
maybe-unary-constant-fold ;
: arithmetic-op? ( op -- ? )
{
##add
##add-imm
##sub
##sub-imm
##mul
##mul-imm
} memq? ;
: immediate? ( value op -- ? )
arithmetic-op? [ immediate-arithmetic? ] [ immediate-bitwise? ] if ;
: reassociate ( insn op -- insn )
[
{
@ -273,7 +293,7 @@ M: ##not rewrite
[ ]
} cleave constant-fold*
] dip
over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
2dup immediate? [ new-insn ] [ 2drop 2drop f ] if ; inline
M: ##add-imm rewrite
{
@ -283,7 +303,7 @@ M: ##add-imm rewrite
} cond ;
: sub-imm>add-imm ( insn -- insn' )
[ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
[ dst>> ] [ src1>> ] [ src2>> neg ] tri dup immediate-arithmetic?
[ \ ##add-imm new-insn ] [ 3drop f ] if ;
M: ##sub-imm rewrite
@ -358,16 +378,20 @@ M: ##sar-imm rewrite
[ swap ] when vreg>constant
] dip new-insn ; inline
: vreg-immediate? ( vreg op -- ? )
arithmetic-op?
[ vreg-immediate-arithmetic? ] [ vreg-immediate-bitwise? ] if ;
: rewrite-arithmetic ( insn op -- ? )
{
{ [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
{ [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
[ 2drop f ]
} cond ; inline
: rewrite-arithmetic-commutative ( insn op -- ? )
{
{ [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
{ [ over src1>> vreg-small-constant? ] [ t insn>imm-insn ] }
{ [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
{ [ over src1>> over vreg-immediate? ] [ t insn>imm-insn ] }
[ 2drop f ]
} cond ; inline
@ -491,3 +515,48 @@ M: ##scalar>vector rewrite
M: ##xor-vector rewrite
dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
[ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
: vector-not? ( expr -- ? )
{
[ not-vector-expr? ]
[ {
[ xor-vector-expr? ]
[ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
} 1&& ]
} 1|| ;
GENERIC: vector-not-src ( expr -- vreg )
M: not-vector-expr vector-not-src src>> vn>vreg ;
M: xor-vector-expr vector-not-src
dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
M: ##and-vector rewrite
{
{ [ dup src1>> vreg>expr vector-not? ] [
{
[ dst>> ]
[ src1>> vreg>expr vector-not-src ]
[ src2>> ]
[ rep>> ]
} cleave \ ##andn-vector new-insn
] }
{ [ dup src2>> vreg>expr vector-not? ] [
{
[ dst>> ]
[ src2>> vreg>expr vector-not-src ]
[ src1>> ]
[ rep>> ]
} cleave \ ##andn-vector new-insn
] }
[ drop f ]
} cond ;
M: ##andn-vector rewrite
dup src1>> vreg>expr vector-not? [
{
[ dst>> ]
[ src1>> vreg>expr vector-not-src ]
[ src2>> ]
[ rep>> ]
} cleave \ ##and-vector new-insn
] [ drop f ] if ;

122
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -1281,6 +1281,128 @@ cell 8 = [
} value-numbering-step
] unit-test
! NOT x AND y => x ANDN y
[
{
T{ ##fill-vector f 3 float-4-rep }
T{ ##xor-vector f 4 0 3 float-4-rep }
T{ ##andn-vector f 5 0 1 float-4-rep }
}
] [
{
T{ ##fill-vector f 3 float-4-rep }
T{ ##xor-vector f 4 0 3 float-4-rep }
T{ ##and-vector f 5 4 1 float-4-rep }
} value-numbering-step
] unit-test
[
{
T{ ##not-vector f 4 0 float-4-rep }
T{ ##andn-vector f 5 0 1 float-4-rep }
}
] [
{
T{ ##not-vector f 4 0 float-4-rep }
T{ ##and-vector f 5 4 1 float-4-rep }
} value-numbering-step
] unit-test
! x AND NOT y => y ANDN x
[
{
T{ ##fill-vector f 3 float-4-rep }
T{ ##xor-vector f 4 0 3 float-4-rep }
T{ ##andn-vector f 5 0 1 float-4-rep }
}
] [
{
T{ ##fill-vector f 3 float-4-rep }
T{ ##xor-vector f 4 0 3 float-4-rep }
T{ ##and-vector f 5 1 4 float-4-rep }
} value-numbering-step
] unit-test
[
{
T{ ##not-vector f 4 0 float-4-rep }
T{ ##andn-vector f 5 0 1 float-4-rep }
}
] [
{
T{ ##not-vector f 4 0 float-4-rep }
T{ ##and-vector f 5 1 4 float-4-rep }
} value-numbering-step
] unit-test
! NOT x ANDN y => x AND y
[
{
T{ ##fill-vector f 3 float-4-rep }
T{ ##xor-vector f 4 0 3 float-4-rep }
T{ ##and-vector f 5 0 1 float-4-rep }
}
] [
{
T{ ##fill-vector f 3 float-4-rep }
T{ ##xor-vector f 4 0 3 float-4-rep }
T{ ##andn-vector f 5 4 1 float-4-rep }
} value-numbering-step
] unit-test
[
{
T{ ##not-vector f 4 0 float-4-rep }
T{ ##and-vector f 5 0 1 float-4-rep }
}
] [
{
T{ ##not-vector f 4 0 float-4-rep }
T{ ##andn-vector f 5 4 1 float-4-rep }
} value-numbering-step
] unit-test
! AND <=> ANDN
[
{
T{ ##fill-vector f 3 float-4-rep }
T{ ##xor-vector f 4 0 3 float-4-rep }
T{ ##andn-vector f 5 0 1 float-4-rep }
T{ ##and-vector f 6 0 2 float-4-rep }
T{ ##or-vector f 7 5 6 float-4-rep }
}
] [
{
T{ ##fill-vector f 3 float-4-rep }
T{ ##xor-vector f 4 0 3 float-4-rep }
T{ ##and-vector f 5 4 1 float-4-rep }
T{ ##andn-vector f 6 4 2 float-4-rep }
T{ ##or-vector f 7 5 6 float-4-rep }
} value-numbering-step
] unit-test
[
{
T{ ##not-vector f 4 0 float-4-rep }
T{ ##andn-vector f 5 0 1 float-4-rep }
T{ ##and-vector f 6 0 2 float-4-rep }
T{ ##or-vector f 7 5 6 float-4-rep }
}
] [
{
T{ ##not-vector f 4 0 float-4-rep }
T{ ##and-vector f 5 4 1 float-4-rep }
T{ ##andn-vector f 6 4 2 float-4-rep }
T{ ##or-vector f 7 5 6 float-4-rep }
} value-numbering-step
] unit-test
! branch folding
: test-branch-folding ( insns -- insns' n )
<basic-block>
[ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep

35
basis/compiler/codegen/codegen.factor
View File

@ -333,35 +333,29 @@ M: reg-class reg-class-full?
[ alloc-stack-param ] [ alloc-fastcall-param ] if
[ param-reg ] dip ;
: (flatten-int-type) ( size -- seq )
cell /i "void*" c-type <repetition> ;
: (flatten-int-type) ( type -- seq )
stack-size cell align cell /i void* c-type <repetition> ;
GENERIC: flatten-value-type ( type -- types )
M: object flatten-value-type 1array ;
M: struct-c-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: struct-c-type flatten-value-type (flatten-int-type) ;
M: long-long-type flatten-value-type (flatten-int-type) ;
M: c-type-name flatten-value-type c-type flatten-value-type ;
: flatten-value-types ( params -- params )
#! Convert value type structs to consecutive void*s.
[
0 [
c-type
[ parameter-align (flatten-int-type) % ] keep
[ parameter-align cell /i void* c-type <repetition> % ] keep
[ stack-size cell align + ] keep
flatten-value-type %
] reduce drop
] { } make ;
: each-parameter ( parameters quot -- )
[ [ parameter-sizes nip ] keep ] dip 2each ; inline
: reverse-each-parameter ( parameters quot -- )
[ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline
[ [ parameter-offsets nip ] keep ] dip 2each ; inline
: reset-fastcall-counts ( -- )
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
@ -378,10 +372,17 @@ M: long-long-type flatten-value-type ( type -- types )
[ '[ alloc-parameter _ execute ] ]
bi* each-parameter ; inline
: reverse-each-parameter ( parameters quot -- )
[ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
: prepare-unbox-parameters ( parameters -- offsets types indices )
[ parameter-offsets nip ] [ ] [ length iota reverse ] tri ;
: unbox-parameters ( offset node -- )
parameters>> [
%prepare-unbox [ over + ] dip unbox-parameter
] reverse-each-parameter drop ;
parameters>> swap
'[ prepare-unbox-parameters [ %prepare-unbox [ _ + ] dip unbox-parameter ] 3each ]
[ length neg %inc-d ]
bi ;
: prepare-box-struct ( node -- offset )
#! Return offset on C stack where to store unboxed
@ -413,7 +414,7 @@ M: long-long-type flatten-value-type ( type -- types )
] if ;
: stdcall-mangle ( symbol params -- symbol )
parameters>> parameter-sizes drop number>string "@" glue ;
parameters>> parameter-offsets drop number>string "@" glue ;
: alien-invoke-dlsym ( params -- symbols dll )
[ [ function>> dup ] keep stdcall-mangle 2array ]

62
basis/compiler/tests/alien.factor
View File

@ -90,14 +90,14 @@ FUNCTION: TINY ffi_test_17 int x ;
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1 ( ptr -- result )
"int" { } "cdecl" alien-indirect ;
int { } "cdecl" alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
"int" { } "cdecl" alien-indirect drop ;
int { } "cdecl" alien-indirect drop ;
{ 1 0 } [ indirect-test-1' ] must-infer-as
@ -106,7 +106,7 @@ FUNCTION: TINY ffi_test_17 int x ;
[ -1 indirect-test-1 ] must-fail
: indirect-test-2 ( x y ptr -- result )
"int" { "int" "int" } "cdecl" alien-indirect gc ;
int { int int } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
@ -115,20 +115,20 @@ FUNCTION: TINY ffi_test_17 int x ;
unit-test
: indirect-test-3 ( a b c d ptr -- result )
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
int { int int int int } "stdcall" alien-indirect
gc ;
[ f ] [ "f-stdcall" load-library f = ] unit-test
[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
: ffi_test_18 ( w x y z -- int )
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
int "f-stdcall" "ffi_test_18" { int int int int }
alien-invoke gc ;
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- BAR )
"BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
BAR "f-stdcall" "ffi_test_19" { long long long }
alien-invoke gc ;
[ 11 6 -7 ] [
@ -157,17 +157,17 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
! Make sure XT doesn't get clobbered in stack frame
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
"int"
int
"f-cdecl" "ffi_test_31"
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
{ int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int }
alien-invoke gc 3 ;
[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
"float"
float
"f-cdecl" "ffi_test_31_point_5"
{ "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
{ float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float }
alien-invoke ;
[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
@ -312,21 +312,21 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
! Test callbacks
: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
: callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
[ t ] [ callback-1 alien? ] unit-test
: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
: callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test
: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
: callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test
: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
: callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
[ t ] [
namestack*
@ -341,7 +341,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
] unit-test
: callback-4 ( -- callback )
"void" { } "cdecl" [ "Hello world" write ] alien-callback
void { } "cdecl" [ "Hello world" write ] alien-callback
gc ;
[ "Hello world" ] [
@ -349,40 +349,40 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
] unit-test
: callback-5 ( -- callback )
"void" { } "cdecl" [ gc ] alien-callback ;
void { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
] unit-test
: callback-5b ( -- callback )
"void" { } "cdecl" [ compact-gc ] alien-callback ;
void { } "cdecl" [ compact-gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5b callback_test_1
] unit-test
: callback-6 ( -- callback )
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7 ( -- callback )
"void" { } "cdecl" [ 1000000 sleep ] alien-callback ;
void { } "cdecl" [ 1000000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test
: callback-8 ( -- callback )
"void" { } "cdecl" [
void { } "cdecl" [
[ continue ] callcc0
] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
: callback-9 ( -- callback )
"int" { "int" "int" "int" } "cdecl" [
int { int int int } "cdecl" [
+ + 1 +
] alien-callback ;
@ -440,13 +440,13 @@ STRUCT: double-rect
} cleave ;
: double-rect-callback ( -- alien )
"void" { "void*" "void*" "double-rect" } "cdecl"
void { void* void* double-rect } "cdecl"
[ "example" set-global 2drop ] alien-callback ;
: double-rect-test ( arg -- arg' )
f f rot
double-rect-callback
"void" { "void*" "void*" "double-rect" } "cdecl" alien-indirect
void { void* void* double-rect } "cdecl" alien-indirect
"example" get-global ;
[ 1.0 2.0 3.0 4.0 ]
@ -463,7 +463,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
] unit-test
: callback-10 ( -- callback )
"test_struct_14" { "double" "double" } "cdecl"
test_struct_14 { double double } "cdecl"
[
test_struct_14 <struct>
swap >>x2
@ -471,7 +471,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
] alien-callback ;
: callback-10-test ( x1 x2 callback -- result )
"test_struct_14" { "double" "double" } "cdecl" alien-indirect ;
test_struct_14 { double double } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-10 callback-10-test
@ -486,7 +486,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
] unit-test
: callback-11 ( -- callback )
"test-struct-12" { "int" "double" } "cdecl"
test-struct-12 { int double } "cdecl"
[
test-struct-12 <struct>
swap >>x
@ -494,7 +494,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
] alien-callback ;
: callback-11-test ( x1 x2 callback -- result )
"test-struct-12" { "int" "double" } "cdecl" alien-indirect ;
test-struct-12 { int double } "cdecl" alien-indirect ;
[ 1 2.0 ] [
1 2.0 callback-11 callback-11-test
@ -510,7 +510,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
: callback-12 ( -- callback )
"test_struct_15" { "float" "float" } "cdecl"
test_struct_15 { float float } "cdecl"
[
test_struct_15 <struct>
swap >>y
@ -518,7 +518,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
] alien-callback ;
: callback-12-test ( x1 x2 callback -- result )
"test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
test_struct_15 { float float } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
@ -533,7 +533,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
: callback-13 ( -- callback )
"test_struct_16" { "float" "int" } "cdecl"
test_struct_16 { float int } "cdecl"
[
test_struct_16 <struct>
swap >>a
@ -541,7 +541,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
] alien-callback ;
: callback-13-test ( x1 x2 callback -- result )
"test_struct_16" { "float" "int" } "cdecl" alien-indirect ;
test_struct_16 { float int } "cdecl" alien-indirect ;
[ 1.0 2 ] [
1.0 2 callback-13 callback-13-test

6
basis/compiler/tests/codegen.factor
View File

@ -270,8 +270,8 @@ TUPLE: id obj ;
{ float } declare dup 0 =
[ drop 1 ] [
dup 0 >=
[ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ]
[ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ]
[ 2 double "libm" "pow" { double double } alien-invoke ]
[ -0.5 double "libm" "pow" { double double } alien-invoke ]
if
] if ;
@ -475,4 +475,4 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
[ 2 0 ] [
1 1
[ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
] unit-test
] unit-test

3
basis/compiler/tests/intrinsics.factor
View File

@ -87,14 +87,17 @@ IN: compiler.tests.intrinsics
[ 4 ] [ 12 7 [ fixnum-bitand ] compile-call ] unit-test
[ 4 ] [ 12 [ 7 fixnum-bitand ] compile-call ] unit-test
[ 4 ] [ [ 12 7 fixnum-bitand ] compile-call ] unit-test
[ -16 ] [ -1 [ -16 fixnum-bitand ] compile-call ] unit-test
[ 15 ] [ 12 7 [ fixnum-bitor ] compile-call ] unit-test
[ 15 ] [ 12 [ 7 fixnum-bitor ] compile-call ] unit-test
[ 15 ] [ [ 12 7 fixnum-bitor ] compile-call ] unit-test
[ -1 ] [ -1 [ -16 fixnum-bitor ] compile-call ] unit-test
[ 11 ] [ 12 7 [ fixnum-bitxor ] compile-call ] unit-test
[ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-call ] unit-test
[ 11 ] [ [ 12 7 fixnum-bitxor ] compile-call ] unit-test
[ 15 ] [ -1 [ -16 fixnum-bitxor ] compile-call ] unit-test
[ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test

2
basis/compiler/tests/low-level-ir.factor
View File

@ -98,7 +98,7 @@ IN: compiler.tests.low-level-ir
V{
T{ ##load-reference f 1 B{ 31 67 52 } }
T{ ##unbox-any-c-ptr f 0 1 2 }
T{ ##alien-unsigned-1 f 0 0 }
T{ ##alien-unsigned-1 f 0 0 0 }
T{ ##shl-imm f 0 0 3 }
} compile-test-bb
] unit-test

15
basis/compiler/tree/propagation/info/info.factor
View File

@ -340,18 +340,3 @@ SYMBOL: value-infos
dup in-d>> last node-value-info
literal>> first immutable-tuple-class?
] [ drop f ] if ;
: value-info-small-fixnum? ( value-info -- ? )
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
[ drop f ]
} cond ;
: value-info-small-tagged? ( value-info -- ? )
dup literal?>> [
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
{ [ dup not ] [ drop t ] }
[ drop f ]
} cond
] [ drop f ] if ;

4
basis/core-foundation/fsevents/fsevents.factor
View File

@ -36,8 +36,8 @@ STRUCT: FSEventStreamContext
{ release void* }
{ copyDescription void* } ;
! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]);
TYPEDEF: void* FSEventStreamCallback
! callback(
CALLBACK: void FSEventStreamCallback ( FSEventStreamRef streamRef, void* clientCallBackInfo, size_t numEvents, void* eventPaths, FSEventStreamEventFlags* eventFlags, FSEventStreamEventId* eventIds ) ;
CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF

2
basis/core-foundation/run-loop/run-loop.factor
View File

@ -115,7 +115,7 @@ PRIVATE>
[ fds>> [ enable-all-callbacks ] each ] bi ;
: timer-callback ( -- callback )
"void" { "CFRunLoopTimerRef" "void*" } "cdecl"
void { CFRunLoopTimerRef void* } "cdecl"
[ 2drop reset-run-loop yield ] alien-callback ;
: init-thread-timer ( -- )

12
basis/cpu/architecture/architecture.factor
View File

@ -440,9 +440,13 @@ M: reg-class param-reg param-regs nth ;
M: stack-params param-reg drop ;
! Is this integer small enough to appear in value template
! slots?
HOOK: small-enough? cpu ( n -- ? )
! Is this integer small enough to be an immediate operand for
! %add-imm, %sub-imm, and %mul-imm?
HOOK: immediate-arithmetic? cpu ( n -- ? )
! Is this integer small enough to be an immediate operand for
! %and-imm, %or-imm, and %xor-imm?
HOOK: immediate-bitwise? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
@ -459,7 +463,7 @@ HOOK: dummy-int-params? cpu ( -- ? )
! If t, all int parameters are shadowed by dummy FP parameters
HOOK: dummy-fp-params? cpu ( -- ? )
HOOK: %prepare-unbox cpu ( -- )
HOOK: %prepare-unbox cpu ( n -- )
HOOK: %unbox cpu ( n rep func -- )

10
basis/cpu/ppc/ppc.factor
View File

@ -577,10 +577,8 @@ M:: ppc %save-param-reg ( stack reg rep -- )
M:: ppc %load-param-reg ( stack reg rep -- )
reg stack local@ rep load-from-frame ;
M: ppc %prepare-unbox ( -- )
! First parameter is top of stack
3 ds-reg 0 LWZ
ds-reg dup cell SUBI ;
M: ppc %prepare-unbox ( n -- )
[ 3 ] dip <ds-loc> loc>operand LWZ ;
M: ppc %unbox ( n rep func -- )
! Value must be in r3
@ -681,7 +679,9 @@ M: ppc %callback-value ( ctype -- )
! Unbox former top of data stack to return registers
unbox-return ;
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
M: ppc return-struct-in-registers? ( c-type -- ? )
c-type return-in-registers?>> ;

226
basis/cpu/x86/32/32.factor
View File

@ -25,6 +25,11 @@ M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
M: x86.32 temp-reg ECX ;
: local@ ( n -- op )
stack-frame get extra-stack-space dup 16 assert= + stack@ ;
M: x86.32 extra-stack-space calls-vm?>> 16 0 ? ;
M: x86.32 %mark-card
drop HEX: ffffffff [+] card-mark <byte> MOV
building get pop
@ -57,12 +62,12 @@ M:: x86.32 %dispatch ( src temp -- )
M: x86.32 pic-tail-reg EBX ;
M: x86.32 reserved-area-size 0 ;
M: x86.32 reserved-stack-space 4 cells ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
: push-vm-ptr ( -- )
0 PUSH 0 rc-absolute-cell rel-vm ; ! push the vm ptr as an argument
: save-vm-ptr ( n -- )
stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type
@ -72,44 +77,34 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
and or ;
: struct-return@ ( n -- operand )
[ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
[ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
M: float-regs param-regs drop { } ;
GENERIC: push-return-reg ( rep -- )
GENERIC: load-return-reg ( n rep -- )
GENERIC: store-return-reg ( n rep -- )
GENERIC: load-return-reg ( src rep -- )
GENERIC: store-return-reg ( dst rep -- )
M: int-rep push-return-reg drop EAX PUSH ;
M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
M: int-rep store-return-reg drop stack@ EAX MOV ;
M: int-rep load-return-reg drop EAX swap MOV ;
M: int-rep store-return-reg drop EAX MOV ;
M: float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
M: float-rep load-return-reg drop next-stack@ FLDS ;
M: float-rep store-return-reg drop stack@ FSTPS ;
M: float-rep load-return-reg drop FLDS ;
M: float-rep store-return-reg drop FSTPS ;
M: double-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
M: double-rep load-return-reg drop next-stack@ FLDL ;
M: double-rep store-return-reg drop stack@ FSTPL ;
: align-sub ( n -- )
[ align-stack ] keep - decr-stack-reg ;
: align-add ( n -- )
align-stack incr-stack-reg ;
: with-aligned-stack ( n quot -- )
'[ align-sub @ ] [ align-add ] bi ; inline
M: double-rep load-return-reg drop FLDL ;
M: double-rep store-return-reg drop FSTPL ;
M: x86.32 %prologue ( n -- )
dup PUSH
0 PUSH rc-absolute-cell rel-this
3 cells - decr-stack-reg ;
M: x86.32 %load-param-reg 3drop ;
M: x86.32 %load-param-reg
stack-params assert=
[ [ EAX ] dip local@ MOV ] dip
stack@ EAX MOV ;
M: x86.32 %save-param-reg 3drop ;
@ -118,16 +113,14 @@ M: x86.32 %save-param-reg 3drop ;
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n] on the stack; we are boxing a
#! parameter being passed to a callback from C.
over [ load-return-reg ] [ 2drop ] if ;
over [ [ next-stack@ ] dip load-return-reg ] [ 2drop ] if ;
M:: x86.32 %box ( n rep func -- )
n rep (%box)
rep rep-size cell + [
push-vm-ptr
rep push-return-reg
func f %alien-invoke
] with-aligned-stack ;
rep rep-size save-vm-ptr
0 stack@ rep store-return-reg
func f %alien-invoke ;
: (%box-long-long) ( n -- )
[
EDX over next-stack@ MOV
@ -136,56 +129,39 @@ M:: x86.32 %box ( n rep func -- )
M: x86.32 %box-long-long ( n func -- )
[ (%box-long-long) ] dip
12 [
push-vm-ptr
EDX PUSH
EAX PUSH
f %alien-invoke
] with-aligned-stack ;
8 save-vm-ptr
4 stack@ EDX MOV
0 stack@ EAX MOV
f %alien-invoke ;
M:: x86.32 %box-large-struct ( n c-type -- )
! Compute destination address
EDX n struct-return@ LEA
12 [
push-vm-ptr
! Push struct size
c-type heap-size PUSH
! Push destination address
EDX PUSH
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke
] with-aligned-stack ;
8 save-vm-ptr
4 stack@ c-type heap-size MOV
0 stack@ EDX MOV
"box_value_struct" f %alien-invoke ;
M: x86.32 %prepare-box-struct ( -- )
! Compute target address for value struct return
EAX f struct-return@ LEA
! Store it as the first parameter
0 stack@ EAX MOV ;
0 local@ EAX MOV ;
M: x86.32 %box-small-struct ( c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
16 [
push-vm-ptr
heap-size PUSH
EDX PUSH
EAX PUSH
"box_small_struct" f %alien-invoke
] with-aligned-stack ;
12 save-vm-ptr
8 stack@ swap heap-size MOV
4 stack@ EDX MOV
0 stack@ EAX MOV
"box_small_struct" f %alien-invoke ;
M: x86.32 %prepare-unbox ( -- )
#! Move top of data stack to EAX.
EAX ESI [] MOV
ESI 4 SUB ;
EAX swap ds-reg reg-stack MOV ;
: call-unbox-func ( func -- )
8 [
! push the vm ptr as an argument
push-vm-ptr
! Push parameter
EAX PUSH
! Call the unboxer
f %alien-invoke
] with-aligned-stack ;
4 save-vm-ptr
0 stack@ EAX MOV
f %alien-invoke ;
M: x86.32 %unbox ( n rep func -- )
#! The value being unboxed must already be in EAX.
@ -194,37 +170,33 @@ M: x86.32 %unbox ( n rep func -- )
#! a parameter to a C function about to be called.
call-unbox-func
! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ;
over [ [ local@ ] dip store-return-reg ] [ 2drop ] if ;
M: x86.32 %unbox-long-long ( n func -- )
call-unbox-func
! Store the return value on the C stack
[
dup stack@ EAX MOV
cell + stack@ EDX MOV
[ local@ EAX MOV ]
[ 4 + local@ EDX MOV ] bi
] when* ;
: %unbox-struct-1 ( -- )
#! Alien must be in EAX.
8 [
push-vm-ptr
EAX PUSH
"alien_offset" f %alien-invoke
! Load first cell
EAX EAX [] MOV
] with-aligned-stack ;
4 save-vm-ptr
0 stack@ EAX MOV
"alien_offset" f %alien-invoke
! Load first cell
EAX EAX [] MOV ;
: %unbox-struct-2 ( -- )
#! Alien must be in EAX.
8 [
push-vm-ptr
EAX PUSH
"alien_offset" f %alien-invoke
! Load second cell
EDX EAX 4 [+] MOV
! Load first cell
EAX EAX [] MOV
] with-aligned-stack ;
4 save-vm-ptr
0 stack@ EAX MOV
"alien_offset" f %alien-invoke
! Load second cell
EDX EAX 4 [+] MOV
! Load first cell
EAX EAX [] MOV ;
M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX.
@ -236,63 +208,46 @@ M: x86 %unbox-small-struct ( size -- )
M:: x86.32 %unbox-large-struct ( n c-type -- )
! Alien must be in EAX.
! Compute destination address
EDX n stack@ LEA
16 [
push-vm-ptr
! Push struct size
c-type heap-size PUSH
! Push destination address
EDX PUSH
! Push source address
EAX PUSH
! Copy the struct to the stack
"to_value_struct" f %alien-invoke
] with-aligned-stack ;
EDX n local@ LEA
12 save-vm-ptr
8 stack@ c-type heap-size MOV
4 stack@ EDX MOV
0 stack@ EAX MOV
"to_value_struct" f %alien-invoke ;
M: x86.32 %nest-stacks ( -- )
! Save current frame. See comment in vm/contexts.hpp
EAX stack-reg stack-frame get total-size>> 3 cells - [+] LEA
8 [
push-vm-ptr
EAX PUSH
"nest_stacks" f %alien-invoke
] with-aligned-stack ;
4 save-vm-ptr
0 stack@ EAX MOV
"nest_stacks" f %alien-invoke ;
M: x86.32 %unnest-stacks ( -- )
4 [
push-vm-ptr
"unnest_stacks" f %alien-invoke
] with-aligned-stack ;
0 save-vm-ptr
"unnest_stacks" f %alien-invoke ;
M: x86.32 %prepare-alien-indirect ( -- )
4 [
push-vm-ptr
"unbox_alien" f %alien-invoke
] with-aligned-stack
0 save-vm-ptr
"unbox_alien" f %alien-invoke
EBP EAX MOV ;
M: x86.32 %alien-indirect ( -- )
EBP CALL ;
M: x86.32 %alien-callback ( quot -- )
! Fastcall
param-reg-1 swap %load-reference
param-reg-2 %mov-vm-ptr
"c_to_factor" f %alien-invoke ;
M: x86.32 %callback-value ( ctype -- )
! Align C stack
ESP 12 SUB
! Save top of data stack in non-volatile register
%prepare-unbox
EAX PUSH
push-vm-ptr
0 %prepare-unbox
4 stack@ EAX MOV
0 save-vm-ptr
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Place top of data stack in EAX
temp-reg POP
EAX POP
! Restore C stack
ESP 12 ADD
! Place former top of data stack back in EAX
EAX 4 stack@ MOV
! Unbox EAX
unbox-return ;
@ -357,17 +312,11 @@ M: x86.32 %callback-return ( n -- )
} cond RET ;
M:: x86.32 %call-gc ( gc-root-count temp -- )
temp gc-root-base param@ LEA
12 [
! Pass the VM ptr as the third parameter
push-vm-ptr
! Pass number of roots as second parameter
gc-root-count PUSH
! Pass pointer to start of GC roots as first parameter
temp PUSH
! Call GC
"inline_gc" f %alien-invoke
] with-aligned-stack ;
temp gc-root-base special@ LEA
8 save-vm-ptr
4 stack@ gc-root-count MOV
0 stack@ temp MOV
"inline_gc" f %alien-invoke ;
M: x86.32 dummy-stack-params? f ;
@ -375,10 +324,13 @@ M: x86.32 dummy-int-params? f ;
M: x86.32 dummy-fp-params? f ;
! Dreadful
M: object flatten-value-type (flatten-int-type) ;
os windows? [
cell "longlong" c-type (>>align)
cell "ulonglong" c-type (>>align)
4 "double" c-type (>>align)
cell longlong c-type (>>align)
cell ulonglong c-type (>>align)
4 double c-type (>>align)
] unless
check-sse

52
basis/cpu/x86/64/64.factor
View File

@ -8,6 +8,22 @@ compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
IN: cpu.x86.64
: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline
M: x86.64 pic-tail-reg RBX ;
M: int-regs return-reg drop RAX ;
M: float-regs return-reg drop XMM0 ;
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: x86.64 extra-stack-space drop 0 ;
M: x86.64 machine-registers
{
{ int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
@ -17,9 +33,13 @@ M: x86.64 machine-registers
} }
} ;
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
: param@ ( n -- op ) reserved-stack-space + stack@ ;
M: x86.64 %prologue ( n -- )
temp-reg 0 MOV rc-absolute-cell rel-this
dup PUSH
temp-reg PUSH
stack-reg swap 3 cells - SUB ;
: load-cards-offset ( dst -- )
0 MOV rc-absolute-cell rel-cards-offset ;
@ -50,22 +70,6 @@ M:: x86.64 %dispatch ( src temp -- )
[ align-code ]
bi ;
: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline
M: x86.64 pic-tail-reg RBX ;
M: int-regs return-reg drop RAX ;
M: float-regs return-reg drop XMM0 ;
M: x86.64 %prologue ( n -- )
temp-reg 0 MOV rc-absolute-cell rel-this
dup PUSH
temp-reg PUSH
stack-reg swap 3 cells - SUB ;
M: stack-params copy-register*
drop
{
@ -84,10 +88,8 @@ M: x86 %load-param-reg [ swap param@ ] dip %copy ;
call
] with-scope ; inline
M: x86.64 %prepare-unbox ( -- )
! First parameter is top of stack
param-reg-1 R14 [] MOV
R14 cell SUB ;
M: x86.64 %prepare-unbox ( n -- )
param-reg-1 swap ds-reg reg-stack MOV ;
M:: x86.64 %unbox ( n rep func -- )
param-reg-2 %mov-vm-ptr
@ -217,9 +219,7 @@ M: x86.64 %alien-callback ( quot -- )
"c_to_factor" f %alien-invoke ;
M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
! Save top of data stack
0 %prepare-unbox
RSP 8 SUB
param-reg-1 PUSH
param-reg-1 %mov-vm-ptr

2
basis/cpu/x86/64/unix/unix.factor
View File

@ -12,7 +12,7 @@ M: int-regs param-regs
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
M: x86.64 reserved-area-size 0 ;
M: x86.64 reserved-stack-space 0 ;
SYMBOL: (stack-value)
! The ABI for passing structs by value is pretty great

2
basis/cpu/x86/64/winnt/winnt.factor
View File

@ -9,7 +9,7 @@ M: int-regs param-regs drop { RCX RDX R8 R9 } ;
M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
M: x86.64 reserved-area-size 4 cells ;
M: x86.64 reserved-stack-space 4 cells ;
M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size { 1 2 4 8 } member? ;

32
basis/cpu/x86/x86.factor
View File

@ -24,15 +24,20 @@ M: x86 vector-regs float-regs ;
HOOK: stack-reg cpu ( -- reg )
HOOK: reserved-area-size cpu ( -- n )
HOOK: reserved-stack-space cpu ( -- n )
HOOK: extra-stack-space cpu ( stack-frame -- n )
: stack@ ( n -- op ) stack-reg swap [+] ;
: param@ ( n -- op ) reserved-area-size + stack@ ;
: special@ ( n -- op )
stack-frame get extra-stack-space +
reserved-stack-space +
stack@ ;
: spill@ ( n -- op ) spill-offset param@ ;
: spill@ ( n -- op ) spill-offset special@ ;
: gc-root@ ( n -- op ) gc-root-offset param@ ;
: gc-root@ ( n -- op ) gc-root-offset special@ ;
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
@ -44,7 +49,11 @@ HOOK: reserved-area-size cpu ( -- n )
os macosx? cpu x86.64? or [ 16 align ] when ;
M: x86 stack-frame-size ( stack-frame -- i )
(stack-frame-size) 3 cells reserved-area-size + + align-stack ;
[ (stack-frame-size) ]
[ extra-stack-space ] bi +
reserved-stack-space +
3 cells +
align-stack ;
! Must be a volatile register not used for parameter passing, for safe
! use in calls in and out of C
@ -879,12 +888,12 @@ M: x86 %compare-vector ( dst src1 src2 rep cc -- )
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep short-8-rep int-4-rep } }
{ sse4.1? { longlong-2-rep } }
{ sse4.2? { longlong-2-rep } }
} available-reps ;
M: x86 %compare-vector-reps
{
{ [ dup { cc= cc/= } memq? ] [ drop %compare-vector-eq-reps ] }
{ [ dup { cc= cc/= cc/<>= cc<>= } memq? ] [ drop %compare-vector-eq-reps ] }
[ drop %compare-vector-ord-reps ]
} cond ;
@ -1089,7 +1098,7 @@ M: x86 %min-vector ( dst src1 src2 rep -- )
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 } }
{ sse2? { uchar-16-rep short-8-rep double-2-rep } }
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ;
@ -1109,7 +1118,7 @@ M: x86 %max-vector ( dst src1 src2 rep -- )
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 } }
{ sse2? { uchar-16-rep short-8-rep double-2-rep } }
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ;
@ -1337,7 +1346,10 @@ M:: x86 %save-context ( temp1 temp2 callback-allowed? -- )
M: x86 value-struct? drop t ;
M: x86 small-enough? ( n -- ? )
M: x86 immediate-arithmetic? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ;
M: x86 immediate-bitwise? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ;
: next-stack@ ( n -- operand )

12
basis/db/sqlite/ffi/ffi.factor
View File

@ -99,8 +99,8 @@ CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000
CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
TYPEDEF: void sqlite3
TYPEDEF: void sqlite3_stmt
TYPEDEF: void* sqlite3*
TYPEDEF: void* sqlite3_stmt*
TYPEDEF: longlong sqlite3_int64
TYPEDEF: ulonglong sqlite3_uint64
@ -120,8 +120,8 @@ FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
! Bind the same function as above, but for unsigned 64bit integers
: sqlite3-bind-uint64 ( pStmt index in64 -- int )
"int" "sqlite" "sqlite3_bind_int64"
{ "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ;
int "sqlite" "sqlite3_bind_int64"
{ sqlite3_stmt* int sqlite3_uint64 } alien-invoke ;
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
@ -134,8 +134,8 @@ FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
! Bind the same function as above, but for unsigned 64bit integers
: sqlite3-column-uint64 ( pStmt col -- uint64 )
"sqlite3_uint64" "sqlite" "sqlite3_column_int64"
{ "sqlite3_stmt*" "int" } alien-invoke ;
sqlite3_uint64 "sqlite" "sqlite3_column_int64"
{ sqlite3_stmt* int } alien-invoke ;
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;

40
basis/debugger/windows/windows.factor Normal file → Executable file
View File

@ -1,6 +1,42 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: debugger io prettyprint sequences system ;
USING: assocs debugger io kernel literals math.parser namespaces
prettyprint sequences system windows.kernel32 ;
IN: debugger.windows
M: windows signal-error. "Windows exception #" write third .h ;
CONSTANT: seh-names
H{
{ $ STATUS_GUARD_PAGE_VIOLATION "STATUS_GUARD_PAGE_VIOLATION" }
{ $ STATUS_DATATYPE_MISALIGNMENT "STATUS_DATATYPE_MISALIGNMENT" }
{ $ STATUS_BREAKPOINT "STATUS_BREAKPOINT" }
{ $ STATUS_SINGLE_STEP "STATUS_SINGLE_STEP" }
{ $ STATUS_ACCESS_VIOLATION "STATUS_ACCESS_VIOLATION" }
{ $ STATUS_IN_PAGE_ERROR "STATUS_IN_PAGE_ERROR" }
{ $ STATUS_INVALID_HANDLE "STATUS_INVALID_HANDLE" }
{ $ STATUS_NO_MEMORY "STATUS_NO_MEMORY" }
{ $ STATUS_ILLEGAL_INSTRUCTION "STATUS_ILLEGAL_INSTRUCTION" }
{ $ STATUS_NONCONTINUABLE_EXCEPTION "STATUS_NONCONTINUABLE_EXCEPTION" }
{ $ STATUS_INVALID_DISPOSITION "STATUS_INVALID_DISPOSITION" }
{ $ STATUS_ARRAY_BOUNDS_EXCEEDED "STATUS_ARRAY_BOUNDS_EXCEEDED" }
{ $ STATUS_FLOAT_DENORMAL_OPERAND "STATUS_FLOAT_DENORMAL_OPERAND" }
{ $ STATUS_FLOAT_DIVIDE_BY_ZERO "STATUS_FLOAT_DIVIDE_BY_ZERO" }
{ $ STATUS_FLOAT_INEXACT_RESULT "STATUS_FLOAT_INEXACT_RESULT" }
{ $ STATUS_FLOAT_INVALID_OPERATION "STATUS_FLOAT_INVALID_OPERATION" }
{ $ STATUS_FLOAT_OVERFLOW "STATUS_FLOAT_OVERFLOW" }
{ $ STATUS_FLOAT_STACK_CHECK "STATUS_FLOAT_STACK_CHECK" }
{ $ STATUS_FLOAT_UNDERFLOW "STATUS_FLOAT_UNDERFLOW" }
{ $ STATUS_INTEGER_DIVIDE_BY_ZERO "STATUS_INTEGER_DIVIDE_BY_ZERO" }
{ $ STATUS_INTEGER_OVERFLOW "STATUS_INTEGER_OVERFLOW" }
{ $ STATUS_PRIVILEGED_INSTRUCTION "STATUS_PRIVILEGED_INSTRUCTION" }
{ $ STATUS_STACK_OVERFLOW "STATUS_STACK_OVERFLOW" }
{ $ STATUS_CONTROL_C_EXIT "STATUS_CONTROL_C_EXIT" }
{ $ STATUS_FLOAT_MULTIPLE_FAULTS "STATUS_FLOAT_MULTIPLE_FAULTS" }
{ $ STATUS_FLOAT_MULTIPLE_TRAPS "STATUS_FLOAT_MULTIPLE_TRAPS" }
}
: seh-name. ( n -- )
seh-names at [ " (" ")" surround write ] when* ;
M: windows signal-error.
"Windows exception 0x" write
third [ >hex write ] [ seh-name. ] bi nl ;

7
basis/eval/eval.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: splitting parser parser.notes compiler.units kernel namespaces
debugger io.streams.string fry combinators effects.parser ;
USING: splitting parser parser.notes compiler.units kernel
namespaces debugger io.streams.string fry combinators
effects.parser continuations ;
IN: eval
: parse-string ( str -- quot )
@ -19,7 +20,7 @@ SYNTAX: eval( \ eval parse-call( ;
[
"quiet" on
parser-notes off
'[ _ (( -- )) (eval) ] try
'[ _ (( -- )) (eval) ] [ print-error ] recover
] with-string-writer ;
: eval>string ( str -- output )

1
basis/help/handbook/handbook-tests.factor
View File

@ -4,5 +4,4 @@ IN: help.handbook.tests
[ ] [ "article-index" print-topic ] unit-test
[ ] [ "primitive-index" print-topic ] unit-test
[ ] [ "error-index" print-topic ] unit-test
[ ] [ "type-index" print-topic ] unit-test
[ ] [ "class-index" print-topic ] unit-test

4
basis/help/handbook/handbook.factor
View File

@ -239,9 +239,6 @@ ARTICLE: "primitive-index" "Primitive index"
ARTICLE: "error-index" "Error index"
{ $index [ all-errors ] } ;
ARTICLE: "type-index" "Type index"
{ $index [ builtins get sift ] } ;
ARTICLE: "class-index" "Class index"
{ $heading "Built-in classes" }
{ $index [ classes [ builtin-class? ] filter ] }
@ -387,7 +384,6 @@ ARTICLE: "handbook" "Factor handbook"
"article-index"
"primitive-index"
"error-index"
"type-index"
"class-index"
}
{ $heading "Explore the code base" }

2
basis/help/tutorial/tutorial.factor
View File

@ -33,7 +33,7 @@ ARTICLE: "first-program-logic" "Writing some logic in your first program"
$nl
"In order to be able to call the words defined in the " { $snippet "palindrome" } " vocabulary, you need to issue the following command in the listener:"
{ $code "USE: palindrome" }
"Now, we will be making some additions to the file. Since the file was loaded by the scaffold tool in the previous step, you need to tell Factor to reload it if it changes. Factor has a handy feature for this; pressing " { $command tool "common" refresh-all } " in the listener window will reload any changed source files. You can also force a single vocabulary to reload:"
"Now, we will be making some additions to the file. Since the file was loaded by the scaffold tool in the previous step, you need to tell Factor to reload it if it changes. Factor has a handy feature for this; pressing " { $command tool "common" refresh-all } " in the listener window will reload any changed source files. You can also force a single vocabulary to reload, in case the refresh feature does not pick up changes from disk:"
{ $code "\"palindrome\" reload" }
"We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "."
$nl

4
basis/images/bitmap/bitmap.factor
View File

@ -6,8 +6,8 @@ images.loader images.normalization io io.binary
io.encodings.binary io.encodings.string io.files
io.streams.limited kernel locals macros math math.bitwise
math.functions namespaces sequences specialized-arrays
specialized-arrays.instances.uint
specialized-arrays.instances.ushort strings summary ;
strings summary ;
SPECIALIZED-ARRAYS: uint ushort ;
IN: images.bitmap
SINGLETON: bmp-image

5
basis/io/backend/unix/multiplexers/run-loop/run-loop.factor
View File

@ -3,13 +3,14 @@
USING: kernel arrays namespaces math accessors alien locals
destructors system threads io.backend.unix.multiplexers
io.backend.unix.multiplexers.kqueue core-foundation
core-foundation.run-loop ;
core-foundation.run-loop core-foundation.file-descriptors ;
FROM: alien.c-types => void void* ;
IN: io.backend.unix.multiplexers.run-loop
TUPLE: run-loop-mx kqueue-mx ;
: file-descriptor-callback ( -- callback )
"void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" }
void { CFFileDescriptorRef CFOptionFlags void* }
"cdecl" [
3drop
0 mx get kqueue-mx>> wait-for-events

11
basis/io/mmap/mmap-docs.factor
View File

@ -68,8 +68,7 @@ ARTICLE: "io.mmap.arrays" "Working with memory-mapped data"
"The " { $link <mapped-file> } " word returns an instance of " { $link mapped-file } ", which doesn't directly support the sequence protocol. Instead, it needs to be wrapped in a specialized array of the appropriate C type:"
{ $subsections <mapped-array> }
"Additionally, files may be opened with two combinators which take a c-type as input:"
{ $subsections with-mapped-array }
{ $subsections with-mapped-array-reader }
{ $subsections with-mapped-array with-mapped-array-reader }
"The appropriate specialized array type must first be generated with " { $link POSTPONE: SPECIALIZED-ARRAY: } "."
$nl
"Data can also be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. This approach is not recommended, though, since in most cases the compiler will generate efficient code for specialized array usage. See " { $link "reading-writing-memory" } " for a description of low-level memory access primitives." ;
@ -101,10 +100,10 @@ ARTICLE: "io.mmap" "Memory-mapped files"
{ $subsections <mapped-file> }
"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." $nl
"Utility combinators which wrap the above:"
{ $subsections with-mapped-file }
{ $subsections with-mapped-file-reader }
{ $subsections with-mapped-array }
{ $subsections with-mapped-array-reader }
{ $subsections with-mapped-file
with-mapped-file-reader
with-mapped-array
with-mapped-array-reader }
"Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:"
{ $subsections
"io.mmap.arrays"

3
basis/io/mmap/mmap-tests.factor
View File

@ -1,7 +1,8 @@
USING: alien.c-types alien.data compiler.tree.debugger
continuations io.directories io.encodings.ascii io.files
io.files.temp io.mmap kernel math sequences sequences.private
specialized-arrays specialized-arrays.instances.uint tools.test ;
specialized-arrays tools.test ;
SPECIALIZED-ARRAY: uint
IN: io.mmap.tests
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors

75
basis/math/vectors/conversion/conversion-docs.factor Normal file
View File

@ -0,0 +1,75 @@
! (c)2009 Joe Groff bsd license
USING: classes help.markup help.syntax kernel quotations ;
IN: math.vectors.conversion
HELP: bad-vconvert
{ $values
{ "from-type" "a SIMD type" } { "to-type" "a SIMD type" }
}
{ $description "This error is thrown when " { $link vconvert } " is given two SIMD types it cannot directly convert." } ;
HELP: bad-vconvert-input
{ $values
{ "value" object } { "expected-type" class }
}
{ $description "This error is thrown when an input to " { $link vconvert } " does not match the expected " { $snippet "from-type" } "." } ;
{ bad-vconvert bad-vconvert-input } related-words
HELP: vconvert
{ $values
{ "from-type" "a SIMD type" } { "to-type" "a SIMD type" }
}
{ $description "Converts SIMD vectors of " { $snippet "from-type" } " to " { $snippet "to-type" } ". The number of inputs and outputs depends on the relationship of the two types:"
{ $list
{ "If " { $snippet "to-type" } " is a floating-point vector type with the same byte length and element count as the integer vector type " { $snippet "from-type" } " (for example, from " { $snippet "int-8" } " to " { $snippet "float-8" } " or from " { $snippet "longlong-2" } " to " { $snippet "double-2" } "), " { $snippet "vconvert" } " takes one vector of " { $snippet "from-type" } " and converts its elements to floating-point, outputting one vector of " { $snippet "to-type" } "." }
{ "Likewise, if " { $snippet "to-type" } " is an integer vector type with the same byte length and element count as the floating-point vector type " { $snippet "from-type" } ", " { $snippet "vconvert" } " takes one vector of " { $snippet "from-type" } " and truncates its elements to integers, outputting one vector of " { $snippet "to-type" } "." }
{ "If " { $snippet "to-type" } " is a vector type with the same byte length as and twice the element count of the vector type " { $snippet "from-type" } " (for example, from " { $snippet "int-4" } " to " { $snippet "ushort-8" } ", from " { $snippet "double-2" } " to " { $snippet "float-4" } ", or from " { $snippet "short-8" } " to " { $snippet "char-16" } "), " { $snippet "vconvert" } " takes two vectors of " { $snippet "from-type" } " and packs them into one vector of " { $snippet "to-type" } ", saturating values too large or small to be representable as elements of " { $snippet "to-type" } "." }
{ "If " { $snippet "to-type" } " is a vector type with the same byte length as and half the element count of the vector type " { $snippet "from-type" } " (for example, from " { $snippet "ushort-8" } " to " { $snippet "int-4" } ", from " { $snippet "float-4" } " to " { $snippet "double-2" } ", or from " { $snippet "char-16" } " to " { $snippet "short-8" } "), " { $snippet "vconvert" } " takes one vector of " { $snippet "from-type" } " and unpacks it into two vectors of " { $snippet "to-type" } "." }
}
{ $snippet "from-type" } " and " { $snippet "to-type" } " must adhere to the following restrictions; a " { $link bad-vconvert } " error will be thrown otherwise:"
{ $list
{ { $snippet "from-type" } " and " { $snippet "to-type" } " must have the same byte length. You cannot currently convert between 128- and 256-bit vector types." }
{ "For conversions between floating-point and integer vectors, " { $snippet "from-type" } " and " { $snippet "to-type" } " must have the same element length." }
{ "For packing conversions, " { $snippet "from-type" } " and " { $snippet "to-type" } " must be both floating-point or both integer types. Integer types can be packed from signed to unsigned or from unsigned to unsigned types. Unsigned to signed packing is invalid." }
{ "For unpacking conversions, " { $snippet "from-type" } " and " { $snippet "to-type" } " must be both floating-point or both integer types. Integer types can be unpacked from unsigned to signed or from unsigned to unsigned types. Signed to unsigned unpacking is invalid." }
}
}
{ $examples
"Conversion between integer and float vectors:"
{ $example """USING: alien.c-types math.vectors.conversion math.vectors.simd
prettyprint ;
SIMDS: int float longlong double ;
int-8{ 0 1 2 3 4 5 6 7 } int-8 float-8 vconvert .
double-2{ 1.25 3.75 } double-2 longlong-2 vconvert ."""
"""float-8{ 0.0 1.0 2.0 3.0 4.0 5.0 6.0 7.0 }
longlong-2{ 1 3 }""" }
"Packing conversions:"
{ $example """USING: alien.c-types math.vectors.conversion math.vectors.simd
prettyprint ;
SIMDS: ushort int float double ;
int-4{ -8 70000 6000 50 } int-4{ 4 3 2 -1 } int-4 ushort-8 vconvert .
double-4{ 0.0 1.5 1.0e100 2.0 }
double-4{ -1.0e100 0.0 1.0 2.0 } double-4 float-8 vconvert ."""
"""ushort-8{ 0 65535 6000 50 4 3 2 0 }
float-8{ 0.0 1.5 1/0. 2.0 -1/0. 0.0 1.0 2.0 }""" }
"Unpacking conversions:"
{ $example """USING: alien.c-types kernel math.vectors.conversion
math.vectors.simd prettyprint ;
SIMDS: uchar short ;
uchar-16{ 8 70 60 50 4 30 200 1 9 10 110 102 133 143 115 0 }
uchar-16 short-8 vconvert [ . ] bi@"""
"""short-8{ 8 70 60 50 4 30 200 1 }
short-8{ 9 10 110 102 133 143 115 0 }""" }
} ;
ARTICLE: "math.vectors.conversion" "SIMD vector conversion"
"The " { $vocab-link "math.vectors.conversion" } " vocabulary provides facilities for converting SIMD vectors between floating-point and integer representations and between different-sized integer representations."
{ $subsections
vconvert
} ;
ABOUT: "math.vectors.conversion"

1
basis/math/vectors/simd/functor/functor.factor
View File

@ -280,6 +280,7 @@ simd new
} >>special-wrappers
{
{ { +vector+ +vector+ -> +vector+ } A-vv->v-op }
{ { +vector+ +any-vector+ -> +vector+ } A-vv->v-op }
{ { +vector+ +scalar+ -> +vector+ } A-vn->v-op }
{ { +vector+ +literal+ -> +vector+ } A-vn->v-op }
{ { +vector+ +vector+ -> +scalar+ } A-vv->n-op }

16
basis/math/vectors/simd/intrinsics/intrinsics.factor
View File

@ -163,8 +163,8 @@ M: vector-rep supported-simd-op?
{ \ (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-vmin) [ %min-vector-reps cc< %compare-vector-reps union ] }
{ \ (simd-vmax) [ %max-vector-reps cc> %compare-vector-reps union ] }
{ \ (simd-v.) [ %dot-vector-reps ] }
{ \ (simd-vsqrt) [ %sqrt-vector-reps ] }
{ \ (simd-sum) [ %horizontal-add-vector-reps ] }
@ -193,12 +193,12 @@ M: vector-rep supported-simd-op?
{ \ (simd-(vpack-unsigned)) [ %unsigned-pack-vector-reps ] }
{ \ (simd-(vunpack-head)) [ (%unpack-reps) ] }
{ \ (simd-(vunpack-tail)) [ (%unpack-reps) ] }
{ \ (simd-v<=) [ cc<= %compare-vector-reps ] }
{ \ (simd-v<) [ cc< %compare-vector-reps ] }
{ \ (simd-v=) [ cc= %compare-vector-reps ] }
{ \ (simd-v>) [ cc> %compare-vector-reps ] }
{ \ (simd-v>=) [ cc>= %compare-vector-reps ] }
{ \ (simd-vunordered?) [ cc/<>= %compare-vector-reps ] }
{ \ (simd-v<=) [ unsign-rep cc<= %compare-vector-reps ] }
{ \ (simd-v<) [ unsign-rep cc< %compare-vector-reps ] }
{ \ (simd-v=) [ unsign-rep cc= %compare-vector-reps ] }
{ \ (simd-v>) [ unsign-rep cc> %compare-vector-reps ] }
{ \ (simd-v>=) [ unsign-rep cc>= %compare-vector-reps ] }
{ \ (simd-vunordered?) [ unsign-rep cc/<>= %compare-vector-reps ] }
{ \ (simd-gather-2) [ %gather-vector-2-reps ] }
{ \ (simd-gather-4) [ %gather-vector-4-reps ] }
{ \ (simd-vany?) [ %test-vector-reps ] }

13
basis/math/vectors/specialization/specialization.factor
View File

@ -7,12 +7,20 @@ namespaces assocs fry splitting classes.algebra generalizations
locals compiler.tree.propagation.info ;
IN: math.vectors.specialization
SYMBOLS: -> +vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
: parent-vector-class ( type -- type' )
{
{ [ dup simd-128 class<= ] [ drop simd-128 ] }
{ [ dup simd-256 class<= ] [ drop simd-256 ] }
[ "Not a vector class" throw ]
} cond ;
: signature-for-schema ( array-type elt-type schema -- signature )
[
{
{ +vector+ [ drop ] }
{ +any-vector+ [ drop parent-vector-class ] }
{ +scalar+ [ nip ] }
{ +boolean+ [ 2drop boolean ] }
{ +nonnegative+ [ nip ] }
@ -32,6 +40,7 @@ SYMBOLS: -> +vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
[
{
{ +vector+ [ drop <class-info> ] }
{ +any-vector+ [ drop parent-vector-class <class-info> ] }
{ +scalar+ [ nip <class-info> ] }
{ +boolean+ [ 2drop boolean <class-info> ] }
{
@ -101,7 +110,7 @@ H{
{ hlshift { +vector+ +literal+ -> +vector+ } }
{ hrshift { +vector+ +literal+ -> +vector+ } }
{ vshuffle-elements { +vector+ +literal+ -> +vector+ } }
{ vshuffle-bytes { +vector+ +vector+ -> +vector+ } }
{ vshuffle-bytes { +vector+ +any-vector+ -> +vector+ } }
{ vbroadcast { +vector+ +literal+ -> +vector+ } }
{ (vmerge-head) { +vector+ +vector+ -> +vector+ } }
{ (vmerge-tail) { +vector+ +vector+ -> +vector+ } }

58
basis/math/vectors/vectors-docs.factor
View File

@ -55,12 +55,15 @@ ARTICLE: "math-vectors-shuffle" "Vector shuffling, packing, and unpacking"
"These operations are primarily meant to be used with " { $vocab-link "math.vectors.simd" } " types. The software fallbacks for types not supported by hardware will not perform well."
}
$nl
{ $subsection vshuffle }
{ $subsection vbroadcast }
{ $subsection hlshift }
{ $subsection hrshift }
{ $subsection vmerge }
{ $subsection (vmerge) } ;
{ $subsections
vshuffle
vbroadcast
hlshift
hrshift
vmerge
(vmerge)
}
"See the " { $vocab-link "math.vectors.conversion" } " vocabulary for packing, unpacking, and converting vectors." ;
ARTICLE: "math-vectors-logic" "Vector component- and bit-wise logic"
{ $notes
@ -98,6 +101,7 @@ $nl
vxor
vnot
v?
vif
}
"Entire vector tests:"
{ $subsections
@ -416,8 +420,12 @@ HELP: vbroadcast
} ;
HELP: vshuffle
{ $values { "u" "a SIMD array" } { "perm" "an array of integers" } { "v" "a SIMD array" } }
{ $description "Permutes the elements of a SIMD array. Duplicate entries are allowed in the permutation." }
{ $values { "u" "a SIMD array" } { "perm" "an array of integers, or a byte-array" } { "v" "a SIMD array" } }
{ $description "Permutes the elements of a SIMD array. Duplicate entries are allowed in the permutation. The " { $snippet "perm" } " argument can have one of two forms:"
{ $list
{ "A literal array of integers of the same length as the vector. This will perform a static, elementwise shuffle." }
{ "A byte array or SIMD vector of the same byte length as the vector. This will perform a variable bytewise shuffle." }
} }
{ $examples
{ $example
"USING: alien.c-types math.vectors math.vectors.simd" "prettyprint ;"
@ -425,6 +433,29 @@ HELP: vshuffle
"int-4{ 69 42 911 13 } { 1 3 2 3 } vshuffle ."
"int-4{ 42 13 911 13 }"
}
{ $example
"USING: alien.c-types combinators math.vectors math.vectors.simd"
"namespaces prettyprint prettyprint.config ;"
"SIMDS: int uchar ;"
"IN: scratchpad"
""
": endian-swap ( size -- vector )"
" {"
" { 1 [ uchar-16{ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 } ] }"
" { 2 [ uchar-16{ 1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14 } ] }"
" { 4 [ uchar-16{ 3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12 } ] }"
" } case ;"
""
"int-4{ HEX: 11223344 HEX: 11223344 HEX: 11223344 HEX: 11223344 }"
"4 endian-swap vshuffle"
"16 number-base [ . ] with-variable"
"""int-4{
HEX: 44332211
HEX: 44332211
HEX: 44332211
HEX: 44332211
}"""
}
} ;
HELP: norm-sq
@ -504,10 +535,19 @@ HELP: vnot
{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ;
HELP: v?
{ $values { "mask" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "w" "a sequence of numbers" } }
{ $values { "mask" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "result" "a sequence of numbers" } }
{ $description "Creates a new sequence by selecting elements from the " { $snippet "true" } " and " { $snippet "false" } " sequences based on whether the corresponding bits of the " { $snippet "mask" } " sequence are set or not." }
{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ;
HELP: vif
{ $values { "mask" "a sequence of booleans" } { "true-quot" { $quotation "( -- vector )" } } { "false-quot" { $quotation "( -- vector )" } } { "result" "a sequence" } }
{ $description "If all of the elements of " { $snippet "mask" } " are true, " { $snippet "true-quot" } " is called and its output value returned. If all of the elements of " { $snippet "mask" } " are false, " { $snippet "false-quot" } " is called and its output value returned. Otherwise, both quotations are called and " { $snippet "mask" } " is used to select elements from each output as with " { $link v? } "." }
{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types."
$nl
"For most conditional SIMD code, unless a case is exceptionally expensive to compute, it is usually most efficient to just compute all cases and blend them with " { $link v? } " instead of using " { $snippet "vif" } "." } ;
{ v? vif } related-words
HELP: vany?
{ $values { "v" "a sequence of booleans" } { "?" "a boolean" } }
{ $description "Returns true if any element of " { $snippet "v" } " is true." }

39
basis/math/vectors/vectors.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien.c-types assocs kernel sequences math math.functions
hints math.order math.libm fry combinators byte-arrays accessors
locals ;
hints math.order math.libm math.floats.private fry combinators
byte-arrays accessors locals ;
QUALIFIED-WITH: alien.c-types c
IN: math.vectors
@ -29,8 +29,16 @@ M: object element-type drop f ; inline
: [v-] ( u v -- w ) [ [-] ] 2map ;
: v* ( u v -- w ) [ * ] 2map ;
: v/ ( u v -- w ) [ / ] 2map ;
: vmax ( u v -- w ) [ max ] 2map ;
: vmin ( u v -- w ) [ min ] 2map ;
<PRIVATE
: if-both-floats ( x y p q -- )
[ 2dup [ float? ] both? ] 2dip if ; inline
PRIVATE>
: vmax ( u v -- w ) [ [ float-max ] [ max ] if-both-floats ] 2map ;
: vmin ( u v -- w ) [ [ float-min ] [ min ] if-both-floats ] 2map ;
: v+- ( u v -- w )
[ t ] 2dip
@ -92,7 +100,7 @@ PRIVATE>
: vshuffle-bytes ( u perm -- v )
underlying>> [
swap [ '[ _ nth ] ] keep map-as
swap [ '[ 15 bitand _ nth ] ] keep map-as
] curry change-underlying ;
GENERIC: vshuffle ( u perm -- v )
@ -134,9 +142,16 @@ M: simd-128 vshuffle ( u perm -- v )
: vunordered? ( u v -- w ) [ unordered? ] 2map ;
: v= ( u v -- w ) [ = ] 2map ;
: v? ( mask true false -- w )
: v? ( mask true false -- result )
[ vand ] [ vandn ] bi-curry* bi vor ; inline
:: vif ( mask true-quot false-quot -- result )
{
{ [ mask vall? ] [ true-quot call ] }
{ [ mask vnone? ] [ false-quot call ] }
[ mask true-quot call false-quot call v? ]
} cond ; inline
: vfloor ( u -- v ) [ floor ] map ;
: vceiling ( u -- v ) [ ceiling ] map ;
: vtruncate ( u -- v ) [ truncate ] map ;
@ -163,24 +178,24 @@ PRIVATE>
: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv )
[ first lerp ] [ second lerp ] [ third lerp ] tri-curry
[ 2tetra@ ] [ 2bi@ ] [ call ] tri* ;
[ 2tetra@ ] [ 2bi@ ] [ call ] tri* ; inline
: bilerp ( aa ba ab bb {t,u} -- a_tu )
[ first lerp ] [ second lerp ] bi-curry
[ 2bi@ ] [ call ] bi* ;
[ 2bi@ ] [ call ] bi* ; inline
: vlerp ( a b t -- a_t )
[ lerp ] 3map ;
[ over v- ] dip v* v+ ; inline
: vnlerp ( a b t -- a_t )
[ lerp ] curry 2map ;
[ over v- ] dip v*n v+ ; inline
: vbilerp ( aa ba ab bb {t,u} -- a_tu )
[ first vnlerp ] [ second vnlerp ] bi-curry
[ 2bi@ ] [ call ] bi* ;
[ 2bi@ ] [ call ] bi* ; inline
: v~ ( a b epsilon -- ? )
[ ~ ] curry 2all? ;
[ ~ ] curry 2all? ; inline
HINTS: vneg { array } ;
HINTS: norm-sq { array } ;

474
basis/peg/ebnf/ebnf-docs.factor Normal file
View File

@ -0,0 +1,474 @@
! Copyright (C) 2009 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup peg peg.search ;
IN: peg.ebnf
HELP: <EBNF
{ $syntax "<EBNF ...ebnf... EBNF>" }
{ $values { "...ebnf..." "EBNF DSL text" } }
{ $description
"Creates a " { $vocab-link "peg" }
" object that parses a string using the syntax "
"defined with the EBNF DSL. The peg object can be run using the " { $link parse }
" word and can be used with the " { $link search } " and " { $link replace } " words."
}
{ $examples
{ $example
"USING: kernel prettyprint peg.ebnf peg.search ;"
"\"abcdab\" <EBNF rule=\"a\" \"b\" => [[ drop \"foo\" ]] EBNF> replace ."
"\"foocdfoo\""
}
} ;
HELP: [EBNF
{ $syntax "[EBNF ...ebnf... EBNF]" }
{ $values { "...ebnf..." "EBNF DSL text" } }
{ $description
"Creates and calls a quotation that parses a string using the syntax "
"defined with the EBNF DSL. The quotation has stack effect "
{ $snippet "( string -- ast )" } " where 'string' is the text to be parsed "
"and 'ast' is the resulting abstract syntax tree. If the parsing fails the "
"quotation throws an exception."
}
{ $examples
{ $example
"USING: prettyprint peg.ebnf ;"
"\"ab\" [EBNF rule=\"a\" \"b\" EBNF] ."
"V{ \"a\" \"b\" }"
}
} ;
HELP: EBNF:
{ $syntax "EBNF: word ...ebnf... ;EBNF" }
{ $values { "word" "a word" } { "...ebnf..." "EBNF DSL text" } }
{ $description
"Defines a word that when called will parse a string using the syntax "
"defined with the EBNF DSL. The word has stack effect "
{ $snippet "( string -- ast )" } " where 'string' is the text to be parsed "
"and 'ast' is the resulting abstract syntax tree. If the parsing fails the "
"word throws an exception."
}
{ $examples
{ $example
"USING: prettyprint peg.ebnf ;"
"IN: scratchpad"
"EBNF: foo rule=\"a\" \"b\" ;EBNF"
"\"ab\" foo ."
"V{ \"a\" \"b\" }"
}
} ;
ARTICLE: "peg.ebnf.strings" "Strings"
"A string in a rule will match that sequence of characters from the input string. "
"The AST result from the match is the string itself."
{ $examples
{ $example
"USING: prettyprint peg.ebnf ;"
"\"helloworld\" [EBNF rule=\"hello\" \"world\" EBNF] ."
"V{ \"hello\" \"world\" }"
}
} ;
ARTICLE: "peg.ebnf.any" "Any"
"A full stop character (.) will match any single token in the input string. "
"The AST resulting from this is the token itself."
{ $examples
{ $example
"USING: prettyprint peg.ebnf ;"
"\"abc\" [EBNF rule=\"a\" . \"c\" EBNF] ."
"V{ \"a\" 98 \"c\" }"
}
} ;
ARTICLE: "peg.ebnf.sequence" "Sequence"
"Any white space separated rule element is considered a sequence. Each rule "
"in the sequence is matched from the input stream, consuming the input as it "
"goes. The AST result is a vector containing the results of each rule element in "
"the sequence."
{ $examples
{ $example
"USING: prettyprint peg.ebnf ;"
"\"abbba\" [EBNF rule=\"a\" (\"b\")* \"a\" EBNF] ."
"V{ \"a\" V{ \"b\" \"b\" \"b\" } \"a\" }"
}
}
;
ARTICLE: "peg.ebnf.choice" "Choice"
"Any rule element separated by a pipe character (|) is considered a choice. Choices "
"are matched against the input stream in order. If a match succeeds then the remaining "
"choices are discarded and the result of the match is the AST result of the choice."
{ $examples
{ $example
"USING: prettyprint peg.ebnf ;"
"\"a\" [EBNF rule=\"a\" | \"b\" | \"c\" EBNF] ."
"\"a\""
}
{ $example
"USING: prettyprint peg.ebnf ;"
"\"b\" [EBNF rule=\"a\" | \"b\" | \"c\" EBNF] ."
"\"b\""
}
{ $example
"USING: prettyprint peg.ebnf ;"
"\"d\" [EBNF rule=\"a\" | \"b\" | \"c\" EBNF] ."
"Peg parsing error at character position 0.\nExpected token 'c' or token 'b' or token 'a'"
}
}
;
ARTICLE: "peg.ebnf.option" "Option"
"Any rule element followed by a question mark (?) is considered optional. The "
"rule is tested against the input. If it succeeds the result is stored in the AST. "
"If it fails then the parse still suceeds and false (f) is stored in the AST."
{ $examples
{ $example
"USING: prettyprint peg.ebnf ;"
"\"abc\" [EBNF rule=\"a\" \"b\"? \"c\" EBNF] ."
"V{ \"a\" \"b\" \"c\" }"
}
{ $example
"USING: prettyprint peg.ebnf ;"
"\"ac\" [EBNF rule=\"a\" \"b\"? \"c\" EBNF] ."
"V{ \"a\" f \"c\" }"
}
}
;
ARTICLE: "peg.ebnf.character-class" "Character Class"
"Character class matching can be done using a range of characters defined in "
"square brackets. Multiple ranges can be included in a single character class "
"definition. The syntax for the range is a start character, followed by a minus "
"(-) followed by an end character. For example " { $snippet "[a-zA-Z]" } ". "
"The AST resulting from the match is an integer of the character code for the "
"character that matched."
{ $examples
{ $example
"USING: prettyprint peg.ebnf ;"
"\"123\" [EBNF rule=[0-9]+ EBNF] ."
"V{ 49 50 51 }"
}
}
;
ARTICLE: "peg.ebnf.one-or-more" "One or more"
"Any rule element followed by a plus (+) matches one or more instances of the rule "
"from the input string. The AST result is the vector of the AST results from "
"the matched rule."
{ $examples
{ $example
"USING: prettyprint peg.ebnf ;"
"\"aab\" [EBNF rule=\"a\"+ \"b\" EBNF] ."
"V{ V{ \"a\" \"a\" } \"b\" }"
}
}
;
ARTICLE: "peg.ebnf.zero-or-more" "Zero or more"
"Any rule element followed by an asterisk (*) matches zero or more instances of the rule "
"from the input string. The AST result is the vector of the AST results from "
"the matched rule. This will be empty if there are no matches."
{ $examples
{ $example
"USING: prettyprint peg.ebnf ;"
"\"aab\" [EBNF rule=\"a\"* \"b\" EBNF] ."
"V{ V{ \"a\" \"a\" } \"b\" }"
}
{ $example
"USING: prettyprint peg.ebnf ;"
"\"b\" [EBNF rule=\"a\"* \"b\" EBNF] ."
"V{ V{ } \"b\" }"
}
}
;
ARTICLE: "peg.ebnf.and" "And"
"Any rule element prefixed by an ampersand (&) performs the Parsing Expression "
"Grammar 'And Predicate' match. It attempts to match the rule against the input "
"string. It will cause the parse to succeed or fail depending on if the rule "
"succeeds or fails. It will not consume anything from the input string however and "
"does not leave any result in the AST. This can be used for lookahead and "
"disambiguation in choices."
{ $examples
{ $example
"USING: prettyprint peg.ebnf ;"
"\"ab\" [EBNF rule=&(\"a\") \"a\" \"b\" EBNF] ."
"V{ \"a\" \"b\" }"
}
}
;
ARTICLE: "peg.ebnf.not" "Not"
"Any rule element prefixed by an exclamation mark (!) performs the Parsing Expression "
"Grammar 'Not Predicate' match. It attempts to match the rule against the input "
"string. It will cause the parse to succeed if the rule match fails, and to fail "
"if the rule match succeeds. It will not consume anything from the input string "
"however and does not leave any result in the AST. This can be used for lookahead and "
"disambiguation in choices."
{ $examples
{ $example
"USING: prettyprint peg.ebnf ;"
"\"<abcd>\" [EBNF rule=\"<\" (!(\">\") .)* \">\" EBNF] ."
"V{ \"<\" V{ 97 98 99 100 } \">\" }"
}
}
;
ARTICLE: "peg.ebnf.action" "Action"
"An action is a quotation that is run after a rule matches. The quotation "
"consumes the AST of the rule match and leaves a new AST as the result. "
"The stack effect of the action can be " { $snippet "( ast -- ast )" } " or "
{ $snippet "( -- ast )" } ". "
"If it is the latter then the original AST is implcitly dropped and will be "
"replaced by the AST left on the stack. This is mostly useful if variables are "
"used in the rule since they can be referenced like locals in the action quotation. "
"The action is defined by having a ' => ' at the end of a rule and "
"using '[[' and ']]' to open and close the quotation. "
"If an action leaves the object 'ignore' on the stack then the result of that "
"action will not be put in the AST of the result."
{ $examples
{ $example
"USING: prettyprint peg.ebnf strings ;"
"\"<abcd>\" [EBNF rule=\"<\" ((!(\">\") .)* => [[ >string ]]) \">\" EBNF] ."
"V{ \"<\" \"abcd\" \">\" }"
}
{ $example
"USING: prettyprint peg.ebnf math.parser ;"
"\"123\" [EBNF rule=[0-9]+ => [[ string>number ]] EBNF] ."
"123"
}
}
;
ARTICLE: "peg.ebnf.semantic-action" "Semantic Action"
"Semantic actions allow providing a quotation that gets run on the AST of a "
"matched rule that returns success or failure. The result of the parse is decided by "
"the result of the semantic action. The stack effect for the quotation is "
{ $snippet ( ast -- ? ) } ". "
"A semantic action follows the rule it applies to and is delimeted by '?[' and ']?'."
{ $examples
{ $example
"USING: prettyprint peg.ebnf math math.parser ;"
"\"1\" [EBNF rule=[0-9] ?[ digit> odd? ]? EBNF] ."
"49"
}
{ $example
"USING: prettyprint peg.ebnf math math.parser ;"
"\"2\" [EBNF rule=[0-9] ?[ digit> odd? ]? EBNF] ."
"Sequence index out of bounds\nindex 0\nseq V{ }"
}
}
;
ARTICLE: "peg.ebnf.variable" "Variable"
"Variables names can be suffixed to a rule element using the colon character (:) "
"followed by the variable name. These can then be used in rule actions to refer to "
"the AST result of the rule element with that variable name."
{ $examples
{ $example
"USING: prettyprint peg.ebnf math.parser ;"
"\"1+2\" [EBNF rule=[0-9]:a \"+\" [0-9]:b => [[ a digit> b digit> + ]] EBNF] ."
"3"
}
}
;
ARTICLE: "peg.ebnf.foreign-rules" "Foreign Rules"
"Rules can call outto other peg.ebnf defined parsers. The result of "
"the foreign call then becomes the AST of the successful parse. Foreign rules "
"are invoked using '<foreign word-name>' or '<foreign word-name rule>'. The "
"latter allows calling a specific rule in a previously designed peg.ebnf parser. "
"If the 'word-name' is not the name of a peg.ebnf defined parser then it must be "
"a word with stack effect " { $snippet "( -- parser )" } ". It must return a "
{ $vocab-link "peg" } " defined parser and it will be called to perform the parse "
"for that rule."
{ $examples
{ $code
"USING: prettyprint peg.ebnf ;"
"EBNF: parse-string"
"StringBody = (!('\"') .)*"
"String= '\"' StringBody:b '\"' => [[ b >string ]]"
";EBNF"
"EBNF: parse-two-strings"
"TwoStrings = <foreign parse-string String> <foreign parse-string String>"
";EBNF"
"EBNF: parse-two-strings"
"TwoString = <foreign parse-string> <foreign parse-string>"
";EBNF"
}
{ $code
": a-token ( -- parser ) \"a\" token ;"
"EBNF: parse-abc"
"abc = <foreign a-token> 'b' 'c'"
";EBNF"
}
}
;
ARTICLE: "peg.ebnf.tokenizers" "Tokenizers"
"It is possible to override the tokenizer in an EBNF defined parser. "
"Usually the input sequence to be parsed is an array of characters or a string. "
"Terminals in a rule match successive characters in the array or string. "
{ $examples
{ $code
"EBNF: foo"
"rule = \"++\" \"--\""
";EBNF"
}
}
"This parser when run with the string \"++--\" or the array "
"{ CHAR: + CHAR: + CHAR: - CHAR: - } will succeed with an AST of { \"++\" \"--\" }. "
"If you want to add whitespace handling to the grammar you need to put it "
"between the terminals: "
{ $examples
{ $code
"EBNF: foo"
"space = (\" \" | \"\\r\" | \"\\t\" | \"\\n\")"
"spaces = space* => [[ drop ignore ]]"
"rule = spaces \"++\" spaces \"--\" spaces"
";EBNF"
}
}
"In a large grammar this gets tedious and makes the grammar hard to read. "
"Instead you can write a rule to split the input sequence into tokens, and "
"have the grammar operate on these tokens. This is how the previous example "
"might look: "
{ $examples
{ $code
"EBNF: foo"
"space = (\" \" | \"\\r\" | \"\\t\" | \"\\n\")"
"spaces = space* => [[ drop ignore ]]"
"tokenizer = spaces ( \"++\" | \"--\" )"
"rule = \"++\" \"--\""
";EBNF"
}
}
"'tokenizer' is the name of a built in rule. Once defined it is called to "
"retrieve the next complete token from the input sequence. So the first part "
"of 'rule' is to try and match \"++\". It calls the tokenizer to get the next "
"complete token. This ignores spaces until it finds a \"++\" or \"--\". "
"It is as if the input sequence for the parser was actually { \"++\" \"--\" } "
"instead of the string \"++--\". With the new tokenizer \"....\" sequences "
"in the grammar are matched for equality against the token, rather than a "
"string comparison against successive items in the sequence. This can be used "
"to match an AST from a tokenizer. "
$nl
"In this example I split the tokenizer into a separate parser and use "
"'foreign' to call it from the main one. This allows testing of the "
"tokenizer separately: "
{ $examples
{ $example
"USING: prettyprint peg peg.ebnf kernel math.parser strings"
"accessors math arrays ;"
"IN: scratchpad"
""
"TUPLE: ast-number value ;"
"TUPLE: ast-string value ;"
""
"EBNF: foo-tokenizer"
"space = (\" \" | \"\\r\" | \"\\t\" | \"\\n\")"
"spaces = space* => [[ drop ignore ]]"
""
"number = [0-9]+ => [[ >string string>number ast-number boa ]]"
"operator = (\"+\" | \"-\")"
""
"token = spaces ( number | operator )"
"tokens = token*"
";EBNF"
""
"EBNF: foo"
"tokenizer = <foreign foo-tokenizer token>"
""
"number = . ?[ ast-number? ]? => [[ value>> ]]"
"string = . ?[ ast-string? ]? => [[ value>> ]]"
""
"rule = string:a number:b \"+\" number:c => [[ a b c + 2array ]]"
";EBNF"
""
"\"123 456 +\" foo-tokenizer ."
"V{\n T{ ast-number { value 123 } }\n T{ ast-number { value 456 } }\n \"+\"\n}"
}
}
"The '.' EBNF production means match a single object in the source sequence. "
"Usually this is a character. With the replacement tokenizer it is either a "
"number object, a string object or a string containing the operator. "
"Using a tokenizer in language grammars makes it easier to deal with whitespace. "
"Defining tokenizers in this way has the advantage of the tokenizer and parser "
"working in one pass. There is no tokenization occurring over the whole string "
"followed by the parse of that result. It tokenizes as it needs to. You can even "
"switch tokenizers multiple times during a grammar. Rules use the tokenizer that "
"was defined lexically before the rule. This is usefull in the JavaScript grammar: "
{ $examples
{ $code
"EBNF: javascript"
"tokenizer = default"
"nl = \"\\r\" \"\\n\" | \"\\n\""
"tokenizer = <foreign tokenize-javascript Tok>"
"..."
"End = !(.)"
"Name = . ?[ ast-name? ]? => [[ value>> ]] "
"Number = . ?[ ast-number? ]? => [[ value>> ]]"
"String = . ?[ ast-string? ]? => [[ value>> ]]"
"RegExp = . ?[ ast-regexp? ]? => [[ value>> ]]"
"SpacesNoNl = (!(nl) Space)* => [[ ignore ]]"
"Sc = SpacesNoNl (nl | &(\"}\") | End)| \";\""
}
}
"Here the rule 'nl' is defined using the default tokenizer of sequential "
"characters ('default' has the special meaning of the built in tokenizer). "
"This is followed by using the JavaScript tokenizer for the remaining rules. "
"This tokenizer strips out whitespace and newlines. Some rules in the grammar "
"require checking for a newline. In particular the automatic semicolon insertion "
"rule (managed by the 'Sc' rule here). If there is a newline, the semicolon can "
"be optional in places. "
{ $examples
{ $code
"\"do\" Stmt:s \"while\" \"(\" Expr:c \")\" Sc => [[ s c ast-do-while boa ]]"
}
}
"Even though the JavaScript tokenizer has removed the newlines, the 'nl' rule can "
"be used to detect them since it is using the default tokenizer. This allows "
"grammars to mix and match the tokenizer as required to make them more readable."
;
ARTICLE: "peg.ebnf" "EBNF"
"The " { $vocab-link "peg.ebnf" } " vocabulary provides a DSL that allows writing PEG parsers that look like "
"EBNF syntax. It provides three parsing words described below. These words all "
"accept the same EBNF syntax. The difference is in how they are used. "
{ $subsection POSTPONE: <EBNF }
{ $subsection POSTPONE: [EBNF }
{ $subsection POSTPONE: EBNF: }
"The EBNF syntax is composed of a series of rules of the form: "
{ $code
"rule1 = ..."
"rule2 = ..."
}
"The last defined rule is the main rule for the EBNF. It is the first one run "
"and it is expected that the remaining rules are used by that rule. Rules may be "
"left recursive. "
"Each rule can contain the following: "
{ $subsection "peg.ebnf.strings" }
{ $subsection "peg.ebnf.any" }
{ $subsection "peg.ebnf.sequence" }
{ $subsection "peg.ebnf.choice" }
{ $subsection "peg.ebnf.option" }
{ $subsection "peg.ebnf.one-or-more" }
{ $subsection "peg.ebnf.zero-or-more" }
{ $subsection "peg.ebnf.and" }
{ $subsection "peg.ebnf.not" }
{ $subsection "peg.ebnf.character-class" }
{ $subsection "peg.ebnf.foreign-rules" }
{ $subsection "peg.ebnf.action" }
{ $subsection "peg.ebnf.semantic-action" }
{ $subsection "peg.ebnf.variable" }
"Grammars defined in EBNF need to handle each character, or sequence of "
"characters in the input. This can be tedious for dealing with whitespace in "
"grammars that have 'tokens' separated by whitespace. You can define your "
"own tokenizer that for an EBNF grammar, and write the grammar in terms of "
"those tokens, allowing you to ignore the whitespace issue. The tokenizer "
"can be changed at various parts in the grammar as needed. The JavaScript grammar "
"does this to define the optional semicolon rule for example."
{ $subsection "peg.ebnf.tokenizers" }
;
ABOUT: "peg.ebnf"

6
basis/peg/ebnf/ebnf-tests.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf words math math.parser
sequences accessors peg.parsers parser namespaces arrays
strings eval unicode.data multiline ;
USING: kernel tools.test peg peg.ebnf peg.ebnf.private words
math math.parser sequences accessors peg.parsers parser
namespaces arrays strings eval unicode.data multiline ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [

4
basis/peg/ebnf/ebnf.factor
View File

@ -16,6 +16,8 @@ IN: peg.ebnf
ERROR: no-rule rule parser ;
<PRIVATE
: lookup-rule ( rule parser -- rule' )
2dup rule [ 2nip ] [ no-rule ] if* ;
@ -540,6 +542,8 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
parse-ebnf dup dup parser [ main swap at compile ] with-variable
[ compiled-parse ] curry [ with-scope ast>> ] curry ;
PRIVATE>
SYNTAX: <EBNF
"EBNF>"
reset-tokenizer parse-multiline-string parse-ebnf main swap at

17
basis/random/sfmt/sfmt.factor
View File

@ -4,7 +4,7 @@ USING: accessors alien.c-types kernel locals math math.ranges
math.bitwise math.vectors math.vectors.simd random
sequences specialized-arrays sequences.private classes.struct
combinators.short-circuit fry ;
SIMD: uint
SIMDS: uchar uint ;
SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: uint-4
IN: random.sfmt
@ -28,14 +28,25 @@ TUPLE: sfmt
{ uint-array uint-array }
{ uint-4-array uint-4-array } ;
: endian-shuffle ( v -- w )
little-endian? [
uchar-16{ 3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12 } vshuffle
] unless ; inline
: hlshift* ( v n -- w )
[ endian-shuffle ] dip hlshift endian-shuffle ; inline
: hrshift* ( v n -- w )
[ endian-shuffle ] dip hrshift endian-shuffle ; inline
: wA ( w -- wA )
dup 1 hlshift vbitxor ; inline
dup 1 hlshift* vbitxor ; inline
: wB ( w mask -- wB )
[ 11 vrshift ] dip vbitand ; inline
: wC ( w -- wC )
1 hrshift ; inline
1 hrshift* ; inline
: wD ( w -- wD )
18 vlshift ; inline

2
basis/specialized-arrays/specialized-arrays-docs.factor
View File

@ -86,7 +86,7 @@ ARTICLE: "specialized-array-examples" "Specialized array examples"
ARTICLE: "specialized-arrays" "Specialized arrays"
"The " { $vocab-link "specialized-arrays" } " vocabulary implements fixed-length sequence types for storing machine values in a space-efficient manner without boxing."
$nl
"A specialized array type needs to be generated for each element type. This is done with a parsing word:"
"A specialized array type needs to be generated for each element type. This is done with parsing words:"
{ $subsections
POSTPONE: SPECIALIZED-ARRAY:
POSTPONE: SPECIALIZED-ARRAYS:

16
basis/specialized-arrays/specialized-arrays-tests.factor
View File

@ -4,7 +4,7 @@ specialized-arrays.private sequences alien.c-types accessors
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 math.vectors ;
assocs prettyprint alien.data math.vectors definitions ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: int
@ -120,10 +120,7 @@ SPECIALIZED-ARRAY: fixed-string
[ "int-array@ f 100" ] [ f 100 <direct-int-array> unparse ] unit-test
! If the C type doesn't exist, don't generate a vocab
[ ] [
[ "__does_not_exist__" specialized-array-vocab forget-vocab ] with-compilation-unit
"__does_not_exist__" c-types get delete-at
] unit-test
SYMBOL: __does_not_exist__
[
"""
@ -146,6 +143,13 @@ SPECIALIZED-ARRAY: __does_not_exist__
[ f ] [
"__does_not_exist__-array{"
"__does_not_exist__" specialized-array-vocab lookup
__does_not_exist__ specialized-array-vocab lookup
deferred?
] unit-test
[ ] [
[
\ __does_not_exist__ forget
__does_not_exist__ specialized-array-vocab forget-vocab
] with-compilation-unit
] unit-test

24
basis/specialized-arrays/specialized-arrays.factor
View File

@ -6,7 +6,7 @@ libc math math.vectors math.vectors.private
math.vectors.specialization namespaces
parser prettyprint.custom sequences sequences.private strings
summary vocabs vocabs.loader vocabs.parser vocabs.generated
words fry combinators present ;
words fry combinators make ;
IN: specialized-arrays
MIXIN: specialized-array
@ -125,11 +125,13 @@ M: word (underlying-type) "c-type" word-prop ;
[ drop ]
} cond ;
: underlying-type-name ( c-type -- name )
underlying-type present ;
: specialized-array-vocab ( c-type -- vocab )
present "specialized-arrays.instances." prepend ;
[
"specialized-arrays.instances." %
[ vocabulary>> % "." % ]
[ name>> % ]
bi
] "" make ;
PRIVATE>
@ -143,18 +145,18 @@ M: c-type-name require-c-array define-array-vocab drop ;
ERROR: specialized-array-vocab-not-loaded c-type ;
M: c-type-name c-array-constructor
underlying-type-name
dup [ "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup
underlying-type
dup [ name>> "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
M: c-type-name c-(array)-constructor
underlying-type-name
dup [ "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup
underlying-type
dup [ name>> "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
M: c-type-name c-direct-array-constructor
underlying-type-name
dup [ "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup
underlying-type
dup [ name>> "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
SYNTAX: SPECIALIZED-ARRAYS:

13
basis/specialized-vectors/specialized-vectors-docs.factor
View File

@ -6,6 +6,13 @@ HELP: SPECIALIZED-VECTOR:
{ $values { "type" "a C type" } }
{ $description "Brings a specialized vector for holding values of " { $snippet "type" } " into the vocabulary search path. The generated words are documented in " { $link "specialized-vector-words" } "." } ;
HELP: SPECIALIZED-VECTORS:
{ $syntax "SPECIALIZED-VECTORS: type type type ... ;" }
{ $values { "type" "a C type" } }
{ $description "Brings a set of specialized vectors for holding values of each " { $snippet "type" } " into the vocabulary search path. The generated words are documented in " { $link "specialized-vector-words" } "." } ;
{ POSTPONE: SPECIALIZED-VECTOR: POSTPONE: SPECIALIZED-VECTORS: } related-words
ARTICLE: "specialized-vector-words" "Specialized vector words"
"The " { $link POSTPONE: SPECIALIZED-VECTOR: } " parsing word generates the specialized vector type if it hasn't been generated already, and adds the following words to the vocabulary search path, where " { $snippet "T" } " is the C type in question:"
{ $table
@ -21,6 +28,12 @@ ARTICLE: "specialized-vector-c" "Passing specialized vectors to C functions"
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."
$nl
"A specialized vector type needs to be generated for each element type. This is done with parsing words:"
{ $subsections
POSTPONE: SPECIALIZED-VECTOR:
POSTPONE: SPECIALIZED-VECTORS:
}
{ $subsections
"specialized-vector-words"
"specialized-vector-c"

3
basis/specialized-vectors/specialized-vectors-tests.factor
View File

@ -2,8 +2,7 @@ IN: specialized-vectors.tests
USING: specialized-arrays specialized-vectors
tools.test kernel sequences alien.c-types ;
SPECIALIZED-ARRAY: float
SPECIALIZED-VECTOR: float
SPECIALIZED-VECTOR: double
SPECIALIZED-VECTORS: float double ;
[ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test

27
basis/specialized-vectors/specialized-vectors.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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 vocabs.generated fry ;
USING: accessors alien.c-types alien.parser assocs
compiler.units functors growable kernel lexer namespaces parser
prettyprint.custom sequences specialized-arrays
specialized-arrays.private strings vocabs vocabs.parser
vocabs.generated fry make ;
QUALIFIED: vectors.functor
IN: specialized-vectors
@ -41,8 +42,13 @@ INSTANCE: V S
;FUNCTOR
: specialized-vector-vocab ( type -- vocab )
"specialized-vectors.instances." prepend ;
: specialized-vector-vocab ( c-type -- vocab )
[
"specialized-vectors.instances." %
[ vocabulary>> % "." % ]
[ name>> % ]
bi
] "" make ;
PRIVATE>
@ -51,7 +57,14 @@ PRIVATE>
[ specialized-vector-vocab ] [ '[ _ define-vector ] ] bi
generate-vocab ;
SYNTAX: SPECIALIZED-VECTORS:
";" parse-tokens [
parse-c-type
[ define-array-vocab use-vocab ]
[ define-vector-vocab use-vocab ] bi
] each ;
SYNTAX: SPECIALIZED-VECTOR:
scan
scan-c-type
[ define-array-vocab use-vocab ]
[ define-vector-vocab use-vocab ] bi ;

6
basis/stack-checker/stack-checker-docs.factor
View File

@ -54,7 +54,7 @@ $nl
{ $heading "Limitations" }
"Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:"
{ $example
"[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help."
"[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected"
}
"To make this work, pass the quotation on the retain stack instead:"
{ $example
@ -74,7 +74,7 @@ $nl
"Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:"
{ $heading "Input quotation declaration" }
"Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:"
{ $example ": bad ( quot -- ) [ call ] keep bad ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
{ $example ": bad ( quot -- ) [ call ] keep bad ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected" }
"The following is correct:"
{ $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" }
"The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter."
@ -82,7 +82,7 @@ $nl
"The stack checker does not trace data flow in two instances."
$nl
"An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:"
{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected" }
"However a small change can be made:"
{ $example ": good ( ? quot: ( ? -- ) -- ) [ good ] 2keep [ not ] dip call ; inline recursive" "[ [ drop ] good ] infer." "( object -- )" }
"An inline recursive word must have a fixed stack effect in its base case. The following will not infer:"

2
basis/system-info/linux/linux.factor
View File

@ -7,7 +7,7 @@ SPECIALIZED-ARRAY: char
IN: system-info.linux
: (uname) ( buf -- int )
"int" f "uname" { "char*" } alien-invoke ;
int f "uname" { char* } alien-invoke ;
: uname ( -- seq )
65536 <char-array> [ (uname) io-error ] keep

4
basis/tools/deploy/deploy-tests.factor
View File

@ -22,7 +22,7 @@ IN: tools.deploy.tests
[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test
[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test
[ t ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test
[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
@ -114,4 +114,4 @@ os macosx? [
rest
] unit-test
[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test
[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test

8
basis/tools/deploy/test/14/14.factor
View File

@ -1,7 +1,9 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes.struct cocoa cocoa.classes
cocoa.subclassing core-graphics.types kernel math ;
cocoa.runtime cocoa.subclassing cocoa.types core-graphics.types
kernel math ;
FROM: alien.c-types => float ;
IN: tools.deploy.test.14
CLASS: {
@ -9,8 +11,8 @@ CLASS: {
{ +name+ "Bar" }
} {
"bar:"
"float"
{ "id" "SEL" "NSRect" }
float
{ id SEL NSRect }
[
[ origin>> [ x>> ] [ y>> ] bi + ]
[ size>> [ w>> ] [ h>> ] bi + ]

6
basis/tools/deploy/test/9/9.factor
View File

@ -1,10 +1,10 @@
USING: alien kernel math ;
USING: alien alien.c-types kernel math ;
IN: tools.deploy.test.9
: callback-test ( -- callback )
"int" { "int" } "cdecl" [ 1 + ] alien-callback ;
int { int } "cdecl" [ 1 + ] alien-callback ;
: indirect-test ( -- )
10 callback-test "int" { "int" } "cdecl" alien-indirect 11 assert= ;
10 callback-test int { int } "cdecl" alien-indirect 11 assert= ;
MAIN: indirect-test

2
basis/tools/deploy/test/test.factor
View File

@ -25,4 +25,4 @@ IN: tools.deploy.test
"-i=" "test.image" temp-file append 2array ;
: run-temp-image ( -- )
deploy-test-command try-output-process ;
deploy-test-command try-output-process ;

4
basis/tools/profiler/profiler-tests.factor
View File

@ -21,9 +21,9 @@ words ;
[ ] [ \ + usage-profile. ] unit-test
: callback-test ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
: callback-test ( -- callback ) void { } "cdecl" [ ] alien-callback ;
: indirect-test ( callback -- ) "void" { } "cdecl" alien-indirect ;
: indirect-test ( callback -- ) void { } "cdecl" alien-indirect ;
: foobar ( -- ) ;

6
basis/typed/debugger/debugger.factor
View File

@ -1,5 +1,6 @@
! (c)Joe Groff bsd license
USING: typed compiler.cfg.debugger compiler.tree.debugger words ;
USING: typed compiler.cfg.debugger compiler.tree.debugger
tools.disassembler words ;
IN: typed.debugger
: typed-test-mr ( word -- mrs )
@ -8,3 +9,6 @@ IN: typed.debugger
"typed-word" word-prop test-mr mr. ; inline
: typed-optimized. ( word -- )
"typed-word" word-prop optimized. ; inline
: typed-disassemble ( word -- )
"typed-word" word-prop disassemble ; inline

2
basis/ui/backend/cocoa/cocoa.factor
View File

@ -218,7 +218,7 @@ CLASS: {
{ +name+ "FactorApplicationDelegate" }
}
{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
{ "applicationDidUpdate:" void { id SEL id }
[ 3drop reset-run-loop ]
} ;

39
basis/ui/backend/cocoa/tools/tools.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax cocoa cocoa.nibs cocoa.application
cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
core-foundation core-foundation.strings help.topics kernel
memory namespaces parser system ui ui.tools.browser
ui.tools.listener ui.backend.cocoa eval locals
vocabs.refresh ;
cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.runtime
cocoa.subclassing core-foundation core-foundation.strings
help.topics kernel memory namespaces parser system ui
ui.tools.browser ui.tools.listener ui.backend.cocoa eval
locals vocabs.refresh ;
FROM: alien.c-types => int void ;
IN: ui.backend.cocoa.tools
: finder-run-files ( alien -- )
@ -25,43 +26,43 @@ CLASS: {
{ +name+ "FactorWorkspaceApplicationDelegate" }
}
{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
{ "application:openFiles:" void { id SEL id id }
[ [ 3drop ] dip finder-run-files ]
}
{ "applicationShouldHandleReopen:hasVisibleWindows:" "int" { "id" "SEL" "id" "int" }
{ "applicationShouldHandleReopen:hasVisibleWindows:" int { id SEL id int }
[ [ 3drop ] dip 0 = [ show-listener ] when 1 ]
}
{ "factorListener:" "id" { "id" "SEL" "id" }
{ "factorListener:" id { id SEL id }
[ 3drop show-listener f ]
}
{ "factorBrowser:" "id" { "id" "SEL" "id" }
{ "factorBrowser:" id { id SEL id }
[ 3drop show-browser f ]
}
{ "newFactorListener:" "id" { "id" "SEL" "id" }
{ "newFactorListener:" id { id SEL id }
[ 3drop listener-window f ]
}
{ "newFactorBrowser:" "id" { "id" "SEL" "id" }
{ "newFactorBrowser:" id { id SEL id }
[ 3drop browser-window f ]
}
{ "runFactorFile:" "id" { "id" "SEL" "id" }
{ "runFactorFile:" id { id SEL id }
[ 3drop menu-run-files f ]
}
{ "saveFactorImage:" "id" { "id" "SEL" "id" }
{ "saveFactorImage:" id { id SEL id }
[ 3drop save f ]
}
{ "saveFactorImageAs:" "id" { "id" "SEL" "id" }
{ "saveFactorImageAs:" id { id SEL id }
[ 3drop menu-save-image f ]
}
{ "refreshAll:" "id" { "id" "SEL" "id" }
{ "refreshAll:" id { id SEL id }
[ 3drop [ refresh-all ] \ refresh-all call-listener f ]
} ;
@ -79,13 +80,13 @@ CLASS: {
{ +name+ "FactorServiceProvider" }
} {
"evalInListener:userData:error:"
"void"
{ "id" "SEL" "id" "id" "id" }
void
{ id SEL id id id }
[ nip [ eval-listener f ] do-service 2drop ]
} {
"evalToString:userData:error:"
"void"
{ "id" "SEL" "id" "id" "id" }
void
{ id SEL id id id }
[ nip [ eval>string ] do-service 2drop ]
} ;

120
basis/ui/backend/cocoa/views/views.factor
View File

@ -3,8 +3,8 @@
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing
cocoa.classes cocoa.views cocoa.application cocoa.pasteboard
cocoa.types cocoa.windows sequences io.encodings.utf8 ui ui.private
ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
cocoa.runtime cocoa.types cocoa.windows sequences io.encodings.utf8
ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
core-foundation.strings core-graphics core-graphics.types threads
combinators math.rectangles ;
IN: ui.backend.cocoa.views
@ -148,76 +148,76 @@ CLASS: {
}
! Rendering
{ "drawRect:" "void" { "id" "SEL" "NSRect" }
{ "drawRect:" void { id SEL NSRect }
[ 2drop window relayout-1 yield ]
}
! Events
{ "acceptsFirstMouse:" "char" { "id" "SEL" "id" }
{ "acceptsFirstMouse:" char { id SEL id }
[ 3drop 1 ]
}
{ "mouseEntered:" "void" { "id" "SEL" "id" }
{ "mouseEntered:" void { id SEL id }
[ nip send-mouse-moved ]
}
{ "mouseExited:" "void" { "id" "SEL" "id" }
{ "mouseExited:" void { id SEL id }
[ 3drop forget-rollover ]
}
{ "mouseMoved:" "void" { "id" "SEL" "id" }
{ "mouseMoved:" void { id SEL id }
[ nip send-mouse-moved ]
}
{ "mouseDragged:" "void" { "id" "SEL" "id" }
{ "mouseDragged:" void { id SEL id }
[ nip send-mouse-moved ]
}
{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
{ "rightMouseDragged:" void { id SEL id }
[ nip send-mouse-moved ]
}
{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
{ "otherMouseDragged:" void { id SEL id }
[ nip send-mouse-moved ]
}
{ "mouseDown:" "void" { "id" "SEL" "id" }
{ "mouseDown:" void { id SEL id }
[ nip send-button-down$ ]
}
{ "mouseUp:" "void" { "id" "SEL" "id" }
{ "mouseUp:" void { id SEL id }
[ nip send-button-up$ ]
}
{ "rightMouseDown:" "void" { "id" "SEL" "id" }
{ "rightMouseDown:" void { id SEL id }
[ nip send-button-down$ ]
}
{ "rightMouseUp:" "void" { "id" "SEL" "id" }
{ "rightMouseUp:" void { id SEL id }
[ nip send-button-up$ ]
}
{ "otherMouseDown:" "void" { "id" "SEL" "id" }
{ "otherMouseDown:" void { id SEL id }
[ nip send-button-down$ ]
}
{ "otherMouseUp:" "void" { "id" "SEL" "id" }
{ "otherMouseUp:" void { id SEL id }
[ nip send-button-up$ ]
}
{ "scrollWheel:" "void" { "id" "SEL" "id" }
{ "scrollWheel:" void { id SEL id }
[ nip send-wheel$ ]
}
{ "keyDown:" "void" { "id" "SEL" "id" }
{ "keyDown:" void { id SEL id }
[ nip send-key-down-event ]
}
{ "keyUp:" "void" { "id" "SEL" "id" }
{ "keyUp:" void { id SEL id }
[ nip send-key-up-event ]
}
{ "validateUserInterfaceItem:" "char" { "id" "SEL" "id" }
{ "validateUserInterfaceItem:" char { id SEL id }
[
nip -> action
2dup [ window ] [ utf8 alien>string ] bi* validate-action
@ -225,57 +225,57 @@ CLASS: {
]
}
{ "undo:" "id" { "id" "SEL" "id" }
{ "undo:" id { id SEL id }
[ nip undo-action send-action$ ]
}
{ "redo:" "id" { "id" "SEL" "id" }
{ "redo:" id { id SEL id }
[ nip redo-action send-action$ ]
}
{ "cut:" "id" { "id" "SEL" "id" }
{ "cut:" id { id SEL id }
[ nip cut-action send-action$ ]
}
{ "copy:" "id" { "id" "SEL" "id" }
{ "copy:" id { id SEL id }
[ nip copy-action send-action$ ]
}
{ "paste:" "id" { "id" "SEL" "id" }
{ "paste:" id { id SEL id }
[ nip paste-action send-action$ ]
}
{ "delete:" "id" { "id" "SEL" "id" }
{ "delete:" id { id SEL id }
[ nip delete-action send-action$ ]
}
{ "selectAll:" "id" { "id" "SEL" "id" }
{ "selectAll:" id { id SEL id }
[ nip select-all-action send-action$ ]
}
{ "newDocument:" "id" { "id" "SEL" "id" }
{ "newDocument:" id { id SEL id }
[ nip new-action send-action$ ]
}
{ "openDocument:" "id" { "id" "SEL" "id" }
{ "openDocument:" id { id SEL id }
[ nip open-action send-action$ ]
}
{ "saveDocument:" "id" { "id" "SEL" "id" }
{ "saveDocument:" id { id SEL id }
[ nip save-action send-action$ ]
}
{ "saveDocumentAs:" "id" { "id" "SEL" "id" }
{ "saveDocumentAs:" id { id SEL id }
[ nip save-as-action send-action$ ]
}
{ "revertDocumentToSaved:" "id" { "id" "SEL" "id" }
{ "revertDocumentToSaved:" id { id SEL id }
[ nip revert-action send-action$ ]
}
! Multi-touch gestures: this is undocumented.
! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
{ "magnifyWithEvent:" void { id SEL id }
[
nip
dup -> deltaZ sgn {
@ -286,7 +286,7 @@ CLASS: {
]
}
{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
{ "swipeWithEvent:" void { id SEL id }
[
nip
dup -> deltaX sgn {
@ -305,14 +305,14 @@ CLASS: {
]
}
! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
! "rotateWithEvent:" void { id SEL id }}
{ "acceptsFirstResponder" "char" { "id" "SEL" }
{ "acceptsFirstResponder" char { id SEL }
[ 2drop 1 ]
}
! Services
{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
{ "validRequestorForSendType:returnType:" id { id SEL id id }
[
! We return either self or nil
[ over window-focus ] 2dip
@ -320,7 +320,7 @@ CLASS: {
]
}
{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" }
{ "writeSelectionToPasteboard:types:" char { id SEL id id }
[
CF>string-array NSStringPboardType swap member? [
[ drop window-focus gadget-selection ] dip over
@ -329,7 +329,7 @@ CLASS: {
]
}
{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
{ "readSelectionFromPasteboard:" char { id SEL id }
[
pasteboard-string dup [
[ drop window ] dip swap user-input 1
@ -338,60 +338,60 @@ CLASS: {
}
! Text input
{ "insertText:" "void" { "id" "SEL" "id" }
{ "insertText:" void { id SEL id }
[ nip CF>string swap window user-input ]
}
{ "hasMarkedText" "char" { "id" "SEL" }
{ "hasMarkedText" char { id SEL }
[ 2drop 0 ]
}
{ "markedRange" "NSRange" { "id" "SEL" }
{ "markedRange" NSRange { id SEL }
[ 2drop 0 0 <NSRange> ]
}
{ "selectedRange" "NSRange" { "id" "SEL" }
{ "selectedRange" NSRange { id SEL }
[ 2drop 0 0 <NSRange> ]
}
{ "setMarkedText:selectedRange:" "void" { "id" "SEL" "id" "NSRange" }
{ "setMarkedText:selectedRange:" void { id SEL id NSRange }
[ 2drop 2drop ]
}
{ "unmarkText" "void" { "id" "SEL" }
{ "unmarkText" void { id SEL }
[ 2drop ]
}
{ "validAttributesForMarkedText" "id" { "id" "SEL" }
{ "validAttributesForMarkedText" id { id SEL }
[ 2drop NSArray -> array ]
}
{ "attributedSubstringFromRange:" "id" { "id" "SEL" "NSRange" }
{ "attributedSubstringFromRange:" id { id SEL NSRange }
[ 3drop f ]
}
{ "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" }
{ "characterIndexForPoint:" NSUInteger { id SEL NSPoint }
[ 3drop 0 ]
}
{ "firstRectForCharacterRange:" "NSRect" { "id" "SEL" "NSRange" }
{ "firstRectForCharacterRange:" NSRect { id SEL NSRange }
[ 3drop 0 0 0 0 <CGRect> ]
}
{ "conversationIdentifier" "NSInteger" { "id" "SEL" }
{ "conversationIdentifier" NSInteger { id SEL }
[ drop alien-address ]
}
! Initialization
{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
{ "updateFactorGadgetSize:" void { id SEL id }
[ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
}
{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
{ "doCommandBySelector:" void { id SEL SEL }
[ 3drop ]
}
{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
{ "initWithFrame:pixelFormat:" id { id SEL NSRect id }
[
[ drop ] 2dip
SUPER-> initWithFrame:pixelFormat:
@ -399,13 +399,13 @@ CLASS: {
]
}
{ "isOpaque" "char" { "id" "SEL" }
{ "isOpaque" char { id SEL }
[
2drop 0
]
}
{ "dealloc" "void" { "id" "SEL" }
{ "dealloc" void { id SEL }
[
drop
[ unregister-window ]
@ -430,19 +430,19 @@ CLASS: {
{ +name+ "FactorWindowDelegate" }
}
{ "windowDidMove:" "void" { "id" "SEL" "id" }
{ "windowDidMove:" void { id SEL id }
[
2nip -> object [ -> contentView window ] keep save-position
]
}
{ "windowDidBecomeKey:" "void" { "id" "SEL" "id" }
{ "windowDidBecomeKey:" void { id SEL id }
[
2nip -> object -> contentView window focus-world
]
}
{ "windowDidResignKey:" "void" { "id" "SEL" "id" }
{ "windowDidResignKey:" void { id SEL id }
[
forget-rollover
2nip -> object -> contentView
@ -452,13 +452,13 @@ CLASS: {
]
}
{ "windowShouldClose:" "char" { "id" "SEL" "id" }
{ "windowShouldClose:" char { id SEL id }
[
3drop 1
]
}
{ "windowWillClose:" "void" { "id" "SEL" "id" }
{ "windowWillClose:" void { id SEL id }
[
2nip -> object -> contentView window ungraft
]

2
basis/ui/backend/windows/windows.factor
View File

@ -596,7 +596,7 @@ SYMBOL: trace-messages?
! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( -- object )
"uint" { "void*" "uint" "long" "long" } "stdcall" [
uint { void* uint long long } "stdcall" [
pick
trace-messages? get-global [ dup windows-message-name name>> print flush ] when
wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if

13
basis/ui/gadgets/editors/editors-tests.factor
View File

@ -1,8 +1,8 @@
USING: accessors ui.gadgets.editors tools.test kernel io
io.streams.plain definitions namespaces ui.gadgets
ui.gadgets.grids prettyprint documents ui.gestures ui.gadgets.debug
models documents.elements ui.gadgets.scrollers ui.gadgets.line-support
sequences ;
USING: accessors ui.gadgets.editors ui.gadgets.editors.private
tools.test kernel io io.streams.plain definitions namespaces
ui.gadgets ui.gadgets.grids prettyprint documents ui.gestures
ui.gadgets.debug models documents.elements ui.gadgets.scrollers
ui.gadgets.line-support sequences ;
IN: ui.gadgets.editors.tests
[ "foo bar" ] [
@ -55,6 +55,9 @@ IN: ui.gadgets.editors.tests
[ ] [ <editor> com-join-lines ] unit-test
[ ] [ <editor> "A" over set-editor-string com-join-lines ] unit-test
[ "A B" ] [ <editor> "A\nB" over set-editor-string [ com-join-lines ] [ editor-string ] bi ] unit-test
[ "A B\nC\nD" ] [ <editor> "A\nB\nC\nD" over set-editor-string { 0 0 } over set-caret dup mark>caret [ com-join-lines ] [ editor-string ] bi ] unit-test
[ "A\nB C\nD" ] [ <editor> "A\nB\nC\nD" over set-editor-string { 1 0 } over set-caret dup mark>caret [ com-join-lines ] [ editor-string ] bi ] unit-test
[ "A\nB\nC D" ] [ <editor> "A\nB\nC\nD" over set-editor-string { 2 0 } over set-caret dup mark>caret [ com-join-lines ] [ editor-string ] bi ] unit-test
[ 2 ] [ <editor> 20 >>min-rows 20 >>min-cols pref-viewport-dim length ] unit-test

59
basis/ui/gadgets/editors/editors.factor
View File

@ -17,6 +17,8 @@ caret-color
caret mark
focused? blink blink-alarm ;
<PRIVATE
: <loc> ( -- loc ) { 0 0 } <model> ;
: init-editor-locs ( editor -- editor )
@ -27,6 +29,8 @@ focused? blink blink-alarm ;
COLOR: red >>caret-color
monospace-font >>font ; inline
PRIVATE>
: new-editor ( class -- editor )
new-line-gadget
<document> >>model
@ -36,6 +40,8 @@ focused? blink blink-alarm ;
: <editor> ( -- editor )
editor new-editor ;
<PRIVATE
: activate-editor-model ( editor model -- )
[ add-connection ]
[ nip activate-model ]
@ -70,6 +76,8 @@ SYMBOL: blink-interval
bi
] [ drop ] if ;
PRIVATE>
M: editor graft*
[ dup caret>> activate-editor-model ]
[ dup mark>> activate-editor-model ] bi ;
@ -142,6 +150,8 @@ M: editor ungraft*
] keep scroll>rect
] [ drop ] if ;
<PRIVATE
: draw-caret? ( editor -- ? )
{ [ focused?>> ] [ blink>> ] } 1&& ;
@ -189,6 +199,8 @@ TUPLE: selected-line start end first? last? ;
] 3bi
] if ;
PRIVATE>
M: editor draw-line ( line index editor -- )
[ selected-lines get at ] dip over
[ draw-selected-line ] [ nip draw-unselected-line ] if ;
@ -206,6 +218,8 @@ M: editor baseline font>> font-metrics ascent>> ;
M: editor cap-height font>> font-metrics cap-height>> ;
<PRIVATE
: contents-changed ( model editor -- )
[ [ nip caret>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ]
[ [ nip mark>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ]
@ -214,6 +228,8 @@ M: editor cap-height font>> font-metrics cap-height>> ;
: caret/mark-changed ( editor -- )
[ restart-blinking ] keep scroll>caret ;
PRIVATE>
M: editor model-changed
{
{ [ 2dup model>> eq? ] [ contents-changed ] }
@ -513,6 +529,8 @@ PRIVATE>
: change-selection ( editor quot -- )
'[ gadget-selection @ ] [ user-input* drop ] bi ; inline
<PRIVATE
: join-lines ( string -- string' )
"\n" split
[ rest-slice [ [ blank? ] trim-head-slice ] change-each ]
@ -520,22 +538,39 @@ PRIVATE>
[ " " join ]
tri ;
: this-line-and-next ( document line -- start end )
[ nip 0 swap 2array ]
[ 1 + [ nip ] [ swap doc-line length ] 2bi 2array ]
2bi ;
: last-line? ( document line -- ? )
[ last-line# ] dip = ;
: prev-line-and-this ( document line -- start end )
swap
[ drop 1 - 0 2array ]
[ [ drop ] [ doc-line length ] 2bi 2array ]
2bi ;
: join-with-prev ( document line -- )
[ prev-line-and-this ] [ drop ] 2bi
[ join-lines ] change-doc-range ;
: this-line-and-next ( document line -- start end )
swap
[ drop 0 2array ]
[ [ 1 + ] dip [ drop ] [ doc-line length ] 2bi 2array ]
2bi ;
: join-with-next ( document line -- )
[ this-line-and-next ] [ drop ] 2bi
[ join-lines ] change-doc-range ;
PRIVATE>
: com-join-lines ( editor -- )
dup gadget-selection?
[ [ join-lines ] change-selection ] [
[ model>> ] [ editor-caret first ] bi
2dup last-line? [ 2drop ] [
[ this-line-and-next ] [ drop ] 2bi
[ join-lines ] change-doc-range
] if
[ model>> ] [ editor-caret first ] bi {
{ [ over last-line# 0 = ] [ 2drop ] }
{ [ 2dup last-line? ] [ join-with-prev ] }
[ join-with-next ]
} cond
] if ;
multiline-editor "multiline" f {
@ -566,6 +601,8 @@ TUPLE: source-editor < multiline-editor ;
! Fields wrap an editor
TUPLE: field < border editor min-cols max-cols ;
<PRIVATE
: field-theme ( gadget -- gadget )
{ 2 2 } >>size
{ 1 0 } >>fill
@ -576,6 +613,8 @@ TUPLE: field < border editor min-cols max-cols ;
{ 1 0 } >>fill
field-theme ;
PRIVATE>
: new-field ( class -- gadget )
[ <editor> ] dip new-border
dup gadget-child >>editor

28
basis/windows/kernel32/kernel32.factor
View File

@ -759,6 +759,34 @@ CONSTANT: PIPE_NOWAIT 1
CONSTANT: PIPE_UNLIMITED_INSTANCES 255
CONSTANT: EXCEPTION_NONCONTINUABLE HEX: 1
CONSTANT: STATUS_GUARD_PAGE_VIOLATION HEX: 80000001
CONSTANT: STATUS_DATATYPE_MISALIGNMENT HEX: 80000002
CONSTANT: STATUS_BREAKPOINT HEX: 80000003
CONSTANT: STATUS_SINGLE_STEP HEX: 80000004
CONSTANT: STATUS_ACCESS_VIOLATION HEX: C0000005
CONSTANT: STATUS_IN_PAGE_ERROR HEX: C0000006
CONSTANT: STATUS_INVALID_HANDLE HEX: C0000008
CONSTANT: STATUS_NO_MEMORY HEX: C0000017
CONSTANT: STATUS_ILLEGAL_INSTRUCTION HEX: C000001D
CONSTANT: STATUS_NONCONTINUABLE_EXCEPTION HEX: C0000025
CONSTANT: STATUS_INVALID_DISPOSITION HEX: C0000026
CONSTANT: STATUS_ARRAY_BOUNDS_EXCEEDED HEX: C000008C
CONSTANT: STATUS_FLOAT_DENORMAL_OPERAND HEX: C000008D
CONSTANT: STATUS_FLOAT_DIVIDE_BY_ZERO HEX: C000008E
CONSTANT: STATUS_FLOAT_INEXACT_RESULT HEX: C000008F
CONSTANT: STATUS_FLOAT_INVALID_OPERATION HEX: C0000090
CONSTANT: STATUS_FLOAT_OVERFLOW HEX: C0000091
CONSTANT: STATUS_FLOAT_STACK_CHECK HEX: C0000092
CONSTANT: STATUS_FLOAT_UNDERFLOW HEX: C0000093
CONSTANT: STATUS_INTEGER_DIVIDE_BY_ZERO HEX: C0000094
CONSTANT: STATUS_INTEGER_OVERFLOW HEX: C0000095
CONSTANT: STATUS_PRIVILEGED_INSTRUCTION HEX: C0000096
CONSTANT: STATUS_STACK_OVERFLOW HEX: C00000FD
CONSTANT: STATUS_CONTROL_C_EXIT HEX: C000013A
CONSTANT: STATUS_FLOAT_MULTIPLE_FAULTS HEX: C00002B4
CONSTANT: STATUS_FLOAT_MULTIPLE_TRAPS HEX: C00002B5
LIBRARY: kernel32
! FUNCTION: _hread
! FUNCTION: _hwrite

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

@ -79,7 +79,7 @@ HELP: alien-callback-error
HELP: alien-callback
{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" "a quotation" } { "alien" alien } }
{ $description
"Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "\"void\"" } " indicates that no value is to be returned."
"Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "void" } " indicates that no value is to be returned."
$nl
"When a compiled reference to this word is called, it pushes the callback's alien address on the data stack. This address can be passed to any C function expecting a C function pointer with the correct signature. The callback is actually generated when the word calling " { $link alien-callback } " is compiled."
$nl
@ -90,7 +90,7 @@ HELP: alien-callback
"A simple example, showing a C function which returns the difference of two given integers:"
{ $code
": difference-callback ( -- alien )"
" \"int\" { \"int\" \"int\" } \"cdecl\" [ - ] alien-callback ;"
" int { int int } \"cdecl\" [ - ] alien-callback ;"
}
}
{ $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ;

2
core/classes/builtin/builtin-docs.factor
View File

@ -9,7 +9,7 @@ $nl
builtin-class
builtin-class?
}
"See " { $link "type-index" } " for a list of built-in classes." ;
"See " { $link "class-index" } " for a list of built-in classes." ;
HELP: builtin-class
{ $class-description "The class of built-in classes." }

3
core/generic/single/single-tests.factor
View File

@ -4,7 +4,8 @@ accessors words byte-arrays bit-arrays parser namespaces make
quotations stack-checker vectors growable hashtables sbufs
prettyprint byte-vectors bit-vectors specialized-vectors
definitions generic sets graphs assocs grouping see eval ;
SPECIALIZED-VECTOR: double
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-VECTOR: c:double
IN: generic.single.tests
GENERIC: lo-tag-test ( obj -- obj' )

6
extra/benchmark/fib6/fib6.factor
View File

@ -1,13 +1,13 @@
USING: math kernel alien ;
USING: math kernel alien alien.c-types ;
IN: benchmark.fib6
: fib ( x -- y )
"int" { "int" } "cdecl" [
int { int } "cdecl" [
dup 1 <= [ drop 1 ] [
1 - dup fib swap 1 - fib +
] if
] alien-callback
"int" { "int" } "cdecl" alien-indirect ;
int { int } "cdecl" alien-indirect ;
: fib-main ( -- ) 32 fib drop ;

1
extra/cpu/8080/emulator/emulator.factor
View File

@ -24,7 +24,6 @@ USING:
quotations
sequences
sequences.deep
syntax
words
;
IN: cpu.8080.emulator

1
extra/decimals/decimals-tests.factor
View File

@ -49,3 +49,4 @@ ERROR: decimal-test-failure D1 D2 quot ;
[ f ] [ D: -1 D: -2 before? ] unit-test
[ f ] [ D: -2 D: -2 before? ] unit-test
[ t ] [ D: -3 D: -2 before? ] unit-test
[ t ] [ D: .5 D: 0 D: 1.0 between? ] unit-test

6
extra/decimals/decimals.factor
View File

@ -37,8 +37,7 @@ SYNTAX: D: parse-decimal parsed ;
] 2bi ;
: scale-decimals ( D1 D2 -- D1' D2' )
[ drop ]
[ scale-mantissas <decimal> nip ] 2bi ;
scale-mantissas tuck [ <decimal> ] 2dip <decimal> ;
ERROR: decimal-types-expected d1 d2 ;
@ -83,3 +82,6 @@ M: decimal before?
e1
e2 a + - <decimal> ;
M: decimal <=>
2dup before? [ 2drop +lt+ ] [ equal? +eq+ +gt+ ? ] if ; inline

5
extra/gpu/render/render-docs.factor
View File

@ -226,6 +226,11 @@ HELP: render-set
} }
{ $notes "User-created framebuffers require OpenGL 3.0 or one of the " { $snippet "GL_EXT_framebuffer_object" } " or " { $snippet "GL_ARB_framebuffer_object" } " extensions. Disabling rasterization requires OpenGL 3.0 or the " { $snippet "GL_EXT_transform_feedback" } " extension. Named output-attachment values are available in GLSL 1.30 or later, and GLSL 1.20 and earlier using the " { $snippet "GL_EXT_gpu_shader4" } " extension. Transform feedback requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_transform_feedback" } " or " { $snippet "GL_ARB_transform_feedback" } " extensions." } ;
HELP: bind-uniforms
{ $values { "program-instance" program-instance } { "uniforms" uniform-tuple } }
{ $description "Binds the uniform shader parameters for " { $snippet "program-instance" } " using values from the given uniform tuple." }
{ $notes "The " { $link render } " word uses this word. Calling this word directly is only necessary if uniform parameters need to be bound independently of a " { $snippet "render" } " operation." } ;
{ render render-set } related-words
HELP: texture-uniform

19
extra/gpu/render/render.factor
View File

@ -168,12 +168,12 @@ M: multi-index-elements render-vertex-indexes
: (bind-texture-unit) ( texture texture-unit -- )
swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
GENERIC: bind-uniform-textures ( program-instance uniform-tuple -- )
GENERIC: bind-uniforms ( program-instance uniform-tuple -- )
GENERIC: (bind-uniform-textures) ( program-instance uniform-tuple -- )
GENERIC: (bind-uniforms) ( program-instance uniform-tuple -- )
M: uniform-tuple bind-uniform-textures
M: uniform-tuple (bind-uniform-textures)
2drop ;
M: uniform-tuple bind-uniforms
M: uniform-tuple (bind-uniforms)
2drop ;
: uniform-slot-type ( uniform -- type )
@ -363,7 +363,7 @@ DEFER: [bind-uniform-tuple]
:: [bind-uniforms] ( superclass uniforms -- quot )
superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
superclass \ bind-uniforms method :> next-method
superclass \ (bind-uniforms) method :> next-method
first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot
{ 2dup next-method } bind-quot [ ] append-as ;
@ -371,10 +371,10 @@ DEFER: [bind-uniform-tuple]
: define-uniform-tuple-methods ( class superclass uniforms -- )
[
2drop
[ \ bind-uniform-textures create-method-in ]
[ \ (bind-uniform-textures) create-method-in ]
[ [bind-uniform-textures] ] bi define
] [
[ \ bind-uniforms create-method-in ] 2dip
[ \ (bind-uniforms) create-method-in ] 2dip
[bind-uniforms] define
] 3bi ;
@ -481,12 +481,15 @@ TUPLE: render-set
: 3<render-set> ( x y z quot-assoc -- render-set )
render-set swap 3make-tuple ; inline
: bind-uniforms ( program-instance uniforms -- )
[ (bind-uniform-textures) ] [ (bind-uniforms) ] 2bi ; inline
: render ( render-set -- )
{
[ vertex-array>> program-instance>> handle>> glUseProgram ]
[
[ vertex-array>> program-instance>> ] [ uniforms>> ] bi
[ bind-uniform-textures ] [ bind-uniforms ] 2bi
bind-uniforms
]
[
framebuffer>>

50
extra/gpu/shaders/shaders.factor
View File

@ -432,33 +432,49 @@ PRIVATE>
: <program-instance> ( program -- instance )
[ find-program-instance dup world get ] keep instances>> set-at ;
<PRIVATE
: old-instances ( name -- instances )
dup constant? [
execute( -- s/p ) dup { [ shader? ] [ program? ] } 1||
[ instances>> ] [ drop H{ } clone ] if
] [ drop H{ } clone ] if ;
PRIVATE>
SYNTAX: GLSL-SHADER:
CREATE-WORD dup
scan-word
f
lexer get line>>
parse-here
H{ } clone
CREATE dup
dup old-instances [
scan-word
f
lexer get line>>
parse-here
] dip
shader boa
over reset-generic
define-constant ;
SYNTAX: GLSL-SHADER-FILE:
CREATE-WORD dup
scan-word execute( -- kind )
scan-object in-word's-path
0
over ascii file-contents
H{ } clone
CREATE dup
dup old-instances [
scan-word execute( -- kind )
scan-object in-word's-path
0
over ascii file-contents
] dip
shader boa
over reset-generic
define-constant ;
SYNTAX: GLSL-PROGRAM:
CREATE-WORD dup
f
lexer get line>>
\ ; parse-until >array shaders-and-feedback-format
H{ } clone
CREATE dup
dup old-instances [
f
lexer get line>>
\ ; parse-until >array shaders-and-feedback-format
] dip
program boa
over reset-generic
define-constant ;
M: shader-instance dispose

2
extra/noise/noise.factor
View File

@ -56,7 +56,7 @@ ERROR: invalid-perlin-noise-table table ;
dup { [ byte-array? ] [ length 512 >= ] } 1&&
[ invalid-perlin-noise-table ] unless ;
! XXX doesn't work for NaNs or floats > 2^31
! XXX doesn't work when v is nan or |v| >= 2^31
: floor-vector ( v -- v' )
[ float-4 int-4 vconvert int-4 float-4 vconvert ]
[ [ v> -1.0 float-4-with vand ] curry keep v+ ] bi ; inline

2
extra/peg/javascript/parser/parser-tests.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.javascript.ast peg.javascript.parser
accessors sequences math peg.ebnf ;
accessors sequences math peg.ebnf peg.ebnf.private ;
IN: peg.javascript.parser.tests
{

2
extra/peg/pl0/pl0-tests.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf peg.pl0
USING: kernel tools.test peg peg.ebnf peg.ebnf.private peg.pl0
sequences accessors ;
IN: peg.pl0.tests

3
extra/random/cmwc/cmwc-tests.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays kernel random random.cmwc sequences
specialized-arrays specialized-arrays.instances.uint tools.test ;
specialized-arrays tools.test ;
SPECIALIZED-ARRAY: uint
IN: random.cmwc.tests
[ ] [

3
extra/random/cmwc/cmwc.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays fry kernel locals math
math.bitwise random sequences sequences.private
specialized-arrays specialized-arrays.instances.uint ;
specialized-arrays ;
SPECIALIZED-ARRAY: uint
IN: random.cmwc
! Multiply-with-carry RNG

3
extra/random/lagged-fibonacci/lagged-fibonacci-tests.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel math.functions random random.lagged-fibonacci
sequences specialized-arrays.instances.double tools.test ;
sequences tools.test specialized-arrays alien.c-types ;
SPECIALIZED-ARRAY: double
IN: random.lagged-fibonacci.tests
[ t ] [

6
extra/space-invaders/space-invaders.factor
View File

@ -22,15 +22,13 @@ USING:
ui.gadgets
ui.gestures
ui.render
specialized-arrays
;
QUALIFIED: threads
QUALIFIED: system
SPECIALIZED-ARRAY: uchar
IN: space-invaders
<<
"uchar" require-c-array
>>
TUPLE: space-invaders < cpu port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
CONSTANT: game-width 224
CONSTANT: game-height 256

4
extra/ui/gadgets/controls/controls.factor
View File

@ -1,7 +1,7 @@
USING: accessors assocs arrays kernel models monads sequences
models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.buttons.private ui.gadgets.editors words images.loader
ui.gadgets.scrollers ui.images vocabs.parser lexer
ui.gadgets.buttons.private ui.gadgets.editors ui.gadgets.editors.private
words images.loader ui.gadgets.scrollers ui.images vocabs.parser lexer
models.range ui.gadgets.sliders ;
QUALIFIED-WITH: ui.gadgets.sliders slider
QUALIFIED-WITH: ui.gadgets.tables tbl

0
extra/modules/rpc-server/authors.txt → unmaintained/modules/rpc-server/authors.txt
View File

0
extra/modules/rpc-server/rpc-server-docs.factor → unmaintained/modules/rpc-server/rpc-server-docs.factor
View File

0
extra/modules/rpc-server/rpc-server.factor → unmaintained/modules/rpc-server/rpc-server.factor
View File

0
extra/modules/rpc-server/summary.txt → unmaintained/modules/rpc-server/summary.txt
View File

0
extra/modules/rpc/authors.txt → unmaintained/modules/rpc/authors.txt
View File

0
extra/modules/rpc/rpc-docs.factor → unmaintained/modules/rpc/rpc-docs.factor
View File

0
extra/modules/rpc/rpc.factor → unmaintained/modules/rpc/rpc.factor
View File

0
extra/modules/rpc/summary.txt → unmaintained/modules/rpc/summary.txt
View File

0
extra/modules/using/authors.txt → unmaintained/modules/using/authors.txt
View File

0
extra/modules/using/summary.txt → unmaintained/modules/using/summary.txt
View File

0
extra/modules/using/using-docs.factor → unmaintained/modules/using/using-docs.factor
View File

0
extra/modules/using/using.factor → unmaintained/modules/using/using.factor
View File

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