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

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

db4
Doug Coleman 2009-08-26 09:40:49 -05:00
parent d109126c4b 5a298a00fd
commit 03fc2a3461
32 changed files with 421 additions and 205 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
basis/alien/arrays/arrays-docs.factor
View File

@ -4,4 +4,9 @@ USING: help.syntax help.markup byte-arrays alien.c-types ;
ARTICLE: "c-arrays" "C arrays" ARTICLE: "c-arrays" "C arrays"
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "." "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
$nl $nl
"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ; "C type specifiers for array types are documented in " { $link "c-types-specs" } "."
$nl
"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets. They can also be loaded and constructed through their primitive C types:"
{ $subsection require-c-type-arrays }
{ $subsection <c-type-array> }
{ $subsection <c-type-direct-array> } ;

6
basis/alien/arrays/arrays.factor
View File

@ -29,7 +29,11 @@ M: array box-return drop "void*" box-return ;
M: array stack-size drop "void*" stack-size ; M: array stack-size drop "void*" stack-size ;
M: array c-type-boxer-quot drop [ ] ; M: array c-type-boxer-quot
unclip
[ product ]
[ [ require-c-type-arrays ] keep ] bi*
[ <c-type-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ; M: array c-type-unboxer-quot drop [ >c-ptr ] ;

17
basis/alien/c-types/c-types-docs.factor
View File

@ -1,7 +1,7 @@
IN: alien.c-types IN: alien.c-types
USING: alien help.syntax help.markup libc kernel.private USING: alien help.syntax help.markup libc kernel.private
byte-arrays math strings hashtables alien.syntax alien.strings sequences byte-arrays math strings hashtables alien.syntax alien.strings sequences
io.encodings.string debugger destructors ; io.encodings.string debugger destructors vocabs.loader ;
HELP: <c-type> HELP: <c-type>
{ $values { "type" hashtable } } { $values { "type" hashtable } }
@ -128,6 +128,21 @@ HELP: malloc-string
} }
} ; } ;
HELP: require-c-type-arrays
{ $values { "c-type" "a C type" } }
{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link <c-type-array> } " or " { $link <c-type-direct-array> } " vocabularies." }
{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets for details on the underlying sequence types loaded." } ;
HELP: <c-type-array>
{ $values { "len" integer } { "c-type" "a C type" } { "array" "a specialized array" } }
{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } "." }
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } ;
HELP: <c-type-direct-array>
{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ;
ARTICLE: "c-strings" "C strings" ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." "C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl $nl

99
basis/alien/c-types/c-types.factor
View File

@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser
cpu.architecture alien alien.accessors alien.strings quotations cpu.architecture alien alien.accessors alien.strings quotations
layouts system compiler.units io io.files io.encodings.binary layouts system compiler.units io io.files io.encodings.binary
io.streams.memory accessors combinators effects continuations fry io.streams.memory accessors combinators effects continuations fry
classes ; classes vocabs vocabs.loader ;
IN: alien.c-types IN: alien.c-types
DEFER: <int> DEFER: <int>
@ -21,7 +21,12 @@ TUPLE: abstract-c-type
{ getter callable } { getter callable }
{ setter callable } { setter callable }
size size
align ; align
array-class
array-constructor
direct-array-class
direct-array-constructor
sequence-mixin-class ;
TUPLE: c-type < abstract-c-type TUPLE: c-type < abstract-c-type
boxer boxer
@ -71,6 +76,51 @@ M: string c-type ( name -- type )
] ?if ] ?if
] if ; ] if ;
: ?require-word ( word/pair -- )
dup word? [ drop ] [ first require ] ?if ;
GENERIC: require-c-type-arrays ( c-type -- )
M: object require-c-type-arrays
drop ;
M: c-type require-c-type-arrays
[ array-class>> ?require-word ]
[ sequence-mixin-class>> ?require-word ]
[ direct-array-class>> ?require-word ] tri ;
M: string require-c-type-arrays
c-type require-c-type-arrays ;
M: array require-c-type-arrays
first c-type require-c-type-arrays ;
ERROR: specialized-array-vocab-not-loaded vocab word ;
: c-type-array-constructor ( c-type -- word )
array-constructor>> dup array?
[ first2 specialized-array-vocab-not-loaded ] when ; foldable
: c-type-direct-array-constructor ( c-type -- word )
direct-array-constructor>> dup array?
[ first2 specialized-array-vocab-not-loaded ] when ; foldable
GENERIC: <c-type-array> ( len c-type -- array )
M: object <c-type-array>
c-type-array-constructor execute( len -- array ) ; inline
M: string <c-type-array>
c-type <c-type-array> ; inline
M: array <c-type-array>
first c-type <c-type-array> ; inline
GENERIC: <c-type-direct-array> ( alien len c-type -- array )
M: object <c-type-direct-array>
c-type-direct-array-constructor execute( alien len -- array ) ; inline
M: string <c-type-direct-array>
c-type <c-type-direct-array> ; inline
M: array <c-type-direct-array>
first c-type <c-type-direct-array> ; inline
GENERIC: c-type-class ( name -- class ) GENERIC: c-type-class ( name -- class )
M: abstract-c-type c-type-class class>> ; M: abstract-c-type c-type-class class>> ;
@ -293,6 +343,36 @@ M: long-long-type box-return ( type -- )
: if-void ( type true false -- ) : if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline pick "void" = [ drop nip call ] [ nip call ] if ; inline
: ?lookup ( vocab word -- word/pair )
over vocab [ swap lookup ] [ 2array ] if ;
: set-array-class* ( c-type vocab-stem type-stem -- c-type )
{
[
[ "specialized-arrays." prepend ]
[ "-array" append ] bi* ?lookup >>array-class
]
[
[ "specialized-arrays." prepend ]
[ "<" "-array>" surround ] bi* ?lookup >>array-constructor
]
[
[ "specialized-arrays." prepend ]
[ "-sequence" append ] bi* ?lookup >>sequence-mixin-class
]
[
[ "specialized-arrays.direct." prepend ]
[ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class
]
[
[ "specialized-arrays.direct." prepend ]
[ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
]
} 2cleave ;
: set-array-class ( c-type stem -- c-type )
dup set-array-class* ;
CONSTANT: primitive-types CONSTANT: primitive-types
{ {
"char" "uchar" "char" "uchar"
@ -315,6 +395,7 @@ CONSTANT: primitive-types
[ >c-ptr ] >>unboxer-quot [ >c-ptr ] >>unboxer-quot
"box_alien" >>boxer "box_alien" >>boxer
"alien_offset" >>unboxer "alien_offset" >>unboxer
"alien" "void*" set-array-class*
"void*" define-primitive-type "void*" define-primitive-type
<long-long-type> <long-long-type>
@ -326,6 +407,7 @@ CONSTANT: primitive-types
8 >>align 8 >>align
"box_signed_8" >>boxer "box_signed_8" >>boxer
"to_signed_8" >>unboxer "to_signed_8" >>unboxer
"longlong" set-array-class
"longlong" define-primitive-type "longlong" define-primitive-type
<long-long-type> <long-long-type>
@ -337,6 +419,7 @@ CONSTANT: primitive-types
8 >>align 8 >>align
"box_unsigned_8" >>boxer "box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer "to_unsigned_8" >>unboxer
"ulonglong" set-array-class
"ulonglong" define-primitive-type "ulonglong" define-primitive-type
<c-type> <c-type>
@ -348,6 +431,7 @@ CONSTANT: primitive-types
bootstrap-cell >>align bootstrap-cell >>align
"box_signed_cell" >>boxer "box_signed_cell" >>boxer
"to_fixnum" >>unboxer "to_fixnum" >>unboxer
"long" set-array-class
"long" define-primitive-type "long" define-primitive-type
<c-type> <c-type>
@ -359,6 +443,7 @@ CONSTANT: primitive-types
bootstrap-cell >>align bootstrap-cell >>align
"box_unsigned_cell" >>boxer "box_unsigned_cell" >>boxer
"to_cell" >>unboxer "to_cell" >>unboxer
"ulong" set-array-class
"ulong" define-primitive-type "ulong" define-primitive-type
<c-type> <c-type>
@ -370,6 +455,7 @@ CONSTANT: primitive-types
4 >>align 4 >>align
"box_signed_4" >>boxer "box_signed_4" >>boxer
"to_fixnum" >>unboxer "to_fixnum" >>unboxer
"int" set-array-class
"int" define-primitive-type "int" define-primitive-type
<c-type> <c-type>
@ -381,6 +467,7 @@ CONSTANT: primitive-types
4 >>align 4 >>align
"box_unsigned_4" >>boxer "box_unsigned_4" >>boxer
"to_cell" >>unboxer "to_cell" >>unboxer
"uint" set-array-class
"uint" define-primitive-type "uint" define-primitive-type
<c-type> <c-type>
@ -392,6 +479,7 @@ CONSTANT: primitive-types
2 >>align 2 >>align
"box_signed_2" >>boxer "box_signed_2" >>boxer
"to_fixnum" >>unboxer "to_fixnum" >>unboxer
"short" set-array-class
"short" define-primitive-type "short" define-primitive-type
<c-type> <c-type>
@ -403,6 +491,7 @@ CONSTANT: primitive-types
2 >>align 2 >>align
"box_unsigned_2" >>boxer "box_unsigned_2" >>boxer
"to_cell" >>unboxer "to_cell" >>unboxer
"ushort" set-array-class
"ushort" define-primitive-type "ushort" define-primitive-type
<c-type> <c-type>
@ -414,6 +503,7 @@ CONSTANT: primitive-types
1 >>align 1 >>align
"box_signed_1" >>boxer "box_signed_1" >>boxer
"to_fixnum" >>unboxer "to_fixnum" >>unboxer
"char" set-array-class
"char" define-primitive-type "char" define-primitive-type
<c-type> <c-type>
@ -425,6 +515,7 @@ CONSTANT: primitive-types
1 >>align 1 >>align
"box_unsigned_1" >>boxer "box_unsigned_1" >>boxer
"to_cell" >>unboxer "to_cell" >>unboxer
"uchar" set-array-class
"uchar" define-primitive-type "uchar" define-primitive-type
<c-type> <c-type>
@ -434,6 +525,7 @@ CONSTANT: primitive-types
1 >>align 1 >>align
"box_boolean" >>boxer "box_boolean" >>boxer
"to_boolean" >>unboxer "to_boolean" >>unboxer
"bool" set-array-class
"bool" define-primitive-type "bool" define-primitive-type
<c-type> <c-type>
@ -447,6 +539,7 @@ CONSTANT: primitive-types
"to_float" >>unboxer "to_float" >>unboxer
single-float-rep >>rep single-float-rep >>rep
[ >float ] >>unboxer-quot [ >float ] >>unboxer-quot
"float" set-array-class
"float" define-primitive-type "float" define-primitive-type
<c-type> <c-type>
@ -460,9 +553,11 @@ CONSTANT: primitive-types
"to_double" >>unboxer "to_double" >>unboxer
double-float-rep >>rep double-float-rep >>rep
[ >float ] >>unboxer-quot [ >float ] >>unboxer-quot
"double" set-array-class
"double" define-primitive-type "double" define-primitive-type
"long" "ptrdiff_t" typedef "long" "ptrdiff_t" typedef
"long" "intptr_t" typedef "long" "intptr_t" typedef
"ulong" "size_t" typedef "ulong" "size_t" typedef
] with-compilation-unit ] with-compilation-unit

1
basis/alien/complex/functor/functor.factor
View File

@ -31,6 +31,7 @@ T c-type
<T> 1quotation >>unboxer-quot <T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot *T 1quotation >>boxer-quot
number >>boxed-class number >>boxed-class
T set-array-class
drop drop
;FUNCTOR ;FUNCTOR

21
basis/alien/structs/structs.factor
View File

@ -3,7 +3,7 @@
USING: accessors arrays assocs generic hashtables kernel kernel.private USING: accessors arrays assocs generic hashtables kernel kernel.private
math namespaces parser sequences strings words libc fry math namespaces parser sequences strings words libc fry
alien.c-types alien.structs.fields cpu.architecture math.order alien.c-types alien.structs.fields cpu.architecture math.order
quotations byte-arrays ; quotations byte-arrays struct-arrays ;
IN: alien.structs IN: alien.structs
TUPLE: struct-type < abstract-c-type fields return-in-registers? ; TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
@ -12,6 +12,16 @@ M: struct-type c-type ;
M: struct-type c-type-stack-align? drop f ; M: struct-type c-type-stack-align? drop f ;
M: struct-type <c-type-array> ( len c-type -- array )
dup c-type-array-constructor
[ execute( len -- array ) ]
[ <struct-array> ] ?if ; inline
M: struct-type <c-type-direct-array> ( alien len c-type -- array )
dup c-type-direct-array-constructor
[ execute( alien len -- array ) ]
[ <direct-struct-array> ] ?if ; inline
: if-value-struct ( ctype true false -- ) : if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
@ -35,9 +45,8 @@ M: struct-type stack-size
: c-struct? ( type -- ? ) (c-type) struct-type? ; : c-struct? ( type -- ? ) (c-type) struct-type? ;
: (define-struct) ( name size align fields -- ) : (define-struct) ( name size align fields class -- )
[ [ align ] keep ] dip [ [ align ] keep ] 2dip new
struct-type new
byte-array >>class byte-array >>class
byte-array >>boxed-class byte-array >>boxed-class
swap >>fields swap >>fields
@ -55,13 +64,13 @@ M: struct-type stack-size
[ 2drop ] [ make-fields ] 3bi [ 2drop ] [ make-fields ] 3bi
[ struct-offsets ] keep [ struct-offsets ] keep
[ [ type>> ] map compute-struct-align ] keep [ [ type>> ] map compute-struct-align ] keep
[ (define-struct) ] keep [ struct-type (define-struct) ] keep
[ define-field ] each ; [ define-field ] each ;
: define-union ( name members -- ) : define-union ( name members -- )
[ expand-constants ] map [ expand-constants ] map
[ [ heap-size ] [ max ] map-reduce ] keep [ [ heap-size ] [ max ] map-reduce ] keep
compute-struct-align f (define-struct) ; compute-struct-align f struct-type (define-struct) ;
: offset-of ( field struct -- offset ) : offset-of ( field struct -- offset )
c-types get at fields>> c-types get at fields>>

30
basis/compiler/cfg/debugger/debugger.factor
View File

@ -1,15 +1,16 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io vectors USING: kernel words sequences quotations namespaces io vectors
classes.tuple accessors prettyprint prettyprint.config assocs arrays hashtables classes.tuple accessors prettyprint
prettyprint.backend prettyprint.custom prettyprint.sections prettyprint.config assocs prettyprint.backend prettyprint.custom
parser compiler.tree.builder compiler.tree.optimizer prettyprint.sections parser compiler.tree.builder
cpu.architecture compiler.cfg.builder compiler.cfg.linearization compiler.tree.optimizer cpu.architecture compiler.cfg.builder
compiler.cfg.registers compiler.cfg.stack-frame compiler.cfg.linearization compiler.cfg.registers
compiler.cfg.linear-scan compiler.cfg.two-operand compiler.cfg.stack-frame compiler.cfg.linear-scan
compiler.cfg.optimizer compiler.cfg.instructions compiler.cfg.two-operand compiler.cfg.optimizer
compiler.cfg.utilities compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.utilities
compiler.cfg.rpo compiler.cfg.mr compiler.cfg ; compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
compiler.cfg.representations.preferred compiler.cfg ;
IN: compiler.cfg.debugger IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs ) GENERIC: test-cfg ( quot -- cfgs )
@ -73,8 +74,9 @@ M: rs-loc pprint* \ R pprint-loc ;
: fake-representations ( cfg -- ) : fake-representations ( cfg -- )
post-order [ post-order [
instructions>> instructions>> [
[ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
map concat [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ]
] map concat bi [ suffix ] when*
[ int-rep ] H{ } map>assoc representations set ; ] map concat
] map concat >hashtable representations set ;

1
basis/compiler/cfg/hats/hats.factor
View File

@ -43,6 +43,7 @@ IN: compiler.cfg.hats
: ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline : ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline
: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline : ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline
: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline : ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline : ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline : ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
: ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline : ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline

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

@ -106,6 +106,7 @@ INSN: ##add-float < ##commutative ;
INSN: ##sub-float < ##binary ; INSN: ##sub-float < ##binary ;
INSN: ##mul-float < ##commutative ; INSN: ##mul-float < ##commutative ;
INSN: ##div-float < ##binary ; INSN: ##div-float < ##binary ;
INSN: ##sqrt < ##unary ;
! Float/integer conversion ! Float/integer conversion
INSN: ##float>integer < ##unary ; INSN: ##float>integer < ##unary ;
@ -256,6 +257,7 @@ UNION: output-float-insn
##sub-float ##sub-float
##mul-float ##mul-float
##div-float ##div-float
##sqrt
##integer>float ##integer>float
##unbox-float ##unbox-float
##alien-float ##alien-float
@ -267,6 +269,7 @@ UNION: input-float-insn
##sub-float ##sub-float
##mul-float ##mul-float
##div-float ##div-float
##sqrt
##float>integer ##float>integer
##box-float ##box-float
##set-alien-float ##set-alien-float

3
basis/compiler/cfg/intrinsics/float/float.factor
View File

@ -15,3 +15,6 @@ IN: compiler.cfg.intrinsics.float
: emit-fixnum>float ( -- ) : emit-fixnum>float ( -- )
ds-pop ^^untag-fixnum ^^integer>float ds-push ; ds-pop ^^untag-fixnum ^^integer>float ds-push ;
: emit-fsqrt ( -- )
ds-pop ^^sqrt ds-push ;

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

@ -19,6 +19,7 @@ QUALIFIED: strings.private
QUALIFIED: classes.tuple.private QUALIFIED: classes.tuple.private
QUALIFIED: math.private QUALIFIED: math.private
QUALIFIED: math.integers.private QUALIFIED: math.integers.private
QUALIFIED: math.libm
QUALIFIED: alien.accessors QUALIFIED: alien.accessors
IN: compiler.cfg.intrinsics IN: compiler.cfg.intrinsics
@ -92,6 +93,9 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-double alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ; } [ t "intrinsic" set-word-prop ] each ;
: enable-fsqrt ( -- )
\ math.libm:fsqrt t "intrinsic" set-word-prop ;
: enable-fixnum-log2 ( -- ) : enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
@ -130,6 +134,7 @@ IN: compiler.cfg.intrinsics
{ \ math.private:float= [ drop cc= emit-float-comparison ] } { \ math.private:float= [ drop cc= emit-float-comparison ] }
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] } { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] } { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
{ \ math.libm:fsqrt [ drop emit-fsqrt ] }
{ \ slots.private:slot [ emit-slot ] } { \ slots.private:slot [ emit-slot ] }
{ \ slots.private:set-slot [ emit-set-slot ] } { \ slots.private:set-slot [ emit-set-slot ] }
{ \ strings.private:string-nth [ drop emit-string-nth ] } { \ strings.private:string-nth [ drop emit-string-nth ] }

51
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -656,14 +656,17 @@ V{
T{ ##copy T{ ##copy
{ dst 689481 } { dst 689481 }
{ src 689475 } { src 689475 }
{ rep int-rep }
} }
T{ ##copy T{ ##copy
{ dst 689482 } { dst 689482 }
{ src 689474 } { src 689474 }
{ rep int-rep }
} }
T{ ##copy T{ ##copy
{ dst 689483 } { dst 689483 }
{ src 689473 } { src 689473 }
{ rep int-rep }
} }
T{ ##branch } T{ ##branch }
} 2 test-bb } 2 test-bb
@ -672,14 +675,17 @@ V{
T{ ##copy T{ ##copy
{ dst 689481 } { dst 689481 }
{ src 689473 } { src 689473 }
{ rep int-rep }
} }
T{ ##copy T{ ##copy
{ dst 689482 } { dst 689482 }
{ src 689475 } { src 689475 }
{ rep int-rep }
} }
T{ ##copy T{ ##copy
{ dst 689483 } { dst 689483 }
{ src 689474 } { src 689474 }
{ rep int-rep }
} }
T{ ##branch } T{ ##branch }
} 3 test-bb } 3 test-bb
@ -742,10 +748,12 @@ V{
T{ ##copy T{ ##copy
{ dst 689608 } { dst 689608 }
{ src 689600 } { src 689600 }
{ rep int-rep }
} }
T{ ##copy T{ ##copy
{ dst 689610 } { dst 689610 }
{ src 689601 } { src 689601 }
{ rep int-rep }
} }
T{ ##branch } T{ ##branch }
} 2 test-bb } 2 test-bb
@ -758,14 +766,17 @@ V{
T{ ##copy T{ ##copy
{ dst 689607 } { dst 689607 }
{ src 689600 } { src 689600 }
{ rep int-rep }
} }
T{ ##copy T{ ##copy
{ dst 689608 } { dst 689608 }
{ src 689601 } { src 689601 }
{ rep int-rep }
} }
T{ ##copy T{ ##copy
{ dst 689610 } { dst 689610 }
{ src 689609 } { src 689609 }
{ rep int-rep }
} }
T{ ##branch } T{ ##branch }
} 3 test-bb } 3 test-bb
@ -816,6 +827,7 @@ V{
T{ ##copy T{ ##copy
{ dst 2 } { dst 2 }
{ src 1 } { src 1 }
{ rep int-rep }
} }
T{ ##branch } T{ ##branch }
} 2 test-bb } 2 test-bb
@ -828,6 +840,7 @@ V{
T{ ##copy T{ ##copy
{ dst 2 } { dst 2 }
{ src 3 } { src 3 }
{ rep int-rep }
} }
T{ ##branch } T{ ##branch }
} 3 test-bb } 3 test-bb
@ -1121,7 +1134,7 @@ V{
{ slot 1 } { slot 1 }
{ tag 2 } { tag 2 }
} }
T{ ##copy { dst 79 } { src 69 } } T{ ##copy { dst 79 } { src 69 } { rep int-rep } }
T{ ##slot-imm T{ ##slot-imm
{ dst 85 } { dst 85 }
{ obj 62 } { obj 62 }
@ -1169,22 +1182,22 @@ V{
T{ ##peek { dst 114 } { loc D 1 } } T{ ##peek { dst 114 } { loc D 1 } }
T{ ##peek { dst 116 } { loc D 4 } } T{ ##peek { dst 116 } { loc D 4 } }
T{ ##peek { dst 119 } { loc R 0 } } T{ ##peek { dst 119 } { loc R 0 } }
T{ ##copy { dst 109 } { src 108 } } T{ ##copy { dst 109 } { src 108 } { rep int-rep } }
T{ ##copy { dst 111 } { src 110 } } T{ ##copy { dst 111 } { src 110 } { rep int-rep } }
T{ ##copy { dst 113 } { src 112 } } T{ ##copy { dst 113 } { src 112 } { rep int-rep } }
T{ ##copy { dst 115 } { src 114 } } T{ ##copy { dst 115 } { src 114 } { rep int-rep } }
T{ ##copy { dst 117 } { src 116 } } T{ ##copy { dst 117 } { src 116 } { rep int-rep } }
T{ ##copy { dst 120 } { src 119 } } T{ ##copy { dst 120 } { src 119 } { rep int-rep } }
T{ ##branch } T{ ##branch }
} 3 test-bb } 3 test-bb
V{ V{
T{ ##copy { dst 109 } { src 62 } } T{ ##copy { dst 109 } { src 62 } { rep int-rep } }
T{ ##copy { dst 111 } { src 61 } } T{ ##copy { dst 111 } { src 61 } { rep int-rep } }
T{ ##copy { dst 113 } { src 62 } } T{ ##copy { dst 113 } { src 62 } { rep int-rep } }
T{ ##copy { dst 115 } { src 79 } } T{ ##copy { dst 115 } { src 79 } { rep int-rep } }
T{ ##copy { dst 117 } { src 64 } } T{ ##copy { dst 117 } { src 64 } { rep int-rep } }
T{ ##copy { dst 120 } { src 69 } } T{ ##copy { dst 120 } { src 69 } { rep int-rep } }
T{ ##branch } T{ ##branch }
} 4 test-bb } 4 test-bb
@ -1306,12 +1319,12 @@ V{
T{ ##peek { dst 162 } { loc D 1 } } T{ ##peek { dst 162 } { loc D 1 } }
T{ ##peek { dst 164 } { loc D 4 } } T{ ##peek { dst 164 } { loc D 4 } }
T{ ##peek { dst 167 } { loc R 0 } } T{ ##peek { dst 167 } { loc R 0 } }
T{ ##copy { dst 157 } { src 156 } } T{ ##copy { dst 157 } { src 156 } { rep int-rep } }
T{ ##copy { dst 159 } { src 158 } } T{ ##copy { dst 159 } { src 158 } { rep int-rep } }
T{ ##copy { dst 161 } { src 160 } } T{ ##copy { dst 161 } { src 160 } { rep int-rep } }
T{ ##copy { dst 163 } { src 162 } } T{ ##copy { dst 163 } { src 162 } { rep int-rep } }
T{ ##copy { dst 165 } { src 164 } } T{ ##copy { dst 165 } { src 164 } { rep int-rep } }
T{ ##copy { dst 168 } { src 167 } } T{ ##copy { dst 168 } { src 167 } { rep int-rep } }
T{ ##branch } T{ ##branch }
} 4 test-bb } 4 test-bb

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

@ -170,6 +170,8 @@ M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
M: ##mul-float generate-insn dst/src1/src2 %mul-float ; M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
M: ##div-float generate-insn dst/src1/src2 %div-float ; M: ##div-float generate-insn dst/src1/src2 %div-float ;
M: ##sqrt generate-insn dst/src %sqrt ;
M: ##integer>float generate-insn dst/src %integer>float ; M: ##integer>float generate-insn dst/src %integer>float ;
M: ##float>integer generate-insn dst/src %float>integer ; M: ##float>integer generate-insn dst/src %float>integer ;

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

@ -3,7 +3,7 @@ compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr
compiler.cfg.registers compiler.codegen compiler.units compiler.cfg.registers compiler.codegen compiler.units
cpu.architecture hashtables kernel namespaces sequences cpu.architecture hashtables kernel namespaces sequences
tools.test vectors words layouts literals math arrays tools.test vectors words layouts literals math arrays
alien.syntax ; alien.syntax math.private ;
IN: compiler.tests.low-level-ir IN: compiler.tests.low-level-ir
: compile-cfg ( cfg -- word ) : compile-cfg ( cfg -- word )
@ -46,6 +46,20 @@ IN: compiler.tests.low-level-ir
} compile-test-bb } compile-test-bb
] unit-test ] unit-test
! ##copy on floats. We can only run this test if float intrinsics
! are enabled.
\ float+ "intrinsic" word-prop [
[ 1.5 ] [
V{
T{ ##load-reference f 4 1.5 }
T{ ##unbox-float f 1 4 }
T{ ##copy f 2 1 double-float-rep }
T{ ##box-float f 3 2 }
T{ ##copy f 0 3 int-rep }
} compile-test-bb
] unit-test
] when
! make sure slot access works when the destination is ! make sure slot access works when the destination is
! one of the sources ! one of the sources
[ t ] [ [ t ] [
@ -138,4 +152,4 @@ USE: multiline
} compile-test-bb } compile-test-bb
] unit-test ] unit-test
*/ */

16
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -2,11 +2,12 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel effects accessors math math.private USING: kernel effects accessors math math.private
math.integers.private math.partial-dispatch math.intervals math.integers.private math.partial-dispatch math.intervals
math.parser math.order math.functions layouts words sequences sequences.private math.parser math.order math.functions math.libm layouts words
arrays assocs classes classes.algebra combinators generic.math sequences sequences.private arrays assocs classes
splitting fry locals classes.tuple alien.accessors classes.algebra combinators generic.math splitting fry locals
classes.tuple.private slots.private definitions strings.private classes.tuple alien.accessors classes.tuple.private
vectors hashtables generic quotations slots.private definitions strings.private vectors hashtables
generic quotations
stack-checker.state stack-checker.state
compiler.tree.comparisons compiler.tree.comparisons
compiler.tree.propagation.info compiler.tree.propagation.info
@ -297,3 +298,8 @@ generic-comparison-ops [
bi bi
] [ 2drop object-info ] if ] [ 2drop object-info ] if
] "outputs" set-word-prop ] "outputs" set-word-prop
{ facos fasin fatan fatan2 fcos fsin ftan fcosh fsinh ftanh fexp
flog fpow fsqrt facosh fasinh fatanh } [
{ float } "default-output-classes" set-word-prop
] each

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

@ -110,6 +110,7 @@ HOOK: %add-float cpu ( dst src1 src2 -- )
HOOK: %sub-float cpu ( dst src1 src2 -- ) HOOK: %sub-float cpu ( dst src1 src2 -- )
HOOK: %mul-float cpu ( dst src1 src2 -- ) HOOK: %mul-float cpu ( dst src1 src2 -- )
HOOK: %div-float cpu ( dst src1 src2 -- ) HOOK: %div-float cpu ( dst src1 src2 -- )
HOOK: %sqrt cpu ( dst src -- )
HOOK: %integer>float cpu ( dst src -- ) HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- ) HOOK: %float>integer cpu ( dst src -- )

223
basis/cpu/ppc/assembler/assembler-tests.factor
View File

@ -1,117 +1,120 @@
USING: cpu.ppc.assembler tools.test arrays kernel namespaces USING: cpu.ppc.assembler tools.test arrays kernel namespaces
make vocabs sequences ; make vocabs sequences byte-arrays.hex ;
FROM: cpu.ppc.assembler => B ; FROM: cpu.ppc.assembler => B ;
IN: cpu.ppc.assembler.tests IN: cpu.ppc.assembler.tests
: test-assembler ( expected quot -- ) : test-assembler ( expected quot -- )
[ 1array ] [ [ B{ } make ] curry ] bi* unit-test ; [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler HEX{ 38 22 00 03 } [ 1 2 3 ADDI ] test-assembler
B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler HEX{ 3c 22 00 03 } [ 1 2 3 ADDIS ] test-assembler
B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler HEX{ 30 22 00 03 } [ 1 2 3 ADDIC ] test-assembler
B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler HEX{ 34 22 00 03 } [ 1 2 3 ADDIC. ] test-assembler
B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler HEX{ 38 40 00 01 } [ 1 2 LI ] test-assembler
B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler HEX{ 3c 40 00 01 } [ 1 2 LIS ] test-assembler
B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler HEX{ 38 22 ff fd } [ 1 2 3 SUBI ] test-assembler
B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler HEX{ 1c 22 00 03 } [ 1 2 3 MULI ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler HEX{ 7c 22 1a 14 } [ 1 2 3 ADD ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler HEX{ 7c 22 1a 15 } [ 1 2 3 ADD. ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler HEX{ 7c 22 1e 15 } [ 1 2 3 ADDO. ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler HEX{ 7c 22 18 14 } [ 1 2 3 ADDC ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler HEX{ 7c 22 18 15 } [ 1 2 3 ADDC. ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler HEX{ 7c 22 1c 15 } [ 1 2 3 ADDCO. ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler HEX{ 7c 22 19 14 } [ 1 2 3 ADDE ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler HEX{ 7c 41 18 38 } [ 1 2 3 AND ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler HEX{ 7c 41 18 39 } [ 1 2 3 AND. ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler HEX{ 7c 22 1b d6 } [ 1 2 3 DIVW ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler HEX{ 7c 22 1b 96 } [ 1 2 3 DIVWU ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler HEX{ 7c 41 1a 38 } [ 1 2 3 EQV ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler HEX{ 7c 41 1b b8 } [ 1 2 3 NAND ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler HEX{ 7c 41 18 f8 } [ 1 2 3 NOR ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler HEX{ 7c 41 10 f8 } [ 1 2 NOT ] test-assembler
B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler HEX{ 60 41 00 03 } [ 1 2 3 ORI ] test-assembler
B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler HEX{ 64 41 00 03 } [ 1 2 3 ORIS ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler HEX{ 7c 41 1b 78 } [ 1 2 3 OR ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler HEX{ 7c 41 13 78 } [ 1 2 MR ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler HEX{ 7c 22 18 96 } [ 1 2 3 MULHW ] test-assembler
B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler HEX{ 1c 22 00 03 } [ 1 2 3 MULLI ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler HEX{ 7c 22 18 16 } [ 1 2 3 MULHWU ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler HEX{ 7c 22 19 d6 } [ 1 2 3 MULLW ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler HEX{ 7c 41 18 30 } [ 1 2 3 SLW ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler HEX{ 7c 41 1e 30 } [ 1 2 3 SRAW ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler HEX{ 7c 41 1c 30 } [ 1 2 3 SRW ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler HEX{ 7c 41 1e 70 } [ 1 2 3 SRAWI ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler HEX{ 7c 22 18 50 } [ 1 2 3 SUBF ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler HEX{ 7c 22 18 10 } [ 1 2 3 SUBFC ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler HEX{ 7c 22 19 10 } [ 1 2 3 SUBFE ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler HEX{ 7c 41 07 74 } [ 1 2 EXTSB ] test-assembler
B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler HEX{ 68 41 00 03 } [ 1 2 3 XORI ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler HEX{ 7c 41 1a 78 } [ 1 2 3 XOR ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler HEX{ 7c 22 00 d0 } [ 1 2 NEG ] test-assembler
B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler HEX{ 2c 22 00 03 } [ 1 2 3 CMPI ] test-assembler
B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler HEX{ 28 22 00 03 } [ 1 2 3 CMPLI ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler HEX{ 7c 41 18 00 } [ 1 2 3 CMP ] test-assembler
B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler HEX{ 54 22 19 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler HEX{ 54 22 18 38 } [ 1 2 3 SLWI ] test-assembler
B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler HEX{ 54 22 e8 fe } [ 1 2 3 SRWI ] test-assembler
B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler HEX{ 88 22 00 03 } [ 1 2 3 LBZ ] test-assembler
B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler HEX{ 8c 22 00 03 } [ 1 2 3 LBZU ] test-assembler
B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler HEX{ a8 22 00 03 } [ 1 2 3 LHA ] test-assembler
B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler HEX{ ac 22 00 03 } [ 1 2 3 LHAU ] test-assembler
B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler HEX{ a0 22 00 03 } [ 1 2 3 LHZ ] test-assembler
B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler HEX{ a4 22 00 03 } [ 1 2 3 LHZU ] test-assembler
B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler HEX{ 80 22 00 03 } [ 1 2 3 LWZ ] test-assembler
B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler HEX{ 84 22 00 03 } [ 1 2 3 LWZU ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler HEX{ 7c 41 18 ae } [ 1 2 3 LBZX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler HEX{ 7c 41 18 ee } [ 1 2 3 LBZUX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler HEX{ 7c 41 1a ae } [ 1 2 3 LHAX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler HEX{ 7c 41 1a ee } [ 1 2 3 LHAUX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler HEX{ 7c 41 1a 2e } [ 1 2 3 LHZX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler HEX{ 7c 41 1a 6e } [ 1 2 3 LHZUX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler HEX{ 7c 41 18 2e } [ 1 2 3 LWZX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler HEX{ 7c 41 18 6e } [ 1 2 3 LWZUX ] test-assembler
B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler HEX{ 48 00 00 01 } [ 1 B ] test-assembler
B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler HEX{ 48 00 00 01 } [ 1 BL ] test-assembler
B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler HEX{ 41 81 00 04 } [ 1 BGT ] test-assembler
B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler HEX{ 40 81 00 04 } [ 1 BLE ] test-assembler
B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler HEX{ 40 80 00 04 } [ 1 BGE ] test-assembler
B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler HEX{ 40 82 00 04 } [ 1 BNE ] test-assembler
B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler HEX{ 41 82 00 04 } [ 1 BEQ ] test-assembler
B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler HEX{ 41 83 00 04 } [ 1 BO ] test-assembler
B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler HEX{ 40 83 00 04 } [ 1 BNO ] test-assembler
B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler HEX{ 4c 20 00 20 } [ 1 BCLR ] test-assembler
B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler HEX{ 4e 80 00 20 } [ BLR ] test-assembler
B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler HEX{ 4e 80 00 21 } [ BLRL ] test-assembler
B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler HEX{ 4c 20 04 20 } [ 1 BCCTR ] test-assembler
B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler HEX{ 4e 80 04 20 } [ BCTR ] test-assembler
B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler HEX{ 7c 69 02 a6 } [ 3 MFCTR ] test-assembler
B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler HEX{ 7c 61 03 a6 } [ 3 MTXER ] test-assembler
B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler HEX{ 7c 68 03 a6 } [ 3 MTLR ] test-assembler
B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler HEX{ 7c 69 03 a6 } [ 3 MTCTR ] test-assembler
B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler HEX{ c0 22 00 03 } [ 1 2 3 LFS ] test-assembler
B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler HEX{ c4 22 00 03 } [ 1 2 3 LFSU ] test-assembler
B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler HEX{ c8 22 00 03 } [ 1 2 3 LFD ] test-assembler
B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler HEX{ cc 22 00 03 } [ 1 2 3 LFDU ] test-assembler
B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler HEX{ d0 22 00 03 } [ 1 2 3 STFS ] test-assembler
B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler HEX{ d4 22 00 03 } [ 1 2 3 STFSU ] test-assembler
B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler HEX{ d8 22 00 03 } [ 1 2 3 STFD ] test-assembler
B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler HEX{ dc 22 00 03 } [ 1 2 3 STFDU ] test-assembler
B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler HEX{ fc 20 10 90 } [ 1 2 FMR ] test-assembler
B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler HEX{ fc 40 08 90 } [ 2 1 FMR ] test-assembler
B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler HEX{ fc 20 10 91 } [ 1 2 FMR. ] test-assembler
B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler HEX{ fc 40 08 91 } [ 2 1 FMR. ] test-assembler
B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler HEX{ fc 20 10 1e } [ 1 2 FCTIWZ ] test-assembler
B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler HEX{ fc 22 18 2a } [ 1 2 3 FADD ] test-assembler
B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler HEX{ fc 22 18 2b } [ 1 2 3 FADD. ] test-assembler
B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler HEX{ fc 22 18 28 } [ 1 2 3 FSUB ] test-assembler
B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler HEX{ fc 22 00 f2 } [ 1 2 3 FMUL ] test-assembler
B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler HEX{ fc 22 18 24 } [ 1 2 3 FDIV ] test-assembler
B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler HEX{ fc 20 10 2c } [ 1 2 FSQRT ] test-assembler
HEX{ fc 41 18 00 } [ 1 2 3 FCMPU ] test-assembler
HEX{ fc 41 18 40 } [ 1 2 3 FCMPO ] test-assembler
HEX{ 3c 60 12 34 60 63 56 78 } [ HEX: 12345678 3 LOAD ] test-assembler

16
basis/cpu/ppc/assembler/assembler.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces words io.binary math math.order USING: kernel namespaces words math math.order locals
cpu.ppc.assembler.backend ; cpu.ppc.assembler.backend ;
IN: cpu.ppc.assembler IN: cpu.ppc.assembler
@ -97,8 +97,8 @@ X: XOR 0 316 31
X: XOR. 1 316 31 X: XOR. 1 316 31
X1: EXTSB 0 954 31 X1: EXTSB 0 954 31
X1: EXTSB. 1 954 31 X1: EXTSB. 1 954 31
: FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ; : FMR ( a s -- ) [ 0 ] 2dip 0 72 63 x-insn ;
: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ; : FMR. ( a s -- ) [ 0 ] 2dip 1 72 63 x-insn ;
: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ; : FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ; : FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
@ -189,9 +189,9 @@ MTSPR: LR 8
MTSPR: CTR 9 MTSPR: CTR 9
! Pseudo-instructions ! Pseudo-instructions
: LI ( value dst -- ) 0 rot ADDI ; inline : LI ( value dst -- ) swap [ 0 ] dip ADDI ; inline
: SUBI ( dst src1 src2 -- ) neg ADDI ; inline : SUBI ( dst src1 src2 -- ) neg ADDI ; inline
: LIS ( value dst -- ) 0 rot ADDIS ; inline : LIS ( value dst -- ) swap [ 0 ] dip ADDIS ; inline
: SUBIC ( dst src1 src2 -- ) neg ADDIC ; inline : SUBIC ( dst src1 src2 -- ) neg ADDIC ; inline
: SUBIC. ( dst src1 src2 -- ) neg ADDIC. ; inline : SUBIC. ( dst src1 src2 -- ) neg ADDIC. ; inline
: NOT ( dst src -- ) dup NOR ; inline : NOT ( dst src -- ) dup NOR ; inline
@ -204,6 +204,8 @@ MTSPR: CTR 9
: (SRWI) ( d a b -- d a b x y ) 32 over - swap 31 ; inline : (SRWI) ( d a b -- d a b x y ) 32 over - swap 31 ; inline
: SRWI ( d a b -- ) (SRWI) RLWINM ; : SRWI ( d a b -- ) (SRWI) RLWINM ;
: SRWI. ( d a b -- ) (SRWI) RLWINM. ; : SRWI. ( d a b -- ) (SRWI) RLWINM. ;
: LOAD32 ( n r -- ) [ w>h/h ] dip tuck LIS dup rot ORI ; :: LOAD32 ( n r -- )
n -16 shift HEX: ffff bitand r LIS
r r n HEX: ffff bitand ORI ;
: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ; : immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ; : LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;

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

@ -62,7 +62,7 @@ M: rs-loc loc-reg drop rs-reg ;
M: ppc %peek loc>operand LWZ ; M: ppc %peek loc>operand LWZ ;
M: ppc %replace loc>operand STW ; M: ppc %replace loc>operand STW ;
: (%inc) ( n reg -- ) dup rot cells ADDI ; inline :: (%inc) ( n reg -- ) reg reg n cells ADDI ; inline
M: ppc %inc-d ( n -- ) ds-reg (%inc) ; M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
M: ppc %inc-r ( n -- ) rs-reg (%inc) ; M: ppc %inc-r ( n -- ) rs-reg (%inc) ;

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

@ -208,13 +208,13 @@ M: x86 %unbox-small-struct ( size -- )
{ 2 [ %unbox-struct-2 ] } { 2 [ %unbox-struct-2 ] }
} case ; } case ;
M: x86.32 %unbox-large-struct ( n c-type -- ) M:: x86.32 %unbox-large-struct ( n c-type -- )
! Alien must be in EAX. ! Alien must be in EAX.
! Compute destination address ! Compute destination address
ECX rot stack@ LEA ECX n stack@ LEA
12 [ 12 [
! Push struct size ! Push struct size
heap-size PUSH c-type heap-size PUSH
! Push destination address ! Push destination address
ECX PUSH ECX PUSH
! Push source address ! Push source address
@ -304,6 +304,7 @@ USING: cpu.x86.features cpu.x86.features.private ;
sse2? [ sse2? [
" - yes" print " - yes" print
enable-float-intrinsics enable-float-intrinsics
enable-fsqrt
[ [
sse2? [ sse2? [
"This image was built to use SSE2, which your CPU does not support." print "This image was built to use SSE2, which your CPU does not support." print

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

@ -102,13 +102,12 @@ M: x86.64 %unbox-small-struct ( c-type -- )
flatten-value-type [ %unbox-struct-field ] each-index flatten-value-type [ %unbox-struct-field ] each-index
] with-return-regs ; ] with-return-regs ;
M: x86.64 %unbox-large-struct ( n c-type -- ) M:: x86.64 %unbox-large-struct ( n c-type -- )
! Source is in param-reg-1 ! Source is in param-reg-1
heap-size ! Load destination address into param-reg-2
! Load destination address param-reg-2 n param@ LEA
param-reg-2 rot param@ LEA ! Load structure size into param-reg-3
! Load structure size param-reg-3 c-type heap-size MOV
param-reg-3 swap MOV
! Copy the struct to the C stack ! Copy the struct to the C stack
"to_value_struct" f %alien-invoke ; "to_value_struct" f %alien-invoke ;
@ -204,6 +203,7 @@ enable-alien-4-intrinsics
! SSE2 is always available on x86-64. ! SSE2 is always available on x86-64.
enable-float-intrinsics enable-float-intrinsics
enable-fsqrt
USE: vocabs.loader USE: vocabs.loader

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

@ -203,6 +203,7 @@ M: x86 %add-float nip ADDSD ;
M: x86 %sub-float nip SUBSD ; M: x86 %sub-float nip SUBSD ;
M: x86 %mul-float nip MULSD ; M: x86 %mul-float nip MULSD ;
M: x86 %div-float nip DIVSD ; M: x86 %div-float nip DIVSD ;
M: x86 %sqrt SQRTSD ;
M: x86 %integer>float CVTSI2SD ; M: x86 %integer>float CVTSI2SD ;
M: x86 %float>integer CVTTSD2SI ; M: x86 %float>integer CVTTSD2SI ;

2
basis/io/directories/unix/unix.factor
View File

@ -57,7 +57,7 @@ M: unix find-next-file ( DIR* -- byte-array )
M: unix >directory-entry ( byte-array -- directory-entry ) M: unix >directory-entry ( byte-array -- directory-entry )
{ {
[ dirent-d_name utf8 alien>string ] [ dirent-d_name underlying>> utf8 alien>string ]
[ dirent-d_type dirent-type>file-type ] [ dirent-d_type dirent-type>file-type ]
} cleave directory-entry boa ; } cleave directory-entry boa ;

17
basis/math/libm/libm.factor
View File

@ -5,69 +5,52 @@ IN: math.libm
: facos ( x -- y ) : facos ( x -- y )
"double" "libm" "acos" { "double" } alien-invoke ; "double" "libm" "acos" { "double" } alien-invoke ;
inline
: fasin ( x -- y ) : fasin ( x -- y )
"double" "libm" "asin" { "double" } alien-invoke ; "double" "libm" "asin" { "double" } alien-invoke ;
inline
: fatan ( x -- y ) : fatan ( x -- y )
"double" "libm" "atan" { "double" } alien-invoke ; "double" "libm" "atan" { "double" } alien-invoke ;
inline
: fatan2 ( x y -- z ) : fatan2 ( x y -- z )
"double" "libm" "atan2" { "double" "double" } alien-invoke ; "double" "libm" "atan2" { "double" "double" } alien-invoke ;
inline
: fcos ( x -- y ) : fcos ( x -- y )
"double" "libm" "cos" { "double" } alien-invoke ; "double" "libm" "cos" { "double" } alien-invoke ;
inline
: fsin ( x -- y ) : fsin ( x -- y )
"double" "libm" "sin" { "double" } alien-invoke ; "double" "libm" "sin" { "double" } alien-invoke ;
inline
: ftan ( x -- y ) : ftan ( x -- y )
"double" "libm" "tan" { "double" } alien-invoke ; "double" "libm" "tan" { "double" } alien-invoke ;
inline
: fcosh ( x -- y ) : fcosh ( x -- y )
"double" "libm" "cosh" { "double" } alien-invoke ; "double" "libm" "cosh" { "double" } alien-invoke ;
inline
: fsinh ( x -- y ) : fsinh ( x -- y )
"double" "libm" "sinh" { "double" } alien-invoke ; "double" "libm" "sinh" { "double" } alien-invoke ;
inline
: ftanh ( x -- y ) : ftanh ( x -- y )
"double" "libm" "tanh" { "double" } alien-invoke ; "double" "libm" "tanh" { "double" } alien-invoke ;
inline
: fexp ( x -- y ) : fexp ( x -- y )
"double" "libm" "exp" { "double" } alien-invoke ; "double" "libm" "exp" { "double" } alien-invoke ;
inline
: flog ( x -- y ) : flog ( x -- y )
"double" "libm" "log" { "double" } alien-invoke ; "double" "libm" "log" { "double" } alien-invoke ;
inline
: fpow ( x y -- z ) : fpow ( x y -- z )
"double" "libm" "pow" { "double" "double" } alien-invoke ; "double" "libm" "pow" { "double" "double" } alien-invoke ;
inline
: fsqrt ( x -- y ) : fsqrt ( x -- y )
"double" "libm" "sqrt" { "double" } alien-invoke ; "double" "libm" "sqrt" { "double" } alien-invoke ;
inline
! Windows doesn't have these... ! Windows doesn't have these...
: facosh ( x -- y ) : facosh ( x -- y )
"double" "libm" "acosh" { "double" } alien-invoke ; "double" "libm" "acosh" { "double" } alien-invoke ;
inline
: fasinh ( x -- y ) : fasinh ( x -- y )
"double" "libm" "asinh" { "double" } alien-invoke ; "double" "libm" "asinh" { "double" } alien-invoke ;
inline
: fatanh ( x -- y ) : fatanh ( x -- y )
"double" "libm" "atanh" { "double" } alien-invoke ; "double" "libm" "atanh" { "double" } alien-invoke ;
inline

9
basis/specialized-arrays/direct/functor/functor.factor
View File

@ -8,6 +8,7 @@ IN: specialized-arrays.direct.functor
FUNCTOR: define-direct-array ( T -- ) FUNCTOR: define-direct-array ( T -- )
A' IS ${T}-array A' IS ${T}-array
S IS ${T}-sequence
>A' IS >${T}-array >A' IS >${T}-array
<A'> IS <${A'}> <A'> IS <${A'}>
A'{ IS ${A'}{ A'{ IS ${A'}{
@ -31,6 +32,8 @@ M: A set-nth-unsafe underlying>> SET-NTH call ;
M: A like drop dup A instance? [ >A' ] unless ; M: A like drop dup A instance? [ >A' ] unless ;
M: A new-sequence drop <A'> ; M: A new-sequence drop <A'> ;
M: A byte-length length>> T heap-size * ;
M: A pprint-delims drop \ A'{ \ } ; M: A pprint-delims drop \ A'{ \ } ;
M: A >pprint-sequence ; M: A >pprint-sequence ;
@ -38,5 +41,11 @@ M: A >pprint-sequence ;
M: A pprint* pprint-object ; M: A pprint* pprint-object ;
INSTANCE: A sequence INSTANCE: A sequence
INSTANCE: A S
T c-type
\ A >>direct-array-class
\ <A> >>direct-array-constructor
drop
;FUNCTOR ;FUNCTOR

10
basis/specialized-arrays/functor/functor.factor
View File

@ -16,6 +16,7 @@ M: bad-byte-array-length summary
FUNCTOR: define-array ( T -- ) FUNCTOR: define-array ( T -- )
A DEFINES-CLASS ${T}-array A DEFINES-CLASS ${T}-array
S DEFINES-CLASS ${T}-sequence
<A> DEFINES <${A}> <A> DEFINES <${A}>
(A) DEFINES (${A}) (A) DEFINES (${A})
>A DEFINES >${A} >A DEFINES >${A}
@ -27,6 +28,8 @@ SET-NTH [ T dup c-setter array-accessor ]
WHERE WHERE
MIXIN: S
TUPLE: A TUPLE: A
{ length array-capacity read-only } { length array-capacity read-only }
{ underlying byte-array read-only } ; { underlying byte-array read-only } ;
@ -73,7 +76,14 @@ M: A pprint* pprint-object ;
SYNTAX: A{ \ } [ >A ] parse-literal ; SYNTAX: A{ \ } [ >A ] parse-literal ;
INSTANCE: A sequence INSTANCE: A sequence
INSTANCE: A S
A T c-type-boxed-class specialize-vector-words A T c-type-boxed-class specialize-vector-words
T c-type
\ A >>array-class
\ <A> >>array-constructor
\ S >>sequence-mixin-class
drop
;FUNCTOR ;FUNCTOR

2
basis/specialized-vectors/functor/functor.factor
View File

@ -10,6 +10,7 @@ FUNCTOR: define-vector ( T -- )
V DEFINES-CLASS ${T}-vector V DEFINES-CLASS ${T}-vector
A IS ${T}-array A IS ${T}-array
S IS ${T}-sequence
<A> IS <${A}> <A> IS <${A}>
>V DEFERS >${V} >V DEFERS >${V}
@ -32,5 +33,6 @@ M: V pprint* pprint-object ;
SYNTAX: V{ \ } [ >V ] parse-literal ; SYNTAX: V{ \ } [ >V ] parse-literal ;
INSTANCE: V growable INSTANCE: V growable
INSTANCE: V S
;FUNCTOR ;FUNCTOR

4
basis/windows/ole32/ole32.factor
View File

@ -148,7 +148,7 @@ TUPLE: ole32-error code message ;
[ ] [ ]
} 2cleave } 2cleave
GUID-Data4 8 <direct-uchar-array> { GUID-Data4 {
[ 20 22 0 (guid-byte>guid) ] [ 20 22 0 (guid-byte>guid) ]
[ 22 24 1 (guid-byte>guid) ] [ 22 24 1 (guid-byte>guid) ]
@ -175,7 +175,7 @@ TUPLE: ole32-error code message ;
[ [ GUID-Data3 ] 4 (guid-section%) "-" % ] [ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
[ ] [ ]
} cleave } cleave
GUID-Data4 8 <direct-uchar-array> { GUID-Data4 {
[ 0 (guid-byte%) ] [ 0 (guid-byte%) ]
[ 1 (guid-byte%) "-" % ] [ 1 (guid-byte%) "-" % ]
[ 2 (guid-byte%) ] [ 2 (guid-byte%) ]

3
core/alien/strings/strings.factor
View File

@ -12,6 +12,9 @@ M: c-ptr alien>string
[ <memory-stream> ] [ <decoder> ] bi* [ <memory-stream> ] [ <decoder> ] bi*
"\0" swap stream-read-until drop ; "\0" swap stream-read-until drop ;
M: object alien>string
[ underlying>> ] dip alien>string ;
M: f alien>string M: f alien>string
drop ; drop ;

2
extra/benchmark/raytracer/raytracer.factor
View File

@ -155,7 +155,7 @@ DEFER: create ( level c r -- scene )
] with map ; ] with map ;
: ray-pixel ( scene point -- n ) : ray-pixel ( scene point -- n )
ss-grid ray-grid 0.0 -rot ss-grid ray-grid [ 0.0 ] 2dip
[ [ swap cast-ray + ] with each ] with each ; [ [ swap cast-ray + ] with each ] with each ;
: pixel-grid ( -- grid ) : pixel-grid ( -- grid )

23
extra/classes/struct/struct-tests.factor
View File

@ -1,9 +1,10 @@
! (c)Joe Groff bsd license ! (c)Joe Groff bsd license
USING: accessors alien.c-types alien.libraries USING: accessors alien.c-types alien.libraries
alien.structs.fields alien.syntax classes.struct combinators alien.structs.fields alien.syntax ascii classes.struct combinators
destructors io.pathnames io.streams.string kernel libc literals math destructors io.encodings.utf8 io.pathnames io.streams.string
multiline namespaces prettyprint prettyprint.config see system kernel libc literals math multiline namespaces prettyprint
tools.test ; prettyprint.config see sequences specialized-arrays.ushort
system tools.test ;
IN: classes.struct.tests IN: classes.struct.tests
<< <<
@ -30,6 +31,7 @@ STRUCT: struct-test-bar
{ foo struct-test-foo } ; { foo struct-test-foo } ;
[ 12 ] [ struct-test-foo heap-size ] unit-test [ 12 ] [ struct-test-foo heap-size ] unit-test
[ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
[ 16 ] [ struct-test-bar heap-size ] unit-test [ 16 ] [ struct-test-bar heap-size ] unit-test
[ 123 ] [ struct-test-foo <struct> y>> ] unit-test [ 123 ] [ struct-test-foo <struct> y>> ] unit-test
[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test [ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
@ -144,3 +146,16 @@ LIBRARY: f-cdecl
FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ; FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
[ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test [ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
STRUCT: struct-test-array-slots
{ x int }
{ y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
{ z int } ;
[ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
[ t ] [
struct-test-array-slots <struct>
[ y>> [ 8 3 ] dip set-nth ]
[ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
] unit-test

12
extra/classes/struct/struct.factor
View File

@ -94,6 +94,10 @@ M: struct-class writer-quot
[ \ struct-slot-values create-method-in ] [ \ struct-slot-values create-method-in ]
[ struct-slot-values-quot ] bi define ; [ struct-slot-values-quot ] bi define ;
: (define-byte-length-method) ( class -- )
[ \ byte-length create-method-in ]
[ heap-size \ drop swap [ ] 2sequence ] bi define ;
! Struct as c-type ! Struct as c-type
: slot>field ( slot -- field ) : slot>field ( slot -- field )
@ -113,7 +117,7 @@ M: struct-class writer-quot
[ "struct-align" word-prop ] [ "struct-align" word-prop ]
[ struct-slots [ slot>field ] map ] [ struct-slots [ slot>field ] map ]
} cleave } cleave
(define-struct) struct-type (define-struct)
] [ ] [
{ {
[ name>> c-type ] [ name>> c-type ]
@ -172,6 +176,10 @@ M: struct-class heap-size
over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
] each ; ] each ;
: (struct-methods) ( class -- )
[ (define-struct-slot-values-method) ]
[ (define-byte-length-method) ] bi ;
: (struct-word-props) ( class slots size align -- ) : (struct-word-props) ( class slots size align -- )
[ [
[ "struct-slots" set-word-prop ] [ "struct-slots" set-word-prop ]
@ -181,7 +189,7 @@ M: struct-class heap-size
[ "struct-align" set-word-prop ] tri-curry* [ "struct-align" set-word-prop ] tri-curry*
[ tri ] 3curry [ tri ] 3curry
[ dup struct-prototype "prototype" set-word-prop ] [ dup struct-prototype "prototype" set-word-prop ]
[ (define-struct-slot-values-method) ] tri ; [ (struct-methods) ] tri ;
: check-struct-slots ( slots -- ) : check-struct-slots ( slots -- )
[ c-type>> c-type drop ] each ; [ c-type>> c-type drop ] each ;