{ +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
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: {
{ +name+ "Foo" }
} {
"foo:"
- "void"
- { "id" "SEL" "NSRect" }
+ void
+ { id SEL NSRect }
[ gc "x" set 2drop ]
} ;
{ +name+ "Bar" }
} {
"bar"
- "NSRect"
- { "id" "SEL" }
+ NSRect
+ { id SEL }
[ 2drop test-foo "x" get ]
} ;
{ +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 ]
} ;
! 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*
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 ;
: (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 ;
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.
[ [ 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 ]
] when
! Regression. Make sure everything is inlined correctly
-[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
\ No newline at end of file
+[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
{ 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 ] }
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 -- )
[ ^^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 )
{
{
]
} 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 ;
+
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 ;
} 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
[ [ 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
[ -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
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 ] [
! 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
! 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*
] unit-test
: callback-4 ( -- callback )
- "void" { } "cdecl" [ "Hello world" write ] alien-callback
+ void { } "cdecl" [ "Hello world" write ] alien-callback
gc ;
[ "Hello world" ] [
] 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 ;
} 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 ]
] unit-test
: callback-10 ( -- callback )
- "test_struct_14" { "double" "double" } "cdecl"
+ test_struct_14 { double double } "cdecl"
[
test_struct_14 <struct>
swap >>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
] unit-test
: callback-11 ( -- callback )
- "test-struct-12" { "int" "double" } "cdecl"
+ test-struct-12 { int double } "cdecl"
[
test-struct-12 <struct>
swap >>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
[ 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
] 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
[ 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
] 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
{ 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 ;
[ 2 0 ] [
1 1
[ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
-] unit-test
\ No newline at end of file
+] unit-test
{ 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
[ 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 ( -- )
{
{ 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 ;
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 ;
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 ;
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
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 ) ;
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 ) ;
! 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 ;
\ No newline at end of file
+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 ;
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
"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." ;
{ $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"
{ \ (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 ] }
{ \ (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 ] }
vxor
vnot
v?
+ vif
}
"Entire vector tests:"
{ $subsections
{ $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." }
: 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 ;
: 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 } ;
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
! 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: {
{ +name+ "Bar" }
} {
"bar:"
- "float"
- { "id" "SEL" "NSRect" }
+ float
+ { id SEL NSRect }
[
[ origin>> [ x>> ] [ y>> ] bi + ]
[ size>> [ w>> ] [ h>> ] bi + ]
-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
-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>>
[ ] [ \ + 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 ( -- ) ;
{ +name+ "FactorApplicationDelegate" }
}
-{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
+{ "applicationDidUpdate:" void { id SEL id }
[ 3drop reset-run-loop ]
} ;
! 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 -- )
{ +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 ]
} ;
{ +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 ]
} ;
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
}
! 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
]
}
-{ "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 {
]
}
-{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
+{ "swipeWithEvent:" void { id SEL id }
[
nip
dup -> deltaX sgn {
]
}
-! "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
]
}
-{ "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
]
}
-{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
+{ "readSelectionFromPasteboard:" char { id SEL id }
[
pasteboard-string dup [
[ drop window ] dip swap user-input 1
}
! 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:
]
}
-{ "isOpaque" "char" { "id" "SEL" }
+{ "isOpaque" char { id SEL }
[
2drop 0
]
}
-{ "dealloc" "void" { "id" "SEL" }
+{ "dealloc" void { id SEL }
[
drop
[ unregister-window ]
{ +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
]
}
-{ "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
]
! 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
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
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
"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." } ;
-USING: math kernel alien ;\r
+USING: math kernel alien alien.c-types ;\r
IN: benchmark.fib6\r
\r
: fib ( x -- y )\r
- "int" { "int" } "cdecl" [\r
+ int { int } "cdecl" [\r
dup 1 <= [ drop 1 ] [\r
1 - dup fib swap 1 - fib +\r
] if\r
] alien-callback\r
- "int" { "int" } "cdecl" alien-indirect ;\r
+ int { int } "cdecl" alien-indirect ;\r
\r
: fib-main ( -- ) 32 fib drop ;\r
\r
[ 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
] 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 ;
e1
e2 a + - <decimal> ;
+
+M: decimal <=>
+ 2dup before? [ 2drop +lt+ ] [ equal? +eq+ +gt+ ? ] if ; inline
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
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()
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)
}
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;
}
}
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);
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;
}
}
-#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)
}
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;
}
}
-#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)
}
const char *vm_executable_path();
const char *default_image_path();
+template<typename Type> Type align_stack_pointer(Type sp)
+{
+ return sp;
+}
+
}
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)
+
}
{
#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])
}
#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;
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])
}
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;
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])
}
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;
}
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)
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)
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)
+
}
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))
}
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])
}
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)
}
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)
}
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])
}
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])
}
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);
+ factor_vm *vm = tls_vm();
+ vm->signal_number = signal;
+ vm->dispatch_signal(uap,factor::misc_signal_handler_impl);
}
-void factor_vm::fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+void 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));
+ factor_vm *vm = tls_vm();
+ vm->signal_number = signal;
+ vm->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;
-}
-void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
-{
- tls_vm()->fpe_signal_handler(signal, siginfo, 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)
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__
projects / factor.git / commitdiff