ARTICLE: "c-arrays" "C arrays"\r
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."\r
$nl\r
-"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ;\r
+"C type specifiers for array types are documented in " { $link "c-types-specs" } "."\r
+$nl\r
+"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:"\r
+{ $subsection require-c-type-arrays }\r
+{ $subsection <c-type-array> }\r
+{ $subsection <c-type-direct-array> } ;\r
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 ] ;
IN: alien.c-types
USING: alien help.syntax help.markup libc kernel.private
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>
{ $values { "type" hashtable } }
}
} ;
+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"
"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
cpu.architecture alien alien.accessors alien.strings quotations
layouts system compiler.units io io.files io.encodings.binary
io.streams.memory accessors combinators effects continuations fry
-classes ;
+classes vocabs vocabs.loader ;
IN: alien.c-types
DEFER: <int>
{ getter callable }
{ setter callable }
size
-align ;
+align
+array-class
+array-constructor
+direct-array-class
+direct-array-constructor
+sequence-mixin-class ;
TUPLE: c-type < abstract-c-type
boxer
] ?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 )
M: abstract-c-type c-type-class class>> ;
GENERIC: byte-length ( seq -- n ) flushable
-M: byte-array byte-length length ;
+M: byte-array byte-length length ; inline
-M: f byte-length drop 0 ;
+M: f byte-length drop 0 ; inline
: c-getter ( name -- quot )
c-type-getter [
] [ [ + ] change-index drop ] 2bi ;
: byte-array>memory ( byte-array base -- )
- swap dup byte-length memcpy ;
+ swap dup byte-length memcpy ; inline
: array-accessor ( type quot -- def )
[
: if-void ( type true false -- )
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
{
"char" "uchar"
[ >c-ptr ] >>unboxer-quot
"box_alien" >>boxer
"alien_offset" >>unboxer
+ "alien" "void*" set-array-class*
"void*" define-primitive-type
<long-long-type>
8 >>align
"box_signed_8" >>boxer
"to_signed_8" >>unboxer
+ "longlong" set-array-class
"longlong" define-primitive-type
<long-long-type>
8 >>align
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
+ "ulonglong" set-array-class
"ulonglong" define-primitive-type
<c-type>
bootstrap-cell >>align
"box_signed_cell" >>boxer
"to_fixnum" >>unboxer
+ "long" set-array-class
"long" define-primitive-type
<c-type>
bootstrap-cell >>align
"box_unsigned_cell" >>boxer
"to_cell" >>unboxer
+ "ulong" set-array-class
"ulong" define-primitive-type
<c-type>
4 >>align
"box_signed_4" >>boxer
"to_fixnum" >>unboxer
+ "int" set-array-class
"int" define-primitive-type
<c-type>
4 >>align
"box_unsigned_4" >>boxer
"to_cell" >>unboxer
+ "uint" set-array-class
"uint" define-primitive-type
<c-type>
2 >>align
"box_signed_2" >>boxer
"to_fixnum" >>unboxer
+ "short" set-array-class
"short" define-primitive-type
<c-type>
2 >>align
"box_unsigned_2" >>boxer
"to_cell" >>unboxer
+ "ushort" set-array-class
"ushort" define-primitive-type
<c-type>
1 >>align
"box_signed_1" >>boxer
"to_fixnum" >>unboxer
+ "char" set-array-class
"char" define-primitive-type
<c-type>
1 >>align
"box_unsigned_1" >>boxer
"to_cell" >>unboxer
+ "uchar" set-array-class
"uchar" define-primitive-type
<c-type>
1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
+ "bool" set-array-class
"bool" define-primitive-type
<c-type>
"to_float" >>unboxer
single-float-rep >>rep
[ >float ] >>unboxer-quot
+ "float" set-array-class
"float" define-primitive-type
<c-type>
"to_double" >>unboxer
double-float-rep >>rep
[ >float ] >>unboxer-quot
+ "double" set-array-class
"double" define-primitive-type
"long" "ptrdiff_t" typedef
"long" "intptr_t" typedef
"ulong" "size_t" typedef
] with-compilation-unit
+
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
number >>boxed-class
+T set-array-class
drop
;FUNCTOR
: c-struct? ( type -- ? ) (c-type) struct-type? ;
-: (define-struct) ( name size align fields -- )
- [ [ align ] keep ] dip
- struct-type new
+: (define-struct) ( name size align fields class -- )
+ [ [ align ] keep ] 2dip new
byte-array >>class
byte-array >>boxed-class
swap >>fields
[ 2drop ] [ make-fields ] 3bi
[ struct-offsets ] keep
[ [ type>> ] map compute-struct-align ] keep
- [ (define-struct) ] keep
+ [ struct-type (define-struct) ] keep
[ define-field ] each ;
: define-union ( name members -- )
[ expand-constants ] map
[ [ 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 )
c-types get at fields>>
[ name>> = ] with find nip offset>> ;
+
+USE: vocabs.loader
+"struct-arrays" require
bit-array boa
dup clean-up ; inline
-M: bit-array byte-length length 7 + -3 shift ;
+M: bit-array byte-length length 7 + -3 shift ; inline
SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors assocs classes classes.struct combinators
+kernel math prettyprint.backend prettyprint.custom
+prettyprint.sections see.private sequences words ;
+IN: classes.struct.prettyprint
+
+<PRIVATE
+
+: struct-definer-word ( class -- word )
+ struct-slots dup length 2 >=
+ [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
+ [ drop \ STRUCT: ] if ;
+
+: struct>assoc ( struct -- assoc )
+ [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
+
+: pprint-struct-slot ( slot -- )
+ <flow \ { pprint-word
+ {
+ [ name>> text ]
+ [ c-type>> text ]
+ [ read-only>> [ \ read-only pprint-word ] when ]
+ [ initial>> [ \ initial: pprint-word pprint* ] when* ]
+ } cleave
+ \ } pprint-word block> ;
+
+PRIVATE>
+
+M: struct-class see-class*
+ <colon dup struct-definer-word pprint-word dup pprint-word
+ <block struct-slots [ pprint-struct-slot ] each
+ block> pprint-; block> ;
+
+M: struct pprint-delims
+ drop \ S{ \ } ;
+
+M: struct >pprint-sequence
+ [ class ] [ struct-slot-values ] bi class-slot-sequence ;
+
+M: struct pprint*
+ [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
--- /dev/null
+! (c)Joe Groff bsd license
+USING: alien classes help.markup help.syntax kernel libc
+quotations slots ;
+IN: classes.struct
+
+HELP: <struct-boa>
+{ $values
+ { "class" class }
+}
+{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
+
+HELP: <struct>
+{ $values
+ { "class" class }
+ { "struct" struct }
+}
+{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ;
+
+{ <struct> <struct-boa> malloc-struct memory>struct } related-words
+
+HELP: STRUCT:
+{ $syntax "STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:"
+{ $list
+{ "Struct classes cannot have a superclass defined." }
+{ "The slots of a struct must all have a type declared. The type must be a C type." }
+{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
+} } ;
+
+HELP: S{
+{ $syntax "S{ class slots... }" }
+{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
+{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
+
+HELP: UNION-STRUCT:
+{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
+
+HELP: define-struct-class
+{ $values
+ { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
+
+HELP: define-union-struct-class
+{ $values
+ { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ;
+
+HELP: malloc-struct
+{ $values
+ { "class" class }
+ { "struct" struct }
+}
+{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ;
+
+HELP: memory>struct
+{ $values
+ { "ptr" c-ptr } { "class" class }
+ { "struct" struct }
+}
+{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
+
+HELP: struct
+{ $class-description "The parent class of all struct types." } ;
+
+{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words
+
+HELP: struct-class
+{ $class-description "The metaclass of all " { $link struct } " classes." } ;
+
+ARTICLE: "classes.struct" "Struct classes"
+{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
+{ $subsection POSTPONE: STRUCT: }
+"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
+{ $subsection <struct> }
+{ $subsection <struct-boa> }
+{ $subsection malloc-struct }
+{ $subsection memory>struct }
+"Structs have literal syntax like tuples:"
+{ $subsection POSTPONE: S{ }
+"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
+{ $subsection POSTPONE: UNION-STRUCT: }
+;
+
+ABOUT: "classes.struct"
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors alien.c-types alien.libraries
+alien.structs.fields alien.syntax ascii classes.struct combinators
+destructors io.encodings.utf8 io.pathnames io.streams.string
+kernel libc literals math multiline namespaces prettyprint
+prettyprint.config see sequences specialized-arrays.ushort
+system tools.test compiler.tree.debugger struct-arrays
+classes.tuple.private specialized-arrays.direct.int
+compiler.units ;
+IN: classes.struct.tests
+
+<<
+: libfactor-ffi-tests-path ( -- string )
+ "resource:" (normalize-path)
+ {
+ { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
+ { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
+ { [ os unix? ] [ "libfactor-ffi-test.so" ] }
+ } cond append-path ;
+
+"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
+
+"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
+>>
+
+SYMBOL: struct-test-empty
+
+[ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
+[ struct-must-have-slots? ] must-fail-with
+
+STRUCT: struct-test-foo
+ { x char }
+ { y int initial: 123 }
+ { z bool } ;
+
+STRUCT: struct-test-bar
+ { w ushort initial: HEX: ffff }
+ { foo struct-test-foo } ;
+
+[ 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
+[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
+[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
+
+[ 1 2 3 t ] [
+ 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
+ {
+ [ w>> ]
+ [ foo>> x>> ]
+ [ foo>> y>> ]
+ [ foo>> z>> ]
+ } cleave
+] unit-test
+
+[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
+[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
+
+UNION-STRUCT: struct-test-float-and-bits
+ { f float }
+ { bits uint } ;
+
+[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
+[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
+
+[ ] [ [ struct-test-foo malloc-struct &free drop ] with-destructors ] unit-test
+
+STRUCT: struct-test-string-ptr
+ { x char* } ;
+
+[ "hello world" ] [
+ [
+ struct-test-string-ptr <struct>
+ "hello world" utf8 malloc-string &free >>x
+ x>>
+ ] with-destructors
+] unit-test
+
+[ "S{ struct-test-foo { y 7654 } }" ]
+[
+ f boa-tuples?
+ [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+ with-variable
+] unit-test
+
+[ "S{ struct-test-foo f 0 7654 f }" ]
+[
+ t boa-tuples?
+ [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+ with-variable
+] unit-test
+
+[ <" USING: classes.struct ;
+IN: classes.struct.tests
+STRUCT: struct-test-foo
+ { x char initial: 0 } { y int initial: 123 } { z bool } ;
+"> ]
+[ [ struct-test-foo see ] with-string-writer ] unit-test
+
+[ <" USING: classes.struct ;
+IN: classes.struct.tests
+UNION-STRUCT: struct-test-float-and-bits
+ { f float initial: 0.0 } { bits uint initial: 0 } ;
+"> ]
+[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
+
+[ {
+ T{ field-spec
+ { name "x" }
+ { offset 0 }
+ { type "char" }
+ { reader x>> }
+ { writer (>>x) }
+ }
+ T{ field-spec
+ { name "y" }
+ { offset 4 }
+ { type "int" }
+ { reader y>> }
+ { writer (>>y) }
+ }
+ T{ field-spec
+ { name "z" }
+ { offset 8 }
+ { type "bool" }
+ { reader z>> }
+ { writer (>>z) }
+ }
+} ] [ "struct-test-foo" c-type fields>> ] unit-test
+
+[ {
+ T{ field-spec
+ { name "f" }
+ { offset 0 }
+ { type "float" }
+ { reader f>> }
+ { writer (>>f) }
+ }
+ T{ field-spec
+ { name "bits" }
+ { offset 0 }
+ { type "uint" }
+ { reader bits>> }
+ { writer (>>bits) }
+ }
+} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
+
+STRUCT: struct-test-equality-1
+ { x int } ;
+STRUCT: struct-test-equality-2
+ { y int } ;
+
+[ t ] [
+ [
+ struct-test-equality-1 <struct> 5 >>x
+ struct-test-equality-1 malloc-struct &free 5 >>x =
+ ] with-destructors
+] unit-test
+
+[ f ] [
+ [
+ struct-test-equality-1 <struct> 5 >>x
+ struct-test-equality-2 malloc-struct &free 5 >>y =
+ ] with-destructors
+] unit-test
+
+STRUCT: struct-test-ffi-foo
+ { x int }
+ { y int } ;
+
+LIBRARY: f-cdecl
+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
+
+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
+
+STRUCT: struct-test-optimization
+ { x int[3] } { y int } ;
+
+[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+[ t ] [
+ [ 3 struct-test-optimization <direct-struct-array> third y>> ]
+ { <tuple> <tuple-boa> memory>struct y>> } inlined?
+] unit-test
+
+[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+
+[ t ] [
+ [ struct-test-optimization memory>struct x>> second ]
+ { memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
+] unit-test
+
+[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors alien alien.c-types alien.structs
+alien.structs.fields arrays byte-arrays classes classes.parser
+classes.tuple classes.tuple.parser classes.tuple.private
+combinators combinators.short-circuit combinators.smart fry
+generalizations generic.parser kernel kernel.private lexer
+libc macros make math math.order parser quotations sequences
+slots slots.private struct-arrays vectors words
+compiler.tree.propagation.transforms ;
+FROM: slots => reader-word writer-word ;
+IN: classes.struct
+
+! struct class
+
+ERROR: struct-must-have-slots ;
+
+TUPLE: struct
+ { (underlying) c-ptr read-only } ;
+
+TUPLE: struct-slot-spec < slot-spec
+ c-type ;
+
+PREDICATE: struct-class < tuple-class
+ { [ \ struct subclass-of? ] [ all-slots length 1 = ] } 1&& ;
+
+: struct-slots ( struct -- slots )
+ "struct-slots" word-prop ;
+
+! struct allocation
+
+M: struct >c-ptr
+ 2 slot { c-ptr } declare ; inline
+
+M: struct equal?
+ {
+ [ [ class ] bi@ = ]
+ [ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
+ } 2&& ;
+
+: memory>struct ( ptr class -- struct )
+ [ 1array ] dip slots>tuple ;
+
+\ memory>struct [
+ dup struct-class? [ '[ _ boa ] ] [ drop f ] if
+] 1 define-partial-eval
+
+: malloc-struct ( class -- struct )
+ [ heap-size malloc ] keep memory>struct ; inline
+
+: (struct) ( class -- struct )
+ [ heap-size <byte-array> ] keep memory>struct ; inline
+
+: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
+
+: <struct> ( class -- struct )
+ dup struct-prototype
+ [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
+
+MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
+ [
+ [ <wrapper> \ (struct) [ ] 2sequence ]
+ [
+ struct-slots
+ [ length \ ndip ]
+ [ [ name>> setter-word 1quotation ] map \ spread ] bi
+ ] bi
+ ] [ ] output>sequence ;
+
+: pad-struct-slots ( values class -- values' class )
+ [ struct-slots [ initial>> ] map over length tail append ] keep ;
+
+: (reader-quot) ( slot -- quot )
+ [ c-type>> c-type-getter-boxer ]
+ [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (writer-quot) ( slot -- quot )
+ [ c-type>> c-setter ]
+ [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (boxer-quot) ( class -- quot )
+ '[ _ memory>struct ] ;
+
+: (unboxer-quot) ( class -- quot )
+ drop [ >c-ptr ] ;
+
+M: struct-class boa>object
+ swap pad-struct-slots
+ [ (struct) ] [ struct-slots ] bi
+ [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
+
+! Struct slot accessors
+
+GENERIC: struct-slot-values ( struct -- sequence )
+
+M: struct-class reader-quot
+ nip (reader-quot) ;
+
+M: struct-class writer-quot
+ nip (writer-quot) ;
+
+: struct-slot-values-quot ( class -- quot )
+ struct-slots
+ [ name>> reader-word 1quotation ] map
+ \ cleave [ ] 2sequence
+ \ output>array [ ] 2sequence ;
+
+: (define-struct-slot-values-method) ( class -- )
+ [ \ struct-slot-values create-method-in ]
+ [ 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
+
+: slot>field ( slot -- field )
+ field-spec new swap {
+ [ name>> >>name ]
+ [ offset>> >>offset ]
+ [ c-type>> >>type ]
+ [ name>> reader-word >>reader ]
+ [ name>> writer-word >>writer ]
+ } cleave ;
+
+: define-struct-for-class ( class -- )
+ [
+ {
+ [ name>> ]
+ [ "struct-size" word-prop ]
+ [ "struct-align" word-prop ]
+ [ struct-slots [ slot>field ] map ]
+ } cleave
+ struct-type (define-struct)
+ ] [
+ {
+ [ name>> c-type ]
+ [ (unboxer-quot) >>unboxer-quot ]
+ [ (boxer-quot) >>boxer-quot ]
+ [ >>boxed-class ]
+ } cleave drop
+ ] bi ;
+
+: align-offset ( offset class -- offset' )
+ c-type-align align ;
+
+: struct-offsets ( slots -- size )
+ 0 [
+ [ c-type>> align-offset ] keep
+ [ (>>offset) ] [ c-type>> heap-size + ] 2bi
+ ] reduce ;
+
+: union-struct-offsets ( slots -- size )
+ [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ;
+
+: struct-align ( slots -- align )
+ [ c-type>> c-type-align ] [ max ] map-reduce ;
+
+M: struct-class c-type
+ name>> c-type ;
+
+M: struct-class c-type-align
+ "struct-align" word-prop ;
+
+M: struct-class c-type-getter
+ drop [ swap <displaced-alien> ] ;
+
+M: struct-class c-type-setter
+ [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
+ '[ @ swap @ _ memcpy ] ;
+
+M: struct-class c-type-boxer-quot
+ (boxer-quot) ;
+
+M: struct-class c-type-unboxer-quot
+ (unboxer-quot) ;
+
+M: struct-class heap-size
+ "struct-size" word-prop ;
+
+! class definition
+
+: make-struct-prototype ( class -- prototype )
+ [ heap-size <byte-array> ]
+ [ memory>struct ]
+ [ struct-slots ] tri
+ [
+ [ initial>> ]
+ [ (writer-quot) ] bi
+ over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
+ ] each ;
+
+: (struct-methods) ( class -- )
+ [ (define-struct-slot-values-method) ]
+ [ (define-byte-length-method) ] bi ;
+
+: (struct-word-props) ( class slots size align -- )
+ [
+ [ "struct-slots" set-word-prop ]
+ [ define-accessors ] 2bi
+ ]
+ [ "struct-size" set-word-prop ]
+ [ "struct-align" set-word-prop ] tri-curry*
+ [ tri ] 3curry
+ [ dup make-struct-prototype "prototype" set-word-prop ]
+ [ (struct-methods) ] tri ;
+
+: check-struct-slots ( slots -- )
+ [ c-type>> c-type drop ] each ;
+
+: (define-struct-class) ( class slots offsets-quot -- )
+ [
+ [ struct-must-have-slots ]
+ [ drop struct f define-tuple-class ] if-empty
+ ]
+ swap '[
+ make-slots dup
+ [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
+ (struct-word-props)
+ ]
+ [ drop define-struct-for-class ] 2tri ; inline
+
+: define-struct-class ( class slots -- )
+ [ struct-offsets ] (define-struct-class) ;
+
+: define-union-struct-class ( class slots -- )
+ [ union-struct-offsets ] (define-struct-class) ;
+
+ERROR: invalid-struct-slot token ;
+
+: struct-slot-class ( c-type -- class' )
+ c-type c-type-boxed-class
+ dup \ byte-array = [ drop \ c-ptr ] when ;
+
+: parse-struct-slot ( -- slot )
+ struct-slot-spec new
+ scan >>name
+ scan [ >>c-type ] [ struct-slot-class >>class ] bi
+ \ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ;
+
+: parse-struct-slots ( slots -- slots' more? )
+ scan {
+ { ";" [ f ] }
+ { "{" [ parse-struct-slot over push t ] }
+ [ invalid-struct-slot ]
+ } case ;
+
+: parse-struct-definition ( -- class slots )
+ CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
+
+SYNTAX: STRUCT:
+ parse-struct-definition define-struct-class ;
+SYNTAX: UNION-STRUCT:
+ parse-struct-definition define-union-struct-class ;
+
+SYNTAX: S{
+ scan-word dup struct-slots parse-tuple-literal-slots parsed ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
: NSApp ( -- app ) NSApplication -> sharedApplication ;
-: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
+CONSTANT: NSAnyEventMask HEX: ffffffff
FUNCTION: void NSBeep ( ) ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry generalizations kernel macros math.order
-stack-checker math ;
+stack-checker math sequences ;
IN: combinators.smart
MACRO: drop-outputs ( quot -- quot' )
MACRO: append-outputs ( quot -- seq )
'[ _ { } append-outputs-as ] ;
+
+MACRO: preserving ( quot -- )
+ [ infer in>> length ] keep '[ _ ndup @ ] ;
+
+MACRO: smart-if ( pred true false -- )
+ '[ _ preserving _ _ if ] ; inline
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io vectors
-classes.tuple accessors prettyprint prettyprint.config assocs
-prettyprint.backend prettyprint.custom prettyprint.sections
-parser compiler.tree.builder compiler.tree.optimizer
-cpu.architecture compiler.cfg.builder compiler.cfg.linearization
-compiler.cfg.registers compiler.cfg.stack-frame
-compiler.cfg.linear-scan compiler.cfg.two-operand
-compiler.cfg.optimizer compiler.cfg.instructions
-compiler.cfg.utilities compiler.cfg.def-use
-compiler.cfg.rpo compiler.cfg.mr compiler.cfg ;
+arrays hashtables classes.tuple accessors prettyprint
+prettyprint.config assocs prettyprint.backend prettyprint.custom
+prettyprint.sections parser compiler.tree.builder
+compiler.tree.optimizer cpu.architecture compiler.cfg.builder
+compiler.cfg.linearization compiler.cfg.registers
+compiler.cfg.stack-frame compiler.cfg.linear-scan
+compiler.cfg.two-operand compiler.cfg.optimizer
+compiler.cfg.instructions compiler.cfg.utilities
+compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
+compiler.cfg.representations.preferred compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
: fake-representations ( cfg -- )
post-order [
- instructions>>
- [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ]
- map concat
- ] map concat
- [ int-rep ] H{ } map>assoc representations set ;
\ No newline at end of file
+ instructions>> [
+ [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
+ [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ]
+ bi [ suffix ] when*
+ ] map concat
+ ] map concat >hashtable representations set ;
\ No newline at end of file
M: ##set-slot temp-vregs temp>> 1array ;
M: ##string-nth temp-vregs temp>> 1array ;
M: ##set-string-nth-fast temp-vregs temp>> 1array ;
+M: ##box-displaced-alien temp-vregs temp>> 1array ;
M: ##compare temp-vregs temp>> 1array ;
M: ##compare-imm temp-vregs temp>> 1array ;
M: ##compare-float temp-vregs temp>> 1array ;
: ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline
: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-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
: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
: ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
+: ^^box-displaced-alien ( base displacement -- dst ) ^^r2 next-vreg ##box-displaced-alien ; inline
: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
INSN: ##sub-float < ##binary ;
INSN: ##mul-float < ##commutative ;
INSN: ##div-float < ##binary ;
+INSN: ##sqrt < ##unary ;
! Float/integer conversion
INSN: ##float>integer < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary/temp ;
INSN: ##box-float < ##unary/temp ;
INSN: ##box-alien < ##unary/temp ;
+INSN: ##box-displaced-alien < ##binary temp ;
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
! Memory allocation
INSN: ##allot < ##flushable size class temp ;
-UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
+UNION: ##allocation
+##allot
+##box-float
+##box-alien
+##box-displaced-alien
+##integer>bignum ;
INSN: ##write-barrier < ##effect card# table ;
##sub-float
##mul-float
##div-float
+ ##sqrt
##integer>float
##unbox-float
##alien-float
##sub-float
##mul-float
##div-float
+ ##sqrt
##float>integer
##box-float
##set-alien-float
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences alien math classes.algebra fry
-locals combinators cpu.architecture compiler.tree.propagation.info
-compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
+locals combinators combinators.short-circuit cpu.architecture
+compiler.tree.propagation.info compiler.cfg.hats
+compiler.cfg.stacks compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.alien
+: emit-<displaced-alien>? ( node -- ? )
+ node-input-infos {
+ [ first class>> fixnum class<= ]
+ [ second class>> c-ptr class<= ]
+ } 1&& ;
+
+: emit-<displaced-alien> ( node -- )
+ dup emit-<displaced-alien>?
+ [ drop 2inputs [ ^^untag-fixnum ] dip ^^box-displaced-alien ds-push ]
+ [ emit-primitive ]
+ if ;
+
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
: emit-fixnum>float ( -- )
ds-pop ^^untag-fixnum ^^integer>float ds-push ;
+
+: emit-fsqrt ( -- )
+ ds-pop ^^sqrt ds-push ;
compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
+QUALIFIED: alien
+QUALIFIED: alien.accessors
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
QUALIFIED: classes.tuple.private
QUALIFIED: math.private
QUALIFIED: math.integers.private
-QUALIFIED: alien.accessors
+QUALIFIED: math.libm
IN: compiler.cfg.intrinsics
{
byte-arrays:<byte-array>
byte-arrays:(byte-array)
kernel:<wrapper>
+ alien:<displaced-alien>
alien.accessors:alien-unsigned-1
alien.accessors:set-alien-unsigned-1
alien.accessors:alien-signed-1
alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ;
+: enable-fsqrt ( -- )
+ \ math.libm:fsqrt t "intrinsic" set-word-prop ;
+
: enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
{ \ math.private:float= [ drop cc= emit-float-comparison ] }
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
+ { \ math.libm:fsqrt [ drop emit-fsqrt ] }
{ \ slots.private:slot [ emit-slot ] }
{ \ slots.private:set-slot [ emit-set-slot ] }
{ \ strings.private:string-nth [ drop emit-string-nth ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
{ \ byte-arrays:(byte-array) [ emit-(byte-array) ] }
{ \ kernel:<wrapper> [ emit-simple-allot ] }
+ { \ alien:<displaced-alien> [ emit-<displaced-alien> ] }
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
T{ ##copy
{ dst 689481 }
{ src 689475 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689482 }
{ src 689474 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689483 }
{ src 689473 }
+ { rep int-rep }
}
T{ ##branch }
} 2 test-bb
T{ ##copy
{ dst 689481 }
{ src 689473 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689482 }
{ src 689475 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689483 }
{ src 689474 }
+ { rep int-rep }
}
T{ ##branch }
} 3 test-bb
T{ ##copy
{ dst 689608 }
{ src 689600 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689610 }
{ src 689601 }
+ { rep int-rep }
}
T{ ##branch }
} 2 test-bb
T{ ##copy
{ dst 689607 }
{ src 689600 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689608 }
{ src 689601 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689610 }
{ src 689609 }
+ { rep int-rep }
}
T{ ##branch }
} 3 test-bb
T{ ##copy
{ dst 2 }
{ src 1 }
+ { rep int-rep }
}
T{ ##branch }
} 2 test-bb
T{ ##copy
{ dst 2 }
{ src 3 }
+ { rep int-rep }
}
T{ ##branch }
} 3 test-bb
{ slot 1 }
{ tag 2 }
}
- T{ ##copy { dst 79 } { src 69 } }
+ T{ ##copy { dst 79 } { src 69 } { rep int-rep } }
T{ ##slot-imm
{ dst 85 }
{ obj 62 }
T{ ##peek { dst 114 } { loc D 1 } }
T{ ##peek { dst 116 } { loc D 4 } }
T{ ##peek { dst 119 } { loc R 0 } }
- T{ ##copy { dst 109 } { src 108 } }
- T{ ##copy { dst 111 } { src 110 } }
- T{ ##copy { dst 113 } { src 112 } }
- T{ ##copy { dst 115 } { src 114 } }
- T{ ##copy { dst 117 } { src 116 } }
- T{ ##copy { dst 120 } { src 119 } }
+ T{ ##copy { dst 109 } { src 108 } { rep int-rep } }
+ T{ ##copy { dst 111 } { src 110 } { rep int-rep } }
+ T{ ##copy { dst 113 } { src 112 } { rep int-rep } }
+ T{ ##copy { dst 115 } { src 114 } { rep int-rep } }
+ T{ ##copy { dst 117 } { src 116 } { rep int-rep } }
+ T{ ##copy { dst 120 } { src 119 } { rep int-rep } }
T{ ##branch }
} 3 test-bb
V{
- T{ ##copy { dst 109 } { src 62 } }
- T{ ##copy { dst 111 } { src 61 } }
- T{ ##copy { dst 113 } { src 62 } }
- T{ ##copy { dst 115 } { src 79 } }
- T{ ##copy { dst 117 } { src 64 } }
- T{ ##copy { dst 120 } { src 69 } }
+ T{ ##copy { dst 109 } { src 62 } { rep int-rep } }
+ T{ ##copy { dst 111 } { src 61 } { rep int-rep } }
+ T{ ##copy { dst 113 } { src 62 } { rep int-rep } }
+ T{ ##copy { dst 115 } { src 79 } { rep int-rep } }
+ T{ ##copy { dst 117 } { src 64 } { rep int-rep } }
+ T{ ##copy { dst 120 } { src 69 } { rep int-rep } }
T{ ##branch }
} 4 test-bb
T{ ##peek { dst 162 } { loc D 1 } }
T{ ##peek { dst 164 } { loc D 4 } }
T{ ##peek { dst 167 } { loc R 0 } }
- T{ ##copy { dst 157 } { src 156 } }
- T{ ##copy { dst 159 } { src 158 } }
- T{ ##copy { dst 161 } { src 160 } }
- T{ ##copy { dst 163 } { src 162 } }
- T{ ##copy { dst 165 } { src 164 } }
- T{ ##copy { dst 168 } { src 167 } }
+ T{ ##copy { dst 157 } { src 156 } { rep int-rep } }
+ T{ ##copy { dst 159 } { src 158 } { rep int-rep } }
+ T{ ##copy { dst 161 } { src 160 } { rep int-rep } }
+ T{ ##copy { dst 163 } { src 162 } { rep int-rep } }
+ T{ ##copy { dst 165 } { src 164 } { rep int-rep } }
+ T{ ##copy { dst 168 } { src 167 } { rep int-rep } }
T{ ##branch }
} 4 test-bb
M: ##set-string-nth-fast rename-insn-temps
TEMP-QUOT change-temp drop ;
+M: ##box-displaced-alien rename-insn-temps
+ TEMP-QUOT change-temp drop ;
+
M: ##compare rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##set-slot temp-vreg-reps drop { int-rep } ;
M: ##string-nth temp-vreg-reps drop { int-rep } ;
M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
+M: ##box-displaced-alien temp-vreg-reps drop { int-rep } ;
M: ##compare temp-vreg-reps drop { int-rep } ;
M: ##compare-imm temp-vreg-reps drop { int-rep } ;
M: ##compare-float temp-vreg-reps drop { int-rep } ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise math.order classes vectors
+math.bitwise math.order classes vectors locals make
compiler.cfg
compiler.cfg.registers
compiler.cfg.comparisons
M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ;
M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
+
+: box-displaced-alien? ( expr -- ? )
+ op>> \ ##box-displaced-alien eq? ;
+
+! ##box-displaced-alien f 1 2 3
+! ##unbox-any-c-ptr 4 1
+! =>
+! ##box-displaced-alien f 1 2 3
+! ##unbox-any-c-ptr 5 3
+! ##add 4 5 2
+
+:: rewrite-unbox-displaced-alien ( insn expr -- insns )
+ [
+ next-vreg :> temp
+ temp expr in2>> vn>vreg insn temp>> ##unbox-any-c-ptr
+ insn dst>> temp expr in1>> vn>vreg ##add
+ ] { } make ;
+
+M: ##unbox-any-c-ptr rewrite
+ dup src>> vreg>expr dup box-displaced-alien?
+ [ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
[ 2drop f ]
} cond ; inline
+: simplify-box-displaced-alien ( expr -- vn/expr/f )
+ >binary-expr< {
+ { [ over expr-zero? ] [ nip ] }
+ [ 2drop f ]
+ } cond ;
+
M: binary-expr simplify*
dup op>> {
{ \ ##add [ simplify-add ] }
{ \ ##sar-imm [ simplify-shr ] }
{ \ ##shl [ simplify-shl ] }
{ \ ##shl-imm [ simplify-shl ] }
+ { \ ##box-displaced-alien [ simplify-box-displaced-alien ] }
[ 2drop f ]
} case ;
] unit-test
] when
+! Displaced alien optimizations
+3 vreg-counter set-global
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 16 }
+ T{ ##box-displaced-alien f 1 2 0 }
+ T{ ##unbox-any-c-ptr f 4 0 }
+ T{ ##add-imm f 3 4 16 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 16 }
+ T{ ##box-displaced-alien f 1 2 0 }
+ T{ ##unbox-any-c-ptr f 3 1 }
+ } value-numbering-step
+] unit-test
+
+4 vreg-counter set-global
+
+[
+ {
+ T{ ##box-alien f 0 1 }
+ T{ ##load-immediate f 2 16 }
+ T{ ##box-displaced-alien f 3 2 0 }
+ T{ ##copy f 5 1 any-rep }
+ T{ ##add-imm f 4 5 16 }
+ }
+] [
+ {
+ T{ ##box-alien f 0 1 }
+ T{ ##load-immediate f 2 16 }
+ T{ ##box-displaced-alien f 3 2 0 }
+ T{ ##unbox-any-c-ptr f 4 3 }
+ } value-numbering-step
+] unit-test
+
+3 vreg-counter set-global
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 1 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 0 }
+ T{ ##box-displaced-alien f 3 2 0 }
+ T{ ##replace f 3 D 1 }
+ } value-numbering-step
+] unit-test
+
! Branch folding
[
{
] unit-test
[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
+
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs kernel accessors
-sorting sets sequences
+sorting sets sequences arrays
cpu.architecture
+sequences.deep
compiler.cfg
compiler.cfg.rpo
compiler.cfg.instructions
dup rewrite
[ process-instruction ] [ ] ?if ;
+M: array process-instruction
+ [ process-instruction ] map ;
+
: value-numbering-step ( insns -- insns' )
init-value-graph
init-expressions
- [ process-instruction ] map ;
+ [ process-instruction ] map flatten ;
: value-numbering ( cfg -- cfg' )
[ value-numbering-step ] local-optimization
M: ##mul-float generate-insn dst/src1/src2 %mul-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: ##float>integer generate-insn dst/src %float>integer ;
M: ##copy generate-insn [ dst/src ] [ rep>> ] bi %copy ;
-M: ##unbox-float generate-insn dst/src %unbox-float ;
+M: ##unbox-float generate-insn dst/src %unbox-float ;
M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
-M: ##box-float generate-insn dst/src/temp %box-float ;
-M: ##box-alien generate-insn dst/src/temp %box-alien ;
+M: ##box-float generate-insn dst/src/temp %box-float ;
+M: ##box-alien generate-insn dst/src/temp %box-alien ;
+
+M: ##box-displaced-alien generate-insn
+ [ dst/src1/src2 ] [ temp>> ] bi %box-displaced-alien ;
M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
-USING: alien alien.c-types alien.syntax compiler kernel namespaces
-sequences stack-checker stack-checker.errors words arrays parser
-quotations continuations effects namespaces.private io
-io.streams.string memory system threads tools.test math accessors
-combinators specialized-arrays.float alien.libraries io.pathnames
-io.backend ;
+USING: accessors alien alien.c-types alien.libraries
+alien.syntax arrays classes.struct combinators
+compiler continuations effects io io.backend io.pathnames
+io.streams.string kernel math memory namespaces
+namespaces.private parser quotations sequences
+specialized-arrays.float stack-checker stack-checker.errors
+system threads tools.test words specialized-arrays.char ;
IN: compiler.tests.alien
<<
[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
-C-STRUCT: foo
- { "int" "x" }
- { "int" "y" }
-;
+STRUCT: FOO { x int } { y int } ;
-: make-foo ( x y -- foo )
- "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
+: make-FOO ( x y -- FOO )
+ FOO <struct> swap >>y swap >>x ;
-FUNCTION: int ffi_test_11 int a foo b int c ;
+FUNCTION: int ffi_test_11 int a FOO b int c ;
-[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
+[ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
-FUNCTION: foo ffi_test_14 int x int y ;
+FUNCTION: FOO ffi_test_14 int x int y ;
-[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
+[ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
FUNCTION: char* ffi_test_15 char* x char* y ;
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
[ 1 2 ffi_test_15 ] must-fail
-C-STRUCT: bar
- { "long" "x" }
- { "long" "y" }
- { "long" "z" }
-;
+STRUCT: BAR { x long } { y long } { z long } ;
-FUNCTION: bar ffi_test_16 long x long y long z ;
+FUNCTION: BAR ffi_test_16 long x long y long z ;
[ 11 6 -7 ] [
- 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
+ 11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
] unit-test
-C-STRUCT: tiny
- { "int" "x" }
-;
+STRUCT: TINY { x int } ;
-FUNCTION: tiny ffi_test_17 int x ;
+FUNCTION: TINY ffi_test_17 int x ;
-[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
+[ 11 ] [ 11 ffi_test_17 x>> ] unit-test
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
-: ffi_test_19 ( x y z -- bar )
- "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
+: ffi_test_19 ( x y z -- BAR )
+ "BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
alien-invoke gc ;
[ 11 6 -7 ] [
- 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
+ 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
] unit-test
FUNCTION: double ffi_test_6 float x float y ;
[ 1111 f 123456789 ffi_test_22 ] must-fail
-C-STRUCT: rect
- { "float" "x" }
- { "float" "y" }
- { "float" "w" }
- { "float" "h" }
-;
+STRUCT: RECT
+ { x float } { y float }
+ { w float } { h float } ;
-: <rect> ( x y w h -- rect )
- "rect" <c-object>
- [ set-rect-h ] keep
- [ set-rect-w ] keep
- [ set-rect-y ] keep
- [ set-rect-x ] keep ;
+: <RECT> ( x y w h -- rect )
+ RECT <struct>
+ swap >>h
+ swap >>w
+ swap >>y
+ swap >>x ;
-FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
+FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
-[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
+[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
] unit-test
! Test odd-size structs
-C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
+STRUCT: test-struct-1 { x char[1] } ;
FUNCTION: test-struct-1 ffi_test_24 ;
-[ B{ 1 } ] [ ffi_test_24 ] unit-test
+[ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
-C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
+STRUCT: test-struct-2 { x char[2] } ;
FUNCTION: test-struct-2 ffi_test_25 ;
-[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
+[ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
-C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
+STRUCT: test-struct-3 { x char[3] } ;
FUNCTION: test-struct-3 ffi_test_26 ;
-[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
+[ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
-C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
+STRUCT: test-struct-4 { x char[4] } ;
FUNCTION: test-struct-4 ffi_test_27 ;
-[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
+[ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
-C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
+STRUCT: test-struct-5 { x char[5] } ;
FUNCTION: test-struct-5 ffi_test_28 ;
-[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
+[ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
-C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
+STRUCT: test-struct-6 { x char[6] } ;
FUNCTION: test-struct-6 ffi_test_29 ;
-[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
+[ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
-C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
+STRUCT: test-struct-7 { x char[7] } ;
FUNCTION: test-struct-7 ffi_test_30 ;
-[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
+[ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
-C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
+STRUCT: test-struct-8 { x double } { y double } ;
FUNCTION: double ffi_test_32 test-struct-8 x int y ;
[ 9.0 ] [
- "test-struct-8" <c-object>
- 1.0 over set-test-struct-8-x
- 2.0 over set-test-struct-8-y
+ test-struct-8 <struct>
+ 1.0 >>x
+ 2.0 >>y
3 ffi_test_32
] unit-test
-C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
+STRUCT: test-struct-9 { x float } { y float } ;
FUNCTION: double ffi_test_33 test-struct-9 x int y ;
[ 9.0 ] [
- "test-struct-9" <c-object>
- 1.0 over set-test-struct-9-x
- 2.0 over set-test-struct-9-y
+ test-struct-9 <struct>
+ 1.0 >>x
+ 2.0 >>y
3 ffi_test_33
] unit-test
-C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
+STRUCT: test-struct-10 { x float } { y int } ;
FUNCTION: double ffi_test_34 test-struct-10 x int y ;
[ 9.0 ] [
- "test-struct-10" <c-object>
- 1.0 over set-test-struct-10-x
- 2 over set-test-struct-10-y
+ test-struct-10 <struct>
+ 1.0 >>x
+ 2 >>y
3 ffi_test_34
] unit-test
-C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
+STRUCT: test-struct-11 { x int } { y int } ;
FUNCTION: double ffi_test_35 test-struct-11 x int y ;
[ 9.0 ] [
- "test-struct-11" <c-object>
- 1 over set-test-struct-11-x
- 2 over set-test-struct-11-y
+ test-struct-11 <struct>
+ 1 >>x
+ 2 >>y
3 ffi_test_35
] unit-test
-C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
+STRUCT: test-struct-12 { a int } { x double } ;
: make-struct-12 ( x -- alien )
- "test-struct-12" <c-object>
- [ set-test-struct-12-x ] keep ;
+ test-struct-12 <struct>
+ swap >>x ;
FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
[ 7 ] [ callback-9 ffi_test_37 ] unit-test
-C-STRUCT: test_struct_13
-{ "float" "x1" }
-{ "float" "x2" }
-{ "float" "x3" }
-{ "float" "x4" }
-{ "float" "x5" }
-{ "float" "x6" } ;
+STRUCT: test_struct_13
+{ x1 float }
+{ x2 float }
+{ x3 float }
+{ x4 float }
+{ x5 float }
+{ x6 float } ;
: make-test-struct-13 ( -- alien )
- "test_struct_13" <c-object>
- 1.0 over set-test_struct_13-x1
- 2.0 over set-test_struct_13-x2
- 3.0 over set-test_struct_13-x3
- 4.0 over set-test_struct_13-x4
- 5.0 over set-test_struct_13-x5
- 6.0 over set-test_struct_13-x6 ;
+ test_struct_13 <struct>
+ 1.0 >>x1
+ 2.0 >>x2
+ 3.0 >>x3
+ 4.0 >>x4
+ 5.0 >>x5
+ 6.0 >>x6 ;
FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
[ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
! Joe Groff found this problem
-C-STRUCT: double-rect
-{ "double" "a" }
-{ "double" "b" }
-{ "double" "c" }
-{ "double" "d" } ;
+STRUCT: double-rect
+{ a double }
+{ b double }
+{ c double }
+{ d double } ;
: <double-rect> ( a b c d -- foo )
- "double-rect" <c-object>
- {
- [ set-double-rect-d ]
- [ set-double-rect-c ]
- [ set-double-rect-b ]
- [ set-double-rect-a ]
- [ ]
- } cleave ;
+ double-rect <struct>
+ swap >>d
+ swap >>c
+ swap >>b
+ swap >>a ;
: >double-rect< ( foo -- a b c d )
{
- [ double-rect-a ]
- [ double-rect-b ]
- [ double-rect-c ]
- [ double-rect-d ]
+ [ a>> ]
+ [ b>> ]
+ [ c>> ]
+ [ d>> ]
} cleave ;
: double-rect-callback ( -- alien )
[ 1.0 2.0 3.0 4.0 ]
[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
-C-STRUCT: test_struct_14
-{ "double" "x1" }
-{ "double" "x2" } ;
+STRUCT: test_struct_14
+ { x1 double }
+ { x2 double } ;
FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
[ 1.0 2.0 ] [
- 1.0 2.0 ffi_test_40
- [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
+ 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
] unit-test
: callback-10 ( -- callback )
"test_struct_14" { "double" "double" } "cdecl"
[
- "test_struct_14" <c-object>
- [ set-test_struct_14-x2 ] keep
- [ set-test_struct_14-x1 ] keep
+ test_struct_14 <struct>
+ swap >>x2
+ swap >>x1
] alien-callback ;
: callback-10-test ( x1 x2 callback -- result )
[ 1.0 2.0 ] [
1.0 2.0 callback-10 callback-10-test
- [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
+ [ x1>> ] [ x2>> ] bi
] unit-test
FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
[ 1 2.0 ] [
1 2.0 ffi_test_41
- [ test-struct-12-a ] [ test-struct-12-x ] bi
+ [ a>> ] [ x>> ] bi
] unit-test
: callback-11 ( -- callback )
"test-struct-12" { "int" "double" } "cdecl"
[
- "test-struct-12" <c-object>
- [ set-test-struct-12-x ] keep
- [ set-test-struct-12-a ] keep
+ test-struct-12 <struct>
+ swap >>x
+ swap >>a
] alien-callback ;
: callback-11-test ( x1 x2 callback -- result )
[ 1 2.0 ] [
1 2.0 callback-11 callback-11-test
- [ test-struct-12-a ] [ test-struct-12-x ] bi
+ [ a>> ] [ x>> ] bi
] unit-test
-C-STRUCT: test_struct_15
-{ "float" "x" }
-{ "float" "y" } ;
+STRUCT: test_struct_15
+ { x float }
+ { y float } ;
FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
-[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ test_struct_15-x ] [ test_struct_15-y ] bi ] unit-test
+[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
: callback-12 ( -- callback )
"test_struct_15" { "float" "float" } "cdecl"
[
- "test_struct_15" <c-object>
- [ set-test_struct_15-y ] keep
- [ set-test_struct_15-x ] keep
+ test_struct_15 <struct>
+ swap >>y
+ swap >>x
] alien-callback ;
: callback-12-test ( x1 x2 callback -- result )
"test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
- 1.0 2.0 callback-12 callback-12-test
- [ test_struct_15-x ] [ test_struct_15-y ] bi
+ 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
] unit-test
-C-STRUCT: test_struct_16
-{ "float" "x" }
-{ "int" "a" } ;
+STRUCT: test_struct_16
+ { x float }
+ { a int } ;
FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
-[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ test_struct_16-x ] [ test_struct_16-a ] bi ] unit-test
+[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
: callback-13 ( -- callback )
"test_struct_16" { "float" "int" } "cdecl"
[
- "test_struct_16" <c-object>
- [ set-test_struct_16-a ] keep
- [ set-test_struct_16-x ] keep
+ test_struct_16 <struct>
+ swap >>a
+ swap >>x
] alien-callback ;
: callback-13-test ( x1 x2 callback -- result )
[ 1.0 2 ] [
1.0 2 callback-13 callback-13-test
- [ test_struct_16-x ] [ test_struct_16-a ] bi
+ [ x>> ] [ a>> ] bi
] unit-test
FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
-[ 1.0 2.0 ] [ ffi_test_44 [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi ] unit-test
+[ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
: stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
] unit-test
! Reported by jedahu
-C-STRUCT: bool-field-test
- { "char*" "name" }
- { "bool" "on" }
- { "short" "parents" } ;
+STRUCT: bool-field-test
+ { name char* }
+ { on bool }
+ { parents short } ;
FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
[ 123 ] [
- "bool-field-test" <c-object> 123 over set-bool-field-test-parents
+ bool-field-test <struct>
+ 123 >>parents
ffi_test_48
] unit-test
dup [ [ 1 fixnum+fast ] dip ] [ [ drop 1 ] dip ] if ;
[ 2 t ] [ 0 t global-dcn-bug-1 ] unit-test
-[ 1 f ] [ 0 f global-dcn-bug-1 ] unit-test
\ No newline at end of file
+[ 1 f ] [ 0 f global-dcn-bug-1 ] unit-test
+
+! Forgot a GC check
+: missing-gc-check-1 ( a -- b ) { fixnum } declare <alien> ;
+: missing-gc-check-2 ( -- ) 10000000 [ missing-gc-check-1 drop ] each-integer ;
+
+[ ] [ missing-gc-check-2 ] unit-test
\ No newline at end of file
] compile-call
] unit-test
+[ ALIEN: 123 ] [
+ 123 [ <alien> ] compile-call
+] unit-test
+
+[ ALIEN: 123 ] [
+ 123 [ { fixnum } declare <alien> ] compile-call
+] unit-test
+
+[ ALIEN: 123 ] [
+ [ 123 <alien> ] compile-call
+] unit-test
+
+[ f ] [
+ 0 [ <alien> ] compile-call
+] unit-test
+
+[ f ] [
+ 0 [ { fixnum } declare <alien> ] compile-call
+] unit-test
+
+[ f ] [
+ [ 0 <alien> ] compile-call
+] unit-test
+
+[ ALIEN: 321 ] [
+ 0 ALIEN: 321 [ <displaced-alien> ] compile-call
+] unit-test
+
+[ ALIEN: 321 ] [
+ 0 ALIEN: 321 [ { fixnum c-ptr } declare <displaced-alien> ] compile-call
+] unit-test
+
+[ ALIEN: 321 ] [
+ ALIEN: 321 [ 0 swap <displaced-alien> ] compile-call
+] unit-test
+
+[ B{ 0 1 2 3 4 } ] [
+ 2 B{ 0 1 2 3 4 } <displaced-alien>
+ [ 1 swap <displaced-alien> ] compile-call
+ underlying>>
+] unit-test
+
+[ B{ 0 1 2 3 4 } ] [
+ 2 B{ 0 1 2 3 4 } <displaced-alien>
+ [ 1 swap { c-ptr } declare <displaced-alien> ] compile-call
+ underlying>>
+] unit-test
+
[
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
] must-fail
compiler.cfg.registers compiler.codegen compiler.units
cpu.architecture hashtables kernel namespaces sequences
tools.test vectors words layouts literals math arrays
-alien.syntax ;
+alien.syntax math.private ;
IN: compiler.tests.low-level-ir
: compile-cfg ( cfg -- word )
} compile-test-bb
] 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
! one of the sources
[ t ] [
} compile-test-bb
] unit-test
-*/
\ No newline at end of file
+*/
! See http://factorcode.org/license.txt for BSD license.
USING: kernel effects accessors math math.private
math.integers.private math.partial-dispatch math.intervals
-math.parser math.order math.functions layouts words sequences sequences.private
-arrays assocs classes classes.algebra combinators generic.math
-splitting fry locals classes.tuple alien.accessors
-classes.tuple.private slots.private definitions strings.private
-vectors hashtables generic quotations
+math.parser math.order math.functions math.libm layouts words
+sequences sequences.private arrays assocs classes
+classes.algebra combinators generic.math splitting fry locals
+classes.tuple alien.accessors classes.tuple.private
+slots.private definitions strings.private vectors hashtables
+generic quotations
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
bi
] [ 2drop object-info ] if
] "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
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.syntax kernel destructors
accessors fry words hashtables strings sequences memoize assocs math
-math.vectors math.rectangles math.functions locals init namespaces
-combinators fonts colors cache core-foundation core-foundation.strings
-core-foundation.attributed-strings core-foundation.utilities
-core-graphics core-graphics.types core-text.fonts core-text.utilities ;
+math.order math.vectors math.rectangles math.functions locals init
+namespaces combinators fonts colors cache core-foundation
+core-foundation.strings core-foundation.attributed-strings
+core-foundation.utilities core-graphics core-graphics.types
+core-text.fonts core-text.utilities ;
IN: core-text
TYPEDEF: void* CTLineRef
(ext) [ (loc) (dim) v+ ]
loc [ (loc) [ floor ] map ]
ext [ (loc) (dim) [ + ceiling ] 2map ]
- dim [ ext loc [ - >integer ] 2map ]
+ dim [ ext loc [ - >integer 1 max ] 2map ]
metrics [ open-font line compute-line-metrics ] |
line >>line
: cached-line ( font string -- line )
cached-lines get [ <line> ] 2cache ;
-[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook
\ No newline at end of file
+[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook
HOOK: %sub-float cpu ( dst src1 src2 -- )
HOOK: %mul-float cpu ( dst src1 src2 -- )
HOOK: %div-float cpu ( dst src1 src2 -- )
+HOOK: %sqrt cpu ( dst src -- )
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %box-float cpu ( dst src temp -- )
HOOK: %box-alien cpu ( dst src temp -- )
+HOOK: %box-displaced-alien cpu ( dst displacement base temp -- )
HOOK: %alien-unsigned-1 cpu ( dst src -- )
HOOK: %alien-unsigned-2 cpu ( dst src -- )
USING: cpu.ppc.assembler tools.test arrays kernel namespaces
-make vocabs sequences ;
+make vocabs sequences byte-arrays.hex ;
FROM: cpu.ppc.assembler => B ;
IN: cpu.ppc.assembler.tests
: test-assembler ( expected quot -- )
[ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
-B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler
-B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler
-B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler
-B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler
-B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler
-B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler
-B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler
-B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler
-B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler
-B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler
-B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler
-B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler
-B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler
-B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler
-B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
-B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler
-B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler
-B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler
-B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler
-B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler
-B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler
-B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler
-B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler
-B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler
-B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler
-B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler
-B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler
-B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
-B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler
-B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler
-B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler
-B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
-B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler
-B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler
-B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler
-B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler
-B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler
-B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler
-B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler
-B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler
-B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler
-B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
-B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
-B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler
-B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler
-B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler
-B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler
-B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
-B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
-B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler
-B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler
-B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler
-B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler
-B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler
-B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler
-B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler
-B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler
-B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler
-B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler
-B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler
-B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler
-B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] 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{ 38 22 00 03 } [ 1 2 3 ADDI ] test-assembler
+HEX{ 3c 22 00 03 } [ 1 2 3 ADDIS ] test-assembler
+HEX{ 30 22 00 03 } [ 1 2 3 ADDIC ] test-assembler
+HEX{ 34 22 00 03 } [ 1 2 3 ADDIC. ] test-assembler
+HEX{ 38 40 00 01 } [ 1 2 LI ] test-assembler
+HEX{ 3c 40 00 01 } [ 1 2 LIS ] test-assembler
+HEX{ 38 22 ff fd } [ 1 2 3 SUBI ] test-assembler
+HEX{ 1c 22 00 03 } [ 1 2 3 MULI ] test-assembler
+HEX{ 7c 22 1a 14 } [ 1 2 3 ADD ] test-assembler
+HEX{ 7c 22 1a 15 } [ 1 2 3 ADD. ] test-assembler
+HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
+HEX{ 7c 22 1e 15 } [ 1 2 3 ADDO. ] test-assembler
+HEX{ 7c 22 18 14 } [ 1 2 3 ADDC ] test-assembler
+HEX{ 7c 22 18 15 } [ 1 2 3 ADDC. ] test-assembler
+HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
+HEX{ 7c 22 1c 15 } [ 1 2 3 ADDCO. ] test-assembler
+HEX{ 7c 22 19 14 } [ 1 2 3 ADDE ] test-assembler
+HEX{ 7c 41 18 38 } [ 1 2 3 AND ] test-assembler
+HEX{ 7c 41 18 39 } [ 1 2 3 AND. ] test-assembler
+HEX{ 7c 22 1b d6 } [ 1 2 3 DIVW ] test-assembler
+HEX{ 7c 22 1b 96 } [ 1 2 3 DIVWU ] test-assembler
+HEX{ 7c 41 1a 38 } [ 1 2 3 EQV ] test-assembler
+HEX{ 7c 41 1b b8 } [ 1 2 3 NAND ] test-assembler
+HEX{ 7c 41 18 f8 } [ 1 2 3 NOR ] test-assembler
+HEX{ 7c 41 10 f8 } [ 1 2 NOT ] test-assembler
+HEX{ 60 41 00 03 } [ 1 2 3 ORI ] test-assembler
+HEX{ 64 41 00 03 } [ 1 2 3 ORIS ] test-assembler
+HEX{ 7c 41 1b 78 } [ 1 2 3 OR ] test-assembler
+HEX{ 7c 41 13 78 } [ 1 2 MR ] test-assembler
+HEX{ 7c 22 18 96 } [ 1 2 3 MULHW ] test-assembler
+HEX{ 1c 22 00 03 } [ 1 2 3 MULLI ] test-assembler
+HEX{ 7c 22 18 16 } [ 1 2 3 MULHWU ] test-assembler
+HEX{ 7c 22 19 d6 } [ 1 2 3 MULLW ] test-assembler
+HEX{ 7c 41 18 30 } [ 1 2 3 SLW ] test-assembler
+HEX{ 7c 41 1e 30 } [ 1 2 3 SRAW ] test-assembler
+HEX{ 7c 41 1c 30 } [ 1 2 3 SRW ] test-assembler
+HEX{ 7c 41 1e 70 } [ 1 2 3 SRAWI ] test-assembler
+HEX{ 7c 22 18 50 } [ 1 2 3 SUBF ] test-assembler
+HEX{ 7c 22 18 10 } [ 1 2 3 SUBFC ] test-assembler
+HEX{ 7c 22 19 10 } [ 1 2 3 SUBFE ] test-assembler
+HEX{ 7c 41 07 74 } [ 1 2 EXTSB ] test-assembler
+HEX{ 68 41 00 03 } [ 1 2 3 XORI ] test-assembler
+HEX{ 7c 41 1a 78 } [ 1 2 3 XOR ] test-assembler
+HEX{ 7c 22 00 d0 } [ 1 2 NEG ] test-assembler
+HEX{ 2c 22 00 03 } [ 1 2 3 CMPI ] test-assembler
+HEX{ 28 22 00 03 } [ 1 2 3 CMPLI ] test-assembler
+HEX{ 7c 41 18 00 } [ 1 2 3 CMP ] test-assembler
+HEX{ 54 22 19 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
+HEX{ 54 22 18 38 } [ 1 2 3 SLWI ] test-assembler
+HEX{ 54 22 e8 fe } [ 1 2 3 SRWI ] test-assembler
+HEX{ 88 22 00 03 } [ 1 2 3 LBZ ] test-assembler
+HEX{ 8c 22 00 03 } [ 1 2 3 LBZU ] test-assembler
+HEX{ a8 22 00 03 } [ 1 2 3 LHA ] test-assembler
+HEX{ ac 22 00 03 } [ 1 2 3 LHAU ] test-assembler
+HEX{ a0 22 00 03 } [ 1 2 3 LHZ ] test-assembler
+HEX{ a4 22 00 03 } [ 1 2 3 LHZU ] test-assembler
+HEX{ 80 22 00 03 } [ 1 2 3 LWZ ] test-assembler
+HEX{ 84 22 00 03 } [ 1 2 3 LWZU ] test-assembler
+HEX{ 7c 41 18 ae } [ 1 2 3 LBZX ] test-assembler
+HEX{ 7c 41 18 ee } [ 1 2 3 LBZUX ] test-assembler
+HEX{ 7c 41 1a ae } [ 1 2 3 LHAX ] test-assembler
+HEX{ 7c 41 1a ee } [ 1 2 3 LHAUX ] test-assembler
+HEX{ 7c 41 1a 2e } [ 1 2 3 LHZX ] test-assembler
+HEX{ 7c 41 1a 6e } [ 1 2 3 LHZUX ] test-assembler
+HEX{ 7c 41 18 2e } [ 1 2 3 LWZX ] test-assembler
+HEX{ 7c 41 18 6e } [ 1 2 3 LWZUX ] test-assembler
+HEX{ 48 00 00 01 } [ 1 B ] test-assembler
+HEX{ 48 00 00 01 } [ 1 BL ] test-assembler
+HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
+HEX{ 41 81 00 04 } [ 1 BGT ] test-assembler
+HEX{ 40 81 00 04 } [ 1 BLE ] test-assembler
+HEX{ 40 80 00 04 } [ 1 BGE ] test-assembler
+HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
+HEX{ 40 82 00 04 } [ 1 BNE ] test-assembler
+HEX{ 41 82 00 04 } [ 1 BEQ ] test-assembler
+HEX{ 41 83 00 04 } [ 1 BO ] test-assembler
+HEX{ 40 83 00 04 } [ 1 BNO ] test-assembler
+HEX{ 4c 20 00 20 } [ 1 BCLR ] test-assembler
+HEX{ 4e 80 00 20 } [ BLR ] test-assembler
+HEX{ 4e 80 00 21 } [ BLRL ] test-assembler
+HEX{ 4c 20 04 20 } [ 1 BCCTR ] test-assembler
+HEX{ 4e 80 04 20 } [ BCTR ] test-assembler
+HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
+HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
+HEX{ 7c 69 02 a6 } [ 3 MFCTR ] test-assembler
+HEX{ 7c 61 03 a6 } [ 3 MTXER ] test-assembler
+HEX{ 7c 68 03 a6 } [ 3 MTLR ] test-assembler
+HEX{ 7c 69 03 a6 } [ 3 MTCTR ] test-assembler
+HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
+HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
+HEX{ c0 22 00 03 } [ 1 2 3 LFS ] test-assembler
+HEX{ c4 22 00 03 } [ 1 2 3 LFSU ] test-assembler
+HEX{ c8 22 00 03 } [ 1 2 3 LFD ] test-assembler
+HEX{ cc 22 00 03 } [ 1 2 3 LFDU ] test-assembler
+HEX{ d0 22 00 03 } [ 1 2 3 STFS ] test-assembler
+HEX{ d4 22 00 03 } [ 1 2 3 STFSU ] test-assembler
+HEX{ d8 22 00 03 } [ 1 2 3 STFD ] test-assembler
+HEX{ dc 22 00 03 } [ 1 2 3 STFDU ] test-assembler
+HEX{ fc 20 10 90 } [ 1 2 FMR ] test-assembler
+HEX{ fc 40 08 90 } [ 2 1 FMR ] test-assembler
+HEX{ fc 20 10 91 } [ 1 2 FMR. ] test-assembler
+HEX{ fc 40 08 91 } [ 2 1 FMR. ] test-assembler
+HEX{ fc 20 10 1e } [ 1 2 FCTIWZ ] test-assembler
+HEX{ fc 22 18 2a } [ 1 2 3 FADD ] test-assembler
+HEX{ fc 22 18 2b } [ 1 2 3 FADD. ] test-assembler
+HEX{ fc 22 18 28 } [ 1 2 3 FSUB ] test-assembler
+HEX{ fc 22 00 f2 } [ 1 2 3 FMUL ] test-assembler
+HEX{ fc 22 18 24 } [ 1 2 3 FDIV ] 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
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! 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 ;
IN: cpu.ppc.assembler
X: XOR. 1 316 31
X1: EXTSB 0 954 31
X1: EXTSB. 1 954 31
-: FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ;
-: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ;
+: FMR ( a s -- ) [ 0 ] 2dip 0 72 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 1 15 63 x-insn ;
MTSPR: CTR 9
! Pseudo-instructions
-: LI ( value dst -- ) 0 rot ADDI ; inline
+: LI ( value dst -- ) swap [ 0 ] dip 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
: NOT ( dst src -- ) dup NOR ; 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. ;
-: 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? ;
: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
M: ppc %peek loc>operand LWZ ;
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-r ( n -- ) rs-reg (%inc) ;
: alien@ ( n -- n' ) cells object tag-number - ;
+:: %allot-alien ( dst displacement base temp -- )
+ dst 4 cells alien temp %allot
+ temp \ f tag-number %load-immediate
+ ! Store underlying-alien slot
+ base dst 1 alien@ STW
+ ! Store expired slot
+ temp dst 2 alien@ STW
+ ! Store offset
+ displacement dst 3 alien@ STW ;
+
M:: ppc %box-alien ( dst src temp -- )
[
"f" define-label
dst \ f tag-number %load-immediate
0 src 0 CMPI
"f" get BEQ
- dst 4 cells alien temp %allot
- ! Store offset
- src dst 3 alien@ STW
- ! Store expired slot
- temp \ f tag-number %load-immediate
- temp dst 1 alien@ STW
- ! Store underlying-alien slot
- temp dst 2 alien@ STW
+ dst src temp temp %allot-alien
"f" resolve-label
] with-scope ;
+M:: ppc %box-displaced-alien ( dst displacement base temp -- )
+ [
+ "end" define-label
+ "ok" define-label
+ ! If displacement is zero, return the base
+ dst base MR
+ 0 displacement 0 CMPI
+ "end" get BEQ
+ ! If base is already a displaced alien, unpack it
+ 0 base \ f tag-number CMPI
+ "ok" get BEQ
+ temp base header-offset LWZ
+ 0 temp alien type-number tag-fixnum CMPI
+ "ok" get BNE
+ ! displacement += base.displacement
+ temp base 3 alien@ LWZ
+ displacement displacement temp ADD
+ ! base = base.base
+ base base 1 alien@ LWZ
+ "ok" resolve-label
+ dst displacement base temp %allot-alien
+ "end" resolve-label
+ ] with-scope ;
+
M: ppc %alien-unsigned-1 0 LBZ ;
M: ppc %alien-unsigned-2 0 LHZ ;
{ 2 [ %unbox-struct-2 ] }
} case ;
-M: x86.32 %unbox-large-struct ( n c-type -- )
+M:: x86.32 %unbox-large-struct ( n c-type -- )
! Alien must be in EAX.
! Compute destination address
- ECX rot stack@ LEA
+ ECX n stack@ LEA
12 [
! Push struct size
- heap-size PUSH
+ c-type heap-size PUSH
! Push destination address
ECX PUSH
! Push source address
sse2? [
" - yes" print
enable-float-intrinsics
+ enable-fsqrt
[
sse2? [
"This image was built to use SSE2, which your CPU does not support." print
flatten-value-type [ %unbox-struct-field ] each-index
] 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
- heap-size
- ! Load destination address
- param-reg-2 rot param@ LEA
- ! Load structure size
- param-reg-3 swap MOV
+ ! Load destination address into param-reg-2
+ param-reg-2 n param@ LEA
+ ! Load structure size into param-reg-3
+ param-reg-3 c-type heap-size MOV
! Copy the struct to the C stack
"to_value_struct" f %alien-invoke ;
! SSE2 is always available on x86-64.
enable-float-intrinsics
+enable-fsqrt
USE: vocabs.loader
M: x86 %sub-float nip SUBSD ;
M: x86 %mul-float nip MULSD ;
M: x86 %div-float nip DIVSD ;
+M: x86 %sqrt SQRTSD ;
M: x86 %integer>float CVTSI2SD ;
M: x86 %float>integer CVTTSD2SI ;
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
+:: %allot-alien ( dst displacement base temp -- )
+ dst 4 cells alien temp %allot
+ dst 1 alien@ base MOV ! alien
+ dst 2 alien@ \ f tag-number MOV ! expired
+ dst 3 alien@ displacement MOV ! displacement
+ ;
+
M:: x86 %box-alien ( dst src temp -- )
[
"end" define-label
dst \ f tag-number MOV
src 0 CMP
"end" get JE
- dst 4 cells alien temp %allot
- dst 1 alien@ \ f tag-number MOV
- dst 2 alien@ \ f tag-number MOV
- ! Store src in alien-offset slot
- dst 3 alien@ src MOV
+ dst src \ f tag-number temp %allot-alien
+ "end" resolve-label
+ ] with-scope ;
+
+M:: x86 %box-displaced-alien ( dst displacement base temp -- )
+ [
+ "end" define-label
+ "ok" define-label
+ ! If displacement is zero, return the base
+ dst base MOV
+ displacement 0 CMP
+ "end" get JE
+ ! If base is already a displaced alien, unpack it
+ base \ f tag-number CMP
+ "ok" get JE
+ base header-offset [+] alien type-number tag-fixnum CMP
+ "ok" get JNE
+ ! displacement += base.displacement
+ displacement base 3 alien@ ADD
+ ! base = base.base
+ base base 1 alien@ MOV
+ "ok" resolve-label
+ dst displacement base temp %allot-alien
"end" resolve-label
] with-scope ;
MACRO: nsequence ( n seq -- )
[
- [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
+ [ drop iota <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep
'[ @ _ like ] ;
1 - [ + ] n*quot ;
MACRO: firstn-unsafe ( n -- )
- [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
+ iota [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
MACRO: nweave ( n -- )
- [ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
+ [ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ;
MACRO: nbi-curry ( n -- )
ERROR: unsupported-bitmap-file magic ;
-: load-bitmap ( path -- loading-bitmap )
- binary stream-throws <limited-file-reader> [
+: load-bitmap ( stream -- loading-bitmap )
+ [
\ loading-bitmap new
parse-file-header [ >>file-header ] [ ] bi magic>> {
{ "BM" [
: loading-bitmap>bytes ( loading-bitmap -- byte-array )
uncompress-bitmap bitmap>bytes ;
-M: bitmap-image load-image* ( path bitmap-image -- bitmap )
+M: bitmap-image stream>image ( stream bitmap-image -- bitmap )
drop load-bitmap
[ image new ] dip
{
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: http.client images.loader images.loader.private kernel ;
+IN: images.http
+
+: load-http-image ( path -- image )
+ [ http-get nip ] [ image-class new ] bi load-image* ;
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
-GENERIC: load-image* ( path class -- image )
-
: bytes-per-component ( component-type -- n )
{
{ ubyte-components [ 1 ] }
io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces
-sequences sequences.deep ;
+sequences sequences.deep images.loader ;
IN: images.jpeg
QUALIFIED-WITH: bitstreams bs
{ huff-tables initial: { f f f f } }
{ components } ;
+"jpg" jpeg-image register-image-class
+"jpeg" jpeg-image register-image-class
+
<PRIVATE
: <jpeg-image> ( headers bitstream -- image )
PRIVATE>
-: load-jpeg ( path -- image )
- binary [
+M: jpeg-image stream>image ( stream jpeg-image -- bitmap )
+ drop [
parse-marker { SOI } = [ not-a-jpeg-image ] unless
parse-headers
contents <jpeg-image>
- ] with-file-reader
+ ] with-input-stream
dup jpeg-image [
baseline-parse
baseline-decompress
] with-variable ;
-
-M: jpeg-image load-image* ( path jpeg-image -- bitmap )
- drop load-jpeg ;
-
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel splitting unicode.case combinators accessors images
-io.pathnames namespaces assocs ;
+USING: accessors assocs byte-arrays combinators images
+io.encodings.binary io.pathnames io.streams.byte-array
+io.streams.limited kernel namespaces splitting strings
+unicode.case ;
IN: images.loader
ERROR: unknown-image-extension extension ;
file-extension >lower types get ?at
[ unknown-image-extension ] unless ;
+: open-image-file ( path -- stream )
+ binary stream-throws <limited-file-reader> ;
+
PRIVATE>
+GENERIC# load-image* 1 ( obj class -- image )
+
+GENERIC: stream>image ( stream class -- image )
+
: register-image-class ( extension class -- )
swap types get set-at ;
: load-image ( path -- image )
- dup image-class load-image* ;
+ [ open-image-file ] [ image-class ] bi load-image* ;
+
+M: byte-array load-image*
+ [ binary <byte-reader> ] dip stream>image ;
+
+M: limited-stream load-image* stream>image ;
+
+M: string load-image* [ open-image-file ] dip stream>image ;
+
+M: pathname load-image* [ open-image-file ] dip stream>image ;
[ unknown-color-type ]
} case ;
-: load-png ( path -- image )
- binary stream-throws <limited-file-reader> [
+M: png-image stream>image
+ drop [
<loading-png>
read-png-header
read-png-chunks
parse-ihdr-chunk
decode-png
] with-input-stream ;
-
-M: png-image load-image*
- drop load-png ;
: with-tiff-endianness ( loading-tiff quot -- )
[ dup endianness>> ] dip with-endianness ; inline
-: load-tiff-ifds ( path -- loading-tiff )
- binary [
+: load-tiff-ifds ( stream -- loading-tiff )
+ [
<loading-tiff>
read-header [
dup ifd-offset>> read-ifds
process-ifds
] with-tiff-endianness
- ] with-file-reader ;
+ ] with-input-stream* ;
: process-chunky-ifd ( ifd -- )
read-strips
ifds>> [ process-ifd ] each ;
: load-tiff ( path -- loading-tiff )
- [ load-tiff-ifds dup ] keep
- binary [
- [ process-tif-ifds ] with-tiff-endianness
- ] with-file-reader ;
+ [ load-tiff-ifds dup ]
+ [
+ [ [ 0 seek-absolute ] dip stream-seek ]
+ [
+ [
+ [ process-tif-ifds ] with-tiff-endianness
+ ] with-input-stream
+ ] bi
+ ] bi ;
! tiff files can store several images -- we just take the first for now
-M: tiff-image load-image* ( path tiff-image -- image )
+M: tiff-image stream>image ( stream tiff-image -- image )
drop load-tiff tiff>image ;
{ "tif" "tiff" } [ tiff-image register-image-class ] each
[ fill>> ] [ pos>> ] bi - ; inline
: buffer@ ( buffer -- alien )
- [ pos>> ] [ ptr>> ] bi <displaced-alien> ;
+ [ pos>> ] [ ptr>> ] bi <displaced-alien> ; inline
: buffer-read ( n buffer -- byte-array )
[ buffer-length min ] keep
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 ]
} cleave directory-entry boa ;
M: limited-stream stream-read-until
swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ;
+M: limited-stream stream-seek
+ stream>> stream-seek ;
+
M: limited-stream dispose
stream>> dispose ;
: memcpy ( dst src size -- )
"void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
+: memcmp ( a b size -- cmp )
+ "int" "libc" "memcmp" { "void*" "void*" "ulong" } alien-invoke ;
+
+: memory= ( a b size -- ? )
+ memcmp 0 = ;
+
: strlen ( alien -- len )
"size_t" "libc" "strlen" { "char*" } alien-invoke ;
: facos ( x -- y )
"double" "libm" "acos" { "double" } alien-invoke ;
- inline
: fasin ( x -- y )
"double" "libm" "asin" { "double" } alien-invoke ;
- inline
: fatan ( x -- y )
"double" "libm" "atan" { "double" } alien-invoke ;
- inline
: fatan2 ( x y -- z )
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
- inline
: fcos ( x -- y )
"double" "libm" "cos" { "double" } alien-invoke ;
- inline
: fsin ( x -- y )
"double" "libm" "sin" { "double" } alien-invoke ;
- inline
: ftan ( x -- y )
"double" "libm" "tan" { "double" } alien-invoke ;
- inline
: fcosh ( x -- y )
"double" "libm" "cosh" { "double" } alien-invoke ;
- inline
: fsinh ( x -- y )
"double" "libm" "sinh" { "double" } alien-invoke ;
- inline
: ftanh ( x -- y )
"double" "libm" "tanh" { "double" } alien-invoke ;
- inline
: fexp ( x -- y )
"double" "libm" "exp" { "double" } alien-invoke ;
- inline
: flog ( x -- y )
"double" "libm" "log" { "double" } alien-invoke ;
- inline
: fpow ( x y -- z )
"double" "libm" "pow" { "double" "double" } alien-invoke ;
- inline
: fsqrt ( x -- y )
"double" "libm" "sqrt" { "double" } alien-invoke ;
- inline
! Windows doesn't have these...
: facosh ( x -- y )
"double" "libm" "acosh" { "double" } alien-invoke ;
- inline
: fasinh ( x -- y )
"double" "libm" "asinh" { "double" } alien-invoke ;
- inline
: fatanh ( x -- y )
"double" "libm" "atanh" { "double" } alien-invoke ;
- inline
HELP: HEREDOC:
{ $syntax "HEREDOC: marker\n...text...\nmarker" }
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
-{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: HEREDOC: } " until the end of the line containing the " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." }
+{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after " { $link POSTPONE: HEREDOC: } " until the end of the line containing " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." }
{ $warning "Whitespace is significant." }
{ $examples
{ $example "USING: multiline prettyprint ;"
HELP: DELIMITED:
{ $syntax "DELIMITED: marker\n...text...\nmarker" }
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
-{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: DELIMITED: } " until the end of the line containing the " { $link POSTPONE: DELIMITED: } ". Text is captured until the exact delimiter string is found, regardless of where." }
+{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after " { $link POSTPONE: DELIMITED: } " until the end of the line containing " { $link POSTPONE: DELIMITED: } ". Text is captured until the exact delimiter string is found, regardless of where." }
+{ $warning "Whitespace is significant on the " { $link POSTPONE: DELIMITED: } " line." }
{ $examples
{ $example "USING: multiline prettyprint ;"
"DELIMITED: factor blows my mind"
FUNCTOR: define-direct-array ( T -- )
A' IS ${T}-array
+S IS ${T}-sequence
>A' IS >${T}-array
<A'> IS <${A'}>
A'{ IS ${A'}{
{ length fixnum read-only } ;
: <A> ( alien len -- direct-array ) A boa ; inline
-M: A length length>> ;
-M: A nth-unsafe underlying>> NTH call ;
-M: A set-nth-unsafe underlying>> SET-NTH call ;
-M: A like drop dup A instance? [ >A' ] unless ;
-M: A new-sequence drop <A'> ;
+M: A length length>> ; inline
+M: A nth-unsafe underlying>> NTH call ; inline
+M: A set-nth-unsafe underlying>> SET-NTH call ; inline
+M: A like drop dup A instance? [ >A' ] unless ; inline
+M: A new-sequence drop <A'> ; inline
+
+M: A byte-length length>> T heap-size * ; inline
M: A pprint-delims drop \ A'{ \ } ;
M: A pprint* pprint-object ;
INSTANCE: A sequence
+INSTANCE: A S
+
+T c-type
+ \ A >>direct-array-class
+ \ <A> >>direct-array-constructor
+ drop
;FUNCTOR
FUNCTOR: define-array ( T -- )
A DEFINES-CLASS ${T}-array
+S DEFINES-CLASS ${T}-sequence
<A> DEFINES <${A}>
(A) DEFINES (${A})
>A DEFINES >${A}
WHERE
+MIXIN: S
+
TUPLE: A
{ length array-capacity read-only }
{ underlying byte-array read-only } ;
SYNTAX: A{ \ } [ >A ] parse-literal ;
INSTANCE: A sequence
+INSTANCE: A S
A T c-type-boxed-class specialize-vector-words
+T c-type
+ \ A >>array-class
+ \ <A> >>array-constructor
+ \ S >>sequence-mixin-class
+ drop
+
;FUNCTOR
V DEFINES-CLASS ${T}-vector
A IS ${T}-array
+S IS ${T}-sequence
<A> IS <${A}>
>V DEFERS >${V}
SYNTAX: V{ \ } [ >V ] parse-literal ;
INSTANCE: V growable
+INSTANCE: V S
;FUNCTOR
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors arrays kernel prettyprint.backend
+prettyprint.custom sequences struct-arrays ;
+IN: struct-arrays.prettyprint
+
+M: struct-array pprint-delims
+ drop \ struct-array{ \ } ;
+
+M: struct-array >pprint-sequence
+ [ >array ] [ class>> ] bi prefix ;
+
+M: struct-array pprint* pprint-object ;
+
IN: struct-arrays.tests
-USING: struct-arrays tools.test kernel math sequences
+USING: classes.struct struct-arrays tools.test kernel math sequences
alien.syntax alien.c-types destructors libc accessors sequences.private ;
-C-STRUCT: test-struct
-{ "int" "x" }
-{ "int" "y" } ;
+STRUCT: test-struct-array
+ { x int }
+ { y int } ;
: make-point ( x y -- struct )
- "test-struct" <c-object>
- [ set-test-struct-y ] keep
- [ set-test-struct-x ] keep ;
+ test-struct-array <struct-boa> ;
[ 5/4 ] [
- 2 "test-struct" <struct-array>
+ 2 test-struct-array <struct-array>
1 2 make-point over set-first
3 4 make-point over set-second
- 0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
+ 0 [ [ x>> ] [ y>> ] bi / + ] reduce
] unit-test
[ 5/4 ] [
[
- 2 "test-struct" malloc-struct-array
+ 2 test-struct-array malloc-struct-array
dup &free drop
1 2 make-point over set-first
3 4 make-point over set-second
- 0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
+ 0 [ [ x>> ] [ y>> ] bi / + ] reduce
] with-destructors
] unit-test
-[ ] [ ALIEN: 123 10 "test-struct" <direct-struct-array> drop ] unit-test
+[ ] [ ALIEN: 123 10 test-struct-array <direct-struct-array> drop ] unit-test
[ ] [
[
- 10 "test-struct" malloc-struct-array
+ 10 test-struct-array malloc-struct-array
&free drop
] with-destructors
] unit-test
-[ 15 ] [ 15 10 "test-struct" <struct-array> resize length ] unit-test
\ No newline at end of file
+[ 15 ] [ 15 10 test-struct-array <struct-array> resize length ] unit-test
+
+[ S{ test-struct-array f 12 20 } ] [
+ struct-array{ test-struct-array
+ S{ test-struct-array f 4 20 }
+ S{ test-struct-array f 12 20 }
+ S{ test-struct-array f 20 20 }
+ } second
+] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types byte-arrays kernel libc
-math sequences sequences.private ;
+USING: accessors alien alien.c-types alien.structs byte-arrays
+classes.struct kernel libc math parser sequences sequences.private ;
IN: struct-arrays
+: c-type-struct-class ( c-type -- class )
+ c-type boxed-class>> ; foldable
+
TUPLE: struct-array
{ underlying c-ptr read-only }
{ length array-capacity read-only }
-{ element-size array-capacity read-only } ;
+{ element-size array-capacity read-only }
+{ class read-only } ;
+
+M: struct-array length length>> ; inline
+M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
-M: struct-array length length>> ;
-M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ;
+: (nth-ptr) ( i struct-array -- alien )
+ [ element-size>> * ] [ underlying>> ] bi <displaced-alien> ; inline
M: struct-array nth-unsafe
- [ element-size>> * ] [ underlying>> ] bi <displaced-alien> ;
+ [ (nth-ptr) ] [ class>> dup struct-class? ] bi [ memory>struct ] [ drop ] if ; inline
M: struct-array set-nth-unsafe
- [ nth-unsafe swap ] [ element-size>> ] bi memcpy ;
+ [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
M: struct-array new-sequence
- element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline
+ [ element-size>> [ * <byte-array> ] 2keep ]
+ [ class>> ] bi struct-array boa ; inline
M: struct-array resize ( n seq -- newseq )
- [ [ element-size>> * ] [ underlying>> ] bi resize ] [ element-size>> ] 2bi
+ [ [ element-size>> * ] [ underlying>> ] bi resize ]
+ [ [ element-size>> ] [ class>> ] bi ] 2bi
struct-array boa ;
: <struct-array> ( length c-type -- struct-array )
- heap-size [ * <byte-array> ] 2keep struct-array boa ; inline
+ [ heap-size [ * <byte-array> ] 2keep ]
+ [ c-type-struct-class ] bi struct-array boa ; inline
ERROR: bad-byte-array-length byte-array ;
: byte-array>struct-array ( byte-array c-type -- struct-array )
- heap-size [
+ [ heap-size [
[ dup length ] dip /mod 0 =
[ drop bad-byte-array-length ] unless
- ] keep struct-array boa ; inline
+ ] keep ] [ c-type-struct-class ] bi struct-array boa ; inline
: <direct-struct-array> ( alien length c-type -- struct-array )
- heap-size struct-array boa ; inline
+ [ heap-size ] [ c-type-struct-class ] bi struct-array boa ; inline
: malloc-struct-array ( length c-type -- struct-array )
[ heap-size calloc ] 2keep <direct-struct-array> ; inline
INSTANCE: struct-array sequence
+
+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
+
+: >struct-array ( sequence class -- struct-array )
+ [ dup length ] dip <struct-array>
+ [ 0 swap copy ] keep ; inline
+
+SYNTAX: struct-array{
+ \ } scan-word [ >struct-array ] curry parse-literal ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "struct-arrays.prettyprint" require ] when
{ +name+ "FactorApplicationDelegate" }
}
-{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
+{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
[ 3drop reset-run-loop ]
} ;
[ +live-wrappers+ get adjoin ] bi ;
: <com-wrapper> ( implementations -- wrapper )
- com-wrapper new-disposable swap (make-callbacks) >>vtbls
+ com-wrapper new-disposable swap (make-callbacks) >>callbacks
dup allocate-wrapper ;
M: com-wrapper dispose*
[ ]
} 2cleave
- GUID-Data4 8 <direct-uchar-array> {
+ GUID-Data4 {
[ 20 22 0 (guid-byte>guid) ]
[ 22 24 1 (guid-byte>guid) ]
[ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
[ ]
} cleave
- GUID-Data4 8 <direct-uchar-array> {
+ GUID-Data4 {
[ 0 (guid-byte%) ]
[ 1 (guid-byte%) "-" % ]
[ 2 (guid-byte%) ]
NO_UI=
GIT_PROTOCOL=${GIT_PROTOCOL:="git"}
GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"}
+SCRIPT_ARGS="$*"
test_program_installed() {
if ! [[ -n `type -p $1` ]] ; then
invoke_git clone $GIT_URL
}
-git_pull_factorcode() {
- echo "Updating the git repository from factorcode.org..."
- invoke_git pull $GIT_URL master
+update_script_name() {
+ echo `dirname $0`/_update.sh
+}
+
+update_script() {
+ update_script=`update_script_name`
+
+ echo "#!/bin/sh" >"$update_script"
+ echo "git pull \"$GIT_URL\" master" >>"$update_script"
+ echo "if [[ \$? -eq 0 ]]; then exec \"$0\" $SCRIPT_ARGS; else echo \"git pull failed\"; exit 2; fi" \
+ >>"$update_script"
+ echo "exit 0" >>"$update_script"
+
+ chmod 755 "$update_script"
+ exec "$update_script"
+}
+
+update_script_changed() {
+ invoke_git diff --stat `invoke_git merge-base HEAD FETCH_HEAD` FETCH_HEAD | grep 'build-support.factor\.sh' >/dev/null
+}
+
+git_fetch_factorcode() {
+ echo "Fetching the git repository from factorcode.org..."
+
+ rm -f `update_script_name`
+ invoke_git fetch "$GIT_URL" master
+
+ if update_script_changed; then
+ echo "Updating and restarting the factor.sh script..."
+ update_script
+ else
+ echo "Updating the working tree..."
+ invoke_git pull "$GIT_URL" master
+ fi
}
cd_factor() {
update() {
get_config_info
- git_pull_factorcode
+ git_fetch_factorcode
backup_factor
make_clean
make_factor
[ <memory-stream> ] [ <decoder> ] bi*
"\0" swap stream-read-until drop ;
+M: object alien>string
+ [ underlying>> ] dip alien>string ;
+
M: f alien>string
drop ;
kernel math namespaces parser prettyprint sequences strings\r
tools.test words quotations classes classes.algebra\r
classes.private classes.union classes.mixin classes.predicate\r
-vectors definitions source-files compiler.units growable\r
-random stack-checker effects kernel.private sbufs math.order\r
+vectors source-files compiler.units growable random\r
+stack-checker effects kernel.private sbufs math.order\r
classes.tuple accessors ;\r
IN: classes.algebra.tests\r
\r
! UNION: u1 sa sb ;\r
! UNION: u2 sc ;\r
\r
-! [ f ] [ u1 u2 classes-intersect? ] unit-test
\ No newline at end of file
+! [ f ] [ u1 u2 classes-intersect? ] unit-test\r
io.streams.string kernel math namespaces parser prettyprint
sequences strings tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
-classes.algebra vectors definitions source-files compiler.units
+classes.algebra definitions source-files compiler.units
kernel.private sorting vocabs memory eval accessors sets ;
IN: classes.tests
layout-of 3 slot { fixnum } declare ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
- check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
+ check-tuple [ tuple-size iota ] [ ] [ layout-of ] tri ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
M: tuple-class slots>tuple ( seq class -- tuple )
check-slots pad-slots
tuple-layout <tuple> [
- [ tuple-size ]
+ [ tuple-size iota ]
[ [ set-array-nth ] curry ]
bi 2each
] keep ;
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
-classes.algebra vectors definitions source-files
-compiler.units kernel.private sorting vocabs io.streams.string
-eval see ;
+classes.algebra source-files compiler.units kernel.private
+sorting vocabs io.streams.string eval see ;
IN: classes.union.tests
! DEFER: bah
TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
+GENERIC: effect-length ( obj -- n )
+M: sequence effect-length length ;
+M: integer effect-length ;
+
: <effect> ( in out -- effect )
dup { "*" } sequence= [ drop { } t ] [ f ] if
effect boa ;
: effect-height ( effect -- n )
- [ out>> length ] [ in>> length ] bi - ; inline
+ [ out>> effect-length ] [ in>> effect-length ] bi - ; inline
: effect<= ( effect1 effect2 -- ? )
{
{ [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] }
- { [ 2dup [ in>> length ] bi@ > ] [ f ] }
+ { [ 2dup [ in>> effect-length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ]
} cond 2nip ; inline
: effect= ( effect1 effect2 -- ? )
- [ [ in>> length ] bi@ = ]
- [ [ out>> length ] bi@ = ]
+ [ [ in>> effect-length ] bi@ = ]
+ [ [ out>> effect-length ] bi@ = ]
[ [ terminated?>> ] bi@ = ]
2tri and and ;
stack-effect effect-height ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
- in>> length cut* ;
+ in>> effect-length cut* ;
: shuffle-mapping ( effect -- mapping )
[ out>> ] [ in>> ] bi [ index ] curry map ;
over terminated?>> [
drop
] [
- [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
- [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
+ [ [ [ in>> effect-length ] [ out>> effect-length ] bi ] [ in>> effect-length ] bi* swap [-] + ]
+ [ [ out>> effect-length ] [ [ in>> effect-length ] [ out>> effect-length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri
+ [ [ [ "obj" ] replicate ] bi@ ] dip
effect boa
] if ; inline
[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
[ t ] [ 0 array-capacity? ] unit-test
-[ f ] [ -1 array-capacity? ] unit-test
\ No newline at end of file
+[ f ] [ -1 array-capacity? ] unit-test
<PRIVATE
: generic-flip ( matrix -- newmatrix )
- [ dup first length [ length min ] reduce ] keep
+ [ dup first length [ length min ] reduce iota ] keep
[ [ nth-unsafe ] with { } map-as ] curry { } map-as ; inline
USE: arrays
: array-flip ( matrix -- newmatrix )
{ array } declare
- [ dup first array-length [ array-length min ] reduce ] keep
+ [ dup first array-length [ array-length min ] reduce iota ] keep
[ [ { array } declare array-nth ] with { } map-as ] curry { } map-as ;
PRIVATE>
: primitive-marshaller ( type -- quot/f )
{
- { "bool" [ [ marshall-bool ] ] }
+ { "bool" [ [ ] ] }
{ "boolean" [ [ marshall-bool ] ] }
{ "char" [ [ marshall-primitive ] ] }
{ "uchar" [ [ marshall-primitive ] ] }
: primitive-unmarshaller ( type -- quot/f )
{
- { "bool" [ [ unmarshall-bool ] ] }
+ { "bool" [ [ ] ] }
{ "boolean" [ [ unmarshall-bool ] ] }
{ "char" [ [ ] ] }
{ "uchar" [ [ ] ] }
C-INCLUDE: <stdlib.h>
C-INCLUDE: <string.h>
-
-C-TYPEDEF: char bool
+C-INCLUDE: <stdbool.h>
CM-FUNCTION: void outarg1 ( int* a )
*a += 2;
] with map ;
: 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 ;
: pixel-grid ( -- grid )
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: alien arrays classes help.markup help.syntax kernel math
-specialized-arrays.direct ;
-IN: classes.c-types
-
-HELP: c-type-class
-{ $class-description "This metaclass encompasses the " { $link "classes.c-types" } "." } ;
-
-HELP: char
-{ $class-description "A signed one-byte integer quantity." } ;
-
-HELP: direct-array-of
-{ $values
- { "alien" c-ptr } { "len" integer } { "class" c-type-class }
- { "array" "a direct array" }
-}
-{ $description "Constructs one of the " { $link "specialized-arrays.direct" } " over " { $snippet "len" } " elements of type " { $snippet "class" } " located at the referenced location in raw memory." } ;
-
-HELP: int
-{ $class-description "A signed four-byte integer quantity." } ;
-
-HELP: long
-{ $class-description "A signed integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ;
-
-HELP: longlong
-{ $class-description "A signed eight-byte integer quantity." } ;
-
-HELP: short
-{ $class-description "A signed two-byte integer quantity." } ;
-
-HELP: single-complex
-{ $class-description "A single-precision complex floating point quantity." } ;
-
-HELP: single-float
-{ $class-description "A single-precision floating point quantity." } ;
-
-HELP: uchar
-{ $class-description "An unsigned one-byte integer quantity." } ;
-
-HELP: uint
-{ $class-description "An unsigned four-byte integer quantity." } ;
-
-HELP: ulong
-{ $class-description "An unsigned integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ;
-
-HELP: ulonglong
-{ $class-description "An unsigned eight-byte integer quantity." } ;
-
-HELP: ushort
-{ $class-description "An unsigned two-byte integer quantity." } ;
-
-ARTICLE: "classes.c-types" "C type classes"
-"The " { $vocab-link "classes.c-types" } " vocabulary defines Factor classes that correspond to C types in the FFI."
-{ $subsection char }
-{ $subsection uchar }
-{ $subsection short }
-{ $subsection ushort }
-{ $subsection int }
-{ $subsection uint }
-{ $subsection long }
-{ $subsection ulong }
-{ $subsection longlong }
-{ $subsection ulonglong }
-{ $subsection single-float }
-{ $subsection float }
-{ $subsection single-complex }
-{ $subsection complex }
-{ $subsection pinned-c-ptr }
-"The vocabulary also provides a word for constructing " { $link "specialized-arrays.direct" } " of C types over raw memory:"
-{ $subsection direct-array-of } ;
-
-ABOUT: "classes.c-types"
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: alien alien.c-types classes classes.predicate kernel
-math math.bitwise math.order namespaces sequences words
-specialized-arrays.direct.alien
-specialized-arrays.direct.bool
-specialized-arrays.direct.char
-specialized-arrays.direct.complex-double
-specialized-arrays.direct.complex-float
-specialized-arrays.direct.double
-specialized-arrays.direct.float
-specialized-arrays.direct.int
-specialized-arrays.direct.long
-specialized-arrays.direct.longlong
-specialized-arrays.direct.short
-specialized-arrays.direct.uchar
-specialized-arrays.direct.uint
-specialized-arrays.direct.ulong
-specialized-arrays.direct.ulonglong
-specialized-arrays.direct.ushort ;
-IN: classes.c-types
-
-PREDICATE: char < fixnum
- HEX: -80 HEX: 7f between? ;
-
-PREDICATE: uchar < fixnum
- HEX: 0 HEX: ff between? ;
-
-PREDICATE: short < fixnum
- HEX: -8000 HEX: 7fff between? ;
-
-PREDICATE: ushort < fixnum
- HEX: 0 HEX: ffff between? ;
-
-PREDICATE: int < integer
- HEX: -8000,0000 HEX: 7fff,ffff between? ;
-
-PREDICATE: uint < integer
- HEX: 0 HEX: ffff,ffff between? ;
-
-PREDICATE: longlong < integer
- HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ;
-
-PREDICATE: ulonglong < integer
- HEX: 0 HEX: ffff,ffff,ffff,ffff between? ;
-
-UNION: single-float float ;
-UNION: single-complex complex ;
-
-SYMBOLS: long ulong long-bits ;
-
-<<
- "long" heap-size 8 =
- [
- \ long integer [ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ] define-predicate-class
- \ ulong integer [ HEX: 0 HEX: ffff,ffff,ffff,ffff between? ] define-predicate-class
- 64 \ long-bits set-global
- ] [
- \ long integer [ HEX: -8000,0000 HEX: 7fff,ffff between? ] define-predicate-class
- \ ulong integer [ HEX: 0 HEX: ffff,ffff between? ] define-predicate-class
- 32 \ long-bits set-global
- ] if
->>
-
-: set-class-c-type ( class initial c-type <direct-array> -- )
- [ "initial-value" set-word-prop ]
- [ c-type "class-c-type" set-word-prop ]
- [ "class-direct-array" set-word-prop ] tri-curry* tri ;
-
-: class-c-type ( class -- c-type )
- "class-c-type" word-prop ;
-: class-direct-array ( class -- <direct-array> )
- "class-direct-array" word-prop ;
-
-\ f f "void*" \ <direct-void*-array> set-class-c-type
-pinned-c-ptr f "void*" \ <direct-void*-array> set-class-c-type
-boolean f "bool" \ <direct-bool-array> set-class-c-type
-char 0 "char" \ <direct-char-array> set-class-c-type
-uchar 0 "uchar" \ <direct-uchar-array> set-class-c-type
-short 0 "short" \ <direct-short-array> set-class-c-type
-ushort 0 "ushort" \ <direct-ushort-array> set-class-c-type
-int 0 "int" \ <direct-int-array> set-class-c-type
-uint 0 "uint" \ <direct-uint-array> set-class-c-type
-long 0 "long" \ <direct-long-array> set-class-c-type
-ulong 0 "ulong" \ <direct-ulong-array> set-class-c-type
-longlong 0 "longlong" \ <direct-longlong-array> set-class-c-type
-ulonglong 0 "ulonglong" \ <direct-ulonglong-array> set-class-c-type
-float 0.0 "double" \ <direct-double-array> set-class-c-type
-single-float 0.0 "float" \ <direct-float-array> set-class-c-type
-complex C{ 0.0 0.0 } "complex-double" \ <direct-complex-double-array> set-class-c-type
-single-complex C{ 0.0 0.0 } "complex-float" \ <direct-complex-float-array> set-class-c-type
-
-char [ 8 bits 8 >signed ] "coercer" set-word-prop
-uchar [ 8 bits ] "coercer" set-word-prop
-short [ 16 bits 16 >signed ] "coercer" set-word-prop
-ushort [ 16 bits ] "coercer" set-word-prop
-int [ 32 bits 32 >signed ] "coercer" set-word-prop
-uint [ 32 bits ] "coercer" set-word-prop
-long [ [ bits ] [ >signed ] ] long-bits get-global prefix "coercer" set-word-prop
-ulong [ bits ] long-bits get-global prefix "coercer" set-word-prop
-longlong [ 64 bits 64 >signed ] "coercer" set-word-prop
-ulonglong [ 64 bits ] "coercer" set-word-prop
-
-PREDICATE: c-type-class < class
- "class-c-type" word-prop ;
-
-GENERIC: direct-array-of ( alien len class -- array ) inline
-
-M: c-type-class direct-array-of
- class-direct-array execute( alien len -- array ) ; inline
-
-M: c-type-class c-type class-c-type ;
-M: c-type-class c-type-align class-c-type c-type-align ;
-M: c-type-class c-type-getter class-c-type c-type-getter ;
-M: c-type-class c-type-setter class-c-type c-type-setter ;
-M: c-type-class c-type-boxer-quot class-c-type c-type-boxer-quot ;
-M: c-type-class c-type-unboxer-quot class-c-type c-type-unboxer-quot ;
-M: c-type-class heap-size class-c-type heap-size ;
-
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors assocs classes classes.struct kernel math
-prettyprint.backend prettyprint.custom prettyprint.sections
-see.private sequences words ;
-IN: classes.struct.prettyprint
-
-<PRIVATE
-
-: struct-definer-word ( class -- word )
- struct-slots dup length 2 >=
- [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
- [ drop \ STRUCT: ] if ;
-
-: struct>assoc ( struct -- assoc )
- [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
-
-PRIVATE>
-
-M: struct-class see-class*
- <colon dup struct-definer-word pprint-word dup pprint-word
- <block struct-slots [ pprint-slot ] each
- block> pprint-; block> ;
-
-M: struct pprint-delims
- drop \ S{ \ } ;
-
-M: struct >pprint-sequence
- [ class ] [ struct-slot-values ] bi class-slot-sequence ;
-
-M: struct pprint*
- [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: alien classes help.markup help.syntax kernel libc
-quotations slots ;
-IN: classes.struct
-
-HELP: <struct-boa>
-{ $values
- { "class" class }
-}
-{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
-
-HELP: <struct>
-{ $values
- { "class" class }
- { "struct" struct }
-}
-{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ;
-
-{ <struct> <struct-boa> malloc-struct memory>struct } related-words
-
-HELP: STRUCT:
-{ $syntax "STRUCT: class { slot type } { slot type } ... ;" }
-{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
-{ $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:"
-{ $list
-{ "Struct classes cannot have a superclass defined." }
-{ "The slots of a struct must all have a type declared. The type must be either another struct class, or one of the " { $link "classes.c-types" } "." }
-{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
-} } ;
-
-HELP: S{
-{ $syntax "S{ class slots... }" }
-{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
-{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
-
-HELP: UNION-STRUCT:
-{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
-{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
-{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
-
-HELP: define-struct-class
-{ $values
- { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
-}
-{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
-
-HELP: define-union-struct-class
-{ $values
- { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
-}
-{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ;
-
-HELP: malloc-struct
-{ $values
- { "class" class }
- { "struct" struct }
-}
-{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ;
-
-HELP: memory>struct
-{ $values
- { "ptr" c-ptr } { "class" class }
- { "struct" struct }
-}
-{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
-
-HELP: struct
-{ $class-description "The parent class of all struct types." } ;
-
-{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words
-
-HELP: struct-class
-{ $class-description "The metaclass of all " { $link struct } " classes." } ;
-
-ARTICLE: "classes.struct" "Struct classes"
-{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
-{ $subsection POSTPONE: STRUCT: }
-"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
-{ $subsection <struct> }
-{ $subsection <struct-boa> }
-{ $subsection malloc-struct }
-{ $subsection memory>struct }
-"Structs have literal syntax like tuples:"
-{ $subsection POSTPONE: S{ }
-"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
-{ $subsection POSTPONE: UNION-STRUCT: }
-;
-
-ABOUT: "classes.struct"
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors alien.c-types alien.structs.fields classes.c-types
-classes.struct combinators io.streams.string kernel libc literals math
-multiline namespaces prettyprint prettyprint.config see tools.test ;
-IN: classes.struct.tests
-
-STRUCT: struct-test-foo
- { x char }
- { y int initial: 123 }
- { z boolean } ;
-
-STRUCT: struct-test-bar
- { w ushort initial: HEX: ffff }
- { foo struct-test-foo } ;
-
-[ 12 ] [ struct-test-foo heap-size ] unit-test
-[ 16 ] [ struct-test-bar heap-size ] unit-test
-[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
-[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
-
-[ 1 2 3 t ] [
- 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
- {
- [ w>> ]
- [ foo>> x>> ]
- [ foo>> y>> ]
- [ foo>> z>> ]
- } cleave
-] unit-test
-
-[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
-[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
-
-UNION-STRUCT: struct-test-float-and-bits
- { f single-float }
- { bits uint } ;
-
-[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
-[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
-
-[ ] [ struct-test-foo malloc-struct free ] unit-test
-
-[ "S{ struct-test-foo { y 7654 } }" ]
-[
- f boa-tuples?
- [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
- with-variable
-] unit-test
-
-[ "S{ struct-test-foo f 0 7654 f }" ]
-[
- t boa-tuples?
- [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
- with-variable
-] unit-test
-
-[ <" USING: classes.c-types classes.struct kernel ;
-IN: classes.struct.tests
-STRUCT: struct-test-foo
- { x char initial: 0 } { y int initial: 123 }
- { z boolean initial: f } ;
-"> ]
-[ [ struct-test-foo see ] with-string-writer ] unit-test
-
-[ <" USING: classes.c-types classes.struct ;
-IN: classes.struct.tests
-UNION-STRUCT: struct-test-float-and-bits
- { f single-float initial: 0.0 } { bits uint initial: 0 } ;
-"> ]
-[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
-
-[ {
- T{ field-spec
- { name "x" }
- { offset 0 }
- { type $[ char c-type ] }
- { reader x>> }
- { writer (>>x) }
- }
- T{ field-spec
- { name "y" }
- { offset 4 }
- { type $[ int c-type ] }
- { reader y>> }
- { writer (>>y) }
- }
- T{ field-spec
- { name "z" }
- { offset 8 }
- { type $[ boolean c-type ] }
- { reader z>> }
- { writer (>>z) }
- }
-} ] [ "struct-test-foo" c-type fields>> ] unit-test
-
-[ {
- T{ field-spec
- { name "f" }
- { offset 0 }
- { type $[ single-float c-type ] }
- { reader f>> }
- { writer (>>f) }
- }
- T{ field-spec
- { name "bits" }
- { offset 0 }
- { type $[ uint c-type ] }
- { reader bits>> }
- { writer (>>bits) }
- }
-} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
-
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays
-byte-arrays classes classes.c-types classes.parser classes.tuple
-classes.tuple.parser classes.tuple.private combinators
-combinators.smart fry generalizations generic.parser kernel
-kernel.private libc macros make math math.order parser
-quotations sequences slots slots.private struct-arrays words ;
-FROM: slots => reader-word writer-word ;
-IN: classes.struct
-
-! struct class
-
-TUPLE: struct
- { (underlying) c-ptr read-only } ;
-
-PREDICATE: struct-class < tuple-class
- \ struct subclass-of? ;
-
-: struct-slots ( struct -- slots )
- "struct-slots" word-prop ;
-
-! struct allocation
-
-M: struct >c-ptr
- 2 slot { c-ptr } declare ; inline
-
-: memory>struct ( ptr class -- struct )
- over c-ptr? [ swap \ c-ptr bad-slot-value ] unless
- tuple-layout <tuple> [ 2 set-slot ] keep ;
-
-: malloc-struct ( class -- struct )
- [ heap-size malloc ] keep memory>struct ; inline
-
-: (struct) ( class -- struct )
- [ heap-size <byte-array> ] keep memory>struct ; inline
-
-: <struct> ( class -- struct )
- dup "prototype" word-prop
- [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
-
-MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
- [
- [ <wrapper> \ (struct) [ ] 2sequence ]
- [
- struct-slots
- [ length \ ndip ]
- [ [ name>> setter-word 1quotation ] map \ spread ] bi
- ] bi
- ] [ ] output>sequence ;
-
-: pad-struct-slots ( values class -- values' class )
- [ struct-slots [ initial>> ] map over length tail append ] keep ;
-
-: (reader-quot) ( slot -- quot )
- [ class>> c-type-getter-boxer ]
- [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
-
-: (writer-quot) ( slot -- quot )
- [ class>> c-setter ]
- [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
-
-: (boxer-quot) ( class -- quot )
- '[ _ memory>struct ] ;
-
-: (unboxer-quot) ( class -- quot )
- drop [ >c-ptr ] ;
-
-M: struct-class boa>object
- swap pad-struct-slots
- [ (struct) ] [ struct-slots ] bi
- [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
-
-! Struct slot accessors
-
-GENERIC: struct-slot-values ( struct -- sequence )
-
-M: struct-class reader-quot
- nip (reader-quot) ;
-
-M: struct-class writer-quot
- nip (writer-quot) ;
-
-: struct-slot-values-quot ( class -- quot )
- struct-slots
- [ name>> reader-word 1quotation ] map
- \ cleave [ ] 2sequence
- \ output>array [ ] 2sequence ;
-
-: (define-struct-slot-values-method) ( class -- )
- [ \ struct-slot-values create-method-in ]
- [ struct-slot-values-quot ] bi define ;
-
-! Struct as c-type
-
-: slot>field ( slot -- field )
- field-spec new swap {
- [ name>> >>name ]
- [ offset>> >>offset ]
- [ class>> c-type >>type ]
- [ name>> reader-word >>reader ]
- [ name>> writer-word >>writer ]
- } cleave ;
-
-: define-struct-for-class ( class -- )
- [
- {
- [ name>> ]
- [ "struct-size" word-prop ]
- [ "struct-align" word-prop ]
- [ struct-slots [ slot>field ] map ]
- } cleave
- (define-struct)
- ] [
- [ name>> c-type ]
- [ (unboxer-quot) >>unboxer-quot ]
- [ (boxer-quot) >>boxer-quot ] tri drop
- ] bi ;
-
-: align-offset ( offset class -- offset' )
- c-type-align align ;
-
-: struct-offsets ( slots -- size )
- 0 [
- [ class>> align-offset ] keep
- [ (>>offset) ] [ class>> heap-size + ] 2bi
- ] reduce ;
-
-: union-struct-offsets ( slots -- size )
- [ 0 >>offset class>> heap-size ] [ max ] map-reduce ;
-
-: struct-align ( slots -- align )
- [ class>> c-type-align ] [ max ] map-reduce ;
-
-M: struct-class c-type
- name>> c-type ;
-
-M: struct-class c-type-align
- "struct-align" word-prop ;
-
-M: struct-class c-type-getter
- drop [ swap <displaced-alien> ] ;
-
-M: struct-class c-type-setter
- [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
- '[ @ swap @ _ memcpy ] ;
-
-M: struct-class c-type-boxer-quot
- (boxer-quot) ;
-
-M: struct-class c-type-unboxer-quot
- (unboxer-quot) ;
-
-M: struct-class heap-size
- "struct-size" word-prop ;
-
-M: struct-class direct-array-of
- <direct-struct-array> ;
-
-! class definition
-
-: struct-prototype ( class -- prototype )
- [ heap-size <byte-array> ]
- [ memory>struct ]
- [ struct-slots ] tri
- [
- [ initial>> ]
- [ (writer-quot) ] bi
- over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
- ] each ;
-
-: (struct-word-props) ( class slots size align -- )
- [
- [ "struct-slots" set-word-prop ]
- [ define-accessors ] 2bi
- ]
- [ "struct-size" set-word-prop ]
- [ "struct-align" set-word-prop ] tri-curry*
- [ tri ] 3curry
- [ dup struct-prototype "prototype" set-word-prop ]
- [ (define-struct-slot-values-method) ] tri ;
-
-: check-struct-slots ( slots -- )
- [ class>> c-type drop ] each ;
-
-: (define-struct-class) ( class slots offsets-quot -- )
- [ drop struct f define-tuple-class ]
- swap '[
- make-slots dup
- [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
- (struct-word-props)
- ]
- [ drop define-struct-for-class ] 2tri ; inline
-
-: define-struct-class ( class slots -- )
- [ struct-offsets ] (define-struct-class) ;
-
-: define-union-struct-class ( class slots -- )
- [ union-struct-offsets ] (define-struct-class) ;
-
-: parse-struct-definition ( -- class slots )
- CREATE-CLASS [ parse-tuple-slots ] { } make ;
-
-SYNTAX: STRUCT:
- parse-struct-definition define-struct-class ;
-SYNTAX: UNION-STRUCT:
- parse-struct-definition define-union-struct-class ;
-
-USING: vocabs vocabs.loader ;
-
-"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
-
-SYNTAX: S{
- scan-word dup struct-slots parse-tuple-literal-slots parsed ;
gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images
images.loader io io.encodings.ascii io.files io.files.temp
kernel math math.matrices math.parser math.vectors
-method-chains sequences specialized-arrays.direct.float
-specialized-arrays.float specialized-vectors.uint splitting
+method-chains sequences specialized-arrays.float specialized-vectors.uint splitting
struct-vectors threads ui ui.gadgets ui.gadgets.worlds
ui.pixel-formats ;
IN: gpu.demos.bunny
: calc-bunny-normal ( vertexes indexes -- )
swap
- [ [ nth bunny-vertex-struct-vertex 3 <direct-float-array> ] curry { } map-as normal ]
+ [ [ nth bunny-vertex-struct-vertex ] curry { } map-as normal ]
[
[
- nth [ bunny-vertex-struct-normal 3 <direct-float-array> v+ ] keep
+ nth [ bunny-vertex-struct-normal v+ ] keep
set-bunny-vertex-struct-normal
] curry with each
] 2bi ;
: normalize-bunny-normals ( vertexes -- )
[
- [ bunny-vertex-struct-normal 3 <direct-float-array> normalize ] keep
+ [ bunny-vertex-struct-normal normalize ] keep
set-bunny-vertex-struct-normal
] each ;
USING: assocs html.parser kernel math sequences strings ascii
arrays generalizations shuffle namespaces make
splitting http accessors io combinators http.client urls
-urls.encoding fry prettyprint sets ;
+urls.encoding fry prettyprint sets combinators.short-circuit ;
IN: html.parser.analyzer
TUPLE: link attributes clickable ;
[ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ]
find-between-all ;
+: find-images ( vector -- vector' )
+ [
+ {
+ [ name>> "img" = ]
+ [ attributes>> "src" swap at ]
+ } 1&&
+ ] find-all
+ values [ attributes>> "src" swap at ] map ;
+
: <link> ( vector -- link )
[ first attributes>> ]
[ [ name>> { text "img" } member? ] filter ] bi
--- /dev/null
+! Copyrigt (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators constructors destructors
+images images.loader io io.binary io.buffers
+io.encodings.binary io.encodings.string io.encodings.utf8
+io.files io.files.info io.ports io.streams.limited kernel make
+math math.bitwise math.functions multiline namespaces
+prettyprint sequences ;
+IN: images.gif
+
+SINGLETON: gif-image
+"gif" gif-image register-image-class
+
+TUPLE: loading-gif
+loading?
+magic
+width height
+flags
+background-color
+default-aspect-ratio
+global-color-table
+graphic-control-extensions
+application-extensions
+plain-text-extensions
+comment-extensions
+
+image-descriptor
+local-color-table
+compressed-bytes ;
+
+TUPLE: gif-frame
+image-descriptor
+local-color-table ;
+
+ERROR: unsupported-gif-format magic ;
+ERROR: unknown-extension n ;
+ERROR: gif-unexpected-eof ;
+
+TUPLE: graphics-control-extension
+label block-size raw-data
+packed delay-time color-index
+block-terminator ;
+
+TUPLE: image-descriptor
+separator left top width height flags ;
+
+TUPLE: plain-text-extension
+introducer label block-size text-grid-left text-grid-top text-grid-width
+text-grid-height cell-width cell-height
+text-fg-color-index text-bg-color-index plain-text-data ;
+
+TUPLE: application-extension
+introducer label block-size identifier authentication-code
+application-data ;
+
+TUPLE: comment-extension
+introducer label comment-data ;
+
+TUPLE: trailer byte ;
+CONSTRUCTOR: trailer ( byte -- obj ) ;
+
+CONSTANT: image-descriptor HEX: 2c
+! Extensions
+CONSTANT: extension-identifier HEX: 21
+CONSTANT: plain-text-extension HEX: 01
+CONSTANT: graphic-control-extension HEX: f9
+CONSTANT: comment-extension HEX: fe
+CONSTANT: application-extension HEX: ff
+CONSTANT: trailer HEX: 3b
+
+: <loading-gif> ( -- loading-gif )
+ \ loading-gif new
+ V{ } clone >>graphic-control-extensions
+ V{ } clone >>application-extensions
+ V{ } clone >>plain-text-extensions
+ V{ } clone >>comment-extensions
+ t >>loading? ;
+
+GENERIC: stream-peek1 ( stream -- byte )
+
+M: input-port stream-peek1
+ dup check-disposed dup wait-to-read
+ [ drop f ] [ buffer>> buffer-peek ] if ; inline
+
+: peek1 ( -- byte ) input-stream get stream-peek1 ;
+
+: (read-sub-blocks) ( -- )
+ read1 [ read , (read-sub-blocks) ] unless-zero ;
+
+: read-sub-blocks ( -- bytes )
+ [ (read-sub-blocks) ] { } make B{ } concat-as ;
+
+: read-image-descriptor ( -- image-descriptor )
+ \ image-descriptor new
+ 1 read le> >>separator
+ 2 read le> >>left
+ 2 read le> >>top
+ 2 read le> >>width
+ 2 read le> >>height
+ 1 read le> >>flags ;
+
+: read-graphic-control-extension ( -- graphic-control-extension )
+ \ graphics-control-extension new
+ 1 read le> [ >>block-size ] [ read ] bi
+ >>raw-data
+ 1 read le> >>block-terminator ;
+
+: read-plain-text-extension ( -- plain-text-extension )
+ \ plain-text-extension new
+ 1 read le> >>block-size
+ 2 read le> >>text-grid-left
+ 2 read le> >>text-grid-top
+ 2 read le> >>text-grid-width
+ 2 read le> >>text-grid-height
+ 1 read le> >>cell-width
+ 1 read le> >>cell-height
+ 1 read le> >>text-fg-color-index
+ 1 read le> >>text-bg-color-index
+ read-sub-blocks >>plain-text-data ;
+
+: read-comment-extension ( -- comment-extension )
+ \ comment-extension new
+ read-sub-blocks >>comment-data ;
+
+: read-application-extension ( -- read-application-extension )
+ \ application-extension new
+ 1 read le> >>block-size
+ 8 read utf8 decode >>identifier
+ 3 read >>authentication-code
+ read-sub-blocks >>application-data ;
+
+: read-gif-header ( loading-gif -- loading-gif )
+ 6 read utf8 decode >>magic ;
+
+ERROR: unimplemented message ;
+: read-GIF87a ( loading-gif -- loading-gif )
+ "GIF87a" unimplemented ;
+
+: read-logical-screen-descriptor ( loading-gif -- loading-gif )
+ 2 read le> >>width
+ 2 read le> >>height
+ 1 read le> >>flags
+ 1 read le> >>background-color
+ 1 read le> >>default-aspect-ratio ;
+
+: color-table? ( image -- ? ) flags>> 7 bit? ; inline
+: interlaced? ( image -- ? ) flags>> 6 bit? ; inline
+: sort? ( image -- ? ) flags>> 5 bit? ; inline
+: color-table-size ( image -- ? ) flags>> 3 bits 1 + 2^ 3 * ; inline
+
+: color-resolution ( image -- ? ) flags>> -4 shift 3 bits ; inline
+
+: read-global-color-table ( loading-gif -- loading-gif )
+ dup color-table? [
+ dup color-table-size read >>global-color-table
+ ] when ;
+
+: maybe-read-local-color-table ( loading-gif -- loading-gif )
+ dup image-descriptor>> color-table? [
+ dup color-table-size read >>local-color-table
+ ] when ;
+
+: read-image-data ( loading-gif -- loading-gif )
+ read-sub-blocks >>compressed-bytes ;
+
+: read-table-based-image ( loading-gif -- loading-gif )
+ read-image-descriptor >>image-descriptor
+ maybe-read-local-color-table
+ read-image-data ;
+
+: read-graphic-rendering-block ( loading-gif -- loading-gif )
+ read-table-based-image ;
+
+: read-extension ( loading-gif -- loading-gif )
+ read1 {
+ { plain-text-extension [
+ read-plain-text-extension over plain-text-extensions>> push
+ ] }
+
+ { graphic-control-extension [
+ read-graphic-control-extension
+ over graphic-control-extensions>> push
+ ] }
+ { comment-extension [
+ read-comment-extension over comment-extensions>> push
+ ] }
+ { application-extension [
+ read-application-extension over application-extensions>> push
+ ] }
+ { f [ gif-unexpected-eof ] }
+ [ unknown-extension ]
+ } case ;
+
+ERROR: unhandled-data byte ;
+
+: read-data ( loading-gif -- loading-gif )
+ read1 {
+ { extension-identifier [ read-extension ] }
+ { graphic-control-extension [
+ read-graphic-control-extension
+ over graphic-control-extensions>> push
+ ] }
+ { image-descriptor [ read-table-based-image ] }
+ { trailer [ f >>loading? ] }
+ [ unhandled-data ]
+ } case ;
+
+: read-GIF89a ( loading-gif -- loading-gif )
+ read-logical-screen-descriptor
+ read-global-color-table
+ [ read-data dup loading?>> ] loop ;
+
+: load-gif ( stream -- loading-gif )
+ [
+ <loading-gif>
+ read-gif-header dup magic>> {
+ { "GIF87a" [ read-GIF87a ] }
+ { "GIF89a" [ read-GIF89a ] }
+ [ unsupported-gif-format ]
+ } case
+ ] with-input-stream ;
+
+: loading-gif>image ( loading-gif -- image )
+ ;
+
+ERROR: loading-gif-error gif-image ;
+
+: ensure-loaded ( gif-image -- gif-image )
+ dup loading?>> [ loading-gif-error ] when ;
+
+M: gif-image stream>image ( path gif-image -- image )
+ drop load-gif ensure-loaded loading-gif>image ;
include vm/Config.macosx
include vm/Config.x86.32
+CFLAGS += -m32
-#include <ucontext.h>
+#include <sys/ucontext.h>
namespace factor
{
-#include <ucontext.h>
+#include <sys/ucontext.h>
namespace factor
{
-#include <ucontext.h>
+#include <sys/ucontext.h>
namespace factor
{
projects / factor.git / commitdiff