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

Merge branch 'master' into new_gc

db4
Slava Pestov 2009-10-22 05:40:57 -05:00
parent 606a805d7d 0c40eb51ae
commit 3394309659
55 changed files with 664 additions and 403 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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 ;

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

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 ;

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

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

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

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

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

@ -888,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 ;
@ -1098,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 ;
@ -1118,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 ;

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 ;

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"

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

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

@ -101,6 +101,7 @@ $nl
vxor
vnot
v?
vif
}
"Entire vector tests:"
{ $subsections
@ -534,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." }

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

@ -142,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 ;
@ -175,20 +182,20 @@ PRIVATE>
: 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 } ;

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

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

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

@ -1,7 +1,7 @@
IN: tools.profiler.tests
USING: accessors tools.profiler tools.test kernel memory math
threads alien tools.profiler.private sequences compiler compiler.units
words ;
threads alien alien.c-types tools.profiler.private sequences
compiler compiler.units words ;
IN: tools.profiler.tests
[ t ] [
\ length counter>>
@ -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 ( -- ) ;

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

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

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

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
vm/errors.cpp
View File

@ -114,7 +114,7 @@ void factor_vm::memory_protection_error(cell addr, stack_frame *native_stack)
void factor_vm::signal_error(int signal, stack_frame *native_stack)
{
general_error(ERROR_SIGNAL,tag_fixnum(signal),false_object,native_stack);
general_error(ERROR_SIGNAL,allot_cell(signal),false_object,native_stack);
}
void factor_vm::divide_by_zero_error()

12
vm/mach_signal.cpp
View File

@ -47,7 +47,7 @@ void factor_vm::call_fault_handler(
else
signal_callstack_top = NULL;
MACH_STACK_POINTER(thread_state) = fix_stack_pointer(MACH_STACK_POINTER(thread_state));
MACH_STACK_POINTER(thread_state) = align_stack_pointer(MACH_STACK_POINTER(thread_state));
/* Now we point the program counter at the right handler function. */
if(exception == EXC_BAD_ACCESS)
@ -63,7 +63,13 @@ void factor_vm::call_fault_handler(
}
else
{
signal_number = (exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT);
switch(exception)
{
case EXC_ARITHMETIC: signal_number = SIGFPE; break;
case EXC_BAD_INSTRUCTION: signal_number = SIGILL; break;
default: signal_number = SIGABRT; break;
}
MACH_PROGRAM_COUNTER(thread_state) = (cell)factor::misc_signal_handler_impl;
}
}
@ -226,7 +232,7 @@ void mach_initialize ()
fatal_error("mach_port_insert_right() failed",0);
/* The exceptions we want to catch. */
mask = EXC_MASK_BAD_ACCESS | EXC_MASK_ARITHMETIC;
mask = EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC;
/* Create the thread listening on the exception port. */
start_thread(mach_exception_thread,NULL);

10
vm/os-freebsd-x86.32.hpp
View File

@ -4,12 +4,6 @@
namespace factor
{
inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.mc_esp;
}
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
@ -43,6 +37,8 @@ inline static void uap_clear_fpu_status(void *uap)
}
}
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip)
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_esp)
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_eip)
}

10
vm/os-freebsd-x86.64.hpp
View File

@ -4,12 +4,6 @@
namespace factor
{
inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.mc_rsp;
}
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
@ -33,6 +27,8 @@ inline static void uap_clear_fpu_status(void *uap)
}
}
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip)
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_rsp)
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_rip)
}

5
vm/os-genunix.hpp
View File

@ -10,4 +10,9 @@ void early_init();
const char *vm_executable_path();
const char *default_image_path();
template<typename Type> Type align_stack_pointer(Type sp)
{
return sp;
}
}

12
vm/os-linux-arm.hpp
View File

@ -5,15 +5,9 @@
namespace factor
{
inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.arm_sp;
}
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.arm_pc)
void flush_icache(cell start, cell len);
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.arm_sp)
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.arm_pc)
}

11
vm/os-linux-ppc.hpp
View File

@ -4,14 +4,7 @@ namespace factor
{
#define FRAME_RETURN_ADDRESS(frame,vm) *((void **)(vm->frame_successor(frame) + 1) + 1)
inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
}
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
#define UAP_STACK_POINTER(ucontext) ((ucontext_t *)ucontext)->uc_mcontext.uc_regs->gregs[PT_R1]
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.uc_regs->gregs[PT_NIP])
}

