parent
ac58033aff
commit
924b434336
|
@ -11,10 +11,10 @@ INLINE-FUNCTOR: complex-type ( n: existing-word t: name -- ) [[
|
|||
STRUCT: ${t} { real ${n} } { imaginary ${n} } ;
|
||||
|
||||
: <${t}> ( z -- alien )
|
||||
math::>rect ${t} <struct-boa> >c-ptr ;
|
||||
math:>rect ${t} <struct-boa> >c-ptr ;
|
||||
|
||||
: *${t} ( alien -- z )
|
||||
${t} memory>struct [ real>> ] [ imaginary>> ] bi math::rect> ; inline
|
||||
${t} memory>struct [ real>> ] [ imaginary>> ] bi math:rect> ; inline
|
||||
|
||||
>>
|
||||
|
||||
|
|
|
@ -4,28 +4,28 @@ specialized-arrays.private system tools.test vocabs ;
|
|||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: alien.data.tests
|
||||
|
||||
{ -1 } [ -1 c::char <ref> c::char deref ] unit-test
|
||||
{ -1 } [ -1 c::short <ref> c::short deref ] unit-test
|
||||
{ -1 } [ -1 c::int <ref> c::int deref ] unit-test
|
||||
{ -1 } [ -1 c:char <ref> c:char deref ] unit-test
|
||||
{ -1 } [ -1 c:short <ref> c:short deref ] unit-test
|
||||
{ -1 } [ -1 c:int <ref> c:int deref ] unit-test
|
||||
|
||||
! I don't care if this throws an error or works, but at least
|
||||
! it should be consistent between platforms
|
||||
{ -1 } [ -1.0 c::int <ref> c::int deref ] unit-test
|
||||
{ -1 } [ -1.0 c::long <ref> c::long deref ] unit-test
|
||||
{ -1 } [ -1.0 c::longlong <ref> c::longlong deref ] unit-test
|
||||
{ 1 } [ 1.0 c::uint <ref> c::uint deref ] unit-test
|
||||
{ 1 } [ 1.0 c::ulong <ref> c::ulong deref ] unit-test
|
||||
{ 1 } [ 1.0 c::ulonglong <ref> c::ulonglong deref ] unit-test
|
||||
{ -1 } [ -1.0 c:int <ref> c:int deref ] unit-test
|
||||
{ -1 } [ -1.0 c:long <ref> c:long deref ] unit-test
|
||||
{ -1 } [ -1.0 c:longlong <ref> c:longlong deref ] unit-test
|
||||
{ 1 } [ 1.0 c:uint <ref> c:uint deref ] unit-test
|
||||
{ 1 } [ 1.0 c:ulong <ref> c:ulong deref ] unit-test
|
||||
{ 1 } [ 1.0 c:ulonglong <ref> c:ulonglong deref ] unit-test
|
||||
|
||||
[
|
||||
0 B{ 1 2 3 4 } <displaced-alien> c::void* <ref>
|
||||
0 B{ 1 2 3 4 } <displaced-alien> c:void* <ref>
|
||||
] must-fail
|
||||
|
||||
os windows? cpu x86.64? and [
|
||||
[ -2147467259 ] [ 2147500037 c::long <ref> c::long deref ] unit-test
|
||||
[ -2147467259 ] [ 2147500037 c:long <ref> c:long deref ] unit-test
|
||||
] when
|
||||
|
||||
STRUCT: foo { a c::int } { b c::void* } { c c::bool } ;
|
||||
STRUCT: foo { a c:int } { b c:void* } { c c:bool } ;
|
||||
|
||||
SPECIALIZED-ARRAY: foo
|
||||
|
||||
|
|
|
@ -175,5 +175,5 @@ GENERIC: binary-zero? ( value -- ? )
|
|||
M: object binary-zero? drop f ; inline
|
||||
M: f binary-zero? drop t ; inline
|
||||
M: integer binary-zero? zero? ; inline
|
||||
M: math::float binary-zero? double>bits zero? ; inline
|
||||
M: math:float binary-zero? double>bits zero? ; inline
|
||||
M: complex binary-zero? >rect [ binary-zero? ] both? ; inline
|
||||
|
|
|
@ -12,7 +12,7 @@ ERROR: invalid-signed-conversion n ;
|
|||
: convert-signed-quot ( n -- quot )
|
||||
{
|
||||
{ 1 [ [ char <ref> char deref ] ] }
|
||||
{ 2 [ [ c::short <ref> c::short deref ] ] }
|
||||
{ 2 [ [ c:short <ref> c:short deref ] ] }
|
||||
{ 4 [ [ int <ref> int deref ] ] }
|
||||
{ 8 [ [ longlong <ref> longlong deref ] ] }
|
||||
[ invalid-signed-conversion ]
|
||||
|
@ -47,7 +47,7 @@ ERROR: unknown-endian-c-type symbol ;
|
|||
: endian-c-type>c-type-symbol ( symbol -- symbol' )
|
||||
{
|
||||
{ [ dup { ule16 ube16 } member? ] [ drop ushort ] }
|
||||
{ [ dup { le16 be16 } member? ] [ drop c::short ] }
|
||||
{ [ dup { le16 be16 } member? ] [ drop c:short ] }
|
||||
{ [ dup { ule32 ube32 } member? ] [ drop uint ] }
|
||||
{ [ dup { le32 be32 } member? ] [ drop int ] }
|
||||
{ [ dup { ule64 ube64 } member? ] [ drop ulonglong ] }
|
||||
|
@ -122,7 +122,7 @@ ERROR: unsupported-endian-type endian slot ;
|
|||
{ [ dup bool = ] [ 2drop bool ] }
|
||||
{ [ dup char = ] [ 2drop char ] }
|
||||
{ [ dup uchar = ] [ 2drop uchar ] }
|
||||
{ [ dup c::short = ] [ { le16 be16 } endian-slot ] }
|
||||
{ [ dup c:short = ] [ { le16 be16 } endian-slot ] }
|
||||
{ [ dup ushort = ] [ { ule16 ube16 } endian-slot ] }
|
||||
{ [ dup int = ] [ { le32 be32 } endian-slot ] }
|
||||
{ [ dup uint = ] [ { ule32 ube32 } endian-slot ] }
|
||||
|
|
|
@ -137,7 +137,7 @@ STRUCT: struct-test-bar
|
|||
[ struct-test-foo struct-definer-word ] unit-test
|
||||
|
||||
UNION-STRUCT: struct-test-float-and-bits
|
||||
{ f c::float }
|
||||
{ f c:float }
|
||||
{ bits uint } ;
|
||||
|
||||
{ 1.0 } [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
|
||||
|
@ -229,7 +229,7 @@ UNION-STRUCT: struct-test-float-and-bits
|
|||
T{ struct-slot-spec
|
||||
{ name "f" }
|
||||
{ offset 0 }
|
||||
{ type c::float }
|
||||
{ type c:float }
|
||||
{ class float }
|
||||
{ initial 0.0 }
|
||||
}
|
||||
|
@ -478,11 +478,11 @@ STRUCT: silly-array-field-test { x int*[3] } ;
|
|||
|
||||
! Packed structs
|
||||
PACKED-STRUCT: packed-struct-test
|
||||
{ d c::int }
|
||||
{ e c::short }
|
||||
{ f c::int }
|
||||
{ g c::char }
|
||||
{ h c::int } ;
|
||||
{ d c:int }
|
||||
{ e c:short }
|
||||
{ f c:int }
|
||||
{ g c:char }
|
||||
{ h c:int } ;
|
||||
|
||||
{ 15 } [ packed-struct-test heap-size ] unit-test
|
||||
|
||||
|
@ -495,9 +495,9 @@ PACKED-STRUCT: packed-struct-test
|
|||
{ postpone: \PACKED-STRUCT: }
|
||||
[ packed-struct-test struct-definer-word ] unit-test
|
||||
|
||||
STRUCT: struct-1 { a c::int } ;
|
||||
PACKED-STRUCT: struct-1-packed { a c::int } ;
|
||||
UNION-STRUCT: struct-1-union { a c::int } ;
|
||||
STRUCT: struct-1 { a c:int } ;
|
||||
PACKED-STRUCT: struct-1-packed { a c:int } ;
|
||||
UNION-STRUCT: struct-1-union { a c:int } ;
|
||||
|
||||
{ "USING: alien.c-types classes.struct ;
|
||||
IN: classes.struct.tests
|
||||
|
|
|
@ -21,8 +21,9 @@ SYNTAX: \?send:
|
|||
suffix! \ send suffix! ;
|
||||
|
||||
SYNTAX: \selector:
|
||||
scan-token unescape-token dup remember-send
|
||||
<selector> suffix! \ cocoa.messages::selector suffix! ;
|
||||
scan-token unescape-token
|
||||
[ remember-send ]
|
||||
[ <selector> suffix! \ cocoa.messages:selector suffix! ] bi ;
|
||||
|
||||
SYMBOL: super-sent-messages
|
||||
|
||||
|
|
|
@ -111,17 +111,17 @@ class-init-hooks [ H{ } clone ] initialize
|
|||
SYMBOL: objc>alien-types
|
||||
|
||||
H{
|
||||
{ "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::void* }
|
||||
{ "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:void* }
|
||||
{ "?" unknown_type }
|
||||
{ "@" id }
|
||||
{ "#" Class }
|
||||
|
@ -129,10 +129,10 @@ H{
|
|||
}
|
||||
cell {
|
||||
{ 4 [ H{
|
||||
{ "l" c::long }
|
||||
{ "q" c::longlong }
|
||||
{ "L" c::ulong }
|
||||
{ "Q" c::ulonglong }
|
||||
{ "l" c:long }
|
||||
{ "q" c:longlong }
|
||||
{ "L" c:ulong }
|
||||
{ "Q" c:ulonglong }
|
||||
} ] }
|
||||
{ 8 [ H{
|
||||
{ "l" long32 }
|
||||
|
|
|
@ -125,13 +125,13 @@ SYMBOL: ac-counter
|
|||
] [ vreg kill-computed-set-slot ] if ;
|
||||
|
||||
: init-alias-analysis ( -- )
|
||||
H{ } clone vregs>acs namespaces::set
|
||||
H{ } clone acs>vregs namespaces::set
|
||||
H{ } clone live-slots namespaces::set
|
||||
H{ } clone copies namespaces::set
|
||||
H{ } clone recent-stores namespaces::set
|
||||
HS{ } clone dead-stores namespaces::set
|
||||
0 ac-counter namespaces::set ;
|
||||
H{ } clone vregs>acs namespaces:set
|
||||
H{ } clone acs>vregs namespaces:set
|
||||
H{ } clone live-slots namespaces:set
|
||||
H{ } clone copies namespaces:set
|
||||
H{ } clone recent-stores namespaces:set
|
||||
HS{ } clone dead-stores namespaces:set
|
||||
0 ac-counter namespaces:set ;
|
||||
|
||||
GENERIC: insn-slot# ( insn -- slot#/f )
|
||||
GENERIC: insn-object ( insn -- vreg )
|
||||
|
@ -255,7 +255,7 @@ M: insn eliminate-dead-stores drop t ;
|
|||
copies get clear-assoc
|
||||
dead-stores get clear-set
|
||||
|
||||
next-ac heap-ac namespaces::set
|
||||
next-ac heap-ac namespaces:set
|
||||
##vm-field set-new-ac
|
||||
##alien-global set-new-ac ;
|
||||
|
||||
|
|
|
@ -85,8 +85,8 @@ SYMBOL: visited
|
|||
[ worklist get push-front ] [ drop ] if ;
|
||||
|
||||
: init-worklist ( cfg -- )
|
||||
<dlist> worklist namespaces::set
|
||||
HS{ } clone visited namespaces::set
|
||||
<dlist> worklist namespaces:set
|
||||
HS{ } clone visited namespaces:set
|
||||
entry>> add-to-worklist ;
|
||||
|
||||
: split-branches ( cfg -- )
|
||||
|
|
|
@ -125,12 +125,12 @@ M: c-type box
|
|||
{
|
||||
{ "from_float" [ drop ] }
|
||||
{ "from_double" [ drop ] }
|
||||
{ "from_signed_1" [ drop c::char ^^convert-integer ] }
|
||||
{ "from_unsigned_1" [ drop c::uchar ^^convert-integer ] }
|
||||
{ "from_signed_2" [ drop c::short ^^convert-integer ] }
|
||||
{ "from_unsigned_2" [ drop c::ushort ^^convert-integer ] }
|
||||
{ "from_signed_4" [ drop c::int ^^convert-integer ] }
|
||||
{ "from_unsigned_4" [ drop c::uint ^^convert-integer ] }
|
||||
{ "from_signed_1" [ drop c:char ^^convert-integer ] }
|
||||
{ "from_unsigned_1" [ drop c:uchar ^^convert-integer ] }
|
||||
{ "from_signed_2" [ drop c:short ^^convert-integer ] }
|
||||
{ "from_unsigned_2" [ drop c:ushort ^^convert-integer ] }
|
||||
{ "from_signed_4" [ drop c:int ^^convert-integer ] }
|
||||
{ "from_unsigned_4" [ drop c:uint ^^convert-integer ] }
|
||||
{ "allot_alien" [ drop ^^box-alien ] }
|
||||
[ swap <gc-map> ^^box ]
|
||||
} case ;
|
||||
|
|
|
@ -57,13 +57,12 @@ M: dataflow-analysis join-sets 2drop assoc-refine ;
|
|||
M: dataflow-analysis ignore-block? drop kill-block?>> ;
|
||||
|
||||
INLINE-FUNCTOR: dataflow-analysis ( name: name -- ) [[
|
||||
USING: assocs namespaces ;
|
||||
|
||||
SINGLETON: ${name}
|
||||
SYMBOL: ${name}-ins
|
||||
: ${name}-in ( bb -- set ) ${name}-ins get at ;
|
||||
SYMBOL: ${name}-outs
|
||||
: ${name}-out ( bb -- set ) ${name}-outs get at ;
|
||||
USING: assocs namespaces ;
|
||||
SINGLETON: ${name}
|
||||
SYMBOL: ${name}-ins
|
||||
: ${name}-in ( bb -- set ) ${name}-ins get at ;
|
||||
SYMBOL: ${name}-outs
|
||||
: ${name}-out ( bb -- set ) ${name}-outs get at ;
|
||||
]]
|
||||
|
||||
! ! ! Forward dataflow analysis
|
||||
|
@ -76,16 +75,17 @@ M: forward-analysis successors drop successors>> ;
|
|||
M: forward-analysis predecessors drop predecessors>> ;
|
||||
|
||||
INLINE-FUNCTOR: forward-analysis ( name: name -- ) [[
|
||||
USING: assocs kernel namespaces ;
|
||||
QUALIFIED: namespaces
|
||||
USING: assocs kernel namespaces ;
|
||||
QUALIFIED: namespaces
|
||||
|
||||
DATAFLOW-ANALYSIS: ${name}
|
||||
DATAFLOW-ANALYSIS: ${name}
|
||||
|
||||
INSTANCE: ${name} forward-analysis
|
||||
INSTANCE: ${name} forward-analysis
|
||||
|
||||
: compute-${name}-sets ( cfg -- )
|
||||
\ ${name} run-dataflow-analysis
|
||||
[ ${name}-ins namespaces:set ] [ ${name}-outs namespaces:set ] bi* ;
|
||||
|
||||
: compute-${name}-sets ( cfg -- )
|
||||
\ ${name} run-dataflow-analysis
|
||||
[ ${name}-ins namespaces::set ] [ ${name}-outs namespaces::set ] bi* ;
|
||||
]]
|
||||
|
||||
! ! ! Backward dataflow analysis
|
||||
|
@ -98,14 +98,15 @@ M: backward-analysis successors drop predecessors>> ;
|
|||
M: backward-analysis predecessors drop successors>> ;
|
||||
|
||||
INLINE-FUNCTOR: backward-analysis ( name: name -- ) [[
|
||||
USING: assocs kernel namespaces ;
|
||||
QUALIFIED: namespaces
|
||||
USING: assocs kernel namespaces ;
|
||||
QUALIFIED: namespaces
|
||||
|
||||
DATAFLOW-ANALYSIS: ${name}
|
||||
DATAFLOW-ANALYSIS: ${name}
|
||||
|
||||
INSTANCE: ${name} backward-analysis
|
||||
INSTANCE: ${name} backward-analysis
|
||||
|
||||
: compute-${name}-sets ( cfg -- )
|
||||
\ ${name} run-dataflow-analysis
|
||||
[ ${name}-outs namespaces:set ] [ ${name}-ins namespaces:set ] bi* ;
|
||||
|
||||
: compute-${name}-sets ( cfg -- )
|
||||
\ ${name} run-dataflow-analysis
|
||||
[ ${name}-outs namespaces::set ] [ ${name}-ins namespaces::set ] bi* ;
|
||||
]]
|
||||
|
|
|
@ -21,9 +21,9 @@ SYMBOL: allocations
|
|||
allocations get in? ;
|
||||
|
||||
: init-dead-code ( -- )
|
||||
H{ } clone liveness-graph namespaces::set
|
||||
HS{ } clone live-vregs namespaces::set
|
||||
HS{ } clone allocations namespaces::set ;
|
||||
H{ } clone liveness-graph namespaces:set
|
||||
HS{ } clone live-vregs namespaces:set
|
||||
HS{ } clone allocations namespaces:set ;
|
||||
|
||||
GENERIC: build-liveness-graph ( insn -- )
|
||||
|
||||
|
|
|
@ -110,7 +110,7 @@ SYMBOLS: defs insns ;
|
|||
_ set-def-of
|
||||
] with each
|
||||
] simple-analysis
|
||||
] keep defs namespaces::set ;
|
||||
] keep defs namespaces:set ;
|
||||
|
||||
: compute-insns ( cfg -- )
|
||||
H{ } clone [
|
||||
|
@ -119,4 +119,4 @@ SYMBOLS: defs insns ;
|
|||
dup _ set-def-of
|
||||
] each
|
||||
] simple-analysis
|
||||
] keep insns namespaces::set ;
|
||||
] keep insns namespaces:set ;
|
||||
|
|
|
@ -32,112 +32,112 @@ ERROR: inline-intrinsics-not-supported word quot ;
|
|||
] assoc-each ;
|
||||
|
||||
{
|
||||
{ kernel.private::tag [ drop emit-tag ] }
|
||||
{ kernel.private::context-object [ emit-context-object ] }
|
||||
{ kernel.private::special-object [ emit-special-object ] }
|
||||
{ kernel.private::set-special-object [ emit-set-special-object ] }
|
||||
{ kernel.private::(identity-hashcode) [ drop emit-identity-hashcode ] }
|
||||
{ math.private::both-fixnums? [ drop emit-both-fixnums? ] }
|
||||
{ math.private::fixnum+ [ drop emit-fixnum+ ] }
|
||||
{ math.private::fixnum- [ drop emit-fixnum- ] }
|
||||
{ math.private::fixnum* [ drop emit-fixnum* ] }
|
||||
{ math.private::fixnum+fast [ drop [ ^^add ] binary-op ] }
|
||||
{ math.private::fixnum-fast [ drop [ ^^sub ] binary-op ] }
|
||||
{ math.private::fixnum*fast [ drop [ ^^mul ] binary-op ] }
|
||||
{ math.private::fixnum-bitand [ drop [ ^^and ] binary-op ] }
|
||||
{ math.private::fixnum-bitor [ drop [ ^^or ] binary-op ] }
|
||||
{ math.private::fixnum-bitxor [ drop [ ^^xor ] binary-op ] }
|
||||
{ math.private::fixnum-shift-fast [ emit-fixnum-shift-fast ] }
|
||||
{ math.private::fixnum-bitnot [ drop [ ^^not ] unary-op ] }
|
||||
{ math.private::fixnum< [ drop cc< emit-fixnum-comparison ] }
|
||||
{ math.private::fixnum<= [ drop cc<= emit-fixnum-comparison ] }
|
||||
{ math.private::fixnum>= [ drop cc>= emit-fixnum-comparison ] }
|
||||
{ math.private::fixnum> [ drop cc> emit-fixnum-comparison ] }
|
||||
{ kernel::eq? [ emit-eq ] }
|
||||
{ slots.private::slot [ emit-slot ] }
|
||||
{ slots.private::set-slot [ emit-set-slot ] }
|
||||
{ strings.private::string-nth-fast [ drop emit-string-nth-fast ] }
|
||||
{ strings.private::set-string-nth-fast [ drop emit-set-string-nth-fast ] }
|
||||
{ classes.tuple.private::<tuple-boa> [ emit-<tuple-boa> ] }
|
||||
{ arrays::<array> [ emit-<array> ] }
|
||||
{ byte-arrays::<byte-array> [ emit-<byte-array> ] }
|
||||
{ byte-arrays::(byte-array) [ emit-(byte-array) ] }
|
||||
{ kernel::<wrapper> [ emit-simple-allot ] }
|
||||
{ alien.data.private::(local-allot) [ emit-local-allot ] }
|
||||
{ alien.data.private::(cleanup-allot) [ emit-cleanup-allot ] }
|
||||
{ alien::<displaced-alien> [ emit-<displaced-alien> ] }
|
||||
{ alien.accessors::alien-unsigned-1 [ int-rep alien.c-types::uchar emit-load-memory ] }
|
||||
{ alien.accessors::set-alien-unsigned-1 [ int-rep alien.c-types::uchar emit-store-memory ] }
|
||||
{ alien.accessors::alien-signed-1 [ int-rep alien.c-types::char emit-load-memory ] }
|
||||
{ alien.accessors::set-alien-signed-1 [ int-rep alien.c-types::char emit-store-memory ] }
|
||||
{ alien.accessors::alien-unsigned-2 [ int-rep alien.c-types::ushort emit-load-memory ] }
|
||||
{ alien.accessors::set-alien-unsigned-2 [ int-rep alien.c-types::ushort emit-store-memory ] }
|
||||
{ alien.accessors::alien-signed-2 [ int-rep alien.c-types::short emit-load-memory ] }
|
||||
{ alien.accessors::set-alien-signed-2 [ int-rep alien.c-types::short emit-store-memory ] }
|
||||
{ alien.accessors::alien-cell [ emit-alien-cell ] }
|
||||
{ alien.accessors::set-alien-cell [ emit-set-alien-cell ] }
|
||||
{ kernel.private:tag [ drop emit-tag ] }
|
||||
{ kernel.private:context-object [ emit-context-object ] }
|
||||
{ kernel.private:special-object [ emit-special-object ] }
|
||||
{ kernel.private:set-special-object [ emit-set-special-object ] }
|
||||
{ kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
|
||||
{ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
|
||||
{ math.private:fixnum+ [ drop emit-fixnum+ ] }
|
||||
{ math.private:fixnum- [ drop emit-fixnum- ] }
|
||||
{ math.private:fixnum* [ drop emit-fixnum* ] }
|
||||
{ math.private:fixnum+fast [ drop [ ^^add ] binary-op ] }
|
||||
{ math.private:fixnum-fast [ drop [ ^^sub ] binary-op ] }
|
||||
{ math.private:fixnum*fast [ drop [ ^^mul ] binary-op ] }
|
||||
{ math.private:fixnum-bitand [ drop [ ^^and ] binary-op ] }
|
||||
{ math.private:fixnum-bitor [ drop [ ^^or ] binary-op ] }
|
||||
{ math.private:fixnum-bitxor [ drop [ ^^xor ] binary-op ] }
|
||||
{ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
|
||||
{ math.private:fixnum-bitnot [ drop [ ^^not ] unary-op ] }
|
||||
{ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
|
||||
{ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
|
||||
{ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
|
||||
{ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
|
||||
{ kernel:eq? [ emit-eq ] }
|
||||
{ slots.private:slot [ emit-slot ] }
|
||||
{ slots.private:set-slot [ emit-set-slot ] }
|
||||
{ strings.private:string-nth-fast [ drop emit-string-nth-fast ] }
|
||||
{ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
|
||||
{ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
|
||||
{ arrays:<array> [ emit-<array> ] }
|
||||
{ byte-arrays:<byte-array> [ emit-<byte-array> ] }
|
||||
{ byte-arrays:(byte-array) [ emit-(byte-array) ] }
|
||||
{ kernel:<wrapper> [ emit-simple-allot ] }
|
||||
{ alien.data.private:(local-allot) [ emit-local-allot ] }
|
||||
{ alien.data.private:(cleanup-allot) [ emit-cleanup-allot ] }
|
||||
{ alien:<displaced-alien> [ emit-<displaced-alien> ] }
|
||||
{ alien.accessors:alien-unsigned-1 [ int-rep alien.c-types:uchar emit-load-memory ] }
|
||||
{ alien.accessors:set-alien-unsigned-1 [ int-rep alien.c-types:uchar emit-store-memory ] }
|
||||
{ alien.accessors:alien-signed-1 [ int-rep alien.c-types:char emit-load-memory ] }
|
||||
{ alien.accessors:set-alien-signed-1 [ int-rep alien.c-types:char emit-store-memory ] }
|
||||
{ alien.accessors:alien-unsigned-2 [ int-rep alien.c-types:ushort emit-load-memory ] }
|
||||
{ alien.accessors:set-alien-unsigned-2 [ int-rep alien.c-types:ushort emit-store-memory ] }
|
||||
{ alien.accessors:alien-signed-2 [ int-rep alien.c-types:short emit-load-memory ] }
|
||||
{ alien.accessors:set-alien-signed-2 [ int-rep alien.c-types:short emit-store-memory ] }
|
||||
{ alien.accessors:alien-cell [ emit-alien-cell ] }
|
||||
{ alien.accessors:set-alien-cell [ emit-set-alien-cell ] }
|
||||
} enable-intrinsics
|
||||
|
||||
: enable-alien-4-intrinsics ( -- )
|
||||
{
|
||||
{ alien.accessors::alien-signed-4 [ int-rep alien.c-types::int emit-load-memory ] }
|
||||
{ alien.accessors::set-alien-signed-4 [ int-rep alien.c-types::int emit-store-memory ] }
|
||||
{ alien.accessors::alien-unsigned-4 [ int-rep alien.c-types::uint emit-load-memory ] }
|
||||
{ alien.accessors::set-alien-unsigned-4 [ int-rep alien.c-types::uint emit-store-memory ] }
|
||||
{ alien.accessors:alien-signed-4 [ int-rep alien.c-types:int emit-load-memory ] }
|
||||
{ alien.accessors:set-alien-signed-4 [ int-rep alien.c-types:int emit-store-memory ] }
|
||||
{ alien.accessors:alien-unsigned-4 [ int-rep alien.c-types:uint emit-load-memory ] }
|
||||
{ alien.accessors:set-alien-unsigned-4 [ int-rep alien.c-types:uint emit-store-memory ] }
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-float-intrinsics ( -- )
|
||||
{
|
||||
{ math.private::float+ [ drop [ ^^add-float ] binary-op ] }
|
||||
{ math.private::float- [ drop [ ^^sub-float ] binary-op ] }
|
||||
{ math.private::float* [ drop [ ^^mul-float ] binary-op ] }
|
||||
{ math.private::float/f [ drop [ ^^div-float ] binary-op ] }
|
||||
{ math.private::float< [ drop cc< emit-float-ordered-comparison ] }
|
||||
{ math.private::float<= [ drop cc<= emit-float-ordered-comparison ] }
|
||||
{ math.private::float>= [ drop cc>= emit-float-ordered-comparison ] }
|
||||
{ math.private::float> [ drop cc> emit-float-ordered-comparison ] }
|
||||
{ math.private::float-u< [ drop cc< emit-float-unordered-comparison ] }
|
||||
{ math.private::float-u<= [ drop cc<= emit-float-unordered-comparison ] }
|
||||
{ math.private::float-u>= [ drop cc>= emit-float-unordered-comparison ] }
|
||||
{ math.private::float-u> [ drop cc> emit-float-unordered-comparison ] }
|
||||
{ math.private::float= [ drop cc= emit-float-unordered-comparison ] }
|
||||
{ math.private::float>fixnum [ drop [ ^^float>integer ] unary-op ] }
|
||||
{ math.private::fixnum>float [ drop [ ^^integer>float ] unary-op ] }
|
||||
{ math.floats.private::float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
|
||||
{ alien.accessors::alien-float [ float-rep f emit-load-memory ] }
|
||||
{ alien.accessors::set-alien-float [ float-rep f emit-store-memory ] }
|
||||
{ alien.accessors::alien-double [ double-rep f emit-load-memory ] }
|
||||
{ alien.accessors::set-alien-double [ double-rep f emit-store-memory ] }
|
||||
{ math.private:float+ [ drop [ ^^add-float ] binary-op ] }
|
||||
{ math.private:float- [ drop [ ^^sub-float ] binary-op ] }
|
||||
{ math.private:float* [ drop [ ^^mul-float ] binary-op ] }
|
||||
{ math.private:float/f [ drop [ ^^div-float ] binary-op ] }
|
||||
{ math.private:float< [ drop cc< emit-float-ordered-comparison ] }
|
||||
{ math.private:float<= [ drop cc<= emit-float-ordered-comparison ] }
|
||||
{ math.private:float>= [ drop cc>= emit-float-ordered-comparison ] }
|
||||
{ math.private:float> [ drop cc> emit-float-ordered-comparison ] }
|
||||
{ math.private:float-u< [ drop cc< emit-float-unordered-comparison ] }
|
||||
{ math.private:float-u<= [ drop cc<= emit-float-unordered-comparison ] }
|
||||
{ math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] }
|
||||
{ math.private:float-u> [ drop cc> emit-float-unordered-comparison ] }
|
||||
{ math.private:float= [ drop cc= emit-float-unordered-comparison ] }
|
||||
{ math.private:float>fixnum [ drop [ ^^float>integer ] unary-op ] }
|
||||
{ math.private:fixnum>float [ drop [ ^^integer>float ] unary-op ] }
|
||||
{ math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
|
||||
{ alien.accessors:alien-float [ float-rep f emit-load-memory ] }
|
||||
{ alien.accessors:set-alien-float [ float-rep f emit-store-memory ] }
|
||||
{ alien.accessors:alien-double [ double-rep f emit-load-memory ] }
|
||||
{ alien.accessors:set-alien-double [ double-rep f emit-store-memory ] }
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-fsqrt ( -- )
|
||||
{
|
||||
{ math.libm::fsqrt [ drop [ ^^sqrt ] unary-op ] }
|
||||
{ math.libm:fsqrt [ drop [ ^^sqrt ] unary-op ] }
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-float-min/max ( -- )
|
||||
{
|
||||
{ math.floats.private::float-min [ drop [ ^^min-float ] binary-op ] }
|
||||
{ math.floats.private::float-max [ drop [ ^^max-float ] binary-op ] }
|
||||
{ math.floats.private:float-min [ drop [ ^^min-float ] binary-op ] }
|
||||
{ math.floats.private:float-max [ drop [ ^^max-float ] binary-op ] }
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-min/max ( -- )
|
||||
{
|
||||
{ math.integers.private::fixnum-min [ drop [ ^^min ] binary-op ] }
|
||||
{ math.integers.private::fixnum-max [ drop [ ^^max ] binary-op ] }
|
||||
{ math.integers.private:fixnum-min [ drop [ ^^min ] binary-op ] }
|
||||
{ math.integers.private:fixnum-max [ drop [ ^^max ] binary-op ] }
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-log2 ( -- )
|
||||
{
|
||||
{ math.integers.private::fixnum-log2 [ drop [ ^^log2 ] unary-op ] }
|
||||
{ math.integers.private:fixnum-log2 [ drop [ ^^log2 ] unary-op ] }
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-bit-count ( -- )
|
||||
{
|
||||
{ math.bitwise.private::fixnum-bit-count [ drop [ ^^bit-count ] unary-op ] }
|
||||
{ math.bitwise.private:fixnum-bit-count [ drop [ ^^bit-count ] unary-op ] }
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-bit-test ( -- )
|
||||
{
|
||||
{ math.integers.private::fixnum-bit? [ drop [ ^^bit-test ] binary-op ] }
|
||||
{ math.integers.private:fixnum-bit? [ drop [ ^^bit-test ] binary-op ] }
|
||||
} enable-intrinsics ;
|
||||
|
|
|
@ -99,7 +99,7 @@ RENAMING: assign "[ vreg>reg ]" "[ vreg>reg ]" "[ vreg>reg ]"
|
|||
|
||||
: begin-block ( bb -- )
|
||||
{
|
||||
[ basic-block set ]
|
||||
[ basic-block namespaces:set ]
|
||||
[ block-from unhandled-intervals get activate-new-intervals ]
|
||||
[ compute-edge-live-in ]
|
||||
[ compute-live-in ]
|
||||
|
@ -110,7 +110,7 @@ RENAMING: assign "[ vreg>reg ]" "[ vreg>reg ]" "[ vreg>reg ]"
|
|||
[ '[ [ _ bi@ ] assoc-map ] change-derived-roots drop ] 2bi ; inline
|
||||
|
||||
: spill-required? ( live-interval root-leaders n -- ? )
|
||||
[ [ vreg>> ] dip sets::in? ] [ swap covers? ] bi-curry* bi or ;
|
||||
[ [ vreg>> ] dip sets:in? ] [ swap covers? ] bi-curry* bi or ;
|
||||
|
||||
: spill-intervals ( root-leaders n -- live-intervals )
|
||||
[ pending-interval-heap get heap-members ] 2dip
|
||||
|
@ -160,12 +160,12 @@ RENAMING: assign "[ vreg>reg ]" "[ vreg>reg ]" "[ vreg>reg ]"
|
|||
[ [ live-interval-start ] map ] keep zip >min-heap ;
|
||||
|
||||
: init-assignment ( live-intervals -- )
|
||||
live-intervals>min-heap unhandled-intervals set
|
||||
<min-heap> pending-interval-heap set
|
||||
H{ } clone pending-interval-assoc set
|
||||
H{ } clone machine-live-ins set
|
||||
H{ } clone machine-edge-live-ins set
|
||||
H{ } clone machine-live-outs set ;
|
||||
live-intervals>min-heap unhandled-intervals namespaces:set
|
||||
<min-heap> pending-interval-heap namespaces:set
|
||||
H{ } clone pending-interval-assoc namespaces:set
|
||||
H{ } clone machine-live-ins namespaces:set
|
||||
H{ } clone machine-edge-live-ins namespaces:set
|
||||
H{ } clone machine-live-outs namespaces:set ;
|
||||
|
||||
: assign-registers ( cfg live-intervals -- )
|
||||
init-assignment
|
||||
|
|
|
@ -47,7 +47,7 @@ SYMBOLS: loop-heads visited ;
|
|||
[ visited? ] reject ;
|
||||
|
||||
: (linearization-order) ( cfg -- bbs )
|
||||
HS{ } clone visited namespaces::set
|
||||
HS{ } clone visited namespaces:set
|
||||
entry>> <dlist> [ push-back ] keep
|
||||
[ dup '[ process-block _ push-all-back ] slurp-deque ] { } make ;
|
||||
|
||||
|
|
|
@ -137,10 +137,10 @@ M: insn visit-insn 2drop ;
|
|||
[ update-live-out/in ] keep predecessors>> { } ? ;
|
||||
|
||||
: init-liveness ( -- )
|
||||
H{ } clone live-ins namespaces::set
|
||||
H{ } clone edge-live-ins namespaces::set
|
||||
H{ } clone live-outs namespaces::set
|
||||
H{ } clone base-pointers namespaces::set ;
|
||||
H{ } clone live-ins namespaces:set
|
||||
H{ } clone edge-live-ins namespaces:set
|
||||
H{ } clone live-outs namespaces:set
|
||||
H{ } clone base-pointers namespaces:set ;
|
||||
|
||||
: compute-live-sets ( cfg -- )
|
||||
init-liveness
|
||||
|
|
|
@ -55,13 +55,13 @@ SYMBOL: loop-nesting
|
|||
: compute-loop-nesting ( -- )
|
||||
loops get H{ } clone [
|
||||
[ values ] dip '[ blocks>> members [ _ inc-at ] each ] each
|
||||
] keep loop-nesting namespaces::set ;
|
||||
] keep loop-nesting namespaces:set ;
|
||||
|
||||
: detect-loops ( cfg -- cfg' )
|
||||
H{ } clone loops namespaces::set
|
||||
HS{ } clone visited namespaces::set
|
||||
HS{ } clone active namespaces::set
|
||||
H{ } clone loop-nesting namespaces::set
|
||||
H{ } clone loops namespaces:set
|
||||
HS{ } clone visited namespaces:set
|
||||
HS{ } clone active namespaces:set
|
||||
H{ } clone loop-nesting namespaces:set
|
||||
[ needs-predecessors ]
|
||||
[ entry>> find-loop-headers process-loop-headers compute-loop-nesting ]
|
||||
[ ] tri ;
|
||||
|
|
|
@ -39,8 +39,8 @@ M: vreg-insn (collect-vreg-reps)
|
|||
M: insn (collect-vreg-reps) drop ;
|
||||
|
||||
: collect-vreg-reps ( cfg -- )
|
||||
H{ } clone vreg-reps namespaces::set
|
||||
HS{ } clone tagged-vregs namespaces::set
|
||||
H{ } clone vreg-reps namespaces:set
|
||||
HS{ } clone tagged-vregs namespaces:set
|
||||
[ [ (collect-vreg-reps) ] each-non-phi ] each-basic-block ;
|
||||
|
||||
SYMBOL: possibilities
|
||||
|
@ -52,7 +52,7 @@ SYMBOL: possibilities
|
|||
|
||||
: compute-possibilities ( cfg -- )
|
||||
collect-vreg-reps
|
||||
vreg-reps get [ possible-reps ] assoc-map possibilities namespaces::set ;
|
||||
vreg-reps get [ possible-reps ] assoc-map possibilities namespaces:set ;
|
||||
|
||||
! For every vreg, compute the cost of keeping it in every possible
|
||||
! representation.
|
||||
|
@ -60,7 +60,7 @@ SYMBOL: possibilities
|
|||
SYMBOL: costs
|
||||
|
||||
: init-costs ( -- )
|
||||
possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs namespaces::set ;
|
||||
possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs namespaces:set ;
|
||||
|
||||
: increase-cost ( rep scc factor -- )
|
||||
[ costs get at 2dup key? ] dip
|
||||
|
@ -122,7 +122,7 @@ M: vreg-insn compute-insn-costs
|
|||
: compute-costs ( cfg -- )
|
||||
init-costs
|
||||
[
|
||||
[ basic-block namespaces::set ]
|
||||
[ basic-block namespaces:set ]
|
||||
[ [ compute-insn-costs ] each-non-phi ] bi
|
||||
] each-basic-block ;
|
||||
|
||||
|
@ -134,4 +134,4 @@ M: vreg-insn compute-insn-costs
|
|||
compute-costs costs get minimize-costs
|
||||
[ components get [ disjoint-set-members ] keep ] dip
|
||||
'[ dup _ representative _ at ] H{ } map>assoc
|
||||
representations namespaces::set ;
|
||||
representations namespaces:set ;
|
||||
|
|
|
@ -33,7 +33,7 @@ IN: compiler.cfg.rpo
|
|||
|
||||
: optimize-basic-block ( bb quot -- )
|
||||
over kill-block?>> [ 2drop ] [
|
||||
over basic-block namespaces::set
|
||||
over basic-block namespaces:set
|
||||
change-instructions drop
|
||||
] if ; inline
|
||||
|
||||
|
@ -42,7 +42,7 @@ IN: compiler.cfg.rpo
|
|||
|
||||
: analyze-basic-block ( bb quot -- )
|
||||
over kill-block?>> [ 2drop ] [
|
||||
[ dup basic-block namespaces::set instructions>> ] dip call
|
||||
[ dup basic-block namespaces:set instructions>> ] dip call
|
||||
] if ; inline
|
||||
|
||||
: simple-analysis ( ... cfg quot: ( ... insns -- ... ) -- ... )
|
||||
|
|
|
@ -27,8 +27,8 @@ M: vreg-insn compute-insn-defs
|
|||
] with each ;
|
||||
|
||||
: compute-defs ( cfg -- )
|
||||
H{ } clone defs namespaces::set
|
||||
HS{ } clone defs-multi namespaces::set
|
||||
H{ } clone defs namespaces:set
|
||||
HS{ } clone defs-multi namespaces:set
|
||||
[
|
||||
[ basic-block get ] dip
|
||||
[ compute-insn-defs ] with each
|
||||
|
@ -46,7 +46,7 @@ SYMBOL: inserting-phis
|
|||
members merge-set [ insert-phi-later ] with each ;
|
||||
|
||||
: compute-phis ( -- )
|
||||
H{ } clone inserting-phis namespaces::set
|
||||
H{ } clone inserting-phis namespaces:set
|
||||
defs-multi get members
|
||||
defs get '[ dup _ at compute-phis-for ] each ;
|
||||
|
||||
|
@ -57,9 +57,9 @@ SYMBOL: used-vregs
|
|||
SYMBOLS: stacks pushed ;
|
||||
|
||||
: init-renaming ( -- )
|
||||
H{ } clone phis namespaces::set
|
||||
<hashed-dlist> used-vregs namespaces::set
|
||||
H{ } clone stacks namespaces::set ;
|
||||
H{ } clone phis namespaces:set
|
||||
<hashed-dlist> used-vregs namespaces:set
|
||||
H{ } clone stacks namespaces:set ;
|
||||
|
||||
: gen-name ( vreg -- vreg' )
|
||||
[ next-vreg dup ] dip
|
||||
|
@ -111,7 +111,7 @@ M: vreg-insn rename-insn
|
|||
pushed get members stacks get '[ _ at pop* ] each ;
|
||||
|
||||
: rename-in-block ( bb -- )
|
||||
HS{ } clone pushed namespaces::set
|
||||
HS{ } clone pushed namespaces:set
|
||||
{
|
||||
[ rename-phis ]
|
||||
[ rename-insns ]
|
||||
|
@ -119,7 +119,7 @@ M: vreg-insn rename-insn
|
|||
[
|
||||
pushed get
|
||||
[ dom-children [ rename-in-block ] each ] dip
|
||||
pushed namespaces::set
|
||||
pushed namespaces:set
|
||||
]
|
||||
} cleave
|
||||
pop-stacks ;
|
||||
|
@ -134,7 +134,7 @@ SYMBOL: live-phis
|
|||
dst>> live-phis get in? ;
|
||||
|
||||
: compute-live-phis ( -- )
|
||||
HS{ } clone live-phis namespaces::set
|
||||
HS{ } clone live-phis namespaces:set
|
||||
used-vregs get [
|
||||
phis get at [
|
||||
[
|
||||
|
|
|
@ -47,7 +47,7 @@ V{ } 6 test-bb
|
|||
|
||||
{ t } [
|
||||
2 get 3 get 2array merge-set
|
||||
4 get 6 get 2array sets::set=
|
||||
4 get 6 get 2array sets:set=
|
||||
] unit-test
|
||||
|
||||
V{ } 0 test-bb
|
||||
|
|
|
@ -16,14 +16,14 @@ SYMBOLS: merge-sets levels again? ;
|
|||
|
||||
: init-merge-sets ( cfg -- )
|
||||
post-order dup length '[ _ <bit-set> ] H{ } map>assoc
|
||||
merge-sets namespaces::set ;
|
||||
merge-sets namespaces:set ;
|
||||
|
||||
: compute-levels ( cfg -- )
|
||||
0 over entry>> associate [
|
||||
'[
|
||||
_ [ [ dom-parent ] dip at 1 + ] 2keep set-at
|
||||
] each-basic-block
|
||||
] keep levels namespaces::set ;
|
||||
] keep levels namespaces:set ;
|
||||
|
||||
: j-edge? ( from to -- ? )
|
||||
2dup eq? [ 2drop f ] [ dominates? not ] if ;
|
||||
|
|
|
@ -42,8 +42,8 @@ ERROR: vregs-shouldn't-interfere vreg1 vreg2 ;
|
|||
defs get [ [ dup dup value-of ] dip <vreg-info> 1array ] assoc-map ;
|
||||
|
||||
: init-coalescing ( insns -- )
|
||||
initial-leaders leader-map namespaces::set
|
||||
initial-class-elements class-element-map namespaces::set ;
|
||||
initial-leaders leader-map namespaces:set
|
||||
initial-class-elements class-element-map namespaces:set ;
|
||||
|
||||
GENERIC: coalesce-now ( insn -- )
|
||||
|
||||
|
|
|
@ -3,6 +3,7 @@ compiler.cfg.registers compiler.cfg.stacks.local
|
|||
compiler.cfg.utilities compiler.test cpu.architecture kernel
|
||||
kernel.private make math namespaces sequences.private slots.private
|
||||
tools.test ;
|
||||
QUALIFIED: sets
|
||||
IN: compiler.cfg.stacks.local.tests
|
||||
|
||||
! end-local-analysis
|
||||
|
|
|
@ -72,8 +72,8 @@ SYMBOLS: locs>vregs local-peek-set replaces ;
|
|||
: begin-local-analysis ( basic-block -- )
|
||||
height-state [ clone ] change
|
||||
height-state get [ reset-incs ] keep >>height drop
|
||||
HS{ } clone local-peek-set namespaces::set
|
||||
H{ } clone replaces namespaces::set ;
|
||||
HS{ } clone local-peek-set namespaces:set
|
||||
H{ } clone replaces namespaces:set ;
|
||||
|
||||
: remove-redundant-replaces ( replaces -- replaces' )
|
||||
[ [ loc>vreg ] dip = ] assoc-reject ;
|
||||
|
|
|
@ -15,13 +15,13 @@ IN: compiler.cfg.stacks.padding
|
|||
first2 swapd remove 2array ;
|
||||
|
||||
: combine-stacks ( stacks -- stack )
|
||||
[ first first ] [ [ second ] map sets::combine ] bi 2array ;
|
||||
[ first first ] [ [ second ] map sets:combine ] bi 2array ;
|
||||
|
||||
: classify-read ( stack n -- val )
|
||||
swap 2dup second member? [ 2drop 2 ] [ first >= [ 1 ] [ 0 ] if ] if ;
|
||||
|
||||
: shift-stack ( n stack -- stack' )
|
||||
first2 pick '[ _ + ] map [ 0 >= ] filter pick 0 max <iota> sets::union
|
||||
first2 pick '[ _ + ] map [ 0 >= ] filter pick 0 max <iota> sets:union
|
||||
[ + ] dip 2array ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
@ -2887,14 +2887,14 @@ cpu x86? [
|
|||
T{ ##peek f 1 d: 0 }
|
||||
T{ ##tagged>integer f 2 1 }
|
||||
T{ ##add-imm f 3 2 10 }
|
||||
T{ ##load-memory-imm f 4 2 10 int-rep c::uchar }
|
||||
T{ ##load-memory-imm f 4 2 10 int-rep c:uchar }
|
||||
}
|
||||
} [
|
||||
V{
|
||||
T{ ##peek f 1 d: 0 }
|
||||
T{ ##tagged>integer f 2 1 }
|
||||
T{ ##add-imm f 3 2 10 }
|
||||
T{ ##load-memory-imm f 4 3 0 int-rep c::uchar }
|
||||
T{ ##load-memory-imm f 4 3 0 int-rep c:uchar }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
|
@ -2905,7 +2905,7 @@ cpu x86? [
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add-imm f 4 3 10 }
|
||||
T{ ##store-memory-imm f 2 3 10 int-rep c::uchar }
|
||||
T{ ##store-memory-imm f 2 3 10 int-rep c:uchar }
|
||||
}
|
||||
} [
|
||||
V{
|
||||
|
@ -2914,7 +2914,7 @@ cpu x86? [
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add-imm f 4 3 10 }
|
||||
T{ ##store-memory-imm f 2 4 0 int-rep c::uchar }
|
||||
T{ ##store-memory-imm f 2 4 0 int-rep c:uchar }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
|
@ -2926,7 +2926,7 @@ cpu x86? [
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add f 4 2 3 }
|
||||
T{ ##load-memory f 5 2 3 0 0 int-rep c::uchar }
|
||||
T{ ##load-memory f 5 2 3 0 0 int-rep c:uchar }
|
||||
}
|
||||
} [
|
||||
V{
|
||||
|
@ -2935,7 +2935,7 @@ cpu x86? [
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add f 4 2 3 }
|
||||
T{ ##load-memory-imm f 5 4 0 int-rep c::uchar }
|
||||
T{ ##load-memory-imm f 5 4 0 int-rep c:uchar }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
|
@ -2946,7 +2946,7 @@ cpu x86? [
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add f 4 2 3 }
|
||||
T{ ##store-memory f 5 2 3 0 0 int-rep c::uchar }
|
||||
T{ ##store-memory f 5 2 3 0 0 int-rep c:uchar }
|
||||
}
|
||||
} [
|
||||
V{
|
||||
|
@ -2955,7 +2955,7 @@ cpu x86? [
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add f 4 2 3 }
|
||||
T{ ##store-memory-imm f 5 4 0 int-rep c::uchar }
|
||||
T{ ##store-memory-imm f 5 4 0 int-rep c:uchar }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
|
@ -2968,7 +2968,7 @@ cpu x86?
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add-imm f 4 2 31337 }
|
||||
T{ ##load-memory f 5 2 3 0 31337 int-rep c::uchar }
|
||||
T{ ##load-memory f 5 2 3 0 31337 int-rep c:uchar }
|
||||
}
|
||||
]
|
||||
[
|
||||
|
@ -2978,7 +2978,7 @@ cpu x86?
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add-imm f 4 2 31337 }
|
||||
T{ ##load-memory f 5 4 3 0 0 int-rep c::uchar }
|
||||
T{ ##load-memory f 5 4 3 0 0 int-rep c:uchar }
|
||||
}
|
||||
] ?
|
||||
[
|
||||
|
@ -2988,7 +2988,7 @@ cpu x86?
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add-imm f 4 2 31337 }
|
||||
T{ ##load-memory f 5 4 3 0 0 int-rep c::uchar }
|
||||
T{ ##load-memory f 5 4 3 0 0 int-rep c:uchar }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
|
@ -3001,7 +3001,7 @@ cpu x86?
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add-imm f 4 3 31337 }
|
||||
T{ ##load-memory f 5 2 3 0 31338 int-rep c::uchar }
|
||||
T{ ##load-memory f 5 2 3 0 31338 int-rep c:uchar }
|
||||
}
|
||||
]
|
||||
[
|
||||
|
@ -3011,7 +3011,7 @@ cpu x86?
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add-imm f 4 3 31337 }
|
||||
T{ ##load-memory f 5 2 4 0 1 int-rep c::uchar }
|
||||
T{ ##load-memory f 5 2 4 0 1 int-rep c:uchar }
|
||||
}
|
||||
] ?
|
||||
[
|
||||
|
@ -3021,7 +3021,7 @@ cpu x86?
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add-imm f 4 3 31337 }
|
||||
T{ ##load-memory f 5 2 4 0 1 int-rep c::uchar }
|
||||
T{ ##load-memory f 5 2 4 0 1 int-rep c:uchar }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
|
@ -3034,7 +3034,7 @@ cpu x86?
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add-imm f 4 3 10 }
|
||||
T{ ##load-memory f 5 2 4 1 1 int-rep c::uchar }
|
||||
T{ ##load-memory f 5 2 4 1 1 int-rep c:uchar }
|
||||
} dup value-numbering-step assert=
|
||||
] unit-test
|
||||
|
||||
|
@ -3047,7 +3047,7 @@ ${
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##shl-imm f 4 3 2 }
|
||||
T{ ##load-memory f 5 2 3 2 0 int-rep c::uchar }
|
||||
T{ ##load-memory f 5 2 3 2 0 int-rep c:uchar }
|
||||
}
|
||||
V{
|
||||
T{ ##peek f 0 d: 0 }
|
||||
|
@ -3055,7 +3055,7 @@ ${
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##shl-imm f 4 3 2 }
|
||||
T{ ##load-memory f 5 2 4 0 0 int-rep c::uchar }
|
||||
T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
|
||||
} ?
|
||||
} [
|
||||
V{
|
||||
|
@ -3064,7 +3064,7 @@ ${
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##shl-imm f 4 3 2 }
|
||||
T{ ##load-memory f 5 2 4 0 0 int-rep c::uchar }
|
||||
T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
|
@ -3077,7 +3077,7 @@ cpu x86? [
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##shl-imm f 4 3 2 }
|
||||
T{ ##load-memory f 5 2 4 1 0 int-rep c::uchar }
|
||||
T{ ##load-memory f 5 2 4 1 0 int-rep c:uchar }
|
||||
} dup value-numbering-step assert=
|
||||
] unit-test
|
||||
|
||||
|
@ -3089,7 +3089,7 @@ cpu x86? [
|
|||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##shl-imm f 4 3 4 }
|
||||
T{ ##load-memory f 5 2 4 0 0 int-rep c::uchar }
|
||||
T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
|
||||
} dup value-numbering-step assert=
|
||||
] unit-test
|
||||
] when
|
||||
|
|
|
@ -54,9 +54,9 @@ M: ##copy eliminate-write-barrier
|
|||
M: insn eliminate-write-barrier drop t ;
|
||||
|
||||
: write-barriers-step ( insns -- insns' )
|
||||
HS{ } clone fresh-allocations namespaces::set
|
||||
HS{ } clone mutated-objects namespaces::set
|
||||
H{ } clone copies namespaces::set
|
||||
HS{ } clone fresh-allocations namespaces:set
|
||||
HS{ } clone mutated-objects namespaces:set
|
||||
H{ } clone copies namespaces:set
|
||||
[ eliminate-write-barrier ] filter! ;
|
||||
|
||||
: eliminate-write-barriers ( cfg -- )
|
||||
|
|
|
@ -55,7 +55,7 @@ M: fake-cpu gc-root-offset ;
|
|||
uint-array{ 100 } underlying>> %
|
||||
|
||||
! GC info footer - 12 bytes
|
||||
S{ vm::gc-info
|
||||
S{ vm:gc-info
|
||||
{ gc-root-count 4 }
|
||||
{ derived-root-count 3 }
|
||||
{ return-address-count 1 }
|
||||
|
|
|
@ -25,9 +25,9 @@ SYMBOL: compiled
|
|||
|
||||
: start-compilation ( word -- )
|
||||
dup name>> compiler-message
|
||||
H{ } clone dependencies namespaces::set
|
||||
H{ } clone generic-dependencies namespaces::set
|
||||
HS{ } clone conditional-dependencies namespaces::set
|
||||
H{ } clone dependencies namespaces:set
|
||||
H{ } clone generic-dependencies namespaces:set
|
||||
HS{ } clone conditional-dependencies namespaces:set
|
||||
clear-compiler-error ;
|
||||
|
||||
GENERIC: no-compile? ( word -- ? )
|
||||
|
|
|
@ -22,7 +22,7 @@ IN: compiler.tests.callstack-overflow
|
|||
: overflow/w-primitive ( -- )
|
||||
reset-dispatch-stats overflow/w-primitive post ;
|
||||
|
||||
: get-context ( -- ctx ) context vm::context memory>struct ;
|
||||
: get-context ( -- ctx ) context vm:context memory>struct ;
|
||||
|
||||
: remaining-stack ( -- n )
|
||||
get-context [ callstack-top>> ] [ callstack-seg>> start>> ] bi - ;
|
||||
|
|
|
@ -52,7 +52,7 @@ unit-test
|
|||
[ 3 ]
|
||||
[
|
||||
global [ 3 \ foo set ] with-variables
|
||||
\ foo [ global >n get namespaces.private::ndrop ] compile-call
|
||||
\ foo [ global >n get namespaces.private:ndrop ] compile-call
|
||||
] unit-test
|
||||
|
||||
: blech ( x -- ) drop ;
|
||||
|
@ -66,7 +66,7 @@ unit-test
|
|||
[ 3 ]
|
||||
[
|
||||
global [ 3 \ foo set ] with-variables
|
||||
\ foo [ global [ get ] swap >n call namespaces.private::ndrop ] compile-call
|
||||
\ foo [ global [ get ] swap >n call namespaces.private:ndrop ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 3 ]
|
||||
|
|
|
@ -2,8 +2,8 @@ USING: compiler.units compiler.test kernel kernel.private memory
|
|||
math math.private tools.test math.floats.private math.order fry
|
||||
specialized-arrays sequences math.functions layouts literals ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
SPECIALIZED-ARRAY: c::float
|
||||
SPECIALIZED-ARRAY: c::double
|
||||
SPECIALIZED-ARRAY: c:float
|
||||
SPECIALIZED-ARRAY: c:double
|
||||
IN: compiler.tests.float
|
||||
|
||||
[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test
|
||||
|
|
|
@ -467,8 +467,8 @@ ERROR: bug-in-fixnum* x y a b ;
|
|||
[ t ] [ pi double <ref> [ { byte-array } declare double deref ] compile-call pi = ] unit-test
|
||||
|
||||
! Silly
|
||||
[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep c::float deref pi - -0.001 0.001 between? ] unit-test
|
||||
[ t ] [ pi c::float <ref> [ { byte-array } declare c::float deref ] compile-call pi - -0.001 0.001 between? ] unit-test
|
||||
[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep c:float deref pi - -0.001 0.001 between? ] unit-test
|
||||
[ t ] [ pi c:float <ref> [ { byte-array } declare c:float deref ] compile-call pi - -0.001 0.001 between? ] unit-test
|
||||
|
||||
[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep double deref pi = ] unit-test
|
||||
|
||||
|
|
|
@ -2,14 +2,14 @@ USING: alien alien.syntax eval math tools.test ;
|
|||
QUALIFIED: alien.c-types
|
||||
IN: compiler.tests.redefine24
|
||||
|
||||
TYPEDEF: alien.c-types::int type-1
|
||||
TYPEDEF: alien.c-types:int type-1
|
||||
|
||||
TYPEDEF: alien.c-types::int type-3
|
||||
TYPEDEF: alien.c-types:int type-3
|
||||
|
||||
: callback ( -- ptr )
|
||||
type-3 { type-1 type-1 } cdecl [ + >integer ] alien-callback ;
|
||||
|
||||
TYPEDEF: alien.c-types::float type-2
|
||||
TYPEDEF: alien.c-types:float type-2
|
||||
|
||||
: indirect ( x y ptr -- z )
|
||||
type-3 { type-2 type-2 } cdecl alien-indirect ;
|
||||
|
|
|
@ -74,8 +74,8 @@ GENERIC: check-stack-flow* ( node -- )
|
|||
[ check-stack-flow* terminated? get not ] all? drop ;
|
||||
|
||||
: init-stack-flow ( -- )
|
||||
V{ } clone datastack namespaces::set
|
||||
V{ } clone retainstack namespaces::set ;
|
||||
V{ } clone datastack namespaces:set
|
||||
V{ } clone retainstack namespaces:set ;
|
||||
|
||||
: check-stack-flow ( nodes -- )
|
||||
[
|
||||
|
@ -149,7 +149,7 @@ SYMBOL: branch-out
|
|||
: check-branch ( nodes -- stack )
|
||||
[
|
||||
datastack [ clone ] change
|
||||
V{ } clone retainstack namespaces::set
|
||||
V{ } clone retainstack namespaces:set
|
||||
(check-stack-flow)
|
||||
terminated? get [ assert-retainstack-empty ] unless
|
||||
terminated? get f datastack get ?
|
||||
|
@ -157,7 +157,7 @@ SYMBOL: branch-out
|
|||
|
||||
M: #branch check-stack-flow*
|
||||
[ check-in-d ]
|
||||
[ children>> [ check-branch ] map branch-out namespaces::set ]
|
||||
[ children>> [ check-branch ] map branch-out namespaces:set ]
|
||||
bi ;
|
||||
|
||||
: check-phi-in ( #phi -- )
|
||||
|
@ -174,7 +174,7 @@ M: #branch check-stack-flow*
|
|||
|
||||
: set-phi-datastack ( #phi -- )
|
||||
phi-in-d>> first length
|
||||
branch-out get [ ] find nip swap head* >vector datastack namespaces::set ;
|
||||
branch-out get [ ] find nip swap head* >vector datastack namespaces:set ;
|
||||
|
||||
M: #phi check-stack-flow*
|
||||
branch-out get [ ] any? [
|
||||
|
|
|
@ -238,22 +238,22 @@ M: float detect-float ;
|
|||
] when
|
||||
|
||||
{ t } [
|
||||
[ B{ 1 0 } c::short deref 0 number= ]
|
||||
[ B{ 1 0 } c:short deref 0 number= ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
[ B{ 1 0 } c::short deref 0 { number number } declare number= ]
|
||||
[ B{ 1 0 } c:short deref 0 { number number } declare number= ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
[ B{ 1 0 } c::short deref 0 = ]
|
||||
[ B{ 1 0 } c:short deref 0 = ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
[ B{ 1 0 } c::short deref dup number? [ 0 number= ] [ drop f ] if ]
|
||||
[ B{ 1 0 } c:short deref dup number? [ 0 number= ] [ drop f ] if ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
|
|
|
@ -18,8 +18,8 @@ SYMBOL: live-values
|
|||
: look-at-inputs ( node -- ) in-d>> look-at-values ;
|
||||
|
||||
: init-dead-code ( -- )
|
||||
<hashed-dlist> work-list namespaces::set
|
||||
H{ { +bottom+ f } } clone live-values namespaces::set ;
|
||||
<hashed-dlist> work-list namespaces:set
|
||||
H{ { +bottom+ f } } clone live-values namespaces:set ;
|
||||
|
||||
GENERIC: mark-live-values* ( node -- )
|
||||
|
||||
|
|
|
@ -51,7 +51,7 @@ GENERIC: node-uses-values ( node -- values )
|
|||
|
||||
M: #introduce node-uses-values drop f ;
|
||||
M: #push node-uses-values drop f ;
|
||||
M: #phi node-uses-values phi-in-d>> concat remove-bottom sets::members ;
|
||||
M: #phi node-uses-values phi-in-d>> concat remove-bottom sets:members ;
|
||||
M: #declare node-uses-values drop f ;
|
||||
M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
|
||||
M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
|
||||
|
|
|
@ -18,8 +18,8 @@ SYMBOLS: visited accum ;
|
|||
|
||||
: with-simplified-def-use ( quot -- real-usages )
|
||||
[
|
||||
HS{ } clone visited namespaces::set
|
||||
HS{ } clone accum namespaces::set
|
||||
HS{ } clone visited namespaces:set
|
||||
HS{ } clone accum namespaces:set
|
||||
call
|
||||
accum get members
|
||||
] with-scope ; inline
|
||||
|
|
|
@ -98,8 +98,8 @@ M: node compute-modular-candidates*
|
|||
drop ;
|
||||
|
||||
: compute-modular-candidates ( nodes -- )
|
||||
HS{ } clone modular-values namespaces::set
|
||||
HS{ } clone fixnum-values namespaces::set
|
||||
HS{ } clone modular-values namespaces:set
|
||||
HS{ } clone fixnum-values namespaces:set
|
||||
[ compute-modular-candidates* ] each-node ;
|
||||
|
||||
GENERIC: only-reads-low-order? ( node -- ? )
|
||||
|
|
|
@ -302,17 +302,17 @@ CONSTANT: lookup-table-at-max 256
|
|||
: diff-quot ( seq -- quot: ( seq' -- seq'' ) )
|
||||
[ tester ] keep '[ members _ reject _ set-like ] ;
|
||||
|
||||
M\\ sets::set diff [ diff-quot ] 1 define-partial-eval
|
||||
M\\ sets:set diff [ diff-quot ] 1 define-partial-eval
|
||||
|
||||
: intersect-quot ( seq -- quot: ( seq' -- seq'' ) )
|
||||
[ tester ] keep '[ members _ filter _ set-like ] ;
|
||||
|
||||
M\\ sets::set intersect [ intersect-quot ] 1 define-partial-eval
|
||||
M\\ sets:set intersect [ intersect-quot ] 1 define-partial-eval
|
||||
|
||||
: intersects?-quot ( seq -- quot: ( seq' -- seq'' ) )
|
||||
tester '[ members _ any? ] ;
|
||||
|
||||
M\\ sets::set intersects? [ intersects?-quot ] 1 define-partial-eval
|
||||
M\\ sets:set intersects? [ intersects?-quot ] 1 define-partial-eval
|
||||
|
||||
: bit-quot ( #call -- quot/f )
|
||||
in-d>> second value-info interval>> 0 fixnum-bits [a,b] interval-subset?
|
||||
|
|
|
@ -35,8 +35,8 @@ GENERIC: node-call-graph ( tail? node -- )
|
|||
|
||||
: build-call-graph ( nodes -- labels calls )
|
||||
[
|
||||
V{ } clone children namespaces::set
|
||||
V{ } clone calls namespaces::set
|
||||
V{ } clone children namespaces:set
|
||||
V{ } clone calls namespaces:set
|
||||
[ t ] dip (build-call-graph)
|
||||
children get
|
||||
calls get
|
||||
|
@ -111,8 +111,8 @@ SYMBOL: changed?
|
|||
[ changed? get [ while-changing ] [ drop ] if ] bi ; inline recursive
|
||||
|
||||
: detect-loops ( call-graph -- )
|
||||
HS{ } clone not-loops namespaces::set
|
||||
V{ } clone recursive-nesting namespaces::set
|
||||
HS{ } clone not-loops namespaces:set
|
||||
V{ } clone recursive-nesting namespaces:set
|
||||
[ visit-back-edges ]
|
||||
[ '[ _ detect-cross-frame-calls ] while-changing ]
|
||||
bi ;
|
||||
|
@ -130,7 +130,7 @@ SYMBOL: call-graph
|
|||
|
||||
: analyze-recursive ( nodes -- nodes )
|
||||
dup build-call-graph drop
|
||||
[ call-graph namespaces::set ]
|
||||
[ call-graph namespaces:set ]
|
||||
[ detect-loops ]
|
||||
[ mark-loops ]
|
||||
tri ;
|
||||
|
|
|
@ -63,13 +63,13 @@ TUPLE: huffman-decoder
|
|||
dup [ tdesc>> ] [ bits/level>> 2^ ] bi reverse-table >>rtable ; inline
|
||||
|
||||
: read1-huff ( huffman-decoder -- elt )
|
||||
16 over [ bs>> bs::peek ] [ rtable>> nth ] bi
|
||||
[ size>> swap bs>> bs::seek ] [ value>> ] bi ; inline
|
||||
16 over [ bs>> bs:peek ] [ rtable>> nth ] bi
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
|
||||
|
||||
: reverse-bits ( value bits -- value' )
|
||||
[ integer>bit-array ] dip
|
||||
f pad-tail reverse bit-array>integer ; inline
|
||||
|
||||
: read1-huff2 ( huffman-decoder -- elt )
|
||||
16 over [ bs>> bs::peek 16 reverse-bits ] [ rtable>> nth ] bi
|
||||
[ size>> swap bs>> bs::seek ] [ value>> ] bi ; inline
|
||||
16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
|
||||
|
|
|
@ -13,14 +13,14 @@ ERROR: bad-zlib-data ;
|
|||
ERROR: bad-zlib-header ;
|
||||
|
||||
:: check-zlib-header ( data -- )
|
||||
16 data bs::peek 2 >le be> 31 mod ! checksum
|
||||
16 data bs:peek 2 >le be> 31 mod ! checksum
|
||||
0 assert=
|
||||
4 data bs::read 8 assert= ! compression method: deflate
|
||||
4 data bs::read ! log2(max length)-8, 32K max
|
||||
4 data bs:read 8 assert= ! compression method: deflate
|
||||
4 data bs:read ! log2(max length)-8, 32K max
|
||||
7 <= [ bad-zlib-header ] unless
|
||||
5 data bs::seek ! drop check bits
|
||||
1 data bs::read 0 assert= ! dictionary - not allowed in png
|
||||
2 data bs::seek ! compression level; ignore
|
||||
5 data bs:seek ! drop check bits
|
||||
1 data bs:read 0 assert= ! dictionary - not allowed in png
|
||||
2 data bs:seek ! compression level; ignore
|
||||
;
|
||||
|
||||
CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
|
||||
|
@ -31,19 +31,19 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
|
|||
seq>> rest-slice [ natural-sort ] map ; inline
|
||||
|
||||
:: decode-huffman-tables ( bitstream -- tables )
|
||||
5 bitstream bs::read 257 +
|
||||
5 bitstream bs::read 1 +
|
||||
4 bitstream bs::read 4 + clen-shuffle swap head
|
||||
5 bitstream bs:read 257 +
|
||||
5 bitstream bs:read 1 +
|
||||
4 bitstream bs:read 4 + clen-shuffle swap head
|
||||
|
||||
dup length [ 3 bitstream bs::read ] replicate
|
||||
dup length [ 3 bitstream bs:read ] replicate
|
||||
get-table
|
||||
bitstream swap <huffman-decoder>
|
||||
[ 2dup + ] dip swap :> k!
|
||||
'[
|
||||
_ read1-huff2 {
|
||||
{ [ dup 16 = ] [ 2 bitstream bs::read 3 + 2array ] }
|
||||
{ [ dup 17 = ] [ 3 bitstream bs::read 3 + 2array ] }
|
||||
{ [ dup 18 = ] [ 7 bitstream bs::read 11 + 2array ] }
|
||||
{ [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
|
||||
{ [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
|
||||
{ [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
|
||||
[ ]
|
||||
} cond
|
||||
dup array? [ dup second ] [ 1 ] if
|
||||
|
@ -105,7 +105,7 @@ CONSTANT: dist-table
|
|||
dup 264 > [
|
||||
dup 261 - 4 /i
|
||||
dup 5 > [ bad-zlib-data ] when
|
||||
bitstream bs::read 2array
|
||||
bitstream bs:read 2array
|
||||
] when
|
||||
] unless
|
||||
|
||||
|
@ -114,7 +114,7 @@ CONSTANT: dist-table
|
|||
dup 3 > [
|
||||
dup 2 - 2 /i dup 13 >
|
||||
[ bad-zlib-data ] when
|
||||
bitstream bs::read 2array
|
||||
bitstream bs:read 2array
|
||||
] when 2array
|
||||
] when dup 256 = not
|
||||
] [ ] produce nip
|
||||
|
@ -131,9 +131,9 @@ CONSTANT: dist-table
|
|||
] map ;
|
||||
|
||||
:: inflate-raw ( bitstream -- bytes )
|
||||
8 bitstream bs::align
|
||||
16 bitstream bs::read :> len
|
||||
16 bitstream bs::read :> nlen
|
||||
8 bitstream bs:align
|
||||
16 bitstream bs:read :> len
|
||||
16 bitstream bs:read :> nlen
|
||||
|
||||
! len + ~len = -1
|
||||
len nlen + 16 >signed -1 assert=
|
||||
|
@ -141,7 +141,7 @@ CONSTANT: dist-table
|
|||
bitstream byte-pos>>
|
||||
bitstream byte-pos>> len +
|
||||
bitstream bytes>> <slice>
|
||||
len 8 * bitstream bs::seek ;
|
||||
len 8 * bitstream bs:seek ;
|
||||
|
||||
: inflate-dynamic ( bitstream -- array )
|
||||
dup decode-huffman-tables inflate-huffman ;
|
||||
|
@ -150,9 +150,9 @@ CONSTANT: dist-table
|
|||
static-huffman-tables inflate-huffman ;
|
||||
|
||||
:: inflate-loop ( bitstream -- array )
|
||||
[ 1 bitstream bs::read 0 = ] [
|
||||
[ 1 bitstream bs:read 0 = ] [
|
||||
bitstream
|
||||
2 bitstream bs::read
|
||||
2 bitstream bs:read
|
||||
{
|
||||
{ 0 [ inflate-raw ] }
|
||||
{ 1 [ inflate-static ] }
|
||||
|
@ -164,6 +164,6 @@ CONSTANT: dist-table
|
|||
PRIVATE>
|
||||
|
||||
: zlib-inflate ( bytes -- bytes )
|
||||
bs::<lsb0-bit-reader>
|
||||
bs:<lsb0-bit-reader>
|
||||
[ check-zlib-header ] [ inflate-loop ] bi
|
||||
inflate-lz77 ;
|
||||
|
|
|
@ -73,7 +73,7 @@ M: gif-lzw increment-code-size [ 1 + 12 min ] change-code-size ;
|
|||
[ maybe-increment-code-size 2drop ] 2bi ;
|
||||
|
||||
: lzw-read ( lzw -- lzw n )
|
||||
[ ] [ code-size>> ] [ input>> ] tri bs::read ;
|
||||
[ ] [ code-size>> ] [ input>> ] tri bs:read ;
|
||||
|
||||
: end-of-information? ( lzw code -- ? ) swap end-of-information-code>> = ;
|
||||
: clear-code? ( lzw code -- ? ) swap clear-code>> = ;
|
||||
|
@ -121,7 +121,7 @@ DEFER: lzw-uncompress-char
|
|||
[ lzw-uncompress-char ] [ output>> ] bi ;
|
||||
|
||||
: tiff-lzw-uncompress ( seq -- byte-array )
|
||||
bs::<msb0-bit-reader> 9 tiff-lzw lzw-uncompress ;
|
||||
bs:<msb0-bit-reader> 9 tiff-lzw lzw-uncompress ;
|
||||
|
||||
: gif-lzw-uncompress ( seq code-size -- byte-array )
|
||||
[ bs::<lsb0-bit-reader> ] dip gif-lzw lzw-uncompress ;
|
||||
[ bs:<lsb0-bit-reader> ] dip gif-lzw lzw-uncompress ;
|
||||
|
|
|
@ -5,4 +5,4 @@ QUALIFIED-WITH: compression.zlib.ffi ffi
|
|||
|
||||
{ t } [ B{ 1 2 3 4 5 } [ compress uncompress ] keep = ] unit-test
|
||||
|
||||
[ ffi::Z_DATA_ERROR zlib-error-message ] [ string>> "data error" = ] must-fail-with
|
||||
[ ffi:Z_DATA_ERROR zlib-error-message ] [ string>> "data error" = ] must-fail-with
|
||||
|
|
|
@ -9,7 +9,7 @@ IN: compression.zlib
|
|||
ERROR: zlib-failed n string ;
|
||||
|
||||
: zlib-error-message ( n -- * )
|
||||
dup compression.zlib.ffi::Z_ERRNO = [
|
||||
dup compression.zlib.ffi:Z_ERRNO = [
|
||||
drop errno "native libc error"
|
||||
] [
|
||||
dup
|
||||
|
@ -23,8 +23,8 @@ ERROR: zlib-failed n string ;
|
|||
|
||||
: zlib-error ( n -- )
|
||||
dup {
|
||||
{ compression.zlib.ffi::Z_OK [ drop ] }
|
||||
{ compression.zlib.ffi::Z_STREAM_END [ drop ] }
|
||||
{ compression.zlib.ffi:Z_OK [ drop ] }
|
||||
{ compression.zlib.ffi:Z_STREAM_END [ drop ] }
|
||||
[ dup zlib-error-message zlib-failed ]
|
||||
} case ;
|
||||
|
||||
|
@ -36,14 +36,14 @@ ERROR: zlib-failed n string ;
|
|||
compressed-size
|
||||
[ <byte-vector> dup underlying>> ] keep ulong <ref>
|
||||
] keep [
|
||||
dup length compression.zlib.ffi::compress zlib-error
|
||||
dup length compression.zlib.ffi:compress zlib-error
|
||||
] keepd ulong deref >>length B{ } like ;
|
||||
|
||||
: (uncompress) ( length byte-array -- byte-array )
|
||||
[
|
||||
[ drop [ malloc &free ] [ ulong <ref> ] bi ]
|
||||
[ nip dup length ] 2bi
|
||||
[ compression.zlib.ffi::uncompress zlib-error ] 4keep
|
||||
[ compression.zlib.ffi:uncompress zlib-error ] 4keep
|
||||
2drop ulong deref memory>byte-array
|
||||
] with-destructors ;
|
||||
|
||||
|
|
|
@ -62,7 +62,7 @@ ERROR: unsupported-number-type type ;
|
|||
{ kCFNumberSInt64Type [ SInt64 (CFNumber>number) ] }
|
||||
{ kCFNumberFloat64Type [ double (CFNumber>number) ] }
|
||||
{ kCFNumberCharType [ char (CFNumber>number) ] }
|
||||
{ kCFNumberShortType [ c::short (CFNumber>number) ] }
|
||||
{ kCFNumberShortType [ c:short (CFNumber>number) ] }
|
||||
{ kCFNumberIntType [ int (CFNumber>number) ] }
|
||||
{ kCFNumberLongType [ long (CFNumber>number) ] }
|
||||
{ kCFNumberLongLongType [ longlong (CFNumber>number) ] }
|
||||
|
|
|
@ -686,36 +686,36 @@ M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
|
|||
|
||||
M:: ppc.32 %convert-integer ( dst src c-type -- )
|
||||
c-type {
|
||||
{ c::char [ dst src 24 CLRLWI dst dst EXTSB ] }
|
||||
{ c::uchar [ dst src 24 CLRLWI ] }
|
||||
{ c::short [ dst src 16 CLRLWI dst dst EXTSH ] }
|
||||
{ c::ushort [ dst src 16 CLRLWI ] }
|
||||
{ c::int [ ] }
|
||||
{ c::uint [ ] }
|
||||
{ c:char [ dst src 24 CLRLWI dst dst EXTSB ] }
|
||||
{ c:uchar [ dst src 24 CLRLWI ] }
|
||||
{ c:short [ dst src 16 CLRLWI dst dst EXTSH ] }
|
||||
{ c:ushort [ dst src 16 CLRLWI ] }
|
||||
{ c:int [ ] }
|
||||
{ c:uint [ ] }
|
||||
} case ;
|
||||
|
||||
M:: ppc.64 %convert-integer ( dst src c-type -- )
|
||||
c-type {
|
||||
{ c::char [ dst src 56 CLRLDI dst dst EXTSB ] }
|
||||
{ c::uchar [ dst src 56 CLRLDI ] }
|
||||
{ c::short [ dst src 48 CLRLDI dst dst EXTSH ] }
|
||||
{ c::ushort [ dst src 48 CLRLDI ] }
|
||||
{ c::int [ dst src 32 CLRLDI dst dst EXTSW ] }
|
||||
{ c::uint [ dst src 32 CLRLDI ] }
|
||||
{ c::longlong [ ] }
|
||||
{ c::ulonglong [ ] }
|
||||
{ c:char [ dst src 56 CLRLDI dst dst EXTSB ] }
|
||||
{ c:uchar [ dst src 56 CLRLDI ] }
|
||||
{ c:short [ dst src 48 CLRLDI dst dst EXTSH ] }
|
||||
{ c:ushort [ dst src 48 CLRLDI ] }
|
||||
{ c:int [ dst src 32 CLRLDI dst dst EXTSW ] }
|
||||
{ c:uint [ dst src 32 CLRLDI ] }
|
||||
{ c:longlong [ ] }
|
||||
{ c:ulonglong [ ] }
|
||||
} case ;
|
||||
|
||||
M: ppc.32 %load-memory-imm ( dst base offset rep c-type -- )
|
||||
[
|
||||
pick %trap-null
|
||||
{
|
||||
{ c::char [ [ dup ] 2dip LBZ dup EXTSB ] }
|
||||
{ c::uchar [ LBZ ] }
|
||||
{ c::short [ LHA ] }
|
||||
{ c::ushort [ LHZ ] }
|
||||
{ c::int [ LWZ ] }
|
||||
{ c::uint [ LWZ ] }
|
||||
{ c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
|
||||
{ c:uchar [ LBZ ] }
|
||||
{ c:short [ LHA ] }
|
||||
{ c:ushort [ LHZ ] }
|
||||
{ c:int [ LWZ ] }
|
||||
{ c:uint [ LWZ ] }
|
||||
} case
|
||||
] [
|
||||
{
|
||||
|
@ -729,14 +729,14 @@ M: ppc.64 %load-memory-imm ( dst base offset rep c-type -- )
|
|||
[
|
||||
pick %trap-null
|
||||
{
|
||||
{ c::char [ [ dup ] 2dip LBZ dup EXTSB ] }
|
||||
{ c::uchar [ LBZ ] }
|
||||
{ c::short [ LHA ] }
|
||||
{ c::ushort [ LHZ ] }
|
||||
{ c::int [ LWZ ] }
|
||||
{ c::uint [ LWZ ] }
|
||||
{ c::longlong [ [ scratch-reg ] dip LI scratch-reg LDX ] }
|
||||
{ c::ulonglong [ [ scratch-reg ] dip LI scratch-reg LDX ] }
|
||||
{ c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
|
||||
{ c:uchar [ LBZ ] }
|
||||
{ c:short [ LHA ] }
|
||||
{ c:ushort [ LHZ ] }
|
||||
{ c:int [ LWZ ] }
|
||||
{ c:uint [ LWZ ] }
|
||||
{ c:longlong [ [ scratch-reg ] dip LI scratch-reg LDX ] }
|
||||
{ c:ulonglong [ [ scratch-reg ] dip LI scratch-reg LDX ] }
|
||||
} case
|
||||
] [
|
||||
{
|
||||
|
@ -752,12 +752,12 @@ M: ppc.32 %load-memory ( dst base displacement scale offset rep c-type -- )
|
|||
[
|
||||
pick %trap-null
|
||||
{
|
||||
{ c::char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
|
||||
{ c::uchar [ LBZX ] }
|
||||
{ c::short [ LHAX ] }
|
||||
{ c::ushort [ LHZX ] }
|
||||
{ c::int [ LWZX ] }
|
||||
{ c::uint [ LWZX ] }
|
||||
{ c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
|
||||
{ c:uchar [ LBZX ] }
|
||||
{ c:short [ LHAX ] }
|
||||
{ c:ushort [ LHZX ] }
|
||||
{ c:int [ LWZX ] }
|
||||
{ c:uint [ LWZX ] }
|
||||
} case
|
||||
] [
|
||||
{
|
||||
|
@ -772,14 +772,14 @@ M: ppc.64 %load-memory ( dst base displacement scale offset rep c-type -- )
|
|||
[
|
||||
pick %trap-null
|
||||
{
|
||||
{ c::char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
|
||||
{ c::uchar [ LBZX ] }
|
||||
{ c::short [ LHAX ] }
|
||||
{ c::ushort [ LHZX ] }
|
||||
{ c::int [ LWZX ] }
|
||||
{ c::uint [ LWZX ] }
|
||||
{ c::longlong [ LDX ] }
|
||||
{ c::ulonglong [ LDX ] }
|
||||
{ c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
|
||||
{ c:uchar [ LBZX ] }
|
||||
{ c:short [ LHAX ] }
|
||||
{ c:ushort [ LHZX ] }
|
||||
{ c:int [ LWZX ] }
|
||||
{ c:uint [ LWZX ] }
|
||||
{ c:longlong [ LDX ] }
|
||||
{ c:ulonglong [ LDX ] }
|
||||
} case
|
||||
] [
|
||||
{
|
||||
|
@ -793,12 +793,12 @@ M: ppc.64 %load-memory ( dst base displacement scale offset rep c-type -- )
|
|||
M: ppc.32 %store-memory-imm ( src base offset rep c-type -- )
|
||||
[
|
||||
{
|
||||
{ c::char [ STB ] }
|
||||
{ c::uchar [ STB ] }
|
||||
{ c::short [ STH ] }
|
||||
{ c::ushort [ STH ] }
|
||||
{ c::int [ STW ] }
|
||||
{ c::uint [ STW ] }
|
||||
{ c:char [ STB ] }
|
||||
{ c:uchar [ STB ] }
|
||||
{ c:short [ STH ] }
|
||||
{ c:ushort [ STH ] }
|
||||
{ c:int [ STW ] }
|
||||
{ c:uint [ STW ] }
|
||||
} case
|
||||
] [
|
||||
{
|
||||
|
@ -811,14 +811,14 @@ M: ppc.32 %store-memory-imm ( src base offset rep c-type -- )
|
|||
M: ppc.64 %store-memory-imm ( src base offset rep c-type -- )
|
||||
[
|
||||
{
|
||||
{ c::char [ STB ] }
|
||||
{ c::uchar [ STB ] }
|
||||
{ c::short [ STH ] }
|
||||
{ c::ushort [ STH ] }
|
||||
{ c::int [ STW ] }
|
||||
{ c::uint [ STW ] }
|
||||
{ c::longlong [ [ scratch-reg ] dip LI scratch-reg STDX ] }
|
||||
{ c::ulonglong [ [ scratch-reg ] dip LI scratch-reg STDX ] }
|
||||
{ c:char [ STB ] }
|
||||
{ c:uchar [ STB ] }
|
||||
{ c:short [ STH ] }
|
||||
{ c:ushort [ STH ] }
|
||||
{ c:int [ STW ] }
|
||||
{ c:uint [ STW ] }
|
||||
{ c:longlong [ [ scratch-reg ] dip LI scratch-reg STDX ] }
|
||||
{ c:ulonglong [ [ scratch-reg ] dip LI scratch-reg STDX ] }
|
||||
} case
|
||||
] [
|
||||
{
|
||||
|
@ -832,12 +832,12 @@ M: ppc.32 %store-memory ( src base displacement scale offset rep c-type -- )
|
|||
[ [ 0 assert= ] bi@ ] 2dip
|
||||
[
|
||||
{
|
||||
{ c::char [ STBX ] }
|
||||
{ c::uchar [ STBX ] }
|
||||
{ c::short [ STHX ] }
|
||||
{ c::ushort [ STHX ] }
|
||||
{ c::int [ STWX ] }
|
||||
{ c::uint [ STWX ] }
|
||||
{ c:char [ STBX ] }
|
||||
{ c:uchar [ STBX ] }
|
||||
{ c:short [ STHX ] }
|
||||
{ c:ushort [ STHX ] }
|
||||
{ c:int [ STWX ] }
|
||||
{ c:uint [ STWX ] }
|
||||
} case
|
||||
] [
|
||||
{
|
||||
|
@ -851,14 +851,14 @@ M: ppc.64 %store-memory ( src base displacement scale offset rep c-type -- )
|
|||
[ [ 0 assert= ] bi@ ] 2dip
|
||||
[
|
||||
{
|
||||
{ c::char [ STBX ] }
|
||||
{ c::uchar [ STBX ] }
|
||||
{ c::short [ STHX ] }
|
||||
{ c::ushort [ STHX ] }
|
||||
{ c::int [ STWX ] }
|
||||
{ c::uint [ STWX ] }
|
||||
{ c::longlong [ STDX ] }
|
||||
{ c::ulonglong [ STDX ] }
|
||||
{ c:char [ STBX ] }
|
||||
{ c:uchar [ STBX ] }
|
||||
{ c:short [ STHX ] }
|
||||
{ c:ushort [ STHX ] }
|
||||
{ c:int [ STWX ] }
|
||||
{ c:uint [ STWX ] }
|
||||
{ c:longlong [ STDX ] }
|
||||
{ c:ulonglong [ STDX ] }
|
||||
} case
|
||||
] [
|
||||
{
|
||||
|
|
|
@ -8,8 +8,8 @@ QUALIFIED-WITH: alien.c-types c
|
|||
IN: cpu.x86.sse
|
||||
|
||||
! Scalar floating point with SSE2
|
||||
M: x86 %load-float c::float <ref> float-rep %load-vector ;
|
||||
M: x86 %load-double c::double <ref> double-rep %load-vector ;
|
||||
M: x86 %load-float c:float <ref> float-rep %load-vector ;
|
||||
M: x86 %load-double c:double <ref> double-rep %load-vector ;
|
||||
|
||||
M: float-rep copy-register* drop MOVAPS ;
|
||||
M: double-rep copy-register* drop MOVAPS ;
|
||||
|
|
|
@ -366,12 +366,12 @@ M: x86.64 has-small-reg? 2drop t ;
|
|||
|
||||
M: x86 %convert-integer ( dst src c-type -- )
|
||||
{
|
||||
{ c::char [ 8 %sign-extend ] }
|
||||
{ c::uchar [ 8 %zero-extend ] }
|
||||
{ c::short [ 16 %sign-extend ] }
|
||||
{ c::ushort [ 16 %zero-extend ] }
|
||||
{ c::int [ 32 %sign-extend ] }
|
||||
{ c::uint [ 32 [ 2drop ] (%convert-integer) ] }
|
||||
{ c:char [ 8 %sign-extend ] }
|
||||
{ c:uchar [ 8 %zero-extend ] }
|
||||
{ c:short [ 16 %sign-extend ] }
|
||||
{ c:ushort [ 16 %zero-extend ] }
|
||||
{ c:int [ 32 %sign-extend ] }
|
||||
{ c:uint [ 32 [ 2drop ] (%convert-integer) ] }
|
||||
} case ;
|
||||
|
||||
:: %alien-integer-getter ( dst exclude address bits quot -- )
|
||||
|
@ -402,12 +402,12 @@ M: x86 %convert-integer ( dst src c-type -- )
|
|||
: (%load-memory) ( dst exclude address rep c-type -- )
|
||||
[
|
||||
{
|
||||
{ c::char [ 8 %alien-signed-getter ] }
|
||||
{ c::uchar [ 8 %alien-unsigned-getter ] }
|
||||
{ c::short [ 16 %alien-signed-getter ] }
|
||||
{ c::ushort [ 16 %alien-unsigned-getter ] }
|
||||
{ c::int [ 32 %alien-signed-getter ] }
|
||||
{ c::uint [ 32 [ 2drop ] %alien-integer-getter ] }
|
||||
{ c:char [ 8 %alien-signed-getter ] }
|
||||
{ c:uchar [ 8 %alien-unsigned-getter ] }
|
||||
{ c:short [ 16 %alien-signed-getter ] }
|
||||
{ c:ushort [ 16 %alien-unsigned-getter ] }
|
||||
{ c:int [ 32 %alien-signed-getter ] }
|
||||
{ c:uint [ 32 [ 2drop ] %alien-integer-getter ] }
|
||||
} case
|
||||
] [ nipd %copy ] ?if ;
|
||||
|
||||
|
@ -420,12 +420,12 @@ M: x86 %load-memory-imm ( dst base offset rep c-type -- )
|
|||
: (%store-memory) ( src exclude address rep c-type -- )
|
||||
[
|
||||
{
|
||||
{ c::char [ 8 %alien-integer-setter ] }
|
||||
{ c::uchar [ 8 %alien-integer-setter ] }
|
||||
{ c::short [ 16 %alien-integer-setter ] }
|
||||
{ c::ushort [ 16 %alien-integer-setter ] }
|
||||
{ c::int [ 32 %alien-integer-setter ] }
|
||||
{ c::uint [ 32 %alien-integer-setter ] }
|
||||
{ c:char [ 8 %alien-integer-setter ] }
|
||||
{ c:uchar [ 8 %alien-integer-setter ] }
|
||||
{ c:short [ 16 %alien-integer-setter ] }
|
||||
{ c:ushort [ 16 %alien-integer-setter ] }
|
||||
{ c:int [ 32 %alien-integer-setter ] }
|
||||
{ c:uint [ 32 %alien-integer-setter ] }
|
||||
} case
|
||||
] [ [ nip swap ] dip %copy ] ?if ;
|
||||
|
||||
|
|
|
@ -131,7 +131,7 @@ PRIVATE>
|
|||
new-lines from text+loc :> new-to
|
||||
from to document doc-range :> old-string
|
||||
old-string string from to new-to <edit> document add-undo
|
||||
new-lines from to document [ (set-doc-range) ] models::change-model
|
||||
new-lines from to document [ (set-doc-range) ] models:change-model
|
||||
new-to document update-locs
|
||||
] unless ;
|
||||
|
||||
|
|
|
@ -159,15 +159,15 @@ T-class DEFINES-CLASS ${T}
|
|||
WHERE
|
||||
|
||||
STRUCT: T-class
|
||||
{ NAME c::longlong }
|
||||
{ NAME c:longlong }
|
||||
{ x { TYPE 4 } }
|
||||
{ y { c::short N } }
|
||||
{ y { c:short N } }
|
||||
{ z TYPE initial: 5 }
|
||||
{ float { c::float 2 } } ;
|
||||
{ float { c:float 2 } } ;
|
||||
|
||||
;FUNCTOR>
|
||||
|
||||
"a-struct" "nemo" c::char 2 define-a-struct
|
||||
"a-struct" "nemo" c:char 2 define-a-struct
|
||||
|
||||
>>
|
||||
|
||||
|
@ -178,35 +178,35 @@ STRUCT: T-class
|
|||
{ offset 0 }
|
||||
{ class integer }
|
||||
{ initial 0 }
|
||||
{ type c::longlong }
|
||||
{ type c:longlong }
|
||||
}
|
||||
T{ struct-slot-spec
|
||||
{ name "x" }
|
||||
{ offset 8 }
|
||||
{ class object }
|
||||
{ initial f }
|
||||
{ type { c::char 4 } }
|
||||
{ type { c:char 4 } }
|
||||
}
|
||||
T{ struct-slot-spec
|
||||
{ name "y" }
|
||||
{ offset 12 }
|
||||
{ class object }
|
||||
{ initial f }
|
||||
{ type { c::short 2 } }
|
||||
{ type { c:short 2 } }
|
||||
}
|
||||
T{ struct-slot-spec
|
||||
{ name "z" }
|
||||
{ offset 16 }
|
||||
{ class fixnum }
|
||||
{ initial 5 }
|
||||
{ type c::char }
|
||||
{ type c:char }
|
||||
}
|
||||
T{ struct-slot-spec
|
||||
{ name "float" }
|
||||
{ offset 20 }
|
||||
{ class object }
|
||||
{ initial f }
|
||||
{ type { c::float 2 } }
|
||||
{ type { c:float 2 } }
|
||||
}
|
||||
}
|
||||
] [ a-struct struct-slots ] unit-test
|
||||
|
|
|
@ -93,12 +93,12 @@ M: user-saver dispose
|
|||
<user-saver> &dispose drop ;
|
||||
|
||||
: init-user ( user -- )
|
||||
[ [ logged-in-user namespaces::set ] [ save-user-after ] bi ] when* ;
|
||||
[ [ logged-in-user namespaces:set ] [ save-user-after ] bi ] when* ;
|
||||
|
||||
\ init-user DEBUG add-input-logging
|
||||
|
||||
M: realm call-responder* ( path responder -- response )
|
||||
dup realm namespaces::set
|
||||
dup realm namespaces:set
|
||||
logged-in? [
|
||||
dup init-realm
|
||||
dup logged-in-username
|
||||
|
@ -147,7 +147,7 @@ TUPLE: protected < filter-responder description capabilities ;
|
|||
] if ;
|
||||
|
||||
M: protected call-responder* ( path responder -- response )
|
||||
dup protected namespaces::set
|
||||
dup protected namespaces:set
|
||||
dup capabilities>> have-capabilities?
|
||||
[ call-next-method ] [
|
||||
[ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
|
||||
|
|
|
@ -29,11 +29,11 @@ SYMBOL: blank-line
|
|||
and [ nl ] when ;
|
||||
|
||||
: ($blank-line) ( -- )
|
||||
nl nl blank-line last-element namespaces::set ;
|
||||
nl nl blank-line last-element namespaces:set ;
|
||||
|
||||
: ($span) ( quot -- )
|
||||
last-block? [ nl ] when
|
||||
span last-element namespaces::set
|
||||
span last-element namespaces:set
|
||||
call ; inline
|
||||
|
||||
GENERIC: print-element ( element -- )
|
||||
|
@ -60,9 +60,9 @@ M: f print-element drop ;
|
|||
|
||||
: ($block) ( quot -- )
|
||||
?nl
|
||||
span last-element namespaces::set
|
||||
span last-element namespaces:set
|
||||
call
|
||||
block last-element namespaces::set ; inline
|
||||
block last-element namespaces:set ; inline
|
||||
|
||||
! Some spans
|
||||
|
||||
|
@ -86,7 +86,7 @@ ALIAS: $slot $snippet
|
|||
|
||||
: $nl ( children -- )
|
||||
drop nl last-element get [ nl ] when
|
||||
blank-line last-element namespaces::set ;
|
||||
blank-line last-element namespaces:set ;
|
||||
|
||||
! Some blocks
|
||||
: ($heading) ( children quot -- )
|
||||
|
|
|
@ -140,8 +140,8 @@ ERROR: unknown-chloe-tag tag ;
|
|||
|
||||
: with-compiler ( quot -- quot' )
|
||||
[
|
||||
SBUF" " string-buffer namespaces::set
|
||||
V{ } clone tag-stack namespaces::set
|
||||
SBUF" " string-buffer namespaces:set
|
||||
V{ } clone tag-stack namespaces:set
|
||||
call
|
||||
reset-buffer
|
||||
] [ ] make ; inline
|
||||
|
@ -152,7 +152,7 @@ ERROR: unknown-chloe-tag tag ;
|
|||
: compile-quot ( quot -- )
|
||||
reset-buffer
|
||||
[
|
||||
SBUF" " string-buffer namespaces::set
|
||||
SBUF" " string-buffer namespaces:set
|
||||
call
|
||||
reset-buffer
|
||||
] [ ] make , ; inline
|
||||
|
|
|
@ -184,7 +184,7 @@ M: file-responder call-responder* ( path responder -- response )
|
|||
[ drop <400> ] [ "/" join serve-object ] if ;
|
||||
|
||||
: add-index ( name responder -- )
|
||||
index-names>> sets::adjoin ;
|
||||
index-names>> sets:adjoin ;
|
||||
|
||||
: serve-fhtml ( path -- response )
|
||||
<fhtml> <html-content> ;
|
||||
|
|
|
@ -69,11 +69,11 @@ SYMBOL: inspector-stack
|
|||
SYMBOL: sorted-keys
|
||||
|
||||
: reinspect ( obj -- )
|
||||
[ me namespaces::set ]
|
||||
[ me namespaces:set ]
|
||||
[
|
||||
dup make-mirror dup mirror namespaces::set
|
||||
dup make-mirror dup mirror namespaces:set
|
||||
t +number-rows+ [ (describe) ] with-variable
|
||||
sorted-keys namespaces::set
|
||||
sorted-keys namespaces:set
|
||||
] bi ;
|
||||
|
||||
: (inspect) ( obj -- )
|
||||
|
@ -118,7 +118,7 @@ PRIVATE>
|
|||
|
||||
: inspector ( obj -- )
|
||||
&help
|
||||
V{ } clone inspector-stack namespaces::set
|
||||
V{ } clone inspector-stack namespaces:set
|
||||
(inspect) ;
|
||||
|
||||
: inspect ( obj -- )
|
||||
|
|
|
@ -10,4 +10,4 @@ M: linux init-io ( -- )
|
|||
|
||||
linux set-io-backend
|
||||
|
||||
[ start-signal-pipe-thread ] "io.backend.unix::signal-pipe-thread" add-startup-hook
|
||||
[ start-signal-pipe-thread ] "io.backend.unix:signal-pipe-thread" add-startup-hook
|
||||
|
|
|
@ -17,4 +17,4 @@ M: macosx init-io ( -- )
|
|||
macosx set-io-backend
|
||||
|
||||
[ start-signal-pipe-thread ]
|
||||
"io.backend.unix::signal-pipe-thread" add-startup-hook
|
||||
"io.backend.unix:signal-pipe-thread" add-startup-hook
|
||||
|
|
|
@ -51,10 +51,10 @@ M: unix tell-handle ( handle -- n )
|
|||
|
||||
M: unix seek-handle ( n seek-type handle -- )
|
||||
swap {
|
||||
{ io::seek-absolute [ SEEK_SET ] }
|
||||
{ io::seek-relative [ SEEK_CUR ] }
|
||||
{ io::seek-end [ SEEK_END ] }
|
||||
[ io::bad-seek-type ]
|
||||
{ io:seek-absolute [ SEEK_SET ] }
|
||||
{ io:seek-relative [ SEEK_CUR ] }
|
||||
{ io:seek-end [ SEEK_END ] }
|
||||
[ io:bad-seek-type ]
|
||||
} case
|
||||
[ fd>> swap ] dip [ lseek ] unix-system-call drop ;
|
||||
|
||||
|
@ -147,8 +147,8 @@ M: stdin dispose*
|
|||
] with-destructors ;
|
||||
|
||||
: wait-for-stdin ( stdin -- size )
|
||||
[ control>> char: X over io::stream-write1 io::stream-flush ]
|
||||
[ size>> ssize_t heap-size swap io::stream-read ssize_t deref ]
|
||||
[ control>> char: X over io:stream-write1 io:stream-flush ]
|
||||
[ size>> ssize_t heap-size swap io:stream-read ssize_t deref ]
|
||||
bi ;
|
||||
|
||||
:: refill-stdin ( buffer stdin size -- )
|
||||
|
@ -194,7 +194,7 @@ dispatch-signal-hook [ [ drop ] ] initialize
|
|||
|
||||
: signal-pipe-loop ( port -- )
|
||||
'[
|
||||
int heap-size _ io::stream-read
|
||||
int heap-size _ io:stream-read
|
||||
dup [ int deref dispatch-signal-hook get call( x -- ) ] when*
|
||||
] loop ;
|
||||
|
||||
|
|
|
@ -123,9 +123,9 @@ M: linux-monitor dispose* ( monitor -- )
|
|||
[ inotify-read-loop ] curry ignore-errors ;
|
||||
|
||||
M: linux init-monitors
|
||||
H{ } clone watches namespaces::set
|
||||
H{ } clone watches namespaces:set
|
||||
<inotify> [
|
||||
[ inotify namespaces::set ]
|
||||
[ inotify namespaces:set ]
|
||||
[
|
||||
[ inotify-read-thread ] curry
|
||||
"Linux monitor thread" spawn drop
|
||||
|
|
|
@ -6,7 +6,7 @@ QUALIFIED: io.pipes
|
|||
SPECIALIZED-ARRAY: int
|
||||
IN: io.pipes.unix
|
||||
|
||||
M: unix io.pipes::(pipe) ( -- pair )
|
||||
M: unix io.pipes:(pipe) ( -- pair )
|
||||
2 int <c-array>
|
||||
[ pipe io-error ]
|
||||
[ first2 [ <fd> init-fd ] bi@ io.pipes::pipe boa ] bi ;
|
||||
[ first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ] bi ;
|
||||
|
|
|
@ -93,7 +93,7 @@ M: f >insecure ;
|
|||
|
||||
: log-connection ( remote local -- )
|
||||
[ accepted-connection ]
|
||||
[ [ remote-address namespaces::set ] [ local-address namespaces::set ] bi* ]
|
||||
[ [ remote-address namespaces:set ] [ local-address namespaces:set ] bi* ]
|
||||
2bi ;
|
||||
|
||||
M: threaded-server handle-client* handler>> call( -- ) ;
|
||||
|
|
|
@ -20,11 +20,11 @@ IN: io.sockets.secure.tests
|
|||
] curry with-stream
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] "SSL server test" qm::spawn-linked drop
|
||||
] "SSL server test" qm:spawn-linked drop
|
||||
! This is hideous.
|
||||
! If we fail with a timeout, the test is passing.
|
||||
! If we fail with something besides a timeout, rethrow it and fail the test.
|
||||
[ qm::my-mailbox 200 milliseconds mailbox-get-timeout drop ]
|
||||
[ qm:my-mailbox 200 milliseconds mailbox-get-timeout drop ]
|
||||
[ dup timed-out-error? [ drop ] [ rethrow ] if ] recover ;
|
||||
|
||||
: ?promise-test ( mailbox -- obj )
|
||||
|
|
|
@ -94,7 +94,7 @@ M: object (server)
|
|||
|
||||
: do-accept ( server addrspec -- fd sockaddr )
|
||||
[ handle>> handle-fd ] [ empty-sockaddr/size int <ref> ] bi*
|
||||
[ unix.ffi::accept ] keepd ; inline
|
||||
[ unix.ffi:accept ] keepd ; inline
|
||||
|
||||
M: object (accept)
|
||||
2dup do-accept over 0 >= [
|
||||
|
|
|
@ -11,7 +11,7 @@ SYMBOL: insomniac-recipients
|
|||
|
||||
: email-subject ( service -- string )
|
||||
[
|
||||
"Log analysis for " % % " on " % io.sockets::host-name %
|
||||
"Log analysis for " % % " on " % io.sockets:host-name %
|
||||
] "" make ;
|
||||
|
||||
:: (email-log-report) ( service word-names -- )
|
||||
|
|
|
@ -7,9 +7,9 @@ sequences.unrolled sequences.unrolled.private specialized-arrays
|
|||
vocabs ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
SPECIALIZED-ARRAYS:
|
||||
c::char c::short c::int c::longlong
|
||||
c::uchar c::ushort c::uint c::ulonglong
|
||||
c::float c::double ;
|
||||
c:char c:short c:int c:longlong
|
||||
c:uchar c:ushort c:uint c:ulonglong
|
||||
c:float c:double ;
|
||||
IN: math.vectors.simd.intrinsics
|
||||
|
||||
! Word props are added later
|
||||
|
@ -47,44 +47,44 @@ IN: math.vectors.simd.intrinsics
|
|||
|
||||
: byte>rep-array ( byte-array rep -- array )
|
||||
{
|
||||
{ char-16-rep [ 16 c::char <c-direct-array> ] }
|
||||
{ uchar-16-rep [ 16 c::uchar <c-direct-array> ] }
|
||||
{ short-8-rep [ 8 c::short <c-direct-array> ] }
|
||||
{ ushort-8-rep [ 8 c::ushort <c-direct-array> ] }
|
||||
{ int-4-rep [ 4 c::int <c-direct-array> ] }
|
||||
{ uint-4-rep [ 4 c::uint <c-direct-array> ] }
|
||||
{ longlong-2-rep [ 2 c::longlong <c-direct-array> ] }
|
||||
{ ulonglong-2-rep [ 2 c::ulonglong <c-direct-array> ] }
|
||||
{ float-4-rep [ 4 c::float <c-direct-array> ] }
|
||||
{ double-2-rep [ 2 c::double <c-direct-array> ] }
|
||||
{ char-16-rep [ 16 c:char <c-direct-array> ] }
|
||||
{ uchar-16-rep [ 16 c:uchar <c-direct-array> ] }
|
||||
{ short-8-rep [ 8 c:short <c-direct-array> ] }
|
||||
{ ushort-8-rep [ 8 c:ushort <c-direct-array> ] }
|
||||
{ int-4-rep [ 4 c:int <c-direct-array> ] }
|
||||
{ uint-4-rep [ 4 c:uint <c-direct-array> ] }
|
||||
{ longlong-2-rep [ 2 c:longlong <c-direct-array> ] }
|
||||
{ ulonglong-2-rep [ 2 c:ulonglong <c-direct-array> ] }
|
||||
{ float-4-rep [ 4 c:float <c-direct-array> ] }
|
||||
{ double-2-rep [ 2 c:double <c-direct-array> ] }
|
||||
} case ; inline
|
||||
|
||||
: >rep-array ( seq rep -- array )
|
||||
{
|
||||
{ char-16-rep [ c::char >c-array ] }
|
||||
{ uchar-16-rep [ c::uchar >c-array ] }
|
||||
{ short-8-rep [ c::short >c-array ] }
|
||||
{ ushort-8-rep [ c::ushort >c-array ] }
|
||||
{ int-4-rep [ c::int >c-array ] }
|
||||
{ uint-4-rep [ c::uint >c-array ] }
|
||||
{ longlong-2-rep [ c::longlong >c-array ] }
|
||||
{ ulonglong-2-rep [ c::ulonglong >c-array ] }
|
||||
{ float-4-rep [ c::float >c-array ] }
|
||||
{ double-2-rep [ c::double >c-array ] }
|
||||
{ char-16-rep [ c:char >c-array ] }
|
||||
{ uchar-16-rep [ c:uchar >c-array ] }
|
||||
{ short-8-rep [ c:short >c-array ] }
|
||||
{ ushort-8-rep [ c:ushort >c-array ] }
|
||||
{ int-4-rep [ c:int >c-array ] }
|
||||
{ uint-4-rep [ c:uint >c-array ] }
|
||||
{ longlong-2-rep [ c:longlong >c-array ] }
|
||||
{ ulonglong-2-rep [ c:ulonglong >c-array ] }
|
||||
{ float-4-rep [ c:float >c-array ] }
|
||||
{ double-2-rep [ c:double >c-array ] }
|
||||
} case ; inline
|
||||
|
||||
: <rep-array> ( rep -- array )
|
||||
{
|
||||
{ char-16-rep [ 16 c::char (c-array) ] }
|
||||
{ uchar-16-rep [ 16 c::uchar (c-array) ] }
|
||||
{ short-8-rep [ 8 c::short (c-array) ] }
|
||||
{ ushort-8-rep [ 8 c::ushort (c-array) ] }
|
||||
{ int-4-rep [ 4 c::int (c-array) ] }
|
||||
{ uint-4-rep [ 4 c::uint (c-array) ] }
|
||||
{ longlong-2-rep [ 2 c::longlong (c-array) ] }
|
||||
{ ulonglong-2-rep [ 2 c::ulonglong (c-array) ] }
|
||||
{ float-4-rep [ 4 c::float (c-array) ] }
|
||||
{ double-2-rep [ 2 c::double (c-array) ] }
|
||||
{ char-16-rep [ 16 c:char (c-array) ] }
|
||||
{ uchar-16-rep [ 16 c:uchar (c-array) ] }
|
||||
{ short-8-rep [ 8 c:short (c-array) ] }
|
||||
{ ushort-8-rep [ 8 c:ushort (c-array) ] }
|
||||
{ int-4-rep [ 4 c:int (c-array) ] }
|
||||
{ uint-4-rep [ 4 c:uint (c-array) ] }
|
||||
{ longlong-2-rep [ 2 c:longlong (c-array) ] }
|
||||
{ ulonglong-2-rep [ 2 c:ulonglong (c-array) ] }
|
||||
{ float-4-rep [ 4 c:float (c-array) ] }
|
||||
{ double-2-rep [ 2 c:double (c-array) ] }
|
||||
} case ; inline
|
||||
|
||||
: rep-tf-values ( rep -- t f )
|
||||
|
@ -158,14 +158,14 @@ PRIVATE>
|
|||
] unrolled-each-unsafe
|
||||
c' underlying>> ;
|
||||
: (simd-vs+) ( a b rep -- c )
|
||||
dup rep-component-type '[ + _ c::c-type-clamp ] components-2map ;
|
||||
dup rep-component-type '[ + _ c:c-type-clamp ] components-2map ;
|
||||
: (simd-vs-) ( a b rep -- c )
|
||||
dup rep-component-type '[ - _ c::c-type-clamp ] components-2map ;
|
||||
dup rep-component-type '[ - _ c:c-type-clamp ] components-2map ;
|
||||
: (simd-vs*) ( a b rep -- c )
|
||||
dup rep-component-type '[ * _ c::c-type-clamp ] components-2map ;
|
||||
dup rep-component-type '[ * _ c:c-type-clamp ] components-2map ;
|
||||
: (simd-v*) ( a b rep -- c ) [ * ] components-2map ;
|
||||
: (simd-v*high) ( a b rep -- c )
|
||||
dup rep-component-type c::heap-size -8 * '[ * _ shift ] components-2map ;
|
||||
dup rep-component-type c:heap-size -8 * '[ * _ shift ] components-2map ;
|
||||
:: (simd-v*hs+) ( a b rep -- c )
|
||||
rep { char-16-rep uchar-16-rep } member-eq?
|
||||
[ uchar-16-rep char-16-rep ]
|
||||
|
@ -177,7 +177,7 @@ PRIVATE>
|
|||
a' b' rep rep-length 2 /i [
|
||||
[ [ first ] bi@ * ]
|
||||
[ [ second ] bi@ * ] 2bi +
|
||||
wide-type c::c-type-clamp
|
||||
wide-type c:c-type-clamp
|
||||
] wide-rep <rep-array> unrolled-2map-as-unsafe underlying>> ;
|
||||
: (simd-v/) ( a b rep -- c ) [ native/ ] components-2map ;
|
||||
: (simd-vavg) ( a b rep -- c )
|
||||
|
@ -257,11 +257,11 @@ PRIVATE>
|
|||
: (simd-vpack-signed) ( a b rep -- c )
|
||||
[ [ 2byte>rep-array cord-append ] [ rep-length 2 * ] bi ]
|
||||
[ narrow-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
|
||||
'[ _ c::c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
|
||||
'[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
|
||||
: (simd-vpack-unsigned) ( a b rep -- c )
|
||||
[ [ 2byte>rep-array cord-append ] [ rep-length 2 * ] bi ]
|
||||
[ narrow-vector-rep >uint-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
|
||||
'[ _ c::c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
|
||||
'[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
|
||||
: (simd-vunpack-head) ( a rep -- c )
|
||||
[ byte>rep-array ] [ widen-vector-rep [ rep-length ] [ '[ _ >rep-array ] ] bi ] bi
|
||||
[ head-slice ] dip call( a' -- c' ) underlying>> ;
|
||||
|
|
|
@ -9,7 +9,7 @@ quotations math.constants compiler.units splitting math.matrices
|
|||
math.vectors.simd.cords alien.data ;
|
||||
FROM: math.vectors.simd.intrinsics => alien-vector set-alien-vector ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
SPECIALIZED-ARRAY: c::float
|
||||
SPECIALIZED-ARRAY: c:float
|
||||
IN: math.vectors.simd.tests
|
||||
|
||||
! Test type propagation
|
||||
|
@ -723,10 +723,10 @@ STRUCT: simd-struct
|
|||
[ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-2 ] unit-test
|
||||
|
||||
: callback-1 ( -- c )
|
||||
c::int { c::int c::int c::int c::int c::int } cdecl [ + + + + ] alien-callback ;
|
||||
c:int { c:int c:int c:int c:int c:int } cdecl [ + + + + ] alien-callback ;
|
||||
|
||||
: indirect-1 ( x x x x x c -- y )
|
||||
c::int { c::int c::int c::int c::int c::int } cdecl alien-indirect ; inline
|
||||
c:int { c:int c:int c:int c:int c:int } cdecl alien-indirect ; inline
|
||||
|
||||
: simd-spill-test-3 ( a b d c -- v )
|
||||
{ float float-4 float-4 float } declare
|
||||
|
@ -740,9 +740,9 @@ STRUCT: simd-struct
|
|||
! aligned right
|
||||
|
||||
: simd-stack-test ( -- b c )
|
||||
{ c::int float-4 } [
|
||||
[ 123 swap 0 c::int c::set-alien-value ]
|
||||
[ float-4{ 1 2 3 4 } swap 0 float-4 c::set-alien-value ] bi*
|
||||
{ c:int float-4 } [
|
||||
[ 123 swap 0 c:int c:set-alien-value ]
|
||||
[ float-4{ 1 2 3 4 } swap 0 float-4 c:set-alien-value ] bi*
|
||||
] with-out-parameters ;
|
||||
|
||||
{ 123 float-4{ 1 2 3 4 } } [ simd-stack-test ] unit-test
|
||||
|
@ -752,8 +752,8 @@ STRUCT: simd-struct
|
|||
: (simd-stack-spill-test) ( -- n ) 17 ;
|
||||
|
||||
: simd-stack-spill-test ( x -- b c )
|
||||
{ c::int } [
|
||||
123 swap 0 c::int c::set-alien-value
|
||||
{ c:int } [
|
||||
123 swap 0 c:int c:set-alien-value
|
||||
>float (simd-stack-spill-test) float-4-with swap cos v*n
|
||||
] with-out-parameters ;
|
||||
|
||||
|
|
|
@ -30,10 +30,10 @@ PRIVATE>
|
|||
! Helper for boolean vector literals
|
||||
|
||||
: vector-true-value ( class -- value )
|
||||
{ c::float c::double } member? [ -1 bits>double ] [ -1 ] if ; foldable
|
||||
{ c:float c:double } member? [ -1 bits>double ] [ -1 ] if ; foldable
|
||||
|
||||
: vector-false-value ( type -- value )
|
||||
{ c::float c::double } member? [ 0.0 ] [ 0 ] if ; foldable
|
||||
{ c:float c:double } member? [ 0.0 ] [ 0 ] if ; foldable
|
||||
|
||||
: boolean>element ( bool/elt type -- elt )
|
||||
swap {
|
||||
|
@ -276,7 +276,7 @@ INLINE-FUNCTOR: simd-128-type ( type: name -- ) [[
|
|||
|
||||
! ELT [ A-rep rep-component-type ]
|
||||
! N [ A-rep rep-length ]
|
||||
! COERCER [ A-rep rep-component-type c::c-type-class "coercer" word-prop [ ] or ]
|
||||
! COERCER [ A-rep rep-component-type c:c-type-class "coercer" word-prop [ ] or ]
|
||||
|
||||
! BOA-EFFECT [ A-rep rep-length "n" <array> { "v" } <effect> ]
|
||||
|
||||
|
@ -287,7 +287,7 @@ TUPLE: ${type} < simd-128 ; final
|
|||
>>
|
||||
|
||||
<<
|
||||
c::<c-type>
|
||||
c:<c-type>
|
||||
byte-array >>class
|
||||
${type} >>boxed-class
|
||||
{ ${type}-rep alien-vector ${type} boa } >quotation >>getter
|
||||
|
@ -298,11 +298,11 @@ c::<c-type>
|
|||
16 >>size
|
||||
16 >>align
|
||||
${type}-rep >>rep
|
||||
\ ${type} c::typedef
|
||||
\ ${type} c:typedef
|
||||
>>
|
||||
|
||||
<<
|
||||
: ${type}-coercer ( -- m ) ${type}-rep rep-component-type c::c-type-class "coercer" word-prop [ ] or ; inline
|
||||
: ${type}-coercer ( -- m ) ${type}-rep rep-component-type c:c-type-class "coercer" word-prop [ ] or ; inline
|
||||
>>
|
||||
: ${type}-with ( n -- v ) $[ ${type}-coercer ] call \ ${type}-rep (simd-with) \ ${type} boa ; inline
|
||||
: ${type}-cast ( v -- v' ) underlying>> \ ${type} boa ; inline
|
||||
|
@ -318,7 +318,7 @@ M: ${type} nth-unsafe
|
|||
swap \ ${type}-rep [ (simd-select) ] [ call-next-method ] vx->x-op ; inline
|
||||
M: ${type} set-nth-unsafe
|
||||
[ ${type} boolean>element ] 2dip
|
||||
underlying>> $[ ${type}-rep rep-component-type ] c::set-alien-element ; inline
|
||||
underlying>> $[ ${type}-rep rep-component-type ] c:set-alien-element ; inline
|
||||
|
||||
M: ${type} like drop dup \ ${type} instance? [ >${type} ] unless ; inline
|
||||
|
||||
|
|
|
@ -3,6 +3,7 @@
|
|||
USING: arrays alien.c-types assocs kernel sequences math
|
||||
math.functions grouping math.order math.libm math.floats.private
|
||||
fry combinators byte-arrays accessors locals ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: math.vectors
|
||||
|
||||
GENERIC: vneg ( v -- w )
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -111,9 +111,9 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
|
||||
: process-rule-result ( p result -- result )
|
||||
[
|
||||
nip [ ast>> ] [ remaining>> ] bi input-from pos namespaces::set
|
||||
nip [ ast>> ] [ remaining>> ] bi input-from pos namespaces:set
|
||||
] [
|
||||
pos namespaces::set fail
|
||||
pos namespaces:set fail
|
||||
] if* ;
|
||||
|
||||
: eval-rule ( rule -- ast )
|
||||
|
@ -138,7 +138,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
pos>> <= or ;
|
||||
|
||||
: setup-growth ( h p -- )
|
||||
pos namespaces::set dup involved-set>> clone >>eval-set drop ;
|
||||
pos namespaces:set dup involved-set>> clone >>eval-set drop ;
|
||||
|
||||
: (grow-lr) ( h p r: ( -- result ) m -- )
|
||||
[ [ setup-growth ] 2keep ] 2dip
|
||||
|
@ -154,7 +154,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
[ [ heads set-at ] 2keep ] 2dip
|
||||
pick over [ (grow-lr) ] 2dip
|
||||
swap heads delete-at
|
||||
dup pos>> pos namespaces::set ans>>
|
||||
dup pos>> pos namespaces:set ans>>
|
||||
; inline
|
||||
|
||||
:: (setup-lr) ( l s -- )
|
||||
|
@ -208,9 +208,9 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
|
||||
:: apply-non-memo-rule ( r p -- ast )
|
||||
fail r rule-id f lrstack get left-recursion boa :> lr
|
||||
lr lrstack namespaces::set lr p memo-entry boa dup p r rule-id set-memo :> m
|
||||
lr lrstack namespaces:set lr p memo-entry boa dup p r rule-id set-memo :> m
|
||||
r eval-rule :> ans
|
||||
lrstack get next>> lrstack namespaces::set
|
||||
lrstack get next>> lrstack namespaces:set
|
||||
pos get m pos<<
|
||||
lr head>> [
|
||||
m ans>> left-recursion? [
|
||||
|
@ -223,7 +223,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
] if ; inline
|
||||
|
||||
: apply-memo-rule ( r m -- ast )
|
||||
[ ans>> ] [ pos>> ] bi pos namespaces::set
|
||||
[ ans>> ] [ pos>> ] bi pos namespaces:set
|
||||
dup left-recursion? [
|
||||
[ setup-lr ] keep seed>>
|
||||
] [
|
||||
|
@ -500,7 +500,7 @@ TUPLE: sp-parser parser ;
|
|||
|
||||
M: sp-parser (compile)
|
||||
parser>> compile-parser-quot '[
|
||||
input-slice [ blank? ] trim-head-slice input-from pos namespaces::set @
|
||||
input-slice [ blank? ] trim-head-slice input-from pos namespaces:set @
|
||||
] ;
|
||||
|
||||
TUPLE: delay-parser quot ;
|
||||
|
|
|
@ -231,7 +231,7 @@ M: callable >pprint-sequence ;
|
|||
M: hashtable >pprint-sequence >alist ;
|
||||
M: wrapper >pprint-sequence wrapped>> 1array ;
|
||||
M: callstack >pprint-sequence callstack>array ;
|
||||
M: hash-set >pprint-sequence sets::members ;
|
||||
M: hash-set >pprint-sequence sets:members ;
|
||||
M: anonymous-union >pprint-sequence members>> ;
|
||||
M: anonymous-intersection >pprint-sequence participants>> ;
|
||||
M: anonymous-complement >pprint-sequence class>> 1array ;
|
||||
|
|
|
@ -327,8 +327,8 @@ SYMBOL: next
|
|||
: group-flow ( seq -- newseq )
|
||||
[
|
||||
dup length <iota> [
|
||||
2dup 1 - swap ?nth prev namespaces::set
|
||||
2dup 1 + swap ?nth next namespaces::set
|
||||
2dup 1 - swap ?nth prev namespaces:set
|
||||
2dup 1 + swap ?nth next namespaces:set
|
||||
swap nth dup split-before dup , split-after
|
||||
] with each
|
||||
] { } make { t } split harvest ;
|
||||
|
@ -359,10 +359,10 @@ M: block long-section ( block -- )
|
|||
|
||||
: make-pprint ( obj quot manifest? -- block manifest/f )
|
||||
[
|
||||
0 position namespaces::set
|
||||
HS{ } clone pprinter-use namespaces::set
|
||||
V{ } clone recursion-check namespaces::set
|
||||
V{ } clone pprinter-stack namespaces::set
|
||||
0 position namespaces:set
|
||||
HS{ } clone pprinter-use namespaces:set
|
||||
V{ } clone recursion-check namespaces:set
|
||||
V{ } clone pprinter-stack namespaces:set
|
||||
|
||||
[ over <object call pprinter-block ] dip
|
||||
[ pprinter-manifest ] [ f ] if
|
||||
|
|
|
@ -7,7 +7,7 @@ io.binary kernel locals math math.bitwise math.constants
|
|||
math.functions math.order math.ranges namespaces sequences
|
||||
sequences.private sets summary system typed vocabs ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
QUALIFIED: sets
|
||||
QUALIFIED-WITH: sets sets
|
||||
IN: random
|
||||
|
||||
SYMBOL: system-random-generator
|
||||
|
@ -22,13 +22,13 @@ M: object random-bytes*
|
|||
[ integer>fixnum-strict [ (byte-array) ] keep ] dip
|
||||
[ over 4 >= ] [
|
||||
[ 4 - ] dip
|
||||
[ random-32* 2over c::int c::set-alien-value ] keep
|
||||
[ random-32* 2over c:int c:set-alien-value ] keep
|
||||
] while over zero? [ 2drop ] [
|
||||
random-32* c::int <ref> swap head 0 pick copy-unsafe
|
||||
random-32* c:int <ref> swap head 0 pick copy-unsafe
|
||||
] if ;
|
||||
|
||||
M: object random-32*
|
||||
4 swap random-bytes* c::uint deref ;
|
||||
4 swap random-bytes* c:uint deref ;
|
||||
|
||||
ERROR: no-random-number-generator ;
|
||||
|
||||
|
@ -105,7 +105,7 @@ M: hashtable random
|
|||
[ array-nth ] [ [ 1 + ] dip array-nth ] 2bi 2array
|
||||
] if-zero ;
|
||||
|
||||
M: sets::set random members random ;
|
||||
M: sets:set random members random ;
|
||||
|
||||
M: hash-set random
|
||||
dup cardinality [ drop f ] [
|
||||
|
|
|
@ -156,8 +156,8 @@ M: with-options nfa-node ( node -- start end )
|
|||
|
||||
: construct-nfa ( ast -- nfa-table )
|
||||
[
|
||||
0 state namespaces::set
|
||||
<transition-table> nfa-table namespaces::set
|
||||
0 state namespaces:set
|
||||
<transition-table> nfa-table namespaces:set
|
||||
nfa-node
|
||||
nfa-table get
|
||||
swap 1array fast-set >>final-states
|
||||
|
|
|
@ -20,8 +20,8 @@ GENERIC: see* ( defspec -- )
|
|||
: synopsis ( defspec -- str )
|
||||
[
|
||||
string-limit? off
|
||||
0 margin namespaces::set
|
||||
1 line-limit namespaces::set
|
||||
0 margin namespaces:set
|
||||
1 line-limit namespaces:set
|
||||
[ synopsis* ] with-in
|
||||
] with-string-writer ;
|
||||
|
||||
|
@ -46,7 +46,7 @@ M: word print-stack-effect? drop t ;
|
|||
<PRIVATE
|
||||
|
||||
: seeing-word ( word -- )
|
||||
vocabulary>> dup [ lookup-vocab ] when pprinter-in namespaces::set ;
|
||||
vocabulary>> dup [ lookup-vocab ] when pprinter-in namespaces:set ;
|
||||
|
||||
: word-synopsis ( word -- )
|
||||
{
|
||||
|
@ -92,8 +92,8 @@ M: pathname synopsis* pprint* ;
|
|||
|
||||
M: alias summary
|
||||
[
|
||||
0 margin namespaces::set
|
||||
1 line-limit namespaces::set
|
||||
0 margin namespaces:set
|
||||
1 line-limit namespaces:set
|
||||
[
|
||||
{
|
||||
[ seeing-word ]
|
||||
|
@ -128,8 +128,8 @@ M: word declarations.
|
|||
|
||||
M: object see*
|
||||
[
|
||||
12 nesting-limit namespaces::set
|
||||
100 length-limit namespaces::set
|
||||
12 nesting-limit namespaces:set
|
||||
100 length-limit namespaces:set
|
||||
<colon dup synopsis*
|
||||
<block dup definition pprint-elements block>
|
||||
dup definer nip [ pprint-word ] when* declarations.
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
USING: specialized-arrays sequences.complex
|
||||
kernel sequences tools.test arrays accessors ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
SPECIALIZED-ARRAY: c::float
|
||||
SPECIALIZED-ARRAY: c:float
|
||||
IN: sequences.complex.tests
|
||||
|
||||
: test-array ( -- x )
|
||||
|
|
|
@ -96,5 +96,5 @@ TUPLE: tuple2 d ;
|
|||
|
||||
{ { { "apples" 1 } { "bananas" 2 } { "cherries" 3 } } } [
|
||||
H{ { "apples" 1 } { "bananas" 2 } { "cherries" 3 } }
|
||||
{ { sequences::length <=> } } sort-keys-by
|
||||
{ { sequences:length <=> } } sort-keys-by
|
||||
] unit-test
|
||||
|
|
|
@ -3,52 +3,55 @@
|
|||
USING: alien.parser arrays functors2 growable kernel lexer make
|
||||
math.parser sequences vocabs.loader ;
|
||||
FROM: sequences.private => nth-unsafe ;
|
||||
QUALIFIED: vectors.functor
|
||||
IN: specialized-vectors
|
||||
|
||||
MIXIN: specialized-vector
|
||||
|
||||
FUNCTOR: specialized-vector ( type: existing-word -- ) [[
|
||||
USING: accessors alien alien.c-types alien.data classes growable
|
||||
kernel math parser prettyprint.custom sequences
|
||||
sequences.private specialized-arrays specialized-arrays.private
|
||||
specialized-vectors vectors.functor ;
|
||||
FROM: specialized-arrays.private => nth-c-ptr direct-like ;
|
||||
|
||||
<<
|
||||
SPECIALIZED-ARRAY: ${type}
|
||||
>>
|
||||
USING: accessors alien alien.c-types alien.data classes growable
|
||||
kernel math parser prettyprint.custom sequences
|
||||
sequences.private specialized-arrays specialized-arrays.private
|
||||
specialized-vectors vectors.functor ;
|
||||
FROM: specialized-arrays.private => nth-c-ptr direct-like ;
|
||||
|
||||
<<
|
||||
! For >foo-vector to be defined in time
|
||||
VECTORIZED: ${type} ${type}-array <${type}-array>
|
||||
>>
|
||||
<<
|
||||
SPECIALIZED-ARRAY: ${type}
|
||||
>>
|
||||
|
||||
SYNTAX: ${type}-vector{ \ } [ >${type}-vector ] parse-literal ;
|
||||
<<
|
||||
! For >foo-vector to be defined in time
|
||||
VECTORIZED: ${type} ${type}-array <${type}-array>
|
||||
>>
|
||||
|
||||
INSTANCE: ${type}-vector specialized-vector
|
||||
SYNTAX: ${type}-vector{ \ } [ >${type}-vector ] parse-literal ;
|
||||
|
||||
M: ${type}-vector contract 2drop ; inline
|
||||
INSTANCE: ${type}-vector specialized-vector
|
||||
|
||||
M: ${type}-vector element-size drop \ ${type} heap-size ; inline
|
||||
M: ${type}-vector contract 2drop ; inline
|
||||
|
||||
M: ${type}-vector pprint-delims drop \ ${type}-vector{ \ } ;
|
||||
M: ${type}-vector element-size drop \ ${type} heap-size ; inline
|
||||
|
||||
M: ${type}-vector >pprint-sequence ;
|
||||
M: ${type}-vector pprint-delims drop \ ${type}-vector{ \ } ;
|
||||
|
||||
M: ${type}-vector pprint* pprint-object ;
|
||||
M: ${type}-vector >pprint-sequence ;
|
||||
|
||||
M: ${type}-vector >c-ptr underlying>> underlying>> ; inline
|
||||
M: ${type}-vector byte-length [ length ] [ element-size ] bi * ; inline
|
||||
M: ${type}-vector pprint* pprint-object ;
|
||||
|
||||
M: ${type}-vector direct-like drop <direct-${type}-array> ; inline
|
||||
M: ${type}-vector nth-c-ptr underlying>> nth-c-ptr ; inline
|
||||
M: ${type}-vector >c-ptr underlying>> underlying>> ; inline
|
||||
M: ${type}-vector byte-length [ length ] [ element-size ] bi * ; inline
|
||||
|
||||
M: ${type}-vector direct-like drop <direct-${type}-array> ; inline
|
||||
M: ${type}-vector nth-c-ptr underlying>> nth-c-ptr ; inline
|
||||
|
||||
M: ${type}-array like
|
||||
drop dup ${type}-array instance? [
|
||||
dup ${type}-vector instance? [
|
||||
[ >c-ptr ] [ length>> ] bi <direct-${type}-array>
|
||||
] [ \ ${type} >c-array ] if
|
||||
] unless ; inline
|
||||
|
||||
M: ${type}-array like
|
||||
drop dup ${type}-array instance? [
|
||||
dup ${type}-vector instance? [
|
||||
[ >c-ptr ] [ length>> ] bi <direct-${type}-array>
|
||||
] [ \ ${type} >c-array ] if
|
||||
] unless ; inline
|
||||
]]
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
USING: assocs kernel sequences tools.completion tools.test ;
|
||||
USING: assocs kernel sequences tools.test ;
|
||||
IN: tools.completion
|
||||
|
||||
{ f } [ "abc" "def" fuzzy ] unit-test
|
||||
{ V{ 4 5 6 } } [ "set-nth" "nth" fuzzy ] unit-test
|
||||
|
|
|
@ -1,10 +1,13 @@
|
|||
! Copyright (C) 2007, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cocoa.application cocoa.plists combinators io.backend
|
||||
io.directories io.directories.hierarchy io.files
|
||||
io.files.info.unix io.pathnames kernel make namespaces sequences
|
||||
system tools.deploy.backend tools.deploy.config
|
||||
tools.deploy.config.editor vocabs.loader ;
|
||||
USING: io io.files io.files.info.unix io.pathnames
|
||||
io.directories io.directories.hierarchy kernel namespaces make
|
||||
sequences system tools.deploy.backend tools.deploy.config
|
||||
tools.deploy.config.editor assocs hashtables prettyprint
|
||||
io.backend.unix cocoa io.encodings.utf8 io.backend
|
||||
cocoa.application cocoa.classes cocoa.plists
|
||||
combinators vocabs.metadata vocabs.loader webbrowser ;
|
||||
QUALIFIED-WITH: tools.deploy.unix unix
|
||||
IN: tools.deploy.macosx
|
||||
|
||||
: bundle-dir ( -- dir )
|
||||
|
|
|
@ -311,11 +311,11 @@ IN: tools.deploy.shaker
|
|||
[
|
||||
"inspector-hook" "inspector" lookup-word ,
|
||||
{
|
||||
source-files::source-files
|
||||
continuations::error
|
||||
continuations::error-continuation
|
||||
continuations::error-thread
|
||||
continuations::restarts
|
||||
source-files:source-files
|
||||
continuations:error
|
||||
continuations:error-continuation
|
||||
continuations:error-thread
|
||||
continuations:restarts
|
||||
} %
|
||||
|
||||
"disposables" "destructors" lookup-word ,
|
||||
|
@ -345,30 +345,30 @@ IN: tools.deploy.shaker
|
|||
{
|
||||
gensym
|
||||
name>char-hook
|
||||
classes.private::next-method-quot-cache
|
||||
classes.private::class-and-cache
|
||||
classes.private::class-not-cache
|
||||
classes.private::class-or-cache
|
||||
classes.private::class<=-cache
|
||||
classes.private::classes-intersect-cache
|
||||
classes.private::implementors-map
|
||||
classes.private::update-map
|
||||
classes.private:next-method-quot-cache
|
||||
classes.private:class-and-cache
|
||||
classes.private:class-not-cache
|
||||
classes.private:class-or-cache
|
||||
classes.private:class<=-cache
|
||||
classes.private:classes-intersect-cache
|
||||
classes.private:implementors-map
|
||||
classes.private:update-map
|
||||
main-vocab-hook
|
||||
compiler.crossref::compiled-crossref
|
||||
compiler.crossref::generic-call-site-crossref
|
||||
compiler.crossref:compiled-crossref
|
||||
compiler.crossref:generic-call-site-crossref
|
||||
compiler-impl
|
||||
compiler.errors::compiler-errors
|
||||
compiler.errors:compiler-errors
|
||||
print-use-hook
|
||||
root-cache
|
||||
require-when-vocabs
|
||||
require-when-table
|
||||
source-files.errors::error-types
|
||||
source-files.errors::error-observers
|
||||
vocabs::dictionary
|
||||
vocabs::require-hook
|
||||
vocabs::vocab-observers
|
||||
vocabs.loader::add-vocab-root-hook
|
||||
vocabs.parser::manifest
|
||||
source-files.errors:error-types
|
||||
source-files.errors:error-observers
|
||||
vocabs:dictionary
|
||||
vocabs:require-hook
|
||||
vocabs:vocab-observers
|
||||
vocabs.loader:add-vocab-root-hook
|
||||
vocabs.parser:manifest
|
||||
word
|
||||
parser-quiet?
|
||||
} %
|
||||
|
@ -387,7 +387,7 @@ IN: tools.deploy.shaker
|
|||
] when
|
||||
|
||||
strip-debugger? [
|
||||
\ compiler.errors::compiler-errors ,
|
||||
\ compiler.errors:compiler-errors ,
|
||||
] when
|
||||
] { } make ;
|
||||
|
||||
|
@ -395,7 +395,7 @@ IN: tools.deploy.shaker
|
|||
[
|
||||
|
||||
{
|
||||
init::startup-hooks
|
||||
init:startup-hooks
|
||||
input-stream
|
||||
output-stream
|
||||
error-stream
|
||||
|
@ -634,7 +634,7 @@ SYMBOL: deploy-vocab
|
|||
"ui.debugger" require
|
||||
] when
|
||||
] unless
|
||||
[ deploy-vocab namespaces::set ] [ require ] [
|
||||
[ deploy-vocab namespaces:set ] [ require ] [
|
||||
vocab-main [
|
||||
"Vocabulary has no MAIN: word." print flush 1 exit
|
||||
] unless
|
||||
|
|
|
@ -1,10 +1,13 @@
|
|||
! Copyright (C) 2013 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: accessors alien.c-types alien.data alien.syntax arrays
|
||||
assocs byte-arrays classes.struct continuations fry grouping
|
||||
kernel libc literals math sequences splitting strings system
|
||||
system-info.macosx tools.ps unix unix.time unix.types ;
|
||||
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
|
||||
IN: tools.ps.macosx
|
||||
|
||||
<PRIVATE
|
||||
|
@ -36,7 +39,7 @@ STRUCT: _pcred
|
|||
STRUCT: _ucred
|
||||
{ cr_ref int32_t }
|
||||
{ cr_uid uid_t }
|
||||
{ cr_ngroups c::short }
|
||||
{ cr_ngroups c:short }
|
||||
{ cr_groups gid_t[16] } ;
|
||||
|
||||
STRUCT: vmspace
|
||||
|
@ -106,15 +109,15 @@ STRUCT: kinfo_proc
|
|||
{ e_vm vmspace }
|
||||
{ e_ppid pid_t }
|
||||
{ e_pgid pid_t }
|
||||
{ e_joc c::short }
|
||||
{ e_joc c:short }
|
||||
{ e_tdev dev_t }
|
||||
{ e_tpgid pid_t }
|
||||
{ e_tsess void* }
|
||||
{ e_mesg char[8] }
|
||||
{ e_xsize segsz_t }
|
||||
{ e_xrssize c::short }
|
||||
{ e_xccount c::short }
|
||||
{ e_xswrss c::short }
|
||||
{ e_xrssize c:short }
|
||||
{ e_xccount c:short }
|
||||
{ e_xswrss c:short }
|
||||
{ e_flag int32_t }
|
||||
{ e_login char[12] }
|
||||
{ e_spare int32_t[4] } ;
|
||||
|
|
|
@ -57,7 +57,7 @@ CONSTANT: attrib-table H{
|
|||
: arb-make-pixel-format ( world attributes -- pf )
|
||||
[ handle>> hDC>> ] dip
|
||||
perm-attribs attrib-table pixel-format-attributes>int-array
|
||||
f 1 { c::int c::int }
|
||||
f 1 { c:int c:int }
|
||||
[ wglChoosePixelFormatARB win32-error=0/f ] with-out-parameters drop ;
|
||||
|
||||
CONSTANT: pfd-flag-map H{
|
||||
|
@ -84,7 +84,7 @@ CONSTANT: pfd-flag-map H{
|
|||
: >pfd ( attributes -- pfd )
|
||||
[ PIXELFORMATDESCRIPTOR <struct> ] dip
|
||||
{
|
||||
[ drop PIXELFORMATDESCRIPTOR c::heap-size >>nSize ]
|
||||
[ drop PIXELFORMATDESCRIPTOR c:heap-size >>nSize ]
|
||||
[ drop 1 >>nVersion ]
|
||||
[ >pfd-flags >>dwFlags ]
|
||||
[ drop PFD_TYPE_RGBA >>iPixelType ]
|
||||
|
@ -434,7 +434,7 @@ SYMBOL: nc-buttons
|
|||
drop
|
||||
] [
|
||||
[ SetCapture drop ] keep
|
||||
mouse-captured namespaces::set
|
||||
mouse-captured namespaces:set
|
||||
] if ;
|
||||
|
||||
: release-capture ( -- )
|
||||
|
@ -466,7 +466,7 @@ SYMBOL: nc-buttons
|
|||
: make-TRACKMOUSEEVENT ( hWnd -- alien )
|
||||
TRACKMOUSEEVENT <struct>
|
||||
swap >>hwndTrack
|
||||
TRACKMOUSEEVENT c::heap-size >>cbSize ;
|
||||
TRACKMOUSEEVENT c:heap-size >>cbSize ;
|
||||
|
||||
: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
|
||||
2nip
|
||||
|
@ -554,10 +554,15 @@ SYMBOL: trace-messages?
|
|||
|
||||
! return 0 if you handle the message, else just let DefWindowProc return its val
|
||||
: ui-wndproc ( -- object )
|
||||
c::uint { c::void* c::uint WPARAM LPARAM } stdcall [
|
||||
pick wm-handlers get-global at*
|
||||
[ flush call( hWnd Msg wParam lParam -- result ) ] [ drop DefWindowProc ] if
|
||||
] alien-callback ;
|
||||
c:uint { c:void* c:uint WPARAM LPARAM } stdcall [
|
||||
pick
|
||||
|
||||
trace-messages? get-global
|
||||
[ dup windows-message-name name>> print flush ] when
|
||||
|
||||
wm-handlers get-global at*
|
||||
[ call( hWnd Msg wParam lParam -- result ) ] [ drop DefWindowProc ] if
|
||||
] alien-callback ;
|
||||
|
||||
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
|
||||
|
||||
|
@ -571,7 +576,7 @@ M: windows-ui-backend do-events
|
|||
:: register-window-class ( class-name-ptr -- )
|
||||
WNDCLASSEX <struct> f GetModuleHandle
|
||||
class-name-ptr pick GetClassInfoEx 0 = [
|
||||
WNDCLASSEX c::heap-size >>cbSize
|
||||
WNDCLASSEX c:heap-size >>cbSize
|
||||
flags{ CS_HREDRAW CS_VREDRAW CS_OWNDC } >>style
|
||||
ui-wndproc >>lpfnWndProc
|
||||
0 >>cbClsExtra
|
||||
|
@ -715,7 +720,7 @@ M: windows-ui-backend system-alert
|
|||
: fullscreen-RECT ( hwnd -- RECT )
|
||||
MONITOR_DEFAULTTONEAREST MonitorFromWindow
|
||||
MONITORINFOEX <struct>
|
||||
MONITORINFOEX c::heap-size >>cbSize
|
||||
MONITORINFOEX c:heap-size >>cbSize
|
||||
[ GetMonitorInfo win32-error=0/f ] keep rcMonitor>> ;
|
||||
|
||||
: client-area>RECT ( hwnd -- RECT )
|
||||
|
|
|
@ -395,7 +395,7 @@ editor "editing" f {
|
|||
|
||||
: com-paste ( editor -- ) clipboard get paste-clipboard ;
|
||||
|
||||
: paste-selection ( editor -- ) ui.clipboards::selection get paste-clipboard ;
|
||||
: paste-selection ( editor -- ) ui.clipboards:selection get paste-clipboard ;
|
||||
|
||||
: com-cut ( editor -- ) clipboard get editor-cut ;
|
||||
|
||||
|
|
|
@ -271,10 +271,10 @@ SYMBOL: drag-timer
|
|||
dup multi-click? [
|
||||
hand-click# inc
|
||||
] [
|
||||
1 hand-click# namespaces::set
|
||||
1 hand-click# namespaces:set
|
||||
] if
|
||||
hand-last-button namespaces::set
|
||||
nano-count hand-last-time namespaces::set
|
||||
hand-last-button namespaces:set
|
||||
nano-count hand-last-time namespaces:set
|
||||
] with-global ;
|
||||
|
||||
: update-clicked ( -- )
|
||||
|
|
|
@ -20,11 +20,11 @@ SYMBOL: viewport-translation
|
|||
: init-clip ( gadget -- )
|
||||
[
|
||||
dim>>
|
||||
[ { 0 1 } v* viewport-translation namespaces::set ]
|
||||
[ { 0 1 } v* viewport-translation namespaces:set ]
|
||||
[ [ { 0 0 } ] dip gl-viewport ]
|
||||
[ [ 0 ] dip first2 0 1 -1 glOrtho ] tri
|
||||
]
|
||||
[ clip namespaces::set ] bi
|
||||
[ clip namespaces:set ] bi
|
||||
do-clip ;
|
||||
|
||||
SLOT: background-color
|
||||
|
@ -87,7 +87,7 @@ M: gadget gadget-foreground dup interior>> pen-foreground ;
|
|||
<PRIVATE
|
||||
|
||||
: draw-selection-background ( gadget -- )
|
||||
selection-background get background namespaces::set
|
||||
selection-background get background namespaces:set
|
||||
selection-background get gl-color
|
||||
[ { 0 0 } ] dip dim>> gl-fill-rect ;
|
||||
|
||||
|
@ -123,7 +123,7 @@ PRIVATE>
|
|||
|
||||
: with-clipping ( gadget quot -- )
|
||||
clip get [ over change-clip do-clip call ] dip
|
||||
clip namespaces::set do-clip ; inline
|
||||
clip namespaces:set do-clip ; inline
|
||||
|
||||
: draw-gadget ( gadget -- )
|
||||
{
|
||||
|
@ -142,10 +142,10 @@ M: gadget draw-children
|
|||
} cleave [
|
||||
|
||||
{
|
||||
[ [ selected-gadgets namespaces::set ] when* ]
|
||||
[ [ selection-background namespaces::set ] when* ]
|
||||
[ [ background namespaces::set ] when* ]
|
||||
[ [ foreground namespaces::set ] when* ]
|
||||
[ [ selected-gadgets namespaces:set ] when* ]
|
||||
[ [ selection-background namespaces:set ] when* ]
|
||||
[ [ background namespaces:set ] when* ]
|
||||
[ [ foreground namespaces:set ] when* ]
|
||||
} spread
|
||||
[ draw-gadget ] each
|
||||
] with-scope
|
||||
|
|
|
@ -28,7 +28,7 @@ M: stack-entry-renderer row-value drop object>> ;
|
|||
40 >>min-cols
|
||||
40 >>max-cols
|
||||
monospace-font >>font
|
||||
[ i::inspector ] >>action
|
||||
[ i:inspector ] >>action
|
||||
t >>single-click? ;
|
||||
|
||||
: <stack-display> ( model quot title color -- gadget )
|
||||
|
@ -68,13 +68,13 @@ TUPLE: traceback-gadget < tool ;
|
|||
add-toolbar ;
|
||||
|
||||
: variables ( traceback -- )
|
||||
model>> [ dup [ name>> vars-in-scope ] when ] <arrow> i::inspect-model ;
|
||||
model>> [ dup [ name>> vars-in-scope ] when ] <arrow> i:inspect-model ;
|
||||
|
||||
: traceback-window ( continuation -- )
|
||||
<model> <traceback-gadget> "Traceback" open-status-window ;
|
||||
|
||||
: inspect-continuation ( traceback -- )
|
||||
control-value i::inspector ;
|
||||
control-value i:inspector ;
|
||||
|
||||
traceback-gadget "toolbar" f {
|
||||
{ T{ key-down f f "v" } variables }
|
||||
|
|
|
@ -2,6 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators.short-circuit kernel locals namespaces sbufs
|
||||
sequences splitting unicode.categories unicode.data ;
|
||||
QUALIFIED: ascii
|
||||
IN: unicode.case
|
||||
|
||||
SYMBOL: locale ! Just casing locale, or overall?
|
||||
|
|
|
@ -33,7 +33,7 @@ CONSTANT: name-map H{ }
|
|||
: combining-class ( char -- n ) class-map at ; inline
|
||||
: non-starter? ( char -- ? ) combining-class { 0 f } member? not ; inline
|
||||
: property ( property -- interval-map ) properties at ; foldable
|
||||
: property? ( char property -- ? ) property interval-sets::in? ; inline
|
||||
: property? ( char property -- ? ) property interval-sets:in? ; inline
|
||||
: special-case ( ch -- casing-tuple ) special-casing at ; inline
|
||||
|
||||
! For non-existent characters, use Cn
|
||||
|
|
|
@ -18,7 +18,7 @@ GENERIC: group-struct ( obj -- group/f )
|
|||
gr_mem>> utf8 alien>strings ;
|
||||
|
||||
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
|
||||
[ unix.ffi::group <struct> ] dip over 4096
|
||||
[ unix.ffi:group <struct> ] dip over 4096
|
||||
[ <byte-array> ] keep f void* <ref> ;
|
||||
|
||||
: check-group-struct ( group-struct ptr -- group-struct/f )
|
||||
|
@ -26,12 +26,12 @@ GENERIC: group-struct ( obj -- group/f )
|
|||
|
||||
M: integer group-struct ( id -- group/f )
|
||||
(group-struct)
|
||||
[ [ unix.ffi::getgrgid_r ] unix-system-call drop ] keep
|
||||
[ [ unix.ffi:getgrgid_r ] unix-system-call drop ] keep
|
||||
check-group-struct ;
|
||||
|
||||
M: string group-struct ( string -- group/f )
|
||||
(group-struct)
|
||||
[ [ unix.ffi::getgrnam_r ] unix-system-call drop ] keep
|
||||
[ [ unix.ffi:getgrnam_r ] unix-system-call drop ] keep
|
||||
check-group-struct ;
|
||||
|
||||
: group-struct>group ( group-struct -- group )
|
||||
|
@ -64,12 +64,12 @@ ERROR: no-group string ;
|
|||
<PRIVATE
|
||||
|
||||
: >groups ( byte-array n -- groups )
|
||||
[ 4 grouping::group ] dip head-slice [ uint deref group-name ] map ;
|
||||
[ 4 grouping:group ] dip head-slice [ uint deref group-name ] map ;
|
||||
|
||||
: (user-groups) ( string -- seq )
|
||||
dup user-passwd [
|
||||
gid>> 64 [ 4 * <byte-array> ] keep
|
||||
int <ref> [ [ unix.ffi::getgrouplist ] unix-system-call drop ] 2keep
|
||||
int <ref> [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep
|
||||
int deref >groups
|
||||
] [
|
||||
drop { }
|
||||
|
@ -86,7 +86,7 @@ M: integer user-groups ( id -- seq )
|
|||
user-name (user-groups) ;
|
||||
|
||||
: all-groups ( -- seq )
|
||||
[ unix.ffi::getgrent dup ] [ group-struct>group ] produce nip
|
||||
[ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip
|
||||
endgrent ;
|
||||
|
||||
: all-group-names ( -- seq )
|
||||
|
@ -98,11 +98,11 @@ M: integer user-groups ( id -- seq )
|
|||
: with-group-cache ( quot -- )
|
||||
[ <group-cache> group-cache ] dip with-variable ; inline
|
||||
|
||||
: real-group-id ( -- id ) unix.ffi::getgid ; inline
|
||||
: real-group-id ( -- id ) unix.ffi:getgid ; inline
|
||||
|
||||
: real-group-name ( -- string ) real-group-id group-name ; inline
|
||||
|
||||
: effective-group-id ( -- string ) unix.ffi::getegid ; inline
|
||||
: effective-group-id ( -- string ) unix.ffi:getegid ; inline
|
||||
|
||||
: effective-group-name ( -- string )
|
||||
effective-group-id group-name ; inline
|
||||
|
@ -130,10 +130,10 @@ GENERIC: set-effective-group ( obj -- )
|
|||
<PRIVATE
|
||||
|
||||
: (set-real-group) ( id -- )
|
||||
[ unix.ffi::setgid ] unix-system-call drop ; inline
|
||||
[ unix.ffi:setgid ] unix-system-call drop ; inline
|
||||
|
||||
: (set-effective-group) ( id -- )
|
||||
[ unix.ffi::setegid ] unix-system-call drop ; inline
|
||||
[ unix.ffi:setegid ] unix-system-call drop ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
@ -35,4 +35,4 @@ C-TYPE: rlimit
|
|||
C-TYPE: rusage
|
||||
C-TYPE: sockaddr
|
||||
|
||||
"unix.types." os name>> sequences::append require
|
||||
"unix.types." os name>> sequences:append require
|
||||
|
|
|
@ -32,13 +32,13 @@ M: unix passwd>new-passwd ( passwd -- seq )
|
|||
|
||||
: with-pwent ( quot -- )
|
||||
setpwent
|
||||
[ unix.ffi::endpwent ] [ ] cleanup ; inline
|
||||
[ unix.ffi:endpwent ] [ ] cleanup ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: all-users ( -- seq )
|
||||
[
|
||||
[ unix.ffi::getpwent dup ] [ passwd>new-passwd ] produce nip
|
||||
[ unix.ffi:getpwent dup ] [ passwd>new-passwd ] produce nip
|
||||
] with-pwent ;
|
||||
|
||||
: all-user-names ( -- seq )
|
||||
|
@ -56,10 +56,10 @@ GENERIC: user-passwd ( obj -- passwd/f )
|
|||
|
||||
M: integer user-passwd ( id -- passwd/f )
|
||||
user-cache get
|
||||
[ at ] [ unix.ffi::getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ;
|
||||
[ at ] [ unix.ffi:getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ;
|
||||
|
||||
M: string user-passwd ( string -- passwd/f )
|
||||
unix.ffi::getpwnam dup [ passwd>new-passwd ] when ;
|
||||
unix.ffi:getpwnam dup [ passwd>new-passwd ] when ;
|
||||
|
||||
: user-name ( id -- string )
|
||||
dup user-passwd
|
||||
|
@ -74,13 +74,13 @@ ERROR: no-user string ;
|
|||
dup user-passwd [ nip uid>> ] [ no-user ] if* ;
|
||||
|
||||
: real-user-id ( -- id )
|
||||
unix.ffi::getuid ; inline
|
||||
unix.ffi:getuid ; inline
|
||||
|
||||
: real-user-name ( -- string )
|
||||
real-user-id user-name ; inline
|
||||
|
||||
: effective-user-id ( -- id )
|
||||
unix.ffi::geteuid ; inline
|
||||
unix.ffi:geteuid ; inline
|
||||
|
||||
: effective-user-name ( -- string )
|
||||
effective-user-id user-name ; inline
|
||||
|
@ -110,10 +110,10 @@ GENERIC: set-effective-user ( string/id -- )
|
|||
<PRIVATE
|
||||
|
||||
: (set-real-user) ( id -- )
|
||||
[ unix.ffi::setuid ] unix-system-call drop ; inline
|
||||
[ unix.ffi:setuid ] unix-system-call drop ; inline
|
||||
|
||||
: (set-effective-user) ( id -- )
|
||||
[ unix.ffi::seteuid ] unix-system-call drop ; inline
|
||||
[ unix.ffi:seteuid ] unix-system-call drop ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
@ -4,7 +4,7 @@ QUALIFIED: vm
|
|||
IN: vm.tests
|
||||
|
||||
: get-ctx ( -- ctx )
|
||||
context vm::context memory>struct ;
|
||||
context vm:context memory>struct ;
|
||||
|
||||
{ t } [
|
||||
get-ctx [ callstack-bottom>> ] [ callstack-top>> ] bi - 0 >
|
||||
|
|
|
@ -5,7 +5,7 @@ math multiline classes.struct alien.data arrays literals ;
|
|||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: windows.kernel32
|
||||
|
||||
: lo-word ( wparam -- lo ) c::short <ref> c::short deref ; inline
|
||||
: lo-word ( wparam -- lo ) c:short <ref> c:short deref ; inline
|
||||
: hi-word ( wparam -- hi ) -16 shift lo-word ; inline
|
||||
: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ; inline
|
||||
|
||||
|
|
|
@ -121,8 +121,8 @@ DEFER: make-tag ! Is this unavoidable?
|
|||
|
||||
: take-internal-subset ( -- dtd )
|
||||
[
|
||||
H{ } clone pe-table namespaces::set
|
||||
t in-dtd? namespaces::set
|
||||
H{ } clone pe-table namespaces:set
|
||||
t in-dtd? namespaces:set
|
||||
dtd-loop
|
||||
pe-table get
|
||||
] { } make swap extra-entities get swap <dtd> ;
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue