Merge branch 'master' of git://factorcode.org/git/factor
Marc Fauconneau
commit
2d4ba8de4d
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.strings alien.c-types alien.accessors alien.structs
|
||||
arrays words sequences math kernel namespaces fry libc cpu.architecture
|
||||
io.encodings.utf8 ;
|
||||
io.encodings.utf8 accessors ;
|
||||
IN: alien.arrays
|
||||
|
||||
UNION: value-type array struct-type ;
|
||||
|
|
@ -13,7 +13,10 @@ M: array c-type-class drop object ;
|
|||
|
||||
M: array c-type-boxed-class drop object ;
|
||||
|
||||
M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
|
||||
: array-length ( seq -- n )
|
||||
[ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ;
|
||||
|
||||
M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
|
||||
|
||||
M: array c-type-align first c-type-align ;
|
||||
|
||||
|
|
@ -31,7 +34,7 @@ M: array stack-size drop "void*" stack-size ;
|
|||
|
||||
M: array c-type-boxer-quot
|
||||
unclip
|
||||
[ product ]
|
||||
[ array-length ]
|
||||
[ [ require-c-type-arrays ] keep ] bi*
|
||||
[ <c-type-direct-array> ] 2curry ;
|
||||
|
||||
|
|
|
|||
|
|
@ -49,12 +49,11 @@ HELP: c-setter
|
|||
{ $errors "Throws an error if the type does not exist." } ;
|
||||
|
||||
HELP: <c-array>
|
||||
{ $deprecated "New code should use " { $link <c-type-array> } " or the " { $vocab-link "specialized-arrays" } " vocabularies." }
|
||||
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } }
|
||||
{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
|
||||
{ $errors "Throws an error if the type does not exist or the requested size is negative." } ;
|
||||
|
||||
{ <c-array> malloc-array } related-words
|
||||
|
||||
HELP: <c-object>
|
||||
{ $values { "type" "a C type" } { "array" byte-array } }
|
||||
{ $description "Creates a byte array suitable for holding a value with the given C type." }
|
||||
|
|
@ -73,9 +72,10 @@ HELP: byte-array>memory
|
|||
|
||||
HELP: malloc-array
|
||||
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
|
||||
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." }
|
||||
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-type-direct-array> } "." }
|
||||
{ $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." }
|
||||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if the type does not exist, if the requested size is negative, or if memory allocation fails." } ;
|
||||
{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
|
||||
|
||||
HELP: malloc-object
|
||||
{ $values { "type" "a C type" } { "alien" alien } }
|
||||
|
|
@ -89,6 +89,8 @@ HELP: malloc-byte-array
|
|||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if memory allocation fails." } ;
|
||||
|
||||
{ <c-type-array> <c-type-direct-array> malloc-array } related-words
|
||||
|
||||
HELP: box-parameter
|
||||
{ $values { "n" integer } { "ctype" string } }
|
||||
{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: alien.c-types.tests
|
|||
|
||||
CONSTANT: xyz 123
|
||||
|
||||
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
|
||||
[ 492 ] [ { "int" xyz } heap-size ] unit-test
|
||||
|
||||
[ -1 ] [ -1 <char> *char ] unit-test
|
||||
[ -1 ] [ -1 <short> *short ] unit-test
|
||||
|
|
|
|||
|
|
@ -236,9 +236,9 @@ M: c-type stack-size size>> cell align ;
|
|||
|
||||
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 [
|
||||
|
|
@ -254,16 +254,25 @@ M: f byte-length drop 0 ;
|
|||
] unless* ;
|
||||
|
||||
: <c-array> ( n type -- array )
|
||||
heap-size * <byte-array> ; inline
|
||||
heap-size * <byte-array> ; inline deprecated
|
||||
|
||||
: <c-object> ( type -- array )
|
||||
1 swap <c-array> ; inline
|
||||
heap-size <byte-array> ; inline
|
||||
|
||||
: (c-object) ( type -- array )
|
||||
heap-size (byte-array) ; inline
|
||||
|
||||
: malloc-array ( n type -- alien )
|
||||
heap-size calloc ; inline
|
||||
[ heap-size calloc ] [ <c-type-direct-array> ] 2bi ; inline
|
||||
|
||||
: (malloc-array) ( n type -- alien )
|
||||
[ heap-size * malloc ] [ <c-type-direct-array> ] 2bi ; inline
|
||||
|
||||
: malloc-object ( type -- alien )
|
||||
1 swap malloc-array ; inline
|
||||
1 swap heap-size calloc ; inline
|
||||
|
||||
: (malloc-object) ( type -- alien )
|
||||
heap-size malloc ; inline
|
||||
|
||||
: malloc-byte-array ( byte-array -- alien )
|
||||
dup byte-length [ nip malloc dup ] 2keep memcpy ;
|
||||
|
|
@ -281,7 +290,7 @@ M: memory-stream stream-read
|
|||
] [ [ + ] 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 )
|
||||
[
|
||||
|
|
@ -326,17 +335,6 @@ M: long-long-type box-return ( type -- )
|
|||
[ define-out ]
|
||||
tri ;
|
||||
|
||||
: expand-constants ( c-type -- c-type' )
|
||||
dup array? [
|
||||
unclip [
|
||||
[
|
||||
dup word? [
|
||||
def>> call( -- object )
|
||||
] when
|
||||
] map
|
||||
] dip prefix
|
||||
] when ;
|
||||
|
||||
: malloc-file-contents ( path -- alien len )
|
||||
binary file-contents [ malloc-byte-array ] [ length ] bi ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,22 +1,21 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test alien.complex kernel alien.c-types alien.syntax
|
||||
namespaces math ;
|
||||
USING: accessors tools.test alien.complex classes.struct kernel
|
||||
alien.c-types alien.syntax namespaces math ;
|
||||
IN: alien.complex.tests
|
||||
|
||||
C-STRUCT: complex-holder
|
||||
{ "complex-float" "z" } ;
|
||||
STRUCT: complex-holder
|
||||
{ z complex-float } ;
|
||||
|
||||
: <complex-holder> ( z -- alien )
|
||||
"complex-holder" <c-object>
|
||||
[ set-complex-holder-z ] keep ;
|
||||
complex-holder <struct-boa> ;
|
||||
|
||||
[ ] [
|
||||
C{ 1.0 2.0 } <complex-holder> "h" set
|
||||
] unit-test
|
||||
|
||||
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
|
||||
[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
|
||||
|
||||
[ number ] [ "complex-float" c-type-boxed-class ] unit-test
|
||||
|
||||
[ number ] [ "complex-double" c-type-boxed-class ] unit-test
|
||||
[ number ] [ "complex-double" c-type-boxed-class ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,33 +1,28 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.structs alien.c-types math math.functions sequences
|
||||
arrays kernel functors vocabs.parser namespaces accessors
|
||||
quotations ;
|
||||
USING: accessors alien alien.structs alien.c-types classes.struct math
|
||||
math.functions sequences arrays kernel functors vocabs.parser
|
||||
namespaces quotations ;
|
||||
IN: alien.complex.functor
|
||||
|
||||
FUNCTOR: define-complex-type ( N T -- )
|
||||
|
||||
T-real DEFINES ${T}-real
|
||||
T-imaginary DEFINES ${T}-imaginary
|
||||
set-T-real DEFINES set-${T}-real
|
||||
set-T-imaginary DEFINES set-${T}-imaginary
|
||||
T-class DEFINES-CLASS ${T}
|
||||
|
||||
<T> DEFINES <${T}>
|
||||
*T DEFINES *${T}
|
||||
|
||||
WHERE
|
||||
|
||||
STRUCT: T-class { real N } { imaginary N } ;
|
||||
|
||||
: <T> ( z -- alien )
|
||||
>rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
|
||||
>rect T-class <struct-boa> >c-ptr ;
|
||||
|
||||
: *T ( alien -- z )
|
||||
[ T-real ] [ T-imaginary ] bi rect> ; inline
|
||||
T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline
|
||||
|
||||
T current-vocab
|
||||
{ { N "real" } { N "imaginary" } }
|
||||
define-struct
|
||||
|
||||
T c-type
|
||||
T-class c-type
|
||||
<T> 1quotation >>unboxer-quot
|
||||
*T 1quotation >>boxer-quot
|
||||
number >>boxed-class
|
||||
|
|
|
|||
|
|
@ -7,16 +7,16 @@ IN: alien.structs.fields
|
|||
TUPLE: field-spec name offset type reader writer ;
|
||||
|
||||
: reader-word ( class name vocab -- word )
|
||||
[ "-" glue ] dip create ;
|
||||
[ "-" glue ] dip create dup make-deprecated ;
|
||||
|
||||
: writer-word ( class name vocab -- word )
|
||||
[ [ swap "set-" % % "-" % % ] "" make ] dip create ;
|
||||
[ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ;
|
||||
|
||||
: <field-spec> ( struct-name vocab type field-name -- spec )
|
||||
field-spec new
|
||||
0 >>offset
|
||||
swap >>name
|
||||
swap expand-constants >>type
|
||||
swap >>type
|
||||
3dup name>> swap reader-word >>reader
|
||||
3dup name>> swap writer-word >>writer
|
||||
2nip ;
|
||||
|
|
|
|||
|
|
@ -30,4 +30,4 @@ ARTICLE: "c-unions" "C unions"
|
|||
{ $subsection POSTPONE: C-UNION: }
|
||||
"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
||||
$nl
|
||||
"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
|
||||
"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
|
||||
|
|
|
|||
|
|
@ -55,12 +55,11 @@ M: struct-type stack-size
|
|||
[ struct-offsets ] keep
|
||||
[ [ type>> ] map compute-struct-align ] keep
|
||||
[ struct-type (define-struct) ] keep
|
||||
[ define-field ] each ;
|
||||
[ define-field ] each ; deprecated
|
||||
|
||||
: define-union ( name members -- )
|
||||
[ expand-constants ] map
|
||||
[ [ heap-size ] [ max ] map-reduce ] keep
|
||||
compute-struct-align f struct-type (define-struct) ;
|
||||
compute-struct-align f struct-type (define-struct) ; deprecated
|
||||
|
||||
: offset-of ( field struct -- offset )
|
||||
c-types get at fields>>
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: alien.syntax
|
||||
USING: alien alien.c-types alien.parser alien.structs
|
||||
help.markup help.syntax ;
|
||||
classes.struct help.markup help.syntax ;
|
||||
|
||||
HELP: DLL"
|
||||
{ $syntax "DLL\" path\"" }
|
||||
|
|
@ -55,12 +55,14 @@ HELP: TYPEDEF:
|
|||
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
|
||||
|
||||
HELP: C-STRUCT:
|
||||
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." }
|
||||
{ $syntax "C-STRUCT: name pairs... ;" }
|
||||
{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
|
||||
{ $description "Defines a C struct layout and accessor words." }
|
||||
{ $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
|
||||
|
||||
HELP: C-UNION:
|
||||
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." }
|
||||
{ $syntax "C-UNION: name members... ;" }
|
||||
{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
|
||||
{ $description "Defines a new C type sized to fit its largest member." }
|
||||
|
|
|
|||
|
|
@ -22,10 +22,10 @@ SYNTAX: TYPEDEF:
|
|||
scan scan typedef ;
|
||||
|
||||
SYNTAX: C-STRUCT:
|
||||
scan current-vocab parse-definition define-struct ;
|
||||
scan current-vocab parse-definition define-struct ; deprecated
|
||||
|
||||
SYNTAX: C-UNION:
|
||||
scan parse-definition define-union ;
|
||||
scan parse-definition define-union ; deprecated
|
||||
|
||||
SYNTAX: C-ENUM:
|
||||
";" parse-tokens
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ M: bit-array resize
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: accessors assocs classes classes.struct combinators
|
||||
kernel math prettyprint.backend prettyprint.custom
|
||||
prettyprint.sections see.private sequences words ;
|
||||
prettyprint.sections see.private sequences strings words ;
|
||||
IN: classes.struct.prettyprint
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -18,7 +18,7 @@ IN: classes.struct.prettyprint
|
|||
<flow \ { pprint-word
|
||||
{
|
||||
[ name>> text ]
|
||||
[ c-type>> text ]
|
||||
[ c-type>> dup string? [ text ] [ pprint* ] if ]
|
||||
[ read-only>> [ \ read-only pprint-word ] when ]
|
||||
[ initial>> [ \ initial: pprint-word pprint* ] when* ]
|
||||
} cleave
|
||||
|
|
|
|||
|
|
@ -9,6 +9,15 @@ HELP: <struct-boa>
|
|||
}
|
||||
{ $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 left uninitialized; in most cases, the " { $link <struct> } " word, which initializes the struct's slots with their initial values, should be used instead." } ;
|
||||
|
||||
{ (struct) (malloc-struct) } related-words
|
||||
|
||||
HELP: <struct>
|
||||
{ $values
|
||||
{ "class" class }
|
||||
|
|
@ -40,13 +49,13 @@ HELP: UNION-STRUCT:
|
|||
|
||||
HELP: define-struct-class
|
||||
{ $values
|
||||
{ "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
|
||||
{ "class" class } { "slots" "a sequence of " { $link struct-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" }
|
||||
{ "class" class } { "slots" "a sequence of " { $link struct-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." } ;
|
||||
|
||||
|
|
@ -55,7 +64,14 @@ HELP: malloc-struct
|
|||
{ "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." } ;
|
||||
{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized to their initial values. The struct should be " { $link free } "d when it is no longer needed." } ;
|
||||
|
||||
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; to initialize the allocated memory with the slots' initial values, use " { $link malloc-struct } ". The struct should be " { $link free } "d when it is no longer needed." } ;
|
||||
|
||||
HELP: memory>struct
|
||||
{ $values
|
||||
|
|
@ -80,6 +96,9 @@ ARTICLE: "classes.struct" "Struct classes"
|
|||
{ $subsection <struct-boa> }
|
||||
{ $subsection malloc-struct }
|
||||
{ $subsection memory>struct }
|
||||
"When the contents of a struct will be immediately reset, faster primitive words are available that will create a struct without initializing its contents:"
|
||||
{ $subsection (struct) }
|
||||
{ $subsection (malloc-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."
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: accessors alien.c-types alien.libraries
|
||||
USING: accessors alien 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
|
||||
|
|
@ -63,7 +63,7 @@ UNION-STRUCT: struct-test-float-and-bits
|
|||
[ 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
|
||||
[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
|
||||
|
||||
STRUCT: struct-test-string-ptr
|
||||
{ x char* } ;
|
||||
|
|
@ -187,7 +187,7 @@ STRUCT: struct-test-array-slots
|
|||
] unit-test
|
||||
|
||||
STRUCT: struct-test-optimization
|
||||
{ x int[3] } { y int } ;
|
||||
{ x { "int" 3 } } { y int } ;
|
||||
|
||||
[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
|
||||
[ t ] [
|
||||
|
|
@ -203,3 +203,5 @@ STRUCT: struct-test-optimization
|
|||
] unit-test
|
||||
|
||||
[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
|
||||
|
||||
[ f ] [ struct-test-foo <struct> dup clone [ >c-ptr ] bi@ eq? ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,11 +2,11 @@
|
|||
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 ;
|
||||
combinators combinators.short-circuit combinators.smart
|
||||
functors.backend fry generalizations generic.parser kernel
|
||||
kernel.private lexer libc locals 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
|
||||
|
||||
|
|
@ -37,6 +37,8 @@ M: struct equal?
|
|||
[ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
|
||||
} 2&& ;
|
||||
|
||||
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
|
||||
|
||||
: memory>struct ( ptr class -- struct )
|
||||
[ 1array ] dip slots>tuple ;
|
||||
|
||||
|
|
@ -44,17 +46,25 @@ M: struct equal?
|
|||
dup struct-class? [ '[ _ boa ] ] [ drop f ] if
|
||||
] 1 define-partial-eval
|
||||
|
||||
: malloc-struct ( class -- struct )
|
||||
M: struct clone
|
||||
[ >c-ptr ] [ byte-length memory>byte-array ] [ class memory>struct ] tri ;
|
||||
|
||||
<PRIVATE
|
||||
: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
|
||||
'[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline
|
||||
PRIVATE>
|
||||
|
||||
: (malloc-struct) ( class -- struct )
|
||||
[ heap-size malloc ] keep memory>struct ; inline
|
||||
|
||||
: (struct) ( class -- struct )
|
||||
[ heap-size <byte-array> ] keep memory>struct ; inline
|
||||
: malloc-struct ( class -- struct )
|
||||
[ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ;
|
||||
|
||||
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
|
||||
: (struct) ( class -- struct )
|
||||
[ heap-size (byte-array) ] keep memory>struct ; inline
|
||||
|
||||
: <struct> ( class -- struct )
|
||||
dup struct-prototype
|
||||
[ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
|
||||
[ >c-ptr clone ] [ heap-size <byte-array> ] (init-struct) ;
|
||||
|
||||
MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
|
||||
[
|
||||
|
|
@ -66,6 +76,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
|
|||
] bi
|
||||
] [ ] output>sequence ;
|
||||
|
||||
<PRIVATE
|
||||
: pad-struct-slots ( values class -- values' class )
|
||||
[ struct-slots [ initial>> ] map over length tail append ] keep ;
|
||||
|
||||
|
|
@ -82,6 +93,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
|
|||
|
||||
: (unboxer-quot) ( class -- quot )
|
||||
drop [ >c-ptr ] ;
|
||||
PRIVATE>
|
||||
|
||||
M: struct-class boa>object
|
||||
swap pad-struct-slots
|
||||
|
|
@ -98,6 +110,9 @@ M: struct-class reader-quot
|
|||
M: struct-class writer-quot
|
||||
nip (writer-quot) ;
|
||||
|
||||
! c-types
|
||||
|
||||
<PRIVATE
|
||||
: struct-slot-values-quot ( class -- quot )
|
||||
struct-slots
|
||||
[ name>> reader-word 1quotation ] map
|
||||
|
|
@ -112,8 +127,6 @@ M: struct-class writer-quot
|
|||
[ \ 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 ]
|
||||
|
|
@ -155,6 +168,7 @@ M: struct-class writer-quot
|
|||
|
||||
: struct-align ( slots -- align )
|
||||
[ c-type>> c-type-align ] [ max ] map-reduce ;
|
||||
PRIVATE>
|
||||
|
||||
M: struct-class c-type
|
||||
name>> c-type ;
|
||||
|
|
@ -180,6 +194,7 @@ M: struct-class heap-size
|
|||
|
||||
! class definition
|
||||
|
||||
<PRIVATE
|
||||
: make-struct-prototype ( class -- prototype )
|
||||
[ heap-size <byte-array> ]
|
||||
[ memory>struct ]
|
||||
|
|
@ -219,6 +234,7 @@ M: struct-class heap-size
|
|||
(struct-word-props)
|
||||
]
|
||||
[ drop define-struct-for-class ] 2tri ; inline
|
||||
PRIVATE>
|
||||
|
||||
: define-struct-class ( class slots -- )
|
||||
[ struct-offsets ] (define-struct-class) ;
|
||||
|
|
@ -228,14 +244,18 @@ M: struct-class heap-size
|
|||
|
||||
ERROR: invalid-struct-slot token ;
|
||||
|
||||
<PRIVATE
|
||||
: struct-slot-class ( c-type -- class' )
|
||||
c-type c-type-boxed-class
|
||||
dup \ byte-array = [ drop \ c-ptr ] when ;
|
||||
|
||||
: scan-c-type ( -- c-type )
|
||||
scan dup "{" = [ drop \ } parse-until >array ] when ;
|
||||
|
||||
: parse-struct-slot ( -- slot )
|
||||
struct-slot-spec new
|
||||
scan >>name
|
||||
scan [ >>c-type ] [ struct-slot-class >>class ] bi
|
||||
scan-c-type [ >>c-type ] [ struct-slot-class >>class ] bi
|
||||
\ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ;
|
||||
|
||||
: parse-struct-slots ( slots -- slots' more? )
|
||||
|
|
@ -247,6 +267,7 @@ ERROR: invalid-struct-slot token ;
|
|||
|
||||
: parse-struct-definition ( -- class slots )
|
||||
CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: STRUCT:
|
||||
parse-struct-definition define-struct-class ;
|
||||
|
|
@ -256,6 +277,38 @@ SYNTAX: UNION-STRUCT:
|
|||
SYNTAX: S{
|
||||
scan-word dup struct-slots parse-tuple-literal-slots parsed ;
|
||||
|
||||
! functor support
|
||||
|
||||
<PRIVATE
|
||||
: scan-c-type` ( -- c-type/param )
|
||||
scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
|
||||
|
||||
:: parse-struct-slot` ( accum -- accum )
|
||||
scan-string-param :> name
|
||||
scan-c-type` :> c-type
|
||||
\ } parse-until :> attributes
|
||||
accum {
|
||||
\ struct-slot-spec new
|
||||
name >>name
|
||||
c-type [ >>c-type ] [ struct-slot-class >>class ] bi
|
||||
attributes [ dup empty? ] [ peel-off-attributes ] until drop
|
||||
over push
|
||||
} over push-all ;
|
||||
|
||||
: parse-struct-slots` ( accum -- accum more? )
|
||||
scan {
|
||||
{ ";" [ f ] }
|
||||
{ "{" [ parse-struct-slot` t ] }
|
||||
[ invalid-struct-slot ]
|
||||
} case ;
|
||||
PRIVATE>
|
||||
|
||||
FUNCTOR-SYNTAX: STRUCT:
|
||||
scan-param parsed
|
||||
[ 8 <vector> ] over push-all
|
||||
[ parse-struct-slots` ] [ ] while
|
||||
[ >array define-struct-class ] over push-all ;
|
||||
|
||||
USING: vocabs vocabs.loader ;
|
||||
|
||||
"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ NSApplicationDelegateReplyFailure ;
|
|||
|
||||
: NSApp ( -- app ) NSApplication -> sharedApplication ;
|
||||
|
||||
: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
|
||||
CONSTANT: NSAnyEventMask HEX: ffffffff
|
||||
|
||||
FUNCTION: void NSBeep ( ) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,27 +1,28 @@
|
|||
! Copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel cocoa cocoa.types alien.c-types locals math
|
||||
sequences vectors fry libc destructors
|
||||
specialized-arrays.direct.alien ;
|
||||
USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types
|
||||
locals math sequences vectors fry libc destructors ;
|
||||
IN: cocoa.enumeration
|
||||
|
||||
<< "id" require-c-type-arrays >>
|
||||
|
||||
CONSTANT: NS-EACH-BUFFER-SIZE 16
|
||||
|
||||
: with-enumeration-buffers ( quot -- )
|
||||
'[
|
||||
"NSFastEnumerationState" malloc-object &free
|
||||
NSFastEnumerationState malloc-struct &free
|
||||
NS-EACH-BUFFER-SIZE "id" malloc-array &free
|
||||
NS-EACH-BUFFER-SIZE
|
||||
@
|
||||
] with-destructors ; inline
|
||||
|
||||
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
|
||||
object state stackbuf count -> countByEnumeratingWithState:objects:count:
|
||||
dup 0 = [ drop ] [
|
||||
state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
|
||||
swap <direct-void*-array> quot each
|
||||
object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
|
||||
items-count 0 = [
|
||||
state itemsPtr>> [ items-count "id" <c-type-direct-array> ] [ stackbuf ] if* :> items
|
||||
items-count iota [ items nth quot call ] each
|
||||
object quot state stackbuf count (NSFastEnumeration-each)
|
||||
] if ; inline recursive
|
||||
] unless ; inline recursive
|
||||
|
||||
: NSFastEnumeration-each ( object quot -- )
|
||||
[ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types alien.strings arrays assocs
|
||||
continuations combinators compiler compiler.alien stack-checker kernel
|
||||
math namespaces make quotations sequences strings words
|
||||
cocoa.runtime io macros memoize io.encodings.utf8 effects libc
|
||||
libc.private lexer init core-foundation fry generalizations
|
||||
specialized-arrays.direct.alien ;
|
||||
classes.struct continuations combinators compiler compiler.alien
|
||||
stack-checker kernel math namespaces make quotations sequences
|
||||
strings words cocoa.runtime io macros memoize io.encodings.utf8
|
||||
effects libc libc.private lexer init core-foundation fry
|
||||
generalizations specialized-arrays.direct.alien ;
|
||||
IN: cocoa.messages
|
||||
|
||||
: make-sender ( method function -- quot )
|
||||
|
|
@ -31,11 +31,8 @@ super-message-senders [ H{ } clone ] initialize
|
|||
bi ;
|
||||
|
||||
: <super> ( receiver -- super )
|
||||
"objc-super" <c-object> [
|
||||
[ dup object_getClass class_getSuperclass ] dip
|
||||
set-objc-super-class
|
||||
] keep
|
||||
[ set-objc-super-receiver ] keep ;
|
||||
[ ] [ object_getClass class_getSuperclass ] bi
|
||||
objc-super <struct-boa> ;
|
||||
|
||||
TUPLE: selector name object ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax ;
|
||||
USING: alien.syntax classes.struct ;
|
||||
IN: cocoa.runtime
|
||||
|
||||
TYPEDEF: void* SEL
|
||||
|
|
@ -17,9 +17,9 @@ TYPEDEF: void* Class
|
|||
TYPEDEF: void* Method
|
||||
TYPEDEF: void* Protocol
|
||||
|
||||
C-STRUCT: objc-super
|
||||
{ "id" "receiver" }
|
||||
{ "Class" "class" } ;
|
||||
STRUCT: objc-super
|
||||
{ receiver id }
|
||||
{ class Class } ;
|
||||
|
||||
CONSTANT: CLS_CLASS HEX: 1
|
||||
CONSTANT: CLS_META HEX: 2
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.syntax combinators kernel layouts
|
||||
core-graphics.types ;
|
||||
classes.struct core-graphics.types ;
|
||||
IN: cocoa.types
|
||||
|
||||
TYPEDEF: long NSInteger
|
||||
|
|
@ -16,9 +16,9 @@ TYPEDEF: NSSize _NSSize
|
|||
TYPEDEF: CGRect NSRect
|
||||
TYPEDEF: NSRect _NSRect
|
||||
|
||||
C-STRUCT: NSRange
|
||||
{ "NSUInteger" "location" }
|
||||
{ "NSUInteger" "length" } ;
|
||||
STRUCT: NSRange
|
||||
{ location NSUInteger }
|
||||
{ length NSUInteger } ;
|
||||
|
||||
TYPEDEF: NSRange _NSRange
|
||||
|
||||
|
|
@ -27,13 +27,11 @@ TYPEDEF: int long32
|
|||
TYPEDEF: uint ulong32
|
||||
TYPEDEF: void* unknown_type
|
||||
|
||||
: <NSRange> ( length location -- size )
|
||||
"NSRange" <c-object>
|
||||
[ set-NSRange-length ] keep
|
||||
[ set-NSRange-location ] keep ;
|
||||
: <NSRange> ( location length -- size )
|
||||
NSRange <struct-boa> ;
|
||||
|
||||
C-STRUCT: NSFastEnumerationState
|
||||
{ "ulong" "state" }
|
||||
{ "id*" "itemsPtr" }
|
||||
{ "ulong*" "mutationsPtr" }
|
||||
{ "ulong[5]" "extra" } ;
|
||||
STRUCT: NSFastEnumerationState
|
||||
{ state ulong }
|
||||
{ itemsPtr id* }
|
||||
{ mutationsPtr ulong* }
|
||||
{ extra ulong[5] } ;
|
||||
|
|
|
|||
|
|
@ -58,6 +58,6 @@ CONSTANT: NSOpenGLCPSwapInterval 222
|
|||
: mouse-location ( view event -- loc )
|
||||
[
|
||||
-> locationInWindow f -> convertPoint:fromView:
|
||||
[ CGPoint-x ] [ CGPoint-y ] bi
|
||||
[ x>> ] [ y>> ] bi
|
||||
] [ drop -> frame CGRect-h ] 2bi
|
||||
swap - [ >integer ] bi@ 2array ;
|
||||
|
|
|
|||
|
|
@ -184,4 +184,10 @@ IN: compiler.cfg.builder.tests
|
|||
[ f ] [
|
||||
[ 1000 [ ] times ]
|
||||
[ [ ##peek? ] [ ##replace? ] bi or ] contains-insn?
|
||||
] unit-test
|
||||
|
||||
[ f t ] [
|
||||
[ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
|
||||
[ [ ##unbox-any-c-ptr? ] contains-insn? ]
|
||||
[ [ ##slot-imm? ] contains-insn? ] bi
|
||||
] unit-test
|
||||
|
|
@ -35,6 +35,8 @@ IN: compiler.cfg.hats
|
|||
: ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline
|
||||
: ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline
|
||||
: ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; inline
|
||||
: ^^min ( src1 src2 -- dst ) ^^r2 ##min ; inline
|
||||
: ^^max ( src1 src2 -- dst ) ^^r2 ##max ; inline
|
||||
: ^^not ( src -- dst ) ^^r1 ##not ; inline
|
||||
: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline
|
||||
: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline
|
||||
|
|
@ -43,6 +45,8 @@ IN: compiler.cfg.hats
|
|||
: ^^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
|
||||
: ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline
|
||||
: ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-float ; inline
|
||||
: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
|
||||
: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
|
||||
: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
|
||||
|
|
@ -51,7 +55,8 @@ IN: compiler.cfg.hats
|
|||
: ^^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
|
||||
: ^^box-displaced-alien ( base displacement base-class -- dst )
|
||||
^^r3 [ next-vreg ] dip ##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
|
||||
|
|
|
|||
|
|
@ -91,6 +91,8 @@ INSN: ##shr < ##binary ;
|
|||
INSN: ##shr-imm < ##binary-imm ;
|
||||
INSN: ##sar < ##binary ;
|
||||
INSN: ##sar-imm < ##binary-imm ;
|
||||
INSN: ##min < ##binary ;
|
||||
INSN: ##max < ##binary ;
|
||||
INSN: ##not < ##unary ;
|
||||
INSN: ##log2 < ##unary ;
|
||||
|
||||
|
|
@ -106,6 +108,8 @@ INSN: ##add-float < ##commutative ;
|
|||
INSN: ##sub-float < ##binary ;
|
||||
INSN: ##mul-float < ##commutative ;
|
||||
INSN: ##div-float < ##binary ;
|
||||
INSN: ##min-float < ##binary ;
|
||||
INSN: ##max-float < ##binary ;
|
||||
INSN: ##sqrt < ##unary ;
|
||||
|
||||
! Float/integer conversion
|
||||
|
|
@ -118,7 +122,7 @@ INSN: ##unbox-float < ##unary ;
|
|||
INSN: ##unbox-any-c-ptr < ##unary/temp ;
|
||||
INSN: ##box-float < ##unary/temp ;
|
||||
INSN: ##box-alien < ##unary/temp ;
|
||||
INSN: ##box-displaced-alien < ##binary temp ;
|
||||
INSN: ##box-displaced-alien < ##binary temp base-class ;
|
||||
|
||||
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
|
||||
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
|
||||
|
|
@ -153,7 +157,12 @@ INSN: ##set-alien-double < ##alien-setter ;
|
|||
! 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 ;
|
||||
|
||||
|
|
@ -258,6 +267,8 @@ UNION: output-float-insn
|
|||
##sub-float
|
||||
##mul-float
|
||||
##div-float
|
||||
##min-float
|
||||
##max-float
|
||||
##sqrt
|
||||
##integer>float
|
||||
##unbox-float
|
||||
|
|
@ -270,6 +281,8 @@ UNION: input-float-insn
|
|||
##sub-float
|
||||
##mul-float
|
||||
##div-float
|
||||
##min-float
|
||||
##max-float
|
||||
##sqrt
|
||||
##float>integer
|
||||
##box-float
|
||||
|
|
|
|||
|
|
@ -14,10 +14,11 @@ IN: compiler.cfg.intrinsics.alien
|
|||
} 1&& ;
|
||||
|
||||
: emit-<displaced-alien> ( node -- )
|
||||
dup emit-<displaced-alien>?
|
||||
[ drop 2inputs [ ^^untag-fixnum ] dip ^^box-displaced-alien ds-push ]
|
||||
[ emit-primitive ]
|
||||
if ;
|
||||
dup emit-<displaced-alien>? [
|
||||
[ 2inputs [ ^^untag-fixnum ] dip ] dip
|
||||
node-input-infos second class>>
|
||||
^^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 ;
|
||||
|
|
|
|||
|
|
@ -21,9 +21,13 @@ QUALIFIED: strings.private
|
|||
QUALIFIED: classes.tuple.private
|
||||
QUALIFIED: math.private
|
||||
QUALIFIED: math.integers.private
|
||||
QUALIFIED: math.floats.private
|
||||
QUALIFIED: math.libm
|
||||
IN: compiler.cfg.intrinsics
|
||||
|
||||
: enable-intrinsics ( words -- )
|
||||
[ t "intrinsic" set-word-prop ] each ;
|
||||
|
||||
{
|
||||
kernel.private:tag
|
||||
kernel.private:getenv
|
||||
|
|
@ -66,7 +70,7 @@ IN: compiler.cfg.intrinsics
|
|||
alien.accessors:set-alien-signed-2
|
||||
alien.accessors:alien-cell
|
||||
alien.accessors:set-alien-cell
|
||||
} [ t "intrinsic" set-word-prop ] each
|
||||
} enable-intrinsics
|
||||
|
||||
: enable-alien-4-intrinsics ( -- )
|
||||
{
|
||||
|
|
@ -74,7 +78,7 @@ IN: compiler.cfg.intrinsics
|
|||
alien.accessors:set-alien-unsigned-4
|
||||
alien.accessors:alien-signed-4
|
||||
alien.accessors:set-alien-signed-4
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-float-intrinsics ( -- )
|
||||
{
|
||||
|
|
@ -93,13 +97,25 @@ IN: compiler.cfg.intrinsics
|
|||
alien.accessors:set-alien-float
|
||||
alien.accessors:alien-double
|
||||
alien.accessors:set-alien-double
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-fsqrt ( -- )
|
||||
\ math.libm:fsqrt t "intrinsic" set-word-prop ;
|
||||
|
||||
: enable-float-min/max ( -- )
|
||||
{
|
||||
math.floats.private:float-min
|
||||
math.floats.private:float-max
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-min/max ( -- )
|
||||
{
|
||||
math.integers.private:fixnum-min
|
||||
math.integers.private:fixnum-max
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-fixnum-log2 ( -- )
|
||||
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
|
||||
{ math.integers.private:fixnum-log2 } enable-intrinsics ;
|
||||
|
||||
: emit-intrinsic ( node word -- )
|
||||
{
|
||||
|
|
@ -123,6 +139,8 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
|
||||
{ \ kernel:eq? [ drop cc= emit-fixnum-comparison ] }
|
||||
{ \ math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] }
|
||||
{ \ math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] }
|
||||
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
|
||||
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
|
||||
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
|
||||
|
|
@ -136,6 +154,8 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ 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.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
|
||||
{ \ math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
|
||||
{ \ math.libm:fsqrt [ drop emit-fsqrt ] }
|
||||
{ \ slots.private:slot [ emit-slot ] }
|
||||
{ \ slots.private:set-slot [ emit-set-slot ] }
|
||||
|
|
|
|||
|
|
@ -35,11 +35,15 @@ UNION: two-operand-insn
|
|||
##shr-imm
|
||||
##sar
|
||||
##sar-imm
|
||||
##min
|
||||
##max
|
||||
##fixnum-overflow
|
||||
##add-float
|
||||
##sub-float
|
||||
##mul-float
|
||||
##div-float ;
|
||||
##div-float
|
||||
##min-float
|
||||
##max-float ;
|
||||
|
||||
GENERIC: convert-two-operand* ( insn -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ TUPLE: commutative-expr < binary-expr ;
|
|||
TUPLE: compare-expr < binary-expr cc ;
|
||||
TUPLE: constant-expr < expr value ;
|
||||
TUPLE: reference-expr < expr value ;
|
||||
TUPLE: box-displaced-alien-expr < expr displacement base base-class ;
|
||||
|
||||
: <constant> ( constant -- expr )
|
||||
f swap constant-expr boa ; inline
|
||||
|
|
@ -85,6 +86,14 @@ M: ##compare-imm >expr compare-imm>expr ;
|
|||
|
||||
M: ##compare-float >expr compare>expr ;
|
||||
|
||||
M: ##box-displaced-alien >expr
|
||||
{
|
||||
[ class ]
|
||||
[ src1>> vreg>vn ]
|
||||
[ src2>> vreg>vn ]
|
||||
[ base-class>> ]
|
||||
} cleave box-displaced-alien-expr boa ;
|
||||
|
||||
M: ##flushable >expr drop next-input-expr ;
|
||||
|
||||
: init-expressions ( -- )
|
||||
|
|
|
|||
|
|
@ -354,18 +354,18 @@ 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 <class>
|
||||
! ##unbox-c-ptr 4 1 <class>
|
||||
! =>
|
||||
! ##box-displaced-alien f 1 2 3
|
||||
! ##unbox-any-c-ptr 5 3
|
||||
! ##box-displaced-alien f 1 2 3 <class>
|
||||
! ##unbox-c-ptr 5 3 <class>
|
||||
! ##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
|
||||
temp expr base>> vn>vreg expr base-class>> insn temp>> ##unbox-c-ptr
|
||||
insn dst>> temp expr displacement>> vn>vreg ##add
|
||||
] { } make ;
|
||||
|
||||
M: ##unbox-any-c-ptr rewrite
|
||||
|
|
|
|||
|
|
@ -87,12 +87,6 @@ M: unary-expr simplify*
|
|||
[ 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 ] }
|
||||
|
|
@ -113,10 +107,15 @@ M: binary-expr simplify*
|
|||
{ \ ##sar-imm [ simplify-shr ] }
|
||||
{ \ ##shl [ simplify-shl ] }
|
||||
{ \ ##shl-imm [ simplify-shl ] }
|
||||
{ \ ##box-displaced-alien [ simplify-box-displaced-alien ] }
|
||||
[ 2drop f ]
|
||||
} case ;
|
||||
|
||||
M: box-displaced-alien-expr simplify*
|
||||
[ base>> ] [ displacement>> ] bi {
|
||||
{ [ dup vn>expr expr-zero? ] [ drop ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
M: expr simplify* drop f ;
|
||||
|
||||
: simplify ( expr -- vn )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ cpu.architecture tools.test kernel math combinators.short-circuit
|
|||
accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce
|
||||
compiler.cfg.ssa.destruction compiler.cfg.loop-detection
|
||||
compiler.cfg.representations compiler.cfg assocs vectors arrays
|
||||
layouts namespaces ;
|
||||
layouts namespaces alien ;
|
||||
IN: compiler.cfg.value-numbering.tests
|
||||
|
||||
: trim-temps ( insns -- insns )
|
||||
|
|
@ -877,7 +877,7 @@ cell 8 = [
|
|||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##load-immediate f 2 16 }
|
||||
T{ ##box-displaced-alien f 1 2 0 }
|
||||
T{ ##box-displaced-alien f 1 2 0 c-ptr }
|
||||
T{ ##unbox-any-c-ptr f 4 0 }
|
||||
T{ ##add-imm f 3 4 16 }
|
||||
}
|
||||
|
|
@ -885,7 +885,7 @@ cell 8 = [
|
|||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##load-immediate f 2 16 }
|
||||
T{ ##box-displaced-alien f 1 2 0 }
|
||||
T{ ##box-displaced-alien f 1 2 0 c-ptr }
|
||||
T{ ##unbox-any-c-ptr f 3 1 }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
|
@ -896,7 +896,7 @@ cell 8 = [
|
|||
{
|
||||
T{ ##box-alien f 0 1 }
|
||||
T{ ##load-immediate f 2 16 }
|
||||
T{ ##box-displaced-alien f 3 2 0 }
|
||||
T{ ##box-displaced-alien f 3 2 0 c-ptr }
|
||||
T{ ##copy f 5 1 any-rep }
|
||||
T{ ##add-imm f 4 5 16 }
|
||||
}
|
||||
|
|
@ -904,7 +904,7 @@ cell 8 = [
|
|||
{
|
||||
T{ ##box-alien f 0 1 }
|
||||
T{ ##load-immediate f 2 16 }
|
||||
T{ ##box-displaced-alien f 3 2 0 }
|
||||
T{ ##box-displaced-alien f 3 2 0 c-ptr }
|
||||
T{ ##unbox-any-c-ptr f 4 3 }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
|
@ -922,7 +922,7 @@ cell 8 = [
|
|||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##load-immediate f 2 0 }
|
||||
T{ ##box-displaced-alien f 3 2 0 }
|
||||
T{ ##box-displaced-alien f 3 2 0 c-ptr }
|
||||
T{ ##replace f 3 D 1 }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -149,6 +149,8 @@ M: ##shr generate-insn dst/src1/src2 %shr ;
|
|||
M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
|
||||
M: ##sar generate-insn dst/src1/src2 %sar ;
|
||||
M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
|
||||
M: ##min generate-insn dst/src1/src2 %min ;
|
||||
M: ##max generate-insn dst/src1/src2 %max ;
|
||||
M: ##not generate-insn dst/src %not ;
|
||||
M: ##log2 generate-insn dst/src %log2 ;
|
||||
|
||||
|
|
@ -169,6 +171,8 @@ M: ##add-float generate-insn dst/src1/src2 %add-float ;
|
|||
M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
|
||||
M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
|
||||
M: ##div-float generate-insn dst/src1/src2 %div-float ;
|
||||
M: ##min-float generate-insn dst/src1/src2 %min-float ;
|
||||
M: ##max-float generate-insn dst/src1/src2 %max-float ;
|
||||
|
||||
M: ##sqrt generate-insn dst/src %sqrt ;
|
||||
|
||||
|
|
|
|||
|
|
@ -401,4 +401,10 @@ cell 4 = [
|
|||
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
|
||||
[ 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
|
||||
|
|
@ -83,3 +83,8 @@ IN: compiler.tests.float
|
|||
[ f ] [ 3.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test
|
||||
|
||||
[ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-call ] unit-test
|
||||
|
||||
[ 17.5 ] [ -11.3 17.5 [ float-max ] compile-call ] unit-test
|
||||
[ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test
|
||||
[ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test
|
||||
[ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
USING: accessors arrays compiler.units kernel kernel.private math
|
||||
math.constants math.private sequences strings tools.test words
|
||||
continuations sequences.private hashtables.private byte-arrays
|
||||
system random layouts vectors
|
||||
USING: accessors arrays compiler.units kernel kernel.private
|
||||
math math.constants math.private math.integers.private sequences
|
||||
strings tools.test words continuations sequences.private
|
||||
hashtables.private byte-arrays system random layouts vectors
|
||||
sbufs strings.private slots.private alien math.order
|
||||
alien.accessors alien.c-types alien.syntax alien.strings
|
||||
namespaces libc io.encodings.ascii
|
||||
classes compiler ;
|
||||
namespaces libc io.encodings.ascii classes compiler ;
|
||||
IN: compiler.tests.intrinsics
|
||||
|
||||
! Make sure that intrinsic ops compile to correct code.
|
||||
|
|
@ -271,6 +270,15 @@ cell 8 = [
|
|||
[ 100000 swap array-nth ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 2 ] [ 2 4 [ fixnum-min ] compile-call ] unit-test
|
||||
[ 2 ] [ 4 2 [ fixnum-min ] compile-call ] unit-test
|
||||
[ 4 ] [ 2 4 [ fixnum-max ] compile-call ] unit-test
|
||||
[ 4 ] [ 4 2 [ fixnum-max ] compile-call ] unit-test
|
||||
[ -2 ] [ -2 -4 [ fixnum-max ] compile-call ] unit-test
|
||||
[ -2 ] [ -4 -2 [ fixnum-max ] compile-call ] unit-test
|
||||
[ -4 ] [ -2 -4 [ fixnum-min ] compile-call ] unit-test
|
||||
[ -4 ] [ -4 -2 [ fixnum-min ] compile-call ] unit-test
|
||||
|
||||
! 64-bit overflow
|
||||
cell 8 = [
|
||||
[ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! 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 math.libm layouts words
|
||||
sequences sequences.private arrays assocs classes
|
||||
math.integers.private math.floats.private math.partial-dispatch
|
||||
math.intervals 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
|
||||
|
|
@ -79,11 +79,16 @@ IN: compiler.tree.propagation.known-words
|
|||
] unless ;
|
||||
|
||||
: ensure-math-class ( class must-be -- class' )
|
||||
[ class<= ] 2keep ? ;
|
||||
[ class<= ] most ;
|
||||
|
||||
: number-valued ( class interval -- class' interval' )
|
||||
[ number ensure-math-class ] dip ;
|
||||
|
||||
: fixnum-valued ( class interval -- class' interval' )
|
||||
over null-class? [
|
||||
[ drop fixnum ] dip
|
||||
] unless ;
|
||||
|
||||
: integer-valued ( class interval -- class' interval' )
|
||||
[ integer ensure-math-class ] dip ;
|
||||
|
||||
|
|
@ -303,3 +308,16 @@ generic-comparison-ops [
|
|||
flog fpow fsqrt facosh fasinh fatanh } [
|
||||
{ float } "default-output-classes" set-word-prop
|
||||
] each
|
||||
|
||||
! Find a less repetitive way of doing this
|
||||
\ float-min { float float } "input-classes" set-word-prop
|
||||
\ float-min [ interval-min ] [ float-valued ] binary-op
|
||||
|
||||
\ float-max { float float } "input-classes" set-word-prop
|
||||
\ float-max [ interval-max ] [ float-valued ] binary-op
|
||||
|
||||
\ fixnum-min { fixnum fixnum } "input-classes" set-word-prop
|
||||
\ fixnum-min [ interval-min ] [ fixnum-valued ] binary-op
|
||||
|
||||
\ fixnum-max { fixnum fixnum } "input-classes" set-word-prop
|
||||
\ fixnum-max [ interval-max ] [ fixnum-valued ] binary-op
|
||||
|
|
|
|||
|
|
@ -780,6 +780,10 @@ M: f whatever2 ; inline
|
|||
[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
|
||||
[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
|
||||
|
||||
SYMBOL: not-an-assoc
|
||||
|
||||
[ f ] [ [ not-an-assoc at ] { at* } inlined? ] unit-test
|
||||
|
||||
[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
|
||||
[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences words fry generic accessors classes.tuple
|
||||
classes classes.algebra definitions stack-checker.state quotations
|
||||
classes.tuple.private math math.partial-dispatch math.private
|
||||
math.intervals layouts math.order vectors hashtables
|
||||
combinators effects generalizations assocs sets
|
||||
combinators.short-circuit sequences.private locals
|
||||
USING: kernel sequences words fry generic accessors
|
||||
classes.tuple classes classes.algebra definitions
|
||||
stack-checker.state quotations classes.tuple.private math
|
||||
math.partial-dispatch math.private math.intervals
|
||||
math.floats.private math.integers.private layouts math.order
|
||||
vectors hashtables combinators effects generalizations assocs
|
||||
sets combinators.short-circuit sequences.private locals
|
||||
stack-checker namespaces compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.transforms
|
||||
|
||||
|
|
@ -79,6 +80,26 @@ IN: compiler.tree.propagation.transforms
|
|||
] [ f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
! Integrate this with generic arithmetic optimization instead?
|
||||
: both-inputs? ( #call class -- ? )
|
||||
[ in-d>> first2 ] dip '[ value-info class>> _ class<= ] both? ;
|
||||
|
||||
\ min [
|
||||
{
|
||||
{ [ dup fixnum both-inputs? ] [ [ fixnum-min ] ] }
|
||||
{ [ dup float both-inputs? ] [ [ float-min ] ] }
|
||||
[ f ]
|
||||
} cond nip
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
\ max [
|
||||
{
|
||||
{ [ dup fixnum both-inputs? ] [ [ fixnum-max ] ] }
|
||||
{ [ dup float both-inputs? ] [ [ float-max ] ] }
|
||||
[ f ]
|
||||
} cond nip
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
! Generate more efficient code for common idiom
|
||||
\ clone [
|
||||
in-d>> first value-info literal>> {
|
||||
|
|
@ -207,12 +228,14 @@ CONSTANT: lookup-table-at-max 256
|
|||
] ;
|
||||
|
||||
: at-quot ( assoc -- quot )
|
||||
dup lookup-table-at? [
|
||||
dup fast-lookup-table-at? [
|
||||
fast-lookup-table-quot
|
||||
] [
|
||||
lookup-table-quot
|
||||
] if
|
||||
dup assoc? [
|
||||
dup lookup-table-at? [
|
||||
dup fast-lookup-table-at? [
|
||||
fast-lookup-table-quot
|
||||
] [
|
||||
lookup-table-quot
|
||||
] if
|
||||
] [ drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
\ at* [ at-quot ] 1 define-partial-eval
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax alien.c-types alien.destructors accessors kernel ;
|
||||
USING: alien.syntax alien.c-types alien.destructors accessors classes.struct kernel ;
|
||||
IN: core-foundation
|
||||
|
||||
TYPEDEF: void* CFTypeRef
|
||||
|
|
@ -20,17 +20,15 @@ TYPEDEF: void* CFUUIDRef
|
|||
ALIAS: <CFIndex> <long>
|
||||
ALIAS: *CFIndex *long
|
||||
|
||||
C-STRUCT: CFRange
|
||||
{ "CFIndex" "location" }
|
||||
{ "CFIndex" "length" } ;
|
||||
STRUCT: CFRange
|
||||
{ location CFIndex }
|
||||
{ length CFIndex } ;
|
||||
|
||||
: <CFRange> ( location length -- range )
|
||||
"CFRange" <c-object>
|
||||
[ set-CFRange-length ] keep
|
||||
[ set-CFRange-location ] keep ;
|
||||
CFRange <struct-boa> ;
|
||||
|
||||
FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
|
||||
|
||||
FUNCTION: void CFRelease ( CFTypeRef cf ) ;
|
||||
|
||||
DESTRUCTOR: CFRelease
|
||||
DESTRUCTOR: CFRelease
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: alien alien.c-types alien.strings alien.syntax kernel
|
||||
math sequences namespaces make assocs init accessors
|
||||
continuations combinators io.encodings.utf8 destructors locals
|
||||
arrays specialized-arrays.direct.alien
|
||||
arrays specialized-arrays.direct.alien classes.struct
|
||||
specialized-arrays.direct.int specialized-arrays.direct.longlong
|
||||
core-foundation core-foundation.run-loop core-foundation.strings
|
||||
core-foundation.time ;
|
||||
|
|
@ -26,12 +26,12 @@ TYPEDEF: int FSEventStreamEventFlags
|
|||
TYPEDEF: longlong FSEventStreamEventId
|
||||
TYPEDEF: void* FSEventStreamRef
|
||||
|
||||
C-STRUCT: FSEventStreamContext
|
||||
{ "CFIndex" "version" }
|
||||
{ "void*" "info" }
|
||||
{ "void*" "retain" }
|
||||
{ "void*" "release" }
|
||||
{ "void*" "copyDescription" } ;
|
||||
STRUCT: FSEventStreamContext
|
||||
{ version CFIndex }
|
||||
{ info void* }
|
||||
{ retain void* }
|
||||
{ release void* }
|
||||
{ copyDescription void* } ;
|
||||
|
||||
! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]);
|
||||
TYPEDEF: void* FSEventStreamCallback
|
||||
|
|
@ -104,8 +104,8 @@ FUNCTION: void FSEventStreamShow ( FSEventStreamRef streamRef ) ;
|
|||
FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef ) ;
|
||||
|
||||
: make-FSEventStreamContext ( info -- alien )
|
||||
"FSEventStreamContext" <c-object>
|
||||
[ set-FSEventStreamContext-info ] keep ;
|
||||
FSEventStreamContext <struct>
|
||||
swap >>info ;
|
||||
|
||||
:: <FSEventStream> ( callback info paths latency flags -- event-stream )
|
||||
f ! allocator
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.syntax kernel layouts
|
||||
USING: accessors alien.c-types alien.syntax classes.struct kernel layouts
|
||||
math math.rectangles arrays ;
|
||||
IN: core-graphics.types
|
||||
|
||||
|
|
@ -12,63 +12,56 @@ IN: core-graphics.types
|
|||
: *CGFloat ( alien -- x )
|
||||
cell 4 = [ *float ] [ *double ] if ; inline
|
||||
|
||||
C-STRUCT: CGPoint
|
||||
{ "CGFloat" "x" }
|
||||
{ "CGFloat" "y" } ;
|
||||
STRUCT: CGPoint
|
||||
{ x CGFloat }
|
||||
{ y CGFloat } ;
|
||||
|
||||
: <CGPoint> ( x y -- point )
|
||||
"CGPoint" <c-object>
|
||||
[ set-CGPoint-y ] keep
|
||||
[ set-CGPoint-x ] keep ;
|
||||
CGPoint <struct-boa> ;
|
||||
|
||||
C-STRUCT: CGSize
|
||||
{ "CGFloat" "w" }
|
||||
{ "CGFloat" "h" } ;
|
||||
STRUCT: CGSize
|
||||
{ w CGFloat }
|
||||
{ h CGFloat } ;
|
||||
|
||||
: <CGSize> ( w h -- size )
|
||||
"CGSize" <c-object>
|
||||
[ set-CGSize-h ] keep
|
||||
[ set-CGSize-w ] keep ;
|
||||
CGSize <struct-boa> ;
|
||||
|
||||
C-STRUCT: CGRect
|
||||
{ "CGPoint" "origin" }
|
||||
{ "CGSize" "size" } ;
|
||||
STRUCT: CGRect
|
||||
{ origin CGPoint }
|
||||
{ size CGSize } ;
|
||||
|
||||
: CGPoint>loc ( CGPoint -- loc )
|
||||
[ CGPoint-x ] [ CGPoint-y ] bi 2array ;
|
||||
[ x>> ] [ y>> ] bi 2array ;
|
||||
|
||||
: CGSize>dim ( CGSize -- dim )
|
||||
[ CGSize-w ] [ CGSize-h ] bi 2array ;
|
||||
[ w>> ] [ h>> ] bi 2array ;
|
||||
|
||||
: CGRect>rect ( CGRect -- rect )
|
||||
[ CGRect-origin CGPoint>loc ]
|
||||
[ CGRect-size CGSize>dim ]
|
||||
[ origin>> CGPoint>loc ]
|
||||
[ size>> CGSize>dim ]
|
||||
bi <rect> ; inline
|
||||
|
||||
: CGRect-x ( CGRect -- x )
|
||||
CGRect-origin CGPoint-x ; inline
|
||||
origin>> x>> ; inline
|
||||
: CGRect-y ( CGRect -- y )
|
||||
CGRect-origin CGPoint-y ; inline
|
||||
origin>> y>> ; inline
|
||||
: CGRect-w ( CGRect -- w )
|
||||
CGRect-size CGSize-w ; inline
|
||||
size>> w>> ; inline
|
||||
: CGRect-h ( CGRect -- h )
|
||||
CGRect-size CGSize-h ; inline
|
||||
size>> h>> ; inline
|
||||
|
||||
: set-CGRect-x ( x CGRect -- )
|
||||
CGRect-origin set-CGPoint-x ; inline
|
||||
origin>> (>>x) ; inline
|
||||
: set-CGRect-y ( y CGRect -- )
|
||||
CGRect-origin set-CGPoint-y ; inline
|
||||
origin>> (>>y) ; inline
|
||||
: set-CGRect-w ( w CGRect -- )
|
||||
CGRect-size set-CGSize-w ; inline
|
||||
size>> (>>w) ; inline
|
||||
: set-CGRect-h ( h CGRect -- )
|
||||
CGRect-size set-CGSize-h ; inline
|
||||
size>> (>>h) ; inline
|
||||
|
||||
: <CGRect> ( x y w h -- rect )
|
||||
"CGRect" <c-object>
|
||||
[ set-CGRect-h ] keep
|
||||
[ set-CGRect-w ] keep
|
||||
[ set-CGRect-y ] keep
|
||||
[ set-CGRect-x ] keep ;
|
||||
[ CGPoint <struct-boa> ] [ CGSize <struct-boa> ] 2bi*
|
||||
CGRect <struct-boa> ;
|
||||
|
||||
: CGRect-x-y ( alien -- origin-x origin-y )
|
||||
[ CGRect-x ] [ CGRect-y ] bi ;
|
||||
|
|
@ -76,13 +69,13 @@ C-STRUCT: CGRect
|
|||
: CGRect-top-left ( alien -- x y )
|
||||
[ CGRect-x ] [ [ CGRect-y ] [ CGRect-h ] bi + ] bi ;
|
||||
|
||||
C-STRUCT: CGAffineTransform
|
||||
{ "CGFloat" "a" }
|
||||
{ "CGFloat" "b" }
|
||||
{ "CGFloat" "c" }
|
||||
{ "CGFloat" "d" }
|
||||
{ "CGFloat" "tx" }
|
||||
{ "CGFloat" "ty" } ;
|
||||
STRUCT: CGAffineTransform
|
||||
{ a CGFloat }
|
||||
{ b CGFloat }
|
||||
{ c CGFloat }
|
||||
{ d CGFloat }
|
||||
{ tx CGFloat }
|
||||
{ ty CGFloat } ;
|
||||
|
||||
TYPEDEF: void* CGColorRef
|
||||
TYPEDEF: void* CGColorSpaceRef
|
||||
|
|
|
|||
|
|
@ -116,8 +116,8 @@ TUPLE: line < disposable line metrics image loc dim ;
|
|||
line [ string open-font font foreground>> <CTLine> |CFRelease ]
|
||||
|
||||
rect [ line line-rect ]
|
||||
(loc) [ rect CGRect-origin CGPoint>loc ]
|
||||
(dim) [ rect CGRect-size CGSize>dim ]
|
||||
(loc) [ rect origin>> CGPoint>loc ]
|
||||
(dim) [ rect size>> CGSize>dim ]
|
||||
(ext) [ (loc) (dim) v+ ]
|
||||
loc [ (loc) [ floor ] map ]
|
||||
ext [ (loc) (dim) [ + ceiling ] 2map ]
|
||||
|
|
|
|||
|
|
@ -96,6 +96,8 @@ HOOK: %shr cpu ( dst src1 src2 -- )
|
|||
HOOK: %shr-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %sar cpu ( dst src1 src2 -- )
|
||||
HOOK: %sar-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %min cpu ( dst src1 src2 -- )
|
||||
HOOK: %max cpu ( dst src1 src2 -- )
|
||||
HOOK: %not cpu ( dst src -- )
|
||||
HOOK: %log2 cpu ( dst src -- )
|
||||
|
||||
|
|
@ -110,6 +112,8 @@ HOOK: %add-float cpu ( dst src1 src2 -- )
|
|||
HOOK: %sub-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %mul-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %div-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %min-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %max-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %sqrt cpu ( dst src -- )
|
||||
|
||||
HOOK: %integer>float cpu ( dst src -- )
|
||||
|
|
|
|||
|
|
@ -315,13 +315,13 @@ M:: ppc %unbox-any-c-ptr ( dst src temp -- )
|
|||
|
||||
: alien@ ( n -- n' ) cells object tag-number - ;
|
||||
|
||||
:: %allot-alien ( dst base displacement temp -- )
|
||||
:: %allot-alien ( dst displacement base temp -- )
|
||||
dst 4 cells alien temp %allot
|
||||
temp \ f tag-number %load-immediate
|
||||
! Store expired slot
|
||||
temp dst 1 alien@ STW
|
||||
! Store underlying-alien slot
|
||||
base dst 2 alien@ STW
|
||||
base dst 1 alien@ STW
|
||||
! Store expired slot
|
||||
temp dst 2 alien@ STW
|
||||
! Store offset
|
||||
displacement dst 3 alien@ STW ;
|
||||
|
||||
|
|
@ -331,7 +331,7 @@ M:: ppc %box-alien ( dst src temp -- )
|
|||
dst \ f tag-number %load-immediate
|
||||
0 src 0 CMPI
|
||||
"f" get BEQ
|
||||
dst temp src temp %allot-alien
|
||||
dst src temp temp %allot-alien
|
||||
"f" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -348,14 +348,14 @@ M:: ppc %box-displaced-alien ( dst displacement base temp -- )
|
|||
"ok" get BEQ
|
||||
temp base header-offset LWZ
|
||||
0 temp alien type-number tag-fixnum CMPI
|
||||
"ok" get BEQ
|
||||
"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 base displacement temp %allot-alien
|
||||
dst displacement base temp %allot-alien
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
|
|
|
|||
|
|
@ -303,8 +303,7 @@ USING: cpu.x86.features cpu.x86.features.private ;
|
|||
"Checking if your CPU supports SSE2..." print flush
|
||||
sse2? [
|
||||
" - yes" print
|
||||
enable-float-intrinsics
|
||||
enable-fsqrt
|
||||
enable-sse2
|
||||
[
|
||||
sse2? [
|
||||
"This image was built to use SSE2, which your CPU does not support." print
|
||||
|
|
|
|||
|
|
@ -202,8 +202,7 @@ M: x86.64 %callback-value ( ctype -- )
|
|||
enable-alien-4-intrinsics
|
||||
|
||||
! SSE2 is always available on x86-64.
|
||||
enable-float-intrinsics
|
||||
enable-fsqrt
|
||||
enable-sse2
|
||||
|
||||
USE: vocabs.loader
|
||||
|
||||
|
|
|
|||
|
|
@ -123,6 +123,10 @@ M: x86 %xor-imm nip XOR ;
|
|||
M: x86 %shl-imm nip SHL ;
|
||||
M: x86 %shr-imm nip SHR ;
|
||||
M: x86 %sar-imm nip SAR ;
|
||||
|
||||
M: x86 %min nip [ CMP ] [ CMOVG ] 2bi ;
|
||||
M: x86 %max nip [ CMP ] [ CMOVL ] 2bi ;
|
||||
|
||||
M: x86 %not drop NOT ;
|
||||
M: x86 %log2 BSR ;
|
||||
|
||||
|
|
@ -203,6 +207,8 @@ M: x86 %add-float nip ADDSD ;
|
|||
M: x86 %sub-float nip SUBSD ;
|
||||
M: x86 %mul-float nip MULSD ;
|
||||
M: x86 %div-float nip DIVSD ;
|
||||
M: x86 %min-float nip MINSD ;
|
||||
M: x86 %max-float nip MAXSD ;
|
||||
M: x86 %sqrt SQRTSD ;
|
||||
|
||||
M: x86 %integer>float CVTSI2SD ;
|
||||
|
|
@ -255,7 +261,7 @@ M:: x86 %box-float ( dst src temp -- )
|
|||
|
||||
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
|
||||
|
||||
:: %allot-alien ( dst base displacement temp -- )
|
||||
:: %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
|
||||
|
|
@ -268,7 +274,7 @@ M:: x86 %box-alien ( dst src temp -- )
|
|||
dst \ f tag-number MOV
|
||||
src 0 CMP
|
||||
"end" get JE
|
||||
dst \ f tag-number src temp %allot-alien
|
||||
dst src \ f tag-number temp %allot-alien
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -290,7 +296,7 @@ M:: x86 %box-displaced-alien ( dst displacement base temp -- )
|
|||
! base = base.base
|
||||
base base 1 alien@ MOV
|
||||
"ok" resolve-label
|
||||
dst base displacement temp %allot-alien
|
||||
dst displacement base temp %allot-alien
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -572,3 +578,10 @@ M: x86 small-enough? ( n -- ? )
|
|||
#! stack frame set up, and we want to read the frame
|
||||
#! set up by the caller.
|
||||
stack-frame get total-size>> + stack@ ;
|
||||
|
||||
: enable-sse2 ( -- )
|
||||
enable-float-intrinsics
|
||||
enable-fsqrt
|
||||
enable-float-min/max ;
|
||||
|
||||
enable-min/max
|
||||
|
|
|
|||
|
|
@ -0,0 +1,33 @@
|
|||
USING: accessors arrays assocs generic.standard kernel
|
||||
lexer locals.types namespaces parser quotations vocabs.parser
|
||||
words ;
|
||||
IN: functors.backend
|
||||
|
||||
DEFER: functor-words
|
||||
\ functor-words [ H{ } clone ] initialize
|
||||
|
||||
SYNTAX: FUNCTOR-SYNTAX:
|
||||
scan-word
|
||||
gensym [ parse-definition define-syntax ] keep
|
||||
swap name>> \ functor-words get-global set-at ;
|
||||
|
||||
: functor-words ( -- assoc )
|
||||
\ functor-words get-global ;
|
||||
|
||||
: scan-param ( -- obj ) scan-object literalize ;
|
||||
|
||||
: >string-param ( string -- string/param )
|
||||
dup search dup lexical? [ nip ] [ drop ] if ;
|
||||
|
||||
: scan-string-param ( -- name/param )
|
||||
scan >string-param ;
|
||||
|
||||
: scan-c-type-param ( -- c-type/param )
|
||||
scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
|
||||
|
||||
: define* ( word def -- ) over set-word define ;
|
||||
|
||||
: define-declared* ( word def effect -- ) pick set-word define-declared ;
|
||||
|
||||
: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
|
||||
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
USING: functors tools.test math words kernel multiline parser
|
||||
io.streams.string generic ;
|
||||
USING: classes.struct functors tools.test math words kernel
|
||||
multiline parser io.streams.string generic ;
|
||||
IN: functors.tests
|
||||
|
||||
<<
|
||||
|
|
@ -151,3 +151,64 @@ SYMBOL: W-symbol
|
|||
|
||||
test-redefinition
|
||||
|
||||
<<
|
||||
|
||||
FUNCTOR: define-a-struct ( T NAME TYPE N -- )
|
||||
|
||||
T-class DEFINES-CLASS ${T}
|
||||
|
||||
WHERE
|
||||
|
||||
STRUCT: T-class
|
||||
{ NAME int }
|
||||
{ x { TYPE 4 } }
|
||||
{ y { "short" N } }
|
||||
{ z TYPE initial: 5 }
|
||||
{ float { "float" 2 } } ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
"a-struct" "nemo" "char" 2 define-a-struct
|
||||
|
||||
>>
|
||||
|
||||
[
|
||||
{
|
||||
T{ struct-slot-spec
|
||||
{ name "nemo" }
|
||||
{ offset 0 }
|
||||
{ class integer }
|
||||
{ initial 0 }
|
||||
{ c-type "int" }
|
||||
}
|
||||
T{ struct-slot-spec
|
||||
{ name "x" }
|
||||
{ offset 4 }
|
||||
{ class object }
|
||||
{ initial f }
|
||||
{ c-type { "char" 4 } }
|
||||
}
|
||||
T{ struct-slot-spec
|
||||
{ name "y" }
|
||||
{ offset 8 }
|
||||
{ class object }
|
||||
{ initial f }
|
||||
{ c-type { "short" 2 } }
|
||||
}
|
||||
T{ struct-slot-spec
|
||||
{ name "z" }
|
||||
{ offset 12 }
|
||||
{ class fixnum }
|
||||
{ initial 5 }
|
||||
{ c-type "char" }
|
||||
}
|
||||
T{ struct-slot-spec
|
||||
{ name "float" }
|
||||
{ offset 16 }
|
||||
{ class object }
|
||||
{ initial f }
|
||||
{ c-type { "float" 2 } }
|
||||
}
|
||||
}
|
||||
] [ a-struct struct-slots ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays classes.mixin classes.parser
|
||||
classes.singleton classes.tuple classes.tuple.parser
|
||||
combinators effects.parser fry generic generic.parser
|
||||
generic.standard interpolate io.streams.string kernel lexer
|
||||
combinators effects.parser fry functors.backend generic
|
||||
generic.parser interpolate io.streams.string kernel lexer
|
||||
locals.parser locals.types macros make namespaces parser
|
||||
quotations sequences vocabs.parser words words.symbol ;
|
||||
IN: functors
|
||||
|
|
@ -12,14 +12,6 @@ IN: functors
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: scan-param ( -- obj ) scan-object literalize ;
|
||||
|
||||
: define* ( word def -- ) over set-word define ;
|
||||
|
||||
: define-declared* ( word def effect -- ) pick set-word define-declared ;
|
||||
|
||||
: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
|
||||
|
||||
TUPLE: fake-call-next-method ;
|
||||
|
||||
TUPLE: fake-quotation seq ;
|
||||
|
|
@ -58,7 +50,7 @@ M: object (fake-quotations>) , ;
|
|||
[ parse-definition* ] dip
|
||||
parsed ;
|
||||
|
||||
SYNTAX: `TUPLE:
|
||||
FUNCTOR-SYNTAX: TUPLE:
|
||||
scan-param parsed
|
||||
scan {
|
||||
{ ";" [ tuple parsed f parsed ] }
|
||||
|
|
@ -71,60 +63,60 @@ SYNTAX: `TUPLE:
|
|||
} case
|
||||
\ define-tuple-class parsed ;
|
||||
|
||||
SYNTAX: `SINGLETON:
|
||||
FUNCTOR-SYNTAX: SINGLETON:
|
||||
scan-param parsed
|
||||
\ define-singleton-class parsed ;
|
||||
|
||||
SYNTAX: `MIXIN:
|
||||
FUNCTOR-SYNTAX: MIXIN:
|
||||
scan-param parsed
|
||||
\ define-mixin-class parsed ;
|
||||
|
||||
SYNTAX: `M:
|
||||
FUNCTOR-SYNTAX: M:
|
||||
scan-param parsed
|
||||
scan-param parsed
|
||||
[ create-method-in dup method-body set ] over push-all
|
||||
parse-definition*
|
||||
\ define* parsed ;
|
||||
|
||||
SYNTAX: `C:
|
||||
FUNCTOR-SYNTAX: C:
|
||||
scan-param parsed
|
||||
scan-param parsed
|
||||
complete-effect
|
||||
[ [ [ boa ] curry ] over push-all ] dip parsed
|
||||
\ define-declared* parsed ;
|
||||
|
||||
SYNTAX: `:
|
||||
FUNCTOR-SYNTAX: :
|
||||
scan-param parsed
|
||||
parse-declared*
|
||||
\ define-declared* parsed ;
|
||||
|
||||
SYNTAX: `SYMBOL:
|
||||
FUNCTOR-SYNTAX: SYMBOL:
|
||||
scan-param parsed
|
||||
\ define-symbol parsed ;
|
||||
|
||||
SYNTAX: `SYNTAX:
|
||||
FUNCTOR-SYNTAX: SYNTAX:
|
||||
scan-param parsed
|
||||
parse-definition*
|
||||
\ define-syntax parsed ;
|
||||
|
||||
SYNTAX: `INSTANCE:
|
||||
FUNCTOR-SYNTAX: INSTANCE:
|
||||
scan-param parsed
|
||||
scan-param parsed
|
||||
\ add-mixin-instance parsed ;
|
||||
|
||||
SYNTAX: `GENERIC:
|
||||
FUNCTOR-SYNTAX: GENERIC:
|
||||
scan-param parsed
|
||||
complete-effect parsed
|
||||
\ define-simple-generic* parsed ;
|
||||
|
||||
SYNTAX: `MACRO:
|
||||
FUNCTOR-SYNTAX: MACRO:
|
||||
scan-param parsed
|
||||
parse-declared*
|
||||
\ define-macro parsed ;
|
||||
|
||||
SYNTAX: `inline [ word make-inline ] over push-all ;
|
||||
FUNCTOR-SYNTAX: inline [ word make-inline ] over push-all ;
|
||||
|
||||
SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
|
||||
FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } parsed ;
|
||||
|
||||
: (INTERPOLATE) ( accum quot -- accum )
|
||||
[ scan interpolate-locals ] dip
|
||||
|
|
@ -144,23 +136,6 @@ DEFER: ;FUNCTOR delimiter
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: functor-words ( -- assoc )
|
||||
H{
|
||||
{ "TUPLE:" POSTPONE: `TUPLE: }
|
||||
{ "SINGLETON:" POSTPONE: `SINGLETON: }
|
||||
{ "MIXIN:" POSTPONE: `MIXIN: }
|
||||
{ "M:" POSTPONE: `M: }
|
||||
{ "C:" POSTPONE: `C: }
|
||||
{ ":" POSTPONE: `: }
|
||||
{ "GENERIC:" POSTPONE: `GENERIC: }
|
||||
{ "INSTANCE:" POSTPONE: `INSTANCE: }
|
||||
{ "SYNTAX:" POSTPONE: `SYNTAX: }
|
||||
{ "SYMBOL:" POSTPONE: `SYMBOL: }
|
||||
{ "inline" POSTPONE: `inline }
|
||||
{ "MACRO:" POSTPONE: `MACRO: }
|
||||
{ "call-next-method" POSTPONE: `call-next-method }
|
||||
} ;
|
||||
|
||||
: push-functor-words ( -- )
|
||||
functor-words use-words ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ destructors io io.backend io.ports io.timeouts io.backend.windows
|
|||
io.files.windows io.files.windows.nt io.files io.pathnames io.buffers
|
||||
io.streams.c io.streams.null libc kernel math namespaces sequences
|
||||
threads windows windows.errors windows.kernel32 strings splitting
|
||||
ascii system accessors locals ;
|
||||
ascii system accessors locals classes.struct combinators.short-circuit ;
|
||||
QUALIFIED: windows.winsock
|
||||
IN: io.backend.windows.nt
|
||||
|
||||
|
|
@ -36,7 +36,7 @@ M: winnt add-completion ( win32-handle -- )
|
|||
handle>> master-completion-port get-global <completion-port> drop ;
|
||||
|
||||
: eof? ( error -- ? )
|
||||
[ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ;
|
||||
{ [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
|
||||
|
||||
: twiddle-thumbs ( overlapped port -- bytes-transferred )
|
||||
[
|
||||
|
|
@ -66,9 +66,9 @@ M: winnt add-completion ( win32-handle -- )
|
|||
|
||||
: handle-overlapped ( us -- ? )
|
||||
wait-for-overlapped [
|
||||
dup [
|
||||
[
|
||||
[ drop GetLastError 1array ] dip resume-callback t
|
||||
] [ 2drop f ] if
|
||||
] [ drop f ] if*
|
||||
] [ resume-callback t ] if ;
|
||||
|
||||
M: win32-handle cancel-operation
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@ USING: alien alien.c-types arrays destructors io io.backend
|
|||
io.buffers io.files io.ports io.binary io.timeouts system
|
||||
strings kernel math namespaces sequences windows.errors
|
||||
windows.kernel32 windows.shell32 windows.types windows.winsock
|
||||
splitting continuations math.bitwise accessors init sets assocs ;
|
||||
splitting continuations math.bitwise accessors init sets assocs
|
||||
classes.struct classes ;
|
||||
IN: io.backend.windows
|
||||
|
||||
TUPLE: win32-handle < disposable handle ;
|
||||
|
|
@ -50,6 +51,5 @@ HOOK: add-completion io-backend ( port -- )
|
|||
} flags ; foldable
|
||||
|
||||
: default-security-attributes ( -- obj )
|
||||
"SECURITY_ATTRIBUTES" <c-object>
|
||||
"SECURITY_ATTRIBUTES" heap-size
|
||||
over set-SECURITY_ATTRIBUTES-nLength ;
|
||||
SECURITY_ATTRIBUTES <struct>
|
||||
dup class heap-size >>nLength ;
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ M: buffer dispose* ptr>> free ;
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,6 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test io.files.info.windows system kernel ;
|
||||
IN: io.files.info.windows.tests
|
||||
|
||||
[ ] [ vm file-times 3drop ] unit-test
|
||||
|
|
@ -5,7 +5,7 @@ io.files.windows io.files.windows.nt kernel windows.kernel32
|
|||
windows.time windows accessors alien.c-types combinators
|
||||
generalizations system alien.strings io.encodings.utf16n
|
||||
sequences splitting windows.errors fry continuations destructors
|
||||
calendar ascii combinators.short-circuit locals ;
|
||||
calendar ascii combinators.short-circuit locals classes.struct ;
|
||||
IN: io.files.info.windows
|
||||
|
||||
:: round-up-to ( n multiple -- n' )
|
||||
|
|
@ -57,35 +57,26 @@ TUPLE: windows-file-info < file-info attributes ;
|
|||
: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
|
||||
[ \ windows-file-info new ] dip
|
||||
{
|
||||
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
|
||||
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ]
|
||||
[ dwFileAttributes>> win32-file-type >>type ]
|
||||
[ dwFileAttributes>> win32-file-attributes >>attributes ]
|
||||
[
|
||||
[ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
|
||||
[ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
|
||||
[ nFileSizeLow>> ]
|
||||
[ nFileSizeHigh>> ] bi >64bit >>size
|
||||
]
|
||||
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ]
|
||||
[
|
||||
BY_HANDLE_FILE_INFORMATION-ftCreationTime
|
||||
FILETIME>timestamp >>created
|
||||
]
|
||||
[
|
||||
BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
|
||||
FILETIME>timestamp >>modified
|
||||
]
|
||||
[
|
||||
BY_HANDLE_FILE_INFORMATION-ftLastAccessTime
|
||||
FILETIME>timestamp >>accessed
|
||||
]
|
||||
! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
|
||||
[ dwFileAttributes>> >>permissions ]
|
||||
[ ftCreationTime>> FILETIME>timestamp >>created ]
|
||||
[ ftLastWriteTime>> FILETIME>timestamp >>modified ]
|
||||
[ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
|
||||
! [ nNumberOfLinks>> ]
|
||||
! [
|
||||
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
|
||||
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
|
||||
! [ nFileIndexLow>> ]
|
||||
! [ nFileIndexHigh>> ] bi >64bit
|
||||
! ]
|
||||
} cleave ;
|
||||
|
||||
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
|
||||
[
|
||||
"BY_HANDLE_FILE_INFORMATION" <c-object>
|
||||
BY_HANDLE_FILE_INFORMATION <struct>
|
||||
[ GetFileInformationByHandle win32-error=0/f ] keep
|
||||
] keep CloseHandle win32-error=0/f ;
|
||||
|
||||
|
|
@ -197,10 +188,10 @@ M: winnt file-systems ( -- array )
|
|||
|
||||
: file-times ( path -- timestamp timestamp timestamp )
|
||||
[
|
||||
normalize-path open-existing &dispose handle>>
|
||||
"FILETIME" <c-object>
|
||||
"FILETIME" <c-object>
|
||||
"FILETIME" <c-object>
|
||||
normalize-path open-read &dispose handle>>
|
||||
FILETIME <struct>
|
||||
FILETIME <struct>
|
||||
FILETIME <struct>
|
||||
[ GetFileTime win32-error=0/f ] 3keep
|
||||
[ FILETIME>timestamp >local-time ] tri@
|
||||
] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -85,7 +85,7 @@ IN: io.launcher.windows.nt
|
|||
: redirect-stderr ( process args -- handle )
|
||||
over stderr>> +stdout+ eq? [
|
||||
nip
|
||||
lpStartupInfo>> STARTUPINFO-hStdOutput
|
||||
lpStartupInfo>> hStdOutput>>
|
||||
] [
|
||||
drop
|
||||
stderr>>
|
||||
|
|
@ -104,7 +104,7 @@ IN: io.launcher.windows.nt
|
|||
STD_INPUT_HANDLE GetStdHandle or ;
|
||||
|
||||
M: winnt fill-redirection ( process args -- )
|
||||
[ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
|
||||
[ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
|
||||
[ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
|
||||
2drop ;
|
||||
dup lpStartupInfo>>
|
||||
[ [ redirect-stdout ] dip (>>hStdOutput) ]
|
||||
[ [ redirect-stderr ] dip (>>hStdError) ]
|
||||
[ [ redirect-stdin ] dip (>>hStdInput) ] 3tri ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ namespaces make io.launcher kernel sequences windows.errors
|
|||
splitting system threads init strings combinators
|
||||
io.backend accessors concurrency.flags io.files assocs
|
||||
io.files.private windows destructors specialized-arrays.ushort
|
||||
specialized-arrays.alien ;
|
||||
specialized-arrays.alien classes classes.struct ;
|
||||
IN: io.launcher.windows
|
||||
|
||||
TUPLE: CreateProcess-args
|
||||
|
|
@ -24,9 +24,10 @@ TUPLE: CreateProcess-args
|
|||
|
||||
: default-CreateProcess-args ( -- obj )
|
||||
CreateProcess-args new
|
||||
"STARTUPINFO" <c-object>
|
||||
"STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
|
||||
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
|
||||
STARTUPINFO <struct>
|
||||
dup class heap-size >>cb
|
||||
>>lpStartupInfo
|
||||
PROCESS_INFORMATION <struct> >>lpProcessInformation
|
||||
TRUE >>bInheritHandles
|
||||
0 >>dwCreateFlags ;
|
||||
|
||||
|
|
@ -108,7 +109,7 @@ TUPLE: CreateProcess-args
|
|||
] when ;
|
||||
|
||||
: fill-startup-info ( process args -- process args )
|
||||
STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ;
|
||||
dup lpStartupInfo>> STARTF_USESTDHANDLES >>dwFlags drop ;
|
||||
|
||||
HOOK: fill-redirection io-backend ( process args -- )
|
||||
|
||||
|
|
@ -136,17 +137,16 @@ M: windows run-process* ( process -- handle )
|
|||
] with-destructors ;
|
||||
|
||||
M: windows kill-process* ( handle -- )
|
||||
PROCESS_INFORMATION-hProcess
|
||||
255 TerminateProcess win32-error=0/f ;
|
||||
hProcess>> 255 TerminateProcess win32-error=0/f ;
|
||||
|
||||
: dispose-process ( process-information -- )
|
||||
#! From MSDN: "Handles in PROCESS_INFORMATION must be closed
|
||||
#! with CloseHandle when they are no longer needed."
|
||||
dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
|
||||
PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
|
||||
[ hProcess>> [ CloseHandle drop ] when* ]
|
||||
[ hThread>> [ CloseHandle drop ] when* ] bi ;
|
||||
|
||||
: exit-code ( process -- n )
|
||||
PROCESS_INFORMATION-hProcess
|
||||
hProcess>>
|
||||
0 <ulong> [ GetExitCodeProcess ] keep *ulong
|
||||
swap win32-error=0/f ;
|
||||
|
||||
|
|
@ -157,7 +157,7 @@ M: windows kill-process* ( handle -- )
|
|||
|
||||
M: windows wait-for-processes ( -- ? )
|
||||
processes get keys dup
|
||||
[ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as
|
||||
[ handle>> hProcess>> ] void*-array{ } map-as
|
||||
[ length ] keep 0 0
|
||||
WaitForMultipleObjects
|
||||
dup HEX: ffffffff = [ win32-error ] when
|
||||
|
|
|
|||
|
|
@ -235,6 +235,10 @@ IN: math.intervals.tests
|
|||
interval-contains?
|
||||
] unit-test
|
||||
|
||||
[ t ] [ full-interval 10 10 [a,b] interval-max 10 1/0. [a,b] = ] unit-test
|
||||
|
||||
[ t ] [ full-interval 10 10 [a,b] interval-min -1/0. 10 [a,b] = ] unit-test
|
||||
|
||||
[ t ] [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test
|
||||
|
||||
! Accuracy of interval-mod
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: math.intervals
|
|||
|
||||
SYMBOL: empty-interval
|
||||
|
||||
SYMBOL: full-interval
|
||||
SINGLETON: full-interval
|
||||
|
||||
TUPLE: interval { from read-only } { to read-only } ;
|
||||
|
||||
|
|
@ -238,12 +238,24 @@ MEMO: array-capacity-interval ( -- interval )
|
|||
] do-empty-interval ;
|
||||
|
||||
: interval-max ( i1 i2 -- i3 )
|
||||
#! Inaccurate; could be tighter
|
||||
[ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ] do-empty-interval ;
|
||||
{
|
||||
{ [ over empty-interval eq? ] [ drop ] }
|
||||
{ [ dup empty-interval eq? ] [ nip ] }
|
||||
{ [ 2dup [ full-interval eq? ] both? ] [ drop ] }
|
||||
{ [ over full-interval eq? ] [ nip from>> first [a,inf] ] }
|
||||
{ [ dup full-interval eq? ] [ drop from>> first [a,inf] ] }
|
||||
[ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ]
|
||||
} cond ;
|
||||
|
||||
: interval-min ( i1 i2 -- i3 )
|
||||
#! Inaccurate; could be tighter
|
||||
[ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ] do-empty-interval ;
|
||||
{
|
||||
{ [ over empty-interval eq? ] [ drop ] }
|
||||
{ [ dup empty-interval eq? ] [ nip ] }
|
||||
{ [ 2dup [ full-interval eq? ] both? ] [ drop ] }
|
||||
{ [ over full-interval eq? ] [ nip to>> first [-inf,a] ] }
|
||||
{ [ dup full-interval eq? ] [ drop to>> first [-inf,a] ] }
|
||||
[ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ]
|
||||
} cond ;
|
||||
|
||||
: interval-interior ( i1 -- i2 )
|
||||
dup special-interval? [
|
||||
|
|
|
|||
|
|
@ -4,53 +4,54 @@ USING: alien ;
|
|||
IN: math.libm
|
||||
|
||||
: facos ( x -- y )
|
||||
"double" "libm" "acos" { "double" } alien-invoke ;
|
||||
"double" "libm" "acos" { "double" } alien-invoke ; inline
|
||||
|
||||
: fasin ( x -- y )
|
||||
"double" "libm" "asin" { "double" } alien-invoke ;
|
||||
"double" "libm" "asin" { "double" } alien-invoke ; inline
|
||||
|
||||
: fatan ( x -- y )
|
||||
"double" "libm" "atan" { "double" } alien-invoke ;
|
||||
"double" "libm" "atan" { "double" } alien-invoke ; inline
|
||||
|
||||
: fatan2 ( x y -- z )
|
||||
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
|
||||
"double" "libm" "atan2" { "double" "double" } alien-invoke ; inline
|
||||
|
||||
: fcos ( x -- y )
|
||||
"double" "libm" "cos" { "double" } alien-invoke ;
|
||||
"double" "libm" "cos" { "double" } alien-invoke ; inline
|
||||
|
||||
: fsin ( x -- y )
|
||||
"double" "libm" "sin" { "double" } alien-invoke ;
|
||||
"double" "libm" "sin" { "double" } alien-invoke ; inline
|
||||
|
||||
: ftan ( x -- y )
|
||||
"double" "libm" "tan" { "double" } alien-invoke ;
|
||||
"double" "libm" "tan" { "double" } alien-invoke ; inline
|
||||
|
||||
: fcosh ( x -- y )
|
||||
"double" "libm" "cosh" { "double" } alien-invoke ;
|
||||
"double" "libm" "cosh" { "double" } alien-invoke ; inline
|
||||
|
||||
: fsinh ( x -- y )
|
||||
"double" "libm" "sinh" { "double" } alien-invoke ;
|
||||
"double" "libm" "sinh" { "double" } alien-invoke ; inline
|
||||
|
||||
: ftanh ( x -- y )
|
||||
"double" "libm" "tanh" { "double" } alien-invoke ;
|
||||
"double" "libm" "tanh" { "double" } alien-invoke ; inline
|
||||
|
||||
: fexp ( x -- y )
|
||||
"double" "libm" "exp" { "double" } alien-invoke ;
|
||||
"double" "libm" "exp" { "double" } alien-invoke ; inline
|
||||
|
||||
: flog ( x -- y )
|
||||
"double" "libm" "log" { "double" } alien-invoke ;
|
||||
"double" "libm" "log" { "double" } alien-invoke ; inline
|
||||
|
||||
: fpow ( x y -- z )
|
||||
"double" "libm" "pow" { "double" "double" } alien-invoke ;
|
||||
"double" "libm" "pow" { "double" "double" } alien-invoke ; inline
|
||||
|
||||
! Don't inline fsqrt -- its an intrinsic!
|
||||
: fsqrt ( x -- y )
|
||||
"double" "libm" "sqrt" { "double" } alien-invoke ;
|
||||
|
||||
! Windows doesn't have these...
|
||||
: facosh ( x -- y )
|
||||
"double" "libm" "acosh" { "double" } alien-invoke ;
|
||||
"double" "libm" "acosh" { "double" } alien-invoke ; inline
|
||||
|
||||
: fasinh ( x -- y )
|
||||
"double" "libm" "asinh" { "double" } alien-invoke ;
|
||||
"double" "libm" "asinh" { "double" } alien-invoke ; inline
|
||||
|
||||
: fatanh ( x -- y )
|
||||
"double" "libm" "atanh" { "double" } alien-invoke ;
|
||||
"double" "libm" "atanh" { "double" } alien-invoke ; inline
|
||||
|
|
|
|||
|
|
@ -56,7 +56,8 @@ PRIVATE>
|
|||
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
|
||||
|
||||
: random-prime ( numbits -- p )
|
||||
random-bits* next-prime ;
|
||||
[ ] [ 2^ ] [ random-bits* next-prime ] tri
|
||||
2dup < [ 2drop random-prime ] [ 2nip ] if ;
|
||||
|
||||
: estimated-primes ( m -- n )
|
||||
dup log / ; foldable
|
||||
|
|
|
|||
|
|
@ -13,6 +13,9 @@ M: bad-byte-array-length summary
|
|||
: (c-array) ( n c-type -- array )
|
||||
heap-size * (byte-array) ; inline
|
||||
|
||||
: <c-array> ( n type -- array )
|
||||
heap-size * <byte-array> ; inline
|
||||
|
||||
FUNCTOR: define-array ( T -- )
|
||||
|
||||
A DEFINES-CLASS ${T}-array
|
||||
|
|
|
|||
|
|
@ -14,9 +14,6 @@ TUPLE: alien-indirect-params < alien-node-params ;
|
|||
|
||||
TUPLE: alien-callback-params < alien-node-params quot xt ;
|
||||
|
||||
: pop-parameters ( -- seq )
|
||||
pop-literal nip [ expand-constants ] map ;
|
||||
|
||||
: param-prep-quot ( node -- quot )
|
||||
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
|
||||
|
||||
|
|
@ -31,7 +28,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
|||
: infer-alien-invoke ( -- )
|
||||
alien-invoke-params new
|
||||
! Compile-time parameters
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>parameters
|
||||
pop-literal nip >>function
|
||||
pop-literal nip >>library
|
||||
pop-literal nip >>return
|
||||
|
|
@ -50,7 +47,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
|||
alien-indirect-params new
|
||||
! Compile-time parameters
|
||||
pop-literal nip >>abi
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>parameters
|
||||
pop-literal nip >>return
|
||||
! Quotation which coerces parameters to required types
|
||||
dup param-prep-quot [ dip ] curry infer-quot-here
|
||||
|
|
@ -71,7 +68,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
|||
alien-callback-params new
|
||||
pop-literal nip >>quot
|
||||
pop-literal nip >>abi
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>parameters
|
||||
pop-literal nip >>return
|
||||
gensym >>xt
|
||||
dup callback-bottom
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ M: struct-array length length>> ; inline
|
|||
M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
|
||||
|
||||
: (nth-ptr) ( i struct-array -- alien )
|
||||
[ element-size>> * ] [ underlying>> ] bi <displaced-alien> ; inline
|
||||
[ element-size>> * >fixnum ] [ underlying>> ] bi <displaced-alien> ; inline
|
||||
|
||||
M: struct-array nth-unsafe
|
||||
[ (nth-ptr) ] [ class>> dup struct-class? ] bi [ memory>struct ] [ drop ] if ; inline
|
||||
|
|
@ -26,7 +26,7 @@ M: struct-array set-nth-unsafe
|
|||
[ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
|
||||
|
||||
M: struct-array new-sequence
|
||||
[ element-size>> [ * <byte-array> ] 2keep ]
|
||||
[ element-size>> [ * (byte-array) ] 2keep ]
|
||||
[ class>> ] bi struct-array boa ; inline
|
||||
|
||||
M: struct-array resize ( n seq -- newseq )
|
||||
|
|
|
|||
|
|
@ -1,12 +1,13 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays accessors io.backend io.streams.c init fry namespaces
|
||||
math make assocs kernel parser parser.notes lexer strings.parser
|
||||
vocabs sequences sequences.private words memory kernel.private
|
||||
continuations io vocabs.loader system strings sets vectors quotations
|
||||
byte-arrays sorting compiler.units definitions generic
|
||||
generic.standard generic.single tools.deploy.config combinators
|
||||
classes classes.builtin slots.private grouping ;
|
||||
USING: arrays accessors io.backend io.streams.c init fry
|
||||
namespaces math make assocs kernel parser parser.notes lexer
|
||||
strings.parser vocabs sequences sequences.deep sequences.private
|
||||
words memory kernel.private continuations io vocabs.loader
|
||||
system strings sets vectors quotations byte-arrays sorting
|
||||
compiler.units definitions generic generic.standard
|
||||
generic.single tools.deploy.config combinators classes
|
||||
classes.builtin slots.private grouping ;
|
||||
QUALIFIED: bootstrap.stage2
|
||||
QUALIFIED: command-line
|
||||
QUALIFIED: compiler.errors
|
||||
|
|
@ -120,6 +121,7 @@ IN: tools.deploy.shaker
|
|||
"combination"
|
||||
"compiled-generic-uses"
|
||||
"compiled-uses"
|
||||
"constant"
|
||||
"constraints"
|
||||
"custom-inlining"
|
||||
"decision-tree"
|
||||
|
|
@ -145,6 +147,7 @@ IN: tools.deploy.shaker
|
|||
"local-writer"
|
||||
"local-writer?"
|
||||
"local?"
|
||||
"low-order"
|
||||
"macro"
|
||||
"members"
|
||||
"memo-quot"
|
||||
|
|
@ -456,11 +459,13 @@ SYMBOL: deploy-vocab
|
|||
[ "method-generic" word-prop ] bi
|
||||
next-method ;
|
||||
|
||||
: calls-next-method? ( method -- ? )
|
||||
def>> flatten \ (call-next-method) swap memq? ;
|
||||
|
||||
: compute-next-methods ( -- )
|
||||
[ standard-generic? ] instances [
|
||||
"methods" word-prop [
|
||||
nip dup next-method* "next-method" set-word-prop
|
||||
] assoc-each
|
||||
"methods" word-prop values [ calls-next-method? ] filter
|
||||
[ dup next-method* "next-method" set-word-prop ] each
|
||||
] each
|
||||
"vocab:tools/deploy/shaker/next-methods.factor" run-file ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,3 +8,7 @@ IN: libc
|
|||
: calloc ( size count -- newalien ) (calloc) check-ptr ;
|
||||
|
||||
: free ( alien -- ) (free) ;
|
||||
|
||||
FORGET: malloc-ptr
|
||||
|
||||
FORGET: <malloc-ptr>
|
||||
|
|
|
|||
|
|
@ -11,7 +11,9 @@ IN: tools.deploy.test
|
|||
] with-directory ;
|
||||
|
||||
: small-enough? ( n -- ? )
|
||||
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
|
||||
[ "test.image" temp-file file-info size>> ]
|
||||
[ cell 4 / * cpu ppc? [ 100000 + ] when ] bi*
|
||||
<= ;
|
||||
|
||||
: run-temp-image ( -- )
|
||||
os macosx?
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors arrays assocs compiler.units
|
||||
debugger init io kernel namespaces prettyprint sequences
|
||||
USING: accessors arrays assocs combinators.short-circuit
|
||||
compiler.units debugger init io
|
||||
io.streams.null kernel namespaces prettyprint sequences
|
||||
source-files.errors summary tools.crossref
|
||||
tools.crossref.private tools.errors words ;
|
||||
IN: tools.deprecation
|
||||
|
|
@ -39,12 +40,14 @@ T{ error-type
|
|||
: clear-deprecation-note ( word -- )
|
||||
deprecation-notes get-global delete-at ;
|
||||
|
||||
: check-deprecations ( word -- )
|
||||
dup "forgotten" word-prop
|
||||
[ clear-deprecation-note ] [
|
||||
dup def>> uses [ deprecated? ] filter
|
||||
[ clear-deprecation-note ] [ >array deprecation-note ] if-empty
|
||||
] if ;
|
||||
: check-deprecations ( usage -- )
|
||||
dup word? [
|
||||
dup { [ "forgotten" word-prop ] [ deprecated? ] } 1||
|
||||
[ clear-deprecation-note ] [
|
||||
dup def>> uses [ deprecated? ] filter
|
||||
[ clear-deprecation-note ] [ >array deprecation-note ] if-empty
|
||||
] if
|
||||
] [ drop ] if ;
|
||||
|
||||
M: deprecated-usages summary
|
||||
drop "Deprecated words used" ;
|
||||
|
|
@ -58,8 +61,10 @@ M: deprecated-usages error.
|
|||
SINGLETON: deprecation-observer
|
||||
|
||||
: initialize-deprecation-notes ( -- )
|
||||
get-crossref [ drop deprecated? ] assoc-filter
|
||||
values [ keys [ check-deprecations ] each ] each ;
|
||||
[
|
||||
get-crossref [ drop deprecated? ] assoc-filter
|
||||
values [ keys [ check-deprecations ] each ] each
|
||||
] with-null-writer ;
|
||||
|
||||
M: deprecation-observer definitions-changed
|
||||
drop keys [ word? ] filter
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: tools.disassembler namespaces combinators
|
||||
alien alien.syntax alien.c-types lexer parser kernel
|
||||
sequences layouts math math.order alien.libraries
|
||||
math.parser system make fry arrays libc destructors ;
|
||||
math.parser system make fry arrays libc destructors
|
||||
tools.disassembler.utils splitting ;
|
||||
IN: tools.disassembler.udis
|
||||
|
||||
<<
|
||||
|
|
@ -103,19 +104,21 @@ FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
|
|||
dup UD_SYN_INTEL ud_set_syntax ;
|
||||
|
||||
: with-ud ( quot: ( ud -- ) -- )
|
||||
[ [ <ud> ] dip call ] with-destructors ; inline
|
||||
[ [ [ <ud> ] dip call ] with-destructors ] with-words-xt ; inline
|
||||
|
||||
SINGLETON: udis-disassembler
|
||||
|
||||
: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
|
||||
|
||||
: resolve-call ( str -- str' ) "0x" split1-last [ resolve-xt append ] when* ;
|
||||
|
||||
: format-disassembly ( lines -- lines' )
|
||||
dup [ second length ] [ max ] map-reduce
|
||||
'[
|
||||
[
|
||||
[ first >hex cell 2 * CHAR: 0 pad-head % ": " % ]
|
||||
[ second _ CHAR: \s pad-tail % " " % ]
|
||||
[ third % ]
|
||||
[ third resolve-call % ]
|
||||
tri
|
||||
] "" make
|
||||
] map ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,41 @@
|
|||
USING: accessors arrays binary-search kernel math math.order
|
||||
math.parser namespaces sequences sorting splitting vectors vocabs words ;
|
||||
IN: tools.disassembler.utils
|
||||
|
||||
SYMBOL: words-xt
|
||||
SYMBOL: smallest-xt
|
||||
SYMBOL: greatest-xt
|
||||
|
||||
: (words-xt) ( -- assoc )
|
||||
vocabs [ words ] map concat [ [ word-xt ] keep 3array ] map
|
||||
[ [ first ] bi@ <=> ] sort >vector ;
|
||||
|
||||
: complete-address ( n seq -- str )
|
||||
[ first - ] [ third name>> ] bi
|
||||
over zero? [ nip ] [ swap 16 >base "0x" prepend "+" glue ] if ;
|
||||
|
||||
: search-xt ( n -- str/f )
|
||||
dup [ smallest-xt get < ] [ greatest-xt get > ] bi or [
|
||||
drop f
|
||||
] [
|
||||
words-xt get over [ swap first <=> ] curry search nip
|
||||
2dup second <= [
|
||||
[ complete-address ] [ drop f ] if*
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: resolve-xt ( str -- str' )
|
||||
[ "0x" prepend ] [ 16 base> ] bi
|
||||
[ search-xt [ " (" ")" surround append ] when* ] when* ;
|
||||
|
||||
: resolve-call ( str -- str' )
|
||||
"0x" split1-last [ resolve-xt "0x" glue ] when* ;
|
||||
|
||||
: with-words-xt ( quot -- )
|
||||
[ (words-xt)
|
||||
[ words-xt set ]
|
||||
[ first first smallest-xt set ]
|
||||
[ last second greatest-xt set ] tri
|
||||
] prepose with-scope ; inline
|
||||
|
|
@ -211,7 +211,7 @@ CLASS: {
|
|||
{ +name+ "FactorApplicationDelegate" }
|
||||
}
|
||||
|
||||
{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
|
||||
{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
|
||||
[ 3drop reset-run-loop ]
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ CLASS: {
|
|||
}
|
||||
|
||||
{ "applicationShouldHandleReopen:hasVisibleWindows:" "int" { "id" "SEL" "id" "int" }
|
||||
[ [ 3drop ] dip 0 = [ show-listener ] when 0 ]
|
||||
[ [ 3drop ] dip 0 = [ show-listener ] when 1 ]
|
||||
}
|
||||
|
||||
{ "factorListener:" "id" { "id" "SEL" "id" }
|
||||
|
|
|
|||
|
|
@ -149,7 +149,7 @@ CLASS: {
|
|||
|
||||
! Rendering
|
||||
{ "drawRect:" "void" { "id" "SEL" "NSRect" }
|
||||
[ 2drop window relayout-1 ]
|
||||
[ 2drop window relayout-1 yield ]
|
||||
}
|
||||
|
||||
! Events
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ threads libc combinators fry combinators.short-circuit continuations
|
|||
command-line shuffle opengl ui.render math.bitwise locals
|
||||
accessors math.rectangles math.order calendar ascii sets
|
||||
io.encodings.utf16n windows.errors literals ui.pixel-formats
|
||||
ui.pixel-formats.private memoize classes struct-arrays ;
|
||||
ui.pixel-formats.private memoize classes struct-arrays classes.struct ;
|
||||
IN: ui.backend.windows
|
||||
|
||||
SINGLETON: windows-ui-backend
|
||||
|
|
@ -89,26 +89,27 @@ CONSTANT: pfd-flag-map H{
|
|||
[ value>> ] [ 0 ] if* ;
|
||||
|
||||
: >pfd ( attributes -- pfd )
|
||||
"PIXELFORMATDESCRIPTOR" <c-object>
|
||||
"PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize
|
||||
1 over set-PIXELFORMATDESCRIPTOR-nVersion
|
||||
over >pfd-flags over set-PIXELFORMATDESCRIPTOR-dwFlags
|
||||
PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
|
||||
over color-bits attr-value over set-PIXELFORMATDESCRIPTOR-cColorBits
|
||||
over red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cRedBits
|
||||
over green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cGreenBits
|
||||
over blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cBlueBits
|
||||
over alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAlphaBits
|
||||
over accum-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBits
|
||||
over accum-red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumRedBits
|
||||
over accum-green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumGreenBits
|
||||
over accum-blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBlueBits
|
||||
over accum-alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumAlphaBits
|
||||
over depth-bits attr-value over set-PIXELFORMATDESCRIPTOR-cDepthBits
|
||||
over stencil-bits attr-value over set-PIXELFORMATDESCRIPTOR-cStencilBits
|
||||
over aux-buffers attr-value over set-PIXELFORMATDESCRIPTOR-cAuxBuffers
|
||||
PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask
|
||||
nip ;
|
||||
[ PIXELFORMATDESCRIPTOR <struct> ] dip
|
||||
{
|
||||
[ drop PIXELFORMATDESCRIPTOR heap-size >>nSize ]
|
||||
[ drop 1 >>nVersion ]
|
||||
[ >pfd-flags >>dwFlags ]
|
||||
[ drop PFD_TYPE_RGBA >>iPixelType ]
|
||||
[ color-bits attr-value >>cColorBits ]
|
||||
[ red-bits attr-value >>cRedBits ]
|
||||
[ green-bits attr-value >>cGreenBits ]
|
||||
[ blue-bits attr-value >>cBlueBits ]
|
||||
[ alpha-bits attr-value >>cAlphaBits ]
|
||||
[ accum-bits attr-value >>cAccumBits ]
|
||||
[ accum-red-bits attr-value >>cAccumRedBits ]
|
||||
[ accum-green-bits attr-value >>cAccumGreenBits ]
|
||||
[ accum-blue-bits attr-value >>cAccumBlueBits ]
|
||||
[ accum-alpha-bits attr-value >>cAccumAlphaBits ]
|
||||
[ depth-bits attr-value >>cDepthBits ]
|
||||
[ stencil-bits attr-value >>cStencilBits ]
|
||||
[ aux-buffers attr-value >>cAuxBuffers ]
|
||||
[ drop PFD_MAIN_PLANE >>dwLayerMask ]
|
||||
} cleave ;
|
||||
|
||||
: pfd-make-pixel-format ( world attributes -- pf )
|
||||
[ handle>> hDC>> ] [ >pfd ] bi*
|
||||
|
|
@ -116,12 +117,12 @@ CONSTANT: pfd-flag-map H{
|
|||
|
||||
: get-pfd ( pixel-format -- pfd )
|
||||
[ world>> handle>> hDC>> ] [ handle>> ] bi
|
||||
"PIXELFORMATDESCRIPTOR" heap-size
|
||||
"PIXELFORMATDESCRIPTOR" <c-object>
|
||||
PIXELFORMATDESCRIPTOR heap-size
|
||||
PIXELFORMATDESCRIPTOR <struct>
|
||||
[ DescribePixelFormat win32-error=0/f ] keep ;
|
||||
|
||||
: pfd-flag? ( pfd flag -- ? )
|
||||
[ PIXELFORMATDESCRIPTOR-dwFlags ] dip bitand c-bool> ;
|
||||
[ dwFlags>> ] dip bitand c-bool> ;
|
||||
|
||||
: (pfd-pixel-format-attribute) ( pfd attribute -- value )
|
||||
{
|
||||
|
|
@ -131,19 +132,19 @@ CONSTANT: pfd-flag-map H{
|
|||
{ fullscreen [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
|
||||
{ windowed [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
|
||||
{ software-rendered [ PFD_GENERIC_FORMAT pfd-flag? ] }
|
||||
{ color-bits [ PIXELFORMATDESCRIPTOR-cColorBits ] }
|
||||
{ red-bits [ PIXELFORMATDESCRIPTOR-cRedBits ] }
|
||||
{ green-bits [ PIXELFORMATDESCRIPTOR-cGreenBits ] }
|
||||
{ blue-bits [ PIXELFORMATDESCRIPTOR-cBlueBits ] }
|
||||
{ alpha-bits [ PIXELFORMATDESCRIPTOR-cAlphaBits ] }
|
||||
{ accum-bits [ PIXELFORMATDESCRIPTOR-cAccumBits ] }
|
||||
{ accum-red-bits [ PIXELFORMATDESCRIPTOR-cAccumRedBits ] }
|
||||
{ accum-green-bits [ PIXELFORMATDESCRIPTOR-cAccumGreenBits ] }
|
||||
{ accum-blue-bits [ PIXELFORMATDESCRIPTOR-cAccumBlueBits ] }
|
||||
{ accum-alpha-bits [ PIXELFORMATDESCRIPTOR-cAccumAlphaBits ] }
|
||||
{ depth-bits [ PIXELFORMATDESCRIPTOR-cDepthBits ] }
|
||||
{ stencil-bits [ PIXELFORMATDESCRIPTOR-cStencilBits ] }
|
||||
{ aux-buffers [ PIXELFORMATDESCRIPTOR-cAuxBuffers ] }
|
||||
{ color-bits [ cColorBits>> ] }
|
||||
{ red-bits [ cRedBits>> ] }
|
||||
{ green-bits [ cGreenBits>> ] }
|
||||
{ blue-bits [ cBlueBits>> ] }
|
||||
{ alpha-bits [ cAlphaBits>> ] }
|
||||
{ accum-bits [ cAccumBits>> ] }
|
||||
{ accum-red-bits [ cAccumRedBits>> ] }
|
||||
{ accum-green-bits [ cAccumGreenBits>> ] }
|
||||
{ accum-blue-bits [ cAccumBlueBits>> ] }
|
||||
{ accum-alpha-bits [ cAccumAlphaBits>> ] }
|
||||
{ depth-bits [ cDepthBits>> ] }
|
||||
{ stencil-bits [ cStencilBits>> ] }
|
||||
{ aux-buffers [ cAuxBuffers>> ] }
|
||||
[ 2drop f ]
|
||||
} case ;
|
||||
|
||||
|
|
@ -663,7 +664,7 @@ M: windows-ui-backend do-events
|
|||
|
||||
: set-pixel-format ( pixel-format hdc -- )
|
||||
swap handle>>
|
||||
"PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
|
||||
PIXELFORMATDESCRIPTOR <struct> SetPixelFormat win32-error=0/f ;
|
||||
|
||||
: setup-gl ( world -- )
|
||||
[ get-dc ] keep
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax kernel windows.types multiline ;
|
||||
USING: alien alien.syntax kernel windows.types multiline
|
||||
classes.struct ;
|
||||
IN: windows.kernel32
|
||||
|
||||
CONSTANT: MAX_PATH 260
|
||||
|
|
@ -215,15 +216,15 @@ C-STRUCT: OVERLAPPED
|
|||
{ "DWORD" "offset-high" }
|
||||
{ "HANDLE" "event" } ;
|
||||
|
||||
C-STRUCT: SYSTEMTIME
|
||||
{ "WORD" "wYear" }
|
||||
{ "WORD" "wMonth" }
|
||||
{ "WORD" "wDayOfWeek" }
|
||||
{ "WORD" "wDay" }
|
||||
{ "WORD" "wHour" }
|
||||
{ "WORD" "wMinute" }
|
||||
{ "WORD" "wSecond" }
|
||||
{ "WORD" "wMilliseconds" } ;
|
||||
STRUCT: SYSTEMTIME
|
||||
{ wYear WORD }
|
||||
{ wMonth WORD }
|
||||
{ wDayOfWeek WORD }
|
||||
{ wDay WORD }
|
||||
{ wHour WORD }
|
||||
{ wMinute WORD }
|
||||
{ wSecond WORD }
|
||||
{ wMilliseconds WORD } ;
|
||||
|
||||
C-STRUCT: TIME_ZONE_INFORMATION
|
||||
{ "LONG" "Bias" }
|
||||
|
|
@ -234,74 +235,74 @@ C-STRUCT: TIME_ZONE_INFORMATION
|
|||
{ "SYSTEMTIME" "DaylightDate" }
|
||||
{ "LONG" "DaylightBias" } ;
|
||||
|
||||
C-STRUCT: FILETIME
|
||||
{ "DWORD" "dwLowDateTime" }
|
||||
{ "DWORD" "dwHighDateTime" } ;
|
||||
STRUCT: FILETIME
|
||||
{ dwLowDateTime DWORD }
|
||||
{ dwHighDateTime DWORD } ;
|
||||
|
||||
C-STRUCT: STARTUPINFO
|
||||
{ "DWORD" "cb" }
|
||||
{ "LPTSTR" "lpReserved" }
|
||||
{ "LPTSTR" "lpDesktop" }
|
||||
{ "LPTSTR" "lpTitle" }
|
||||
{ "DWORD" "dwX" }
|
||||
{ "DWORD" "dwY" }
|
||||
{ "DWORD" "dwXSize" }
|
||||
{ "DWORD" "dwYSize" }
|
||||
{ "DWORD" "dwXCountChars" }
|
||||
{ "DWORD" "dwYCountChars" }
|
||||
{ "DWORD" "dwFillAttribute" }
|
||||
{ "DWORD" "dwFlags" }
|
||||
{ "WORD" "wShowWindow" }
|
||||
{ "WORD" "cbReserved2" }
|
||||
{ "LPBYTE" "lpReserved2" }
|
||||
{ "HANDLE" "hStdInput" }
|
||||
{ "HANDLE" "hStdOutput" }
|
||||
{ "HANDLE" "hStdError" } ;
|
||||
STRUCT: STARTUPINFO
|
||||
{ cb DWORD }
|
||||
{ lpReserved LPTSTR }
|
||||
{ lpDesktop LPTSTR }
|
||||
{ lpTitle LPTSTR }
|
||||
{ dwX DWORD }
|
||||
{ dwY DWORD }
|
||||
{ dwXSize DWORD }
|
||||
{ dwYSize DWORD }
|
||||
{ dwXCountChars DWORD }
|
||||
{ dwYCountChars DWORD }
|
||||
{ dwFillAttribute DWORD }
|
||||
{ dwFlags DWORD }
|
||||
{ wShowWindow WORD }
|
||||
{ cbReserved2 WORD }
|
||||
{ lpReserved2 LPBYTE }
|
||||
{ hStdInput HANDLE }
|
||||
{ hStdOutput HANDLE }
|
||||
{ hStdError HANDLE } ;
|
||||
|
||||
TYPEDEF: void* LPSTARTUPINFO
|
||||
|
||||
C-STRUCT: PROCESS_INFORMATION
|
||||
{ "HANDLE" "hProcess" }
|
||||
{ "HANDLE" "hThread" }
|
||||
{ "DWORD" "dwProcessId" }
|
||||
{ "DWORD" "dwThreadId" } ;
|
||||
STRUCT: PROCESS_INFORMATION
|
||||
{ hProcess HANDLE }
|
||||
{ hThread HANDLE }
|
||||
{ dwProcessId DWORD }
|
||||
{ dwThreadId DWORD } ;
|
||||
|
||||
C-STRUCT: SYSTEM_INFO
|
||||
{ "DWORD" "dwOemId" }
|
||||
{ "DWORD" "dwPageSize" }
|
||||
{ "LPVOID" "lpMinimumApplicationAddress" }
|
||||
{ "LPVOID" "lpMaximumApplicationAddress" }
|
||||
{ "DWORD_PTR" "dwActiveProcessorMask" }
|
||||
{ "DWORD" "dwNumberOfProcessors" }
|
||||
{ "DWORD" "dwProcessorType" }
|
||||
{ "DWORD" "dwAllocationGranularity" }
|
||||
{ "WORD" "wProcessorLevel" }
|
||||
{ "WORD" "wProcessorRevision" } ;
|
||||
STRUCT: SYSTEM_INFO
|
||||
{ dwOemId DWORD }
|
||||
{ dwPageSize DWORD }
|
||||
{ lpMinimumApplicationAddress LPVOID }
|
||||
{ lpMaximumApplicationAddress LPVOID }
|
||||
{ dwActiveProcessorMask DWORD_PTR }
|
||||
{ dwNumberOfProcessors DWORD }
|
||||
{ dwProcessorType DWORD }
|
||||
{ dwAllocationGranularity DWORD }
|
||||
{ wProcessorLevel WORD }
|
||||
{ wProcessorRevision WORD } ;
|
||||
|
||||
TYPEDEF: void* LPSYSTEM_INFO
|
||||
|
||||
C-STRUCT: MEMORYSTATUS
|
||||
{ "DWORD" "dwLength" }
|
||||
{ "DWORD" "dwMemoryLoad" }
|
||||
{ "SIZE_T" "dwTotalPhys" }
|
||||
{ "SIZE_T" "dwAvailPhys" }
|
||||
{ "SIZE_T" "dwTotalPageFile" }
|
||||
{ "SIZE_T" "dwAvailPageFile" }
|
||||
{ "SIZE_T" "dwTotalVirtual" }
|
||||
{ "SIZE_T" "dwAvailVirtual" } ;
|
||||
STRUCT: MEMORYSTATUS
|
||||
{ dwLength DWORD }
|
||||
{ dwMemoryLoad DWORD }
|
||||
{ dwTotalPhys SIZE_T }
|
||||
{ dwAvailPhys SIZE_T }
|
||||
{ dwTotalPageFile SIZE_T }
|
||||
{ dwAvailPageFile SIZE_T }
|
||||
{ dwTotalVirtual SIZE_T }
|
||||
{ dwAvailVirtual SIZE_T } ;
|
||||
|
||||
TYPEDEF: void* LPMEMORYSTATUS
|
||||
|
||||
C-STRUCT: MEMORYSTATUSEX
|
||||
{ "DWORD" "dwLength" }
|
||||
{ "DWORD" "dwMemoryLoad" }
|
||||
{ "DWORDLONG" "ullTotalPhys" }
|
||||
{ "DWORDLONG" "ullAvailPhys" }
|
||||
{ "DWORDLONG" "ullTotalPageFile" }
|
||||
{ "DWORDLONG" "ullAvailPageFile" }
|
||||
{ "DWORDLONG" "ullTotalVirtual" }
|
||||
{ "DWORDLONG" "ullAvailVirtual" }
|
||||
{ "DWORDLONG" "ullAvailExtendedVirtual" } ;
|
||||
STRUCT: MEMORYSTATUSEX
|
||||
{ dwLength DWORD }
|
||||
{ dwMemoryLoad DWORD }
|
||||
{ ullTotalPhys DWORDLONG }
|
||||
{ ullAvailPhys DWORDLONG }
|
||||
{ ullTotalPageFile DWORDLONG }
|
||||
{ ullAvailPageFile DWORDLONG }
|
||||
{ ullTotalVirtual DWORDLONG }
|
||||
{ ullAvailVirtual DWORDLONG }
|
||||
{ ullAvailExtendedVirtual DWORDLONG } ;
|
||||
|
||||
TYPEDEF: void* LPMEMORYSTATUSEX
|
||||
|
||||
|
|
@ -707,17 +708,17 @@ C-STRUCT: WIN32_FIND_DATA
|
|||
{ { "TCHAR" 260 } "cFileName" }
|
||||
{ { "TCHAR" 14 } "cAlternateFileName" } ;
|
||||
|
||||
C-STRUCT: BY_HANDLE_FILE_INFORMATION
|
||||
{ "DWORD" "dwFileAttributes" }
|
||||
{ "FILETIME" "ftCreationTime" }
|
||||
{ "FILETIME" "ftLastAccessTime" }
|
||||
{ "FILETIME" "ftLastWriteTime" }
|
||||
{ "DWORD" "dwVolumeSerialNumber" }
|
||||
{ "DWORD" "nFileSizeHigh" }
|
||||
{ "DWORD" "nFileSizeLow" }
|
||||
{ "DWORD" "nNumberOfLinks" }
|
||||
{ "DWORD" "nFileIndexHigh" }
|
||||
{ "DWORD" "nFileIndexLow" } ;
|
||||
STRUCT: BY_HANDLE_FILE_INFORMATION
|
||||
{ dwFileAttributes DWORD }
|
||||
{ ftCreationTime FILETIME }
|
||||
{ ftLastAccessTime FILETIME }
|
||||
{ ftLastWriteTime FILETIME }
|
||||
{ dwVolumeSerialNumber DWORD }
|
||||
{ nFileSizeHigh DWORD }
|
||||
{ nFileSizeLow DWORD }
|
||||
{ nNumberOfLinks DWORD }
|
||||
{ nFileIndexHigh DWORD }
|
||||
{ nFileIndexLow DWORD } ;
|
||||
|
||||
TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA
|
||||
TYPEDEF: WIN32_FIND_DATA* LPWIN32_FIND_DATA
|
||||
|
|
@ -737,10 +738,10 @@ TYPEDEF: PFILETIME LPFILETIME
|
|||
|
||||
TYPEDEF: int GET_FILEEX_INFO_LEVELS
|
||||
|
||||
C-STRUCT: SECURITY_ATTRIBUTES
|
||||
{ "DWORD" "nLength" }
|
||||
{ "LPVOID" "lpSecurityDescriptor" }
|
||||
{ "BOOL" "bInheritHandle" } ;
|
||||
STRUCT: SECURITY_ATTRIBUTES
|
||||
{ nLength DWORD }
|
||||
{ lpSecurityDescriptor LPVOID }
|
||||
{ bInheritHandle BOOL } ;
|
||||
|
||||
CONSTANT: HANDLE_FLAG_INHERIT 1
|
||||
CONSTANT: HANDLE_FLAG_PROTECT_FROM_CLOSE 2
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types kernel math windows.errors
|
||||
windows.kernel32 namespaces calendar math.bitwise ;
|
||||
windows.kernel32 namespaces calendar math.bitwise accessors
|
||||
classes.struct ;
|
||||
IN: windows.time
|
||||
|
||||
: >64bit ( lo hi -- n )
|
||||
|
|
@ -11,15 +12,13 @@ IN: windows.time
|
|||
1601 1 1 0 0 0 instant <timestamp> ;
|
||||
|
||||
: FILETIME>windows-time ( FILETIME -- n )
|
||||
[ FILETIME-dwLowDateTime ]
|
||||
[ FILETIME-dwHighDateTime ]
|
||||
bi >64bit ;
|
||||
[ dwLowDateTime>> ] [ dwHighDateTime>> ] bi >64bit ;
|
||||
|
||||
: windows-time>timestamp ( n -- timestamp )
|
||||
10000000 /i seconds windows-1601 swap time+ ;
|
||||
|
||||
: windows-time ( -- n )
|
||||
"FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep
|
||||
FILETIME <struct> [ GetSystemTimeAsFileTime ] keep
|
||||
FILETIME>windows-time ;
|
||||
|
||||
: timestamp>windows-time ( timestamp -- n )
|
||||
|
|
@ -27,11 +26,8 @@ IN: windows.time
|
|||
>gmt windows-1601 (time-) 10000000 * >integer ;
|
||||
|
||||
: windows-time>FILETIME ( n -- FILETIME )
|
||||
"FILETIME" <c-object>
|
||||
[
|
||||
[ [ 32 bits ] dip set-FILETIME-dwLowDateTime ]
|
||||
[ [ -32 shift ] dip set-FILETIME-dwHighDateTime ] 2bi
|
||||
] keep ;
|
||||
[ FILETIME <struct> ] dip
|
||||
[ 32 bits >>dwLowDateTime ] [ -32 shift >>dwHighDateTime ] bi ;
|
||||
|
||||
: timestamp>FILETIME ( timestamp -- FILETIME/f )
|
||||
dup [ >gmt timestamp>windows-time windows-time>FILETIME ] when ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.syntax namespaces kernel words
|
||||
sequences math math.bitwise math.vectors colors
|
||||
io.encodings.utf16n ;
|
||||
io.encodings.utf16n classes.struct ;
|
||||
IN: windows.types
|
||||
|
||||
TYPEDEF: char CHAR
|
||||
|
|
@ -301,33 +301,33 @@ C-STRUCT: MSG
|
|||
|
||||
TYPEDEF: MSG* LPMSG
|
||||
|
||||
C-STRUCT: PIXELFORMATDESCRIPTOR
|
||||
{ "WORD" "nSize" }
|
||||
{ "WORD" "nVersion" }
|
||||
{ "DWORD" "dwFlags" }
|
||||
{ "BYTE" "iPixelType" }
|
||||
{ "BYTE" "cColorBits" }
|
||||
{ "BYTE" "cRedBits" }
|
||||
{ "BYTE" "cRedShift" }
|
||||
{ "BYTE" "cGreenBits" }
|
||||
{ "BYTE" "cGreenShift" }
|
||||
{ "BYTE" "cBlueBits" }
|
||||
{ "BYTE" "cBlueShift" }
|
||||
{ "BYTE" "cAlphaBits" }
|
||||
{ "BYTE" "cAlphaShift" }
|
||||
{ "BYTE" "cAccumBits" }
|
||||
{ "BYTE" "cAccumRedBits" }
|
||||
{ "BYTE" "cAccumGreenBits" }
|
||||
{ "BYTE" "cAccumBlueBits" }
|
||||
{ "BYTE" "cAccumAlphaBits" }
|
||||
{ "BYTE" "cDepthBits" }
|
||||
{ "BYTE" "cStencilBits" }
|
||||
{ "BYTE" "cAuxBuffers" }
|
||||
{ "BYTE" "iLayerType" }
|
||||
{ "BYTE" "bReserved" }
|
||||
{ "DWORD" "dwLayerMask" }
|
||||
{ "DWORD" "dwVisibleMask" }
|
||||
{ "DWORD" "dwDamageMask" } ;
|
||||
STRUCT: PIXELFORMATDESCRIPTOR
|
||||
{ nSize WORD }
|
||||
{ nVersion WORD }
|
||||
{ dwFlags DWORD }
|
||||
{ iPixelType BYTE }
|
||||
{ cColorBits BYTE }
|
||||
{ cRedBits BYTE }
|
||||
{ cRedShift BYTE }
|
||||
{ cGreenBits BYTE }
|
||||
{ cGreenShift BYTE }
|
||||
{ cBlueBits BYTE }
|
||||
{ cBlueShift BYTE }
|
||||
{ cAlphaBits BYTE }
|
||||
{ cAlphaShift BYTE }
|
||||
{ cAccumBits BYTE }
|
||||
{ cAccumRedBits BYTE }
|
||||
{ cAccumGreenBits BYTE }
|
||||
{ cAccumBlueBits BYTE }
|
||||
{ cAccumAlphaBits BYTE }
|
||||
{ cDepthBits BYTE }
|
||||
{ cStencilBits BYTE }
|
||||
{ cAuxBuffers BYTE }
|
||||
{ iLayerType BYTE }
|
||||
{ bReserved BYTE }
|
||||
{ dwLayerMask DWORD }
|
||||
{ dwVisibleMask DWORD }
|
||||
{ dwDamageMask DWORD } ;
|
||||
|
||||
C-STRUCT: RECT
|
||||
{ "LONG" "left" }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax parser namespaces kernel math
|
||||
windows.types generalizations math.bitwise ;
|
||||
windows.types generalizations math.bitwise classes.struct ;
|
||||
IN: windows.user32
|
||||
|
||||
! HKL for ActivateKeyboardLayout
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ WORD=
|
|||
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
|
||||
|
|
@ -353,9 +354,40 @@ git_clone() {
|
|||
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() {
|
||||
|
|
@ -475,7 +507,7 @@ install() {
|
|||
|
||||
update() {
|
||||
get_config_info
|
||||
git_pull_factorcode
|
||||
git_fetch_factorcode
|
||||
backup_factor
|
||||
make_clean
|
||||
make_factor
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@ USING: alien arrays definitions generic assocs hashtables io
|
|||
kernel math namespaces parser prettyprint sequences strings
|
||||
tools.test words quotations classes classes.algebra
|
||||
classes.private classes.union classes.mixin classes.predicate
|
||||
vectors definitions source-files compiler.units growable
|
||||
random stack-checker effects kernel.private sbufs math.order
|
||||
vectors source-files compiler.units growable random
|
||||
stack-checker effects kernel.private sbufs math.order
|
||||
classes.tuple accessors ;
|
||||
IN: classes.algebra.tests
|
||||
|
||||
|
|
@ -317,4 +317,4 @@ SINGLETON: sc
|
|||
! UNION: u1 sa sb ;
|
||||
! UNION: u2 sc ;
|
||||
|
||||
! [ f ] [ u1 u2 classes-intersect? ] unit-test
|
||||
! [ f ] [ u1 u2 classes-intersect? ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: alien arrays generic assocs hashtables io
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -2,9 +2,8 @@ USING: alien arrays definitions generic assocs hashtables io
|
|||
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
|
||||
|
|
|
|||
|
|
@ -3,6 +3,9 @@
|
|||
USING: kernel math math.private ;
|
||||
IN: math.floats.private
|
||||
|
||||
: float-min ( x y -- z ) [ float< ] most ; foldable
|
||||
: float-max ( x y -- z ) [ float> ] most ; foldable
|
||||
|
||||
M: fixnum >float fixnum>float ; inline
|
||||
M: bignum >float bignum>float ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,13 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel kernel.private sequences
|
||||
sequences.private math math.private combinators ;
|
||||
IN: math.integers.private
|
||||
|
||||
: fixnum-min ( x y -- z ) [ fixnum< ] most ; foldable
|
||||
: fixnum-max ( x y -- z ) [ fixnum> ] most ; foldable
|
||||
|
||||
M: integer numerator ; inline
|
||||
M: integer denominator drop 1 ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -32,8 +32,8 @@ M: real after? ( obj1 obj2 -- ? ) > ; inline
|
|||
M: real before=? ( obj1 obj2 -- ? ) <= ; inline
|
||||
M: real after=? ( obj1 obj2 -- ? ) >= ; inline
|
||||
|
||||
: min ( x y -- z ) [ before? ] most ; inline
|
||||
: max ( x y -- z ) [ after? ] most ; inline
|
||||
: min ( x y -- z ) [ before? ] most ;
|
||||
: max ( x y -- z ) [ after? ] most ;
|
||||
: clamp ( x min max -- y ) [ max ] dip min ; inline
|
||||
|
||||
: between? ( x y z -- ? )
|
||||
|
|
|
|||
|
|
@ -98,9 +98,9 @@ M: f like drop [ f ] when-empty ; inline
|
|||
|
||||
INSTANCE: f immutable-sequence
|
||||
|
||||
! Integers support the sequence protocol
|
||||
M: integer length ; inline
|
||||
M: integer nth-unsafe drop ; inline
|
||||
! Integers used to support the sequence protocol
|
||||
M: integer length ; inline deprecated
|
||||
M: integer nth-unsafe drop ; inline deprecated
|
||||
|
||||
INSTANCE: integer immutable-sequence
|
||||
|
||||
|
|
|
|||
|
|
@ -219,7 +219,11 @@ HELP: <word> ( name vocab -- word )
|
|||
HELP: gensym
|
||||
{ $values { "word" word } }
|
||||
{ $description "Creates an uninterned word that is not equal to any other word in the system." }
|
||||
{ $examples { $unchecked-example "gensym ." "G:260561" } }
|
||||
{ $examples { $example "USING: prettyprint words ;"
|
||||
"gensym ."
|
||||
"( gensym )"
|
||||
}
|
||||
}
|
||||
{ $notes "Gensyms are often used as placeholder values that have no meaning of their own but must be unique. For example, the compiler uses gensyms to label sections of code." } ;
|
||||
|
||||
HELP: bootstrapping?
|
||||
|
|
|
|||
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors classes.struct combinators.smart fry kernel
|
||||
math math.functions math.order math.parser sequences
|
||||
struct-arrays io ;
|
||||
IN: benchmark.struct-arrays
|
||||
|
||||
STRUCT: point { x float } { y float } { z float } ;
|
||||
|
||||
: xyz ( point -- x y z )
|
||||
[ x>> ] [ y>> ] [ z>> ] tri ; inline
|
||||
|
||||
: change-xyz ( point obj x: ( x obj -- x' ) y: ( y obj -- y' ) z: ( z obj -- z' ) -- point )
|
||||
tri-curry [ change-x ] [ change-y ] [ change-z ] tri* ; inline
|
||||
|
||||
: init-point ( n point -- n )
|
||||
over >fixnum >float
|
||||
[ sin >>x ] [ cos 3 * >>y ] [ sin sq 2 / >>z ] tri drop
|
||||
1 + ; inline
|
||||
|
||||
: make-points ( len -- points )
|
||||
point <struct-array> dup 0 [ init-point ] reduce drop ; inline
|
||||
|
||||
: point-norm ( point -- norm )
|
||||
[ xyz [ absq ] tri@ ] sum-outputs sqrt ; inline
|
||||
|
||||
: normalize-point ( point -- )
|
||||
dup point-norm [ / ] [ / ] [ / ] change-xyz drop ; inline
|
||||
|
||||
: normalize-points ( points -- )
|
||||
[ normalize-point ] each ; inline
|
||||
|
||||
: max-point ( point1 point2 -- point1 )
|
||||
[ x>> max ] [ y>> max ] [ z>> max ] change-xyz ; inline
|
||||
|
||||
: <zero-point> ( -- point )
|
||||
0 0 0 point <struct-boa> ; inline
|
||||
|
||||
: max-points ( points -- point )
|
||||
<zero-point> [ max-point ] reduce ; inline
|
||||
|
||||
: print-point ( point -- )
|
||||
[ xyz [ number>string ] tri@ ] output>array ", " join print ; inline
|
||||
|
||||
: struct-array-benchmark ( len -- )
|
||||
make-points [ normalize-points ] [ max-points ] bi print-point ;
|
||||
|
||||
: main ( -- ) 5000000 struct-array-benchmark ;
|
||||
|
||||
MAIN: main
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: io kernel terrain.generation threads ;
|
||||
IN: benchmark.terrain-generation
|
||||
|
||||
: terrain-generation-benchmark ( -- )
|
||||
"Generating terrain segment..." write flush yield
|
||||
<terrain> { 0 0 } terrain-segment drop
|
||||
"done" print ;
|
||||
|
||||
MAIN: terrain-generation-benchmark
|
||||
|
|
@ -66,7 +66,8 @@ IN: bloom-filters.tests
|
|||
[ t ] [ 2000 iota
|
||||
full-bloom-filter
|
||||
[ bloom-filter-member? ] curry map
|
||||
[ ] all? ] unit-test
|
||||
[ ] all?
|
||||
] unit-test
|
||||
|
||||
! We shouldn't have more than 0.01 false-positive rate.
|
||||
[ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map
|
||||
|
|
@ -74,5 +75,6 @@ IN: bloom-filters.tests
|
|||
[ bloom-filter-member? ] curry map
|
||||
[ ] filter
|
||||
! TODO: This should be 10, but the false positive rate is currently very
|
||||
! high. It shouldn't be much more than this.
|
||||
length 150 <= ] unit-test
|
||||
! high. 300 is large enough not to prevent builds from succeeding.
|
||||
length 300 <=
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,232 @@
|
|||
! 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 ;
|
||||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2007, 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors images images.loader io.pathnames kernel namespaces
|
||||
opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
|
||||
ui.gadgets.panes ui.render ui.images ;
|
||||
USING: accessors images images.loader io.pathnames kernel
|
||||
models namespaces opengl opengl.gl opengl.textures sequences
|
||||
strings ui ui.gadgets ui.gadgets.panes ui.images ui.render
|
||||
constructors ;
|
||||
IN: images.viewer
|
||||
|
||||
TUPLE: image-gadget < gadget image texture ;
|
||||
|
|
@ -13,7 +14,20 @@ M: image-gadget pref-dim* image>> dim>> ;
|
|||
dup texture>> [ ] [ dup image>> { 0 0 } <texture> >>texture texture>> ] ?if ;
|
||||
|
||||
M: image-gadget draw-gadget* ( gadget -- )
|
||||
[ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture ;
|
||||
dup image>> [
|
||||
[ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
TUPLE: image-control < image-gadget ;
|
||||
|
||||
CONSTRUCTOR: image-control ( model -- image-control ) ;
|
||||
|
||||
M: image-control pref-dim* image>> [ dim>> ] [ { 640 480 } ] if* ;
|
||||
|
||||
M: image-control model-changed
|
||||
swap value>> >>image relayout ;
|
||||
|
||||
! Todo: delete texture on ungraft
|
||||
|
||||
|
|
|
|||
|
|
@ -3,37 +3,38 @@
|
|||
USING: alien alien.c-types alien.strings
|
||||
kernel libc math namespaces system-info.backend
|
||||
system-info.windows windows windows.advapi32
|
||||
windows.kernel32 system byte-arrays windows.errors ;
|
||||
windows.kernel32 system byte-arrays windows.errors
|
||||
classes classes.struct accessors ;
|
||||
IN: system-info.windows.nt
|
||||
|
||||
M: winnt cpus ( -- n )
|
||||
system-info SYSTEM_INFO-dwNumberOfProcessors ;
|
||||
system-info dwNumberOfProcessors>> ;
|
||||
|
||||
: memory-status ( -- MEMORYSTATUSEX )
|
||||
"MEMORYSTATUSEX" <c-object>
|
||||
"MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
|
||||
"MEMORYSTATUSEX" <struct>
|
||||
dup class heap-size >>dwLength
|
||||
dup GlobalMemoryStatusEx win32-error=0/f ;
|
||||
|
||||
M: winnt memory-load ( -- n )
|
||||
memory-status MEMORYSTATUSEX-dwMemoryLoad ;
|
||||
memory-status dwMemoryLoad>> ;
|
||||
|
||||
M: winnt physical-mem ( -- n )
|
||||
memory-status MEMORYSTATUSEX-ullTotalPhys ;
|
||||
memory-status ullTotalPhys>> ;
|
||||
|
||||
M: winnt available-mem ( -- n )
|
||||
memory-status MEMORYSTATUSEX-ullAvailPhys ;
|
||||
memory-status ullAvailPhys>> ;
|
||||
|
||||
M: winnt total-page-file ( -- n )
|
||||
memory-status MEMORYSTATUSEX-ullTotalPageFile ;
|
||||
memory-status ullTotalPageFile>> ;
|
||||
|
||||
M: winnt available-page-file ( -- n )
|
||||
memory-status MEMORYSTATUSEX-ullAvailPageFile ;
|
||||
memory-status ullAvailPageFile>> ;
|
||||
|
||||
M: winnt total-virtual-mem ( -- n )
|
||||
memory-status MEMORYSTATUSEX-ullTotalVirtual ;
|
||||
memory-status ullTotalVirtual>> ;
|
||||
|
||||
M: winnt available-virtual-mem ( -- n )
|
||||
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
|
||||
memory-status ullAvailVirtual>> ;
|
||||
|
||||
: computer-name ( -- string )
|
||||
MAX_COMPUTERNAME_LENGTH 1 +
|
||||
|
|
|
|||
|
|
@ -1,24 +1,24 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types kernel libc math namespaces
|
||||
windows windows.kernel32 windows.advapi32
|
||||
words combinators vocabs.loader system-info.backend
|
||||
system alien.strings windows.errors ;
|
||||
USING: alien alien.c-types classes.struct accessors kernel
|
||||
math namespaces windows windows.kernel32 windows.advapi32 words
|
||||
combinators vocabs.loader system-info.backend system
|
||||
alien.strings windows.errors ;
|
||||
IN: system-info.windows
|
||||
|
||||
: system-info ( -- SYSTEM_INFO )
|
||||
"SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
|
||||
SYSTEM_INFO <struct> [ GetSystemInfo ] keep ;
|
||||
|
||||
: page-size ( -- n )
|
||||
system-info SYSTEM_INFO-dwPageSize ;
|
||||
system-info dwPageSize>> ;
|
||||
|
||||
! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664)
|
||||
: processor-type ( -- n )
|
||||
system-info SYSTEM_INFO-dwProcessorType ;
|
||||
system-info dwProcessorType>> ;
|
||||
|
||||
! 0 = x86, 6 = Intel Itanium, 9 = x64 (AMD or Intel), 10 = WOW64, 0xffff = Unk
|
||||
: processor-architecture ( -- n )
|
||||
system-info SYSTEM_INFO-dwOemId HEX: ffff0000 bitand ;
|
||||
system-info dwOemId>> HEX: ffff0000 bitand ;
|
||||
|
||||
: os-version ( -- os-version )
|
||||
"OSVERSIONINFO" <c-object>
|
||||
|
|
|
|||
Loading…
Reference in New Issue