11
vm/os-linux-x86.32.hpp
View File

@ -29,12 +29,6 @@ struct _fpstate {
#define X86_FXSR_MAGIC 0x0000
inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.gregs[7];
}
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
@ -54,7 +48,8 @@ inline static void uap_clear_fpu_status(void *uap)
fpregs->mxcsr &= 0xffffffc0;
}
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[7])
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[14])
}

10
vm/os-linux-x86.64.hpp
View File

@ -3,12 +3,6 @@
namespace factor
{
inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.gregs[15];
}
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
@ -23,7 +17,7 @@ inline static void uap_clear_fpu_status(void *uap)
ucontext->uc_mcontext.fpregs->mxcsr &= 0xffffffc0;
}
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[15])
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[16])
}

2
vm/os-macosx-ppc.hpp
View File

@ -62,7 +62,7 @@ inline static unsigned int uap_fpu_status(void *uap)
return mach_fpu_status(UAP_FS(uap));
}
inline static cell fix_stack_pointer(cell sp)
template<typename Type> Type align_stack_pointer(Type sp)
{
return sp;
}

4
vm/os-macosx-x86.32.hpp
View File

@ -64,9 +64,9 @@ inline static unsigned int uap_fpu_status(void *uap)
return mach_fpu_status(UAP_FS(uap));
}
inline static cell fix_stack_pointer(cell sp)
template<typename Type> Type align_stack_pointer(Type sp)
{
return ((sp + 4) & ~15) - 4;
return (Type)((((cell)sp + 4) & ~15) - 4);
}
inline static void mach_clear_fpu_status(i386_float_state_t *float_state)

4
vm/os-macosx-x86.64.hpp
View File

@ -62,9 +62,9 @@ inline static unsigned int uap_fpu_status(void *uap)
return mach_fpu_status(UAP_FS(uap));
}
inline static cell fix_stack_pointer(cell sp)
template<typename Type> Type align_stack_pointer(Type sp)
{
return ((sp + 8) & ~15) - 8;
return (Type)((((cell)sp + 8) & ~15) - 8);
}
inline static void mach_clear_fpu_status(x86_float_state64_t *float_state)

8
vm/os-macosx.hpp
View File

@ -11,12 +11,8 @@ void early_init();
const char *vm_executable_path();
const char *default_image_path();
inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return ucontext->uc_stack.ss_sp;
}
void c_to_factor_toplevel(cell quot);
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_stack.ss_sp)
}

6
vm/os-netbsd-x86.32.hpp
View File

@ -3,9 +3,9 @@
namespace factor
{
#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
static inline void uap_clear_fpu_status(void *uap) { }
static inline void uap_clear_fpu_status(void *uap) {}
#define UAP_STACK_POINTER(ucontext) (_UC_MACHINE_SP((ucontext_t *)ucontext))
}

7
vm/os-netbsd-x86.64.hpp
View File

@ -3,10 +3,9 @@
namespace factor
{
#define ucontext_stack_pointer(uap) \
((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP]))
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
static inline void uap_clear_fpu_status(void *uap) { }
static inline void uap_clear_fpu_status(void *uap) {}
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.__gregs[_REG_URSP])
}

14
vm/os-openbsd-x86.32.hpp
View File

@ -3,16 +3,10 @@
namespace factor
{
inline static void *openbsd_stack_pointer(void *uap)
{
struct sigcontext *sc = (struct sigcontext*) uap;
return (void *)sc->sc_esp;
}
#define ucontext_stack_pointer openbsd_stack_pointer
#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
static inline void uap_clear_fpu_status(void *uap) { }
static inline void uap_clear_fpu_status(void *uap) {}
#define UAP_STACK_POINTER(ucontext) (((struct sigcontext *)ucontext)->sc_esp)
#define UAP_PROGRAM_COUNTER(ucontext) (((struct sigcontext *)ucontext)->sc_eip)
}

14
vm/os-openbsd-x86.64.hpp
View File

@ -3,16 +3,10 @@
namespace factor
{
inline static void *openbsd_stack_pointer(void *uap)
{
struct sigcontext *sc = (struct sigcontext*) uap;
return (void *)sc->sc_rsp;
}
#define ucontext_stack_pointer openbsd_stack_pointer
#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
static inline void uap_clear_fpu_status(void *uap) { }
static inline void uap_clear_fpu_status(void *uap) {}
#define UAP_STACK_POINTER(ucontext) (((struct sigcontext *)ucontext)->sc_rsp)
#define UAP_PROGRAM_COUNTER(ucontext) (((struct sigcontext *)ucontext)->sc_rip)
}

10
vm/os-solaris-x86.32.hpp
View File

@ -3,13 +3,7 @@
namespace factor
{
inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.gregs[ESP];
}
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP])
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[ESP])
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[EIP])
}

10
vm/os-solaris-x86.64.hpp
View File

@ -3,13 +3,7 @@
namespace factor
{
inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.gregs[RSP];
}
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP])
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[RSP])
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[RIP])
}

62
vm/os-unix.cpp
View File

@ -115,63 +115,47 @@ segment::~segment()
if(retval)
fatal_error("Segment deallocation failed",0);
}
stack_frame *factor_vm::uap_stack_pointer(void *uap)
void factor_vm::dispatch_signal(void *uap, void (handler)())
{
/* There is a race condition here, but in practice a signal
delivered during stack frame setup/teardown or while transitioning
from Factor to C is a sign of things seriously gone wrong, not just
a divide by zero or stack underflow in the listener */
if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap)))
{
stack_frame *ptr = (stack_frame *)ucontext_stack_pointer(uap);
if(!ptr)
critical_error("Invalid uap",(cell)uap);
return ptr;
stack_frame *ptr = (stack_frame *)UAP_STACK_POINTER(uap);
assert(ptr);
signal_callstack_top = ptr;
}
else
return NULL;
}
signal_callstack_top = NULL;
void factor_vm::memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_fault_addr = (cell)siginfo->si_addr;
signal_callstack_top = uap_stack_pointer(uap);
UAP_PROGRAM_COUNTER(uap) = (cell)factor::memory_signal_handler_impl;
UAP_STACK_POINTER(uap) = align_stack_pointer(UAP_STACK_POINTER(uap));
UAP_PROGRAM_COUNTER(uap) = (cell)handler;
}
void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
tls_vm()->memory_signal_handler(signal,siginfo,uap);
}
void factor_vm::misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_number = signal;
signal_callstack_top = uap_stack_pointer(uap);
UAP_PROGRAM_COUNTER(uap) = (cell)factor::misc_signal_handler_impl;
factor_vm *vm = tls_vm();
vm->signal_fault_addr = (cell)siginfo->si_addr;
vm->dispatch_signal(uap,factor::memory_signal_handler_impl);
}
void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
tls_vm()->misc_signal_handler(signal,siginfo,uap);
}
void factor_vm::fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_number = signal;
signal_callstack_top = uap_stack_pointer(uap);
signal_fpu_status = fpu_status(uap_fpu_status(uap));
uap_clear_fpu_status(uap);
UAP_PROGRAM_COUNTER(uap) =
(siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
? (cell)factor::misc_signal_handler_impl
: (cell)factor::fp_signal_handler_impl;
factor_vm *vm = tls_vm();
vm->signal_number = signal;
vm->dispatch_signal(uap,factor::misc_signal_handler_impl);
}
void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
tls_vm()->fpe_signal_handler(signal, siginfo, uap);
factor_vm *vm = tls_vm();
vm->signal_number = signal;
vm->signal_fpu_status = fpu_status(uap_fpu_status(uap));
uap_clear_fpu_status(uap);
vm->dispatch_signal(uap,
(siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
? factor::misc_signal_handler_impl
: factor::fp_signal_handler_impl);
}
static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)

11
vm/vm.hpp
View File

@ -678,17 +678,12 @@ struct factor_vm
void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length);
bool windows_stat(vm_char *path);
#if defined(WINNT)
#if defined(WINNT)
void open_console();
LONG exception_handler(PEXCEPTION_POINTERS pe);
// next method here:
#endif
#endif
#else // UNIX
void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap);
void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap);
void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap);
stack_frame *uap_stack_pointer(void *uap);
void dispatch_signal(void *uap, void (handler)());
#endif
#ifdef __APPLE__