ARTICLE: "c-arrays" "C arrays"\r
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."\r
$nl\r
-"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ;\r
+"C type specifiers for array types are documented in " { $link "c-types-specs" } "."\r
+$nl\r
+"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " vocabulary set. They can also be loaded and constructed through their primitive C types:"\r
+{ $subsection require-c-array }\r
+{ $subsection <c-array> }\r
+{ $subsection <c-direct-array> } ;\r
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.strings alien.c-types alien.accessors alien.structs
+USING: alien alien.strings alien.c-types alien.accessors
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 ;
+INSTANCE: array value-type
M: array c-type ;
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 ;
M: array stack-size drop "void*" stack-size ;
-M: array c-type-boxer-quot drop [ ] ;
+M: array c-type-boxer-quot
+ unclip
+ [ array-length ]
+ [ [ require-c-array ] keep ] bi*
+ [ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
-M: value-type c-type-rep drop int-rep ;
-
-M: value-type c-type-getter
- drop [ swap <displaced-alien> ] ;
-
-M: value-type c-type-setter ( type -- quot )
- [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
- '[ @ swap @ _ memcpy ] ;
-
PREDICATE: string-type < pair
first2 [ "char*" = ] [ word? ] bi* and ;
IN: alien.c-types
USING: alien help.syntax help.markup libc kernel.private
byte-arrays math strings hashtables alien.syntax alien.strings sequences
-io.encodings.string debugger destructors ;
+io.encodings.string debugger destructors vocabs.loader ;
HELP: <c-type>
{ $values { "type" hashtable } }
{ $errors "Throws an error if the type does not exist." } ;
HELP: <c-array>
-{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } }
+{ $values { "len" "a non-negative integer" } { "c-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
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
+{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
HELP: <c-object>
{ $values { "type" "a C type" } { "array" byte-array } }
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-direct-array> } "." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary 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 } }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
+{ <c-array> <c-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." }
}
} ;
+HELP: require-c-array
+{ $values { "c-type" "a C type" } }
+{ $description "Generates a specialized array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
+{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence types loaded." } ;
+
+HELP: <c-direct-array>
+{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
+{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } ;
+
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl
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
cpu.architecture alien alien.accessors alien.strings quotations
layouts system compiler.units io io.files io.encodings.binary
io.streams.memory accessors combinators effects continuations fry
-classes ;
+classes vocabs vocabs.loader ;
IN: alien.c-types
DEFER: <int>
] ?if
] if ;
+GENERIC: c-struct? ( type -- ? )
+
+M: object c-struct?
+ drop f ;
+M: string c-struct?
+ dup "void" = [ drop f ] [ c-type c-struct? ] if ;
+
+! These words being foldable means that words need to be
+! recompiled if a C type is redefined. Even so, folding the
+! size facilitates some optimizations.
+GENERIC: heap-size ( type -- size ) foldable
+
+M: string heap-size c-type heap-size ;
+
+M: abstract-c-type heap-size size>> ;
+
+GENERIC: require-c-array ( c-type -- )
+
+M: array require-c-array first require-c-array ;
+
+GENERIC: c-array-constructor ( c-type -- word )
+
+GENERIC: c-(array)-constructor ( c-type -- word )
+
+GENERIC: c-direct-array-constructor ( c-type -- word )
+
+GENERIC: <c-array> ( len c-type -- array )
+
+M: string <c-array>
+ c-array-constructor execute( len -- array ) ; inline
+
+GENERIC: (c-array) ( len c-type -- array )
+
+M: string (c-array)
+ c-(array)-constructor execute( len -- array ) ; inline
+
+GENERIC: <c-direct-array> ( alien len c-type -- array )
+
+M: string <c-direct-array>
+ c-direct-array-constructor execute( alien len -- array ) ; inline
+
+: malloc-array ( n type -- alien )
+ [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
+
+: (malloc-array) ( n type -- alien )
+ [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
+
GENERIC: c-type-class ( name -- class )
M: abstract-c-type c-type-class class>> ;
M: string unbox-return c-type unbox-return ;
-! These words being foldable means that words need to be
-! recompiled if a C type is redefined. Even so, folding the
-! size facilitates some optimizations.
-GENERIC: heap-size ( type -- size ) foldable
-
-M: string heap-size c-type heap-size ;
-
-M: abstract-c-type heap-size size>> ;
-
GENERIC: stack-size ( type -- size ) foldable
M: string stack-size c-type stack-size ;
M: c-type stack-size size>> cell align ;
+MIXIN: value-type
+
+M: value-type c-type-rep drop int-rep ;
+
+M: value-type c-type-getter
+ drop [ swap <displaced-alien> ] ;
+
+M: value-type c-type-setter ( type -- quot )
+ [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
+ '[ @ swap @ _ memcpy ] ;
+
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 [
[ "Cannot write struct fields with this type" throw ]
] unless* ;
-: <c-array> ( n type -- array )
- heap-size * <byte-array> ; inline
-
: <c-object> ( type -- array )
- 1 swap <c-array> ; inline
+ heap-size <byte-array> ; inline
-: malloc-array ( n type -- alien )
- heap-size calloc ; inline
+: (c-object) ( type -- array )
+ heap-size (byte-array) ; 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 ;
] [ [ + ] 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 )
[
[ 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 ;
4 >>align
"box_float" >>boxer
"to_float" >>unboxer
- single-float-rep >>rep
+ float-rep >>rep
[ >float ] >>unboxer-quot
"float" define-primitive-type
8 >>align
"box_double" >>boxer
"to_double" >>unboxer
- double-float-rep >>rep
+ double-rep >>rep
[ >float ] >>unboxer-quot
"double" define-primitive-type
"long" "intptr_t" typedef
"ulong" "size_t" typedef
] with-compilation-unit
+
! 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
\ No newline at end of file
+[ number ] [ "complex-double" c-type-boxed-class ] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.structs alien.complex.functor accessors
+USING: alien.c-types alien.complex.functor accessors
sequences kernel ;
IN: alien.complex
! 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.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 current-vocab
-{ { N "real" } { N "imaginary" } }
-define-struct
+ T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline
-T c-type
+T-class c-type
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
number >>boxed-class
! Copyright (C) 2009 Joe Groff
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations sequences strings words.symbol ;
+USING: help.markup help.syntax kernel quotations sequences strings words.symbol classes.struct ;
QUALIFIED-WITH: alien.syntax c
IN: alien.fortran
{ { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." }
{ { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." }
{ "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." }
- { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameter and return types." }
+ { "Struct classes defined by " { $link POSTPONE: STRUCT: } " are also supported as parameter and return types." }
}
"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ;
{ $values { "name" "a logical library name" } }
{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ;
-HELP: RECORD:
-{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" }
-{ $description "Defines a Fortran record type with the given slots. The record is defined as the corresponding C struct and can be used as a type for subsequent Fortran or C function declarations." } ;
-
HELP: add-fortran-library
{ $values { "name" string } { "soname" string } { "fortran-abi" symbol } }
{ $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." }
{ $subsection POSTPONE: LIBRARY: }
{ $subsection POSTPONE: FUNCTION: }
{ $subsection POSTPONE: SUBROUTINE: }
-{ $subsection POSTPONE: RECORD: }
{ $subsection fortran-invoke }
;
! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.complex
-alien.fortran alien.fortran.private alien.strings alien.structs
+alien.fortran alien.fortran.private alien.strings classes.struct
arrays assocs byte-arrays combinators fry
generalizations io.encodings.ascii kernel macros
macros.expander namespaces sequences shuffle tools.test ;
<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >>
LIBRARY: (alien.fortran-tests)
-RECORD: FORTRAN_TEST_RECORD
- { "INTEGER" "FOO" }
- { "REAL(2)" "BAR" }
- { "CHARACTER*4" "BAS" } ;
+STRUCT: FORTRAN_TEST_RECORD
+ { FOO int }
+ { BAR double[2] }
+ { BAS char[4] } ;
intel-unix-abi fortran-abi [
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
- ! fortran-record>c-struct
-
- [ {
- { "double" "ex" }
- { "float" "wye" }
- { "int" "zee" }
- { "char[20]" "woo" }
- } ] [
- {
- { "DOUBLE-PRECISION" "EX" }
- { "REAL" "WYE" }
- { "INTEGER" "ZEE" }
- { "CHARACTER(20)" "WOO" }
- } fortran-record>c-struct
- ] unit-test
-
- ! RECORD:
-
- [ 16 ] [ "fortran_test_record" heap-size ] unit-test
- [ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test
- [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test
- [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test
-
! (fortran-invoke)
[ [
! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.complex alien.parser
-alien.strings alien.structs alien.syntax arrays ascii assocs
+alien.strings alien.syntax arrays ascii assocs
byte-arrays combinators combinators.short-circuit fry generalizations
kernel lexer macros math math.parser namespaces parser sequences
splitting stack-checker vectors vocabs.parser words locals
: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args )
[ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ;
-: fortran-record>c-struct ( record -- struct )
- [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ;
-
-: define-fortran-record ( name vocab fields -- )
- [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
-
-SYNTAX: RECORD: scan current-vocab parse-definition define-fortran-record ;
-
: set-fortran-abi ( library -- )
library-fortran-abis get-global at fortran-abi set ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators alien alien.strings alien.syntax
-prettyprint.backend prettyprint.custom prettyprint.sections ;
+math.parser prettyprint.backend prettyprint.custom
+prettyprint.sections ;
IN: alien.prettyprint
M: alien pprint*
{
{ [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
- [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
+ [ \ ALIEN: [ alien-address >hex text ] pprint-prefix ]
} cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
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 ;
}
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
-"Arrays of C structures can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
+"Arrays of C structures can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ;
ARTICLE: "c-unions" "C unions"
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
{ $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." ;
\ No newline at end of file
+"Arrays of C unions can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ;
TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
+INSTANCE: struct-type value-type
+
M: struct-type c-type ;
M: struct-type c-type-stack-align? drop f ;
M: struct-type stack-size
[ heap-size ] [ stack-size ] if-value-struct ;
-: c-struct? ( type -- ? ) (c-type) struct-type? ;
+M: struct-type c-struct? drop t ;
-: (define-struct) ( name size align fields -- )
- [ [ align ] keep ] dip
- struct-type new
+: (define-struct) ( name size align fields class -- )
+ [ [ align ] keep ] 2dip new
byte-array >>class
byte-array >>boxed-class
swap >>fields
[ 2drop ] [ make-fields ] 3bi
[ struct-offsets ] keep
[ [ type>> ] map compute-struct-align ] keep
- [ (define-struct) ] keep
- [ define-field ] each ;
+ [ struct-type (define-struct) ] keep
+ [ define-field ] each ; deprecated
: define-union ( name members -- )
- [ expand-constants ] map
[ [ heap-size ] [ max ] map-reduce ] keep
- compute-struct-align f (define-struct) ;
+ compute-struct-align f struct-type (define-struct) ; deprecated
: offset-of ( field struct -- offset )
c-types get at fields>>
[ name>> = ] with find nip offset>> ;
+
+USE: vocabs.loader
+"specialized-arrays" require
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\"" }
HELP: ALIEN:
{ $syntax "ALIEN: address" }
-{ $values { "address" "a non-negative integer" } }
+{ $values { "address" "a non-negative hexadecimal integer" } }
{ $description "Creates an alien object at parse time." }
{ $notes "Alien objects are invalidated between image saves and loads, and hence source files should not contain alien literals; this word is for interactive use only. See " { $link "alien-expiry" } " for details." } ;
{ $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." }
{ $syntax "C-ENUM: words... ;" }
{ $values { "words" "a sequence of word names" } }
{ $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." }
-{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use symbolic constants instead." }
+{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use " { $link "words.symbol" } " or " { $link "singletons" } " instead." }
{ $examples
- "The following two lines are equivalent:"
- { $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" }
+ "Here is an example enumeration definition:"
+ { $code "C-ENUM: red green blue ;" }
+ "It is equivalent to the following series of definitions:"
+ { $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" }
} ;
HELP: &:
SYNTAX: DLL" lexer get skip-blank parse-string dlopen parsed ;
-SYNTAX: ALIEN:
scan string>number <alien> parsed ;
+SYNTAX: ALIEN:
16 scan-base <alien> parsed ;
SYNTAX: BAD-ALIEN <bad-alien> parsed ;
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
bit-array boa
dup clean-up ; inline
-M: bit-array byte-length length 7 + -3 shift ;
+M: bit-array byte-length length 7 + -3 shift ; inline
SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
--- /dev/null
+unportable
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax arrays calendar
-kernel math unix unix.time unix.types namespaces system ;
+kernel math unix unix.time unix.types namespaces system
+accessors classes.struct ;
IN: calendar.unix
: timeval>seconds ( timeval -- seconds )
- [ timeval-sec seconds ] [ timeval-usec microseconds ] bi
- time+ ;
+ [ sec>> seconds ] [ usec>> microseconds ] bi time+ ;
: timeval>unix-time ( timeval -- timestamp )
timeval>seconds since-1970 ;
: timespec>seconds ( timespec -- seconds )
- [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi
- time+ ;
+ [ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
: timespec>unix-time ( timespec -- timestamp )
timespec>seconds since-1970 ;
: get-time ( -- alien )
- f time <time_t> localtime ;
+ f time <time_t> localtime tm memory>struct ;
: timezone-name ( -- string )
- get-time tm-zone ;
+ get-time zone>> ;
M: unix gmt-offset ( -- hours minutes seconds )
- get-time tm-gmtoff 3600 /mod 60 /mod ;
+ get-time gmtoff>> 3600 /mod 60 /mod ;
USING: calendar namespaces alien.c-types system
-windows.kernel32 kernel math combinators windows.errors ;
+windows.kernel32 kernel math combinators windows.errors
+accessors classes.struct ;
IN: calendar.windows
M: windows gmt-offset ( -- hours minutes seconds )
- "TIME_ZONE_INFORMATION" <c-object>
+ TIME_ZONE_INFORMATION <struct>
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_INVALID [ win32-error-string throw ] }
- { TIME_ZONE_ID_UNKNOWN [ TIME_ZONE_INFORMATION-Bias ] }
- { TIME_ZONE_ID_STANDARD [ TIME_ZONE_INFORMATION-Bias ] }
- { TIME_ZONE_ID_DAYLIGHT [
- [ TIME_ZONE_INFORMATION-Bias ]
- [ TIME_ZONE_INFORMATION-DaylightBias ] bi +
- ] }
+ { TIME_ZONE_ID_UNKNOWN [ Bias>> ] }
+ { TIME_ZONE_ID_STANDARD [ Bias>> ] }
+ { TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] }
} case neg 60 /mod 0 ;
sequences byte-arrays locals sequences.private macros fry
io.encodings.binary math.bitwise checksums accessors
checksums.common checksums.stream combinators combinators.smart
-specialized-arrays.uint literals hints ;
+specialized-arrays literals hints ;
+SPECIALIZED-ARRAY: uint
IN: checksums.md5
SINGLETON: md5
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors alien alien.c-types arrays assocs classes
+classes.struct combinators combinators.short-circuit continuations
+fry kernel libc make math math.parser mirrors prettyprint.backend
+prettyprint.custom prettyprint.sections see.private sequences
+slots strings summary words ;
+IN: classes.struct.prettyprint
+
+<PRIVATE
+
+: struct-definer-word ( class -- word )
+ struct-slots dup length 2 >=
+ [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
+ [ drop \ STRUCT: ] if ;
+
+: struct>assoc ( struct -- assoc )
+ [ class struct-slots ] [ struct-slot-values ] bi zip ;
+
+: pprint-struct-slot ( slot -- )
+ <flow \ { pprint-word
+ f <inset {
+ [ name>> text ]
+ [ type>> dup string? [ text ] [ pprint* ] if ]
+ [ read-only>> [ \ read-only pprint-word ] when ]
+ [ initial>> [ \ initial: pprint-word pprint* ] when* ]
+ } cleave block>
+ \ } pprint-word block> ;
+
+: pprint-struct ( struct -- )
+ [
+ [ \ S{ ] dip
+ [ class ]
+ [ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
+ \ } (pprint-tuple)
+ ] ?pprint-tuple ;
+
+: pprint-struct-pointer ( struct -- )
+ \ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
+
+PRIVATE>
+
+M: struct-class see-class*
+ <colon dup struct-definer-word pprint-word dup pprint-word
+ <block struct-slots [ pprint-struct-slot ] each
+ block> pprint-; block> ;
+
+M: struct pprint-delims
+ drop \ S{ \ } ;
+
+M: struct >pprint-sequence
+ [ class ] [ struct-slot-values ] bi class-slot-sequence ;
+
+M: struct pprint*
+ [ pprint-struct ]
+ [ pprint-struct-pointer ] pprint-c-object ;
+
+M: struct summary
+ [
+ dup class name>> %
+ " struct of " %
+ byte-length #
+ " bytes " %
+ ] "" make ;
+
+TUPLE: struct-mirror { object read-only } ;
+C: <struct-mirror> struct-mirror
+
+: get-struct-slot ( struct slot -- value present? )
+ over class struct-slots slot-named
+ [ name>> reader-word execute( struct -- value ) t ]
+ [ drop f f ] if* ;
+: set-struct-slot ( value struct slot -- )
+ over class struct-slots slot-named
+ [ name>> writer-word execute( value struct -- ) ]
+ [ 2drop ] if* ;
+: reset-struct-slot ( struct slot -- )
+ over class struct-slots slot-named
+ [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ]
+ [ drop ] if* ;
+: reset-struct-slots ( struct -- )
+ dup class struct-prototype
+ dup byte-length memcpy ;
+
+M: struct-mirror at*
+ object>> {
+ { [ over "underlying" = ] [ nip >c-ptr t ] }
+ { [ over { [ array? ] [ length 1 >= ] } 1&& ] [ swap first get-struct-slot ] }
+ [ 2drop f f ]
+ } cond ;
+
+M: struct-mirror set-at
+ object>> {
+ { [ over "underlying" = ] [ 3drop ] }
+ { [ over array? ] [ swap first set-struct-slot ] }
+ [ 3drop ]
+ } cond ;
+
+M: struct-mirror delete-at
+ object>> {
+ { [ over "underlying" = ] [ 2drop ] }
+ { [ over array? ] [ swap first reset-struct-slot ] }
+ [ 2drop ]
+ } cond ;
+
+M: struct-mirror clear-assoc
+ object>> reset-struct-slots ;
+
+M: struct-mirror >alist ( mirror -- alist )
+ object>> [
+ [ drop "underlying" ] [ >c-ptr ] bi 2array 1array
+ ] [
+ '[
+ _ struct>assoc
+ [ [ [ name>> ] [ type>> ] bi 2array ] dip ] assoc-map
+ ] [ drop { } ] recover
+ ] bi append ;
+
+M: struct make-mirror <struct-mirror> ;
+
+INSTANCE: struct-mirror assoc
--- /dev/null
+! (c)Joe Groff bsd license
+USING: alien classes help.markup help.syntax kernel libc
+quotations slots ;
+IN: classes.struct
+
+HELP: <struct-boa>
+{ $values
+ { "class" class }
+}
+{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
+
+HELP: (struct)
+{ $values
+ { "class" class }
+ { "struct" struct }
+}
+{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are 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 }
+ { "struct" struct }
+}
+{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ;
+
+{ <struct> <struct-boa> malloc-struct memory>struct } related-words
+
+HELP: STRUCT:
+{ $syntax "STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:"
+{ $list
+{ "Struct classes cannot have a superclass defined." }
+{ "The slots of a struct must all have a type declared. The type must be a C type." }
+{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
+} } ;
+
+HELP: S{
+{ $syntax "S{ class slots... }" }
+{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
+{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
+
+HELP: S@
+{ $syntax "S@ class alien" }
+{ $values { "class" "a " { $link struct } " class word" } { "alien" "a literal alien" } }
+{ $description "Marks the beginning of a literal struct at a specific C address. The prettyprinter uses this syntax when the memory backing a struct object is invalid. This syntax should not generally be used in source code." } ;
+
+{ POSTPONE: S{ POSTPONE: S@ } related-words
+
+HELP: UNION-STRUCT:
+{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
+
+HELP: define-struct-class
+{ $values
+ { "class" class } { "slots" "a sequence of " { $link 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 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." } ;
+
+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 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
+ { "ptr" c-ptr } { "class" class }
+ { "struct" struct }
+}
+{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
+
+HELP: struct
+{ $class-description "The parent class of all struct types." } ;
+
+{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words
+
+HELP: struct-class
+{ $class-description "The metaclass of all " { $link struct } " classes." } ;
+
+ARTICLE: "classes.struct" "Struct classes"
+{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
+{ $subsection POSTPONE: STRUCT: }
+"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
+{ $subsection <struct> }
+{ $subsection <struct-boa> }
+{ $subsection malloc-struct }
+{ $subsection memory>struct }
+"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."
+{ $subsection POSTPONE: UNION-STRUCT: }
+;
+
+ABOUT: "classes.struct"
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors alien alien.c-types ascii
+assocs byte-arrays classes.struct classes.tuple.private
+combinators compiler.tree.debugger compiler.units destructors
+io.encodings.utf8 io.pathnames io.streams.string kernel libc
+literals math mirrors multiline namespaces prettyprint
+prettyprint.config see sequences specialized-arrays system
+tools.test parser lexer eval layouts ;
+SPECIALIZED-ARRAY: char
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: ushort
+IN: classes.struct.tests
+
+SYMBOL: struct-test-empty
+
+[ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
+[ struct-must-have-slots? ] must-fail-with
+
+STRUCT: struct-test-foo
+ { x char }
+ { y int initial: 123 }
+ { z bool } ;
+
+STRUCT: struct-test-bar
+ { w ushort initial: HEX: ffff }
+ { foo struct-test-foo } ;
+
+[ 12 ] [ struct-test-foo heap-size ] unit-test
+[ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
+[ 16 ] [ struct-test-bar heap-size ] unit-test
+[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
+[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
+
+[ 1 2 3 t ] [
+ 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
+ {
+ [ w>> ]
+ [ foo>> x>> ]
+ [ foo>> y>> ]
+ [ foo>> z>> ]
+ } cleave
+] unit-test
+
+[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
+[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
+
+[ {
+ { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
+ { { "x" "char" } 98 }
+ { { "y" "int" } HEX: 7F00007F }
+ { { "z" "bool" } f }
+} ] [
+ B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
+ make-mirror >alist
+] unit-test
+
+[ { { "underlying" f } } ] [
+ f struct-test-foo memory>struct
+ make-mirror >alist
+] unit-test
+
+[ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test
+[ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int" } swap at* ] unit-test
+[ t t ] [ S{ struct-test-foo { z t } } make-mirror { "z" "bool" } swap at* ] unit-test
+[ f t ] [ S{ struct-test-foo { z f } } make-mirror { "z" "bool" } swap at* ] unit-test
+[ f f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
+[ f f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
+[ f t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test
+
+[ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [
+ S{ struct-test-foo { x 1 } { y 2 } { z f } }
+ [ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 5 } { z f } } ] [
+ S{ struct-test-foo { x 1 } { y 2 } { z f } }
+ [ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z t } } ] [
+ S{ struct-test-foo { x 1 } { y 2 } { z f } }
+ [ make-mirror [ t { "z" "bool" } ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+ S{ struct-test-foo { x 1 } { y 2 } { z f } }
+ [ make-mirror [ "nonsense" "underlying" ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+ S{ struct-test-foo { x 1 } { y 2 } { z f } }
+ [ make-mirror [ "nonsense" "nonexist" ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+ S{ struct-test-foo { x 1 } { y 2 } { z f } }
+ [ make-mirror [ "nonsense" { "nonexist" "int" } ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 123 } { z f } } ] [
+ S{ struct-test-foo { x 1 } { y 2 } { z f } }
+ [ make-mirror { "y" "int" } swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 0 } { y 2 } { z f } } ] [
+ S{ struct-test-foo { x 1 } { y 2 } { z f } }
+ [ make-mirror { "x" "char" } swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+ S{ struct-test-foo { x 1 } { y 2 } { z f } }
+ [ make-mirror { "nonexist" "char" } swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+ S{ struct-test-foo { x 1 } { y 2 } { z f } }
+ [ make-mirror "underlying" swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+ S{ struct-test-foo { x 1 } { y 2 } { z f } }
+ [ make-mirror "nonsense" swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 0 } { y 123 } { z f } } ] [
+ S{ struct-test-foo { x 1 } { y 2 } { z t } }
+ [ make-mirror clear-assoc ] keep
+] unit-test
+
+UNION-STRUCT: struct-test-float-and-bits
+ { f float }
+ { bits uint } ;
+
+[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
+[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
+
+[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
+
+STRUCT: struct-test-string-ptr
+ { x char* } ;
+
+[ "hello world" ] [
+ [
+ struct-test-string-ptr <struct>
+ "hello world" utf8 malloc-string &free >>x
+ x>>
+ ] with-destructors
+] unit-test
+
+[ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
+[
+ [
+ boa-tuples? off
+ c-object-pointers? off
+ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
+ ] with-scope
+] unit-test
+
+[ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
+[
+ [
+ c-object-pointers? on
+ 12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
+ ] with-scope
+] unit-test
+
+[ "S{ struct-test-foo f 0 7654 f }" ]
+[
+ [
+ boa-tuples? on
+ c-object-pointers? off
+ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
+ ] with-scope
+] unit-test
+
+[ "S@ struct-test-foo f" ]
+[
+ [
+ c-object-pointers? off
+ f struct-test-foo memory>struct [ pprint ] with-string-writer
+ ] with-scope
+] unit-test
+
+[ <" USING: classes.struct ;
+IN: classes.struct.tests
+STRUCT: struct-test-foo
+ { x char initial: 0 } { y int initial: 123 } { z bool } ;
+"> ]
+[ [ struct-test-foo see ] with-string-writer ] unit-test
+
+[ <" USING: classes.struct ;
+IN: classes.struct.tests
+UNION-STRUCT: struct-test-float-and-bits
+ { f float initial: 0.0 } { bits uint initial: 0 } ;
+"> ]
+[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
+
+[ {
+ T{ struct-slot-spec
+ { name "x" }
+ { offset 0 }
+ { initial 0 }
+ { class fixnum }
+ { type "char" }
+ }
+ T{ struct-slot-spec
+ { name "y" }
+ { offset 4 }
+ { initial 123 }
+ { class integer }
+ { type "int" }
+ }
+ T{ struct-slot-spec
+ { name "z" }
+ { offset 8 }
+ { initial f }
+ { type "bool" }
+ { class object }
+ }
+} ] [ "struct-test-foo" c-type fields>> ] unit-test
+
+[ {
+ T{ struct-slot-spec
+ { name "f" }
+ { offset 0 }
+ { type "float" }
+ { class float }
+ { initial 0.0 }
+ }
+ T{ struct-slot-spec
+ { name "bits" }
+ { offset 0 }
+ { type "uint" }
+ { class integer }
+ { initial 0 }
+ }
+} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
+
+STRUCT: struct-test-equality-1
+ { x int } ;
+STRUCT: struct-test-equality-2
+ { y int } ;
+
+[ t ] [
+ [
+ struct-test-equality-1 <struct> 5 >>x
+ struct-test-equality-1 malloc-struct &free 5 >>x =
+ ] with-destructors
+] unit-test
+
+[ f ] [
+ [
+ struct-test-equality-1 <struct> 5 >>x
+ struct-test-equality-2 malloc-struct &free 5 >>y =
+ ] with-destructors
+] unit-test
+
+[ t ] [
+ [
+ struct-test-equality-1 <struct> 5 >>x
+ struct-test-equality-1 malloc-struct &free 5 >>x
+ [ hashcode ] bi@ =
+ ] with-destructors
+] unit-test
+
+STRUCT: struct-test-array-slots
+ { x int }
+ { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
+ { z int } ;
+
+[ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
+
+[ t ] [
+ struct-test-array-slots <struct>
+ [ y>> [ 8 3 ] dip set-nth ]
+ [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
+] unit-test
+
+STRUCT: struct-test-optimization
+ { x { "int" 3 } } { y int } ;
+
+SPECIALIZED-ARRAY: struct-test-optimization
+
+[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+[ t ] [
+ [ 3 <direct-struct-test-optimization-array> third y>> ]
+ { <tuple> <tuple-boa> memory>struct y>> } inlined?
+] unit-test
+
+[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+
+[ t ] [
+ [ struct-test-optimization memory>struct x>> second ]
+ { memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
+] unit-test
+
+[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+
+[ t ] [
+ [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
+ { x>> } inlined?
+] unit-test
+
+! Test cloning structs
+STRUCT: clone-test-struct { x int } { y char[3] } ;
+
+[ 1 char-array{ 9 1 1 } ] [
+ clone-test-struct <struct>
+ 1 >>x char-array{ 9 1 1 } >>y
+ clone
+ [ x>> ] [ y>> >char-array ] bi
+] unit-test
+
+[ t 1 char-array{ 9 1 1 } ] [
+ [
+ clone-test-struct malloc-struct &free
+ 1 >>x char-array{ 9 1 1 } >>y
+ clone
+ [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
+ ] with-destructors
+] unit-test
+
+STRUCT: struct-that's-a-word { x int } ;
+
+: struct-that's-a-word ( -- ) "OOPS" throw ;
+
+[ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
+
+! Interactive parsing of struct slot definitions
+[
+ "USE: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" <string-reader>
+ "struct-class-test-1" parse-stream
+] [ error>> error>> unexpected-eof? ] must-fail-with
+
+! S{ with non-struct type
+[
+ "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
+ eval( -- value )
+] must-fail
+
+! Subclassing a struct class should not be allowed
+[
+ "USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
+ eval( -- )
+] must-fail
+
+! Remove c-type when struct class is forgotten
+[ ] [
+ "USE: classes.struct IN: classes.struct.tests TUPLE: a-struct ;" eval( -- )
+] unit-test
+
+[ f ] [ "a-struct" c-types get key? ] unit-test
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors alien alien.c-types arrays byte-arrays classes
+classes.parser classes.tuple classes.tuple.parser
+classes.tuple.private combinators combinators.short-circuit
+combinators.smart cpu.architecture definitions functors.backend
+fry generalizations generic.parser kernel kernel.private lexer
+libc locals macros make math math.order parser quotations
+sequences slots slots.private specialized-arrays vectors words
+summary namespaces assocs ;
+IN: classes.struct
+
+SPECIALIZED-ARRAY: uchar
+
+ERROR: struct-must-have-slots ;
+
+M: struct-must-have-slots summary
+ drop "Struct definitions must have slots" ;
+
+TUPLE: struct
+ { (underlying) c-ptr read-only } ;
+
+TUPLE: struct-slot-spec < slot-spec
+ type ;
+
+PREDICATE: struct-class < tuple-class
+ superclass \ struct eq? ;
+
+M: struct-class valid-superclass? drop f ;
+
+GENERIC: struct-slots ( struct-class -- slots )
+
+M: struct-class struct-slots "struct-slots" word-prop ;
+
+! struct allocation
+
+M: struct >c-ptr
+ 2 slot { c-ptr } declare ; inline
+
+M: struct equal?
+ {
+ [ [ class ] bi@ = ]
+ [ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
+ } 2&& ; inline
+
+M: struct hashcode*
+ [ >c-ptr ] [ byte-length ] bi <direct-uchar-array> hashcode* ; inline
+
+: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
+
+: memory>struct ( ptr class -- struct )
+ ! This is sub-optimal if the class is not literal, but gets
+ ! optimized down to efficient code if it is.
+ '[ _ boa ] call( ptr -- struct ) ; inline
+
+<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
+
+: malloc-struct ( class -- struct )
+ [ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ; inline
+
+: (struct) ( class -- struct )
+ [ heap-size (byte-array) ] keep memory>struct ; inline
+
+: <struct> ( class -- struct )
+ [ >c-ptr clone ] [ heap-size <byte-array> ] (init-struct) ; inline
+
+MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
+ [
+ [ <wrapper> \ (struct) [ ] 2sequence ]
+ [
+ struct-slots
+ [ length \ ndip ]
+ [ [ name>> setter-word 1quotation ] map \ spread ] bi
+ ] bi
+ ] [ ] output>sequence ;
+
+<PRIVATE
+: pad-struct-slots ( values class -- values' class )
+ [ struct-slots [ initial>> ] map over length tail append ] keep ;
+
+: (reader-quot) ( slot -- quot )
+ [ type>> c-type-getter-boxer ]
+ [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (writer-quot) ( slot -- quot )
+ [ type>> c-setter ]
+ [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (boxer-quot) ( class -- quot )
+ '[ _ memory>struct ] ;
+
+: (unboxer-quot) ( class -- quot )
+ drop [ >c-ptr ] ;
+PRIVATE>
+
+M: struct-class boa>object
+ swap pad-struct-slots
+ [ <struct> ] [ struct-slots ] bi
+ [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
+
+! Struct slot accessors
+
+GENERIC: struct-slot-values ( struct -- sequence )
+
+M: struct-class reader-quot
+ nip (reader-quot) ;
+
+M: struct-class writer-quot
+ nip (writer-quot) ;
+
+! c-types
+
+TUPLE: struct-c-type < abstract-c-type
+ fields
+ return-in-registers? ;
+
+INSTANCE: struct-c-type value-type
+
+M: struct-c-type c-type ;
+
+M: struct-c-type c-type-stack-align? drop f ;
+
+: if-value-struct ( ctype true false -- )
+ [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
+
+M: struct-c-type unbox-parameter
+ [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
+
+M: struct-c-type box-parameter
+ [ %box-large-struct ] [ box-parameter ] if-value-struct ;
+
+: if-small-struct ( c-type true false -- ? )
+ [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
+
+M: struct-c-type unbox-return
+ [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
+
+M: struct-c-type box-return
+ [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
+
+M: struct-c-type stack-size
+ [ heap-size ] [ stack-size ] if-value-struct ;
+
+M: struct-c-type c-struct? drop t ;
+
+<PRIVATE
+: struct-slot-values-quot ( class -- quot )
+ struct-slots
+ [ name>> reader-word 1quotation ] map
+ \ cleave [ ] 2sequence
+ \ output>array [ ] 2sequence ;
+
+: define-inline-method ( class generic quot -- )
+ [ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ;
+
+: (define-struct-slot-values-method) ( class -- )
+ [ \ struct-slot-values ] [ struct-slot-values-quot ] bi
+ define-inline-method ;
+
+: clone-underlying ( struct -- byte-array )
+ [ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
+
+: (define-clone-method) ( class -- )
+ [ \ clone ]
+ [ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
+ define-inline-method ;
+
+: c-type-for-class ( class -- c-type )
+ struct-c-type new swap {
+ [ drop byte-array >>class ]
+ [ >>boxed-class ]
+ [ struct-slots >>fields ]
+ [ "struct-size" word-prop >>size ]
+ [ "struct-align" word-prop >>align ]
+ [ (unboxer-quot) >>unboxer-quot ]
+ [ (boxer-quot) >>boxer-quot ]
+ } cleave ;
+
+: align-offset ( offset class -- offset' )
+ c-type-align align ;
+
+: struct-offsets ( slots -- size )
+ 0 [
+ [ type>> align-offset ] keep
+ [ (>>offset) ] [ type>> heap-size + ] 2bi
+ ] reduce ;
+
+: union-struct-offsets ( slots -- size )
+ [ 0 >>offset type>> heap-size ] [ max ] map-reduce ;
+
+: struct-align ( slots -- align )
+ [ type>> c-type-align ] [ max ] map-reduce ;
+PRIVATE>
+
+M: struct-class c-type name>> c-type ;
+
+M: struct-class c-type-align c-type c-type-align ;
+
+M: struct-class c-type-getter c-type c-type-getter ;
+
+M: struct-class c-type-setter c-type c-type-setter ;
+
+M: struct-class c-type-boxer-quot c-type c-type-boxer-quot ;
+
+M: struct-class c-type-unboxer-quot c-type c-type-boxer-quot ;
+
+M: struct-class heap-size c-type heap-size ;
+
+M: struct byte-length class "struct-size" word-prop ; foldable
+
+! class definition
+
+<PRIVATE
+: make-struct-prototype ( class -- prototype )
+ [ "struct-size" word-prop <byte-array> ]
+ [ memory>struct ]
+ [ struct-slots ] tri
+ [
+ [ initial>> ]
+ [ (writer-quot) ] bi
+ over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
+ ] each ;
+
+: (struct-methods) ( class -- )
+ [ (define-struct-slot-values-method) ]
+ [ (define-clone-method) ]
+ bi ;
+
+: (struct-word-props) ( class slots size align -- )
+ [
+ [ "struct-slots" set-word-prop ]
+ [ define-accessors ] 2bi
+ ]
+ [ "struct-size" set-word-prop ]
+ [ "struct-align" set-word-prop ] tri-curry*
+ [ tri ] 3curry
+ [ dup make-struct-prototype "prototype" set-word-prop ]
+ [ (struct-methods) ] tri ;
+
+: check-struct-slots ( slots -- )
+ [ type>> c-type drop ] each ;
+
+: redefine-struct-tuple-class ( class -- )
+ [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
+
+: (define-struct-class) ( class slots offsets-quot -- )
+ [
+ empty?
+ [ struct-must-have-slots ]
+ [ redefine-struct-tuple-class ] if
+ ]
+ swap '[
+ make-slots dup
+ [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
+ (struct-word-props)
+ ]
+ [ drop [ c-type-for-class ] [ name>> ] bi typedef ] 2tri ; inline
+PRIVATE>
+
+: define-struct-class ( class slots -- )
+ [ struct-offsets ] (define-struct-class) ;
+
+: define-union-struct-class ( class slots -- )
+ [ union-struct-offsets ] (define-struct-class) ;
+
+M: struct-class reset-class
+ [ call-next-method ] [ name>> c-types get delete-at ] bi ;
+
+ERROR: invalid-struct-slot token ;
+
+: struct-slot-class ( c-type -- class' )
+ c-type c-type-boxed-class
+ dup \ byte-array = [ drop \ c-ptr ] when ;
+
+: <struct-slot-spec> ( name c-type attributes -- slot-spec )
+ [ struct-slot-spec new ] 3dip
+ [ >>name ]
+ [ [ >>type ] [ struct-slot-class >>class ] bi ]
+ [ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
+
+<PRIVATE
+: scan-c-type ( -- c-type )
+ scan dup "{" = [ drop \ } parse-until >array ] when ;
+
+: parse-struct-slot ( -- slot )
+ scan scan-c-type \ } parse-until <struct-slot-spec> ;
+
+: parse-struct-slots ( slots -- slots' more? )
+ scan {
+ { ";" [ f ] }
+ { "{" [ parse-struct-slot over push t ] }
+ { f [ unexpected-eof ] }
+ [ invalid-struct-slot ]
+ } case ;
+
+: parse-struct-definition ( -- class slots )
+ CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
+PRIVATE>
+
+SYNTAX: STRUCT:
+ parse-struct-definition define-struct-class ;
+SYNTAX: UNION-STRUCT:
+ parse-struct-definition define-union-struct-class ;
+
+SYNTAX: S{
+ scan-word dup struct-slots parse-tuple-literal-slots parsed ;
+
+SYNTAX: S@
+ scan-word scan-object swap memory>struct 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 scan-c-type` \ } parse-until
+ [ <struct-slot-spec> over push ] 3curry 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
--- /dev/null
+Tuple-like access to structured raw memory
: NSApp ( -- app ) NSApplication -> sharedApplication ;
-: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
+CONSTANT: NSAnyEventMask HEX: ffffffff
FUNCTION: void NSBeep ( ) ;
! 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-array >>
+
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-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
! 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 ;
IN: cocoa.messages
+SPECIALIZED-ARRAY: void*
+
: make-sender ( method function -- quot )
[ over first , f , , second , \ alien-invoke , ] [ ] make ;
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 ;
} case
assoc-union alien>objc-types set-global
+: internal-cocoa-type? ( c-type -- ? )
+ [ "?" = ] [ first CHAR: _ = ] bi or ;
+
+: warn-c-type ( c-type -- )
+ dup internal-cocoa-type?
+ [ drop ] [ "Warning: no such C type: " write print ] if ;
+
: objc-struct-type ( i string -- ctype )
[ CHAR: = ] 2keep index-from swap subseq
- dup c-types get key? [
- "Warning: no such C type: " write dup print
- drop "void*"
- ] unless ;
+ dup c-types get key? [ warn-c-type "void*" ] unless ;
ERROR: no-objc-type name ;
! 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
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
! 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
TYPEDEF: CGRect NSRect
TYPEDEF: NSRect _NSRect
-C-STRUCT: NSRange
- { "NSUInteger" "location" }
- { "NSUInteger" "length" } ;
+STRUCT: NSRange
+ { location NSUInteger }
+ { length NSUInteger } ;
TYPEDEF: NSRange _NSRange
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] } ;
: 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 ;
} ;
ARTICLE: "colors.constants" "Standard color database"
-"The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and provides words for looking up color values."
+"The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and Factor's " { $snippet "factor-colors.txt" } " theme database to provide words for looking up color values by name."
{ $subsection named-color }
{ $subsection named-colors }
{ $subsection POSTPONE: COLOR: } ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs math math.parser memoize io.encodings.utf8
-io.files lexer parser colors sequences splitting
-combinators.smart ascii ;
+io.files lexer parser colors sequences splitting ascii ;
IN: colors.constants
<PRIVATE
: parse-color ( line -- name color )
- [
- [ [ string>number 255 /f ] tri@ 1.0 <rgba> ] dip
- [ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap
- ] input<sequence ;
+ first4
+ [ [ string>number 255 /f ] tri@ 1.0 <rgba> ] dip
+ [ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap ;
-: parse-rgb.txt ( lines -- assoc )
+: parse-colors ( lines -- assoc )
[ "!" head? not ] filter
[ 11 cut [ " \t" split harvest ] dip suffix ] map
[ parse-color ] H{ } map>assoc ;
-MEMO: rgb.txt ( -- assoc )
- "resource:basis/colors/constants/rgb.txt" utf8 file-lines parse-rgb.txt ;
+MEMO: colors ( -- assoc )
+ "resource:basis/colors/constants/rgb.txt"
+ "resource:basis/colors/constants/factor-colors.txt"
+ [ utf8 file-lines parse-colors ] bi@ assoc-union ;
PRIVATE>
-: named-colors ( -- keys ) rgb.txt keys ;
+: named-colors ( -- keys ) colors keys ;
ERROR: no-such-color name ;
: named-color ( name -- color )
- dup rgb.txt at [ ] [ no-such-color ] ?if ;
+ dup colors at [ ] [ no-such-color ] ?if ;
SYNTAX: COLOR: scan named-color parsed ;
\ No newline at end of file
--- /dev/null
+! Factor UI theme colors
+243 242 234 FactorLightTan
+227 226 219 FactorTan
+172 167 147 FactorDarkTan
+ 81 91 105 FactorLightSlateBlue
+ 55 62 72 FactorDarkSlateBlue
IN: combinators.short-circuit
HELP: 0&&
-{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- ? )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 0||
-{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the first true result, or " { $link f } } }
+{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- ? )" } } { "?" "the first true result, or " { $link f } } }
{ $description "If every quotation in the sequence outputs " { $link f } ", outputs " { $link f } ", otherwise outputs the result of the first quotation that did not yield " { $link f } "." } ;
HELP: 1&&
-{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- ? )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 1||
-{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the first true result, or " { $link f } } }
+{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- ? )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ;
HELP: 2&&
-{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- ? )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 2||
-{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the first true result, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- ? )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ;
HELP: 3&&
-{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- ? )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 3||
-{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the first true result, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- ? )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
HELP: n&&
USING: kernel combinators quotations arrays sequences assocs
-locals generalizations macros fry ;
+generalizations macros fry ;
IN: combinators.short-circuit
-MACRO:: n&& ( quots n -- quot )
- [ f ] quots [| q |
- n
- [ q '[ drop _ ndup @ dup not ] ]
- [ '[ drop _ ndrop f ] ]
- bi 2array
- ] map
- n '[ _ nnip ] suffix 1array
+MACRO: n&& ( quots n -- quot )
+ [
+ [ [ f ] ] 2dip swap [
+ [ '[ drop _ ndup @ dup not ] ]
+ [ drop '[ drop _ ndrop f ] ]
+ 2bi 2array
+ ] with map
+ ] [ '[ _ nnip ] suffix 1array ] bi
[ cond ] 3append ;
<PRIVATE
: 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ;
: 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ;
-MACRO:: n|| ( quots n -- quot )
- [ f ] quots [| q |
- n
- [ q '[ drop _ ndup @ dup ] ]
- [ '[ _ nnip ] ]
- bi 2array
- ] map
- n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
+MACRO: n|| ( quots n -- quot )
+ [
+ [ [ f ] ] 2dip swap [
+ [ '[ drop _ ndup @ dup ] ]
+ [ drop '[ _ nnip ] ]
+ 2bi 2array
+ ] with map
+ ] [ '[ drop _ ndrop t ] [ f ] 2array suffix 1array ] bi
[ cond ] 3append ;
<PRIVATE
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry generalizations kernel macros math.order
-stack-checker math ;
+stack-checker math sequences ;
IN: combinators.smart
MACRO: drop-outputs ( quot -- quot' )
MACRO: append-outputs ( quot -- seq )
'[ _ { } append-outputs-as ] ;
+
+MACRO: preserving ( quot -- )
+ [ infer in>> length ] keep '[ _ ndup @ ] ;
+
+MACRO: smart-if ( pred true false -- )
+ '[ _ preserving _ _ if ] ; inline
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces make math sequences layouts
-alien.c-types alien.structs cpu.architecture ;
+alien.c-types cpu.architecture ;
IN: compiler.alien
: large-struct? ( ctype -- ? )
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences arrays
-accessors vectors combinators sets classes cpu.architecture compiler.cfg
-compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ;
+accessors vectors combinators sets classes cpu.architecture
+compiler.cfg compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.def-use compiler.cfg.copy-prop compiler.cfg.rpo
+compiler.cfg.liveness ;
IN: compiler.cfg.alias-analysis
! We try to eliminate redundant slot operations using some simple heuristics.
GENERIC: analyze-aliases* ( insn -- insn' )
+M: insn analyze-aliases*
+ dup defs-vreg [ set-heap-ac ] when* ;
+
M: ##load-immediate analyze-aliases*
dup [ val>> ] [ dst>> ] bi constants get set-at ;
-M: ##flushable analyze-aliases*
- dup dst>> set-heap-ac ;
-
M: ##allocation analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
#! vreg, since they both contain the same value.
dup record-copy ;
-M: insn analyze-aliases* ;
-
: analyze-aliases ( insns -- insns' )
[ insn# set analyze-aliases* ] map-index sift ;
frame-required? on
stack-frame [ max-stack-frame ] change ;
-M: ##alien-invoke compute-stack-frame*
- stack-frame>> request-stack-frame ;
-
-M: ##alien-indirect compute-stack-frame*
- stack-frame>> request-stack-frame ;
+UNION: stack-frame-insn
+ ##alien-invoke
+ ##alien-indirect
+ ##alien-callback ;
-M: ##alien-callback compute-stack-frame*
+M: stack-frame-insn compute-stack-frame*
stack-frame>> request-stack-frame ;
M: ##call compute-stack-frame*
] when ;
\ _spill t frame-required? set-word-prop
+\ ##unary-float-function t frame-required? set-word-prop
+\ ##binary-float-function t frame-required? set-word-prop
: compute-stack-frame ( insns -- )
frame-required? off
[ f ] [
[ 1000 [ ] times ]
[ [ ##peek? ] [ ##replace? ] bi or ] contains-insn?
-] unit-test
\ No newline at end of file
+] unit-test
+
+[ f t ] [
+ [ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
+ [ [ ##unbox-any-c-ptr? ] contains-insn? ]
+ [ [ ##unbox-alien? ] contains-insn? ] bi
+] unit-test
+
+\ alien-float "intrinsic" word-prop [
+ [ f t ] [
+ [ { byte-array fixnum } declare alien-cell 4 alien-float ]
+ [ [ ##box-alien? ] contains-insn? ]
+ [ [ ##box-float? ] contains-insn? ] bi
+ ] unit-test
+
+ [ f t ] [
+ [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
+ [ [ ##box-alien? ] contains-insn? ]
+ [ [ ##box-float? ] contains-insn? ] bi
+ ] unit-test
+] when
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays
-layouts alien.c-types alien.structs
+layouts alien.c-types
stack-checker.inlining cpu.architecture
compiler.tree
compiler.tree.builder
: emit-actual-if ( #if -- )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync
- ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
+ ds-pop any-rep ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
M: #if emit-node
{
M: #phi emit-node drop ;
-M: #declare emit-node drop ;
\ No newline at end of file
+M: #declare emit-node drop ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.instructions compiler.cfg.rpo
-compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities
-compiler.cfg.mr combinators.short-circuit accessors math
-sequences sets assocs ;
+USING: kernel combinators.short-circuit accessors math sequences
+sets assocs compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg.linearization
+compiler.cfg.utilities compiler.cfg.mr compiler.utilities ;
IN: compiler.cfg.checker
+! Check invariants
+
ERROR: bad-kill-block bb ;
: check-kill-block ( bb -- )
- dup instructions>> first2
- swap ##epilogue? [
- { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1||
- ] [ ##branch? ] if
+ dup instructions>> dup penultimate ##epilogue? [
+ {
+ [ length 2 = ]
+ [ last { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1|| ]
+ } 1&&
+ ] [ last ##branch? ] if
[ drop ] [ bad-kill-block ] if ;
ERROR: last-insn-not-a-jump bb ;
dup instructions>> last {
[ ##branch? ]
[ ##dispatch? ]
- [ ##conditional-branch? ]
+ [ ##compare-branch? ]
[ ##compare-imm-branch? ]
+ [ ##compare-float-ordered-branch? ]
+ [ ##compare-float-unordered-branch? ]
[ ##fixnum-add? ]
[ ##fixnum-sub? ]
[ ##fixnum-mul? ]
USING: assocs math.order sequences ;
IN: compiler.cfg.comparisons
-SYMBOLS: cc< cc<= cc= cc> cc>= cc/= ;
+SYMBOL: +unordered+
+
+SYMBOLS:
+ cc< cc<= cc= cc> cc>= cc<> cc<>=
+ cc/< cc/<= cc/= cc/> cc/>= cc/<> cc/<>= ;
: negate-cc ( cc -- cc' )
H{
- { cc< cc>= }
- { cc<= cc> }
- { cc> cc<= }
- { cc>= cc< }
- { cc= cc/= }
- { cc/= cc= }
+ { cc< cc/< }
+ { cc<= cc/<= }
+ { cc> cc/> }
+ { cc>= cc/>= }
+ { cc= cc/= }
+ { cc<> cc/<> }
+ { cc<>= cc/<>= }
+ { cc/< cc< }
+ { cc/<= cc<= }
+ { cc/> cc> }
+ { cc/>= cc>= }
+ { cc/= cc= }
+ { cc/<> cc<> }
+ { cc/<>= cc<>= }
} at ;
: swap-cc ( cc -- cc' )
H{
- { cc< cc> }
- { cc<= cc>= }
- { cc> cc< }
- { cc>= cc<= }
- { cc= cc= }
- { cc/= cc/= }
+ { cc< cc> }
+ { cc<= cc>= }
+ { cc> cc< }
+ { cc>= cc<= }
+ { cc= cc= }
+ { cc<> cc<> }
+ { cc<>= cc<>= }
+ { cc/< cc/> }
+ { cc/<= cc/>= }
+ { cc/> cc/< }
+ { cc/>= cc/<= }
+ { cc/= cc/= }
+ { cc/<> cc/<> }
+ { cc/<>= cc/<>= }
+ } at ;
+
+: order-cc ( cc -- cc' )
+ H{
+ { cc< cc< }
+ { cc<= cc<= }
+ { cc> cc> }
+ { cc>= cc>= }
+ { cc= cc= }
+ { cc<> cc/= }
+ { cc<>= t }
+ { cc/< cc>= }
+ { cc/<= cc> }
+ { cc/> cc<= }
+ { cc/>= cc< }
+ { cc/= cc/= }
+ { cc/<> cc= }
+ { cc/<>= f }
} at ;
: evaluate-cc ( result cc -- ? )
H{
- { cc< { +lt+ } }
- { cc<= { +lt+ +eq+ } }
- { cc= { +eq+ } }
- { cc>= { +eq+ +gt+ } }
- { cc> { +gt+ } }
- { cc/= { +lt+ +gt+ } }
- } at memq? ;
\ No newline at end of file
+ { cc< { +lt+ } }
+ { cc<= { +lt+ +eq+ } }
+ { cc= { +eq+ } }
+ { cc>= { +eq+ +gt+ } }
+ { cc> { +gt+ } }
+ { cc<> { +lt+ +gt+ } }
+ { cc<>= { +lt+ +eq+ +gt+ } }
+ { cc/< { +eq+ +gt+ +unordered+ } }
+ { cc/<= { +gt+ +unordered+ } }
+ { cc/= { +lt+ +gt+ +unordered+ } }
+ { cc/>= { +lt+ +unordered+ } }
+ { cc/> { +lt+ +eq+ +unordered+ } }
+ { cc/<> { +eq+ +unordered+ } }
+ { cc/<>= { +unordered+ } }
+ } at memq? ;
+
M: ##write-barrier build-liveness-graph
dup src>> setter-liveness-graph ;
-M: ##flushable build-liveness-graph
- dup dst>> add-edges ;
-
M: ##allot build-liveness-graph
- [ dst>> allocations get conjoin ]
- [ call-next-method ] bi ;
+ [ dst>> allocations get conjoin ] [ call-next-method ] bi ;
-M: insn build-liveness-graph drop ;
+M: insn build-liveness-graph
+ dup defs-vreg dup [ add-edges ] [ 2drop ] if ;
GENERIC: compute-live-vregs ( insn -- )
M: ##write-barrier compute-live-vregs
dup src>> setter-live-vregs ;
-M: ##flushable compute-live-vregs drop ;
+M: ##fixnum-add compute-live-vregs record-live ;
+
+M: ##fixnum-sub compute-live-vregs record-live ;
+
+M: ##fixnum-mul compute-live-vregs record-live ;
M: insn compute-live-vregs
- record-live ;
+ dup defs-vreg [ drop ] [ record-live ] if ;
GENERIC: live-insn? ( insn -- ? )
-M: ##flushable live-insn? dst>> live-vreg? ;
-
M: ##set-slot live-insn? obj>> live-vreg? ;
M: ##set-slot-imm live-insn? obj>> live-vreg? ;
M: ##write-barrier live-insn? src>> live-vreg? ;
-M: insn live-insn? drop t ;
+M: ##fixnum-add live-insn? drop t ;
+
+M: ##fixnum-sub live-insn? drop t ;
+
+M: ##fixnum-mul live-insn? drop t ;
+
+M: insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ;
: eliminate-dead-code ( cfg -- cfg' )
+ ! Even though we don't use predecessors directly, we depend
+ ! on the predecessors pass updating phi nodes to remove dead
+ ! inputs.
needs-predecessors
init-dead-code
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io vectors
-classes.tuple accessors prettyprint prettyprint.config assocs
-prettyprint.backend prettyprint.custom prettyprint.sections
-parser compiler.tree.builder compiler.tree.optimizer
-cpu.architecture compiler.cfg.builder compiler.cfg.linearization
-compiler.cfg.registers compiler.cfg.stack-frame
-compiler.cfg.linear-scan compiler.cfg.two-operand
-compiler.cfg.optimizer compiler.cfg.instructions
-compiler.cfg.utilities compiler.cfg.def-use
-compiler.cfg.rpo compiler.cfg.mr compiler.cfg ;
+arrays hashtables classes.tuple accessors prettyprint
+prettyprint.config assocs prettyprint.backend prettyprint.custom
+prettyprint.sections parser compiler.tree.builder
+compiler.tree.optimizer cpu.architecture compiler.cfg.builder
+compiler.cfg.linearization compiler.cfg.registers
+compiler.cfg.stack-frame compiler.cfg.linear-scan
+compiler.cfg.two-operand compiler.cfg.optimizer
+compiler.cfg.instructions compiler.cfg.utilities
+compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
+compiler.cfg.representations.preferred compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
: fake-representations ( cfg -- )
post-order [
- instructions>>
- [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ]
- map concat
- ] map concat
- [ int-rep ] H{ } map>assoc representations set ;
\ No newline at end of file
+ instructions>> [
+ [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
+ [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ]
+ bi [ suffix ] when*
+ ] map concat
+ ] map concat >hashtable representations set ;
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel assocs sequences namespaces fry
-sets compiler.cfg.rpo compiler.cfg.instructions locals ;
+USING: accessors assocs arrays classes combinators
+compiler.units fry generalizations generic kernel locals
+namespaces quotations sequences sets slots words
+compiler.cfg.instructions compiler.cfg.instructions.syntax
+compiler.cfg.rpo ;
IN: compiler.cfg.def-use
GENERIC: defs-vreg ( insn -- vreg/f )
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
-M: ##flushable defs-vreg dst>> ;
-M: ##fixnum-overflow defs-vreg dst>> ;
-M: _fixnum-overflow defs-vreg dst>> ;
-M: insn defs-vreg drop f ;
-
-M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
-M: ##unary/temp temp-vregs temp>> 1array ;
-M: ##allot temp-vregs temp>> 1array ;
-M: ##dispatch temp-vregs temp>> 1array ;
-M: ##slot temp-vregs temp>> 1array ;
-M: ##set-slot temp-vregs temp>> 1array ;
-M: ##string-nth temp-vregs temp>> 1array ;
-M: ##set-string-nth-fast temp-vregs temp>> 1array ;
-M: ##compare temp-vregs temp>> 1array ;
-M: ##compare-imm temp-vregs temp>> 1array ;
-M: ##compare-float temp-vregs temp>> 1array ;
-M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
-M: _dispatch temp-vregs temp>> 1array ;
-M: insn temp-vregs drop f ;
-
-M: ##unary uses-vregs src>> 1array ;
-M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
-M: ##binary-imm uses-vregs src1>> 1array ;
-M: ##effect uses-vregs src>> 1array ;
-M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
-M: ##slot-imm uses-vregs obj>> 1array ;
-M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
-M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
-M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
-M: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ;
-M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
-M: ##compare-imm-branch uses-vregs src1>> 1array ;
-M: ##dispatch uses-vregs src>> 1array ;
-M: ##alien-getter uses-vregs src>> 1array ;
-M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
-M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##phi uses-vregs inputs>> values ;
-M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
-M: _compare-imm-branch uses-vregs src1>> 1array ;
-M: _dispatch uses-vregs src>> 1array ;
-M: insn uses-vregs drop f ;
+
+<PRIVATE
+
+: slot-array-quot ( slots -- quot )
+ [ reader-word 1quotation ] map dup length {
+ { 0 [ drop [ drop f ] ] }
+ { 1 [ first [ 1array ] compose ] }
+ { 2 [ first2 '[ _ _ bi 2array ] ] }
+ [ '[ _ cleave _ narray ] ]
+ } case ;
+
+: define-defs-vreg-method ( insn -- )
+ [ \ defs-vreg create-method ]
+ [ insn-def-slot [ name>> reader-word 1quotation ] [ [ drop f ] ] if* ] bi
+ define ;
+
+: define-uses-vregs-method ( insn -- )
+ [ \ uses-vregs create-method ]
+ [ insn-use-slots [ name>> ] map slot-array-quot ] bi
+ define ;
+
+: define-temp-vregs-method ( insn -- )
+ [ \ temp-vregs create-method ]
+ [ insn-temp-slots [ name>> ] map slot-array-quot ] bi
+ define ;
+
+PRIVATE>
+
+[
+ insn-classes get
+ [ [ define-defs-vreg-method ] each ]
+ [ { ##phi } diff [ define-uses-vregs-method ] each ]
+ [ [ define-temp-vregs-method ] each ]
+ tri
+] with-compilation-unit
! Computing def-use chains.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays kernel layouts math namespaces
-sequences classes.tuple cpu.architecture compiler.cfg.registers
-compiler.cfg.instructions ;
+USING: accessors arrays byte-arrays kernel layouts math
+namespaces sequences combinators splitting parser effects
+words cpu.architecture compiler.cfg.registers
+compiler.cfg.instructions compiler.cfg.instructions.syntax ;
IN: compiler.cfg.hats
-: ^^r ( -- vreg vreg ) next-vreg dup ; inline
-: ^^r1 ( obj -- vreg vreg obj ) [ ^^r ] dip ; inline
-: ^^r2 ( obj obj -- vreg vreg obj obj ) [ ^^r ] 2dip ; inline
-: ^^r3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^r ] 3dip ; inline
+<<
+
+<PRIVATE
+
+: hat-name ( insn -- word )
+ name>> "##" ?head drop "^^" prepend create-in ;
+
+: hat-quot ( insn -- quot )
+ [
+ "insn-slots" word-prop [ ] [
+ type>> {
+ { def [ [ next-vreg dup ] ] }
+ { temp [ [ next-vreg ] ] }
+ [ drop [ ] ]
+ } case swap [ dip ] curry compose
+ ] reduce
+ ] keep suffix ;
+
+: hat-effect ( insn -- effect )
+ "insn-slots" word-prop
+ [ type>> { def temp } memq? not ] filter [ name>> ] map
+ { "vreg" } <effect> ;
+
+: define-hat ( insn -- )
+ [ hat-name ] [ hat-quot ] [ hat-effect ] tri define-inline ;
+
+PRIVATE>
+
+insn-classes get [
+ dup [ insn-def-slot ] [ name>> "##" head? ] bi and
+ [ define-hat ] [ drop ] if
+] each
+
+>>
+
+: ^^load-literal ( obj -- dst )
+ [ next-vreg dup ] dip {
+ { [ dup not ] [ drop \ f tag-number ##load-immediate ] }
+ { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
+ [ ##load-reference ]
+ } cond ; inline
+
+: ^^unbox-c-ptr ( src class -- dst )
+ [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ; inline
-: ^^load-literal ( obj -- dst ) ^^r1 ##load-literal ; inline
-: ^^copy ( src -- dst ) ^^r1 any-rep ##copy ; inline
-: ^^slot ( obj slot tag -- dst ) ^^r3 next-vreg ##slot ; inline
-: ^^slot-imm ( obj slot tag -- dst ) ^^r3 ##slot-imm ; inline
-: ^^set-slot ( src obj slot tag -- ) next-vreg ##set-slot ; inline
-: ^^string-nth ( obj index -- dst ) ^^r2 next-vreg ##string-nth ; inline
-: ^^add ( src1 src2 -- dst ) ^^r2 ##add ; inline
-: ^^add-imm ( src1 src2 -- dst ) ^^r2 ##add-imm ; inline
-: ^^sub ( src1 src2 -- dst ) ^^r2 ##sub ; inline
-: ^^sub-imm ( src1 src2 -- dst ) ^^r2 ##sub-imm ; inline
: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
-: ^^mul ( src1 src2 -- dst ) ^^r2 ##mul ; inline
-: ^^mul-imm ( src1 src2 -- dst ) ^^r2 ##mul-imm ; inline
-: ^^and ( input mask -- output ) ^^r2 ##and ; inline
-: ^^and-imm ( input mask -- output ) ^^r2 ##and-imm ; inline
-: ^^or ( src1 src2 -- dst ) ^^r2 ##or ; inline
-: ^^or-imm ( src1 src2 -- dst ) ^^r2 ##or-imm ; inline
-: ^^xor ( src1 src2 -- dst ) ^^r2 ##xor ; inline
-: ^^xor-imm ( src1 src2 -- dst ) ^^r2 ##xor-imm ; inline
-: ^^shl ( src1 src2 -- dst ) ^^r2 ##shl ; inline
-: ^^shl-imm ( src1 src2 -- dst ) ^^r2 ##shl-imm ; inline
-: ^^shr ( src1 src2 -- dst ) ^^r2 ##shr ; inline
-: ^^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
-: ^^not ( src -- dst ) ^^r1 ##not ; inline
-: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline
-: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline
-: ^^integer>bignum ( src -- dst ) ^^r1 next-vreg ##integer>bignum ; inline
-: ^^add-float ( src1 src2 -- dst ) ^^r2 ##add-float ; inline
-: ^^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
-: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
-: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
-: ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
-: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
-: ^^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
-: ^^alien-unsigned-2 ( src -- dst ) ^^r1 ##alien-unsigned-2 ; inline
-: ^^alien-unsigned-4 ( src -- dst ) ^^r1 ##alien-unsigned-4 ; inline
-: ^^alien-signed-1 ( src -- dst ) ^^r1 ##alien-signed-1 ; inline
-: ^^alien-signed-2 ( src -- dst ) ^^r1 ##alien-signed-2 ; inline
-: ^^alien-signed-4 ( src -- dst ) ^^r1 ##alien-signed-4 ; inline
-: ^^alien-cell ( src -- dst ) ^^r1 ##alien-cell ; inline
-: ^^alien-float ( src -- dst ) ^^r1 ##alien-float ; inline
-: ^^alien-double ( src -- dst ) ^^r1 ##alien-double ; inline
-: ^^alien-global ( symbol library -- dst ) ^^r2 ##alien-global ; inline
-: ^^compare ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare ; inline
-: ^^compare-imm ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-imm ; inline
-: ^^compare-float ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-float ; inline
-: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline
-: ^^tag-fixnum ( src -- dst ) ^^r1 ##tag-fixnum ; inline
-: ^^untag-fixnum ( src -- dst ) ^^r1 ##untag-fixnum ; inline
-: ^^fixnum-add ( src1 src2 -- dst ) ^^r2 ##fixnum-add ; inline
-: ^^fixnum-sub ( src1 src2 -- dst ) ^^r2 ##fixnum-sub ; inline
-: ^^fixnum-mul ( src1 src2 -- dst ) ^^r2 ##fixnum-mul ; inline
-: ^^phi ( inputs -- dst ) ^^r1 ##phi ; inline
\ No newline at end of file
+: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline
+: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline
+: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences namespaces words
-math math.order layouts classes.algebra alien byte-arrays
-compiler.constants combinators compiler.cfg.registers
-compiler.cfg.instructions.syntax ;
+math math.order layouts classes.algebra classes.union
+compiler.units alien byte-arrays compiler.constants combinators
+compiler.cfg.registers compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions
+<<
+SYMBOL: insn-classes
+V{ } clone insn-classes set-global
+>>
+
: new-insn ( ... class -- insn ) f swap boa ; inline
! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: insn ;
-! Instruction with no side effects; if 'out' is never read, we
-! can eliminate it.
-TUPLE: ##flushable < insn dst ;
+! Instructions which are referentially transparent; used for
+! value numbering
+TUPLE: pure-insn < insn ;
-! Instruction which is referentially transparent; we can replace
-! repeated computation with a reference to a previous value
-TUPLE: ##pure < ##flushable ;
+! Stack operations
+INSN: ##load-immediate
+def: dst/int-rep
+constant: val ;
-TUPLE: ##unary < ##pure src ;
-TUPLE: ##unary/temp < ##unary temp ;
-TUPLE: ##binary < ##pure src1 src2 ;
-TUPLE: ##binary-imm < ##pure src1 { src2 integer } ;
-TUPLE: ##commutative < ##binary ;
-TUPLE: ##commutative-imm < ##binary-imm ;
+INSN: ##load-reference
+def: dst/int-rep
+constant: obj ;
-! Instruction only used for its side effect, produces no values
-TUPLE: ##effect < insn src ;
+INSN: ##peek
+def: dst/int-rep
+literal: loc ;
-! Read/write ops: candidates for alias analysis
-TUPLE: ##read < ##flushable ;
-TUPLE: ##write < ##effect ;
+INSN: ##replace
+use: src/int-rep
+literal: loc ;
-TUPLE: ##alien-getter < ##flushable src ;
-TUPLE: ##alien-setter < ##effect value ;
+INSN: ##inc-d
+literal: n ;
-! Stack operations
-INSN: ##load-immediate < ##pure { val integer } ;
-INSN: ##load-reference < ##pure obj ;
+INSN: ##inc-r
+literal: n ;
-GENERIC: ##load-literal ( dst value -- )
-
-M: fixnum ##load-literal tag-fixnum ##load-immediate ;
-M: f ##load-literal drop \ f tag-number ##load-immediate ;
-M: object ##load-literal ##load-reference ;
+! Subroutine calls
+INSN: ##call
+literal: word ;
-INSN: ##peek < ##flushable { loc loc } ;
-INSN: ##replace < ##effect { loc loc } ;
-INSN: ##inc-d { n integer } ;
-INSN: ##inc-r { n integer } ;
+INSN: ##jump
+literal: word ;
-! Subroutine calls
-INSN: ##call word ;
-INSN: ##jump word ;
INSN: ##return ;
! Dummy instruction that simply inhibits TCO
INSN: ##no-tco ;
! Jump tables
-INSN: ##dispatch src temp ;
+INSN: ##dispatch
+use: src/int-rep
+temp: temp/int-rep ;
! Slot access
-INSN: ##slot < ##read obj slot { tag integer } temp ;
-INSN: ##slot-imm < ##read obj { slot integer } { tag integer } ;
-INSN: ##set-slot < ##write obj slot { tag integer } temp ;
-INSN: ##set-slot-imm < ##write obj { slot integer } { tag integer } ;
+INSN: ##slot
+def: dst/int-rep
+use: obj/int-rep slot/int-rep
+literal: tag
+temp: temp/int-rep ;
+
+INSN: ##slot-imm
+def: dst/int-rep
+use: obj/int-rep
+literal: slot tag ;
+
+INSN: ##set-slot
+use: src/int-rep obj/int-rep slot/int-rep
+literal: tag
+temp: temp/int-rep ;
+
+INSN: ##set-slot-imm
+use: src/int-rep obj/int-rep
+literal: slot tag ;
! String element access
-INSN: ##string-nth < ##flushable obj index temp ;
-INSN: ##set-string-nth-fast < ##effect obj index temp ;
+INSN: ##string-nth
+def: dst/int-rep
+use: obj/int-rep index/int-rep
+temp: temp/int-rep ;
+
+INSN: ##set-string-nth-fast
+use: src/int-rep obj/int-rep index/int-rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##copy
+def: dst
+use: src
+literal: rep ;
! Integer arithmetic
-INSN: ##add < ##commutative ;
-INSN: ##add-imm < ##commutative-imm ;
-INSN: ##sub < ##binary ;
-INSN: ##sub-imm < ##binary-imm ;
-INSN: ##mul < ##commutative ;
-INSN: ##mul-imm < ##commutative-imm ;
-INSN: ##and < ##commutative ;
-INSN: ##and-imm < ##commutative-imm ;
-INSN: ##or < ##commutative ;
-INSN: ##or-imm < ##commutative-imm ;
-INSN: ##xor < ##commutative ;
-INSN: ##xor-imm < ##commutative-imm ;
-INSN: ##shl < ##binary ;
-INSN: ##shl-imm < ##binary-imm ;
-INSN: ##shr < ##binary ;
-INSN: ##shr-imm < ##binary-imm ;
-INSN: ##sar < ##binary ;
-INSN: ##sar-imm < ##binary-imm ;
-INSN: ##not < ##unary ;
-INSN: ##log2 < ##unary ;
-
-: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
-: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
+PURE-INSN: ##add
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##add-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##sub
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##sub-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##mul
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##mul-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##and
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##and-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##or
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##or-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##xor
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##xor-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##shl
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##shl-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##shr
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##shr-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##sar
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##sar-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##min
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##max
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##not
+def: dst/int-rep
+use: src/int-rep ;
+
+PURE-INSN: ##log2
+def: dst/int-rep
+use: src/int-rep ;
! Bignum/integer conversion
-INSN: ##integer>bignum < ##unary/temp ;
-INSN: ##bignum>integer < ##unary/temp ;
+PURE-INSN: ##integer>bignum
+def: dst/int-rep
+use: src/int-rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##bignum>integer
+def: dst/int-rep
+use: src/int-rep
+temp: temp/int-rep ;
! Float arithmetic
-INSN: ##add-float < ##commutative ;
-INSN: ##sub-float < ##binary ;
-INSN: ##mul-float < ##commutative ;
-INSN: ##div-float < ##binary ;
+PURE-INSN: ##unbox-float
+def: dst/double-rep
+use: src/int-rep ;
+
+PURE-INSN: ##box-float
+def: dst/int-rep
+use: src/double-rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##add-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##sub-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##mul-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##div-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##min-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##max-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##sqrt
+def: dst/double-rep
+use: src/double-rep ;
+
+! libc intrinsics
+PURE-INSN: ##unary-float-function
+def: dst/double-rep
+use: src/double-rep
+literal: func ;
+
+PURE-INSN: ##binary-float-function
+def: dst/double-rep
+use: src1/double-rep src2/double-rep
+literal: func ;
+
+! Single/double float conversion
+PURE-INSN: ##single>double-float
+def: dst/double-rep
+use: src/float-rep ;
+
+PURE-INSN: ##double>single-float
+def: dst/float-rep
+use: src/double-rep ;
! Float/integer conversion
-INSN: ##float>integer < ##unary ;
-INSN: ##integer>float < ##unary ;
-
-! Boxing and unboxing
-INSN: ##copy < ##unary rep ;
-INSN: ##unbox-float < ##unary ;
-INSN: ##unbox-any-c-ptr < ##unary/temp ;
-INSN: ##box-float < ##unary/temp ;
-INSN: ##box-alien < ##unary/temp ;
+PURE-INSN: ##float>integer
+def: dst/int-rep
+use: src/double-rep ;
+
+PURE-INSN: ##integer>float
+def: dst/double-rep
+use: src/int-rep ;
+
+! SIMD operations
+
+PURE-INSN: ##box-vector
+def: dst/int-rep
+use: src
+literal: rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##unbox-vector
+def: dst
+use: src/int-rep
+literal: rep ;
+
+PURE-INSN: ##broadcast-vector
+def: dst
+use: src/scalar-rep
+literal: rep ;
+
+PURE-INSN: ##gather-vector-2
+def: dst
+use: src1/scalar-rep src2/scalar-rep
+literal: rep ;
+
+PURE-INSN: ##gather-vector-4
+def: dst
+use: src1/scalar-rep src2/scalar-rep src3/scalar-rep src4/scalar-rep
+literal: rep ;
+
+PURE-INSN: ##add-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##sub-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##mul-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##div-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##min-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##max-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##sqrt-vector
+def: dst
+use: src
+literal: rep ;
+
+PURE-INSN: ##horizontal-add-vector
+def: dst/scalar-rep
+use: src
+literal: rep ;
+
+! Boxing and unboxing aliens
+PURE-INSN: ##box-alien
+def: dst/int-rep
+use: src/int-rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##box-displaced-alien
+def: dst/int-rep
+use: displacement/int-rep base/int-rep
+temp: temp1/int-rep temp2/int-rep
+literal: base-class ;
+
+PURE-INSN: ##unbox-any-c-ptr
+def: dst/int-rep
+use: src/int-rep
+temp: temp/int-rep ;
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
-: ##unbox-alien ( dst src -- ) 3 object tag-number ##slot-imm ;
+
+PURE-INSN: ##unbox-alien
+def: dst/int-rep
+use: src/int-rep ;
: ##unbox-c-ptr ( dst src class temp -- )
{
} cond ;
! Alien accessors
-INSN: ##alien-unsigned-1 < ##alien-getter ;
-INSN: ##alien-unsigned-2 < ##alien-getter ;
-INSN: ##alien-unsigned-4 < ##alien-getter ;
-INSN: ##alien-signed-1 < ##alien-getter ;
-INSN: ##alien-signed-2 < ##alien-getter ;
-INSN: ##alien-signed-4 < ##alien-getter ;
-INSN: ##alien-cell < ##alien-getter ;
-INSN: ##alien-float < ##alien-getter ;
-INSN: ##alien-double < ##alien-getter ;
-
-INSN: ##set-alien-integer-1 < ##alien-setter ;
-INSN: ##set-alien-integer-2 < ##alien-setter ;
-INSN: ##set-alien-integer-4 < ##alien-setter ;
-INSN: ##set-alien-cell < ##alien-setter ;
-INSN: ##set-alien-float < ##alien-setter ;
-INSN: ##set-alien-double < ##alien-setter ;
+INSN: ##alien-unsigned-1
+def: dst/int-rep
+use: src/int-rep ;
-! Memory allocation
-INSN: ##allot < ##flushable size class temp ;
+INSN: ##alien-unsigned-2
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-unsigned-4
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-signed-1
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-signed-2
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-signed-4
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-cell
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-float
+def: dst/float-rep
+use: src/int-rep ;
+
+INSN: ##alien-double
+def: dst/double-rep
+use: src/int-rep ;
+
+INSN: ##alien-vector
+def: dst
+use: src/int-rep
+literal: rep ;
-UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
+INSN: ##set-alien-integer-1
+use: src/int-rep value/int-rep ;
-INSN: ##write-barrier < ##effect card# table ;
+INSN: ##set-alien-integer-2
+use: src/int-rep value/int-rep ;
-INSN: ##alien-global < ##flushable symbol library ;
+INSN: ##set-alien-integer-4
+use: src/int-rep value/int-rep ;
+
+INSN: ##set-alien-cell
+use: src/int-rep value/int-rep ;
+
+INSN: ##set-alien-float
+use: src/int-rep value/float-rep ;
+
+INSN: ##set-alien-double
+use: src/int-rep value/double-rep ;
+
+INSN: ##set-alien-vector
+use: src/int-rep value
+literal: rep ;
+
+! Memory allocation
+INSN: ##allot
+def: dst/int-rep
+literal: size class
+temp: temp/int-rep ;
+
+INSN: ##write-barrier
+use: src/int-rep
+temp: card#/int-rep table/int-rep ;
+
+INSN: ##alien-global
+def: dst/int-rep
+literal: symbol library ;
! FFI
-INSN: ##alien-invoke params stack-frame ;
-INSN: ##alien-indirect params stack-frame ;
-INSN: ##alien-callback params stack-frame ;
-INSN: ##callback-return params ;
+INSN: ##alien-invoke
+literal: params stack-frame ;
+
+INSN: ##alien-indirect
+literal: params stack-frame ;
+
+INSN: ##alien-callback
+literal: params stack-frame ;
+
+INSN: ##callback-return
+literal: params ;
! Instructions used by CFG IR only.
INSN: ##prologue ;
INSN: ##branch ;
-INSN: ##phi < ##pure inputs ;
+INSN: ##phi
+def: dst
+literal: inputs ;
! Conditionals
-TUPLE: ##conditional-branch < insn src1 src2 cc ;
+INSN: ##compare-branch
+use: src1/int-rep src2/int-rep
+literal: cc ;
+
+INSN: ##compare-imm-branch
+use: src1/int-rep
+constant: src2
+literal: cc ;
+
+PURE-INSN: ##compare
+def: dst/int-rep
+use: src1/int-rep src2/int-rep
+literal: cc
+temp: temp/int-rep ;
+
+PURE-INSN: ##compare-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2
+literal: cc
+temp: temp/int-rep ;
+
+INSN: ##compare-float-ordered-branch
+use: src1/double-rep src2/double-rep
+literal: cc ;
+
+INSN: ##compare-float-unordered-branch
+use: src1/double-rep src2/double-rep
+literal: cc ;
+
+PURE-INSN: ##compare-float-ordered
+def: dst/int-rep
+use: src1/double-rep src2/double-rep
+literal: cc
+temp: temp/int-rep ;
+
+PURE-INSN: ##compare-float-unordered
+def: dst/int-rep
+use: src1/double-rep src2/double-rep
+literal: cc
+temp: temp/int-rep ;
-INSN: ##compare-branch < ##conditional-branch ;
-INSN: ##compare-imm-branch src1 { src2 integer } cc ;
+! Overflowing arithmetic
+INSN: ##fixnum-add
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
-INSN: ##compare < ##binary cc temp ;
-INSN: ##compare-imm < ##binary-imm cc temp ;
+INSN: ##fixnum-sub
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
-INSN: ##compare-float-branch < ##conditional-branch ;
-INSN: ##compare-float < ##binary cc temp ;
+INSN: ##fixnum-mul
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
-! Overflowing arithmetic
-TUPLE: ##fixnum-overflow < insn dst src1 src2 ;
-INSN: ##fixnum-add < ##fixnum-overflow ;
-INSN: ##fixnum-sub < ##fixnum-overflow ;
-INSN: ##fixnum-mul < ##fixnum-overflow ;
+INSN: ##gc
+temp: temp1/int-rep temp2/int-rep
+literal: data-values tagged-values uninitialized-locs ;
-INSN: ##gc temp1 temp2 data-values tagged-values uninitialized-locs ;
+INSN: ##save-context
+temp: temp1/int-rep temp2/int-rep
+literal: callback-allowed? ;
! Instructions used by machine IR only.
-INSN: _prologue stack-frame ;
-INSN: _epilogue stack-frame ;
+INSN: _prologue
+literal: stack-frame ;
+
+INSN: _epilogue
+literal: stack-frame ;
+
+INSN: _label
+literal: label ;
-INSN: _label id ;
+INSN: _branch
+literal: label ;
-INSN: _branch label ;
INSN: _loop-entry ;
-INSN: _dispatch src temp ;
-INSN: _dispatch-label label ;
+INSN: _dispatch
+use: src/int-rep
+temp: temp ;
-TUPLE: _conditional-branch < insn label src1 src2 cc ;
+INSN: _dispatch-label
+literal: label ;
-INSN: _compare-branch < _conditional-branch ;
-INSN: _compare-imm-branch label src1 { src2 integer } cc ;
+INSN: _compare-branch
+literal: label
+use: src1/int-rep src2/int-rep
+literal: cc ;
-INSN: _compare-float-branch < _conditional-branch ;
+INSN: _compare-imm-branch
+literal: label
+use: src1/int-rep
+constant: src2
+literal: cc ;
+
+INSN: _compare-float-unordered-branch
+literal: label
+use: src1/int-rep src2/int-rep
+literal: cc ;
+
+INSN: _compare-float-ordered-branch
+literal: label
+use: src1/int-rep src2/int-rep
+literal: cc ;
! Overflowing arithmetic
-TUPLE: _fixnum-overflow < insn label dst src1 src2 ;
-INSN: _fixnum-add < _fixnum-overflow ;
-INSN: _fixnum-sub < _fixnum-overflow ;
-INSN: _fixnum-mul < _fixnum-overflow ;
+INSN: _fixnum-add
+literal: label
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+INSN: _fixnum-sub
+literal: label
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+INSN: _fixnum-mul
+literal: label
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
-INSN: _gc temp1 temp2 data-values tagged-values uninitialized-locs ;
+INSN: _gc
+temp: temp1 temp2
+literal: data-values tagged-values uninitialized-locs ;
! These instructions operate on machine registers and not
! virtual registers
-INSN: _spill src rep n ;
-INSN: _reload dst rep n ;
-INSN: _spill-area-size n ;
-
-! Instructions that use vregs
-UNION: vreg-insn
- ##flushable
- ##write-barrier
- ##dispatch
- ##effect
- ##fixnum-overflow
- ##conditional-branch
- ##compare-imm-branch
- ##phi
- ##gc
- _conditional-branch
- _compare-imm-branch
- _dispatch ;
+INSN: _spill
+use: src
+literal: rep n ;
+
+INSN: _reload
+def: dst
+literal: rep n ;
+
+INSN: _spill-area-size
+literal: n ;
+
+UNION: ##allocation
+##allot
+##box-float
+##box-vector
+##box-alien
+##box-displaced-alien
+##integer>bignum ;
+
+! For alias analysis
+UNION: ##read ##slot ##slot-imm ;
+UNION: ##write ##set-slot ##set-slot-imm ;
+
+! Instructions that kill all live vregs but cannot trigger GC
+UNION: partial-sync-insn
+##unary-float-function
+##binary-float-function ;
! Instructions that kill all live vregs
UNION: kill-vreg-insn
- ##call
- ##prologue
- ##epilogue
- ##alien-invoke
- ##alien-indirect
- ##alien-callback ;
-
-! Instructions that output floats
-UNION: output-float-insn
- ##add-float
- ##sub-float
- ##mul-float
- ##div-float
- ##integer>float
- ##unbox-float
- ##alien-float
- ##alien-double ;
-
-! Instructions that take floats as inputs
-UNION: input-float-insn
- ##add-float
- ##sub-float
- ##mul-float
- ##div-float
- ##float>integer
- ##box-float
- ##set-alien-float
- ##set-alien-double
- ##compare-float
- ##compare-float-branch ;
-
-! Smackdown
-INTERSECTION: ##unary-float ##unary input-float-insn ;
-INTERSECTION: ##binary-float ##binary input-float-insn ;
+##call
+##prologue
+##epilogue
+##alien-invoke
+##alien-indirect
+##alien-callback ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
UNION: def-is-use-insn
- ##integer>bignum
- ##bignum>integer
- ##unbox-any-c-ptr ;
\ No newline at end of file
+##integer>bignum
+##bignum>integer
+##unbox-any-c-ptr ;
+
+SYMBOL: vreg-insn
+
+[
+ vreg-insn
+ insn-classes get [
+ "insn-slots" word-prop [ type>> { def use temp } memq? ] any?
+ ] filter
+ define-union-class
+] with-compilation-unit
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.tuple classes.tuple.parser kernel words
-make fry sequences parser accessors effects ;
+make fry sequences parser accessors effects namespaces
+combinators splitting classes.parser lexer quotations ;
IN: compiler.cfg.instructions.syntax
+SYMBOLS: def use temp literal constant ;
+
+SYMBOL: scalar-rep
+
+TUPLE: insn-slot-spec type name rep ;
+
+: parse-rep ( str/f -- rep )
+ {
+ { [ dup not ] [ ] }
+ { [ dup "scalar-rep" = ] [ drop scalar-rep ] }
+ [ "cpu.architecture" lookup ]
+ } cond ;
+
+: parse-insn-slot-spec ( type string -- spec )
+ over [ "Missing type" throw ] unless
+ "/" split1 parse-rep
+ insn-slot-spec boa ;
+
+: parse-insn-slot-specs ( seq -- specs )
+ [
+ f [
+ {
+ { "def:" [ drop def ] }
+ { "use:" [ drop use ] }
+ { "temp:" [ drop temp ] }
+ { "literal:" [ drop literal ] }
+ { "constant:" [ drop constant ] }
+ [ dupd parse-insn-slot-spec , ]
+ } case
+ ] reduce drop
+ ] { } make ;
+
+: insn-def-slot ( class -- slot/f )
+ "insn-slots" word-prop
+ [ type>> def eq? ] find nip ;
+
+: insn-use-slots ( class -- slots )
+ "insn-slots" word-prop
+ [ type>> use eq? ] filter ;
+
+: insn-temp-slots ( class -- slots )
+ "insn-slots" word-prop
+ [ type>> temp eq? ] filter ;
+
+! We cannot reference words in compiler.cfg.instructions directly
+! since that would create circularity.
+: insn-classes-word ( -- word )
+ "insn-classes" "compiler.cfg.instructions" lookup ;
+
: insn-word ( -- word )
- #! We want to put the insn tuple in compiler.cfg.instructions,
- #! but we cannot have circularity between that vocabulary and
- #! this one.
"insn" "compiler.cfg.instructions" lookup ;
+: pure-insn-word ( -- word )
+ "pure-insn" "compiler.cfg.instructions" lookup ;
+
: insn-effect ( word -- effect )
boa-effect in>> but-last f <effect> ;
-SYNTAX: INSN:
- parse-tuple-definition "insn#" suffix
- [ dup tuple eq? [ drop insn-word ] when ] dip
- [ define-tuple-class ]
- [ 2drop save-location ]
- [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
- 3tri ;
+: define-insn-tuple ( class superclass specs -- )
+ [ name>> ] map "insn#" suffix define-tuple-class ;
+
+: define-insn-ctor ( class specs -- )
+ [ dup '[ _ ] [ f ] [ boa , ] surround ] dip
+ [ name>> ] map f <effect> define-declared ;
+
+: define-insn ( class superclass specs -- )
+ parse-insn-slot-specs {
+ [ nip "insn-slots" set-word-prop ]
+ [ 2drop insn-classes-word get push ]
+ [ define-insn-tuple ]
+ [ 2drop save-location ]
+ [ nip define-insn-ctor ]
+ } 3cleave ;
+
+SYNTAX: INSN: CREATE-CLASS insn-word ";" parse-tokens define-insn ;
+
+SYNTAX: PURE-INSN: CREATE-CLASS pure-insn-word ";" parse-tokens define-insn ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences alien math classes.algebra fry
-locals combinators cpu.architecture compiler.tree.propagation.info
-compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
+locals combinators combinators.short-circuit cpu.architecture
+compiler.tree.propagation.info compiler.cfg.hats
+compiler.cfg.stacks compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.alien
-: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
- ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
+: emit-<displaced-alien>? ( node -- ? )
+ node-input-infos {
+ [ first class>> fixnum class<= ]
+ [ second class>> c-ptr class<= ]
+ } 1&& ;
-: (prepare-alien-accessor) ( class -- offset-vreg )
- [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
-
-: prepare-alien-accessor ( infos -- offset-vreg )
- <reversed> [ second class>> ] [ first ] bi
- dup value-info-small-fixnum? [
- literal>> (prepare-alien-accessor-imm)
- ] [ drop (prepare-alien-accessor) ] if ;
+: emit-<displaced-alien> ( node -- )
+ dup emit-<displaced-alien>? [
+ [ 2inputs [ ^^untag-fixnum ] dip ] dip
+ node-input-infos second class>>
+ ^^box-displaced-alien ds-push
+ ] [ emit-primitive ] if ;
:: inline-alien ( node quot test -- )
[let | infos [ node node-input-infos ] |
infos test call
- [ infos prepare-alien-accessor quot call ]
+ [ infos quot call ]
[ node emit-primitive ]
if
] ; inline
[ second class>> fixnum class<= ]
bi and ;
+: prepare-alien-accessor ( info -- offset-vreg )
+ class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
+
+: prepare-alien-getter ( infos -- offset-vreg )
+ first prepare-alien-accessor ;
+
: inline-alien-getter ( node quot -- )
- '[ @ ds-push ]
+ '[ prepare-alien-getter @ ds-push ]
[ inline-alien-getter? ] inline-alien ; inline
: inline-alien-setter? ( infos class -- ? )
[ third class>> fixnum class<= ]
tri and and ;
+: prepare-alien-setter ( infos -- offset-vreg )
+ second prepare-alien-accessor ;
+
: inline-alien-integer-setter ( node quot -- )
- '[ ds-pop ^^untag-fixnum @ ]
+ '[ prepare-alien-setter ds-pop ^^untag-fixnum @ ]
[ fixnum inline-alien-setter? ]
inline-alien ; inline
: inline-alien-cell-setter ( node quot -- )
- [ dup node-input-infos first class>> ] dip
- '[ ds-pop _ ^^unbox-c-ptr @ ]
+ '[ [ prepare-alien-setter ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ]
[ pinned-c-ptr inline-alien-setter? ]
inline-alien ; inline
: inline-alien-float-setter ( node quot -- )
- '[ ds-pop @ ]
+ '[ prepare-alien-setter ds-pop @ ]
[ float inline-alien-setter? ]
inline-alien ; inline
: emit-alien-float-getter ( node rep -- )
'[
_ {
- { single-float-rep [ ^^alien-float ] }
- { double-float-rep [ ^^alien-double ] }
+ { float-rep [ ^^alien-float ] }
+ { double-rep [ ^^alien-double ] }
} case
] inline-alien-getter ;
: emit-alien-float-setter ( node rep -- )
'[
_ {
- { single-float-rep [ ##set-alien-float ] }
- { double-float-rep [ ##set-alien-double ] }
+ { float-rep [ ##set-alien-float ] }
+ { double-rep [ ##set-alien-double ] }
} case
] inline-alien-float-setter ;
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math math.intervals
namespaces combinators fry arrays
+cpu.architecture
compiler.tree.propagation.info
compiler.cfg.hats
compiler.cfg.stacks
: emit-fixnum-overflow-op ( quot word -- )
! Inputs to the final instruction need to be copied because
! of loc>vreg sync
- [ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip
+ [ [ (2inputs) [ any-rep ^^copy ] bi@ ] dip call ] dip
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
emit-conditional ; inline
: emit-float-op ( insn -- )
[ 2inputs ] dip call ds-push ; inline
-: emit-float-comparison ( cc -- )
- [ 2inputs ] dip ^^compare-float ds-push ; inline
+: emit-float-ordered-comparison ( cc -- )
+ [ 2inputs ] dip ^^compare-float-ordered ds-push ; inline
+
+: emit-float-unordered-comparison ( cc -- )
+ [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline
: emit-float>fixnum ( -- )
ds-pop ^^float>integer ^^tag-fixnum ds-push ;
: emit-fixnum>float ( -- )
ds-pop ^^untag-fixnum ^^integer>float ds-push ;
+
+: emit-fsqrt ( -- )
+ ds-pop ^^sqrt ds-push ;
+
+: emit-unary-float-function ( func -- )
+ [ ds-pop ] dip ^^unary-float-function ds-push ;
+
+: emit-binary-float-function ( func -- )
+ [ 2inputs ] dip ^^binary-float-function ds-push ;
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: words sequences kernel combinators cpu.architecture
+USING: words sequences kernel combinators cpu.architecture assocs
compiler.cfg.hats
compiler.cfg.instructions
compiler.cfg.intrinsics.alien
compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
+compiler.cfg.intrinsics.simd
compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
+QUALIFIED: alien
+QUALIFIED: alien.accessors
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
QUALIFIED: classes.tuple.private
QUALIFIED: math.private
QUALIFIED: math.integers.private
-QUALIFIED: alien.accessors
+QUALIFIED: math.floats.private
+QUALIFIED: math.vectors.simd.intrinsics
+QUALIFIED: math.libm
IN: compiler.cfg.intrinsics
+: enable-intrinsics ( alist -- )
+ [ "intrinsic" set-word-prop ] assoc-each ;
+
{
- kernel.private:tag
- kernel.private:getenv
- math.private:both-fixnums?
- math.private:fixnum+
- math.private:fixnum-
- math.private:fixnum*
- math.private:fixnum+fast
- math.private:fixnum-fast
- math.private:fixnum-bitand
- math.private:fixnum-bitor
- math.private:fixnum-bitxor
- math.private:fixnum-shift-fast
- math.private:fixnum-bitnot
- math.private:fixnum*fast
- math.private:fixnum<
- math.private:fixnum<=
- math.private:fixnum>=
- math.private:fixnum>
- ! math.private:bignum>fixnum
- ! math.private:fixnum>bignum
- kernel:eq?
- slots.private:slot
- slots.private:set-slot
- strings.private:string-nth
- strings.private:set-string-nth-fast
- classes.tuple.private:<tuple-boa>
- arrays:<array>
- byte-arrays:<byte-array>
- byte-arrays:(byte-array)
- kernel:<wrapper>
- alien.accessors:alien-unsigned-1
- alien.accessors:set-alien-unsigned-1
- alien.accessors:alien-signed-1
- alien.accessors:set-alien-signed-1
- alien.accessors:alien-unsigned-2
- alien.accessors:set-alien-unsigned-2
- alien.accessors:alien-signed-2
- alien.accessors:set-alien-signed-2
- alien.accessors:alien-cell
- alien.accessors:set-alien-cell
-} [ t "intrinsic" set-word-prop ] each
+ { kernel.private:tag [ drop emit-tag ] }
+ { kernel.private:getenv [ emit-getenv ] }
+ { math.private:both-fixnums? [ drop emit-both-fixnums? ] }
+ { math.private:fixnum+ [ drop emit-fixnum+ ] }
+ { math.private:fixnum- [ drop emit-fixnum- ] }
+ { math.private:fixnum* [ drop emit-fixnum* ] }
+ { math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
+ { math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
+ { math.private:fixnum*fast [ drop emit-fixnum*fast ] }
+ { math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
+ { math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
+ { math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
+ { math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
+ { math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+ { math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
+ { math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
+ { math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
+ { math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
+ { kernel:eq? [ drop cc= emit-fixnum-comparison ] }
+ { slots.private:slot [ emit-slot ] }
+ { slots.private:set-slot [ emit-set-slot ] }
+ { strings.private:string-nth [ drop emit-string-nth ] }
+ { strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
+ { classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
+ { arrays:<array> [ emit-<array> ] }
+ { byte-arrays:<byte-array> [ emit-<byte-array> ] }
+ { byte-arrays:(byte-array) [ emit-(byte-array) ] }
+ { kernel:<wrapper> [ emit-simple-allot ] }
+ { alien:<displaced-alien> [ emit-<displaced-alien> ] }
+ { alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
+ { alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
+ { alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
+ { alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
+ { alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
+ { alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
+ { alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
+ { alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
+ { alien.accessors:alien-cell [ emit-alien-cell-getter ] }
+ { alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+} enable-intrinsics
: enable-alien-4-intrinsics ( -- )
{
- alien.accessors:alien-unsigned-4
- alien.accessors:set-alien-unsigned-4
- alien.accessors:alien-signed-4
- alien.accessors:set-alien-signed-4
- } [ t "intrinsic" set-word-prop ] each ;
+ { alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
+ { alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
+ { alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
+ { alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+ } enable-intrinsics ;
: enable-float-intrinsics ( -- )
{
- math.private:float+
- math.private:float-
- math.private:float*
- math.private:float/f
- math.private:fixnum>float
- math.private:float>fixnum
- math.private:float<
- math.private:float<=
- math.private:float>
- math.private:float>=
- math.private:float=
- alien.accessors:alien-float
- alien.accessors:set-alien-float
- alien.accessors:alien-double
- alien.accessors:set-alien-double
- } [ t "intrinsic" set-word-prop ] each ;
+ { math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
+ { math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
+ { math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
+ { math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+ { math.private:float< [ drop cc< emit-float-ordered-comparison ] }
+ { math.private:float<= [ drop cc<= emit-float-ordered-comparison ] }
+ { math.private:float>= [ drop cc>= emit-float-ordered-comparison ] }
+ { math.private:float> [ drop cc> emit-float-ordered-comparison ] }
+ { math.private:float-u< [ drop cc< emit-float-unordered-comparison ] }
+ { math.private:float-u<= [ drop cc<= emit-float-unordered-comparison ] }
+ { math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] }
+ { math.private:float-u> [ drop cc> emit-float-unordered-comparison ] }
+ { math.private:float= [ drop cc= emit-float-unordered-comparison ] }
+ { math.private:float>fixnum [ drop emit-float>fixnum ] }
+ { math.private:fixnum>float [ drop emit-fixnum>float ] }
+ { math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
+ { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] }
+ { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] }
+ { alien.accessors:alien-double [ double-rep emit-alien-float-getter ] }
+ { alien.accessors:set-alien-double [ double-rep emit-alien-float-setter ] }
+ } enable-intrinsics ;
+
+: enable-fsqrt ( -- )
+ {
+ { math.libm:fsqrt [ drop emit-fsqrt ] }
+ } enable-intrinsics ;
+
+: enable-float-min/max ( -- )
+ {
+ { math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
+ { math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
+ } enable-intrinsics ;
+
+: enable-float-functions ( -- )
+ {
+ { math.libm:facos [ drop "acos" emit-unary-float-function ] }
+ { math.libm:fasin [ drop "asin" emit-unary-float-function ] }
+ { math.libm:fatan [ drop "atan" emit-unary-float-function ] }
+ { math.libm:fatan2 [ drop "atan2" emit-binary-float-function ] }
+ { math.libm:fcos [ drop "cos" emit-unary-float-function ] }
+ { math.libm:fsin [ drop "sin" emit-unary-float-function ] }
+ { math.libm:ftan [ drop "tan" emit-unary-float-function ] }
+ { math.libm:fcosh [ drop "cosh" emit-unary-float-function ] }
+ { math.libm:fsinh [ drop "sinh" emit-unary-float-function ] }
+ { math.libm:ftanh [ drop "tanh" emit-unary-float-function ] }
+ { math.libm:fexp [ drop "exp" emit-unary-float-function ] }
+ { math.libm:flog [ drop "log" emit-unary-float-function ] }
+ { math.libm:flog10 [ drop "log10" emit-unary-float-function ] }
+ { math.libm:fpow [ drop "pow" emit-binary-float-function ] }
+ { math.libm:facosh [ drop "acosh" emit-unary-float-function ] }
+ { math.libm:fasinh [ drop "asinh" emit-unary-float-function ] }
+ { math.libm:fatanh [ drop "atanh" emit-unary-float-function ] }
+ { math.libm:fsqrt [ drop "sqrt" emit-unary-float-function ] }
+ { math.floats.private:float-min [ drop "fmin" emit-binary-float-function ] }
+ { math.floats.private:float-max [ drop "fmax" emit-binary-float-function ] }
+ { math.private:float-mod [ drop "fmod" emit-binary-float-function ] }
+ } enable-intrinsics ;
+
+: enable-min/max ( -- )
+ {
+ { math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] }
+ { math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] }
+ } enable-intrinsics ;
: enable-fixnum-log2 ( -- )
- \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
+ {
+ { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
+ } enable-intrinsics ;
-: emit-intrinsic ( node word -- )
+: enable-sse2-simd ( -- )
{
- { \ kernel.private:tag [ drop emit-tag ] }
- { \ kernel.private:getenv [ emit-getenv ] }
- { \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
- { \ math.private:fixnum+ [ drop emit-fixnum+ ] }
- { \ math.private:fixnum- [ drop emit-fixnum- ] }
- { \ math.private:fixnum* [ drop emit-fixnum* ] }
- { \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
- { \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
- { \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
- { \ math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
- { \ math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
- { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
- { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
- { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
- { \ math.private:fixnum*fast [ drop emit-fixnum*fast ] }
- { \ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
- { \ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
- { \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
- { \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
- { \ kernel:eq? [ drop cc= emit-fixnum-comparison ] }
- { \ 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 ] }
- { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
- { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
- { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
- { \ math.private:float< [ drop cc< emit-float-comparison ] }
- { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
- { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
- { \ math.private:float> [ drop cc> emit-float-comparison ] }
- { \ math.private:float= [ drop cc= emit-float-comparison ] }
- { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
- { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
- { \ slots.private:slot [ emit-slot ] }
- { \ slots.private:set-slot [ emit-set-slot ] }
- { \ strings.private:string-nth [ drop emit-string-nth ] }
- { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
- { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
- { \ arrays:<array> [ emit-<array> ] }
- { \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
- { \ byte-arrays:(byte-array) [ emit-(byte-array) ] }
- { \ kernel:<wrapper> [ emit-simple-allot ] }
- { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
- { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
- { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
- { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
- { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
- { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
- { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
- { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
- { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
- { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
- { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
- { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
- { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
- { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
- { \ alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] }
- { \ alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] }
- { \ alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] }
- { \ alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] }
- } case ;
+ { math.vectors.simd.intrinsics:assert-positive [ drop ] }
+ { math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-vector ] emit-unary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
+ { math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
+ { math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] }
+ { math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] }
+ } enable-intrinsics ;
+
+: enable-sse3-simd ( -- )
+ {
+ { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
+ } enable-intrinsics ;
+
+: emit-intrinsic ( node word -- )
+ "intrinsic" word-prop call( node -- ) ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays fry cpu.architecture kernel
+sequences compiler.tree.propagation.info
+compiler.cfg.builder.blocks compiler.cfg.stacks
+compiler.cfg.stacks.local compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.intrinsics.alien ;
+IN: compiler.cfg.intrinsics.simd
+
+: emit-vector-op ( node quot: ( rep -- ) -- )
+ [ dup node-input-infos last literal>> ] dip over representation?
+ [ [ drop ] 2dip call ] [ 2drop emit-primitive ] if ; inline
+
+: emit-binary-vector-op ( node quot -- )
+ '[ [ ds-drop 2inputs ] dip @ ds-push ] emit-vector-op ; inline
+
+: emit-unary-vector-op ( node quot -- )
+ '[ [ ds-drop ds-pop ] dip @ ds-push ] emit-vector-op ; inline
+
+: emit-gather-vector-2 ( node -- )
+ [ ^^gather-vector-2 ] emit-binary-vector-op ;
+
+: emit-gather-vector-4 ( node -- )
+ [
+ ds-drop
+ [
+ D 3 peek-loc
+ D 2 peek-loc
+ D 1 peek-loc
+ D 0 peek-loc
+ -4 inc-d
+ ] dip
+ ^^gather-vector-4
+ ds-push
+ ] emit-vector-op ;
+
+: emit-alien-vector ( node -- )
+ dup [
+ '[
+ ds-drop prepare-alien-getter
+ _ ^^alien-vector ds-push
+ ]
+ [ inline-alien-getter? ] inline-alien
+ ] with emit-vector-op ;
+
+: emit-set-alien-vector ( node -- )
+ dup [
+ '[
+ ds-drop prepare-alien-setter ds-pop
+ _ ##set-alien-vector
+ ]
+ [ byte-array inline-alien-setter? ]
+ inline-alien
+ ] with emit-vector-op ;
: (emit-set-slot) ( infos -- obj-reg )
[ 3inputs ^^offset>slot ] [ second value-tag ] bi*
- pick [ ^^set-slot ] dip ;
+ pick [ next-vreg ##set-slot ] dip ;
: (emit-set-slot-imm) ( infos -- obj-reg )
ds-drop
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs heaps kernel namespaces sequences fry math
-math.order combinators arrays sorting compiler.utilities
+math.order combinators arrays sorting compiler.utilities locals
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.splitting
[ drop assign-blocked-register ]
} cond ;
-: handle-interval ( live-interval -- )
- [
- start>>
+: handle-sync-point ( n -- )
+ [ active-intervals get values ] dip
+ [ '[ [ _ spill ] each ] each ]
+ [ drop [ delete-all ] each ]
+ 2bi ;
+
+:: handle-progress ( n sync? -- )
+ n {
[ progress set ]
[ deactivate-intervals ]
- [ activate-intervals ] tri
- ] [ assign-register ] bi ;
+ [ sync? [ handle-sync-point ] [ drop ] if ]
+ [ activate-intervals ]
+ } cleave ;
+
+GENERIC: handle ( obj -- )
+
+M: live-interval handle ( live-interval -- )
+ [ start>> f handle-progress ] [ assign-register ] bi ;
+
+M: sync-point handle ( sync-point -- )
+ n>> t handle-progress ;
+
+: smallest-heap ( heap1 heap2 -- heap )
+ ! If heap1 and heap2 have the same key, favors heap1.
+ [ [ heap-peek nip ] bi@ <= ] most ;
: (allocate-registers) ( -- )
- unhandled-intervals get [ handle-interval ] slurp-heap ;
+ {
+ { [ unhandled-intervals get heap-empty? ] [ unhandled-sync-points get ] }
+ { [ unhandled-sync-points get heap-empty? ] [ unhandled-intervals get ] }
+ ! If a live interval begins at the same location as a sync point,
+ ! process the sync point before the live interval. This ensures that the
+ ! return value of C function calls doesn't get spilled and reloaded
+ ! unnecessarily.
+ [ unhandled-sync-points get unhandled-intervals get smallest-heap ]
+ } cond dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
: finish-allocation ( -- )
active-intervals inactive-intervals
[ get values [ handled-intervals get push-all ] each ] bi@ ;
-: allocate-registers ( live-intervals machine-registers -- live-intervals )
+: allocate-registers ( live-intervals sync-point machine-registers -- live-intervals )
init-allocator
init-unhandled
(allocate-registers)
2bi ;
: assign-spill ( live-interval -- )
- dup vreg>> assign-spill-slot >>spill-to drop ;
+ dup vreg>> vreg-spill-slot >>spill-to drop ;
: spill-before ( before -- before/f )
! If the interval does not have any usages before the spill location,
] if ;
: assign-reload ( live-interval -- )
- dup vreg>> assign-spill-slot >>reload-from drop ;
+ dup vreg>> vreg-spill-slot >>reload-from drop ;
: spill-after ( after -- after/f )
! If the interval has no more usages after the spill location,
rep-size cfg get
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ;
+! Minheap of sync points which still need to be processed
+SYMBOL: unhandled-sync-points
+
! Mapping from vregs to spill slots
SYMBOL: spill-slots
-: assign-spill-slot ( vreg -- n )
+: vreg-spill-slot ( vreg -- n )
spill-slots get [ rep-of next-spill-slot ] cache ;
: init-allocator ( registers -- )
registers set
<min-heap> unhandled-intervals set
+ <min-heap> unhandled-sync-points set
[ V{ } clone ] reg-class-assoc active-intervals set
[ V{ } clone ] reg-class-assoc inactive-intervals set
V{ } clone handled-intervals set
H{ } clone spill-slots set
-1 progress set ;
-: init-unhandled ( live-intervals -- )
- [ [ start>> ] keep ] { } map>assoc
- unhandled-intervals get heap-push-all ;
+: init-unhandled ( live-intervals sync-points -- )
+ [ [ [ start>> ] keep ] { } map>assoc unhandled-intervals get heap-push-all ]
+ [ [ [ n>> ] keep ] { } map>assoc unhandled-sync-points get heap-push-all ]
+ bi* ;
! A utility used by register-status and spill-status words
: free-positions ( new -- assoc )
: remove-pending ( live-interval -- )
vreg>> pending-interval-assoc get delete-at ;
+: (vreg>reg) ( vreg pending -- reg )
+ ! If a live vreg is not in the pending set, then it must
+ ! have been spilled.
+ ?at [ spill-slots get at <spill-slot> ] unless ;
+
+: vreg>reg ( vreg -- reg )
+ pending-interval-assoc get (vreg>reg) ;
+
+: vregs>regs ( vregs -- assoc )
+ dup assoc-empty? [
+ pending-interval-assoc get
+ '[ _ (vreg>reg) ] assoc-map
+ ] unless ;
+
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
GENERIC: assign-registers-in-insn ( insn -- )
-: vreg>reg ( vreg -- reg ) pending-interval-assoc get at ;
-
RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
M: vreg-insn assign-registers-in-insn
[
[
2dup spill-on-gc?
- [ swap [ assign-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
+ [ swap [ rep-of ] [ vreg-spill-slot ] bi 3array , ] [ 2drop ] if
] assoc-each
] { } make ;
M: insn assign-registers-in-insn drop ;
-: compute-live-values ( vregs -- assoc )
- ! If a live vreg is not in active or inactive, then it must have been
- ! spilled.
- dup assoc-empty? [
- pending-interval-assoc get
- '[ _ ?at [ ] [ spill-slots get at <spill-slot> ] if ] assoc-map
- ] unless ;
-
: begin-block ( bb -- )
dup basic-block set
dup block-from activate-new-intervals
- [ live-in compute-live-values ] keep
- register-live-ins get set-at ;
+ [ live-in vregs>regs ] keep register-live-ins get set-at ;
: end-block ( bb -- )
- [ live-out compute-live-values ] keep
- register-live-outs get set-at ;
+ [ live-out vregs>regs ] keep register-live-outs get set-at ;
ERROR: bad-vreg vreg ;
[
[ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc
live-intervals set
+ f
] dip
allocate-registers drop ;
H{ } spill-slots set
H{
- { 1 single-float-rep }
- { 2 single-float-rep }
- { 3 single-float-rep }
+ { 1 float-rep }
+ { 2 float-rep }
+ { 3 float-rep }
} representations set
[
T{ ##copy
{ dst 689481 }
{ src 689475 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689482 }
{ src 689474 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689483 }
{ src 689473 }
+ { rep int-rep }
}
T{ ##branch }
} 2 test-bb
T{ ##copy
{ dst 689481 }
{ src 689473 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689482 }
{ src 689475 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689483 }
{ src 689474 }
+ { rep int-rep }
}
T{ ##branch }
} 3 test-bb
T{ ##copy
{ dst 689608 }
{ src 689600 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689610 }
{ src 689601 }
+ { rep int-rep }
}
T{ ##branch }
} 2 test-bb
T{ ##copy
{ dst 689607 }
{ src 689600 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689608 }
{ src 689601 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689610 }
{ src 689609 }
+ { rep int-rep }
}
T{ ##branch }
} 3 test-bb
T{ ##copy
{ dst 2 }
{ src 1 }
+ { rep int-rep }
}
T{ ##branch }
} 2 test-bb
T{ ##copy
{ dst 2 }
{ src 3 }
+ { rep int-rep }
}
T{ ##branch }
} 3 test-bb
{ slot 1 }
{ tag 2 }
}
- T{ ##copy { dst 79 } { src 69 } }
+ T{ ##copy { dst 79 } { src 69 } { rep int-rep } }
T{ ##slot-imm
{ dst 85 }
{ obj 62 }
T{ ##peek { dst 114 } { loc D 1 } }
T{ ##peek { dst 116 } { loc D 4 } }
T{ ##peek { dst 119 } { loc R 0 } }
- T{ ##copy { dst 109 } { src 108 } }
- T{ ##copy { dst 111 } { src 110 } }
- T{ ##copy { dst 113 } { src 112 } }
- T{ ##copy { dst 115 } { src 114 } }
- T{ ##copy { dst 117 } { src 116 } }
- T{ ##copy { dst 120 } { src 119 } }
+ T{ ##copy { dst 109 } { src 108 } { rep int-rep } }
+ T{ ##copy { dst 111 } { src 110 } { rep int-rep } }
+ T{ ##copy { dst 113 } { src 112 } { rep int-rep } }
+ T{ ##copy { dst 115 } { src 114 } { rep int-rep } }
+ T{ ##copy { dst 117 } { src 116 } { rep int-rep } }
+ T{ ##copy { dst 120 } { src 119 } { rep int-rep } }
T{ ##branch }
} 3 test-bb
V{
- T{ ##copy { dst 109 } { src 62 } }
- T{ ##copy { dst 111 } { src 61 } }
- T{ ##copy { dst 113 } { src 62 } }
- T{ ##copy { dst 115 } { src 79 } }
- T{ ##copy { dst 117 } { src 64 } }
- T{ ##copy { dst 120 } { src 69 } }
+ T{ ##copy { dst 109 } { src 62 } { rep int-rep } }
+ T{ ##copy { dst 111 } { src 61 } { rep int-rep } }
+ T{ ##copy { dst 113 } { src 62 } { rep int-rep } }
+ T{ ##copy { dst 115 } { src 79 } { rep int-rep } }
+ T{ ##copy { dst 117 } { src 64 } { rep int-rep } }
+ T{ ##copy { dst 120 } { src 69 } { rep int-rep } }
T{ ##branch }
} 4 test-bb
T{ ##peek { dst 162 } { loc D 1 } }
T{ ##peek { dst 164 } { loc D 4 } }
T{ ##peek { dst 167 } { loc R 0 } }
- T{ ##copy { dst 157 } { src 156 } }
- T{ ##copy { dst 159 } { src 158 } }
- T{ ##copy { dst 161 } { src 160 } }
- T{ ##copy { dst 163 } { src 162 } }
- T{ ##copy { dst 165 } { src 164 } }
- T{ ##copy { dst 168 } { src 167 } }
+ T{ ##copy { dst 157 } { src 156 } { rep int-rep } }
+ T{ ##copy { dst 159 } { src 158 } { rep int-rep } }
+ T{ ##copy { dst 161 } { src 160 } { rep int-rep } }
+ T{ ##copy { dst 163 } { src 162 } { rep int-rep } }
+ T{ ##copy { dst 165 } { src 164 } { rep int-rep } }
+ T{ ##copy { dst 168 } { src 167 } { rep int-rep } }
T{ ##branch }
} 4 test-bb
covers?
] if ;
-ERROR: dead-value-error vreg ;
+: add-new-range ( from to live-interval -- )
+ [ <live-range> ] dip ranges>> push ;
: shorten-range ( n live-interval -- )
dup ranges>> empty?
- [ vreg>> dead-value-error ] [ ranges>> last (>>from) ] if ;
+ [ dupd add-new-range ] [ ranges>> last (>>from) ] if ;
: extend-range ( from to live-range -- )
ranges>> last
[ min ] change-from
drop ;
-: add-new-range ( from to live-interval -- )
- [ <live-range> ] dip ranges>> push ;
-
: extend-range? ( to live-interval -- ? )
ranges>> [ drop f ] [ last from>> >= ] if-empty ;
2dup extend-range?
[ extend-range ] [ add-new-range ] if ;
-: add-use ( n live-interval -- )
- uses>> push ;
+GENERIC: operands-in-registers? ( insn -- ? )
+
+M: vreg-insn operands-in-registers? drop t ;
+
+M: partial-sync-insn operands-in-registers? drop f ;
+
+: add-def ( insn live-interval -- )
+ [ insn#>> ] [ uses>> ] bi* push ;
+
+: add-use ( insn live-interval -- )
+ ! Every use is a potential def, no SSA here baby!
+ over operands-in-registers? [ add-def ] [ 2drop ] if ;
: <live-interval> ( vreg -- live-interval )
\ live-interval new
M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ;
-M: live-interval clone
- call-next-method [ clone ] change-uses ;
-
! Mapping from vreg to live-interval
SYMBOL: live-intervals
-: live-interval ( vreg live-intervals -- live-interval )
- [ <live-interval> ] cache ;
+: live-interval ( vreg -- live-interval )
+ live-intervals get [ <live-interval> ] cache ;
GENERIC: compute-live-intervals* ( insn -- )
M: insn compute-live-intervals* drop ;
-: handle-output ( n vreg live-intervals -- )
+: handle-output ( insn vreg -- )
live-interval
- [ add-use ] [ shorten-range ] 2bi ;
+ [ [ insn#>> ] dip shorten-range ] [ add-def ] 2bi ;
-: handle-input ( n vreg live-intervals -- )
+: handle-input ( insn vreg -- )
live-interval
- [ [ basic-block get block-from ] 2dip add-range ] [ add-use ] 2bi ;
+ [ [ [ basic-block get block-from ] dip insn#>> ] dip add-range ] [ add-use ] 2bi ;
-: handle-temp ( n vreg live-intervals -- )
+: handle-temp ( insn vreg -- )
live-interval
- [ dupd add-range ] [ add-use ] 2bi ;
+ [ [ insn#>> dup ] dip add-range ] [ add-use ] 2bi ;
M: vreg-insn compute-live-intervals*
- dup insn#>>
- live-intervals get
- [ [ defs-vreg ] 2dip '[ [ _ ] dip _ handle-output ] when* ]
- [ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
- [ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
- 3tri ;
+ [ dup defs-vreg [ handle-output ] with when* ]
+ [ dup uses-vregs [ handle-input ] with each ]
+ [ dup temp-vregs [ handle-temp ] with each ]
+ tri ;
: handle-live-out ( bb -- )
- live-out keys
- basic-block get [ block-from ] [ block-to ] bi
- live-intervals get '[
- [ _ _ ] dip _ live-interval add-range
- ] each ;
+ [ block-from ] [ block-to ] [ live-out keys ] tri
+ [ live-interval add-range ] with with each ;
+
+! A location where all registers have to be spilled
+TUPLE: sync-point n ;
+
+C: <sync-point> sync-point
+
+! Sequence of sync points
+SYMBOL: sync-points
+
+GENERIC: compute-sync-points* ( insn -- )
+
+M: partial-sync-insn compute-sync-points*
+ insn#>> <sync-point> sync-points get push ;
+
+M: insn compute-sync-points* drop ;
: compute-live-intervals-step ( bb -- )
[ basic-block set ]
[ handle-live-out ]
- [ instructions>> <reversed> [ compute-live-intervals* ] each ] tri ;
-
+ [
+ instructions>> <reversed> [
+ [ compute-live-intervals* ]
+ [ compute-sync-points* ]
+ bi
+ ] each
+ ] tri ;
+
+: init-live-intervals ( -- )
+ H{ } clone live-intervals set
+ V{ } clone sync-points set ;
+
: compute-start/end ( live-interval -- )
dup ranges>> [ first from>> ] [ last to>> ] bi
[ >>start ] [ >>end ] bi* drop ;
: check-start ( live-interval -- )
dup start>> -1 = [ bad-live-interval ] [ drop ] if ;
-: finish-live-intervals ( live-intervals -- )
+: finish-live-intervals ( live-intervals -- seq )
! Since live intervals are computed in a backward order, we have
! to reverse some sequences, and compute the start and end.
- [
+ values dup [
{
[ ranges>> reverse-here ]
[ uses>> reverse-here ]
} cleave
] each ;
-: compute-live-intervals ( cfg -- live-intervals )
- H{ } clone [
- live-intervals set
- linearization-order <reversed>
- [ compute-live-intervals-step ] each
- ] keep values dup finish-live-intervals ;
+: compute-live-intervals ( cfg -- live-intervals sync-points )
+ init-live-intervals
+ linearization-order <reversed> [ compute-live-intervals-step ] each
+ live-intervals get finish-live-intervals
+ sync-points get ;
: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
M: ##compare-imm-branch linearize-insn
binary-conditional _compare-imm-branch emit-branch ;
-M: ##compare-float-branch linearize-insn
- binary-conditional _compare-float-branch emit-branch ;
+M: ##compare-float-ordered-branch linearize-insn
+ binary-conditional _compare-float-ordered-branch emit-branch ;
+
+M: ##compare-float-unordered-branch linearize-insn
+ binary-conditional _compare-float-unordered-branch emit-branch ;
: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
[ dup successors block-number ]
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces accessors compiler.cfg
compiler.cfg.linearization compiler.cfg.gc-checks
-compiler.cfg.linear-scan compiler.cfg.build-stack-frame ;
+compiler.cfg.save-contexts compiler.cfg.linear-scan
+compiler.cfg.build-stack-frame ;
IN: compiler.cfg.mr
: build-mr ( cfg -- mr )
insert-gc-checks
+ insert-save-contexts
linear-scan
flatten-cfg
build-stack-frame ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: functors assocs kernel accessors compiler.cfg.instructions
-lexer parser ;
+USING: accessors arrays assocs fry functors generic.parser
+kernel lexer namespaces parser sequences slots words sets
+compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.instructions.syntax ;
IN: compiler.cfg.renaming.functor
+: slot-change-quot ( slots quot -- quot' )
+ '[ [ _ ] dip changer-word [ ] 2sequence ] map [ ] join
+ [ drop ] append ;
+
FUNCTOR: define-renaming ( NAME DEF-QUOT USE-QUOT TEMP-QUOT -- )
rename-insn-defs DEFINES ${NAME}-insn-defs
GENERIC: rename-insn-defs ( insn -- )
-M: ##flushable rename-insn-defs
- DEF-QUOT change-dst
- drop ;
-
-M: ##fixnum-overflow rename-insn-defs
- DEF-QUOT change-dst
- drop ;
-
-M: _fixnum-overflow rename-insn-defs
- DEF-QUOT change-dst
- drop ;
-
-M: insn rename-insn-defs drop ;
+insn-classes get [
+ [ \ rename-insn-defs create-method-in ]
+ [ insn-def-slot dup [ name>> 1array ] when DEF-QUOT slot-change-quot ] bi
+ define
+] each
GENERIC: rename-insn-uses ( insn -- )
-M: ##effect rename-insn-uses
- USE-QUOT change-src
- drop ;
-
-M: ##unary rename-insn-uses
- USE-QUOT change-src
- drop ;
-
-M: ##binary rename-insn-uses
- USE-QUOT change-src1
- USE-QUOT change-src2
- drop ;
-
-M: ##binary-imm rename-insn-uses
- USE-QUOT change-src1
- drop ;
-
-M: ##slot rename-insn-uses
- USE-QUOT change-obj
- USE-QUOT change-slot
- drop ;
-
-M: ##slot-imm rename-insn-uses
- USE-QUOT change-obj
- drop ;
-
-M: ##set-slot rename-insn-uses
- dup call-next-method
- USE-QUOT change-obj
- USE-QUOT change-slot
- drop ;
-
-M: ##string-nth rename-insn-uses
- USE-QUOT change-obj
- USE-QUOT change-index
- drop ;
-
-M: ##set-string-nth-fast rename-insn-uses
- dup call-next-method
- USE-QUOT change-obj
- USE-QUOT change-index
- drop ;
-
-M: ##set-slot-imm rename-insn-uses
- dup call-next-method
- USE-QUOT change-obj
- drop ;
-
-M: ##alien-getter rename-insn-uses
- dup call-next-method
- USE-QUOT change-src
- drop ;
-
-M: ##alien-setter rename-insn-uses
- dup call-next-method
- USE-QUOT change-value
- drop ;
-
-M: ##conditional-branch rename-insn-uses
- USE-QUOT change-src1
- USE-QUOT change-src2
- drop ;
-
-M: ##compare-imm-branch rename-insn-uses
- USE-QUOT change-src1
- drop ;
-
-M: ##dispatch rename-insn-uses
- USE-QUOT change-src
- drop ;
-
-M: ##fixnum-overflow rename-insn-uses
- USE-QUOT change-src1
- USE-QUOT change-src2
- drop ;
+insn-classes get { ##phi } diff [
+ [ \ rename-insn-uses create-method-in ]
+ [ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
+ define
+] each
M: ##phi rename-insn-uses
- [ USE-QUOT assoc-map ] change-inputs
- drop ;
-
-M: insn rename-insn-uses drop ;
+ [ USE-QUOT assoc-map ] change-inputs drop ;
GENERIC: rename-insn-temps ( insn -- )
-M: ##write-barrier rename-insn-temps
- TEMP-QUOT change-card#
- TEMP-QUOT change-table
- drop ;
-
-M: ##unary/temp rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##allot rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##dispatch rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##slot rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##set-slot rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##string-nth rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##set-string-nth-fast rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##compare rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##compare-imm rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##compare-float rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##gc rename-insn-temps
- TEMP-QUOT change-temp1
- TEMP-QUOT change-temp2
- drop ;
-
-M: _dispatch rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: insn rename-insn-temps drop ;
+insn-classes get [
+ [ \ rename-insn-temps create-method-in ]
+ [ insn-temp-slots [ name>> ] map TEMP-QUOT slot-change-quot ] bi
+ define
+] each
;FUNCTOR
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences arrays fry namespaces
-cpu.architecture compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
-compiler.cfg.instructions compiler.cfg.def-use ;
+USING: kernel accessors sequences arrays fry namespaces generic
+words sets combinators generalizations cpu.architecture compiler.units
+compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
+compiler.cfg.instructions compiler.cfg.instructions.syntax
+compiler.cfg.def-use ;
IN: compiler.cfg.representations.preferred
GENERIC: defs-vreg-rep ( insn -- rep/f )
GENERIC: temp-vreg-reps ( insn -- reps )
GENERIC: uses-vreg-reps ( insn -- reps )
-M: ##flushable defs-vreg-rep drop int-rep ;
-M: ##copy defs-vreg-rep rep>> ;
-M: output-float-insn defs-vreg-rep drop double-float-rep ;
-M: ##fixnum-overflow defs-vreg-rep drop int-rep ;
-M: _fixnum-overflow defs-vreg-rep drop int-rep ;
-M: ##phi defs-vreg-rep drop "##phi must be special-cased" throw ;
-M: insn defs-vreg-rep drop f ;
+<PRIVATE
-M: ##write-barrier temp-vreg-reps drop { int-rep int-rep } ;
-M: ##unary/temp temp-vreg-reps drop { int-rep } ;
-M: ##allot temp-vreg-reps drop { int-rep } ;
-M: ##dispatch temp-vreg-reps drop { int-rep } ;
-M: ##slot temp-vreg-reps drop { int-rep } ;
-M: ##set-slot temp-vreg-reps drop { int-rep } ;
-M: ##string-nth temp-vreg-reps drop { int-rep } ;
-M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
-M: ##compare temp-vreg-reps drop { int-rep } ;
-M: ##compare-imm temp-vreg-reps drop { int-rep } ;
-M: ##compare-float temp-vreg-reps drop { int-rep } ;
-M: ##gc temp-vreg-reps drop { int-rep int-rep } ;
-M: _dispatch temp-vreg-reps drop { int-rep } ;
-M: insn temp-vreg-reps drop f ;
+: rep-getter-quot ( rep -- quot )
+ {
+ { f [ [ rep>> ] ] }
+ { scalar-rep [ [ rep>> scalar-rep-of ] ] }
+ [ [ drop ] swap suffix ]
+ } case ;
-M: ##copy uses-vreg-reps rep>> 1array ;
-M: ##unary uses-vreg-reps drop { int-rep } ;
-M: ##unary-float uses-vreg-reps drop { double-float-rep } ;
-M: ##binary uses-vreg-reps drop { int-rep int-rep } ;
-M: ##binary-imm uses-vreg-reps drop { int-rep } ;
-M: ##binary-float uses-vreg-reps drop { double-float-rep double-float-rep } ;
-M: ##effect uses-vreg-reps drop { int-rep } ;
-M: ##slot uses-vreg-reps drop { int-rep int-rep } ;
-M: ##slot-imm uses-vreg-reps drop { int-rep } ;
-M: ##set-slot uses-vreg-reps drop { int-rep int-rep int-rep } ;
-M: ##set-slot-imm uses-vreg-reps drop { int-rep int-rep } ;
-M: ##string-nth uses-vreg-reps drop { int-rep int-rep } ;
-M: ##set-string-nth-fast uses-vreg-reps drop { int-rep int-rep int-rep } ;
-M: ##compare-branch uses-vreg-reps drop { int-rep int-rep } ;
-M: ##compare-imm-branch uses-vreg-reps drop { int-rep } ;
-M: ##compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
-M: ##dispatch uses-vreg-reps drop { int-rep } ;
-M: ##alien-getter uses-vreg-reps drop { int-rep } ;
-M: ##alien-setter uses-vreg-reps drop { int-rep int-rep } ;
-M: ##set-alien-float uses-vreg-reps drop { int-rep double-float-rep } ;
-M: ##set-alien-double uses-vreg-reps drop { int-rep double-float-rep } ;
-M: ##fixnum-overflow uses-vreg-reps drop { int-rep int-rep } ;
-M: _compare-imm-branch uses-vreg-reps drop { int-rep } ;
-M: _compare-branch uses-vreg-reps drop { int-rep int-rep } ;
-M: _compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
-M: _dispatch uses-vreg-reps drop { int-rep } ;
-M: ##phi uses-vreg-reps drop "##phi must be special-cased" throw ;
-M: insn uses-vreg-reps drop f ;
+: define-defs-vreg-rep-method ( insn -- )
+ [ \ defs-vreg-rep create-method ]
+ [ insn-def-slot [ rep>> rep-getter-quot ] [ [ drop f ] ] if* ]
+ bi define ;
+
+: reps-getter-quot ( reps -- quot )
+ dup [ rep>> { f scalar-rep } memq? not ] all? [
+ [ rep>> ] map [ drop ] swap suffix
+ ] [
+ [ rep>> rep-getter-quot ] map dup length {
+ { 0 [ drop [ drop f ] ] }
+ { 1 [ first [ 1array ] compose ] }
+ { 2 [ first2 '[ _ _ bi 2array ] ] }
+ [ '[ _ cleave _ narray ] ]
+ } case
+ ] if ;
+
+: define-uses-vreg-reps-method ( insn -- )
+ [ \ uses-vreg-reps create-method ]
+ [ insn-use-slots reps-getter-quot ]
+ bi define ;
+
+: define-temp-vreg-reps-method ( insn -- )
+ [ \ temp-vreg-reps create-method ]
+ [ insn-temp-slots reps-getter-quot ]
+ bi define ;
+
+PRIVATE>
+
+[
+ insn-classes get
+ [ [ define-defs-vreg-rep-method ] each ]
+ [ { ##phi } diff [ define-uses-vreg-reps-method ] each ]
+ [ [ define-temp-vreg-reps-method ] each ]
+ tri
+] with-compilation-unit
: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
compiler.cfg.representations.preferred ;
IN: compiler.cfg.representations
-[ { double-float-rep double-float-rep } ] [
+[ { double-rep double-rep } ] [
T{ ##add-float
{ dst 5 }
{ src1 3 }
} uses-vreg-reps
] unit-test
-[ double-float-rep ] [
+[ double-rep ] [
T{ ##alien-double
{ dst 5 }
{ src 3 }
cpu.architecture compiler.utilities
compiler.cfg
compiler.cfg.rpo
+compiler.cfg.hats
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.def-use
! Virtual register representation selection.
+ERROR: bad-conversion dst src dst-rep src-rep ;
+
+GENERIC: emit-box ( dst src rep -- )
+GENERIC: emit-unbox ( dst src rep -- )
+
+M: float-rep emit-box
+ drop
+ [ double-rep next-vreg-rep dup ] dip ##single>double-float
+ int-rep next-vreg-rep ##box-float ;
+
+M: float-rep emit-unbox
+ drop
+ [ double-rep next-vreg-rep dup ] dip ##unbox-float
+ ##double>single-float ;
+
+M: double-rep emit-box
+ drop
+ int-rep next-vreg-rep ##box-float ;
+
+M: double-rep emit-unbox
+ drop ##unbox-float ;
+
+M: vector-rep emit-box
+ int-rep next-vreg-rep ##box-vector ;
+
+M: vector-rep emit-unbox
+ ##unbox-vector ;
+
: emit-conversion ( dst src dst-rep src-rep -- )
- 2array {
- { { int-rep int-rep } [ int-rep ##copy ] }
- { { double-float-rep double-float-rep } [ double-float-rep ##copy ] }
- { { double-float-rep int-rep } [ ##unbox-float ] }
- { { int-rep double-float-rep } [ int-rep next-vreg-rep ##box-float ] }
- } case ;
+ {
+ { [ 2dup eq? ] [ drop ##copy ] }
+ { [ dup int-rep eq? ] [ drop emit-unbox ] }
+ { [ over int-rep eq? ] [ nip emit-box ] }
+ [
+ 2dup 2array {
+ { { double-rep float-rep } [ 2drop ##single>double-float ] }
+ { { float-rep double-rep } [ 2drop ##double>single-float ] }
+ ! Punning SIMD vector types? Naughty naughty! But
+ ! it is allowed... otherwise bail out.
+ [
+ drop 2dup [ reg-class-of ] bi@ eq?
+ [ drop ##copy ] [ bad-conversion ] if
+ ]
+ } case
+ ]
+ } cond ;
<PRIVATE
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: accessors compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.save-contexts kernel namespaces tools.test ;
+IN: compiler.cfg.save-contexts.tests
+
+0 vreg-counter set-global
+H{ } clone representations set
+
+V{
+ T{ ##unary-float-function f 2 3 "sqrt" }
+ T{ ##branch }
+} 0 test-bb
+
+0 get insert-save-context
+
+[
+ V{
+ T{ ##save-context f 1 2 f }
+ T{ ##unary-float-function f 2 3 "sqrt" }
+ T{ ##branch }
+ }
+] [
+ 0 get instructions>>
+] unit-test
+
+V{
+ T{ ##add f 1 2 3 }
+ T{ ##branch }
+} 0 test-bb
+
+0 get insert-save-context
+
+[
+ V{
+ T{ ##add f 1 2 3 }
+ T{ ##branch }
+ }
+] [
+ 0 get instructions>>
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.rpo cpu.architecture kernel sequences vectors ;
+IN: compiler.cfg.save-contexts
+
+! Insert context saves.
+
+: needs-save-context? ( insns -- ? )
+ [
+ {
+ [ ##unary-float-function? ]
+ [ ##binary-float-function? ]
+ [ ##alien-invoke? ]
+ [ ##alien-indirect? ]
+ } 1||
+ ] any? ;
+
+: needs-callback-context? ( insns -- ? )
+ [
+ {
+ [ ##alien-invoke? ]
+ [ ##alien-indirect? ]
+ } 1||
+ ] any? ;
+
+: insert-save-context ( bb -- )
+ dup instructions>> dup needs-save-context? [
+ int-rep next-vreg-rep
+ int-rep next-vreg-rep
+ pick needs-callback-context?
+ \ ##save-context new-insn prefix
+ >>instructions drop
+ ] [ 2drop ] if ;
+
+: insert-save-contexts ( cfg -- cfg' )
+ dup [ insert-save-context ] each-basic-block ;
[
V{
- T{ ##copy f 1 2 double-float-rep }
+ T{ ##copy f 1 2 double-rep }
T{ ##sub-float f 1 1 3 }
}
] [
H{
- { 1 double-float-rep }
- { 2 double-float-rep }
- { 3 double-float-rep }
+ { 1 double-rep }
+ { 2 double-rep }
+ { 3 double-rep }
} clone representations set
{
T{ ##sub-float f 1 2 3 }
[
V{
- T{ ##copy f 1 2 double-float-rep }
+ T{ ##copy f 1 2 double-rep }
T{ ##mul-float f 1 1 1 }
}
] [
H{
- { 1 double-float-rep }
- { 2 double-float-rep }
+ { 1 double-rep }
+ { 2 double-rep }
} clone representations set
{
T{ ##mul-float f 1 2 2 }
##shr-imm
##sar
##sar-imm
- ##fixnum-overflow
+ ##min
+ ##max
+ ##fixnum-add
+ ##fixnum-sub
+ ##fixnum-mul
##add-float
##sub-float
##mul-float
- ##div-float ;
+ ##div-float
+ ##min-float
+ ##max-float
+ ##add-vector
+ ##sub-vector
+ ##mul-vector
+ ##div-vector
+ ##min-vector
+ ##max-vector ;
GENERIC: convert-two-operand* ( insn -- )
: delete-conditional? ( bb -- ? )
{
- [ instructions>> last class { ##compare-branch ##compare-imm-branch ##compare-float-branch } memq? ]
+ [
+ instructions>> last class {
+ ##compare-branch
+ ##compare-imm-branch
+ ##compare-float-ordered-branch
+ ##compare-float-unordered-branch
+ } memq?
+ ]
[ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
} 1&& ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators combinators.short-circuit
cpu.architecture kernel layouts locals make math namespaces sequences
-sets vectors fry compiler.cfg compiler.cfg.instructions
-compiler.cfg.rpo arrays ;
+sets vectors fry arrays compiler.cfg compiler.cfg.instructions
+compiler.cfg.rpo compiler.utilities ;
IN: compiler.cfg.utilities
PREDICATE: kill-block < basic-block
instructions>> {
- [ length 2 = ]
- [ first kill-vreg-insn? ]
+ [ length 2 >= ]
+ [ penultimate kill-vreg-insn? ]
} 1&& ;
: back-edge? ( from to -- ? )
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes kernel math namespaces combinators
-combinators.short-circuit compiler.cfg.instructions
+USING: accessors classes classes.algebra classes.parser
+classes.tuple combinators combinators.short-circuit fry
+generic.parser kernel math namespaces quotations sequences slots
+splitting words compiler.cfg.instructions
+compiler.cfg.instructions.syntax
compiler.cfg.value-numbering.graph ;
IN: compiler.cfg.value-numbering.expressions
-! Referentially-transparent expressions
-TUPLE: unary-expr < expr in ;
-TUPLE: binary-expr < expr in1 in2 ;
-TUPLE: commutative-expr < binary-expr ;
-TUPLE: compare-expr < binary-expr cc ;
TUPLE: constant-expr < expr value ;
-TUPLE: reference-expr < expr value ;
-: <constant> ( constant -- expr )
- f swap constant-expr boa ; inline
+C: <constant> constant-expr
M: constant-expr equal?
over constant-expr? [
} 2&&
] [ 2drop f ] if ;
-: <reference> ( constant -- expr )
- f swap reference-expr boa ; inline
+TUPLE: reference-expr < expr value ;
+
+C: <reference> reference-expr
M: reference-expr equal?
over reference-expr? [
GENERIC: >expr ( insn -- expr )
+M: insn >expr drop next-input-expr ;
+
M: ##load-immediate >expr val>> <constant> ;
M: ##load-reference >expr obj>> <reference> ;
-M: ##unary >expr
- [ class ] [ src>> vreg>vn ] bi unary-expr boa ;
-
-M: ##binary >expr
- [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
- binary-expr boa ;
-
-M: ##binary-imm >expr
- [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
- binary-expr boa ;
-
-M: ##commutative >expr
- [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
- commutative-expr boa ;
+<<
-M: ##commutative-imm >expr
- [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
- commutative-expr boa ;
+: input-values ( slot-specs -- slot-specs' )
+ [ type>> { use literal constant } memq? ] filter ;
-: compare>expr ( insn -- expr )
- {
- [ class ]
- [ src1>> vreg>vn ]
- [ src2>> vreg>vn ]
- [ cc>> ]
- } cleave compare-expr boa ; inline
+: expr-class ( insn -- expr )
+ name>> "##" ?head drop "-expr" append create-class-in ;
-M: ##compare >expr compare>expr ;
+: define-expr-class ( insn expr slot-specs -- )
+ [ nip expr ] dip [ name>> ] map define-tuple-class ;
-: compare-imm>expr ( insn -- expr )
- {
- [ class ]
- [ src1>> vreg>vn ]
- [ src2>> constant>vn ]
- [ cc>> ]
- } cleave compare-expr boa ; inline
+: >expr-quot ( expr slot-specs -- quot )
+ [
+ [ name>> reader-word 1quotation ]
+ [
+ type>> {
+ { use [ [ vreg>vn ] ] }
+ { literal [ [ ] ] }
+ { constant [ [ constant>vn ] ] }
+ } case
+ ] bi append
+ ] map cleave>quot swap suffix \ boa suffix ;
-M: ##compare-imm >expr compare-imm>expr ;
+: define->expr-method ( insn expr slot-specs -- )
+ [ 2drop \ >expr create-method-in ] [ >expr-quot nip ] 3bi define ;
-M: ##compare-float >expr compare>expr ;
+: handle-pure-insn ( insn -- )
+ [ ] [ expr-class ] [ "insn-slots" word-prop input-values ] tri
+ [ define-expr-class ] [ define->expr-method ] 3bi ;
-M: ##flushable >expr drop next-input-expr ;
+insn-classes get [ pure-insn class<= ] filter [ handle-pure-insn ] each
-: init-expressions ( -- )
- 0 input-expr-counter set ;
+>>
! biassoc mapping expressions to value numbers
SYMBOL: exprs>vns
-TUPLE: expr op ;
+TUPLE: expr ;
: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
SYMBOL: input-expr-counter
: next-input-expr ( -- expr )
- f input-expr-counter counter input-expr boa ;
+ input-expr-counter counter input-expr boa ;
SYMBOL: vregs>vns
: init-value-graph ( -- )
0 vn-counter set
+ 0 input-expr-counter set
<bihash> exprs>vns set
<bihash> vregs>vns set ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise math.order classes vectors
+math.bitwise math.order classes vectors locals make
compiler.cfg
compiler.cfg.registers
compiler.cfg.comparisons
} 1&&
] [ drop f ] if ; inline
+: general-compare-expr? ( insn -- ? )
+ {
+ [ compare-expr? ]
+ [ compare-imm-expr? ]
+ [ compare-float-unordered-expr? ]
+ [ compare-float-ordered-expr? ]
+ } 1|| ;
+
: rewrite-boolean-comparison? ( insn -- ? )
dup ##branch-t? [
- src1>> vreg>expr compare-expr?
+ src1>> vreg>expr general-compare-expr?
] [ drop f ] if ; inline
: >compare-expr< ( expr -- in1 in2 cc )
- [ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline
+ [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
: >compare-imm-expr< ( expr -- in1 in2 cc )
- [ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline
+ [ src1>> vn>vreg ] [ src2>> vn>constant ] [ cc>> ] tri ; inline
: rewrite-boolean-comparison ( expr -- insn )
- src1>> vreg>expr dup op>> {
- { \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] }
- { \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
- { \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] }
- } case ;
+ src1>> vreg>expr {
+ { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] }
+ { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
+ { [ dup compare-float-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] }
+ { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-branch new-insn ] }
+ } cond ;
: tag-fixnum-expr? ( expr -- ? )
- dup op>> \ ##shl-imm eq?
- [ in2>> vn>constant tag-bits get = ] [ drop f ] if ;
+ dup shl-imm-expr?
+ [ src2>> vn>constant tag-bits get = ] [ drop f ] if ;
: rewrite-tagged-comparison? ( insn -- ? )
#! Are we comparing two tagged fixnums? Then untag them.
tag-bits get neg shift ; inline
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
- [ src1>> vreg>expr in1>> vn>vreg ]
+ [ src1>> vreg>expr src1>> vn>vreg ]
[ src2>> tagged>constant ]
[ cc>> ]
tri ; inline
: rewrite-redundant-comparison? ( insn -- ? )
{
- [ src1>> vreg>expr compare-expr? ]
+ [ src1>> vreg>expr general-compare-expr? ]
[ src2>> \ f tag-number = ]
[ cc>> { cc= cc/= } memq? ]
} 1&& ; inline
: rewrite-redundant-comparison ( insn -- insn' )
- [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
- { \ ##compare [ >compare-expr< next-vreg \ ##compare new-insn ] }
- { \ ##compare-imm [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
- { \ ##compare-float [ >compare-expr< next-vreg \ ##compare-float new-insn ] }
- } case
+ [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
+ { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
+ { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
+ { [ dup compare-float-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] }
+ { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered new-insn ] }
+ } cond
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
ERROR: bad-comparison ;
[ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
\ ##load-immediate new-insn ; inline
-: reassociate? ( insn -- ? )
- [ src1>> vreg>expr op>> ] [ class ] bi = ; inline
-
: reassociate ( insn op -- insn )
[
{
[ dst>> ]
- [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ]
+ [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>constant ] bi ]
[ src2>> ]
[ ]
} cleave constant-fold*
M: ##add-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup reassociate? ] [ \ ##add-imm reassociate ] }
+ { [ dup src1>> vreg>expr add-imm-expr? ] [ \ ##add-imm reassociate ] }
[ drop f ]
} cond ;
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
- { [ dup reassociate? ] [ \ ##mul-imm reassociate ] }
+ { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] }
[ drop f ]
} cond ;
M: ##and-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup reassociate? ] [ \ ##and-imm reassociate ] }
+ { [ dup src1>> vreg>expr and-imm-expr? ] [ \ ##and-imm reassociate ] }
[ drop f ]
} cond ;
M: ##or-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup reassociate? ] [ \ ##or-imm reassociate ] }
+ { [ dup src1>> vreg>expr or-imm-expr? ] [ \ ##or-imm reassociate ] }
[ drop f ]
} cond ;
M: ##xor-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
+ { [ dup src1>> vreg>expr xor-imm-expr? ] [ \ ##xor-imm reassociate ] }
[ drop f ]
} cond ;
M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ;
M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
+
+! ##box-displaced-alien f 1 2 3 <class>
+! ##unbox-c-ptr 4 1 <class>
+! =>
+! ##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 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
+ dup src>> vreg>expr dup box-displaced-alien-expr?
+ [ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators classes math layouts
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions locals ;
+compiler.cfg.value-numbering.expressions ;
IN: compiler.cfg.value-numbering.simplify
! Return value of f means we didn't simplify.
GENERIC: simplify* ( expr -- vn/expr/f )
-: simplify-unbox-alien ( in -- vn/expr/f )
- dup op>> \ ##box-alien eq? [ in>> ] [ drop f ] if ; inline
+M: copy-expr simplify* src>> ;
-M: unary-expr simplify*
- #! Note the copy propagation: a copy always simplifies to
- #! its source VN.
- [ in>> vn>expr ] [ op>> ] bi {
- { \ ##copy [ ] }
- { \ ##unbox-alien [ simplify-unbox-alien ] }
- { \ ##unbox-any-c-ptr [ simplify-unbox-alien ] }
- [ 2drop f ]
- } case ;
+: simplify-unbox-alien ( expr -- vn/expr/f )
+ src>> vn>expr dup box-alien-expr? [ src>> ] [ drop f ] if ;
+
+M: unbox-alien-expr simplify* simplify-unbox-alien ;
+
+M: unbox-any-c-ptr-expr simplify* simplify-unbox-alien ;
-: expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
+: expr-zero? ( expr -- ? ) T{ constant-expr f 0 } = ; inline
-: expr-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline
+: expr-one? ( expr -- ? ) T{ constant-expr f 1 } = ; inline
: >binary-expr< ( expr -- in1 in2 )
- [ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
+ [ src1>> vn>expr ] [ src2>> vn>expr ] bi ; inline
: simplify-add ( expr -- vn/expr/f )
>binary-expr< {
[ 2drop f ]
} cond ; inline
+M: add-expr simplify* simplify-add ;
+M: add-imm-expr simplify* simplify-add ;
+
: simplify-sub ( expr -- vn/expr/f )
>binary-expr< {
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
+M: sub-expr simplify* simplify-sub ;
+M: sub-imm-expr simplify* simplify-sub ;
+
: simplify-mul ( expr -- vn/expr/f )
>binary-expr< {
{ [ over expr-one? ] [ drop ] }
[ 2drop f ]
} cond ; inline
+M: mul-expr simplify* simplify-mul ;
+M: mul-imm-expr simplify* simplify-mul ;
+
: simplify-and ( expr -- vn/expr/f )
>binary-expr< {
{ [ 2dup eq? ] [ drop ] }
[ 2drop f ]
} cond ; inline
+M: and-expr simplify* simplify-and ;
+M: and-imm-expr simplify* simplify-and ;
+
: simplify-or ( expr -- vn/expr/f )
>binary-expr< {
{ [ 2dup eq? ] [ drop ] }
[ 2drop f ]
} cond ; inline
+M: or-expr simplify* simplify-or ;
+M: or-imm-expr simplify* simplify-or ;
+
: simplify-xor ( expr -- vn/expr/f )
>binary-expr< {
{ [ over expr-zero? ] [ nip ] }
[ 2drop f ]
} cond ; inline
+M: xor-expr simplify* simplify-xor ;
+M: xor-imm-expr simplify* simplify-xor ;
+
: useless-shr? ( in1 in2 -- ? )
- over op>> \ ##shl-imm eq?
- [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
+ over shl-imm-expr?
+ [ [ src2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
: simplify-shr ( expr -- vn/expr/f )
>binary-expr< {
- { [ 2dup useless-shr? ] [ drop in1>> ] }
+ { [ 2dup useless-shr? ] [ drop src1>> ] }
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
+M: shr-expr simplify* simplify-shr ;
+M: shr-imm-expr simplify* simplify-shr ;
+
: simplify-shl ( expr -- vn/expr/f )
>binary-expr< {
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
-M: binary-expr simplify*
- dup op>> {
- { \ ##add [ simplify-add ] }
- { \ ##add-imm [ simplify-add ] }
- { \ ##sub [ simplify-sub ] }
- { \ ##sub-imm [ simplify-sub ] }
- { \ ##mul [ simplify-mul ] }
- { \ ##mul-imm [ simplify-mul ] }
- { \ ##and [ simplify-and ] }
- { \ ##and-imm [ simplify-and ] }
- { \ ##or [ simplify-or ] }
- { \ ##or-imm [ simplify-or ] }
- { \ ##xor [ simplify-xor ] }
- { \ ##xor-imm [ simplify-xor ] }
- { \ ##shr [ simplify-shr ] }
- { \ ##shr-imm [ simplify-shr ] }
- { \ ##sar [ simplify-shr ] }
- { \ ##sar-imm [ simplify-shr ] }
- { \ ##shl [ simplify-shl ] }
- { \ ##shl-imm [ simplify-shl ] }
+M: shl-expr simplify* simplify-shl ;
+M: shl-imm-expr simplify* simplify-shl ;
+
+M: box-displaced-alien-expr simplify*
+ [ base>> ] [ displacement>> ] bi {
+ { [ dup vn>expr expr-zero? ] [ drop ] }
[ 2drop f ]
- } case ;
+ } cond ;
M: expr simplify* drop f ;
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 )
dup {
[ ##compare? ]
[ ##compare-imm? ]
- [ ##compare-float? ]
+ [ ##compare-float-unordered? ]
+ [ ##compare-float-ordered? ]
} 1|| [ f >>temp ] when
] map ;
T{ ##load-reference f 1 + }
T{ ##peek f 2 D 0 }
T{ ##compare f 4 2 1 cc<= }
- T{ ##compare f 6 2 1 cc> }
+ T{ ##compare f 6 2 1 cc/<= }
T{ ##replace f 6 D 0 }
}
] [
T{ ##peek f 9 D -1 }
T{ ##unbox-float f 10 8 }
T{ ##unbox-float f 11 9 }
- T{ ##compare-float f 12 10 11 cc< }
- T{ ##compare-float f 14 10 11 cc>= }
+ T{ ##compare-float-unordered f 12 10 11 cc< }
+ T{ ##compare-float-unordered f 14 10 11 cc/< }
T{ ##replace f 14 D 0 }
}
] [
T{ ##peek f 9 D -1 }
T{ ##unbox-float f 10 8 }
T{ ##unbox-float f 11 9 }
- T{ ##compare-float f 12 10 11 cc< }
+ T{ ##compare-float-unordered f 12 10 11 cc< }
T{ ##compare-imm f 14 12 5 cc= }
T{ ##replace f 14 D 0 }
} value-numbering-step trim-temps
] unit-test
] when
+! Displaced alien optimizations
+3 vreg-counter set-global
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 16 }
+ T{ ##box-displaced-alien f 1 2 0 c-ptr }
+ T{ ##unbox-any-c-ptr f 4 0 }
+ T{ ##add-imm f 3 4 16 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 16 }
+ T{ ##box-displaced-alien f 1 2 0 c-ptr }
+ T{ ##unbox-any-c-ptr f 3 1 }
+ } value-numbering-step
+] unit-test
+
+4 vreg-counter set-global
+
+[
+ {
+ T{ ##box-alien f 0 1 }
+ T{ ##load-immediate f 2 16 }
+ T{ ##box-displaced-alien f 3 2 0 c-ptr }
+ T{ ##copy f 5 1 any-rep }
+ T{ ##add-imm f 4 5 16 }
+ }
+] [
+ {
+ T{ ##box-alien f 0 1 }
+ T{ ##load-immediate f 2 16 }
+ T{ ##box-displaced-alien f 3 2 0 c-ptr }
+ T{ ##unbox-any-c-ptr f 4 3 }
+ } value-numbering-step
+] unit-test
+
+3 vreg-counter set-global
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 1 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 0 }
+ T{ ##box-displaced-alien f 3 2 0 c-ptr }
+ T{ ##replace f 3 D 1 }
+ } value-numbering-step
+] unit-test
+
! Branch folding
[
{
] unit-test
[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
+
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs kernel accessors
-sorting sets sequences
+sorting sets sequences arrays
cpu.architecture
+sequences.deep
compiler.cfg
compiler.cfg.rpo
+compiler.cfg.def-use
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions
! Local value numbering.
: >copy ( insn -- insn/##copy )
- dup dst>> dup vreg>vn vn>vreg
+ dup defs-vreg dup vreg>vn vn>vreg
2dup eq? [ 2drop ] [ any-rep \ ##copy new-insn nip ] if ;
-: rewrite-loop ( insn -- insn' )
- dup rewrite [ rewrite-loop ] [ ] ?if ;
-
GENERIC: process-instruction ( insn -- insn' )
-M: ##flushable process-instruction
+M: insn process-instruction
dup rewrite
[ process-instruction ]
- [ dup number-values >copy ] ?if ;
+ [ dup defs-vreg [ dup number-values >copy ] when ] ?if ;
-M: insn process-instruction
- dup rewrite
- [ process-instruction ] [ ] ?if ;
+M: array process-instruction
+ [ process-instruction ] map ;
: value-numbering-step ( insns -- insns' )
init-value-graph
- init-expressions
- [ process-instruction ] map ;
+ [ process-instruction ] map flatten ;
: value-numbering ( cfg -- cfg' )
[ value-numbering-step ] local-optimization
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
-combinators classes.algebra alien alien.c-types alien.structs
+combinators classes.algebra alien alien.c-types
alien.strings alien.arrays alien.complex alien.libraries sets libc
continuations.private fry cpu.architecture classes locals
-source-files.errors
+source-files.errors slots parser generic.parser
compiler.errors
compiler.alien
compiler.constants
compiler.cfg.builder
compiler.codegen.fixup
compiler.utilities ;
+QUALIFIED: classes.struct
+QUALIFIED: alien.structs
IN: compiler.codegen
SYMBOL: insn-counts
: lookup-label ( id -- label )
labels get [ drop <label> ] cache ;
+! Special cases
M: ##no-tco generate-insn drop ;
-M: ##load-immediate generate-insn
- [ dst>> ] [ val>> ] bi %load-immediate ;
-
-M: ##load-reference generate-insn
- [ dst>> ] [ obj>> ] bi %load-reference ;
-
-M: ##peek generate-insn
- [ dst>> ] [ loc>> ] bi %peek ;
-
-M: ##replace generate-insn
- [ src>> ] [ loc>> ] bi %replace ;
-
-M: ##inc-d generate-insn n>> %inc-d ;
-
-M: ##inc-r generate-insn n>> %inc-r ;
-
M: ##call generate-insn
word>> dup sub-primitive>>
[ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
-M: ##return generate-insn drop %return ;
-
-M: _dispatch generate-insn
- [ src>> ] [ temp>> ] bi %dispatch ;
-
M: _dispatch-label generate-insn
label>> lookup-label
cell 0 <repetition> %
rc-absolute-cell label-fixup ;
-: >slot< ( insn -- dst obj slot tag )
- { [ dst>> ] [ obj>> ] [ slot>> ] [ tag>> ] } cleave ; inline
-
-M: ##slot generate-insn
- [ >slot< ] [ temp>> ] bi %slot ;
-
-M: ##slot-imm generate-insn
- >slot< %slot-imm ;
-
-: >set-slot< ( insn -- src obj slot tag )
- { [ src>> ] [ obj>> ] [ slot>> ] [ tag>> ] } cleave ; inline
-
-M: ##set-slot generate-insn
- [ >set-slot< ] [ temp>> ] bi %set-slot ;
-
-M: ##set-slot-imm generate-insn
- >set-slot< %set-slot-imm ;
-
-M: ##string-nth generate-insn
- { [ dst>> ] [ obj>> ] [ index>> ] [ temp>> ] } cleave %string-nth ;
-
-M: ##set-string-nth-fast generate-insn
- { [ src>> ] [ obj>> ] [ index>> ] [ temp>> ] } cleave %set-string-nth-fast ;
-
-: dst/src ( insn -- dst src )
- [ dst>> ] [ src>> ] bi ; inline
-
-: dst/src1/src2 ( insn -- dst src1 src2 )
- [ dst>> ] [ src1>> ] [ src2>> ] tri ; inline
-
-M: ##add generate-insn dst/src1/src2 %add ;
-M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
-M: ##sub generate-insn dst/src1/src2 %sub ;
-M: ##sub-imm generate-insn dst/src1/src2 %sub-imm ;
-M: ##mul generate-insn dst/src1/src2 %mul ;
-M: ##mul-imm generate-insn dst/src1/src2 %mul-imm ;
-M: ##and generate-insn dst/src1/src2 %and ;
-M: ##and-imm generate-insn dst/src1/src2 %and-imm ;
-M: ##or generate-insn dst/src1/src2 %or ;
-M: ##or-imm generate-insn dst/src1/src2 %or-imm ;
-M: ##xor generate-insn dst/src1/src2 %xor ;
-M: ##xor-imm generate-insn dst/src1/src2 %xor-imm ;
-M: ##shl generate-insn dst/src1/src2 %shl ;
-M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
-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: ##not generate-insn dst/src %not ;
-M: ##log2 generate-insn dst/src %log2 ;
-
-: label/dst/src1/src2 ( insn -- label dst src1 src2 )
- [ label>> lookup-label ] [ dst/src1/src2 ] bi ; inline
-
-M: _fixnum-add generate-insn label/dst/src1/src2 %fixnum-add ;
-M: _fixnum-sub generate-insn label/dst/src1/src2 %fixnum-sub ;
-M: _fixnum-mul generate-insn label/dst/src1/src2 %fixnum-mul ;
-
-: dst/src/temp ( insn -- dst src temp )
- [ dst/src ] [ temp>> ] bi ; inline
-
-M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
-M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ;
-
-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: ##integer>float generate-insn dst/src %integer>float ;
-M: ##float>integer generate-insn dst/src %float>integer ;
-
-M: ##copy generate-insn [ dst/src ] [ rep>> ] bi %copy ;
-
-M: ##unbox-float generate-insn dst/src %unbox-float ;
-M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
-M: ##box-float generate-insn dst/src/temp %box-float ;
-M: ##box-alien generate-insn dst/src/temp %box-alien ;
-
-M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
-M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
-M: ##alien-unsigned-4 generate-insn dst/src %alien-unsigned-4 ;
-M: ##alien-signed-1 generate-insn dst/src %alien-signed-1 ;
-M: ##alien-signed-2 generate-insn dst/src %alien-signed-2 ;
-M: ##alien-signed-4 generate-insn dst/src %alien-signed-4 ;
-M: ##alien-cell generate-insn dst/src %alien-cell ;
-M: ##alien-float generate-insn dst/src %alien-float ;
-M: ##alien-double generate-insn dst/src %alien-double ;
-
-: >alien-setter< ( insn -- src value )
- [ src>> ] [ value>> ] bi ; inline
-
-M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
-M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
-M: ##set-alien-integer-4 generate-insn >alien-setter< %set-alien-integer-4 ;
-M: ##set-alien-cell generate-insn >alien-setter< %set-alien-cell ;
-M: ##set-alien-float generate-insn >alien-setter< %set-alien-float ;
-M: ##set-alien-double generate-insn >alien-setter< %set-alien-double ;
-
-M: ##allot generate-insn
- {
- [ dst>> ]
- [ size>> ]
- [ class>> ]
- [ temp>> ]
- } cleave
- %allot ;
+M: _prologue generate-insn
+ stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
+
+M: _epilogue generate-insn
+ stack-frame>> total-size>> %epilogue ;
-M: ##write-barrier generate-insn
- [ src>> ]
- [ card#>> ]
- [ table>> ]
- tri %write-barrier ;
+M: _spill-area-size generate-insn drop ;
+
+! Some meta-programming to generate simple code generators, where
+! the instruction is unpacked and then a %word is called
+<<
+
+: insn-slot-quot ( spec -- quot )
+ name>> [ reader-word ] [ "label" = ] bi
+ [ \ lookup-label [ ] 2sequence ] [ [ ] 1sequence ] if ;
-! GC checks
+: codegen-method-body ( class word -- quot )
+ [
+ "insn-slots" word-prop
+ [ insn-slot-quot ] map cleave>quot
+ ] dip suffix ;
+
+SYNTAX: CODEGEN:
+ scan-word [ \ generate-insn create-method-in ] keep scan-word
+ codegen-method-body define ;
+>>
+
+CODEGEN: ##load-immediate %load-immediate
+CODEGEN: ##load-reference %load-reference
+CODEGEN: ##peek %peek
+CODEGEN: ##replace %replace
+CODEGEN: ##inc-d %inc-d
+CODEGEN: ##inc-r %inc-r
+CODEGEN: ##return %return
+CODEGEN: ##slot %slot
+CODEGEN: ##slot-imm %slot-imm
+CODEGEN: ##set-slot %set-slot
+CODEGEN: ##set-slot-imm %set-slot-imm
+CODEGEN: ##string-nth %string-nth
+CODEGEN: ##set-string-nth-fast %set-string-nth-fast
+CODEGEN: ##add %add
+CODEGEN: ##add-imm %add-imm
+CODEGEN: ##sub %sub
+CODEGEN: ##sub-imm %sub-imm
+CODEGEN: ##mul %mul
+CODEGEN: ##mul-imm %mul-imm
+CODEGEN: ##and %and
+CODEGEN: ##and-imm %and-imm
+CODEGEN: ##or %or
+CODEGEN: ##or-imm %or-imm
+CODEGEN: ##xor %xor
+CODEGEN: ##xor-imm %xor-imm
+CODEGEN: ##shl %shl
+CODEGEN: ##shl-imm %shl-imm
+CODEGEN: ##shr %shr
+CODEGEN: ##shr-imm %shr-imm
+CODEGEN: ##sar %sar
+CODEGEN: ##sar-imm %sar-imm
+CODEGEN: ##min %min
+CODEGEN: ##max %max
+CODEGEN: ##not %not
+CODEGEN: ##log2 %log2
+CODEGEN: ##copy %copy
+CODEGEN: ##integer>bignum %integer>bignum
+CODEGEN: ##bignum>integer %bignum>integer
+CODEGEN: ##unbox-float %unbox-float
+CODEGEN: ##box-float %box-float
+CODEGEN: ##add-float %add-float
+CODEGEN: ##sub-float %sub-float
+CODEGEN: ##mul-float %mul-float
+CODEGEN: ##div-float %div-float
+CODEGEN: ##min-float %min-float
+CODEGEN: ##max-float %max-float
+CODEGEN: ##sqrt %sqrt
+CODEGEN: ##unary-float-function %unary-float-function
+CODEGEN: ##binary-float-function %binary-float-function
+CODEGEN: ##single>double-float %single>double-float
+CODEGEN: ##double>single-float %double>single-float
+CODEGEN: ##integer>float %integer>float
+CODEGEN: ##float>integer %float>integer
+CODEGEN: ##unbox-vector %unbox-vector
+CODEGEN: ##broadcast-vector %broadcast-vector
+CODEGEN: ##gather-vector-2 %gather-vector-2
+CODEGEN: ##gather-vector-4 %gather-vector-4
+CODEGEN: ##box-vector %box-vector
+CODEGEN: ##add-vector %add-vector
+CODEGEN: ##sub-vector %sub-vector
+CODEGEN: ##mul-vector %mul-vector
+CODEGEN: ##div-vector %div-vector
+CODEGEN: ##min-vector %min-vector
+CODEGEN: ##max-vector %max-vector
+CODEGEN: ##sqrt-vector %sqrt-vector
+CODEGEN: ##horizontal-add-vector %horizontal-add-vector
+CODEGEN: ##box-alien %box-alien
+CODEGEN: ##box-displaced-alien %box-displaced-alien
+CODEGEN: ##unbox-alien %unbox-alien
+CODEGEN: ##unbox-any-c-ptr %unbox-any-c-ptr
+CODEGEN: ##alien-unsigned-1 %alien-unsigned-1
+CODEGEN: ##alien-unsigned-2 %alien-unsigned-2
+CODEGEN: ##alien-unsigned-4 %alien-unsigned-4
+CODEGEN: ##alien-signed-1 %alien-signed-1
+CODEGEN: ##alien-signed-2 %alien-signed-2
+CODEGEN: ##alien-signed-4 %alien-signed-4
+CODEGEN: ##alien-cell %alien-cell
+CODEGEN: ##alien-float %alien-float
+CODEGEN: ##alien-double %alien-double
+CODEGEN: ##alien-vector %alien-vector
+CODEGEN: ##set-alien-integer-1 %set-alien-integer-1
+CODEGEN: ##set-alien-integer-2 %set-alien-integer-2
+CODEGEN: ##set-alien-integer-4 %set-alien-integer-4
+CODEGEN: ##set-alien-cell %set-alien-cell
+CODEGEN: ##set-alien-float %set-alien-float
+CODEGEN: ##set-alien-double %set-alien-double
+CODEGEN: ##set-alien-vector %set-alien-vector
+CODEGEN: ##allot %allot
+CODEGEN: ##write-barrier %write-barrier
+CODEGEN: ##compare %compare
+CODEGEN: ##compare-imm %compare-imm
+CODEGEN: ##compare-float-ordered %compare-float-ordered
+CODEGEN: ##compare-float-unordered %compare-float-unordered
+CODEGEN: ##save-context %save-context
+
+CODEGEN: _fixnum-add %fixnum-add
+CODEGEN: _fixnum-sub %fixnum-sub
+CODEGEN: _fixnum-mul %fixnum-mul
+CODEGEN: _label resolve-label
+CODEGEN: _branch %jump-label
+CODEGEN: _compare-branch %compare-branch
+CODEGEN: _compare-imm-branch %compare-imm-branch
+CODEGEN: _compare-float-ordered-branch %compare-float-ordered-branch
+CODEGEN: _compare-float-unordered-branch %compare-float-unordered-branch
+CODEGEN: _dispatch %dispatch
+CODEGEN: _spill %spill
+CODEGEN: _reload %reload
+
+! ##gc
: wipe-locs ( locs temp -- )
'[
_
GENERIC# save-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot save-gc-root ( gc-root operand temp -- )
- temp operand n>> int-rep %reload
+ temp int-rep operand n>> %reload
gc-root temp %save-gc-root ;
M: object save-gc-root drop %save-gc-root ;
M:: spill-slot load-gc-root ( gc-root operand temp -- )
gc-root temp %load-gc-root
- temp operand n>> int-rep %spill ;
+ temp int-rep operand n>> %spill ;
M: object load-gc-root drop %load-gc-root ;
[ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
[ data-values>> save-data-regs ]
[ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
+ [ [ temp1>> ] [ temp2>> ] bi t %save-context ]
[ tagged-values>> length %call-gc ]
[ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
[ data-values>> load-data-regs ]
M: int-rep next-fastcall-param
int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
-M: single-float-rep next-fastcall-param
+M: float-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-M: double-float-rep next-fastcall-param
+M: double-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
GENERIC: reg-class-full? ( reg-class -- ? )
M: object flatten-value-type 1array ;
-M: struct-type flatten-value-type ( type -- types )
+M: alien.structs:struct-type flatten-value-type ( type -- types )
+ stack-size cell align (flatten-int-type) ;
+
+M: classes.struct:struct-c-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- types )
M: ##alien-invoke generate-insn
params>>
- ! Save registers for GC
- %prepare-alien-invoke
! Unbox parameters
dup objects>registers
%prepare-var-args
! ##alien-indirect
M: ##alien-indirect generate-insn
params>>
- ! Save registers for GC
- %prepare-alien-invoke
! Save alien at top of stack to temporary storage
%prepare-alien-indirect
! Unbox parameters
[ wrap-callback-quot %alien-callback ]
[ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
tri ;
-
-M: _prologue generate-insn
- stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
-
-M: _epilogue generate-insn
- stack-frame>> total-size>> %epilogue ;
-
-M: _label generate-insn
- id>> lookup-label resolve-label ;
-
-M: _branch generate-insn
- label>> lookup-label %jump-label ;
-
-: >compare< ( insn -- dst temp cc src1 src2 )
- {
- [ dst>> ]
- [ temp>> ]
- [ cc>> ]
- [ src1>> ]
- [ src2>> ]
- } cleave ; inline
-
-M: ##compare generate-insn >compare< %compare ;
-M: ##compare-imm generate-insn >compare< %compare-imm ;
-M: ##compare-float generate-insn >compare< %compare-float ;
-
-: >binary-branch< ( insn -- label cc src1 src2 )
- {
- [ label>> lookup-label ]
- [ cc>> ]
- [ src1>> ]
- [ src2>> ]
- } cleave ; inline
-
-M: _compare-branch generate-insn
- >binary-branch< %compare-branch ;
-
-M: _compare-imm-branch generate-insn
- >binary-branch< %compare-imm-branch ;
-
-M: _compare-float-branch generate-insn
- >binary-branch< %compare-float-branch ;
-
-M: _spill generate-insn
- [ src>> ] [ n>> ] [ rep>> ] tri %spill ;
-
-M: _reload generate-insn
- [ dst>> ] [ n>> ] [ rep>> ] tri %reload ;
-
-M: _spill-area-size generate-insn drop ;
-USING: alien alien.c-types alien.syntax compiler kernel namespaces
-sequences stack-checker stack-checker.errors words arrays parser
-quotations continuations effects namespaces.private io
-io.streams.string memory system threads tools.test math accessors
-combinators specialized-arrays.float alien.libraries io.pathnames
-io.backend ;
+USING: accessors alien alien.c-types alien.libraries
+alien.syntax arrays classes.struct combinators
+compiler continuations effects io io.backend io.pathnames
+io.streams.string kernel math memory namespaces
+namespaces.private parser quotations sequences
+specialized-arrays stack-checker stack-checker.errors
+system threads tools.test words ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: char
IN: compiler.tests.alien
<<
[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
-C-STRUCT: foo
- { "int" "x" }
- { "int" "y" }
-;
+STRUCT: FOO { x int } { y int } ;
-: make-foo ( x y -- foo )
- "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
+: make-FOO ( x y -- FOO )
+ FOO <struct> swap >>y swap >>x ;
-FUNCTION: int ffi_test_11 int a foo b int c ;
+FUNCTION: int ffi_test_11 int a FOO b int c ;
-[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
+[ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
-FUNCTION: foo ffi_test_14 int x int y ;
+FUNCTION: FOO ffi_test_14 int x int y ;
-[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
+[ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
FUNCTION: char* ffi_test_15 char* x char* y ;
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
[ 1 2 ffi_test_15 ] must-fail
-C-STRUCT: bar
- { "long" "x" }
- { "long" "y" }
- { "long" "z" }
-;
+STRUCT: BAR { x long } { y long } { z long } ;
-FUNCTION: bar ffi_test_16 long x long y long z ;
+FUNCTION: BAR ffi_test_16 long x long y long z ;
[ 11 6 -7 ] [
- 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
+ 11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
] unit-test
-C-STRUCT: tiny
- { "int" "x" }
-;
+STRUCT: TINY { x int } ;
-FUNCTION: tiny ffi_test_17 int x ;
+FUNCTION: TINY ffi_test_17 int x ;
-[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
+[ 11 ] [ 11 ffi_test_17 x>> ] unit-test
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
-: ffi_test_19 ( x y z -- bar )
- "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
+: ffi_test_19 ( x y z -- BAR )
+ "BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
alien-invoke gc ;
[ 11 6 -7 ] [
- 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
+ 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
] unit-test
FUNCTION: double ffi_test_6 float x float y ;
[ 1111 f 123456789 ffi_test_22 ] must-fail
-C-STRUCT: rect
- { "float" "x" }
- { "float" "y" }
- { "float" "w" }
- { "float" "h" }
-;
+STRUCT: RECT
+ { x float } { y float }
+ { w float } { h float } ;
-: <rect> ( x y w h -- rect )
- "rect" <c-object>
- [ set-rect-h ] keep
- [ set-rect-w ] keep
- [ set-rect-y ] keep
- [ set-rect-x ] keep ;
+: <RECT> ( x y w h -- rect )
+ RECT <struct>
+ swap >>h
+ swap >>w
+ swap >>y
+ swap >>x ;
-FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
+FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
-[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
+[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
] unit-test
! Test odd-size structs
-C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
+STRUCT: test-struct-1 { x char[1] } ;
FUNCTION: test-struct-1 ffi_test_24 ;
-[ B{ 1 } ] [ ffi_test_24 ] unit-test
+[ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
-C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
+STRUCT: test-struct-2 { x char[2] } ;
FUNCTION: test-struct-2 ffi_test_25 ;
-[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
+[ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
-C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
+STRUCT: test-struct-3 { x char[3] } ;
FUNCTION: test-struct-3 ffi_test_26 ;
-[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
+[ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
-C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
+STRUCT: test-struct-4 { x char[4] } ;
FUNCTION: test-struct-4 ffi_test_27 ;
-[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
+[ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
-C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
+STRUCT: test-struct-5 { x char[5] } ;
FUNCTION: test-struct-5 ffi_test_28 ;
-[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
+[ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
-C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
+STRUCT: test-struct-6 { x char[6] } ;
FUNCTION: test-struct-6 ffi_test_29 ;
-[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
+[ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
-C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
+STRUCT: test-struct-7 { x char[7] } ;
FUNCTION: test-struct-7 ffi_test_30 ;
-[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
+[ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
-C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
+STRUCT: test-struct-8 { x double } { y double } ;
FUNCTION: double ffi_test_32 test-struct-8 x int y ;
[ 9.0 ] [
- "test-struct-8" <c-object>
- 1.0 over set-test-struct-8-x
- 2.0 over set-test-struct-8-y
+ test-struct-8 <struct>
+ 1.0 >>x
+ 2.0 >>y
3 ffi_test_32
] unit-test
-C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
+STRUCT: test-struct-9 { x float } { y float } ;
FUNCTION: double ffi_test_33 test-struct-9 x int y ;
[ 9.0 ] [
- "test-struct-9" <c-object>
- 1.0 over set-test-struct-9-x
- 2.0 over set-test-struct-9-y
+ test-struct-9 <struct>
+ 1.0 >>x
+ 2.0 >>y
3 ffi_test_33
] unit-test
-C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
+STRUCT: test-struct-10 { x float } { y int } ;
FUNCTION: double ffi_test_34 test-struct-10 x int y ;
[ 9.0 ] [
- "test-struct-10" <c-object>
- 1.0 over set-test-struct-10-x
- 2 over set-test-struct-10-y
+ test-struct-10 <struct>
+ 1.0 >>x
+ 2 >>y
3 ffi_test_34
] unit-test
-C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
+STRUCT: test-struct-11 { x int } { y int } ;
FUNCTION: double ffi_test_35 test-struct-11 x int y ;
[ 9.0 ] [
- "test-struct-11" <c-object>
- 1 over set-test-struct-11-x
- 2 over set-test-struct-11-y
+ test-struct-11 <struct>
+ 1 >>x
+ 2 >>y
3 ffi_test_35
] unit-test
-C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
+STRUCT: test-struct-12 { a int } { x double } ;
: make-struct-12 ( x -- alien )
- "test-struct-12" <c-object>
- [ set-test-struct-12-x ] keep ;
+ test-struct-12 <struct>
+ swap >>x ;
FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
[ 7 ] [ callback-9 ffi_test_37 ] unit-test
-C-STRUCT: test_struct_13
-{ "float" "x1" }
-{ "float" "x2" }
-{ "float" "x3" }
-{ "float" "x4" }
-{ "float" "x5" }
-{ "float" "x6" } ;
+STRUCT: test_struct_13
+{ x1 float }
+{ x2 float }
+{ x3 float }
+{ x4 float }
+{ x5 float }
+{ x6 float } ;
: make-test-struct-13 ( -- alien )
- "test_struct_13" <c-object>
- 1.0 over set-test_struct_13-x1
- 2.0 over set-test_struct_13-x2
- 3.0 over set-test_struct_13-x3
- 4.0 over set-test_struct_13-x4
- 5.0 over set-test_struct_13-x5
- 6.0 over set-test_struct_13-x6 ;
+ test_struct_13 <struct>
+ 1.0 >>x1
+ 2.0 >>x2
+ 3.0 >>x3
+ 4.0 >>x4
+ 5.0 >>x5
+ 6.0 >>x6 ;
FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
[ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
! Joe Groff found this problem
-C-STRUCT: double-rect
-{ "double" "a" }
-{ "double" "b" }
-{ "double" "c" }
-{ "double" "d" } ;
+STRUCT: double-rect
+{ a double }
+{ b double }
+{ c double }
+{ d double } ;
: <double-rect> ( a b c d -- foo )
- "double-rect" <c-object>
- {
- [ set-double-rect-d ]
- [ set-double-rect-c ]
- [ set-double-rect-b ]
- [ set-double-rect-a ]
- [ ]
- } cleave ;
+ double-rect <struct>
+ swap >>d
+ swap >>c
+ swap >>b
+ swap >>a ;
: >double-rect< ( foo -- a b c d )
{
- [ double-rect-a ]
- [ double-rect-b ]
- [ double-rect-c ]
- [ double-rect-d ]
+ [ a>> ]
+ [ b>> ]
+ [ c>> ]
+ [ d>> ]
} cleave ;
: double-rect-callback ( -- alien )
[ 1.0 2.0 3.0 4.0 ]
[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
-C-STRUCT: test_struct_14
-{ "double" "x1" }
-{ "double" "x2" } ;
+STRUCT: test_struct_14
+ { x1 double }
+ { x2 double } ;
FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
[ 1.0 2.0 ] [
- 1.0 2.0 ffi_test_40
- [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
+ 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
] unit-test
: callback-10 ( -- callback )
"test_struct_14" { "double" "double" } "cdecl"
[
- "test_struct_14" <c-object>
- [ set-test_struct_14-x2 ] keep
- [ set-test_struct_14-x1 ] keep
+ test_struct_14 <struct>
+ swap >>x2
+ swap >>x1
] alien-callback ;
: callback-10-test ( x1 x2 callback -- result )
[ 1.0 2.0 ] [
1.0 2.0 callback-10 callback-10-test
- [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
+ [ x1>> ] [ x2>> ] bi
] unit-test
FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
[ 1 2.0 ] [
1 2.0 ffi_test_41
- [ test-struct-12-a ] [ test-struct-12-x ] bi
+ [ a>> ] [ x>> ] bi
] unit-test
: callback-11 ( -- callback )
"test-struct-12" { "int" "double" } "cdecl"
[
- "test-struct-12" <c-object>
- [ set-test-struct-12-x ] keep
- [ set-test-struct-12-a ] keep
+ test-struct-12 <struct>
+ swap >>x
+ swap >>a
] alien-callback ;
: callback-11-test ( x1 x2 callback -- result )
[ 1 2.0 ] [
1 2.0 callback-11 callback-11-test
- [ test-struct-12-a ] [ test-struct-12-x ] bi
+ [ a>> ] [ x>> ] bi
] unit-test
-C-STRUCT: test_struct_15
-{ "float" "x" }
-{ "float" "y" } ;
+STRUCT: test_struct_15
+ { x float }
+ { y float } ;
FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
-[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ test_struct_15-x ] [ test_struct_15-y ] bi ] unit-test
+[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
: callback-12 ( -- callback )
"test_struct_15" { "float" "float" } "cdecl"
[
- "test_struct_15" <c-object>
- [ set-test_struct_15-y ] keep
- [ set-test_struct_15-x ] keep
+ test_struct_15 <struct>
+ swap >>y
+ swap >>x
] alien-callback ;
: callback-12-test ( x1 x2 callback -- result )
"test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
- 1.0 2.0 callback-12 callback-12-test
- [ test_struct_15-x ] [ test_struct_15-y ] bi
+ 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
] unit-test
-C-STRUCT: test_struct_16
-{ "float" "x" }
-{ "int" "a" } ;
+STRUCT: test_struct_16
+ { x float }
+ { a int } ;
FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
-[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ test_struct_16-x ] [ test_struct_16-a ] bi ] unit-test
+[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
: callback-13 ( -- callback )
"test_struct_16" { "float" "int" } "cdecl"
[
- "test_struct_16" <c-object>
- [ set-test_struct_16-a ] keep
- [ set-test_struct_16-x ] keep
+ test_struct_16 <struct>
+ swap >>a
+ swap >>x
] alien-callback ;
: callback-13-test ( x1 x2 callback -- result )
[ 1.0 2 ] [
1.0 2 callback-13 callback-13-test
- [ test_struct_16-x ] [ test_struct_16-a ] bi
+ [ x>> ] [ a>> ] bi
] unit-test
FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
-[ 1.0 2.0 ] [ ffi_test_44 [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi ] unit-test
+[ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
: stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
] unit-test
! Reported by jedahu
-C-STRUCT: bool-field-test
- { "char*" "name" }
- { "bool" "on" }
- { "short" "parents" } ;
+STRUCT: bool-field-test
+ { name char* }
+ { on bool }
+ { parents short } ;
FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
[ 123 ] [
- "bool-field-test" <c-object> 123 over set-bool-field-test-parents
+ bool-field-test <struct>
+ 123 >>parents
ffi_test_48
] unit-test
namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make alien.c-types combinators.short-circuit
-math.order ;
+math.order math.libm math.parser ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
dup [ [ 1 fixnum+fast ] dip ] [ [ drop 1 ] dip ] if ;
[ 2 t ] [ 0 t global-dcn-bug-1 ] unit-test
-[ 1 f ] [ 0 f global-dcn-bug-1 ] unit-test
\ No newline at end of file
+[ 1 f ] [ 0 f global-dcn-bug-1 ] unit-test
+
+! Forgot a GC check
+: missing-gc-check-1 ( a -- b ) { fixnum } declare <alien> ;
+: missing-gc-check-2 ( -- ) 10000000 [ missing-gc-check-1 drop ] each-integer ;
+
+[ ] [ missing-gc-check-2 ] unit-test
+
+[ 1 "0.169967142900241" ] [ 1.4 [ 1 swap fcos ] compile-call number>string ] unit-test
+[ 1 "0.169967142900241" ] [ 1.4 1 [ swap fcos ] compile-call number>string ] unit-test
+[ "0.169967142900241" "0.9854497299884601" ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
+[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
+
+[ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test
\ No newline at end of file
[ 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
+
+[ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test
+[ t ] [ 0/0. 1.0 [ float-unordered? ] compile-call ] unit-test
+[ t ] [ 1.0 0/0. [ float-unordered? ] compile-call ] unit-test
+[ f ] [ 3.0 1.0 [ float-unordered? ] compile-call ] unit-test
+[ f ] [ 1.0 3.0 [ float-unordered? ] compile-call ] unit-test
+
+[ 1 ] [ 0/0. 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 1 ] [ 0/0. 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 1 ] [ 1.0 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
-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.
[ 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
] compile-call
] unit-test
+[ ALIEN: 123 ] [
+ HEX: 123 [ <alien> ] compile-call
+] unit-test
+
+[ ALIEN: 123 ] [
+ HEX: 123 [ { fixnum } declare <alien> ] compile-call
+] unit-test
+
+[ ALIEN: 123 ] [
+ [ HEX: 123 <alien> ] compile-call
+] unit-test
+
+[ f ] [
+ 0 [ <alien> ] compile-call
+] unit-test
+
+[ f ] [
+ 0 [ { fixnum } declare <alien> ] compile-call
+] unit-test
+
+[ f ] [
+ [ 0 <alien> ] compile-call
+] unit-test
+
+[ ALIEN: 321 ] [
+ 0 ALIEN: 321 [ <displaced-alien> ] compile-call
+] unit-test
+
+[ ALIEN: 321 ] [
+ 0 ALIEN: 321 [ { fixnum c-ptr } declare <displaced-alien> ] compile-call
+] unit-test
+
+[ ALIEN: 321 ] [
+ ALIEN: 321 [ 0 swap <displaced-alien> ] compile-call
+] unit-test
+
+[ B{ 0 1 2 3 4 } ] [
+ 2 B{ 0 1 2 3 4 } <displaced-alien>
+ [ 1 swap <displaced-alien> ] compile-call
+ underlying>>
+] unit-test
+
+[ B{ 0 1 2 3 4 } ] [
+ 2 B{ 0 1 2 3 4 } <displaced-alien>
+ [ 1 swap { c-ptr } declare <displaced-alien> ] compile-call
+ underlying>>
+] unit-test
+
+[ ALIEN: 1234 ALIEN: 2234 ] [
+ ALIEN: 234 [
+ { c-ptr } declare
+ [ HEX: 1000 swap <displaced-alien> ]
+ [ HEX: 2000 swap <displaced-alien> ] bi
+ ] compile-call
+] unit-test
+
[
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
] must-fail
compiler.cfg.registers compiler.codegen compiler.units
cpu.architecture hashtables kernel namespaces sequences
tools.test vectors words layouts literals math arrays
-alien.syntax ;
+alien.syntax math.private ;
IN: compiler.tests.low-level-ir
: compile-cfg ( cfg -- word )
} compile-test-bb
] unit-test
+! ##copy on floats. We can only run this test if float intrinsics
+! are enabled.
+\ float+ "intrinsic" word-prop [
+ [ 1.5 ] [
+ V{
+ T{ ##load-reference f 4 1.5 }
+ T{ ##unbox-float f 1 4 }
+ T{ ##copy f 2 1 double-rep }
+ T{ ##box-float f 3 2 }
+ T{ ##copy f 0 3 int-rep }
+ } compile-test-bb
+ ] unit-test
+] when
+
! make sure slot access works when the destination is
! one of the sources
[ t ] [
} compile-test-bb
] unit-test
-*/
\ No newline at end of file
+*/
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order math.intervals assocs combinators ;
IN: compiler.tree.comparisons
! Some utilities for working with comparison operations.
-CONSTANT: comparison-ops { < > <= >= }
+CONSTANT: comparison-ops { < > <= >= u< u> u<= u>= }
CONSTANT: generic-comparison-ops { before? after? before=? after=? }
: assumption ( i1 i2 op -- i3 )
{
- { \ < [ assume< ] }
- { \ > [ assume> ] }
- { \ <= [ assume<= ] }
- { \ >= [ assume>= ] }
+ { \ < [ assume< ] }
+ { \ > [ assume> ] }
+ { \ <= [ assume<= ] }
+ { \ >= [ assume>= ] }
+ { \ u< [ assume< ] }
+ { \ u> [ assume> ] }
+ { \ u<= [ assume<= ] }
+ { \ u>= [ assume>= ] }
} case ;
: interval-comparison ( i1 i2 op -- result )
{
- { \ < [ interval< ] }
- { \ > [ interval> ] }
- { \ <= [ interval<= ] }
- { \ >= [ interval>= ] }
+ { \ < [ interval< ] }
+ { \ > [ interval> ] }
+ { \ <= [ interval<= ] }
+ { \ >= [ interval>= ] }
+ { \ u< [ interval< ] }
+ { \ u> [ interval> ] }
+ { \ u<= [ interval<= ] }
+ { \ u>= [ interval>= ] }
} case ;
: swap-comparison ( op -- op' )
{ > < }
{ <= >= }
{ >= <= }
+ { u< u> }
+ { u> u< }
+ { u<= u>= }
+ { u>= u<= }
} at ;
: negate-comparison ( op -- op' )
{ > <= }
{ <= > }
{ >= < }
+ { u< u>= }
+ { u> u<= }
+ { u<= u> }
+ { u>= u< }
} at ;
: specific-comparison ( op -- op' )
pad-with-bottom >>phi-in-d drop ;
: live-value-indices ( values -- indices )
- [ length ] keep live-values get
+ [ length iota ] keep live-values get
'[ _ nth _ key? ] filter ; inline
: drop-indexed-values ( values indices -- node )
[ t ] [ [ 2 '[ _ ] 1 '[ _ + ] compose ] final-info first infer-value (( -- object )) effect= ] unit-test
[ t ] [ [ 2 '[ _ + ] ] final-info first infer-value (( object -- object )) effect= ] unit-test
[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
-[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
+[ t ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value (( -- object )) effect= ] unit-test
[ f ] [ [ dup drop ] final-info first infer-value ] unit-test
! This should not hang
[ ] [ [ [ dup call( quot -- ) ] dup call( quot -- ) ] final-info drop ] unit-test
-[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
\ No newline at end of file
+[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
+
+! This should get inlined, because the parameter to the curry is literal even though
+! [ boa ] by itself doesn't infer
+TUPLE: a-tuple x ;
+
+[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test
\ No newline at end of file
M: compose cached-effect
[ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
+: safe-infer ( quot -- effect )
+ [ infer ] [ 2drop +unknown+ ] recover ;
+
M: quotation cached-effect
dup cached-effect>>
- [ ] [
- [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
- (>>cached-effect)
- ] ?if ;
+ [ ] [ [ safe-infer dup ] keep (>>cached-effect) ] ?if ;
: call-effect-unsafe? ( quot effect -- ? )
[ cached-effect ] dip
: execute-effect>quot ( effect -- quot )
inline-cache new '[ drop _ _ execute-effect-ic ] ;
+! Some bookkeeping to make sure that crap like
+! [ dup curry call( quot -- ) ] dup curry call( quot -- ) ]
+! doesn't hang the compiler.
+GENERIC: already-inlined-quot? ( quot -- ? )
+
+M: curry already-inlined-quot? quot>> already-inlined-quot? ;
+
+M: compose already-inlined-quot?
+ [ first>> already-inlined-quot? ]
+ [ second>> already-inlined-quot? ] bi or ;
+
+M: quotation already-inlined-quot? already-inlined? ;
+
+GENERIC: add-quot-to-history ( quot -- )
+
+M: curry add-quot-to-history quot>> add-quot-to-history ;
+
+M: compose add-quot-to-history
+ [ first>> add-quot-to-history ]
+ [ second>> add-quot-to-history ] bi ;
+
+M: quotation add-quot-to-history add-to-history ;
+
: last2 ( seq -- penultimate ultimate )
2 tail* first2 ;
(( -- object )) swap compose-effects ;
: (infer-value) ( value-info -- effect )
- dup class>> {
- { \ quotation [
- literal>> [ uninferable ] unless*
- dup already-inlined? [ uninferable ] when
- cached-effect dup +unknown+ = [ uninferable ] when
- ] }
- { \ curry [
- slots>> third (infer-value)
- remove-effect-input
- ] }
- { \ compose [
- slots>> last2 [ (infer-value) ] bi@
- compose-effects
- ] }
- [ uninferable ]
- } case ;
+ dup literal?>> [
+ literal>>
+ [ callable? [ uninferable ] unless ]
+ [ already-inlined-quot? [ uninferable ] when ]
+ [ safe-infer dup +unknown+ = [ uninferable ] when ] tri
+ ] [
+ dup class>> {
+ { \ curry [ slots>> third (infer-value) remove-effect-input ] }
+ { \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
+ [ uninferable ]
+ } case
+ ] if ;
: infer-value ( value-info -- effect/f )
[ (infer-value) ]
recover ;
: (value>quot) ( value-info -- quot )
- dup class>> {
- { \ quotation [ literal>> dup add-to-history '[ drop @ ] ] }
- { \ curry [
- slots>> third (value>quot)
- '[ [ obj>> ] [ quot>> @ ] bi ]
- ] }
- { \ compose [
- slots>> last2 [ (value>quot) ] bi@
- '[ [ first>> @ ] [ second>> @ ] bi ]
- ] }
- } case ;
+ dup literal?>> [
+ literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
+ ] [
+ dup class>> {
+ { \ curry [
+ slots>> third (value>quot)
+ '[ [ obj>> ] [ quot>> @ ] bi ]
+ ] }
+ { \ compose [
+ slots>> last2 [ (value>quot) ] bi@
+ '[ [ first>> @ ] [ second>> @ ] bi ]
+ ] }
+ } case
+ ] if ;
: value>quot ( value-info -- quot: ( code effect -- ) )
(value>quot) '[ drop @ ] ;
:: inline-word ( #call word -- ? )
word already-inlined? [ f ] [
#call word splicing-body [
- [
- word add-to-history
- dup (propagate)
- ] with-scope
- #call (>>body) t
+ word add-to-history
+ #call (>>body)
+ #call propagate-body
] [ f ] if*
] if ;
#! Note the logic here: if there's a custom inlining hook,
#! it is permitted to return f, which means that we try the
#! normal inlining heuristic.
- dup custom-inlining? [ 2dup inline-custom ] [ f ] if
- [ 2drop t ] [ (do-inlining) ] if ;
+ [
+ dup custom-inlining? [ 2dup inline-custom ] [ f ] if
+ [ 2drop t ] [ (do-inlining) ] if
+ ] with-scope ;
-! 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 layouts words sequences sequences.private
-arrays assocs classes classes.algebra combinators generic.math
-splitting fry locals classes.tuple alien.accessors
-classes.tuple.private slots.private definitions strings.private
-vectors hashtables generic quotations
+math.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
+generic quotations alien
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
compiler.tree.propagation.simple
compiler.tree.propagation.constraints
compiler.tree.propagation.call-effect
-compiler.tree.propagation.transforms ;
+compiler.tree.propagation.transforms
+compiler.tree.propagation.simd ;
IN: compiler.tree.propagation.known-words
{ + - * / }
[ { number number } "input-classes" set-word-prop ] each
-{ /f < > <= >= }
+{ /f < > <= >= u< u> u<= u>= }
[ { real real } "input-classes" set-word-prop ] each
{ /i mod /mod }
\ bitnot { integer } "input-classes" set-word-prop
-: real-op ( info quot -- quot' )
- [
- dup class>> real classes-intersect?
- [ clone ] [ drop real <class-info> ] if
- ] dip
- change-interval ; inline
-
-{ bitnot fixnum-bitnot bignum-bitnot } [
- [ [ interval-bitnot ] real-op ] "outputs" set-word-prop
-] each
-
-\ abs [ [ interval-abs ] real-op ] "outputs" set-word-prop
-
-\ absq [ [ interval-absq ] real-op ] "outputs" set-word-prop
-
: math-closure ( class -- newclass )
{ fixnum bignum integer rational float real number object }
[ class<= ] with find nip ;
: fits-in-fixnum? ( interval -- ? )
fixnum-interval interval-subset? ;
-: binary-op-class ( info1 info2 -- newclass )
- [ class>> ] bi@
- 2dup [ null-class? ] either? [ 2drop null ] [
- [ math-closure ] bi@ math-class-max
- ] if ;
-
-: binary-op-interval ( info1 info2 quot -- newinterval )
- [ [ interval>> ] bi@ ] dip call ; inline
-
: won't-overflow? ( class interval -- ? )
[ fixnum class<= ] [ fits-in-fixnum? ] bi* and ;
] 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 ;
[ drop float ] dip
] unless ;
+: unary-op-class ( info -- newclass )
+ class>> dup null-class? [ drop null ] [ math-closure ] if ;
+
+: unary-op-interval ( info quot -- newinterval )
+ [
+ dup class>> real classes-intersect?
+ [ interval>> ] [ drop full-interval ] if
+ ] dip call ; inline
+
+: unary-op ( word interval-quot post-proc-quot -- )
+ '[
+ [ unary-op-class ] [ _ unary-op-interval ] bi
+ @
+ <class/interval-info>
+ ] "outputs" set-word-prop ;
+
+{ bitnot fixnum-bitnot bignum-bitnot } [
+ [ interval-bitnot ] [ integer-valued ] unary-op
+] each
+
+\ abs [ interval-abs ] [ may-overflow real-valued ] unary-op
+
+\ absq [ interval-absq ] [ may-overflow real-valued ] unary-op
+
+: binary-op-class ( info1 info2 -- newclass )
+ [ class>> ] bi@
+ 2dup [ null-class? ] either? [ 2drop null ] [
+ [ math-closure ] bi@ math-class-max
+ ] if ;
+
+: binary-op-interval ( info1 info2 quot -- newinterval )
+ [ [ interval>> ] bi@ ] dip call ; inline
+
: binary-op ( word interval-quot post-proc-quot -- )
'[
[ binary-op-class ] [ _ binary-op-interval ] 2bi
'[ 2drop _ ] "outputs" set-word-prop
] each
+\ alien-cell [
+ 2drop simple-alien \ f class-or <class-info>
+] "outputs" set-word-prop
+
{ <tuple> <tuple-boa> } [
[
literal>> dup array? [ first ] [ drop tuple ] if <class-info>
] "outputs" set-word-prop
! the output of clone has the same type as the input
+: cloned-value-info ( value-info -- value-info' )
+ clone f >>literal f >>literal?
+ [ [ dup [ cloned-value-info ] when ] map ] change-slots ;
+
{ clone (clone) } [
- [ clone f >>literal f >>literal? ]
- "outputs" set-word-prop
+ [ cloned-value-info ] "outputs" set-word-prop
] each
\ slot [
bi
] [ 2drop object-info ] if
] "outputs" set-word-prop
+
+{ facos fasin fatan fatan2 fcos fsin ftan fcosh fsinh ftanh fexp
+flog fpow fsqrt facosh fasinh fatanh } [
+ { float } "default-output-classes" set-word-prop
+] each
+
+! 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
compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
-specialized-arrays.double system sorting math.libm
-math.intervals quotations effects ;
+specialized-arrays system sorting math.libm
+math.intervals quotations effects alien ;
+SPECIALIZED-ARRAY: double
IN: compiler.tree.propagation.tests
[ V{ } ] [ [ ] final-classes ] unit-test
[ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
+[ V{ integer } ] [ [ bitnot ] final-classes ] unit-test
+
[ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
! Test type propagation for math ops
[ t ] [ [ absq ] final-info first interval>> [0,inf] = ] unit-test
+[ t ] [ [ { fixnum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
+[ t ] [ [ { fixnum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
+[ V{ integer } ] [ [ { fixnum } declare abs ] final-classes ] unit-test
+
+[ V{ integer } ] [ [ { fixnum } declare absq ] final-classes ] unit-test
+
+[ t ] [ [ { bignum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
+[ t ] [ [ { bignum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
[ t ] [ [ { float } declare abs ] final-info first interval>> [0,inf] = ] unit-test
[ t ] [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test
[ t ] [ [ { complex } declare absq ] final-info first interval>> [0,inf] = ] unit-test
+[ t ] [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-info first interval>> [0,inf] = ] unit-test
+
+[ V{ float } ] [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-classes ] unit-test
+
[ t ] [ [ [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
[ t ] [ [ { double-array double-array } declare [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
] final-literals
] unit-test
+[ V{ 1.5 } ] [
+ [
+ /f
+ dup 1.5 u<= [ dup 1.5 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+ ] final-literals
+] unit-test
+
[ V{ 1.5 } ] [
[
/f
] final-literals
] unit-test
+[ V{ 1.5 } ] [
+ [
+ /f
+ dup 1.5 u<= [ dup 10 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+ ] final-literals
+] unit-test
+
[ V{ f } ] [
[
/f
] final-literals
] unit-test
+[ V{ f } ] [
+ [
+ /f
+ dup 0.0 u<= [ dup 0.0 u>= [ drop 0.0 ] unless ] [ drop 0.0 ] if
+ ] final-literals
+] unit-test
+
[ V{ fixnum } ] [
[ 0 dup 10 > [ 100 * ] when ] final-classes
] unit-test
[ 0 dup 10 > [ drop "foo" ] when ] final-classes
] unit-test
+[ V{ fixnum } ] [
+ [ 0 dup 10 u> [ 100 * ] when ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+ [ 0 dup 10 u> [ drop "foo" ] when ] final-classes
+] unit-test
+
[ V{ fixnum } ] [
[ { fixnum } declare 3 3 - + ] final-classes
] unit-test
[ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
] unit-test
+[ V{ t } ] [
+ [ dup 10 u< [ 3 * 30 u< ] [ drop t ] if ] final-literals
+] unit-test
+
[ V{ "d" } ] [
[
3 {
[ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes
] unit-test
+[ V{ fixnum } ] [
+ [ >fixnum dup 100 u< [ 1 + ] [ "Oops" throw ] if ] final-classes
+] unit-test
+
[ V{ -1 } ] [
[ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals
] unit-test
+[ V{ -1 } ] [
+ [ 0 dup 100 u< not [ 1 + ] [ 1 - ] if ] final-literals
+] unit-test
+
[ V{ 2 } ] [
[ [ 1 ] [ 1 ] if 1 + ] final-literals
] unit-test
[ 0 * 10 < ] final-classes
] unit-test
+[ V{ object } ] [
+ [ 0 * 10 u< ] final-classes
+] unit-test
+
[ V{ 27 } ] [
[
123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if
] final-literals
] unit-test
+[ V{ 27 } ] [
+ [
+ 123 bitand dup 10 u< over 8 u> and [ 3 * ] [ "B" throw ] if
+ ] final-literals
+] unit-test
+
[ V{ 27 } ] [
[
dup number? over sequence? and [
[ 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
[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
+
+! Type function for 'clone' had a subtle issue
+TUPLE: tuple-with-read-only-slot { x read-only } ;
+
+M: tuple-with-read-only-slot clone
+ x>> clone tuple-with-read-only-slot boa ; inline
+
+[ V{ object } ] [
+ [ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
+] unit-test
+
+! alien-cell outputs a simple-alien or f
+[ t ] [
+ [ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
+ first simple-alien class=
+] unit-test
+
+! Don't crash if bad literal inputs are passed to unsafe words
+[ f ] [ [ { } 1 fixnum+fast ] final-info first literal?>> ] unit-test
+
+! Converting /i to shift
+[ t ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { /i fixnum/i fixnum/i-fast } inlined? ] unit-test
+[ f ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { fixnum-shift-fast } inlined? ] unit-test
+[ f ] [ [ >float dup 0 >= [ 16 /i ] when ] { /i float/f } inlined? ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays combinators fry
+compiler.tree.propagation.info cpu.architecture kernel words math
+math.intervals math.vectors.simd.intrinsics ;
+IN: compiler.tree.propagation.simd
+
+\ (simd-v+) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-v-) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-v*) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-v/) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-vmin) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-vmax) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-vsqrt) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-sum) [
+ nip dup literal?>> [
+ literal>> scalar-rep-of {
+ { float-rep [ float ] }
+ { double-rep [ float ] }
+ } case
+ ] [ drop real ] if
+ <class-info>
+] "outputs" set-word-prop
+
+\ (simd-broadcast) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-gather-2) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-gather-4) { byte-array } "default-output-classes" set-word-prop
+
+\ assert-positive [
+ real [0,inf] <class/interval-info> value-info-intersect
+] "outputs" set-word-prop
+
+\ alien-vector { byte-array } "default-output-classes" set-word-prop
+
+! If SIMD is not available, inline alien-vector and set-alien-vector
+! to get a speedup
+: inline-unless-intrinsic ( word -- )
+ dup '[ drop _ dup "intrinsic" word-prop [ drop f ] [ def>> ] if ]
+ "custom-inlining" set-word-prop ;
+
+\ alien-vector inline-unless-intrinsic
+
+\ set-alien-vector inline-unless-intrinsic
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors kernel sequences sequences.private assocs words
-namespaces classes.algebra combinators classes classes.tuple
-classes.tuple.private continuations arrays alien.c-types
-math math.private slots generic definitions
-stack-checker.state
+USING: fry accessors kernel sequences sequences.private assocs
+words namespaces classes.algebra combinators
+combinators.short-circuit classes classes.tuple
+classes.tuple.private continuations arrays alien.c-types math
+math.private slots generic definitions stack-checker.state
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.nodes
[ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi*
with-datastack ;
+: literal-inputs? ( #call -- ? )
+ in-d>> [ value-info literal?>> ] all? ;
+
+: input-classes-match? ( #call word -- ? )
+ [ in-d>> ] [ "input-classes" word-prop ] bi*
+ [ [ value-info literal>> ] dip instance? ] 2all? ;
+
: foldable-call? ( #call word -- ? )
- "foldable" word-prop
- [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
+ {
+ [ nip "foldable" word-prop ]
+ [ drop literal-inputs? ]
+ [ input-classes-match? ]
+ } 2&& ;
: (fold-call) ( #call word -- info )
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*
! 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
] [ f ] if
] "custom-inlining" set-word-prop
+{ /i fixnum/i fixnum/i-fast bignum/i } [
+ [
+ in-d>> first2 [ value-info ] bi@ {
+ [ drop class>> integer class<= ]
+ [ drop interval>> 0 [a,a] interval>= ]
+ [ nip literal>> integer? ]
+ [ nip literal>> power-of-2? ]
+ } 2&& [ [ log2 neg shift ] ] [ f ] if
+ ] "custom-inlining" set-word-prop
+] each
+
+! 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>> {
] ;
: 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
! 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
TYPEDEF: void* CFAllocatorRef
CONSTANT: kCFAllocatorDefault f
-TYPEDEF: bool Boolean
-TYPEDEF: long CFIndex
-TYPEDEF: char UInt8
-TYPEDEF: int SInt32
-TYPEDEF: uint UInt32
+TYPEDEF: bool Boolean
+TYPEDEF: long CFIndex
+TYPEDEF: uchar UInt8
+TYPEDEF: ushort UInt16
+TYPEDEF: uint UInt32
+TYPEDEF: ulonglong UInt64
+TYPEDEF: char SInt8
+TYPEDEF: short SInt16
+TYPEDEF: int SInt32
+TYPEDEF: longlong SInt64
TYPEDEF: ulong CFTypeID
TYPEDEF: UInt32 CFOptionFlags
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
\ No newline at end of file
+DESTRUCTOR: CFRelease
+
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax core-foundation kernel assocs
-specialized-arrays.alien math sequences accessors ;
+specialized-arrays math sequences accessors ;
IN: core-foundation.dictionaries
+SPECIALIZED-ARRAY: void*
+
TYPEDEF: void* CFDictionaryRef
TYPEDEF: void* CFMutableDictionaryRef
TYPEDEF: void* CFDictionaryKeyCallBacks*
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
-specialized-arrays.direct.int specialized-arrays.direct.longlong
-core-foundation core-foundation.run-loop core-foundation.strings
+arrays specialized-arrays classes.struct core-foundation
+core-foundation.run-loop core-foundation.strings
core-foundation.time ;
IN: core-foundation.fsevents
+SPECIALIZED-ARRAY: void*
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: longlong
+
CONSTANT: kFSEventStreamCreateFlagUseCFTypes 2
CONSTANT: kFSEventStreamCreateFlagWatchRoot 4
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
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
CFStringRef mode
) ;
-: CFRunLoopDefaultMode ( -- alien )
- #! Ugly, but we don't have static NSStrings
- \ CFRunLoopDefaultMode [
- "kCFRunLoopDefaultMode" <CFString>
- ] initialize-alien ;
+CFSTRING: CFRunLoopDefaultMode "kCFRunLoopDefaultMode"
TUPLE: run-loop fds sources timers ;
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax alien.strings io.encodings.string kernel
sequences byte-arrays io.encodings.utf8 math core-foundation
-core-foundation.arrays destructors ;
+core-foundation.arrays destructors parser fry alien words ;
IN: core-foundation.strings
TYPEDEF: void* CFStringRef
: <CFStringArray> ( seq -- alien )
[ [ <CFString> &CFRelease ] map <CFArray> ] with-destructors ;
+
+SYNTAX: CFSTRING:
+ CREATE scan-object
+ [ drop ] [ '[ _ [ _ <CFString> ] initialize-alien ] ] 2bi
+ (( -- alien )) define-declared ;
! 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
: *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 ;
: 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
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.syntax kernel destructors
accessors fry words hashtables strings sequences memoize assocs math
-math.vectors math.rectangles math.functions locals init namespaces
-combinators fonts colors cache core-foundation core-foundation.strings
-core-foundation.attributed-strings core-foundation.utilities
-core-graphics core-graphics.types core-text.fonts core-text.utilities ;
+math.order math.vectors math.rectangles math.functions locals init
+namespaces combinators fonts colors cache core-foundation
+core-foundation.strings core-foundation.attributed-strings
+core-foundation.utilities core-graphics core-graphics.types
+core-text.fonts core-text.utilities ;
IN: core-text
TYPEDEF: void* CTLineRef
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 ]
- dim [ ext loc [ - >integer ] 2map ]
+ dim [ ext loc [ - >integer 1 max ] 2map ]
metrics [ open-font line compute-line-metrics ] |
line >>line
: cached-line ( font string -- line )
cached-lines get [ <line> ] 2cache ;
-[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook
\ No newline at end of file
+[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook
! Floating point registers can contain data with
! one of these representations
-SINGLETONS: single-float-rep double-float-rep ;
-
-UNION: representation any-rep tagged-rep int-rep single-float-rep double-float-rep ;
+SINGLETONS: float-rep double-rep ;
+
+! On x86, floating point registers are really vector registers
+SINGLETONS:
+float-4-rep
+double-2-rep
+char-16-rep
+uchar-16-rep
+short-8-rep
+ushort-8-rep
+int-4-rep
+uint-4-rep ;
+
+UNION: vector-rep
+float-4-rep
+double-2-rep
+char-16-rep
+uchar-16-rep
+short-8-rep
+ushort-8-rep
+int-4-rep
+uint-4-rep ;
+
+UNION: representation
+any-rep
+tagged-rep
+int-rep
+float-rep
+double-rep
+vector-rep ;
! Register classes
SINGLETONS: int-regs float-regs ;
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
-: reg-class-of ( rep -- reg-class )
- {
- { tagged-rep [ int-regs ] }
- { int-rep [ int-regs ] }
- { single-float-rep [ float-regs ] }
- { double-float-rep [ float-regs ] }
- { stack-params [ stack-params ] }
- } case ;
-
-: rep-size ( rep -- n )
- {
- { tagged-rep [ cell ] }
- { int-rep [ cell ] }
- { single-float-rep [ 4 ] }
- { double-float-rep [ 8 ] }
- { stack-params [ cell ] }
- } case ;
+GENERIC: reg-class-of ( rep -- reg-class )
+
+M: tagged-rep reg-class-of drop int-regs ;
+M: int-rep reg-class-of drop int-regs ;
+M: float-rep reg-class-of drop float-regs ;
+M: double-rep reg-class-of drop float-regs ;
+M: vector-rep reg-class-of drop float-regs ;
+M: stack-params reg-class-of drop stack-params ;
+
+GENERIC: rep-size ( rep -- n ) foldable
+
+M: tagged-rep rep-size drop cell ;
+M: int-rep rep-size drop cell ;
+M: float-rep rep-size drop 4 ;
+M: double-rep rep-size drop 8 ;
+M: stack-params rep-size drop cell ;
+M: vector-rep rep-size drop 16 ;
+
+GENERIC: scalar-rep-of ( rep -- rep' )
+
+M: float-4-rep scalar-rep-of drop float-rep ;
+M: double-2-rep scalar-rep-of drop double-rep ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
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 -- )
+HOOK: %copy cpu ( dst src rep -- )
+
HOOK: %fixnum-add cpu ( label dst src1 src2 -- )
HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
HOOK: %integer>bignum cpu ( dst src temp -- )
HOOK: %bignum>integer cpu ( dst src temp -- )
+HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %box-float cpu ( dst src temp -- )
+
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: %unary-float-function cpu ( dst src func -- )
+HOOK: %binary-float-function cpu ( dst src1 src2 func -- )
+
+HOOK: %single>double-float cpu ( dst src -- )
+HOOK: %double>single-float cpu ( dst src -- )
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
-HOOK: %copy cpu ( dst src rep -- )
-HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %box-vector cpu ( dst src temp rep -- )
+HOOK: %unbox-vector cpu ( dst src rep -- )
+
+HOOK: %broadcast-vector cpu ( dst src rep -- )
+HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- )
+HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
+
+HOOK: %add-vector cpu ( dst src1 src2 rep -- )
+HOOK: %sub-vector cpu ( dst src1 src2 rep -- )
+HOOK: %mul-vector cpu ( dst src1 src2 rep -- )
+HOOK: %div-vector cpu ( dst src1 src2 rep -- )
+HOOK: %min-vector cpu ( dst src1 src2 rep -- )
+HOOK: %max-vector cpu ( dst src1 src2 rep -- )
+HOOK: %sqrt-vector cpu ( dst src rep -- )
+HOOK: %horizontal-add-vector cpu ( dst src rep -- )
+
+HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
-HOOK: %box-float cpu ( dst src temp -- )
HOOK: %box-alien cpu ( dst src temp -- )
+HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- )
HOOK: %alien-unsigned-1 cpu ( dst src -- )
HOOK: %alien-unsigned-2 cpu ( dst src -- )
HOOK: %alien-cell cpu ( dst src -- )
HOOK: %alien-float cpu ( dst src -- )
HOOK: %alien-double cpu ( dst src -- )
+HOOK: %alien-vector cpu ( dst src rep -- )
HOOK: %set-alien-integer-1 cpu ( ptr value -- )
HOOK: %set-alien-integer-2 cpu ( ptr value -- )
HOOK: %set-alien-cell cpu ( ptr value -- )
HOOK: %set-alien-float cpu ( ptr value -- )
HOOK: %set-alien-double cpu ( ptr value -- )
+HOOK: %set-alien-vector cpu ( ptr value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %compare cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-imm cpu ( dst temp cc src1 src2 -- )
-HOOK: %compare-float cpu ( dst temp cc src1 src2 -- )
+HOOK: %compare-float-ordered cpu ( dst temp cc src1 src2 -- )
+HOOK: %compare-float-unordered cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
-HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- )
-HOOK: %spill cpu ( src n rep -- )
-HOOK: %reload cpu ( dst n rep -- )
+HOOK: %spill cpu ( src rep n -- )
+HOOK: %reload cpu ( dst rep n -- )
HOOK: %loop-entry cpu ( -- )
HOOK: %load-param-reg cpu ( stack reg rep -- )
-HOOK: %prepare-alien-invoke cpu ( -- )
+HOOK: %save-context cpu ( temp1 temp2 callback-allowed? -- )
HOOK: %prepare-var-args cpu ( -- )
USING: cpu.ppc.assembler tools.test arrays kernel namespaces
-make vocabs sequences ;
+make vocabs sequences byte-arrays.hex ;
FROM: cpu.ppc.assembler => B ;
IN: cpu.ppc.assembler.tests
: test-assembler ( expected quot -- )
[ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
-B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler
-B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler
-B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler
-B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler
-B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler
-B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler
-B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler
-B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler
-B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler
-B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler
-B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler
-B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler
-B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler
-B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler
-B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
-B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler
-B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler
-B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler
-B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler
-B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler
-B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler
-B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler
-B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler
-B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler
-B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler
-B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler
-B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler
-B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
-B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler
-B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler
-B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler
-B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
-B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler
-B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler
-B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler
-B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler
-B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler
-B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler
-B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler
-B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler
-B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler
-B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
-B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
-B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler
-B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler
-B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler
-B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler
-B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
-B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
-B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler
-B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler
-B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler
-B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler
-B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler
-B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler
-B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler
-B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler
-B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler
-B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler
-B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler
-B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler
-B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler
-B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler
+HEX{ 38 22 00 03 } [ 1 2 3 ADDI ] test-assembler
+HEX{ 3c 22 00 03 } [ 1 2 3 ADDIS ] test-assembler
+HEX{ 30 22 00 03 } [ 1 2 3 ADDIC ] test-assembler
+HEX{ 34 22 00 03 } [ 1 2 3 ADDIC. ] test-assembler
+HEX{ 38 40 00 01 } [ 1 2 LI ] test-assembler
+HEX{ 3c 40 00 01 } [ 1 2 LIS ] test-assembler
+HEX{ 38 22 ff fd } [ 1 2 3 SUBI ] test-assembler
+HEX{ 1c 22 00 03 } [ 1 2 3 MULI ] test-assembler
+HEX{ 7c 22 1a 14 } [ 1 2 3 ADD ] test-assembler
+HEX{ 7c 22 1a 15 } [ 1 2 3 ADD. ] test-assembler
+HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
+HEX{ 7c 22 1e 15 } [ 1 2 3 ADDO. ] test-assembler
+HEX{ 7c 22 18 14 } [ 1 2 3 ADDC ] test-assembler
+HEX{ 7c 22 18 15 } [ 1 2 3 ADDC. ] test-assembler
+HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
+HEX{ 7c 22 1c 15 } [ 1 2 3 ADDCO. ] test-assembler
+HEX{ 7c 22 19 14 } [ 1 2 3 ADDE ] test-assembler
+HEX{ 7c 41 18 38 } [ 1 2 3 AND ] test-assembler
+HEX{ 7c 41 18 39 } [ 1 2 3 AND. ] test-assembler
+HEX{ 7c 22 1b d6 } [ 1 2 3 DIVW ] test-assembler
+HEX{ 7c 22 1b 96 } [ 1 2 3 DIVWU ] test-assembler
+HEX{ 7c 41 1a 38 } [ 1 2 3 EQV ] test-assembler
+HEX{ 7c 41 1b b8 } [ 1 2 3 NAND ] test-assembler
+HEX{ 7c 41 18 f8 } [ 1 2 3 NOR ] test-assembler
+HEX{ 7c 41 10 f8 } [ 1 2 NOT ] test-assembler
+HEX{ 60 41 00 03 } [ 1 2 3 ORI ] test-assembler
+HEX{ 64 41 00 03 } [ 1 2 3 ORIS ] test-assembler
+HEX{ 7c 41 1b 78 } [ 1 2 3 OR ] test-assembler
+HEX{ 7c 41 13 78 } [ 1 2 MR ] test-assembler
+HEX{ 7c 22 18 96 } [ 1 2 3 MULHW ] test-assembler
+HEX{ 1c 22 00 03 } [ 1 2 3 MULLI ] test-assembler
+HEX{ 7c 22 18 16 } [ 1 2 3 MULHWU ] test-assembler
+HEX{ 7c 22 19 d6 } [ 1 2 3 MULLW ] test-assembler
+HEX{ 7c 41 18 30 } [ 1 2 3 SLW ] test-assembler
+HEX{ 7c 41 1e 30 } [ 1 2 3 SRAW ] test-assembler
+HEX{ 7c 41 1c 30 } [ 1 2 3 SRW ] test-assembler
+HEX{ 7c 41 1e 70 } [ 1 2 3 SRAWI ] test-assembler
+HEX{ 7c 22 18 50 } [ 1 2 3 SUBF ] test-assembler
+HEX{ 7c 22 18 10 } [ 1 2 3 SUBFC ] test-assembler
+HEX{ 7c 22 19 10 } [ 1 2 3 SUBFE ] test-assembler
+HEX{ 7c 41 07 74 } [ 1 2 EXTSB ] test-assembler
+HEX{ 68 41 00 03 } [ 1 2 3 XORI ] test-assembler
+HEX{ 7c 41 1a 78 } [ 1 2 3 XOR ] test-assembler
+HEX{ 7c 22 00 d0 } [ 1 2 NEG ] test-assembler
+HEX{ 2c 22 00 03 } [ 1 2 3 CMPI ] test-assembler
+HEX{ 28 22 00 03 } [ 1 2 3 CMPLI ] test-assembler
+HEX{ 7c 41 18 00 } [ 1 2 3 CMP ] test-assembler
+HEX{ 54 22 19 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
+HEX{ 54 22 18 38 } [ 1 2 3 SLWI ] test-assembler
+HEX{ 54 22 e8 fe } [ 1 2 3 SRWI ] test-assembler
+HEX{ 88 22 00 03 } [ 1 2 3 LBZ ] test-assembler
+HEX{ 8c 22 00 03 } [ 1 2 3 LBZU ] test-assembler
+HEX{ a8 22 00 03 } [ 1 2 3 LHA ] test-assembler
+HEX{ ac 22 00 03 } [ 1 2 3 LHAU ] test-assembler
+HEX{ a0 22 00 03 } [ 1 2 3 LHZ ] test-assembler
+HEX{ a4 22 00 03 } [ 1 2 3 LHZU ] test-assembler
+HEX{ 80 22 00 03 } [ 1 2 3 LWZ ] test-assembler
+HEX{ 84 22 00 03 } [ 1 2 3 LWZU ] test-assembler
+HEX{ 7c 41 18 ae } [ 1 2 3 LBZX ] test-assembler
+HEX{ 7c 41 18 ee } [ 1 2 3 LBZUX ] test-assembler
+HEX{ 7c 41 1a ae } [ 1 2 3 LHAX ] test-assembler
+HEX{ 7c 41 1a ee } [ 1 2 3 LHAUX ] test-assembler
+HEX{ 7c 41 1a 2e } [ 1 2 3 LHZX ] test-assembler
+HEX{ 7c 41 1a 6e } [ 1 2 3 LHZUX ] test-assembler
+HEX{ 7c 41 18 2e } [ 1 2 3 LWZX ] test-assembler
+HEX{ 7c 41 18 6e } [ 1 2 3 LWZUX ] test-assembler
+HEX{ 48 00 00 01 } [ 1 B ] test-assembler
+HEX{ 48 00 00 01 } [ 1 BL ] test-assembler
+HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
+HEX{ 41 81 00 04 } [ 1 BGT ] test-assembler
+HEX{ 40 81 00 04 } [ 1 BLE ] test-assembler
+HEX{ 40 80 00 04 } [ 1 BGE ] test-assembler
+HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
+HEX{ 40 82 00 04 } [ 1 BNE ] test-assembler
+HEX{ 41 82 00 04 } [ 1 BEQ ] test-assembler
+HEX{ 41 83 00 04 } [ 1 BO ] test-assembler
+HEX{ 40 83 00 04 } [ 1 BNO ] test-assembler
+HEX{ 4c 20 00 20 } [ 1 BCLR ] test-assembler
+HEX{ 4e 80 00 20 } [ BLR ] test-assembler
+HEX{ 4e 80 00 21 } [ BLRL ] test-assembler
+HEX{ 4c 20 04 20 } [ 1 BCCTR ] test-assembler
+HEX{ 4e 80 04 20 } [ BCTR ] test-assembler
+HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
+HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
+HEX{ 7c 69 02 a6 } [ 3 MFCTR ] test-assembler
+HEX{ 7c 61 03 a6 } [ 3 MTXER ] test-assembler
+HEX{ 7c 68 03 a6 } [ 3 MTLR ] test-assembler
+HEX{ 7c 69 03 a6 } [ 3 MTCTR ] test-assembler
+HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
+HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
+HEX{ c0 22 00 03 } [ 1 2 3 LFS ] test-assembler
+HEX{ c4 22 00 03 } [ 1 2 3 LFSU ] test-assembler
+HEX{ c8 22 00 03 } [ 1 2 3 LFD ] test-assembler
+HEX{ cc 22 00 03 } [ 1 2 3 LFDU ] test-assembler
+HEX{ d0 22 00 03 } [ 1 2 3 STFS ] test-assembler
+HEX{ d4 22 00 03 } [ 1 2 3 STFSU ] test-assembler
+HEX{ d8 22 00 03 } [ 1 2 3 STFD ] test-assembler
+HEX{ dc 22 00 03 } [ 1 2 3 STFDU ] test-assembler
+HEX{ fc 20 10 90 } [ 1 2 FMR ] test-assembler
+HEX{ fc 40 08 90 } [ 2 1 FMR ] test-assembler
+HEX{ fc 20 10 91 } [ 1 2 FMR. ] test-assembler
+HEX{ fc 40 08 91 } [ 2 1 FMR. ] test-assembler
+HEX{ fc 20 10 1e } [ 1 2 FCTIWZ ] test-assembler
+HEX{ fc 22 18 2a } [ 1 2 3 FADD ] test-assembler
+HEX{ fc 22 18 2b } [ 1 2 3 FADD. ] test-assembler
+HEX{ fc 22 18 28 } [ 1 2 3 FSUB ] test-assembler
+HEX{ fc 22 00 f2 } [ 1 2 3 FMUL ] test-assembler
+HEX{ fc 22 18 24 } [ 1 2 3 FDIV ] test-assembler
+HEX{ fc 20 10 2c } [ 1 2 FSQRT ] test-assembler
+HEX{ fc 41 18 00 } [ 1 2 3 FCMPU ] test-assembler
+HEX{ fc 41 18 40 } [ 1 2 3 FCMPO ] test-assembler
+HEX{ 3c 60 12 34 60 63 56 78 } [ HEX: 12345678 3 LOAD ] test-assembler
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces words io.binary math math.order
+USING: kernel namespaces words math math.order locals
cpu.ppc.assembler.backend ;
IN: cpu.ppc.assembler
X: XOR. 1 316 31
X1: EXTSB 0 954 31
X1: EXTSB. 1 954 31
-: FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ;
-: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ;
+: FMR ( a s -- ) [ 0 ] 2dip 0 72 63 x-insn ;
+: FMR. ( a s -- ) [ 0 ] 2dip 1 72 63 x-insn ;
: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
MTSPR: CTR 9
! Pseudo-instructions
-: LI ( value dst -- ) 0 rot ADDI ; inline
+: LI ( value dst -- ) swap [ 0 ] dip ADDI ; inline
: SUBI ( dst src1 src2 -- ) neg ADDI ; inline
-: LIS ( value dst -- ) 0 rot ADDIS ; inline
+: LIS ( value dst -- ) swap [ 0 ] dip ADDIS ; inline
: SUBIC ( dst src1 src2 -- ) neg ADDIC ; inline
: SUBIC. ( dst src1 src2 -- ) neg ADDIC. ; inline
: NOT ( dst src -- ) dup NOR ; inline
: (SRWI) ( d a b -- d a b x y ) 32 over - swap 31 ; inline
: SRWI ( d a b -- ) (SRWI) RLWINM ;
: SRWI. ( d a b -- ) (SRWI) RLWINM. ;
-: LOAD32 ( n r -- ) [ w>h/h ] dip tuck LIS dup rot ORI ;
+:: LOAD32 ( n r -- )
+ n -16 shift HEX: ffff bitand r LIS
+ r r n HEX: ffff bitand ORI ;
: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
+
+! Altivec/VMX instructions
+VA: VMHADDSHS 32 4
+VA: VMHRADDSHS 33 4
+VA: VMLADDUHM 34 4
+VA: VMSUMUBM 36 4
+VA: VMSUMMBM 37 4
+VA: VMSUMUHM 38 4
+VA: VMSUMUHS 39 4
+VA: VMSUMSHM 40 4
+VA: VMSUMSHS 41 4
+VA: VSEL 42 4
+VA: VPERM 43 4
+VA: VSLDOI 44 4
+VA: VMADDFP 46 4
+VA: VNMSUBFP 47 4
+
+VX: VADDUBM 0 4
+VX: VADDUHM 64 4
+VX: VADDUWM 128 4
+VX: VADDCUW 384 4
+VX: VADDUBS 512 4
+VX: VADDUHS 576 4
+VX: VADDUWS 640 4
+VX: VADDSBS 768 4
+VX: VADDSHS 832 4
+VX: VADDSWS 896 4
+
+VX: VSUBUBM 1024 4
+VX: VSUBUHM 1088 4
+VX: VSUBUWM 1152 4
+VX: VSUBCUW 1408 4
+VX: VSUBUBS 1536 4
+VX: VSUBUHS 1600 4
+VX: VSUBUWS 1664 4
+VX: VSUBSBS 1792 4
+VX: VSUBSHS 1856 4
+VX: VSUBSWS 1920 4
+
+VX: VMAXUB 2 4
+VX: VMAXUH 66 4
+VX: VMAXUW 130 4
+VX: VMAXSB 258 4
+VX: VMAXSH 322 4
+VX: VMAXSW 386 4
+
+VX: VMINUB 514 4
+VX: VMINUH 578 4
+VX: VMINUW 642 4
+VX: VMINSB 770 4
+VX: VMINSH 834 4
+VX: VMINSW 898 4
+
+VX: VAVGUB 1026 4
+VX: VAVGUH 1090 4
+VX: VAVGUW 1154 4
+VX: VAVGSB 1282 4
+VX: VAVGSH 1346 4
+VX: VAVGSW 1410 4
+
+VX: VRLB 4 4
+VX: VRLH 68 4
+VX: VRLW 132 4
+VX: VSLB 260 4
+VX: VSLH 324 4
+VX: VSLW 388 4
+VX: VSL 452 4
+VX: VSRB 516 4
+VX: VSRH 580 4
+VX: VSRW 644 4
+VX: VSR 708 4
+VX: VSRAB 772 4
+VX: VSRAH 836 4
+VX: VSRAW 900 4
+
+VX: VAND 1028 4
+VX: VANDC 1092 4
+VX: VOR 1156 4
+VX: VNOR 1284 4
+VX: VXOR 1220 4
+
+VXD: MFVSCR 1540 4
+VXB: MTVSCR 1604 4
+
+VX: VMULOUB 8 4
+VX: VMULOUH 72 4
+VX: VMULOSB 264 4
+VX: VMULOSH 328 4
+VX: VMULEUB 520 4
+VX: VMULEUH 584 4
+VX: VMULESB 776 4
+VX: VMULESH 840 4
+VX: VSUM4UBS 1544 4
+VX: VSUM4SBS 1800 4
+VX: VSUM4SHS 1608 4
+VX: VSUM2SWS 1672 4
+VX: VSUMSWS 1928 4
+
+VX: VADDFP 10 4
+VX: VSUBFP 74 4
+
+VXDB: VREFP 266 4
+VXDB: VRSQRTEFP 330 4
+VXDB: VEXPTEFP 394 4
+VXDB: VLOGEFP 458 4
+VXDB: VRFIN 522 4
+VXDB: VRFIZ 586 4
+VXDB: VRFIP 650 4
+VXDB: VRFIM 714 4
+
+VX: VCFUX 778 4
+VX: VCFSX 842 4
+VX: VCTUXS 906 4
+VX: VCTSXS 970 4
+
+VX: VMAXFP 1034 4
+VX: VMINFP 1098 4
+
+VX: VMRGHB 12 4
+VX: VMRGHH 76 4
+VX: VMRGHW 140 4
+VX: VMRGLB 268 4
+VX: VMRGLH 332 4
+VX: VMRGLW 396 4
+
+VX: VSPLTB 524 4
+VX: VSPLTH 588 4
+VX: VSPLTW 652 4
+
+VXA: VSPLTISB 780 4
+VXA: VSPLTISH 844 4
+VXA: VSPLTISW 908 4
+
+VX: VSLO 1036 4
+VX: VSRO 1100 4
+
+VX: VPKUHUM 14 4
+VX: VPKUWUM 78 4
+VX: VPKUHUS 142 4
+VX: VPKUWUS 206 4
+VX: VPKSHUS 270 4
+VX: VPKSWUS 334 4
+VX: VPKSHSS 398 4
+VX: VPKSWSS 462 4
+VX: VPKPX 782 4
+
+VXDB: VUPKHSB 526 4
+VXDB: VUPKHSH 590 4
+VXDB: VUPKLSB 654 4
+VXDB: VUPKLSH 718 4
+VXDB: VUPKHPX 846 4
+VXDB: VUPKLPX 974 4
+
+: -T ( strm a b -- strm-t a b ) [ 16 bitor ] 2dip ;
+
+XD: DST 0 342 31
+: DSTT ( strm a b -- ) -T DST ;
+
+XD: DSTST 0 374 31
+: DSTSTT ( strm a b -- ) -T DSTST ;
+
+XD: (DSS) 0 822 31
+: DSS ( strm -- ) 0 0 (DSS) ;
+: DSSALL ( -- ) 16 0 0 (DSS) ;
+
+XD: LVEBX 0 7 31
+XD: LVEHX 0 39 31
+XD: LVEWX 0 71 31
+XD: LVSL 0 6 31
+XD: LVSR 0 38 31
+XD: LVX 0 103 31
+XD: LVXL 0 359 31
+
+XD: STVEBX 0 135 31
+XD: STVEHX 0 167 31
+XD: STVEWX 0 199 31
+XD: STVX 0 231 31
+XD: STVXL 0 487 31
+
+VXR: VCMPBFP 0 966 4
+VXR: VCMPEQFP 0 198 4
+VXR: VCMPEQUB 0 6 4
+VXR: VCMPEQUH 0 70 4
+VXR: VCMPEQUW 0 134 4
+VXR: VCMPGEFP 0 454 4
+VXR: VCMPGTFP 0 710 4
+VXR: VCMPGTSB 0 774 4
+VXR: VCMPGTSH 0 838 4
+VXR: VCMPGTSW 0 902 4
+VXR: VCMPGTUB 0 518 4
+VXR: VCMPGTUH 0 582 4
+VXR: VCMPGTUW 0 646 4
+
+VXR: VCMPBFP. 1 966 4
+VXR: VCMPEQFP. 1 198 4
+VXR: VCMPEQUB. 1 6 4
+VXR: VCMPEQUH. 1 70 4
+VXR: VCMPEQUW. 1 134 4
+VXR: VCMPGEFP. 1 454 4
+VXR: VCMPGTFP. 1 710 4
+VXR: VCMPGTSB. 1 774 4
+VXR: VCMPGTSH. 1 838 4
+VXR: VCMPGTSW. 1 902 4
+VXR: VCMPGTUB. 1 518 4
+VXR: VCMPGTUH. 1 582 4
+VXR: VCMPGTUW. 1 646 4
+
: x-insn ( a s b rc xo opcode -- )
[ { 1 0 11 21 16 } bitfield ] dip insn ;
+: xd-insn ( d a b rc xo opcode -- )
+ [ { 1 0 11 16 21 } bitfield ] dip insn ;
+
: (X) ( -- word quot )
CREATE scan-word scan-word scan-word [ x-insn ] 3curry ;
-SYNTAX: X: (X) (( a s b -- )) define-declared ;
+: (XD) ( -- word quot )
+ CREATE scan-word scan-word scan-word [ xd-insn ] 3curry ;
+
+SYNTAX: X: (X) (( a s b -- )) define-declared ;
+SYNTAX: XD: (XD) (( d a b -- )) define-declared ;
: (1) ( quot -- quot' ) [ 0 ] prepose ;
CREATE scan-word scan-word scan-word scan-word
[ xo-insn ] 2curry 2curry ;
-SYNTAX: XO: (XO) (( a s b -- )) define-declared ;
+SYNTAX: XO: (XO) (( d a b -- )) define-declared ;
-SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
+SYNTAX: XO1: (XO) (1) (( d a -- )) define-declared ;
GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) 18 i-insn ;
SYNTAX: B:
CREATE-B scan-word scan-word scan-word scan-word scan-word
'[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
+
+: va-insn ( d a b c xo opcode -- )
+ [ { 0 6 11 16 21 } bitfield ] dip insn ;
+
+: (VA) ( -- word quot )
+ CREATE scan-word scan-word [ va-insn ] 2curry ;
+
+SYNTAX: VA: (VA) (( d a b c -- )) define-declared ;
+
+: vx-insn ( d a b xo opcode -- )
+ [ { 0 11 16 21 } bitfield ] dip insn ;
+
+: (VX) ( -- word quot )
+ CREATE scan-word scan-word [ vx-insn ] 2curry ;
+: (VXD) ( -- word quot )
+ CREATE scan-word scan-word '[ 0 0 _ _ vx-insn ] ;
+: (VXA) ( -- word quot )
+ CREATE scan-word scan-word '[ [ 0 ] dip 0 _ _ vx-insn ] ;
+: (VXB) ( -- word quot )
+ CREATE scan-word scan-word '[ [ 0 0 ] dip _ _ vx-insn ] ;
+: (VXDB) ( -- word quot )
+ CREATE scan-word scan-word '[ [ 0 ] dip _ _ vx-insn ] ;
+
+SYNTAX: VX: (VX) (( d a b -- )) define-declared ;
+SYNTAX: VXD: (VXD) (( d -- )) define-declared ;
+SYNTAX: VXA: (VXA) (( a -- )) define-declared ;
+SYNTAX: VXB: (VXB) (( b -- )) define-declared ;
+SYNTAX: VXDB: (VXDB) (( d b -- )) define-declared ;
+
+: vxr-insn ( d a b rc xo opcode -- )
+ [ { 0 10 11 16 21 } bitfield ] dip insn ;
+
+: (VXR) ( -- word quot )
+ CREATE scan-word scan-word scan-word [ vxr-insn ] 3curry ;
+
+SYNTAX: VXR: (VXR) (( d a b -- )) define-declared ;
+
M: ppc %peek loc>operand LWZ ;
M: ppc %replace loc>operand STW ;
-: (%inc) ( n reg -- ) dup rot cells ADDI ; inline
+:: (%inc) ( n reg -- ) reg reg n cells ADDI ; inline
M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
M: ppc %copy ( dst src rep -- )
{
{ int-rep [ MR ] }
- { double-float-rep [ FMR ] }
+ { double-rep [ FMR ] }
} case ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
dst 16 float temp %allot
src dst float-offset STFD ;
+: float-function-param ( i spill-slot -- )
+ [ float-regs param-regs nth 1 ] [ n>> spill@ ] bi* LFD ;
+
+: float-function-return ( reg -- )
+ float-regs return-reg 2dup = [ 2drop ] [ FMR ] if ;
+
+M:: ppc %unary-float-function ( dst src func -- )
+ 0 src float-function-param
+ func f %alien-invoke
+ dst float-function-return ;
+
+M:: ppc %binary-float-function ( dst src1 src2 func -- )
+ 0 src1 float-function-param
+ 1 src2 float-function-param
+ func f %alien-invoke
+ dst float-function-return ;
+
+! Internal format is always double-precision on PowerPC
+M: ppc %single>double-float FMR ;
+
+M: ppc %double>single-float FMR ;
+
+M: ppc %unbox-alien ( dst src -- )
+ alien-offset LWZ ;
+
M:: ppc %unbox-any-c-ptr ( dst src temp -- )
[
{ "is-byte-array" "end" "start" } [ define-label ] each
: alien@ ( n -- n' ) cells object tag-number - ;
+:: %allot-alien ( dst displacement base temp -- )
+ dst 4 cells alien temp %allot
+ temp \ f tag-number %load-immediate
+ ! Store underlying-alien slot
+ base dst 1 alien@ STW
+ ! Store expired slot
+ temp dst 2 alien@ STW
+ ! Store offset
+ displacement dst 3 alien@ STW ;
+
M:: ppc %box-alien ( dst src temp -- )
[
"f" define-label
dst \ f tag-number %load-immediate
0 src 0 CMPI
"f" get BEQ
+ dst src temp temp %allot-alien
+ "f" resolve-label
+ ] with-scope ;
+
+M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
+ [
+ "end" define-label
+ "alloc" define-label
+ "simple-case" define-label
+ ! If displacement is zero, return the base
+ dst base MR
+ 0 displacement 0 CMPI
+ "end" get BEQ
+ ! Quickly use displacement' before its needed for real, as allot temporary
+ displacement' :> temp
dst 4 cells alien temp %allot
+ ! If base is already a displaced alien, unpack it
+ 0 base \ f tag-number CMPI
+ "simple-case" get BEQ
+ temp base header-offset LWZ
+ 0 temp alien type-number tag-fixnum CMPI
+ "simple-case" get BNE
+ ! displacement += base.displacement
+ temp base 3 alien@ LWZ
+ displacement' displacement temp ADD
+ ! base = base.base
+ base' base 1 alien@ LWZ
+ "alloc" get B
+ "simple-case" resolve-label
+ displacement' displacement MR
+ base' base MR
+ "alloc" resolve-label
+ ! Store underlying-alien slot
+ base' dst 1 alien@ STW
! Store offset
- src dst 3 alien@ STW
- ! Store expired slot
+ displacement' dst 3 alien@ STW
+ ! Store expired slot (its ok to clobber displacement')
temp \ f tag-number %load-immediate
- temp dst 1 alien@ STW
- ! Store underlying-alien slot
temp dst 2 alien@ STW
- "f" resolve-label
+ "end" resolve-label
] with-scope ;
M: ppc %alien-unsigned-1 0 LBZ ;
register 1 gc-root gc-root@ LWZ ;
M:: ppc %call-gc ( gc-root-count -- )
- %prepare-alien-invoke
3 1 gc-root-base local@ ADDI
gc-root-count 4 LI
"inline_gc" f %alien-invoke ;
[ [ 1 1 ] dip ADDI ] bi
0 MTLR ;
-:: (%boolean) ( dst temp word -- )
+:: (%boolean) ( dst temp branch1 branch2 -- )
"end" define-label
dst \ f tag-number %load-immediate
- "end" get word execute
+ "end" get branch1 execute( label -- )
+ branch2 [ "end" get branch2 execute( label -- ) ] when
dst \ t %load-reference
"end" get resolve-label ; inline
-: %boolean ( dst temp cc -- )
- negate-cc {
- { cc< [ \ BLT (%boolean) ] }
- { cc<= [ \ BLE (%boolean) ] }
- { cc> [ \ BGT (%boolean) ] }
- { cc>= [ \ BGE (%boolean) ] }
- { cc= [ \ BEQ (%boolean) ] }
- { cc/= [ \ BNE (%boolean) ] }
+:: %boolean ( dst cc temp -- )
+ cc negate-cc order-cc {
+ { cc< [ dst temp \ BLT f (%boolean) ] }
+ { cc<= [ dst temp \ BLE f (%boolean) ] }
+ { cc> [ dst temp \ BGT f (%boolean) ] }
+ { cc>= [ dst temp \ BGE f (%boolean) ] }
+ { cc= [ dst temp \ BEQ f (%boolean) ] }
+ { cc/= [ dst temp \ BNE f (%boolean) ] }
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
: (%compare-imm) ( src1 src2 -- ) [ 0 ] 2dip CMPI ; inline
-: (%compare-float) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
+: (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
+: (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
+
+:: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
+ cc {
+ { cc< [ src1 src2 \ compare execute( a b -- ) \ BLT f ] }
+ { cc<= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
+ { cc> [ src1 src2 \ compare execute( a b -- ) \ BGT f ] }
+ { cc>= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
+ { cc= [ src1 src2 \ compare execute( a b -- ) \ BEQ f ] }
+ { cc<> [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
+ { cc<>= [ src1 src2 \ compare execute( a b -- ) \ BNO f ] }
+ { cc/< [ src1 src2 \ compare execute( a b -- ) \ BGE f ] }
+ { cc/<= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BO ] }
+ { cc/> [ src1 src2 \ compare execute( a b -- ) \ BLE f ] }
+ { cc/>= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BO ] }
+ { cc/= [ src1 src2 \ compare execute( a b -- ) \ BNE f ] }
+ { cc/<> [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BO ] }
+ { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BO f ] }
+ } case ; inline
+
+M: ppc %compare [ (%compare) ] 2dip %boolean ;
+
+M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
+
+M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
+ src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> branch2 :> branch1
+ dst temp branch1 branch2 (%boolean) ;
+
+M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
+ src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> branch2 :> branch1
+ dst temp branch1 branch2 (%boolean) ;
+
+:: %branch ( label cc -- )
+ cc order-cc {
+ { cc< [ label BLT ] }
+ { cc<= [ label BLE ] }
+ { cc> [ label BGT ] }
+ { cc>= [ label BGE ] }
+ { cc= [ label BEQ ] }
+ { cc/= [ label BNE ] }
+ } case ;
-M: ppc %compare (%compare) %boolean ;
-M: ppc %compare-imm (%compare-imm) %boolean ;
-M: ppc %compare-float (%compare-float) %boolean ;
+M:: ppc %compare-branch ( label src1 src2 cc -- )
+ src1 src2 (%compare)
+ label cc %branch ;
-: %branch ( label cc -- )
- {
- { cc< [ BLT ] }
- { cc<= [ BLE ] }
- { cc> [ BGT ] }
- { cc>= [ BGE ] }
- { cc= [ BEQ ] }
- { cc/= [ BNE ] }
- } case ;
+M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
+ src1 src2 (%compare-imm)
+ label cc %branch ;
-M: ppc %compare-branch (%compare) %branch ;
-M: ppc %compare-imm-branch (%compare-imm) %branch ;
-M: ppc %compare-float-branch (%compare-float) %branch ;
+:: (%branch) ( label branch1 branch2 -- )
+ label branch1 execute( label -- )
+ branch2 [ label branch2 execute( label -- ) ] when ; inline
+
+M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
+ src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> branch2 :> branch1
+ label branch1 branch2 (%branch) ;
+
+M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
+ src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> branch2 :> branch1
+ label branch1 branch2 (%branch) ;
: load-from-frame ( dst n rep -- )
{
{ int-rep [ [ 1 ] dip LWZ ] }
- { single-float-rep [ [ 1 ] dip LFS ] }
- { double-float-rep [ [ 1 ] dip LFD ] }
+ { float-rep [ [ 1 ] dip LFS ] }
+ { double-rep [ [ 1 ] dip LFD ] }
{ stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
} case ;
: store-to-frame ( src n rep -- )
{
{ int-rep [ [ 1 ] dip STW ] }
- { single-float-rep [ [ 1 ] dip STFS ] }
- { double-float-rep [ [ 1 ] dip STFD ] }
+ { float-rep [ [ 1 ] dip STFS ] }
+ { double-rep [ [ 1 ] dip STFD ] }
{ stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] }
} case ;
-M: ppc %spill ( src n rep -- )
- [ spill@ ] dip store-to-frame ;
+M: ppc %spill ( src rep n -- )
+ swap [ spill@ ] dip store-to-frame ;
-M: ppc %reload ( dst n rep -- )
- [ spill@ ] dip load-from-frame ;
+M: ppc %reload ( dst rep n -- )
+ swap [ spill@ ] dip load-from-frame ;
M: ppc %loop-entry ;
! Call the function
"box_value_struct" f %alien-invoke ;
-M: ppc %prepare-alien-invoke
+M:: ppc %save-context ( temp1 temp2 callback-allowed? -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- scratch-reg "stack_chain" f %alien-global
- scratch-reg scratch-reg 0 LWZ
- 1 scratch-reg 0 STW
- ds-reg scratch-reg 8 STW
- rs-reg scratch-reg 12 STW ;
+ temp1 "stack_chain" f %alien-global
+ temp1 temp1 0 LWZ
+ 1 temp1 0 STW
+ callback-allowed? [
+ ds-reg temp1 8 STW
+ rs-reg temp1 12 STW
+ ] when ;
M: ppc %alien-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
{ 4 [ %unbox-struct-4 ] }
} case ;
+enable-float-functions
+
USE: vocabs.loader
{
M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
M: int-rep store-return-reg drop stack@ EAX MOV ;
-M: single-float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
-M: single-float-rep load-return-reg drop next-stack@ FLDS ;
-M: single-float-rep store-return-reg drop stack@ FSTPS ;
+M: float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
+M: float-rep load-return-reg drop next-stack@ FLDS ;
+M: float-rep store-return-reg drop stack@ FSTPS ;
-M: double-float-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
-M: double-float-rep load-return-reg drop next-stack@ FLDL ;
-M: double-float-rep store-return-reg drop stack@ FSTPL ;
+M: double-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
+M: double-rep load-return-reg drop next-stack@ FLDL ;
+M: double-rep store-return-reg drop stack@ FSTPL ;
: align-sub ( n -- )
[ align-stack ] keep - decr-stack-reg ;
{ 2 [ %unbox-struct-2 ] }
} case ;
-M: x86.32 %unbox-large-struct ( n c-type -- )
+M:: x86.32 %unbox-large-struct ( n c-type -- )
! Alien must be in EAX.
! Compute destination address
- ECX rot stack@ LEA
+ ECX n stack@ LEA
12 [
! Push struct size
- heap-size PUSH
+ c-type heap-size PUSH
! Push destination address
ECX PUSH
! Push source address
4 "double" c-type (>>align)
] unless
-USING: cpu.x86.features cpu.x86.features.private ;
-
-"-no-sse2" (command-line) member? [
- [ { check_sse2 } compile ] with-optimizer
-
- "Checking if your CPU supports SSE2..." print flush
- sse2? [
- " - yes" print
- enable-float-intrinsics
- [
- sse2? [
- "This image was built to use SSE2, which your CPU does not support." print
- "You will need to bootstrap Factor again." print
- flush
- 1 exit
- ] unless
- ] "cpu.x86" add-init-hook
- ] [ " - no" print ] if
-] unless
+"cpu.x86.features" require
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences system
-layouts alien alien.c-types alien.accessors alien.structs slots
+layouts alien alien.c-types alien.accessors slots
splitting assocs combinators locals compiler.constants
compiler.codegen compiler.codegen.fixup compiler.cfg.instructions
compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame
flatten-value-type [ %unbox-struct-field ] each-index
] with-return-regs ;
-M: x86.64 %unbox-large-struct ( n c-type -- )
+M:: x86.64 %unbox-large-struct ( n c-type -- )
! Source is in param-reg-1
- heap-size
- ! Load destination address
- param-reg-2 rot param@ LEA
- ! Load structure size
- param-reg-3 swap MOV
+ ! Load destination address into param-reg-2
+ param-reg-2 n param@ LEA
+ ! Load structure size into param-reg-3
+ param-reg-3 c-type heap-size MOV
! Copy the struct to the C stack
"to_value_struct" f %alien-invoke ;
! Unbox former top of data stack to return registers
unbox-return ;
+: float-function-param ( i spill-slot -- )
+ [ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ;
+
+: float-function-return ( reg -- )
+ float-regs return-reg double-rep copy-register ;
+
+M:: x86.64 %unary-float-function ( dst src func -- )
+ 0 src float-function-param
+ func f %alien-invoke
+ dst float-function-return ;
+
+M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
+ 0 src1 float-function-param
+ 1 src2 float-function-param
+ func f %alien-invoke
+ dst float-function-return ;
+
! The result of reading 4 bytes from memory is a fixnum on
! x86-64.
enable-alien-4-intrinsics
-! SSE2 is always available on x86-64.
-enable-float-intrinsics
+! Enable fast calling of libc math functions
+enable-float-functions
USE: vocabs.loader
{ [ os unix? ] [ "cpu.x86.64.unix" require ] }
{ [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
} cond
+
+"cpu.x86.features" require
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences math splitting make assocs kernel
-layouts system alien.c-types alien.structs cpu.architecture
+layouts system alien.c-types cpu.architecture
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen
compiler.cfg.registers ;
+QUALIFIED: alien.structs
+QUALIFIED: classes.struct
IN: cpu.x86.64.unix
M: int-regs param-regs
heap-size cell align
cell /i "__stack_value" c-type <repetition> ;
-M: struct-type flatten-value-type ( type -- seq )
+: flatten-struct ( c-type -- seq )
dup heap-size 16 > [
flatten-large-struct
] [
flatten-small-struct
] if ;
+M: alien.structs:struct-type flatten-value-type ( type -- seq )
+ flatten-struct ;
+M: classes.struct:struct-c-type flatten-value-type ( type -- seq )
+ flatten-struct ;
+
M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size 2 cells <= ;
: MOVHPD ( dest src -- ) HEX: 16 HEX: 66 2-operand-sse ;
: MOVSHDUP ( dest src -- ) HEX: 16 HEX: f3 2-operand-rm-sse ;
+ALIAS: MOVHLPS MOVLPS
+ALIAS: MOVLHPS MOVHPS
+
: PREFETCHNTA ( mem -- ) { BIN: 000 f { HEX: 0f HEX: 18 } } 1-operand ;
: PREFETCHT0 ( mem -- ) { BIN: 001 f { HEX: 0f HEX: 18 } } 1-operand ;
: PREFETCHT1 ( mem -- ) { BIN: 010 f { HEX: 0f HEX: 18 } } 1-operand ;
-USING: cpu.x86.features tools.test kernel sequences math system ;
+USING: cpu.x86.features tools.test kernel sequences math math.order system ;
IN: cpu.x86.features.tests
cpu x86? [
- [ t ] [ sse2? { t f } member? ] unit-test
+ [ t ] [ sse-version 0 42 between? ] unit-test
[ t ] [ [ 10000 [ ] times ] count-instructions integer? ] unit-test
] when
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel math alien.syntax ;
+USING: system kernel math math.order math.parser namespaces
+alien.syntax combinators locals init io cpu.x86 compiler
+compiler.units accessors ;
IN: cpu.x86.features
<PRIVATE
-FUNCTION: bool check_sse2 ( ) ;
+FUNCTION: int sse_version ( ) ;
FUNCTION: longlong read_timestamp_counter ( ) ;
PRIVATE>
-HOOK: sse2? cpu ( -- ? )
+ALIAS: sse-version sse_version
-M: x86.32 sse2? check_sse2 ;
-
-M: x86.64 sse2? t ;
+: sse-string ( version -- string )
+ {
+ { 00 [ "no SSE" ] }
+ { 10 [ "SSE1" ] }
+ { 20 [ "SSE2" ] }
+ { 30 [ "SSE3" ] }
+ { 33 [ "SSSE3" ] }
+ { 41 [ "SSE4.1" ] }
+ { 42 [ "SSE4.2" ] }
+ } case ;
HOOK: instruction-count cpu ( -- n )
: count-instructions ( quot -- n )
instruction-count [ call ] dip instruction-count swap - ; inline
+
+USING: cpu.x86.features cpu.x86.features.private ;
+
+:: install-sse-check ( version -- )
+ [
+ sse-version version < [
+ "This image was built to use " write
+ version sse-string write
+ " but your CPU only supports " write
+ sse-version sse-string write "." print
+ "You will need to bootstrap Factor again." print
+ flush
+ 1 exit
+ ] when
+ ] "cpu.x86" add-init-hook ;
+
+: enable-sse ( version -- )
+ {
+ { 00 [ ] }
+ { 10 [ ] }
+ { 20 [ enable-sse2 ] }
+ { 30 [ enable-sse3 ] }
+ { 33 [ enable-sse3 ] }
+ { 41 [ enable-sse3 ] }
+ { 42 [ enable-sse3 ] }
+ } case ;
+
+[ { sse_version } compile ] with-optimizer
+
+"Checking for multimedia extensions: " write sse-version
+"sse-version" get [ string>number min ] when*
+[ sse-string write " detected" print ]
+[ install-sse-check ]
+[ enable-sse ] tri
--- /dev/null
+unportable
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
cpu.architecture kernel kernel.private math memory namespaces make
sequences words system layouts combinators math.order fry locals
-compiler.constants
+compiler.constants byte-arrays
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
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 ;
+GENERIC: copy-register* ( dst src rep -- )
+
+M: int-rep copy-register* drop MOV ;
+M: tagged-rep copy-register* drop MOV ;
+M: float-rep copy-register* drop MOVSS ;
+M: double-rep copy-register* drop MOVSD ;
+M: float-4-rep copy-register* drop MOVUPS ;
+M: double-2-rep copy-register* drop MOVUPD ;
+M: vector-rep copy-register* drop MOVDQU ;
+
+: copy-register ( dst src rep -- )
+ 2over eq? [ 3drop ] [ copy-register* ] if ;
+
+M: x86 %copy ( dst src rep -- ) copy-register ;
+
:: overflow-template ( label dst src1 src2 insn -- )
src1 src2 insn call
label JO ; inline
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 %single>double-float CVTSS2SD ;
+M: x86 %double>single-float CVTSD2SS ;
M: x86 %integer>float CVTSI2SD ;
M: x86 %float>integer CVTTSD2SI ;
-GENERIC: copy-register* ( dst src rep -- )
+M: x86 %unbox-float ( dst src -- )
+ float-offset [+] MOVSD ;
-M: int-rep copy-register* drop MOV ;
-M: tagged-rep copy-register* drop MOV ;
-M: single-float-rep copy-register* drop MOVSS ;
-M: double-float-rep copy-register* drop MOVSD ;
+M:: x86 %box-float ( dst src temp -- )
+ dst 16 float temp %allot
+ dst float-offset [+] src MOVSD ;
-: copy-register ( dst src rep -- )
- 2over eq? [ 3drop ] [ copy-register* ] if ;
+M:: x86 %box-vector ( dst src rep temp -- )
+ dst rep rep-size 2 cells + byte-array temp %allot
+ 16 tag-fixnum dst 1 byte-array tag-number %set-slot-imm
+ dst byte-array-offset [+]
+ src rep copy-register ;
-M: x86 %copy ( dst src rep -- ) copy-register ;
+M:: x86 %unbox-vector ( dst src rep -- )
+ dst src byte-array-offset [+]
+ rep copy-register ;
-M: x86 %unbox-float ( dst src -- )
- float-offset [+] MOVSD ;
+M: x86 %broadcast-vector ( dst src rep -- )
+ {
+ { float-4-rep [ [ MOVSS ] [ drop dup 0 SHUFPS ] 2bi ] }
+ { double-2-rep [ [ MOVSD ] [ drop dup UNPCKLPD ] 2bi ] }
+ } case ;
+
+M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
+ rep {
+ {
+ float-4-rep
+ [
+ dst src1 MOVSS
+ dst src2 UNPCKLPS
+ src3 src4 UNPCKLPS
+ dst src3 MOVLHPS
+ ]
+ }
+ } case ;
+
+M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
+ rep {
+ {
+ double-2-rep
+ [
+ dst src1 MOVSD
+ dst src2 UNPCKLPD
+ ]
+ }
+ } case ;
+
+M: x86 %add-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ ADDPS ] }
+ { double-2-rep [ ADDPD ] }
+ { char-16-rep [ PADDB ] }
+ { uchar-16-rep [ PADDB ] }
+ { short-8-rep [ PADDW ] }
+ { ushort-8-rep [ PADDW ] }
+ { int-4-rep [ PADDD ] }
+ { uint-4-rep [ PADDD ] }
+ } case drop ;
+
+M: x86 %sub-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ SUBPS ] }
+ { double-2-rep [ SUBPD ] }
+ { char-16-rep [ PSUBB ] }
+ { uchar-16-rep [ PSUBB ] }
+ { short-8-rep [ PSUBW ] }
+ { ushort-8-rep [ PSUBW ] }
+ { int-4-rep [ PSUBD ] }
+ { uint-4-rep [ PSUBD ] }
+ } case drop ;
+
+M: x86 %mul-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ MULPS ] }
+ { double-2-rep [ MULPD ] }
+ { int-4-rep [ PMULLW ] }
+ } case drop ;
+
+M: x86 %div-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ DIVPS ] }
+ { double-2-rep [ DIVPD ] }
+ } case drop ;
+
+M: x86 %min-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ MINPS ] }
+ { double-2-rep [ MINPD ] }
+ } case drop ;
+
+M: x86 %max-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ MAXPS ] }
+ { double-2-rep [ MAXPD ] }
+ } case drop ;
+
+M: x86 %sqrt-vector ( dst src rep -- )
+ {
+ { float-4-rep [ SQRTPS ] }
+ { double-2-rep [ SQRTPD ] }
+ } case ;
+
+M: x86 %horizontal-add-vector ( dst src rep -- )
+ {
+ { float-4-rep [ [ MOVAPS ] [ HADDPS ] [ HADDPS ] 2tri ] }
+ { double-2-rep [ [ MOVAPD ] [ HADDPD ] 2bi ] }
+ } case ;
+
+M: x86 %unbox-alien ( dst src -- )
+ alien-offset [+] MOV ;
M:: x86 %unbox-any-c-ptr ( dst src temp -- )
[
"end" resolve-label
] with-scope ;
-M:: x86 %box-float ( dst src temp -- )
- dst 16 float temp %allot
- dst float-offset [+] src MOVSD ;
-
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
+:: %allot-alien ( dst displacement base temp -- )
+ dst 4 cells alien temp %allot
+ dst 1 alien@ base MOV ! alien
+ dst 2 alien@ \ f tag-number MOV ! expired
+ dst 3 alien@ displacement MOV ! displacement
+ ;
+
M:: x86 %box-alien ( dst src temp -- )
[
"end" define-label
dst \ f tag-number MOV
src 0 CMP
"end" get JE
- dst 4 cells alien temp %allot
- dst 1 alien@ \ f tag-number MOV
- dst 2 alien@ \ f tag-number MOV
- ! Store src in alien-offset slot
- dst 3 alien@ src MOV
+ dst src \ f tag-number temp %allot-alien
+ "end" resolve-label
+ ] with-scope ;
+
+M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
+ [
+ "end" define-label
+ "ok" define-label
+ ! If displacement is zero, return the base
+ dst base MOV
+ displacement 0 CMP
+ "end" get JE
+ ! Quickly use displacement' before its needed for real, as allot temporary
+ dst 4 cells alien displacement' %allot
+ ! If base is already a displaced alien, unpack it
+ base' base MOV
+ displacement' displacement MOV
+ base \ f tag-number CMP
+ "ok" get JE
+ base header-offset [+] alien type-number tag-fixnum CMP
+ "ok" get JNE
+ ! displacement += base.displacement
+ displacement' base 3 alien@ ADD
+ ! base = base.base
+ base' base 1 alien@ MOV
+ "ok" resolve-label
+ dst 1 alien@ base' MOV ! alien
+ dst 2 alien@ \ f tag-number MOV ! expired
+ dst 3 alien@ displacement' MOV ! displacement
"end" resolve-label
] with-scope ;
M: x86 %alien-signed-4 32 %alien-signed-getter ;
M: x86 %alien-cell [] MOV ;
-M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
+M: x86 %alien-float [] MOVSS ;
M: x86 %alien-double [] MOVSD ;
+M: x86 %alien-vector [ [] ] dip copy-register ;
:: %alien-integer-setter ( ptr value size -- )
value { ptr } size [| new-value |
M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
M: x86 %set-alien-cell [ [] ] dip MOV ;
-M: x86 %set-alien-float dup dup CVTSD2SS [ [] ] dip MOVSS ;
+M: x86 %set-alien-float [ [] ] dip MOVSS ;
M: x86 %set-alien-double [ [] ] dip MOVSD ;
+M: x86 %set-alien-vector [ [] ] 2dip copy-register ;
: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
! Pass number of roots as second parameter
param-reg-2 gc-root-count MOV
! Call GC
- %prepare-alien-invoke
"inline_gc" f %alien-invoke ;
M: x86 %alien-global
temp 0 MOV \ t rc-absolute-cell rel-immediate
dst temp word execute ; inline
-M: x86 %compare ( dst temp cc src1 src2 -- )
- CMP {
- { cc< [ \ CMOVL %boolean ] }
- { cc<= [ \ CMOVLE %boolean ] }
- { cc> [ \ CMOVG %boolean ] }
- { cc>= [ \ CMOVGE %boolean ] }
- { cc= [ \ CMOVE %boolean ] }
- { cc/= [ \ CMOVNE %boolean ] }
+M:: x86 %compare ( dst src1 src2 cc temp -- )
+ src1 src2 CMP
+ cc order-cc {
+ { cc< [ dst temp \ CMOVL %boolean ] }
+ { cc<= [ dst temp \ CMOVLE %boolean ] }
+ { cc> [ dst temp \ CMOVG %boolean ] }
+ { cc>= [ dst temp \ CMOVGE %boolean ] }
+ { cc= [ dst temp \ CMOVE %boolean ] }
+ { cc/= [ dst temp \ CMOVNE %boolean ] }
} case ;
-M: x86 %compare-imm ( dst temp cc src1 src2 -- )
+M: x86 %compare-imm ( dst src1 src2 cc temp -- )
%compare ;
-M: x86 %compare-float ( dst temp cc src1 src2 -- )
- UCOMISD {
- { cc< [ \ CMOVB %boolean ] }
- { cc<= [ \ CMOVBE %boolean ] }
- { cc> [ \ CMOVA %boolean ] }
- { cc>= [ \ CMOVAE %boolean ] }
- { cc= [ \ CMOVE %boolean ] }
- { cc/= [ \ CMOVNE %boolean ] }
- } case ;
+: %cmov-float= ( dst src -- )
+ [
+ "no-move" define-label
+
+ "no-move" get [ JNE ] [ JP ] bi
+ MOV
+ "no-move" resolve-label
+ ] with-scope ;
+
+: %cmov-float/= ( dst src -- )
+ [
+ "no-move" define-label
+ "move" define-label
+
+ "move" get JP
+ "no-move" get JE
+ "move" resolve-label
+ MOV
+ "no-move" resolve-label
+ ] with-scope ;
-M: x86 %compare-branch ( label cc src1 src2 -- )
- CMP {
- { cc< [ JL ] }
- { cc<= [ JLE ] }
- { cc> [ JG ] }
- { cc>= [ JGE ] }
- { cc= [ JE ] }
- { cc/= [ JNE ] }
+:: (%compare-float) ( dst src1 src2 cc temp compare -- )
+ cc {
+ { cc< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
+ { cc<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
+ { cc> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
+ { cc>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
+ { cc= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= %boolean ] }
+ { cc<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE %boolean ] }
+ { cc<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP %boolean ] }
+ { cc/< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
+ { cc/<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
+ { cc/> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
+ { cc/>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
+ { cc/= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= %boolean ] }
+ { cc/<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE %boolean ] }
+ { cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP %boolean ] }
+ } case ; inline
+
+M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
+ \ COMISD (%compare-float) ;
+
+M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
+ \ UCOMISD (%compare-float) ;
+
+M:: x86 %compare-branch ( label src1 src2 cc -- )
+ src1 src2 CMP
+ cc order-cc {
+ { cc< [ label JL ] }
+ { cc<= [ label JLE ] }
+ { cc> [ label JG ] }
+ { cc>= [ label JGE ] }
+ { cc= [ label JE ] }
+ { cc/= [ label JNE ] }
} case ;
M: x86 %compare-imm-branch ( label src1 src2 cc -- )
%compare-branch ;
-M: x86 %compare-float-branch ( label cc src1 src2 -- )
- UCOMISD {
- { cc< [ JB ] }
- { cc<= [ JBE ] }
- { cc> [ JA ] }
- { cc>= [ JAE ] }
- { cc= [ JE ] }
- { cc/= [ JNE ] }
+: %jump-float= ( label -- )
+ [
+ "no-jump" define-label
+ "no-jump" get JP
+ JE
+ "no-jump" resolve-label
+ ] with-scope ;
+
+: %jump-float/= ( label -- )
+ [ JNE ] [ JP ] bi ;
+
+:: (%compare-float-branch) ( label src1 src2 cc compare -- )
+ cc {
+ { cc< [ src2 src1 \ compare execute( a b -- ) label JA ] }
+ { cc<= [ src2 src1 \ compare execute( a b -- ) label JAE ] }
+ { cc> [ src1 src2 \ compare execute( a b -- ) label JA ] }
+ { cc>= [ src1 src2 \ compare execute( a b -- ) label JAE ] }
+ { cc= [ src1 src2 \ compare execute( a b -- ) label %jump-float= ] }
+ { cc<> [ src1 src2 \ compare execute( a b -- ) label JNE ] }
+ { cc<>= [ src1 src2 \ compare execute( a b -- ) label JNP ] }
+ { cc/< [ src2 src1 \ compare execute( a b -- ) label JBE ] }
+ { cc/<= [ src2 src1 \ compare execute( a b -- ) label JB ] }
+ { cc/> [ src1 src2 \ compare execute( a b -- ) label JBE ] }
+ { cc/>= [ src1 src2 \ compare execute( a b -- ) label JB ] }
+ { cc/= [ src1 src2 \ compare execute( a b -- ) label %jump-float/= ] }
+ { cc/<> [ src1 src2 \ compare execute( a b -- ) label JE ] }
+ { cc/<>= [ src1 src2 \ compare execute( a b -- ) label JP ] }
} case ;
-M: x86 %spill ( src n rep -- ) [ spill@ swap ] dip copy-register ;
-M: x86 %reload ( dst n rep -- ) [ spill@ ] dip copy-register ;
+M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- )
+ \ COMISD (%compare-float-branch) ;
+
+M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
+ \ UCOMISD (%compare-float-branch) ;
+
+M:: x86 %spill ( src rep n -- )
+ n spill@ src rep copy-register ;
+
+M:: x86 %reload ( dst rep n -- )
+ dst n spill@ rep copy-register ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
-M: x86 %prepare-alien-invoke
+M:: x86 %save-context ( temp1 temp2 callback-allowed? -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- temp-reg "stack_chain" f %alien-global
- temp-reg temp-reg [] MOV
- temp-reg [] stack-reg MOV
- temp-reg [] cell SUB
- temp-reg 2 cells [+] ds-reg MOV
- temp-reg 3 cells [+] rs-reg MOV ;
+ temp1 "stack_chain" f %alien-global
+ temp1 temp1 [] MOV
+ temp2 stack-reg cell neg [+] LEA
+ temp1 [] temp2 MOV
+ callback-allowed? [
+ temp1 2 cells [+] ds-reg MOV
+ temp1 3 cells [+] rs-reg MOV
+ ] when ;
M: x86 value-struct? drop t ;
#! 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-sse2-simd ;
+
+: enable-sse3 ( -- )
+ enable-sse2
+ enable-sse3-simd ;
+
+enable-min/max
"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
{ $code <"
-USING: db.sqlite db io.files ;
+USING: db.sqlite db io.files io.files.temp ;
: with-book-db ( quot -- )
- "book.db" temp-file <sqlite-db> swap with-db ;"> }
+ "book.db" temp-file <sqlite-db> swap with-db ; inline"> }
"Now let's create the table manually:"
{ $code <" "create table books
(id integer primary key, title text, author text, date_published timestamp,
edition integer, cover_price double, condition text)"
- [ sql-command ] with-book-db" "> }
+ [ sql-command ] with-book-db"> }
"Time to insert some books:"
{ $code <"
"insert into books
libc calendar.format byte-arrays destructors prettyprint
accessors strings serialize io.encodings.binary io.encodings.utf8
alien.strings io.streams.byte-array summary present urls
-specialized-arrays.uint specialized-arrays.alien db.private ;
+specialized-arrays db.private ;
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: void*
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
"User-defined errors can have customized printed representation by implementing a generic word:"
{ $subsection error. }
"A number of words facilitate interactive debugging of errors:"
+{ $subsection :error }
{ $subsection :s }
{ $subsection :r }
{ $subsection :c }
{ $subsection :2 }
{ $subsection :3 }
{ $subsection :res }
-"You can read more about error handling in " { $link "errors" } "." ;
+"You can read more about error handling in " { $link "errors" } "."
+$nl
+"Note that in Factor, the debugger is a tool for printing and inspecting errors, not for walking through code. For the latter, see " { $link "ui-walker" } "." ;
ABOUT: "debugger"
+HELP: :error
+{ $description "Prints the most recent error. Used for interactive debugging." } ;
+
HELP: :s
{ $description "Prints the data stack at the time of the most recent error. Used for interactive debugging." } ;
: primitive-error. ( error -- )
"Unimplemented primitive" print drop ;
+: fp-trap-error. ( error -- )
+ "Floating point trap" print drop ;
+
PREDICATE: vm-error < array
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }
- [ second 0 15 between? ]
+ [ second 0 16 between? ]
} cond ;
: vm-errors ( error -- n errors )
{ 13 [ retainstack-underflow. ] }
{ 14 [ retainstack-overflow. ] }
{ 15 [ memory-error. ] }
+ { 16 [ fp-trap-error. ] }
} ; inline
M: vm-error summary drop "VM error" ;
ICON: constant constant-word
ICON: word normal-word
ICON: word-link word-help-article
-ICON: link help-article
+ICON: topic help-article
ICON: runnable-vocab runnable-vocab
ICON: vocab open-vocab
ICON: vocab-link unopen-vocab
io.encodings io ;
IN: environment.winnt
+<< "TCHAR" require-c-array >>
+
M: winnt os-env ( key -- value )
MAX_UNICODE_PATH "TCHAR" <c-array>
[ dup length GetEnvironmentVariable ] keep over 0 = [
--- /dev/null
+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 ;
+
-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
<<
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
+
! 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
<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 ;
[ parse-definition* ] dip
parsed ;
-SYNTAX: `TUPLE:
+FUNCTOR-SYNTAX: TUPLE:
scan-param parsed
scan {
{ ";" [ tuple parsed f parsed ] }
} 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
SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
+SYNTAX: DEFINES-PRIVATE [ begin-private create-in end-private ] (INTERPOLATE) ;
+
SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax http.server.filters kernel
+multiline furnace.actions ;
+IN: furnace.chloe-tags.recaptcha
+
+HELP: <recaptcha>
+{ $values
+ { "responder" "a responder" }
+ { "obj" object }
+}
+{ $description "A " { $link filter-responder } " wrapping another responder. Set the domain, public, and private keys using the key you get by registering with Recaptcha." } ;
+
+HELP: recaptcha-error
+{ $var-description "Set to the error string returned by the Recaptcha server." } ;
+
+HELP: recaptcha-valid?
+{ $var-description "Set to " { $link t } " if the user solved the last Recaptcha correctly." } ;
+
+HELP: validate-recaptcha
+{ $description "Validates a Recaptcha using the Recaptcha web service API." } ;
+
+ARTICLE: "recaptcha-example" "Recaptcha example"
+"There are several steps to using the Recaptcha library."
+{ $list
+ { "Wrap the responder in a " { $link <recaptcha> } }
+ { "Add a handler calling " { $link validate-recaptcha } " in the " { $slot "submit" } " of the " { $link page-action } }
+ { "Put the chloe tag " { $snippet "<recaptcha/>" } " in the template for your " { $link action } }
+}
+"An example follows:"
+{ $code
+HEREDOC: RECAPTCHA-TUTORIAL
+TUPLE: recaptcha-app < dispatcher recaptcha ;
+
+: <recaptcha-challenge> ( -- obj )
+ <action>
+ [
+ validate-recaptcha
+ recaptcha-valid? get "?good" "?bad" ? <redirect>
+ ] >>submit
+ [
+ <response>
+{" <?xml version='1.0' ?>
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+<html><body><t:recaptcha/></body></html>
+</t:chloe>"} >>body
+ ] >>display ;
+
+: <recaptcha-app> ( -- obj )
+ \ recaptcha-app new-dispatcher
+ <recaptcha-challenge> "" add-responder
+ <recaptcha>
+ "concatenative.org" >>domain
+ "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" >>public-key
+ "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" >>private-key ;
+
+<recaptcha-app> main-responder set-global
+RECAPTCHA-TUTORIAL
+}
+
+;
+
+ARTICLE: "furnace.chloe-tags.recaptcha" "Recaptcha chloe tag"
+"The " { $vocab-link "furnace.chloe-tags.recaptcha" } " vocabulary implements support for the Recaptcha. Recaptcha is a web service that provides the user with a captcha, a test that is easy to solve by visual inspection, but hard to solve by writing a computer program. Use a captcha to protect forms from abusive users." $nl
+
+"The recaptcha responder is a " { $link filter-responder } " that wraps another responder. Set the " { $slot "domain" } ", " { $slot "public-key" } ", and " { $slot "private-key" } " slots of this responder to your Recaptcha account information." $nl
+
+"Wrapping a responder with Recaptcha:"
+{ $subsection <recaptcha> }
+"Validating recaptcha:"
+{ $subsection validate-recaptcha }
+"Symbols set after validation:"
+{ $subsection recaptcha-valid? }
+{ $subsection recaptcha-error }
+{ $subsection "recaptcha-example" } ;
+
+ABOUT: "furnace.chloe-tags.recaptcha"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions furnace.redirection html.forms
+html.templates.chloe.compiler html.templates.chloe.syntax
+http.client http.server http.server.filters io.sockets kernel
+locals namespaces sequences splitting urls validators
+xml.syntax ;
+IN: furnace.chloe-tags.recaptcha
+
+TUPLE: recaptcha < filter-responder domain public-key private-key ;
+
+SYMBOLS: recaptcha-valid? recaptcha-error ;
+
+: <recaptcha> ( responder -- obj )
+ recaptcha new
+ swap >>responder ;
+
+M: recaptcha call-responder*
+ dup \ recaptcha set
+ responder>> call-responder ;
+
+<PRIVATE
+
+: (render-recaptcha) ( private-key -- xml )
+ dup
+[XML <script type="text/javascript"
+ src=<->>
+</script>
+
+<noscript>
+ <iframe src=<->
+ height="300" width="500" frameborder="0"></iframe><br/>
+ <textarea name="recaptcha_challenge_field" rows="3" cols="40">
+ </textarea>
+ <input type="hidden" name="recaptcha_response_field"
+ value="manual_challenge"/>
+</noscript>
+XML] ;
+
+: recaptcha-url ( secure? -- ? )
+ [ "https://api.recaptcha.net/challenge" >url ]
+ [ "http://api.recaptcha.net/challenge" >url ] if ;
+
+: render-recaptcha ( -- xml )
+ secure-connection? recaptcha-url
+ recaptcha get public-key>> "k" set-query-param (render-recaptcha) ;
+
+: parse-recaptcha-response ( string -- valid? error )
+ "\n" split first2 [ "true" = ] dip ;
+
+:: (validate-recaptcha) ( challenge response recaptcha -- valid? error )
+ recaptcha private-key>> :> private-key
+ remote-address get host>> :> remote-ip
+ H{
+ { "challenge" challenge }
+ { "response" response }
+ { "privatekey" private-key }
+ { "remoteip" remote-ip }
+ } URL" http://api-verify.recaptcha.net/verify"
+ <post-request> http-request nip parse-recaptcha-response ;
+
+CHLOE: recaptcha
+ drop [ render-recaptcha ] [xml-code] ;
+
+PRIVATE>
+
+: validate-recaptcha ( -- )
+ {
+ { "recaptcha_challenge_field" [ v-required ] }
+ { "recaptcha_response_field" [ v-required ] }
+ } validate-params
+ "recaptcha_challenge_field" value
+ "recaptcha_response_field" value
+ \ recaptcha get (validate-recaptcha)
+ [ recaptcha-valid? set ] [ recaptcha-error set ] bi* ;
--- /dev/null
+<?xml version='1.0' ?>
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+<html>
+ <body><t:recaptcha/>
+ </body>
+</html>
+</t:chloe>
--- /dev/null
+Recaptcha library
game-input.dinput.keys-array io.encodings.utf16
io.encodings.utf16n kernel locals math math.bitwise
math.rectangles namespaces parser sequences shuffle
-struct-arrays ui.backend.windows vectors windows.com
+specialized-arrays ui.backend.windows vectors windows.com
windows.dinput windows.dinput.constants windows.errors
windows.kernel32 windows.messages windows.ole32
-windows.user32 ;
+windows.user32 classes.struct ;
+SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
IN: game-input.dinput
+
CONSTANT: MOUSE-BUFFER-SIZE 16
SINGLETON: dinput-game-input-backend
get IDirectInputDevice8W::SetDataFormat ole32-error ;
: <buffer-size-diprop> ( size -- DIPROPDWORD )
- "DIPROPDWORD" <c-object>
- "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize
- "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize
- 0 over set-DIPROPHEADER-dwObj
- DIPH_DEVICE over set-DIPROPHEADER-dwHow
- swap over set-DIPROPDWORD-dwData ;
+ DIPROPDWORD <struct> [
+ diph>>
+ DIPROPDWORD heap-size >>dwSize
+ DIPROPHEADER heap-size >>dwHeaderSize
+ 0 >>dwObj
+ DIPH_DEVICE >>dwHow
+ drop
+ ] keep swap >>dwData ;
: set-buffer-size ( device size -- )
DIPROP_BUFFERSIZE swap <buffer-size-diprop>
GUID_SysKeyboard device-for-guid
[ configure-keyboard ]
[ +keyboard-device+ set-global ] bi
- 256 <byte-array> <keys-array> keyboard-state boa
+ 256 <byte-array> 256 <keys-array> keyboard-state boa
+keyboard-state+ set-global ;
: find-mouse ( -- )
GUID_SysMouse device-for-guid
- [ configure-mouse ]
- [ +mouse-device+ set-global ] bi
- 0 0 0 0 8 f <array> mouse-state boa
- +mouse-state+ set-global
- MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" <c-array>
- +mouse-buffer+ set-global ;
+ [ configure-mouse ] [ +mouse-device+ set-global ] bi
+ 0 0 0 0 8 f <array> mouse-state boa +mouse-state+ set-global
+ MOUSE-BUFFER-SIZE <DIDEVICEOBJECTDATA-array> +mouse-buffer+ set-global ;
: device-info ( device -- DIDEVICEIMAGEINFOW )
- "DIDEVICEINSTANCEW" <c-object>
- "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
- [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
+ DIDEVICEINSTANCEW <struct>
+ DIDEVICEINSTANCEW heap-size >>dwSize
+ [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ; inline
: device-caps ( device -- DIDEVCAPS )
- "DIDEVCAPS" <c-object>
- "DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
- [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
-
-: <guid> ( memory -- byte-array )
- "GUID" heap-size memory>byte-array ;
+ DIDEVCAPS <struct>
+ DIDEVCAPS heap-size >>dwSize
+ [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ; inline
: device-guid ( device -- guid )
- device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
+ device-info guidInstance>> ; inline
: device-attached? ( device -- ? )
+dinput+ get swap device-guid
: find-device-axes-callback ( -- alien )
[ ! ( lpddoi pvRef -- BOOL )
+ [ DIDEVICEOBJECTINSTANCEW memory>struct ] dip
+controller-devices+ get at
- swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
+ swap guidType>> {
{ [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
{ [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
{ [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
: controller-state-template ( device -- controller-state )
controller-state new
over device-caps
- [
DIDEVCAPS-dwButtons f <array> >>buttons ]
- [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
+ [
dwButtons>> f <array> >>buttons ]
+ [ dwPOVs>> zero? f pov-neutral ? >>pov ] bi
find-device-axes ;
: device-known? ( guid -- ? )
device-for-guid {
[ configure-controller ]
[ controller-state-template ]
- [ dup device-guid +controller-guids+ get set-at ]
+ [ dup device-guid clone +controller-guids+ get set-at ]
[ +controller-devices+ get set-at ]
} cleave ;
: add-controller ( guid -- )
- dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
+ dup device-known? [ drop ] [ (add-controller) ] if ;
: remove-controller ( device -- )
[ +controller-devices+ get delete-at ]
: find-controller-callback ( -- alien )
[ ! ( lpddi pvRef -- BOOL )
- drop DIDEVICEINSTANCEW-guidInstance add-controller
+ drop DIDEVICEINSTANCEW memory>struct guidInstance>> add-controller
DIENUM_CONTINUE
- ] LPDIENUMDEVICESCALLBACKW ;
+ ] LPDIENUMDEVICESCALLBACKW ; inline
: find-controllers ( -- )
+dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
[ remove-controller ] each ;
: device-interface? ( dbt-broadcast-hdr -- ? )
- DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
+ dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = ;
: device-arrived ( dbt-broadcast-hdr -- )
device-interface? [ find-controllers ] when ;
{ 0 0 } >>dim ;
: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
- "DEV_BROADCAST_DEVICEW" <c-object>
- "DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
- DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
+ DEV_BROADCAST_DEVICEW <struct>
+ DEV_BROADCAST_DEVICEW heap-size >>dbcc_size
+ DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ;
: create-device-change-window ( -- )
<zero-window-rect> WS_OVERLAPPEDWINDOW 0 create-window
delete-dinput ;
M: dinput-game-input-backend (reset-game-input)
- {
- +dinput+ +keyboard-device+ +keyboard-state+
- +controller-devices+ +controller-guids+
- +device-change-window+ +device-change-handle+
- } [ f swap set-global ] each ;
+ global [
+ {
+ +dinput+ +keyboard-device+ +keyboard-state+
+ +controller-devices+ +controller-guids+
+ +device-change-window+ +device-change-handle+
+ } [ off ] each
+ ] bind ;
M: dinput-game-input-backend get-controllers
+controller-devices+ get
[ drop controller boa ] { } assoc>map ;
M: dinput-game-input-backend product-string
- handle>> device-info DIDEVICEINSTANCEW-tszProductName
+ handle>> device-info tszProductName>>
utf16n alien>string ;
M: dinput-game-input-backend product-id
- handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
+ handle>> device-info guidProduct>> ;
M: dinput-game-input-backend instance-id
handle>> device-guid ;
}
: >axis ( long -- float )
- 32767 - 32767.0 /f ;
+ 32767 - 32767.0 /f ; inline
: >slider ( long -- float )
- 65535.0 /f ;
+ 65535.0 /f ; inline
: >pov ( long -- symbol )
dup HEX: FFFF bitand HEX: FFFF =
[ drop pov-neutral ]
- [ 2750 + 4500 /i pov-values nth ] if ;
-: >buttons ( alien length -- array )
- memory>byte-array <keys-array> ;
+ [ 2750 + 4500 /i pov-values nth ] if ; inline
: (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
[ drop ] compose [ 2drop ] if ; inline
: fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
{
- [ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
- [ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
- [ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
- [ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
- [ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
- [ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
- [ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
- [ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
- [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
+ [ over x>> [ lX>> >axis >>x ] (fill-if) ]
+ [ over y>> [ lY>> >axis >>y ] (fill-if) ]
+ [ over z>> [ lZ>> >axis >>z ] (fill-if) ]
+ [ over rx>> [ lRx>> >axis >>rx ] (fill-if) ]
+ [ over ry>> [ lRy>> >axis >>ry ] (fill-if) ]
+ [ over rz>> [ lRz>> >axis >>rz ] (fill-if) ]
+ [ over slider>> [ rglSlider>> first >slider >>slider ] (fill-if) ]
+ [ over pov>> [ rgdwPOV>> first >pov >>pov ] (fill-if) ]
+ [ rgbButtons>> over buttons>> length <keys-array> >>buttons ]
} 2cleave ;
: read-device-buffer ( device buffer count -- buffer count' )
- [ "DIDEVICEOBJECTDATA" heap-size ] 2dip <uint>
+ [ DIDEVICEOBJECTDATA heap-size ] 2dip <uint>
[ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
- [ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi {
+ [ dwData>> 32 >signed ] [ dwOfs>> ] bi {
{ DIMOFS_X [ [ + ] curry change-dx ] }
{ DIMOFS_Y [ [ + ] curry change-dy ] }
{ DIMOFS_Z [ [ + ] curry change-scroll-dy ] }
} case ;
: fill-mouse-state ( buffer count -- state )
- [ +mouse-state+ get ] 2dip swap
- [ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ;
+ [ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ;
-: get-device-state ( device byte-array -- )
+: get-device-state ( device DIJOYSTATE2 -- )
[ dup IDirectInputDevice8W::Poll ole32-error ] dip
- [ length ] keep
+ [ byte-length ] keep
IDirectInputDevice8W::GetDeviceState ole32-error ;
: (read-controller) ( handle template -- state )
- swap [ "DIJOYSTATE2" heap-size <byte-array> [ get-device-state ] keep ]
+ swap [ DIJOYSTATE2 <struct> [ get-device-state ] keep ]
[ fill-controller-state ] [ drop f ] with-acquisition ;
M: dinput-game-input-backend read-controller
accessors ;
IN: game-input.dinput.keys-array
-TUPLE: keys-array underlying ;
+TUPLE: keys-array
+ { underlying sequence read-only }
+ { length integer read-only } ;
C: <keys-array> keys-array
: >key ( byte -- ? )
HEX: 80 bitand c-bool> ;
-M: keys-array length underlying>> length ;
+M: keys-array length length>> ;
M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
INSTANCE: keys-array sequence
MACRO: nsequence ( n seq -- )
[
- [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
+ [ drop iota <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep
'[ @ _ like ] ;
1 - [ + ] n*quot ;
MACRO: firstn-unsafe ( n -- )
- [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
+ iota [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
MACRO: nweave ( n -- )
- [ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
+ [ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ;
MACRO: nbi-curry ( n -- )
{ $subsection "complex-numbers" }
"Advanced features:"
{ $subsection "math-vectors" }
-{ $subsection "math-intervals" }
-{ $subsection "math-bitfields" }
-"Implementation:"
-{ $subsection "math.libm" } ;
+{ $subsection "math-intervals" } ;
USE: io.buffers
: $navigation-row ( content element label -- )
[ prefix 1array ] dip prefix , ;
+: ($navigation-table) ( element -- )
+ help-path-style get table-style set [ $table ] with-scope ;
+
: $navigation-table ( topic -- )
[
- [ help-path [ \ $links "Up:" $navigation-row ] unless-empty ]
[ prev-article [ 1array \ $long-link "Prev:" $navigation-row ] when* ]
[ next-article [ 1array \ $long-link "Next:" $navigation-row ] when* ]
- tri
- ] { } make [ $table ] unless-empty ;
+ bi
+ ] { } make [ ($navigation-table) ] unless-empty ;
+
+: ($navigation) ( topic -- )
+ help-path-style get [
+ [ help-path [ reverse $breadcrumbs ] unless-empty ]
+ [ $navigation-table ] bi
+ ] with-style ;
: $title ( topic -- )
title-style get [
title-style get [
- [ ($title) ]
- [ help-path-style get [ $navigation-table ] with-style ] bi
+ [ ($title) ] [ ($navigation) ] bi
] with-nesting
] with-style nl ;
-USING: help.html tools.test help.topics kernel ;
+USING: help.html tools.test help.topics kernel sequences vocabs ;
IN: help.html.tests
[ ] [ "xml" >link help>html drop ] unit-test
[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test
+
+[ t ] [ all-vocabs-really [ vocab-spec? ] all? ] unit-test
+
+[ t ] [ all-vocabs-really [ vocab-name "sequences.private" = ] any? ] unit-test
+
+[ f ] [ all-vocabs-really [ vocab-name "scratchpad" = ] any? ] unit-test
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
: all-vocabs-really ( -- seq )
- all-vocabs-recursive >hashtable f over delete-at no-roots remove-redundant-prefixes ;
+ all-vocabs-recursive >hashtable no-roots remove-redundant-prefixes
+ [ vocab-name "scratchpad" = not ] filter ;
: all-topics ( -- topics )
[
-a:link { text-decoration: none; color: #00004c; }
-a:visited { text-decoration: none; color: #00004c; }
-a:active { text-decoration: none; color: #00004c; }
-a:hover { text-decoration: underline; color: #00004c; }
+a:link { text-decoration: none; color: #104e8b; }
+a:visited { text-decoration: none; color: #104e8b; }
+a:active { text-decoration: none; color: #104e8b; }
+a:hover { text-decoration: underline; color: #104e8b; }
: ($code) ( presentation quot -- )
[
- snippet-style get [
+ code-char-style get [
last-element off
[ ($code-style) ] dip with-nesting
] with-style
"Vocabulary" $heading nl dup ($vocab-link)
] when* ;
+: (textual-list) ( seq quot sep -- )
+ '[ _ print-element ] swap interleave ; inline
+
: textual-list ( seq quot -- )
- [ ", " print-element ] swap interleave ; inline
+ ", " (textual-list) ; inline
: $links ( topics -- )
[ [ ($link) ] textual-list ] ($span) ;
: $vocab-links ( vocabs -- )
[ vocab ] map $links ;
+: $breadcrumbs ( topics -- )
+ [ [ ($link) ] " > " (textual-list) ] ($span) ;
+
: $see-also ( topics -- )
"See also" $heading $links ;
: ($see) ( word quot -- )
[
- snippet-style get [
+ code-char-style get [
code-style get swap with-nesting
] with-style
] ($block) ; inline
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.styles namespaces colors colors.constants ;
+USING: colors colors.constants io.styles namespaces ;
IN: help.stylesheet
SYMBOL: default-span-style
SYMBOL: link-style
H{
- { foreground COLOR: dark-blue }
+ { foreground COLOR: DodgerBlue4 }
{ font-style bold }
} link-style set-global
SYMBOL: title-style
H{
{ font-name "sans-serif" }
- { font-size 18 }
+ { font-size 20 }
{ font-style bold }
{ wrap-margin 500 }
- { page-color COLOR: light-gray }
- { border-width 5 }
+ { foreground COLOR: gray20 }
+ { page-color COLOR: FactorLightTan }
+ { inset { 5 5 } }
} title-style set-global
SYMBOL: help-path-style
-H{ { font-size 10 } } help-path-style set-global
+H{
+ { font-size 10 }
+ { table-gap { 5 5 } }
+ { table-border COLOR: FactorLightTan }
+} help-path-style set-global
SYMBOL: heading-style
H{
{ font-name "sans-serif" }
{ font-size 16 }
{ font-style bold }
+ { foreground COLOR: FactorDarkSlateBlue }
} heading-style set-global
SYMBOL: subsection-style
H{
{ font-name "monospace" }
{ font-size 12 }
- { foreground COLOR: navy-blue }
+ { foreground COLOR: DarkOrange4 }
} snippet-style set-global
+SYMBOL: code-char-style
+H{
+ { font-name "monospace" }
+ { font-size 12 }
+} code-char-style set-global
+
SYMBOL: code-style
H{
- { page-color COLOR: gray80 }
- { border-width 5 }
+ { page-color COLOR: FactorLightTan }
+ { inset { 5 5 } }
{ wrap-margin f }
} code-style set-global
SYMBOL: url-style
H{
{ font-name "monospace" }
- { foreground COLOR: blue }
+ { foreground COLOR: DodgerBlue4 }
} url-style set-global
SYMBOL: warning-style
H{
{ page-color COLOR: gray90 }
{ border-color COLOR: red }
- { border-width 5 }
+ { inset { 5 5 } }
{ wrap-margin 500 }
} warning-style set-global
H{
{ page-color COLOR: gray90 }
{ border-color COLOR: red }
- { border-width 5 }
+ { inset { 5 5 } }
{ wrap-margin 500 }
} deprecated-style set-global
SYMBOL: table-style
H{
{ table-gap { 5 5 } }
- { table-border COLOR: light-gray }
+ { table-border COLOR: FactorTan }
} table-style set-global
SYMBOL: list-style
H{
{ page-color COLOR: lavender }
- { border-width 5 }
+ { inset { 5 5 } }
{ wrap-margin 500 }
} tip-of-the-day-style set-global
] bi
] unless-empty ;
+: vocab-is-not-loaded ( vocab -- )
+ "Not loaded" $heading
+ "You must first load this vocabulary to browse its documentation and words."
+ print-element vocab-name "USE: " prepend 1array $code ;
+
+: describe-words ( vocab -- )
+ {
+ { [ dup vocab ] [ words $words ] }
+ { [ dup find-vocab-root ] [ vocab-is-not-loaded ] }
+ [ drop ]
+ } cond ;
+
: words. ( vocab -- )
last-element off
[ require ] [ words $words ] bi nl ;
first {
[ describe-help ]
[ describe-metadata ]
- [ words $words ]
+ [ describe-words ]
[ describe-files ]
[ describe-children ]
} cleave ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays byte-vectors classes
-combinators definitions fry generic generic.single
+combinators definitions effects fry generic generic.single
generic.standard hashtables io.binary io.streams.string kernel
kernel.private math math.parser namespaces parser sbufs
sequences splitting splitting.private strings vectors words ;
M: object specializer-declaration class ;
+: specializer ( word -- specializer )
+ "specializer" word-prop ;
+
: make-specializer ( specs -- quot )
dup length <reversed>
[ (picker) 2array ] 2map
[ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
] if-empty ;
-: specializer-cases ( quot word -- default alist )
+: specializer-cases ( quot specializer -- alist )
dup [ array? ] all? [ 1array ] unless [
- [ make-specializer ] keep
- [ specializer-declaration ] map '[ _ declare ] pick append
- ] { } map>assoc ;
+ [ nip make-specializer ]
+ [ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi
+ ] with { } map>assoc ;
-: specialize-quot ( quot specializer -- quot' )
- specializer-cases alist>quot ;
+: specialize-quot ( quot word specializer -- quot' )
+ [ drop nip def>> ] [ nip specializer-cases ] 3bi alist>quot ;
! compiler.tree.propagation.inlining sets this to f
SYMBOL: specialize-method?
: specialize-method ( quot method -- quot' )
[ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
- [ "method-generic" word-prop "specializer" word-prop ] bi
- [ specialize-quot ] when* ;
+ [ dup "method-generic" word-prop specializer ] bi
+ [ specialize-quot ] [ drop ] if* ;
: standard-method? ( method -- ? )
dup method-body? [
[ def>> ] keep
dup generic? [ drop ] [
[ dup standard-method? [ specialize-method ] [ drop ] if ]
- [ "specializer" word-prop [ specialize-quot ] when* ]
+ [ dup specializer [ specialize-quot ] [ drop ] if* ]
bi
] if ;
: border-css, ( border -- )
"border: 1px solid #" % hex-color, "; " % ;
-: padding-css, ( padding -- ) "padding: " % # "px; " % ;
+: padding-css, ( padding -- )
+ first2 "padding: " % # "px " % # "px; " % ;
CONSTANT: pre-css "white-space: pre; font-family: monospace;"
{
{ page-color bg-css, }
{ border-color border-css, }
- { border-width padding-css, }
+ { inset padding-css, }
} make-css
] [
wrap-margin swap at
images.bitmap.loading images.loader io io.binary
io.encodings.binary io.encodings.string io.files
io.streams.limited kernel locals macros math math.bitwise
-math.functions namespaces sequences specialized-arrays.uint
-specialized-arrays.ushort strings summary ;
+math.functions namespaces sequences specialized-arrays
+strings summary ;
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: ushort
IN: images.bitmap
: write2 ( n -- ) 2 >le write ;
compression.run-length fry grouping images images.loader io
io.binary io.encodings.8-bit io.encodings.binary
io.encodings.string io.streams.limited kernel math math.bitwise
-sequences specialized-arrays.ushort summary ;
+sequences specialized-arrays summary ;
QUALIFIED-WITH: bitstreams b
+SPECIALIZED-ARRAY: ushort
IN: images.bitmap.loading
SINGLETON: bitmap-image
ERROR: unsupported-bitmap-file magic ;
-: load-bitmap ( path -- loading-bitmap )
- binary stream-throws <limited-file-reader> [
+: load-bitmap ( stream -- loading-bitmap )
+ [
\ loading-bitmap new
parse-file-header [ >>file-header ] [ ] bi magic>> {
{ "BM" [
: loading-bitmap>bytes ( loading-bitmap -- byte-array )
uncompress-bitmap bitmap>bytes ;
-M: bitmap-image load-image* ( path bitmap-image -- bitmap )
+M: bitmap-image stream>image ( stream bitmap-image -- bitmap )
drop load-bitmap
[ image new ] dip
{
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: http.client images.loader images.loader.private kernel ;
+IN: images.http
+
+: load-http-image ( path -- image )
+ [ http-get nip ] [ image-class new ] bi load-image* ;
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
-GENERIC: load-image* ( path class -- image )
-
: bytes-per-component ( component-type -- n )
{
{ ubyte-components [ 1 ] }
io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces
-sequences sequences.deep ;
+sequences sequences.deep images.loader io.streams.limited ;
IN: images.jpeg
QUALIFIED-WITH: bitstreams bs
{ huff-tables initial: { f f f f } }
{ components } ;
+"jpg" jpeg-image register-image-class
+"jpeg" jpeg-image register-image-class
+
<PRIVATE
: <jpeg-image> ( headers bitstream -- image )
] with-byte-reader ;
: decode-huff-table ( chunk -- )
- data>>
- binary
- [
- 1 ! %fixme: Should handle multiple tables at once
+ data>> [ binary <byte-reader> ] [ length ] bi
+ stream-throws limit
+ [
+ [ input-stream get [ count>> ] [ limit>> ] bi < ]
[
read4/4 swap 2 * +
16 read
dup [ ] [ + ] map-reduce read
binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
swap jpeg> huff-tables>> set-nth
- ] times
- ] with-byte-reader ;
+ ] while
+ ] with-input-stream* ;
: decode-scan ( chunk -- )
data>>
: singleton-first ( seq -- elt )
[ length 1 assert= ] [ first ] bi ;
+ERROR: not-a-baseline-jpeg-image ;
+
: baseline-parse ( -- )
+ jpeg> headers>> [ type>> { SOF 0 } = ] any? [ not-a-baseline-jpeg-image ] unless
jpeg> headers>>
{
[ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
: V.M ( x A -- x.A ) Mtranspose swap M.V ;
: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
-: idct ( b -- b' ) idct-blas ;
+: idct ( b -- b' ) idct-factor ;
:: draw-block ( block x,y color-id jpeg-image -- )
block dup length>> sqrt >fixnum group flip
PRIVATE>
-: load-jpeg ( path -- image )
- binary [
+M: jpeg-image stream>image ( stream jpeg-image -- bitmap )
+ drop [
parse-marker { SOI } = [ not-a-jpeg-image ] unless
parse-headers
contents <jpeg-image>
- ] with-file-reader
+ ] with-input-stream
dup jpeg-image [
baseline-parse
baseline-decompress
] with-variable ;
-
-M: jpeg-image load-image* ( path jpeg-image -- bitmap )
- drop load-jpeg ;
-
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel splitting unicode.case combinators accessors images
-io.pathnames namespaces assocs ;
+USING: accessors assocs byte-arrays combinators images
+io.encodings.binary io.pathnames io.streams.byte-array
+io.streams.limited kernel namespaces splitting strings
+unicode.case ;
IN: images.loader
ERROR: unknown-image-extension extension ;
file-extension >lower types get ?at
[ unknown-image-extension ] unless ;
+: open-image-file ( path -- stream )
+ binary stream-throws <limited-file-reader> ;
+
PRIVATE>
+GENERIC# load-image* 1 ( obj class -- image )
+
+GENERIC: stream>image ( stream class -- image )
+
: register-image-class ( extension class -- )
swap types get set-at ;
: load-image ( path -- image )
- dup image-class load-image* ;
+ [ open-image-file ] [ image-class ] bi load-image* ;
+
+M: byte-array load-image*
+ [ binary <byte-reader> ] dip stream>image ;
+
+M: limited-stream load-image* stream>image ;
+
+M: string load-image* [ open-image-file ] dip stream>image ;
+
+M: pathname load-image* [ open-image-file ] dip stream>image ;
[ unknown-color-type ]
} case ;
-: load-png ( path -- image )
- binary stream-throws <limited-file-reader> [
+M: png-image stream>image
+ drop [
<loading-png>
read-png-header
read-png-chunks
parse-ihdr-chunk
decode-png
] with-input-stream ;
-
-M: png-image load-image*
- drop load-png ;
io.binary io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences
-strings math.vectors specialized-arrays.float locals
+strings math.vectors specialized-arrays locals
images.loader ;
+SPECIALIZED-ARRAY: float
IN: images.tiff
SINGLETON: tiff-image
: with-tiff-endianness ( loading-tiff quot -- )
[ dup endianness>> ] dip with-endianness ; inline
-: load-tiff-ifds ( path -- loading-tiff )
- binary [
+: load-tiff-ifds ( stream -- loading-tiff )
+ [
<loading-tiff>
read-header [
dup ifd-offset>> read-ifds
process-ifds
] with-tiff-endianness
- ] with-file-reader ;
+ ] with-input-stream* ;
: process-chunky-ifd ( ifd -- )
read-strips
ifds>> [ process-ifd ] each ;
: load-tiff ( path -- loading-tiff )
- [ load-tiff-ifds dup ] keep
- binary [
- [ process-tif-ifds ] with-tiff-endianness
- ] with-file-reader ;
+ [ load-tiff-ifds dup ]
+ [
+ [ [ 0 seek-absolute ] dip stream-seek ]
+ [
+ [
+ [ process-tif-ifds ] with-tiff-endianness
+ ] with-input-stream
+ ] bi
+ ] bi ;
! tiff files can store several images -- we just take the first for now
-M: tiff-image load-image* ( path tiff-image -- image )
+M: tiff-image stream>image ( stream tiff-image -- image )
drop load-tiff tiff>image ;
{ "tif" "tiff" } [ tiff-image register-image-class ] each
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types kernel destructors bit-arrays
-sequences assocs struct-arrays math namespaces locals fry unix
-unix.linux.epoll unix.time io.ports io.backend.unix
-io.backend.unix.multiplexers ;
+USING: accessors classes.struct kernel destructors bit-arrays
+sequences assocs specialized-arrays math namespaces
+locals fry unix unix.linux.epoll unix.time io.ports
+io.backend.unix io.backend.unix.multiplexers ;
+SPECIALIZED-ARRAY: epoll-event
IN: io.backend.unix.multiplexers.epoll
TUPLE: epoll-mx < mx events ;
: <epoll-mx> ( -- mx )
epoll-mx new-mx
max-events epoll_create dup io-error >>fd
- max-events "epoll-event" <struct-array> >>events ;
+ max-events <epoll-event-array> >>events ;
M: epoll-mx dispose* fd>> close-file ;
: make-event ( fd events -- event )
- "epoll-event" <c-object>
- [ set-epoll-event-events ] keep
- [ set-epoll-event-fd ] keep ;
+ epoll-event <struct>
+ swap >>events
+ swap >>fd ;
:: do-epoll-ctl ( fd mx what events -- )
mx fd>> what fd fd events make-event epoll_ctl io-error ;
epoll_wait multiplexer-error ;
: handle-event ( event mx -- )
- [ epoll-event-fd ] dip
+ [ fd>> ] dip
[ EPOLLIN EPOLLOUT bitor do-epoll-del ]
[ input-available ] [ output-available ] 2tri ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types combinators destructors
-io.backend.unix kernel math.bitwise sequences struct-arrays unix
-unix.kqueue unix.time assocs io.backend.unix.multiplexers ;
+io.backend.unix kernel math.bitwise sequences
+specialized-arrays unix unix.kqueue unix.time assocs
+io.backend.unix.multiplexers classes.struct ;
+SPECIALIZED-ARRAY: kevent
IN: io.backend.unix.multiplexers.kqueue
TUPLE: kqueue-mx < mx events ;
-: max-events ( -- n )
- #! We read up to 256 events at a time. This is an arbitrary
- #! constant...
- 256 ; inline
+! We read up to 256 events at a time. This is an arbitrary
+! constant...
+CONSTANT: max-events 256
: <kqueue-mx> ( -- mx )
kqueue-mx new-mx
kqueue dup io-error >>fd
- max-events "kevent" <struct-array> >>events ;
+ max-events <kevent-array> >>events ;
M: kqueue-mx dispose* fd>> close-file ;
: make-kevent ( fd filter flags -- event )
- "kevent" <c-object>
- [ set-kevent-flags ] keep
- [ set-kevent-filter ] keep
- [ set-kevent-ident ] keep ;
+ \ kevent <struct>
+ swap >>flags
+ swap >>filter
+ swap >>ident ;
: register-kevent ( kevent mx -- )
fd>> swap 1 f 0 f kevent io-error ;
] dip kevent multiplexer-error ;
: handle-kevent ( mx kevent -- )
- [ kevent-ident swap ] [ kevent-filter ] bi {
+ [ ident>> swap ] [ filter>> ] bi {
{ EVFILT_READ [ input-available ] }
{ EVFILT_WRITE [ output-available ] }
} case ;
: handle-kevents ( mx n -- )
- [ dup events>> ] dip head-slice [ handle-kevent ] with each ;
+ [ dup events>> ] dip head-slice
+ [ handle-kevent ] with each ;
M: kqueue-mx wait-for-events ( us mx -- )
swap dup [ make-timespec ] when
[ datagram-client delete-file ] ignore-errors
-datagram-client <local> <datagram>
-"d" set
+[ ] [ datagram-client <local> <datagram> "d" set ] unit-test
[ ] [
"hello" >byte-array
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 ;
-QUALIFIED: windows.winsock
+ascii system accessors locals classes.struct combinators.short-circuit ;
IN: io.backend.windows.nt
! Global variable with assoc mapping overlapped to threads
C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext )
- "OVERLAPPED" malloc-object &free ;
+ OVERLAPPED malloc-struct &free ;
: make-overlapped ( port -- overlapped-ext )
[ (make-overlapped) ] dip
- handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
+ handle>> ptr>> [ >>offset ] when* ;
M: winnt FileArgs-overlapped ( port -- overlapped )
make-overlapped ;
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 )
[
drop
- [ pending-overlapped get-global set-at ] curry "I/O" suspend
+ [ >c-ptr pending-overlapped get-global set-at ] curry "I/O" suspend
{
{ [ dup integer? ] [ ] }
{ [ dup array? ] [
f <void*> [ ! overlapped
us [ 1000 /i ] [ INFINITE ] if* ! timeout
GetQueuedCompletionStatus zero?
- ] keep *void*
+ ] keep
+ *void* dup [ OVERLAPPED memory>struct ] when
] keep *int spin ;
: resume-callback ( result overlapped -- )
- pending-overlapped get-global delete-at* drop resume-with ;
+ >c-ptr pending-overlapped get-global delete-at* drop resume-with ;
: 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
M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global
- H{ } clone pending-overlapped set-global
- windows.winsock:init-winsock ;
+ H{ } clone pending-overlapped set-global ;
ERROR: invalid-file-size n ;
\r
: make-token-privileges ( name ? -- obj )\r
"TOKEN_PRIVILEGES" <c-object>\r
- 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep\r
- "LUID_AND_ATTRIBUTES" malloc-array &free\r
+ 1 over set-TOKEN_PRIVILEGES-PrivilegeCount\r
+ "LUID_AND_ATTRIBUTES" malloc-object &free\r
over set-TOKEN_PRIVILEGES-Privileges\r
\r
swap [\r
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 ;
+windows.kernel32 windows.shell32 windows.types splitting
+continuations math.bitwise accessors init sets assocs
+classes.struct classes ;
IN: io.backend.windows
TUPLE: win32-handle < disposable handle ;
} flags ; foldable
: default-security-attributes ( -- obj )
- "SECURITY_ATTRIBUTES" <c-object>
- "SECURITY_ATTRIBUTES" heap-size
- over set-SECURITY_ATTRIBUTES-nLength ;
+ SECURITY_ATTRIBUTES <struct>
+ SECURITY_ATTRIBUTES heap-size >>nLength ;
[ 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
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types io.directories.unix kernel system unix ;
+USING: alien.c-types io.directories.unix kernel system unix
+classes.struct ;
IN: io.directories.unix.linux
-M: unix find-next-file ( DIR* -- byte-array )
- "dirent" <c-object>
+M: unix find-next-file ( DIR* -- dirent )
+ dirent <struct>
f <void*>
[ readdir64_r 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;
continuations destructors fry io io.backend io.backend.unix
io.directories io.encodings.binary io.encodings.utf8 io.files
io.pathnames io.files.types kernel math.bitwise sequences system
-unix unix.stat vocabs.loader ;
+unix unix.stat vocabs.loader classes.struct ;
IN: io.directories.unix
: touch-mode ( -- n )
HOOK: find-next-file os ( DIR* -- byte-array )
M: unix find-next-file ( DIR* -- byte-array )
- "dirent" <c-object>
+ dirent <struct>
f <void*>
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;
M: unix >directory-entry ( byte-array -- directory-entry )
{
- [ dirent-d_name utf8 alien>string ]
- [ dirent-d_type dirent-type>file-type ]
+ [ d_name>> underlying>> utf8 alien>string ]
+ [ d_type>> dirent-type>file-type ]
} cleave directory-entry boa ;
M: unix (directory-entries) ( path -- seq )
io.pathnames io.backend io.files.windows destructors
kernel accessors calendar windows windows.errors
windows.kernel32 alien.c-types sequences splitting
-fry continuations ;
+fry continuations classes.struct ;
IN: io.directories.windows
M: windows touch-file ( path -- )
RemoveDirectory win32-error=0/f ;
: find-first-file ( path -- WIN32_FIND_DATA handle )
- "WIN32_FIND_DATA" <c-object>
+ WIN32_FIND_DATA <struct>
[ nip ] [ FindFirstFile ] 2bi
[ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
: find-next-file ( path -- WIN32_FIND_DATA/f )
- "WIN32_FIND_DATA" <c-object>
+ WIN32_FIND_DATA <struct>
[ nip ] [ FindNextFile ] 2bi 0 = [
GetLastError ERROR_NO_MORE_FILES = [
win32-error
TUPLE: windows-directory-entry < directory-entry attributes ;
M: windows >directory-entry ( byte-array -- directory-entry )
- [ WIN32_FIND_DATA-cFileName utf16n alien>string ]
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
- tri
+ [ cFileName>> utf16n alien>string ]
+ [
+ dwFileAttributes>>
+ [ win32-file-type ] [ win32-file-attributes ] bi
+ ] bi
dupd remove windows-directory-entry boa ;
M: windows (directory-entries) ( path -- seq )
M: bsd stat>file-info ( stat -- file-info )
[ call-next-method ] keep
{
- [ stat-st_flags >>flags ]
- [ stat-st_gen >>gen ]
- [
- stat-st_birthtimespec timespec>unix-time
- >>birth-time
- ]
+ [ st_flags>> >>flags ]
+ [ st_gen>> >>gen ]
+ [ st_birthtimespec>> timespec>unix-time >>birth-time ]
} cleave ;
io.backend io.files io.files.info io.files.unix kernel math system unix
unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
sequences grouping alien.strings io.encodings.utf8 unix.types
-specialized-arrays.direct.uint arrays io.files.info.unix ;
+arrays io.files.info.unix classes.struct
+specialized-arrays ;
+SPECIALIZED-ARRAY: statfs
IN: io.files.info.unix.freebsd
TUPLE: freebsd-file-system-info < unix-file-system-info
M: freebsd new-file-system-info freebsd-file-system-info new ;
M: freebsd file-system-statfs ( path -- byte-array )
- "statfs" <c-object> [ statfs io-error ] keep ;
+ \ statfs <struct> [ statfs io-error ] keep ;
M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
- [ statfs-f_version >>version ]
- [ statfs-f_type >>type ]
- [ statfs-f_flags >>flags ]
- [ statfs-f_bsize >>block-size ]
- [ statfs-f_iosize >>io-size ]
- [ statfs-f_blocks >>blocks ]
- [ statfs-f_bfree >>blocks-free ]
- [ statfs-f_bavail >>blocks-available ]
- [ statfs-f_files >>files ]
- [ statfs-f_ffree >>files-free ]
- [ statfs-f_syncwrites >>syncwrites ]
- [ statfs-f_asyncwrites >>asyncwrites ]
- [ statfs-f_syncreads >>syncreads ]
- [ statfs-f_asyncreads >>asyncreads ]
- [ statfs-f_namemax >>name-max ]
- [ statfs-f_owner >>owner ]
- [ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
- [ statfs-f_fstypename utf8 alien>string >>type ]
- [ statfs-f_mntfromname utf8 alien>string >>device-name ]
- [ statfs-f_mntonname utf8 alien>string >>mount-point ]
+ [ f_version>> >>version ]
+ [ f_type>> >>type ]
+ [ f_flags>> >>flags ]
+ [ f_bsize>> >>block-size ]
+ [ f_iosize>> >>io-size ]
+ [ f_blocks>> >>blocks ]
+ [ f_bfree>> >>blocks-free ]
+ [ f_bavail>> >>blocks-available ]
+ [ f_files>> >>files ]
+ [ f_ffree>> >>files-free ]
+ [ f_syncwrites>> >>syncwrites ]
+ [ f_asyncwrites>> >>asyncwrites ]
+ [ f_syncreads>> >>syncreads ]
+ [ f_asyncreads>> >>asyncreads ]
+ [ f_namemax>> >>name-max ]
+ [ f_owner>> >>owner ]
+ [ f_fsid>> >>id ]
+ [ f_fstypename>> utf8 alien>string >>type ]
+ [ f_mntfromname>> utf8 alien>string >>device-name ]
+ [ f_mntonname>> utf8 alien>string >>mount-point ]
} cleave ;
M: freebsd file-system-statvfs ( path -- byte-array )
- "statvfs" <c-object> [ statvfs io-error ] keep ;
+ \ statvfs <struct> [ statvfs io-error ] keep ;
M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
- [ statvfs-f_favail >>files-available ]
- [ statvfs-f_frsize >>preferred-block-size ]
+ [ f_favail>> >>files-available ]
+ [ f_frsize>> >>preferred-block-size ]
} cleave ;
M: freebsd file-systems ( -- array )
f 0 0 getfsstat dup io-error
- "statfs" <c-array> dup dup length 0 getfsstat io-error
- "statfs" heap-size group
- [ statfs-f_mntonname alien>native-string file-system-info ] map ;
+ <statfs-array>
+ [ dup byte-length 0 getfsstat io-error ]
+ [ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ;
io.backend io.encodings.utf8 io.files io.files.info io.streams.string
io.files.unix kernel math.order namespaces sequences sorting
system unix unix.statfs.linux unix.statvfs.linux io.files.links
-specialized-arrays.direct.uint arrays io.files.info.unix assocs
-io.pathnames unix.types ;
+arrays io.files.info.unix assocs io.pathnames unix.types
+classes.struct ;
FROM: csv => delimiter ;
IN: io.files.info.unix.linux
M: linux new-file-system-info linux-file-system-info new ;
M: linux file-system-statfs ( path -- byte-array )
- "statfs64" <c-object> [ statfs64 io-error ] keep ;
+ \ statfs64 <struct> [ statfs64 io-error ] keep ;
M: linux statfs>file-system-info ( struct -- statfs )
{
- [ statfs64-f_type >>type ]
- [ statfs64-f_bsize >>block-size ]
- [ statfs64-f_blocks >>blocks ]
- [ statfs64-f_bfree >>blocks-free ]
- [ statfs64-f_bavail >>blocks-available ]
- [ statfs64-f_files >>files ]
- [ statfs64-f_ffree >>files-free ]
- [ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
- [ statfs64-f_namelen >>namelen ]
- [ statfs64-f_frsize >>preferred-block-size ]
+ [ f_type>> >>type ]
+ [ f_bsize>> >>block-size ]
+ [ f_blocks>> >>blocks ]
+ [ f_bfree>> >>blocks-free ]
+ [ f_bavail>> >>blocks-available ]
+ [ f_files>> >>files ]
+ [ f_ffree>> >>files-free ]
+ [ f_fsid>> >>id ]
+ [ f_namelen>> >>namelen ]
+ [ f_frsize>> >>preferred-block-size ]
! [ statfs64-f_spare >>spare ]
} cleave ;
M: linux file-system-statvfs ( path -- byte-array )
- "statvfs64" <c-object> [ statvfs64 io-error ] keep ;
+ \ statvfs64 <struct> [ statvfs64 io-error ] keep ;
M: linux statvfs>file-system-info ( struct -- statfs )
{
- [ statvfs64-f_flag >>flags ]
- [ statvfs64-f_namemax >>name-max ]
+ [ f_flag>> >>flags ]
+ [ f_namemax>> >>name-max ]
} cleave ;
TUPLE: mtab-entry file-system-name mount-point type options
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings combinators
-grouping io.encodings.utf8 io.files kernel math sequences
-system unix io.files.unix specialized-arrays.direct.uint arrays
-unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx
-io.files.info.unix io.files.info ;
+grouping io.encodings.utf8 io.files kernel math sequences system
+unix io.files.unix arrays unix.statfs.macosx unix.statvfs.macosx
+unix.getfsstat.macosx io.files.info.unix io.files.info
+classes.struct specialized-arrays ;
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: statfs64
IN: io.files.info.unix.macosx
TUPLE: macosx-file-system-info < unix-file-system-info
M: macosx file-systems ( -- array )
f <void*> dup 0 getmntinfo64 dup io-error
- [ *void* ] dip
- "statfs64" heap-size [ * memory>byte-array ] keep group
- [ statfs64-f_mntonname utf8 alien>string file-system-info ] map ;
- ! [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
+ [ *void* ] dip <direct-statfs64-array>
+ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ;
M: macosx new-file-system-info macosx-file-system-info new ;
M: macosx file-system-statfs ( normalized-path -- statfs )
- "statfs64" <c-object> [ statfs64 io-error ] keep ;
+ \ statfs64 <struct> [ statfs64 io-error ] keep ;
M: macosx file-system-statvfs ( normalized-path -- statvfs )
- "statvfs" <c-object> [ statvfs io-error ] keep ;
+ \ statvfs <struct> [ statvfs io-error ] keep ;
M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{
- [ statfs64-f_bsize >>block-size ]
- [ statfs64-f_iosize >>io-size ]
- [ statfs64-f_blocks >>blocks ]
- [ statfs64-f_bfree >>blocks-free ]
- [ statfs64-f_bavail >>blocks-available ]
- [ statfs64-f_files >>files ]
- [ statfs64-f_ffree >>files-free ]
- [ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
- [ statfs64-f_owner >>owner ]
- [ statfs64-f_type >>type-id ]
- [ statfs64-f_flags >>flags ]
- [ statfs64-f_fssubtype >>filesystem-subtype ]
- [ statfs64-f_fstypename utf8 alien>string >>type ]
- [ statfs64-f_mntonname utf8 alien>string >>mount-point ]
- [ statfs64-f_mntfromname utf8 alien>string >>device-name ]
+ [ f_bsize>> >>block-size ]
+ [ f_iosize>> >>io-size ]
+ [ f_blocks>> >>blocks ]
+ [ f_bfree>> >>blocks-free ]
+ [ f_bavail>> >>blocks-available ]
+ [ f_files>> >>files ]
+ [ f_ffree>> >>files-free ]
+ [ f_fsid>> >>id ]
+ [ f_owner>> >>owner ]
+ [ f_type>> >>type-id ]
+ [ f_flags>> >>flags ]
+ [ f_fssubtype>> >>filesystem-subtype ]
+ [ f_fstypename>> utf8 alien>string >>type ]
+ [ f_mntonname>> utf8 alien>string >>mount-point ]
+ [ f_mntfromname>> utf8 alien>string >>device-name ]
} cleave ;
M: macosx statvfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{
- [ statvfs-f_frsize >>preferred-block-size ]
- [ statvfs-f_favail >>files-available ]
- [ statvfs-f_namemax >>name-max ]
+ [ f_frsize>> >>preferred-block-size ]
+ [ f_favail>> >>files-available ]
+ [ f_namemax>> >>name-max ]
} cleave ;
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types io.files.unix
io.files io.files.info unix.statvfs.netbsd unix.getfsstat.netbsd arrays
-grouping sequences io.encodings.utf8
-specialized-arrays.direct.uint io.files.info.unix ;
+grouping sequences io.encodings.utf8 classes.struct
+specialized-arrays io.files.info.unix ;
+SPECIALIZED-ARRAY: statvfs
IN: io.files.info.unix.netbsd
TUPLE: netbsd-file-system-info < unix-file-system-info
M: netbsd new-file-system-info netbsd-file-system-info new ;
M: netbsd file-system-statvfs
- "statvfs" <c-object> [ statvfs io-error ] keep ;
+ \ statvfs <struct> [ statvfs io-error ] keep ;
M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{
- [ statvfs-f_flag >>flags ]
- [ statvfs-f_bsize >>block-size ]
- [ statvfs-f_frsize >>preferred-block-size ]
- [ statvfs-f_iosize >>io-size ]
- [ statvfs-f_blocks >>blocks ]
- [ statvfs-f_bfree >>blocks-free ]
- [ statvfs-f_bavail >>blocks-available ]
- [ statvfs-f_bresvd >>blocks-reserved ]
- [ statvfs-f_files >>files ]
- [ statvfs-f_ffree >>files-free ]
- [ statvfs-f_favail >>files-available ]
- [ statvfs-f_fresvd >>files-reserved ]
- [ statvfs-f_syncreads >>sync-reads ]
- [ statvfs-f_syncwrites >>sync-writes ]
- [ statvfs-f_asyncreads >>async-reads ]
- [ statvfs-f_asyncwrites >>async-writes ]
- [ statvfs-f_fsidx 2 <direct-uint-array> >array >>idx ]
- [ statvfs-f_fsid >>id ]
- [ statvfs-f_namemax >>name-max ]
- [ statvfs-f_owner >>owner ]
- ! [ statvfs-f_spare >>spare ]
- [ statvfs-f_fstypename utf8 alien>string >>type ]
- [ statvfs-f_mntonname utf8 alien>string >>mount-point ]
- [ statvfs-f_mntfromname utf8 alien>string >>device-name ]
+ [ f_flag>> >>flags ]
+ [ f_bsize>> >>block-size ]
+ [ f_frsize>> >>preferred-block-size ]
+ [ f_iosize>> >>io-size ]
+ [ f_blocks>> >>blocks ]
+ [ f_bfree>> >>blocks-free ]
+ [ f_bavail>> >>blocks-available ]
+ [ f_bresvd>> >>blocks-reserved ]
+ [ f_files>> >>files ]
+ [ f_ffree>> >>files-free ]
+ [ f_favail>> >>files-available ]
+ [ f_fresvd>> >>files-reserved ]
+ [ f_syncreads>> >>sync-reads ]
+ [ f_syncwrites>> >>sync-writes ]
+ [ f_asyncreads>> >>async-reads ]
+ [ f_asyncwrites>> >>async-writes ]
+ [ f_fsidx>> >>idx ]
+ [ f_fsid>> >>id ]
+ [ f_namemax>> >>name-max ]
+ [ f_owner>> >>owner ]
+ [ f_fstypename>> utf8 alien>string >>type ]
+ [ f_mntonname>> utf8 alien>string >>mount-point ]
+ [ f_mntfromname>> utf8 alien>string >>device-name ]
} cleave ;
M: netbsd file-systems ( -- array )
f 0 0 getvfsstat dup io-error
- "statvfs" <c-array> dup dup length 0 getvfsstat io-error
- "statvfs" heap-size group
- [ statvfs-f_mntonname utf8 alien>string file-system-info ] map ;
+ <statvfs-array>
+ [ dup byte-length 0 getvfsstat io-error ]
+ [ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ;
combinators io.backend io.files io.files.info io.files.unix kernel math
sequences system unix unix.getfsstat.openbsd grouping
unix.statfs.openbsd unix.statvfs.openbsd unix.types
-specialized-arrays.direct.uint arrays io.files.info.unix ;
+arrays io.files.info.unix classes.struct
+specialized-arrays io.encodings.utf8 ;
+SPECIALIZED-ARRAY: statfs
IN: io.files.unix.openbsd
-TUPLE: freebsd-file-system-info < unix-file-system-info
+TUPLE: openbsd-file-system-info < unix-file-system-info
io-size sync-writes sync-reads async-writes async-reads
owner ;
-M: openbsd new-file-system-info freebsd-file-system-info new ;
+M: openbsd new-file-system-info openbsd-file-system-info new ;
M: openbsd file-system-statfs
- "statfs" <c-object> [ statfs io-error ] keep ;
+ \ statfs <struct> [ statfs io-error ] keep ;
M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' )
{
- [ statfs-f_flags >>flags ]
- [ statfs-f_bsize >>block-size ]
- [ statfs-f_iosize >>io-size ]
- [ statfs-f_blocks >>blocks ]
- [ statfs-f_bfree >>blocks-free ]
- [ statfs-f_bavail >>blocks-available ]
- [ statfs-f_files >>files ]
- [ statfs-f_ffree >>files-free ]
- [ statfs-f_favail >>files-available ]
- [ statfs-f_syncwrites >>sync-writes ]
- [ statfs-f_syncreads >>sync-reads ]
- [ statfs-f_asyncwrites >>async-writes ]
- [ statfs-f_asyncreads >>async-reads ]
- [ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
- [ statfs-f_namemax >>name-max ]
- [ statfs-f_owner >>owner ]
- ! [ statfs-f_spare >>spare ]
- [ statfs-f_fstypename alien>native-string >>type ]
- [ statfs-f_mntonname alien>native-string >>mount-point ]
- [ statfs-f_mntfromname alien>native-string >>device-name ]
+ [ f_flags>> >>flags ]
+ [ f_bsize>> >>block-size ]
+ [ f_iosize>> >>io-size ]
+ [ f_blocks>> >>blocks ]
+ [ f_bfree>> >>blocks-free ]
+ [ f_bavail>> >>blocks-available ]
+ [ f_files>> >>files ]
+ [ f_ffree>> >>files-free ]
+ [ f_favail>> >>files-available ]
+ [ f_syncwrites>> >>sync-writes ]
+ [ f_syncreads>> >>sync-reads ]
+ [ f_asyncwrites>> >>async-writes ]
+ [ f_asyncreads>> >>async-reads ]
+ [ f_fsid>> >>id ]
+ [ f_namemax>> >>name-max ]
+ [ f_owner>> >>owner ]
+ [ f_fstypename>> utf8 alien>string >>type ]
+ [ f_mntonname>> utf8 alien>string >>mount-point ]
+ [ f_mntfromname>> utf8 alien>string >>device-name ]
} cleave ;
M: openbsd file-system-statvfs ( normalized-path -- statvfs )
- "statvfs" <c-object> [ statvfs io-error ] keep ;
+ \ statvfs <struct> [ statvfs io-error ] keep ;
M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
- {
- [ statvfs-f_frsize >>preferred-block-size ]
- } cleave ;
+ f_frsize>> >>preferred-block-size ;
M: openbsd file-systems ( -- seq )
f 0 0 getfsstat dup io-error
- "statfs" <c-array> dup dup length 0 getfsstat io-error
- "statfs" heap-size group
- [ statfs-f_mntonname alien>native-string file-system-info ] map ;
+ <statfs-array>
+ [ dup byte-length 0 getfsstat io-error ]
+ [ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ;
USING: accessors kernel system math math.bitwise strings arrays
sequences combinators combinators.short-circuit alien.c-types
vocabs.loader calendar calendar.unix io.files.info
-io.files.types io.backend io.directories unix unix.stat unix.time unix.users
-unix.groups ;
+io.files.types io.backend io.directories unix unix.stat
+unix.time unix.users unix.groups classes.struct
+specialized-arrays ;
+SPECIALIZED-ARRAY: timeval
IN: io.files.info.unix
TUPLE: unix-file-system-info < file-system-info
[ new-file-info ] dip
{
[ stat>type >>type ]
- [ stat-st_size >>size ]
- [ stat-st_mode >>permissions ]
- [ stat-st_ctimespec timespec>unix-time >>created ]
- [ stat-st_mtimespec timespec>unix-time >>modified ]
- [ stat-st_atimespec timespec>unix-time >>accessed ]
- [ stat-st_uid >>uid ]
- [ stat-st_gid >>gid ]
- [ stat-st_dev >>dev ]
- [ stat-st_ino >>ino ]
- [ stat-st_nlink >>nlink ]
- [ stat-st_rdev >>rdev ]
- [ stat-st_blocks >>blocks ]
- [ stat-st_blksize >>blocksize ]
+ [ st_size>> >>size ]
+ [ st_mode>> >>permissions ]
+ [ st_ctimespec>> timespec>unix-time >>created ]
+ [ st_mtimespec>> timespec>unix-time >>modified ]
+ [ st_atimespec>> timespec>unix-time >>accessed ]
+ [ st_uid>> >>uid ]
+ [ st_gid>> >>gid ]
+ [ st_dev>> >>dev ]
+ [ st_ino>> >>ino ]
+ [ st_nlink>> >>nlink ]
+ [ st_rdev>> >>rdev ]
+ [ st_blocks>> >>blocks ]
+ [ st_blksize>> >>blocksize ]
[ drop dup blocks>> standard-unix-block-size * >>size-on-disk ]
} cleave ;
} case ;
M: unix stat>type ( stat -- type )
- stat-st_mode n>file-type ;
+ st_mode>> n>file-type ;
<PRIVATE
: stat-mode ( path -- mode )
- normalize-path file-status stat-st_mode ;
+ normalize-path file-status st_mode>> ;
: chmod-set-bit ( path mask ? -- )
[ dup stat-mode ] 2dip
<PRIVATE
-: make-timeval-array ( array -- byte-array )
- [ [ "timeval" <c-object> ] unless* ] map concat ;
-
: timestamp>timeval ( timestamp -- timeval )
unix-1970 time- duration>microseconds make-timeval ;
: timestamps>byte-array ( timestamps -- byte-array )
- [ dup [ timestamp>timeval ] when ] map make-timeval-array ;
+ [ [ timestamp>timeval ] [ \ timeval <struct> ] if* ] map
+ >timeval-array ;
PRIVATE>
f swap 2array set-file-times ;
: set-file-ids ( path uid gid -- )
- [ normalize-path ] 2dip
- [ [ -1 ] unless* ] bi@ chown io-error ;
+ [ normalize-path ] 2dip [ -1 or ] bi@ chown io-error ;
GENERIC: set-file-user ( path string/id -- )
--- /dev/null
+! 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
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
+specialized-arrays ;
+SPECIALIZED-ARRAY: ushort
IN: io.files.info.windows
:: round-up-to ( n multiple -- n' )
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
[ \ windows-file-info new ] dip
{
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ]
- [
- [ WIN32_FIND_DATA-nFileSizeLow ]
- [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
- ]
- [ WIN32_FIND_DATA-dwFileAttributes >>permissions ]
- [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ]
- [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ]
- [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ]
+ [ dwFileAttributes>> win32-file-type >>type ]
+ [ dwFileAttributes>> win32-file-attributes >>attributes ]
+ [ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit >>size ]
+ [ dwFileAttributes>> >>permissions ]
+ [ ftCreationTime>> FILETIME>timestamp >>created ]
+ [ ftLastWriteTime>> FILETIME>timestamp >>modified ]
+ [ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
} cleave ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
- "WIN32_FIND_DATA" <c-object> [
+ WIN32_FIND_DATA <struct> [
FindFirstFile
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
FindClose win32-error=0/f
: 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 ]
- [
- [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
- [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
- ]
- [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ]
+ [ dwFileAttributes>> win32-file-type >>type ]
+ [ dwFileAttributes>> win32-file-attributes >>attributes ]
[
- BY_HANDLE_FILE_INFORMATION-ftCreationTime
- FILETIME>timestamp >>created
+ [ nFileSizeLow>> ]
+ [ nFileSizeHigh>> ] bi >64bit >>size
]
- [
- 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 ;
file-info ;
: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
- MAX_PATH 1 + [ <byte-array> ] keep
+ MAX_PATH 1 + [ <ushort-array> ] keep
"DWORD" <c-object>
"DWORD" <c-object>
"DWORD" <c-object>
- MAX_PATH 1 + [ <byte-array> ] keep
+ MAX_PATH 1 + [ <ushort-array> ] keep
[ GetVolumeInformation win32-error=0/f ] 7 nkeep
drop 5 nrot drop
[ utf16n alien>string ] 4 ndip
[ first Letter? ]
} 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
-M: winnt file-system-info ( path -- file-system-info )
- normalize-path root-directory
+<PRIVATE
+
+: (file-system-info) ( path -- file-system-info )
dup [ volume-information ] [ file-system-space ] bi
\ win32-file-system-info new
swap *ulonglong >>free-space
swap >>mount-point
calculate-file-system-info ;
+PRIVATE>
+
+M: winnt file-system-info ( path -- file-system-info )
+ normalize-path root-directory (file-system-info) ;
+
: volume>paths ( string -- array )
- 16384 "ushort" <c-array> tuck dup length
+ 16384 <ushort-array> tuck dup length
0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
win32-error-string throw
] [
] if ;
: find-first-volume ( -- string handle )
- MAX_PATH 1 + [ <byte-array> ] keep
+ MAX_PATH 1 + [ <ushort-array> ] keep
dupd
FindFirstVolume dup win32-error=0/f
[ utf16n alien>string ] dip ;
: find-next-volume ( handle -- string/f )
- MAX_PATH 1 + [ <byte-array> tuck ] keep
+ MAX_PATH 1 + [ <ushort-array> tuck ] keep
FindNextVolume 0 = [
GetLastError ERROR_NO_MORE_FILES =
[ drop f ] [ win32-error-string throw ] if
M: winnt file-systems ( -- array )
find-volumes [ volume>paths ] map
concat [
- [ file-system-info ]
+ [ (file-system-info) ]
[ drop \ file-system-info new swap >>mount-point ] recover
] map ;
: 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 ;
alien.c-types alien.arrays alien.strings sequences combinators
combinators.short-circuit ascii splitting alien strings assocs
namespaces make accessors tr windows.time windows.shell32
-windows.errors ;
+windows.errors specialized-arrays classes.struct ;
+SPECIALIZED-ARRAY: ushort
IN: io.files.windows.nt
M: winnt cwd
- MAX_UNICODE_PATH dup "ushort" <c-array>
+ MAX_UNICODE_PATH dup <ushort-array>
[ GetCurrentDirectory win32-error=0/f ] keep
utf16n alien>string ;
M: winnt cd
SetCurrentDirectory win32-error=0/f ;
-: unicode-prefix ( -- seq )
- "\\\\?\\" ; inline
+CONSTANT: unicode-prefix "\\\\?\\"
M: winnt root-directory? ( path -- ? )
{
<PRIVATE
: windows-file-size ( path -- size )
- normalize-path 0 "WIN32_FILE_ATTRIBUTE_DATA" <c-object>
+ normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
[ GetFileAttributesEx win32-error=0/f ] keep
- [ WIN32_FILE_ATTRIBUTE_DATA-nFileSizeLow ]
- [ WIN32_FILE_ATTRIBUTE_DATA-nFileSizeHigh ] bi >64bit ;
+ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ;
PRIVATE>
console-vm "-run=listener" 2array >>command
+closed+ >>stdin
+stdout+ >>stderr
- ascii [ contents ] with-process-reader
+ ascii [ lines last ] with-process-reader
] unit-test
: launcher-test-path ( -- str )
[ "( scratchpad ) " ] [
console-vm "-run=listener" 2array
- ascii [ "USE: system 0 exit" print flush readln ] with-process-stream
+ ascii [ "USE: system 0 exit" print flush lines last ] with-process-stream
] unit-test
[ ] [
: redirect-stderr ( process args -- handle )
over stderr>> +stdout+ eq? [
nip
- lpStartupInfo>> STARTUPINFO-hStdOutput
+ lpStartupInfo>> hStdOutput>>
] [
drop
stderr>>
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 ;
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations io
-io.backend.windows io.pipes.windows.nt io.pathnames libc io.ports
-windows.types math windows.kernel32
-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 ;
+io.backend.windows io.pipes.windows.nt io.pathnames libc
+io.ports windows.types math windows.kernel32 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 classes classes.struct specialized-arrays ;
+SPECIALIZED-ARRAY: ushort
+SPECIALIZED-ARRAY: void*
IN: io.launcher.windows
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 ;
] 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 -- )
] 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 ;
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
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.alien ;
-IN: io.mmap.alien
-
-<< "void*" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.bool ;
-IN: io.mmap.bool
-
-<< "bool" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.char ;
-IN: io.mmap.char
-
-<< "char" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.double ;
-IN: io.mmap.double
-
-<< "double" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.float ;
-IN: io.mmap.float
-
-<< "float" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io.mmap functors accessors alien.c-types math kernel
-words fry ;
-IN: io.mmap.functor
-
-SLOT: address
-SLOT: length
-
-: mapped-file>direct ( mapped-file type -- alien length )
- [ [ address>> ] [ length>> ] bi ] dip
- heap-size [ 1 - + ] keep /i ;
-
-FUNCTOR: define-mapped-array ( T -- )
-
-<mapped-A> DEFINES <mapped-${T}-array>
-<A> IS <direct-${T}-array>
-with-mapped-A-file DEFINES with-mapped-${T}-file
-with-mapped-A-file-reader DEFINES with-mapped-${T}-file-reader
-
-WHERE
-
-: <mapped-A> ( mapped-file -- direct-array )
- T mapped-file>direct <A> ; inline
-
-: with-mapped-A-file ( path quot -- )
- '[ <mapped-A> @ ] with-mapped-file ; inline
-
-: with-mapped-A-file-reader ( path quot -- )
- '[ <mapped-A> @ ] with-mapped-file-reader ; inline
-
-;FUNCTOR
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.int ;
-IN: io.mmap.int
-
-<< "int" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.long ;
-IN: io.mmap.long
-
-<< "long" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.longlong ;
-IN: io.mmap.longlong
-
-<< "longlong" define-mapped-array >>
\ No newline at end of file
-USING: io io.mmap io.mmap.char io.files io.files.temp
+USING: io io.mmap io.files io.files.temp
io.directories kernel tools.test continuations sequences
io.encodings.ascii accessors math ;
IN: io.mmap.tests
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
-[ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file-reader ] unit-test
+[ ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> length ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> length ] with-mapped-file-reader ] unit-test
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
-! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
+! Copyright (C) 2007, 2009 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors io.files io.files.info
io.backend kernel quotations system alien alien.accessors
: <mapped-file> ( path -- mmap )
[ (mapped-file-r/w) ] prepare-mapped-file ;
+: <mapped-array> ( mmap c-type -- direct-array )
+ [ [ address>> ] [ length>> ] bi ] dip
+ [ heap-size /i ] keep
+ <c-direct-array> ; inline
+
HOOK: close-mapped-file io-backend ( mmap -- )
M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.short ;
-IN: io.mmap.short
-
-<< "short" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.uchar ;
-IN: io.mmap.uchar
-
-<< "uchar" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.uint ;
-IN: io.mmap.uint
-
-<< "uint" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.ulong ;
-IN: io.mmap.ulong
-
-<< "ulong" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.ulonglong ;
-IN: io.mmap.ulonglong
-
-<< "ulonglong" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.direct.ushort ;
-IN: io.mmap.ushort
-
-<< "ushort" define-mapped-array >>
\ No newline at end of file
io.backend.unix io.encodings.utf8 unix.linux.inotify assocs
namespaces make threads continuations init math math.bitwise
sets alien alien.strings alien.c-types vocabs.loader accessors
-system hashtables destructors unix ;
+system hashtables destructors unix classes.struct ;
IN: io.monitors.linux
SYMBOL: watches
] { } make prune ;
: parse-event-name ( event -- name )
- dup inotify-event-len zero?
- [ drop "" ] [ inotify-event-name utf8 alien>string ] if ;
+ dup len>> zero?
+ [ drop "" ] [ name>> utf8 alien>string ] if ;
: parse-file-notify ( buffer -- path changed )
- dup inotify-event-mask ignore-flags? [
+ dup mask>> ignore-flags? [
drop f f
] [
- [ parse-event-name ] [ inotify-event-mask parse-action ] bi
+ [ parse-event-name ] [ mask>> parse-action ] bi
] if ;
: events-exhausted? ( i buffer -- ? )
fill>> >= ;
-: inotify-event@ ( i buffer -- alien )
- ptr>> <displaced-alien> ;
+: inotify-event@ ( i buffer -- inotify-event )
+ ptr>> <displaced-alien> inotify-event memory>struct ;
: next-event ( i buffer -- i buffer )
2dup inotify-event@
- inotify-event-len "inotify-event" heap-size +
+ len>> inotify-event heap-size +
swap [ + ] dip ;
: parse-file-notifications ( i buffer -- )
2dup events-exhausted? [ 2drop ] [
- 2dup inotify-event@ dup inotify-event-wd wd>monitor
+ 2dup inotify-event@ dup wd>> wd>monitor
[ parse-file-notify ] dip queue-change
next-event parse-file-notifications
] if ;
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
io.buffers io.files io.timeouts io.encodings.string
io.encodings.utf16n io windows.errors windows.kernel32 windows.types
-io.pathnames ;
+io.pathnames classes.struct ;
IN: io.monitors.windows.nt
: open-directory ( path -- handle )
memory>byte-array utf16n decode ;
: parse-notify-record ( buffer -- path changed )
- [
- [ FILE_NOTIFY_INFORMATION-FileName ]
- [ FILE_NOTIFY_INFORMATION-FileNameLength ]
- bi memory>u16-string
- ]
- [ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ;
+ [ [ FileName>> ] [ FileNameLength>> ] bi memory>u16-string ]
+ [ Action>> parse-action ] bi ;
: (file-notify-records) ( buffer -- buffer )
+ FILE_NOTIFY_INFORMATION memory>struct
dup ,
- dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [
- [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien>
+ dup NextEntryOffset>> zero? [
+ [ NextEntryOffset>> ] [ >c-ptr <displaced-alien> ] bi
(file-notify-records)
] unless ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel unix math sequences
-io.backend.unix io.ports specialized-arrays.int accessors ;
-IN: io.pipes.unix
+io.backend.unix io.ports specialized-arrays accessors ;
QUALIFIED: io.pipes
+SPECIALIZED-ARRAY: int
+IN: io.pipes.unix
M: unix io.pipes:(pipe) ( -- pair )
2 <int-array>
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces continuations
-destructors io debugger io.sockets sequences summary calendar
-delegate system vocabs.loader combinators present ;
+USING: accessors kernel namespaces continuations destructors io
+debugger io.sockets io.sockets.private sequences summary
+calendar delegate system vocabs.loader combinators present ;
IN: io.sockets.secure
SYMBOL: secure-socket-timeout
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors unix byte-arrays kernel sequences
-namespaces math math.order combinators init alien alien.c-types
+USING: accessors unix byte-arrays kernel sequences namespaces
+math math.order combinators init alien alien.c-types
alien.strings libc continuations destructors openssl
openssl.libcrypto openssl.libssl io io.files io.ports
io.backend.unix io.sockets.unix io.encodings.ascii io.buffers
-io.sockets io.sockets.secure io.sockets.secure.openssl
-io.timeouts system summary fry ;
+io.sockets io.sockets.private io.sockets.secure
+io.sockets.secure.openssl io.timeouts system summary fry ;
FROM: io.ports => shutdown ;
IN: io.sockets.secure.unix
IN: io.sockets.tests
-USING: io.sockets sequences math tools.test namespaces accessors
-kernel destructors calendar io.timeouts io.encodings.utf8 io
-concurrency.promises threads io.streams.string ;
+USING: io.sockets io.sockets.private sequences math tools.test
+namespaces accessors kernel destructors calendar io.timeouts
+io.encodings.utf8 io concurrency.promises threads
+io.streams.string ;
[ B{ 1 2 3 4 } ]
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
arrays io.encodings io.ports io.streams.duplex io.encodings.ascii
alien.strings io.binary accessors destructors classes byte-arrays
parser alien.c-types math.parser splitting grouping math assocs
-summary system vocabs.loader combinators present fry vocabs.parser ;
+summary system vocabs.loader combinators present fry vocabs.parser
+classes.struct ;
IN: io.sockets
<< {
} cond use-vocab >>
! Addressing
+<PRIVATE
+
GENERIC: protocol-family ( addrspec -- af )
GENERIC: sockaddr-size ( addrspec -- n )
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
-TUPLE: local path ;
+HOOK: sockaddr-of-family os ( alien af -- sockaddr )
-: <local> ( path -- addrspec )
- normalize-path local boa ;
+HOOK: addrspec-of-family os ( af -- addrspec )
-M: local present path>> "Unix domain socket: " prepend ;
+PRIVATE>
TUPLE: abstract-inet host port ;
M: abstract-inet present
[ host>> ":" ] [ port>> number>string ] bi 3append ;
+TUPLE: local path ;
+
+: <local> ( path -- addrspec )
+ normalize-path local boa ;
+
+M: local present path>> "Unix domain socket: " prepend ;
+
TUPLE: inet4 < abstract-inet ;
C: <inet4> inet4
M: inet4 protocol-family drop PF_INET ;
-M: inet4 sockaddr-size drop "sockaddr-in" heap-size ;
+M: inet4 sockaddr-size drop sockaddr-in heap-size ;
-M: inet4 empty-sockaddr drop "sockaddr-in" <c-object> ;
+M: inet4 empty-sockaddr drop sockaddr-in <struct> ;
M: inet4 make-sockaddr ( inet -- sockaddr )
- "sockaddr-in" <c-object>
- AF_INET over set-sockaddr-in-family
- over port>> htons over set-sockaddr-in-port
- over host>>
- "0.0.0.0" or
- rot inet-pton *uint over set-sockaddr-in-addr ;
+ sockaddr-in <struct>
+ AF_INET >>family
+ swap [ port>> htons >>port ]
+ [ host>> "0.0.0.0" or ]
+ [ inet-pton *uint >>addr ] tri ;
-M: inet4 parse-sockaddr
- [ dup sockaddr-in-addr <uint> ] dip inet-ntop
- swap sockaddr-in-port ntohs <inet4> ;
+M: inet4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
+ [ [ addr>> <uint> ] dip inet-ntop ]
+ [ drop port>> ntohs ] 2bi <inet4> ;
TUPLE: inet6 < abstract-inet ;
M: inet6 protocol-family drop PF_INET6 ;
-M: inet6 sockaddr-size drop "sockaddr-in6" heap-size ;
+M: inet6 sockaddr-size drop sockaddr-in6 heap-size ;
-M: inet6 empty-sockaddr drop "sockaddr-in6" <c-object> ;
+M: inet6 empty-sockaddr drop sockaddr-in6 <struct> ;
M: inet6 make-sockaddr ( inet -- sockaddr )
- "sockaddr-in6" <c-object>
- AF_INET6 over set-sockaddr-in6-family
- over port>> htons over set-sockaddr-in6-port
- over host>> "::" or
- rot inet-pton over set-sockaddr-in6-addr ;
+ sockaddr-in6 <struct>
+ AF_INET6 >>family
+ swap [ port>> htons >>port ]
+ [ host>> "::" or ]
+ [ inet-pton >>addr ] tri ;
M: inet6 parse-sockaddr
- [ dup sockaddr-in6-addr ] dip inet-ntop
- swap sockaddr-in6-port ntohs <inet6> ;
-
-: addrspec-of-family ( af -- addrspec )
- {
- { AF_INET [ T{ inet4 } ] }
- { AF_INET6 [ T{ inet6 } ] }
- { AF_UNIX [ T{ local } ] }
- [ drop f ]
- } case ;
+ [ [ addr>> ] dip inet-ntop ]
+ [ drop port>> ntohs ] 2bi <inet6> ;
M: f parse-sockaddr nip ;
+<PRIVATE
+
GENERIC: (get-local-address) ( handle remote -- sockaddr )
: get-local-address ( handle remote -- local )
2bi
] with-destructors ;
+TUPLE: server-port < port addr encoding ;
+
+: check-server-port ( port -- port )
+ dup check-disposed
+ dup server-port? [ "Not a server port" throw ] unless ; inline
+
+GENERIC: (server) ( addrspec -- handle )
+
+GENERIC: (accept) ( server addrspec -- handle sockaddr )
+
+TUPLE: datagram-port < port addr ;
+
+HOOK: (datagram) io-backend ( addr -- datagram )
+
+: check-datagram-port ( port -- port )
+ dup check-disposed
+ dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
+
+HOOK: (receive) io-backend ( datagram -- packet addrspec )
+
+: check-datagram-send ( packet addrspec port -- packet addrspec port )
+ check-datagram-port
+ 2dup addr>> [ class ] bi@ assert=
+ pick class byte-array assert= ;
+
+HOOK: (send) io-backend ( packet addrspec datagram -- )
+
+: addrinfo>addrspec ( addrinfo -- addrspec )
+ [ [ addr>> ] [ family>> ] bi sockaddr-of-family ]
+ [ family>> addrspec-of-family ] bi
+ parse-sockaddr ;
+
+: parse-addrinfo-list ( addrinfo -- seq )
+ [ next>> dup [ addrinfo memory>struct ] when ] follow
+ [ addrinfo>addrspec ] map
+ sift ;
+
+HOOK: addrinfo-error io-backend ( n -- )
+
+: resolve-passive-host ( -- addrspecs )
+ { T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ;
+
+: prepare-addrinfo ( -- addrinfo )
+ addrinfo <struct>
+ PF_UNSPEC >>family
+ IPPROTO_TCP >>protocol ;
+
+: fill-in-ports ( addrspecs port -- addrspecs )
+ '[ _ >>port ] map ;
+
+PRIVATE>
+
: <client> ( remote encoding -- stream local )
[ (client) ] dip swap [ <encoder-duplex> ] dip ;
] dip with-stream
] with-scope ; inline
-TUPLE: server-port < port addr encoding ;
-
-: check-server-port ( port -- port )
- dup check-disposed
- dup server-port? [ "Not a server port" throw ] unless ; inline
-
-GENERIC: (server) ( addrspec -- handle )
-
: <server> ( addrspec encoding -- server )
[
[ (server) ] keep
>>addr
] dip >>encoding ;
-GENERIC: (accept) ( server addrspec -- handle sockaddr )
-
: accept ( server -- client remote )
[
dup addr>>
<ports>
] keep encoding>> <encoder-duplex> swap ;
-TUPLE: datagram-port < port addr ;
-
-HOOK: (datagram) io-backend ( addr -- datagram )
-
: <datagram> ( addrspec -- datagram )
[
[ (datagram) |dispose ] keep
>>addr
] with-destructors ;
-: check-datagram-port ( port -- port )
- dup check-disposed
- dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
-
-HOOK: (receive) io-backend ( datagram -- packet addrspec )
-
: receive ( datagram -- packet addrspec )
check-datagram-port
[ (receive) ] [ addr>> ] bi parse-sockaddr ;
-: check-datagram-send ( packet addrspec port -- packet addrspec port )
- check-datagram-port
- 2dup addr>> [ class ] bi@ assert=
- pick class byte-array assert= ;
-
-HOOK: (send) io-backend ( packet addrspec datagram -- )
-
: send ( packet addrspec datagram -- )
check-datagram-send (send) ;
-: addrinfo>addrspec ( addrinfo -- addrspec )
- [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi
- parse-sockaddr ;
-
-: parse-addrinfo-list ( addrinfo -- seq )
- [ addrinfo-next ] follow
- [ addrinfo>addrspec ] map
- sift ;
-
-HOOK: addrinfo-error io-backend ( n -- )
-
GENERIC: resolve-host ( addrspec -- seq )
TUPLE: inet < abstract-inet ;
C: <inet> inet
-: resolve-passive-host ( -- addrspecs )
- { T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ;
-
-: prepare-addrinfo ( -- addrinfo )
- "addrinfo" <c-object>
- PF_UNSPEC over set-addrinfo-family
- IPPROTO_TCP over set-addrinfo-protocol ;
-
-: fill-in-ports ( addrspecs port -- addrspecs )
- '[ _ >>port ] map ;
-
M: inet resolve-host
[ port>> ] [ host>> ] bi [
f prepare-addrinfo f <void*>
- [ getaddrinfo addrinfo-error ] keep *void*
+ [ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct
[ parse-addrinfo-list ] keep freeaddrinfo
] [ resolve-passive-host ] if*
swap fill-in-ports ;
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings generic kernel math threads
-sequences byte-arrays io.binary io.backend.unix io.streams.duplex
-io.backend io.pathnames io.files.private io.encodings.utf8 math.parser
-continuations libc combinators system accessors destructors unix
-locals init ;
+USING: alien alien.c-types alien.strings generic kernel math
+threads sequences byte-arrays io.binary io.backend.unix
+io.streams.duplex io.backend io.pathnames io.sockets.private
+io.files.private io.encodings.utf8 math.parser continuations
+libc combinators system accessors destructors unix locals init
+classes.struct ;
EXCLUDE: namespaces => bind ;
EXCLUDE: io => read write ;
M: unix addrinfo-error ( n -- )
[ gai_strerror throw ] unless-zero ;
+M: unix sockaddr-of-family ( alien af -- addrspec )
+ {
+ { AF_INET [ sockaddr-in memory>struct ] }
+ { AF_INET6 [ sockaddr-in6 memory>struct ] }
+ { AF_UNIX [ sockaddr-un memory>struct ] }
+ [ 2drop f ]
+ } case ;
+
+M: unix addrspec-of-family ( af -- addrspec )
+ {
+ { AF_INET [ T{ inet4 } ] }
+ { AF_INET6 [ T{ inet6 } ] }
+ { AF_UNIX [ T{ local } ] }
+ [ drop f ]
+ } case ;
+
! Client sockets - TCP and Unix domain
M: object (get-local-address) ( handle remote -- sockaddr )
[ handle-fd ] dip empty-sockaddr/size <int>
: server-socket-fd ( addrspec type -- fd )
[ dup protocol-family ] dip socket-fd
- dup init-server-socket
- dup handle-fd rot make-sockaddr/size bind io-error ;
+ [ init-server-socket ] keep
+ [ handle-fd swap make-sockaddr/size bind io-error ] keep ;
M: object (server) ( addrspec -- handle )
[
[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-init-hook
:: do-receive ( port -- packet sockaddr )
- port addr>> empty-sockaddr/size [| sockaddr len |
- port handle>> handle-fd ! s
- receive-buffer get-global ! buf
- packet-size ! nbytes
- 0 ! flags
- sockaddr ! from
- len <int> ! fromlen
- recvfrom dup 0 >= [
- receive-buffer get-global swap memory>byte-array sockaddr
- ] [
- drop f f
- ] if
- ] call ;
+ port addr>> empty-sockaddr/size :> len :> sockaddr
+ port handle>> handle-fd ! s
+ receive-buffer get-global ! buf
+ packet-size ! nbytes
+ 0 ! flags
+ sockaddr ! from
+ len <int> ! fromlen
+ recvfrom dup 0 >=
+ [ receive-buffer get-global swap memory>byte-array sockaddr ]
+ [ drop f f ]
+ if ;
M: unix (receive) ( datagram -- packet sockaddr )
dup do-receive dup [ [ drop ] 2dip ] [
! Unix domain sockets
M: local protocol-family drop PF_UNIX ;
-M: local sockaddr-size drop "sockaddr-un" heap-size ;
+M: local sockaddr-size drop sockaddr-un heap-size ;
-M: local empty-sockaddr drop "sockaddr-un" <c-object> ;
+M: local empty-sockaddr drop sockaddr-un <struct> ;
M: local make-sockaddr
path>> (normalize-path)
dup length 1 + max-un-path > [ "Path too long" throw ] when
- "sockaddr-un" <c-object>
- AF_UNIX over set-sockaddr-un-family
- dup sockaddr-un-path rot utf8 string>alien dup length memcpy ;
+ sockaddr-un <struct>
+ AF_UNIX >>family
+ swap utf8 string>alien >>path ;
M: local parse-sockaddr
drop
- sockaddr-un-path utf8 alien>string <local> ;
+ path>> utf8 alien>string <local> ;
USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.ports io.timeouts io.sockets
-io namespaces io.streams.duplex io.backend.windows
-io.sockets.windows io.backend.windows.nt windows.winsock kernel
-libc math sequences threads system combinators accessors ;
+io.sockets.private io namespaces io.streams.duplex
+io.backend.windows io.sockets.windows io.backend.windows.nt
+windows.winsock kernel libc math sequences threads system
+combinators accessors classes.struct windows.kernel32 ;
IN: io.sockets.windows.nt
-: malloc-int ( object -- object )
- "int" heap-size malloc [ nip ] [ 0 set-alien-signed-4 ] 2bi ; inline
+: malloc-int ( n -- alien )
+ <int> malloc-byte-array ; inline
M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;
: get-ConnectEx-ptr ( socket -- void* )
SIO_GET_EXTENSION_FUNCTION_POINTER
WSAID_CONNECTEX
- "GUID" heap-size
+ GUID heap-size
"void*" <c-object>
[
"void*" heap-size
} cleave AcceptEx drop
winsock-error-string [ throw ] when* ; inline
+: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
+ f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
+
: extract-remote-address ( AcceptEx -- sockaddr )
- {
- [ lpOutputBuffer>> ]
- [ dwReceiveDataLength>> ]
- [ dwLocalAddressLength>> ]
- [ dwRemoteAddressLength>> ]
- } cleave
- f <void*>
- 0 <int>
- f <void*>
- [ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
+ [
+ {
+ [ lpOutputBuffer>> ]
+ [ dwReceiveDataLength>> ]
+ [ dwLocalAddressLength>> ]
+ [ dwRemoteAddressLength>> ]
+ } cleave
+ (extract-remote-address)
+ ] [ port>> addr>> protocol-family ] bi
+ sockaddr-of-family ; inline
M: object (accept) ( server addr -- handle sockaddr )
[
lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
: make-receive-buffer ( -- WSABUF )
- "WSABUF" malloc-object &free
- default-buffer-size get over set-WSABUF-len
- default-buffer-size get malloc &free over set-WSABUF-buf ; inline
+ WSABUF malloc-struct &free
+ default-buffer-size get
+ [ >>len ] [ malloc &free >>buf ] bi ; inline
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
WSARecvFrom-args new
} cleave WSARecvFrom socket-error* ; inline
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
- [ lpBuffers>> WSABUF-buf swap memory>byte-array ]
- [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
+ [ lpBuffers>> buf>> swap memory>byte-array ]
+ [
+ [ port>> addr>> empty-sockaddr dup ]
+ [ lpFrom>> ]
+ [ lpFromLen>> *int ]
+ tri memcpy
+ ] bi ; inline
M: winnt (receive) ( datagram -- packet addrspec )
[
dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
: make-send-buffer ( packet -- WSABUF )
- "WSABUF" malloc-object &free
- [ [ malloc-byte-array &free ] dip set-WSABUF-buf ]
- [ [ length ] dip set-WSABUF-len ]
- [ nip ]
- 2tri ; inline
+ [ WSABUF malloc-struct &free ] dip
+ [ malloc-byte-array &free >>buf ]
+ [ length >>len ] bi ; inline
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
WSASendTo-args new
-USING: kernel accessors io.sockets io.backend.windows io.backend\r
-windows.winsock system destructors alien.c-types ;\r
+USING: kernel accessors io.sockets io.sockets.private\r
+io.backend.windows io.backend windows.winsock system destructors\r
+alien.c-types classes.struct combinators ;\r
IN: io.sockets.windows\r
\r
+M: windows addrinfo-error ( n -- )\r
+ winsock-return-check ;\r
+\r
+M: windows sockaddr-of-family ( alien af -- addrspec )\r
+ {\r
+ { AF_INET [ sockaddr-in memory>struct ] }\r
+ { AF_INET6 [ sockaddr-in6 memory>struct ] }\r
+ [ 2drop f ]\r
+ } case ;\r
+\r
+M: windows addrspec-of-family ( af -- addrspec )\r
+ {\r
+ { AF_INET [ T{ inet4 } ] }\r
+ { AF_INET6 [ T{ inet6 } ] }\r
+ [ drop f ]\r
+ } case ;\r
+\r
HOOK: WSASocket-flags io-backend ( -- DWORD )\r
\r
TUPLE: win32-socket < win32-file ;\r
handle>> closesocket drop ;\r
\r
: unspecific-sockaddr/size ( addrspec -- sockaddr len )\r
- [ empty-sockaddr/size ] [ protocol-family ] bi\r
- pick set-sockaddr-in-family ;\r
+ [ empty-sockaddr/size ] [ protocol-family ] bi pick (>>family) ;\r
\r
: opened-socket ( handle -- win32-socket )\r
<win32-socket> |dispose dup add-completion ;\r
\r
M: windows (datagram) ( addrspec -- handle )\r
[ SOCK_DGRAM server-socket ] with-destructors ;\r
-\r
-M: windows addrinfo-error ( n -- )\r
- winsock-return-check ;\r
M: limited-stream stream-read-until
swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ;
+M: limited-stream stream-seek
+ stream>> stream-seek ;
+
M: limited-stream dispose
stream>> dispose ;
"Paragraph styles for " { $link with-nesting } ":"
{ $subsection page-color }
{ $subsection border-color }
-{ $subsection border-width }
+{ $subsection inset }
{ $subsection wrap-margin }
{ $subsection presented } ;
{ $code "H{ { border-color T{ rgba f 1 0 0 1 } } }\n[ \"A border\" write ] with-nesting nl" }
} ;
-HELP: border-width
-{ $description "Paragraph style. Pixels between edge of text and border, an integer." }
+HELP: inset
+{ $description "Paragraph style. A pair of integers representing the number of pixels that the content should be inset from the border. The first number is the horizontal inset, and the second is the vertical inset." }
{ $examples
- { $code "H{ { border-width 10 } }\n[ \"Some inset text\" write ] with-nesting nl" }
+ { $code "H{ { inset { 10 10 } } }\n[ \"Some inset text\" write ] with-nesting nl" }
} ;
HELP: wrap-margin
! Paragraph styles
SYMBOL: page-color
SYMBOL: border-color
-SYMBOL: border-width
+SYMBOL: inset
SYMBOL: wrap-margin
! Table styles
! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators io io.streams.string json
-kernel math math.parser math.parser.private prettyprint
+kernel math math.parser prettyprint
sequences strings vectors ;
IN: json.reader
PRIVATE>
: json> ( string -- object )
- (json-parser>) ;
\ No newline at end of file
+ (json-parser>) ;
: memcpy ( dst src size -- )
"void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
+: memcmp ( a b size -- cmp )
+ "int" "libc" "memcmp" { "void*" "void*" "ulong" } alien-invoke ;
+
+: memory= ( a b size -- ? )
+ memcmp 0 = ;
+
: strlen ( alien -- len )
"size_t" "libc" "strlen" { "char*" } alien-invoke ;
! (c) Joe Groff, see license for details
USING: accessors continuations kernel parser words quotations
-combinators.smart vectors sequences fry ;
+vectors sequences fry ;
IN: literals
<PRIVATE
SYNTAX: $ scan-word expand-literal >vector ;
SYNTAX: $[ parse-quotation with-datastack >vector ;
SYNTAX: ${ \ } [ expand-literals ] parse-literal ;
-
-SYNTAX: $$
- scan-word execute( accum -- accum ) dup pop [ >quotation ] keep
- [ output>sequence ] 2curry call( -- object ) parsed ;
dup length zero? not [ rest ] [ drop f ] if ;
: (match-first) ( seq pattern-seq -- bindings leftover/f )
- 2dup [ length ] bi@ < [ 2drop f f ]
- [
+ 2dup shorter? [ 2drop f f ] [
2dup length head over match
- [ nip swap ?1-tail ] [ [ rest ] dip (match-first) ] if*
+ [ swap ?1-tail ] [ [ rest ] dip (match-first) ] ?if
] if ;
: match-first ( seq pattern-seq -- bindings )
: (match-all) ( seq pattern-seq -- )
[ nip ] [ (match-first) swap ] 2bi
- [
- , [ swap (match-all) ] [ drop ] if*
- ] [ 2drop ] if* ;
+ [ , [ swap (match-all) ] [ drop ] if* ] [ 2drop ] if* ;
: match-all ( seq pattern-seq -- bindings-seq )
[ (match-all) ] { } make ;
-
ABOUT: "math.bits"
ARTICLE: "math.bits" "Number bits virtual sequence"
+"The " { $vocab-link "math.bits" } " vocabulary implements a virtual sequence which presents an integer as a sequence of bits, with the first element of the sequence being the least significant bit of the integer."
{ $subsection bits }
{ $subsection <bits> }
{ $subsection make-bits } ;
math math.blas.ffi math.blas.vectors math.blas.vectors.private
math.complex math.functions math.order functors words
sequences sequences.merged sequences.private shuffle
-specialized-arrays.direct.float specialized-arrays.direct.double
-specialized-arrays.float specialized-arrays.double
-specialized-arrays.direct.complex-float specialized-arrays.direct.complex-double
-specialized-arrays.complex-float specialized-arrays.complex-double
-parser prettyprint.backend prettyprint.custom ascii ;
+parser prettyprint.backend prettyprint.custom ascii
+specialized-arrays ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: complex-float
+SPECIALIZED-ARRAY: complex-double
IN: math.blas.matrices
TUPLE: blas-matrix-base underlying ld rows cols transpose ;
! XXX try rounding stride to next 128 bit bound for better vectorizin'
: <empty-matrix> ( rows cols exemplar -- matrix )
- [ element-type [ * ] dip <c-array> ]
+ [ element-type heap-size * * <byte-array> ]
[ 2drop ]
[ f swap (blas-matrix-like) ] 3tri ;
combinators.short-circuit fry kernel math math.blas.ffi
math.complex math.functions math.order sequences sequences.private
functors words locals parser prettyprint.backend prettyprint.custom
-specialized-arrays.float specialized-arrays.double
-specialized-arrays.direct.float specialized-arrays.direct.double
-specialized-arrays.complex-float specialized-arrays.complex-double
-specialized-arrays.direct.complex-float
-specialized-arrays.direct.complex-double ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: complex-float
+SPECIALIZED-ARRAY: complex-double
IN: math.blas.vectors
TUPLE: blas-vector-base underlying length inc ;
length v inc>> v (blas-vector-like) ;
: <zero-vector> ( exemplar -- zero )
- [ element-type <c-object> ]
+ [ element-type heap-size <byte-array> ]
[ length>> 0 ]
[ (blas-vector-like) ] tri ;
: <empty-vector> ( length exemplar -- vector )
- [ element-type <c-array> ]
+ [ element-type heap-size * <byte-array> ]
[ 1 swap ] 2bi
(blas-vector-like) ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private
-math.libm math.functions arrays math.functions.private sequences
-parser ;
+math.functions arrays math.functions.private sequences parser ;
IN: math.complex.private
M: real real-part ; inline
M: complex / [ / ] complex/ ; inline
M: complex /f [ /f ] complex/ ; inline
M: complex /i [ /i ] complex/ ; inline
-M: complex abs absq >float fsqrt ; inline
-M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; inline
+M: complex abs absq sqrt ; inline
+M: complex sqrt >polar [ sqrt ] [ 2.0 / ] bi* polar> ; inline
IN: syntax
{ $subsection euler }
{ $subsection phi }
{ $subsection pi }
-{ $subsection epsilon } ;
+{ $subsection epsilon }
+{ $subsection single-epsilon } ;
ABOUT: "math-constants"
{ $values { "pi" "circumference of circle with diameter 1" } } ;
HELP: epsilon
-{ $values { "epsilon" "smallest floating point value you can add to 1 without underflow" } } ;
+{ $values { "epsilon" "smallest double-precision floating point value you can add to 1 without underflow" } } ;
+
+HELP: single-epsilon
+{ $values { "epsilon" "smallest single-precision floating point value you can add to 1 without underflow" } } ;
: phi ( -- phi ) 1.61803398874989484820 ; inline
: pi ( -- pi ) 3.14159265358979323846 ; inline
: 2pi ( -- pi ) 2 pi * ; inline
-: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
+: epsilon ( -- epsilon ) HEX: 3cb0000000000000 bits>double ; foldable
+: single-epsilon ( -- epsilon ) HEX: 34000000 bits>float ; foldable
: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
--- /dev/null
+! (c)Joe Groff bsd license
+USING: help help.markup help.syntax kernel quotations ;
+IN: math.floats.env
+
+HELP: fp-exception
+{ $class-description "Symbols of this type represent floating-point exceptions. They are used to get and set the floating-point unit's exception flags (using " { $link fp-exception-flags } " and " { $link set-fp-exception-flags } ") and to control processor traps (using " { $link with-fp-traps } "). The following symbols are defined:"
+{ $list
+{ { $link +fp-invalid-operation+ } " indicates that an invalid floating-point operation occurred, such as taking the square root of a negative number or dividing zero by zero." }
+{ { $link +fp-overflow+ } " indicates that a floating-point operation gave a result larger than the maximum representable value of the type used to perform the calculation." }
+{ { $link +fp-underflow+ } " indicates that a floating-point operation gave a result smaller than the minimum representable normalized value of the type used to perform the calculation." }
+{ { $link +fp-zero-divide+ } " indicates that a floating-point division by zero was attempted." }
+{ { $link +fp-inexact+ } " indicates that a floating-point operation gave an inexact result that needed to be rounded." }
+} } ;
+
+HELP: +fp-invalid-operation+
+{ $class-description "This symbol represents a invalid operation " { $link fp-exception } "." } ;
+HELP: +fp-overflow+
+{ $class-description "This symbol represents an overflow " { $link fp-exception } "." } ;
+HELP: +fp-underflow+
+{ $class-description "This symbol represents an underflow " { $link fp-exception } "." } ;
+HELP: +fp-zero-divide+
+{ $class-description "This symbol represents a division-by-zero " { $link fp-exception } "." } ;
+HELP: +fp-inexact+
+{ $class-description "This symbol represents an inexact result " { $link fp-exception } "." } ;
+
+HELP: fp-rounding-mode
+{ $class-description "Symbols of this type represent floating-point rounding modes. They are passed to the " { $link with-rounding-mode } " word to control how inexact values are calculated when exact results cannot fit in a floating-point type. The following symbols are defined:"
+{ $list
+{ { $link +round-nearest+ } " rounds the exact result to the nearest representable value, using the even value when the result is halfway between its two nearest values." }
+{ { $link +round-zero+ } " rounds the exact result toward zero, that is, down for positive values, and up for negative values." }
+{ { $link +round-down+ } " always rounds the exact result down." }
+{ { $link +round-up+ } " always rounds the exact result up." }
+} } ;
+
+HELP: +round-nearest+
+{ $class-description "This symbol represents the round-to-nearest " { $link fp-rounding-mode } "." } ;
+HELP: +round-zero+
+{ $class-description "This symbol represents the round-toward-zero " { $link fp-rounding-mode } "." } ;
+HELP: +round-down+
+{ $class-description "This symbol represents the round-down " { $link fp-rounding-mode } "." } ;
+HELP: +round-up+
+{ $class-description "This symbol represents the round-up " { $link fp-rounding-mode } "." } ;
+
+HELP: fp-denormal-mode
+{ $class-description "Symbols of this type represent floating-point denormal modes. They are passed to the " { $link with-denormal-mode } " word to control whether denormals are generated as outputs of floating-point operations and how they are treated when given as inputs."
+{ $list
+{ { $link +denormal-keep+ } " causes denormal results to be generated and accepted as inputs as required by IEEE 754." }
+{ { $link +denormal-flush+ } " causes denormal results to be flushed to zero and be treated as zero when given as inputs. This mode may allow floating point operations to give results that are not compliant with the IEEE 754 standard." }
+} } ;
+
+HELP: +denormal-keep+
+{ $class-description "This symbol represents the IEEE 754 compliant keep-denormals " { $link fp-denormal-mode } "." } ;
+HELP: +denormal-flush+
+{ $class-description "This symbol represents the non-IEEE-754-compliant flush-denormals-to-zero " { $link fp-denormal-mode } "." } ;
+
+HELP: fp-exception-flags
+{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "Returns the set of floating-point exception flags that have been raised." } ;
+
+HELP: set-fp-exception-flags
+{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "Replaces the set of floating-point exception flags with the set specified in " { $snippet "exceptions" } "." }
+{ $notes "On Intel platforms, the legacy x87 floating-point unit does not support setting exception flags, so this word only clears the x87 exception flags. However, the SSE unit's flags are set as expected." } ;
+
+HELP: clear-fp-exception-flags
+{ $description "Clears all of the floating-point exception flags." } ;
+
+HELP: collect-fp-exceptions
+{ $values { "quot" quotation } { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "Clears the floating-point exception flags and then calls " { $snippet "quot" } ", returning the set of floating-point exceptions raised during its execution and placing them on the datastack on " { $snippet "quot" } "'s completion." } ;
+
+{ fp-exception-flags set-fp-exception-flags clear-fp-exception-flags collect-fp-exceptions } related-words
+
+HELP: denormal-mode
+{ $values { "mode" fp-denormal-mode } }
+{ $description "Returns the current floating-point denormal mode." } ;
+
+HELP: with-denormal-mode
+{ $values { "mode" fp-denormal-mode } { "quot" quotation } }
+{ $description "Sets the floating-point denormal mode to " { $snippet "mode" } " for the dynamic extent of " { $snippet "quot" } ", restoring the denormal mode to its original value on " { $snippet "quot" } "'s completion." } ;
+
+{ denormal-mode with-denormal-mode } related-words
+
+HELP: rounding-mode
+{ $values { "mode" fp-rounding-mode } }
+{ $description "Returns the current floating-point rounding mode." } ;
+
+HELP: with-rounding-mode
+{ $values { "mode" fp-rounding-mode } { "quot" quotation } }
+{ $description "Sets the floating-point rounding mode to " { $snippet "mode" } " for the dynamic extent of " { $snippet "quot" } ", restoring the rounding mode to its original value on " { $snippet "quot" } "'s completion." } ;
+
+{ rounding-mode with-rounding-mode } related-words
+
+HELP: fp-traps
+{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "Returns the set of floating point exceptions with processor traps currently set." } ;
+
+HELP: with-fp-traps
+{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } { "quot" quotation } }
+{ $description "Clears the floating-point exception flags and replaces the exception mask, enabling processor traps for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ". The original exception mask is restored on " { $snippet "quot" } "'s completion." } ;
+
+HELP: without-fp-traps
+{ $values { "quot" quotation } }
+{ $description "Disables all floating-pointer processor traps for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ;
+
+{ fp-traps with-fp-traps without-fp-traps vm-error>exception-flags vm-error-exception-flag? } related-words
+
+HELP: vm-error>exception-flags
+{ $values { "error" "a floating-point error object from the Factor VM" } { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "When a floating-point trap is raised, the Factor VM reports the trap by throwing a Factor exception containing the exception flags at the time the trap was raised. This word extracts the exception flag information from " { $snippet "error" } " and converts it into a sequence of " { $link fp-exception } "s." } ;
+
+HELP: vm-error-exception-flag?
+{ $values { "error" "a floating-point error object from the Factor VM" } { "flag" fp-exception } { "?" boolean } }
+{ $description "When a floating-point trap is raised, the Factor VM reports the trap by throwing a Factor exception containing the exception flags at the time the trap was raised. This word returns a boolean indicating whether the exception " { $snippet "flag" } " was raised at the time " { $snippet "error" } " was thrown." } ;
+
+ARTICLE: "math.floats.env" "Controlling the floating-point environment"
+"The " { $vocab-link "math.floats.env" } " vocabulary contains words for querying and controlling the floating-point environment."
+$nl
+"Querying and setting exception flags:"
+{ $subsection fp-exception-flags }
+{ $subsection set-fp-exception-flags }
+{ $subsection clear-fp-exception-flags }
+{ $subsection collect-fp-exceptions }
+"Querying and controlling processor traps for floating-point exceptions:"
+{ $subsection fp-traps }
+{ $subsection with-fp-traps }
+{ $subsection without-fp-traps }
+"Getting the floating-point exception state from errors raised by enabled traps:"
+{ $subsection vm-error>exception-flags }
+{ $subsection vm-error-exception-flag? }
+"Querying and controlling the rounding mode and treatment of denormals:"
+{ $subsection rounding-mode }
+{ $subsection with-rounding-mode }
+{ $subsection denormal-mode }
+{ $subsection with-denormal-mode } ;
+
+ABOUT: "math.floats.env"
--- /dev/null
+USING: kernel math math.floats.env math.floats.env.private
+math.functions math.libm sequences tools.test locals
+compiler.units kernel.private fry compiler math.private words
+system ;
+IN: math.floats.env.tests
+
+: set-default-fp-env ( -- )
+ { } { } +round-nearest+ +denormal-keep+ set-fp-env ;
+
+! In case the tests screw up the FP env because of bugs in math.floats.env
+set-default-fp-env
+
+: test-fp-exception ( exception inputs quot -- quot' )
+ '[ _ [ @ @ ] collect-fp-exceptions nip member? ] ;
+
+: test-fp-exception-compiled ( exception inputs quot -- quot' )
+ '[ _ @ [ _ collect-fp-exceptions ] compile-call nip member? ] ;
+
+[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception unit-test
+[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception unit-test
+[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception unit-test
+[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception unit-test
+[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception unit-test
+[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception unit-test
+[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception unit-test
+
+[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test
+[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception-compiled unit-test
+[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test
+[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test
+[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
+
+! No underflow on Linux with this test, just inexact. Reported as an Ubuntu bug:
+! https://bugs.launchpad.net/ubuntu/+source/glibc/+bug/429113
+os linux? cpu x86.64? and [
+ [ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception unit-test
+ [ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
+] unless
+
+[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test
+[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception-compiled unit-test
+
+[
+ HEX: 3fd5,5555,5555,5555
+ HEX: 3fc9,9999,9999,999a
+ HEX: bfc9,9999,9999,999a
+ HEX: bfd5,5555,5555,5555
+] [
+ +round-nearest+ [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+ ] with-rounding-mode
+] unit-test
+
+[
+ HEX: 3fd5,5555,5555,5555
+ HEX: 3fc9,9999,9999,9999
+ HEX: bfc9,9999,9999,999a
+ HEX: bfd5,5555,5555,5556
+] [
+ +round-down+ [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+ ] with-rounding-mode
+] unit-test
+
+[
+ HEX: 3fd5,5555,5555,5556
+ HEX: 3fc9,9999,9999,999a
+ HEX: bfc9,9999,9999,9999
+ HEX: bfd5,5555,5555,5555
+] [
+ +round-up+ [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+ ] with-rounding-mode
+] unit-test
+
+[
+ HEX: 3fd5,5555,5555,5555
+ HEX: 3fc9,9999,9999,9999
+ HEX: bfc9,9999,9999,9999
+ HEX: bfd5,5555,5555,5555
+] [
+ +round-zero+ [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+ ] with-rounding-mode
+] unit-test
+
+! ensure rounding mode is restored to +round-nearest+
+[
+ HEX: 3fd5,5555,5555,5555
+ HEX: 3fc9,9999,9999,999a
+ HEX: bfc9,9999,9999,999a
+ HEX: bfd5,5555,5555,5555
+] [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+] unit-test
+
+: test-traps ( traps inputs quot -- quot' )
+ append '[ _ _ with-fp-traps ] ;
+
+: test-traps-compiled ( traps inputs quot -- quot' )
+ swapd '[ @ [ _ _ with-fp-traps ] compile-call ] ;
+
+{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail
+{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail
+{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail
+{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail
+{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail
+
+{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail
+{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail
+{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail
+{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail
+{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail
+
+! Ensure ordered comparisons raise traps
+:: test-comparison-quot ( word -- quot )
+ [
+ { float float } declare
+ { +fp-invalid-operation+ } [ word execute ] with-fp-traps
+ ] ;
+
+: test-comparison ( inputs word -- quot )
+ test-comparison-quot append ;
+
+: test-comparison-compiled ( inputs word -- quot )
+ test-comparison-quot '[ @ _ compile-call ] ;
+
+\ float< "intrinsic" word-prop [
+ [ 0/0. -15.0 ] \ < test-comparison must-fail
+ [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail
+ [ -15.0 0/0. ] \ < test-comparison must-fail
+ [ -15.0 0/0. ] \ < test-comparison-compiled must-fail
+ [ 0/0. -15.0 ] \ <= test-comparison must-fail
+ [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail
+ [ -15.0 0/0. ] \ <= test-comparison must-fail
+ [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail
+ [ 0/0. -15.0 ] \ > test-comparison must-fail
+ [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail
+ [ -15.0 0/0. ] \ > test-comparison must-fail
+ [ -15.0 0/0. ] \ > test-comparison-compiled must-fail
+ [ 0/0. -15.0 ] \ >= test-comparison must-fail
+ [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail
+ [ -15.0 0/0. ] \ >= test-comparison must-fail
+ [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail
+
+ [ f ] [ 0/0. -15.0 ] \ u< test-comparison unit-test
+ [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled unit-test
+ [ f ] [ -15.0 0/0. ] \ u< test-comparison unit-test
+ [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled unit-test
+ [ f ] [ 0/0. -15.0 ] \ u<= test-comparison unit-test
+ [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled unit-test
+ [ f ] [ -15.0 0/0. ] \ u<= test-comparison unit-test
+ [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled unit-test
+ [ f ] [ 0/0. -15.0 ] \ u> test-comparison unit-test
+ [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled unit-test
+ [ f ] [ -15.0 0/0. ] \ u> test-comparison unit-test
+ [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled unit-test
+ [ f ] [ 0/0. -15.0 ] \ u>= test-comparison unit-test
+ [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled unit-test
+ [ f ] [ -15.0 0/0. ] \ u>= test-comparison unit-test
+ [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled unit-test
+] when
+
+! Ensure traps get cleared
+[ 1/0. ] [ 1.0 0.0 /f ] unit-test
+
+! Ensure state is back to normal
+[ +round-nearest+ ] [ rounding-mode ] unit-test
+[ +denormal-keep+ ] [ denormal-mode ] unit-test
+[ { } ] [ fp-traps ] unit-test
+
+! In case the tests screw up the FP env because of bugs in math.floats.env
+set-default-fp-env
+
--- /dev/null
+! (c)Joe Groff bsd license
+USING: alien.syntax arrays assocs biassocs combinators
+combinators.short-circuit continuations generalizations kernel
+literals locals math math.bitwise sequences sets system
+vocabs.loader ;
+IN: math.floats.env
+
+SINGLETONS:
+ +fp-invalid-operation+
+ +fp-overflow+
+ +fp-underflow+
+ +fp-zero-divide+
+ +fp-inexact+ ;
+
+UNION: fp-exception
+ +fp-invalid-operation+
+ +fp-overflow+
+ +fp-underflow+
+ +fp-zero-divide+
+ +fp-inexact+ ;
+
+CONSTANT: all-fp-exceptions
+ {
+ +fp-invalid-operation+
+ +fp-overflow+
+ +fp-underflow+
+ +fp-zero-divide+
+ +fp-inexact+
+ }
+
+SINGLETONS:
+ +round-nearest+
+ +round-down+
+ +round-up+
+ +round-zero+ ;
+
+UNION: fp-rounding-mode
+ +round-nearest+
+ +round-down+
+ +round-up+
+ +round-zero+ ;
+
+SINGLETONS:
+ +denormal-keep+
+ +denormal-flush+ ;
+
+UNION: fp-denormal-mode
+ +denormal-keep+
+ +denormal-flush+ ;
+
+<PRIVATE
+
+HOOK: (fp-env-registers) cpu ( -- registers )
+
+: fp-env-register ( -- register ) (fp-env-registers) first ;
+
+:: mask> ( bits assoc -- symbols )
+ assoc [| k v | bits v mask zero? not ] assoc-filter keys ;
+: >mask ( symbols assoc -- bits )
+ over empty?
+ [ 2drop 0 ]
+ [ [ at ] curry [ bitor ] map-reduce ] if ;
+
+: remask ( x new-bits mask-bits -- x' )
+ [ unmask ] [ mask ] bi-curry bi* bitor ; inline
+
+GENERIC: (set-fp-env-register) ( fp-env -- )
+
+GENERIC: (get-exception-flags) ( fp-env -- exceptions )
+GENERIC# (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
+
+GENERIC: (get-fp-traps) ( fp-env -- exceptions )
+GENERIC# (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
+
+GENERIC: (get-rounding-mode) ( fp-env -- mode )
+GENERIC# (set-rounding-mode) 1 ( fp-env mode -- fp-env )
+
+GENERIC: (get-denormal-mode) ( fp-env -- mode )
+GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
+
+: change-fp-env-registers ( quot -- )
+ (fp-env-registers) swap [ (set-fp-env-register) ] compose each ; inline
+
+: set-fp-traps ( exceptions -- ) [ (set-fp-traps) ] curry change-fp-env-registers ;
+: set-rounding-mode ( mode -- ) [ (set-rounding-mode) ] curry change-fp-env-registers ;
+: set-denormal-mode ( mode -- ) [ (set-denormal-mode) ] curry change-fp-env-registers ;
+
+: get-fp-env ( -- exception-flags fp-traps rounding-mode denormal-mode )
+ fp-env-register {
+ [ (get-exception-flags) ]
+ [ (get-fp-traps) ]
+ [ (get-rounding-mode) ]
+ [ (get-denormal-mode) ]
+ } cleave ;
+
+: set-fp-env ( exception-flags fp-traps rounding-mode denormal-mode -- )
+ [
+ {
+ [ [ (set-exception-flags) ] when* ]
+ [ [ (set-fp-traps) ] when* ]
+ [ [ (set-rounding-mode) ] when* ]
+ [ [ (set-denormal-mode) ] when* ]
+ } spread
+ ] 4 ncurry change-fp-env-registers ;
+
+CONSTANT: vm-error-exception-flag>bit
+ H{
+ { +fp-invalid-operation+ HEX: 01 }
+ { +fp-overflow+ HEX: 02 }
+ { +fp-underflow+ HEX: 04 }
+ { +fp-zero-divide+ HEX: 08 }
+ { +fp-inexact+ HEX: 10 }
+ }
+
+PRIVATE>
+
+: fp-exception-flags ( -- exceptions )
+ (fp-env-registers) [ (get-exception-flags) ] [ union ] map-reduce >array ; inline
+: set-fp-exception-flags ( exceptions -- )
+ [ (set-exception-flags) ] curry change-fp-env-registers ; inline
+: clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
+
+: collect-fp-exceptions ( quot -- exceptions )
+ [ clear-fp-exception-flags ] dip call fp-exception-flags ; inline
+
+: vm-error>exception-flags ( error -- exceptions )
+ third vm-error-exception-flag>bit mask> ;
+: vm-error-exception-flag? ( error flag -- ? )
+ vm-error>exception-flags member? ;
+
+: denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ;
+
+:: with-denormal-mode ( mode quot -- )
+ denormal-mode :> orig
+ mode set-denormal-mode
+ quot [ orig set-denormal-mode ] [ ] cleanup ; inline
+
+: rounding-mode ( -- mode ) fp-env-register (get-rounding-mode) ;
+
+:: with-rounding-mode ( mode quot -- )
+ rounding-mode :> orig
+ mode set-rounding-mode
+ quot [ orig set-rounding-mode ] [ ] cleanup ; inline
+
+: fp-traps ( -- exceptions )
+ (fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline
+
+:: with-fp-traps ( exceptions quot -- )
+ clear-fp-exception-flags
+ fp-traps :> orig
+ exceptions set-fp-traps
+ quot [ orig set-fp-traps ] [ ] cleanup ; inline
+
+: without-fp-traps ( quot -- )
+ { } swap with-fp-traps ; inline
+
+<< {
+ { [ cpu x86? ] [ "math.floats.env.x86" require ] }
+ { [ cpu ppc? ] [ "math.floats.env.ppc" require ] }
+ [ "CPU architecture unsupported by math.floats.env" throw ]
+} cond >>
+
--- /dev/null
+USING: accessors alien.syntax arrays assocs biassocs
+classes.struct combinators kernel literals math math.bitwise
+math.floats.env math.floats.env.private system ;
+IN: math.floats.env.ppc
+
+STRUCT: ppc-fpu-env
+ { padding uint }
+ { fpscr uint } ;
+
+STRUCT: ppc-vmx-env
+ { vscr uint } ;
+
+! defined in the vm, cpu-ppc*.S
+FUNCTION: void get_ppc_fpu_env ( ppc-fpu-env* env ) ;
+FUNCTION: void set_ppc_fpu_env ( ppc-fpu-env* env ) ;
+
+FUNCTION: void get_ppc_vmx_env ( ppc-vmx-env* env ) ;
+FUNCTION: void set_ppc_vmx_env ( ppc-vmx-env* env ) ;
+
+: <ppc-fpu-env> ( -- ppc-fpu-env )
+ ppc-fpu-env (struct)
+ [ get_ppc_fpu_env ] keep ;
+
+: <ppc-vmx-env> ( -- ppc-fpu-env )
+ ppc-vmx-env (struct)
+ [ get_ppc_vmx_env ] keep ;
+
+M: ppc-fpu-env (set-fp-env-register)
+ set_ppc_fpu_env ;
+
+M: ppc-vmx-env (set-fp-env-register)
+ set_ppc_vmx_env ;
+
+M: ppc (fp-env-registers)
+ <ppc-fpu-env> <ppc-vmx-env> 2array ;
+
+CONSTANT: ppc-exception-flag-bits HEX: fff8,0700
+CONSTANT: ppc-exception-flag>bit
+ H{
+ { +fp-invalid-operation+ HEX: 2000,0000 }
+ { +fp-overflow+ HEX: 1000,0000 }
+ { +fp-underflow+ HEX: 0800,0000 }
+ { +fp-zero-divide+ HEX: 0400,0000 }
+ { +fp-inexact+ HEX: 0200,0000 }
+ }
+
+CONSTANT: ppc-fp-traps-bits HEX: f8
+CONSTANT: ppc-fp-traps>bit
+ H{
+ { +fp-invalid-operation+ HEX: 80 }
+ { +fp-overflow+ HEX: 40 }
+ { +fp-underflow+ HEX: 20 }
+ { +fp-zero-divide+ HEX: 10 }
+ { +fp-inexact+ HEX: 08 }
+ }
+
+CONSTANT: ppc-rounding-mode-bits HEX: 3
+CONSTANT: ppc-rounding-mode>bit
+ $[ H{
+ { +round-nearest+ HEX: 0 }
+ { +round-zero+ HEX: 1 }
+ { +round-up+ HEX: 2 }
+ { +round-down+ HEX: 3 }
+ } >biassoc ]
+
+CONSTANT: ppc-denormal-mode-bits HEX: 4
+
+M: ppc-fpu-env (get-exception-flags) ( register -- exceptions )
+ fpscr>> ppc-exception-flag>bit mask> ; inline
+M: ppc-fpu-env (set-exception-flags) ( register exceptions -- register' )
+ [ ppc-exception-flag>bit >mask ppc-exception-flag-bits remask ] curry change-fpscr ; inline
+
+M: ppc-fpu-env (get-fp-traps) ( register -- exceptions )
+ fpscr>> ppc-fp-traps>bit mask> ; inline
+M: ppc-fpu-env (set-fp-traps) ( register exceptions -- register' )
+ [ ppc-fp-traps>bit >mask ppc-fp-traps-bits remask ] curry change-fpscr ; inline
+
+M: ppc-fpu-env (get-rounding-mode) ( register -- mode )
+ fpscr>> ppc-rounding-mode-bits mask ppc-rounding-mode>bit value-at ; inline
+M: ppc-fpu-env (set-rounding-mode) ( register mode -- register' )
+ [ ppc-rounding-mode>bit at ppc-rounding-mode-bits remask ] curry change-fpscr ; inline
+
+M: ppc-fpu-env (get-denormal-mode) ( register -- mode )
+ fpscr>> ppc-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
+M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' )
+ [
+ {
+ { +denormal-keep+ [ ppc-denormal-mode-bits unmask ] }
+ { +denormal-flush+ [ ppc-denormal-mode-bits bitor ] }
+ } case
+ ] curry change-fpscr ; inline
+
+CONSTANT: vmx-denormal-mode-bits HEX: 10000
+
+M: ppc-vmx-env (get-exception-flags) ( register -- exceptions )
+ drop { } ; inline
+M: ppc-vmx-env (set-exception-flags) ( register exceptions -- register' )
+ drop ;
+
+M: ppc-vmx-env (get-fp-traps) ( register -- exceptions )
+ drop { } ; inline
+M: ppc-vmx-env (set-fp-traps) ( register exceptions -- register' )
+ drop ;
+
+M: ppc-vmx-env (get-rounding-mode) ( register -- mode )
+ drop +round-nearest+ ;
+M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' )
+ drop ;
+
+M: ppc-vmx-env (get-denormal-mode) ( register -- mode )
+ vscr>> vmx-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
+M: ppc-vmx-env (set-denormal-mode) ( register mode -- register )
+ [
+ {
+ { +denormal-keep+ [ vmx-denormal-mode-bits unmask ] }
+ { +denormal-flush+ [ vmx-denormal-mode-bits bitor ] }
+ } case
+ ] curry change-vscr ; inline
+
--- /dev/null
+unportable
--- /dev/null
+IEEE 754 floating-point environment querying and control (exceptions, rounding mode, and denormals)
--- /dev/null
+unportable
--- /dev/null
+USING: accessors alien.syntax arrays assocs biassocs
+classes.struct combinators cpu.x86.features kernel literals
+math math.bitwise math.floats.env math.floats.env.private
+system ;
+IN: math.floats.env.x86
+
+STRUCT: sse-env
+ { mxcsr uint } ;
+
+STRUCT: x87-env
+ { status ushort }
+ { control ushort } ;
+
+! defined in the vm, cpu-x86*.S
+FUNCTION: void get_sse_env ( sse-env* env ) ;
+FUNCTION: void set_sse_env ( sse-env* env ) ;
+
+FUNCTION: void get_x87_env ( x87-env* env ) ;
+FUNCTION: void set_x87_env ( x87-env* env ) ;
+
+: <sse-env> ( -- sse-env )
+ sse-env (struct) [ get_sse_env ] keep ;
+
+M: sse-env (set-fp-env-register)
+ set_sse_env ;
+
+: <x87-env> ( -- x87-env )
+ x87-env (struct) [ get_x87_env ] keep ;
+
+M: x87-env (set-fp-env-register)
+ set_x87_env ;
+
+M: x86 (fp-env-registers)
+ sse-version 20 >=
+ [ <sse-env> <x87-env> 2array ]
+ [ <x87-env> 1array ] if ;
+
+CONSTANT: sse-exception-flag-bits HEX: 3f
+CONSTANT: sse-exception-flag>bit
+ H{
+ { +fp-invalid-operation+ HEX: 01 }
+ { +fp-overflow+ HEX: 08 }
+ { +fp-underflow+ HEX: 10 }
+ { +fp-zero-divide+ HEX: 04 }
+ { +fp-inexact+ HEX: 20 }
+ }
+
+CONSTANT: sse-fp-traps-bits HEX: 1f80
+CONSTANT: sse-fp-traps>bit
+ H{
+ { +fp-invalid-operation+ HEX: 0080 }
+ { +fp-overflow+ HEX: 0400 }
+ { +fp-underflow+ HEX: 0800 }
+ { +fp-zero-divide+ HEX: 0200 }
+ { +fp-inexact+ HEX: 1000 }
+ }
+
+CONSTANT: sse-rounding-mode-bits HEX: 6000
+CONSTANT: sse-rounding-mode>bit
+ $[ H{
+ { +round-nearest+ HEX: 0000 }
+ { +round-down+ HEX: 2000 }
+ { +round-up+ HEX: 4000 }
+ { +round-zero+ HEX: 6000 }
+ } >biassoc ]
+
+CONSTANT: sse-denormal-mode-bits HEX: 8040
+
+M: sse-env (get-exception-flags) ( register -- exceptions )
+ mxcsr>> sse-exception-flag>bit mask> ; inline
+M: sse-env (set-exception-flags) ( register exceptions -- register' )
+ [ sse-exception-flag>bit >mask sse-exception-flag-bits remask ] curry change-mxcsr ; inline
+
+M: sse-env (get-fp-traps) ( register -- exceptions )
+ mxcsr>> bitnot sse-fp-traps>bit mask> ; inline
+M: sse-env (set-fp-traps) ( register exceptions -- register' )
+ [ sse-fp-traps>bit >mask bitnot sse-fp-traps-bits remask ] curry change-mxcsr ; inline
+
+M: sse-env (get-rounding-mode) ( register -- mode )
+ mxcsr>> sse-rounding-mode-bits mask sse-rounding-mode>bit value-at ; inline
+M: sse-env (set-rounding-mode) ( register mode -- register' )
+ [ sse-rounding-mode>bit at sse-rounding-mode-bits remask ] curry change-mxcsr ; inline
+
+M: sse-env (get-denormal-mode) ( register -- mode )
+ mxcsr>> sse-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
+M: sse-env (set-denormal-mode) ( register mode -- register' )
+ [
+ {
+ { +denormal-keep+ [ sse-denormal-mode-bits unmask ] }
+ { +denormal-flush+ [ sse-denormal-mode-bits bitor ] }
+ } case
+ ] curry change-mxcsr ; inline
+
+CONSTANT: x87-exception-bits HEX: 3f
+CONSTANT: x87-exception>bit
+ H{
+ { +fp-invalid-operation+ HEX: 01 }
+ { +fp-overflow+ HEX: 08 }
+ { +fp-underflow+ HEX: 10 }
+ { +fp-zero-divide+ HEX: 04 }
+ { +fp-inexact+ HEX: 20 }
+ }
+
+CONSTANT: x87-rounding-mode-bits HEX: 0c00
+CONSTANT: x87-rounding-mode>bit
+ $[ H{
+ { +round-nearest+ HEX: 0000 }
+ { +round-down+ HEX: 0400 }
+ { +round-up+ HEX: 0800 }
+ { +round-zero+ HEX: 0c00 }
+ } >biassoc ]
+
+M: x87-env (get-exception-flags) ( register -- exceptions )
+ status>> x87-exception>bit mask> ; inline
+M: x87-env (set-exception-flags) ( register exceptions -- register' )
+ drop ;
+
+M: x87-env (get-fp-traps) ( register -- exceptions )
+ control>> bitnot x87-exception>bit mask> ; inline
+M: x87-env (set-fp-traps) ( register exceptions -- register' )
+ [ x87-exception>bit >mask bitnot x87-exception-bits remask ] curry change-control ; inline
+
+M: x87-env (get-rounding-mode) ( register -- mode )
+ control>> x87-rounding-mode-bits mask x87-rounding-mode>bit value-at ; inline
+M: x87-env (set-rounding-mode) ( register mode -- register' )
+ [ x87-rounding-mode>bit at x87-rounding-mode-bits remask ] curry change-control ; inline
+
+M: x87-env (get-denormal-mode) ( register -- mode )
+ drop +denormal-keep+ ; inline
+M: x87-env (set-denormal-mode) ( register mode -- register' )
+ drop ;
+
"Computing additive and multiplicative inverses:"
{ $subsection neg }
{ $subsection recip }
-"Minimum, maximum, clamping:"
-{ $subsection min }
-{ $subsection max }
-{ $subsection clamp }
"Complex conjugation:"
{ $subsection conjugate }
"Tests:"
{ $subsection truncate }
{ $subsection round }
"Inexact comparison:"
-{ $subsection ~ } ;
+{ $subsection ~ }
+"Numbers implement the " { $link "math.order" } ", therefore operations such as " { $link min } " and " { $link max } " can be used with numbers." ;
ARTICLE: "power-functions" "Powers and logarithms"
"Squares:"
{ $subsection exp }
{ $subsection cis }
{ $subsection log }
+"Other logarithms:"
+{ $subsection log1+ }
{ $subsection log10 }
"Raising a number to a power:"
{ $subsection ^ }
{ $values { "x" number } { "y" number } }
{ $description "Natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
+HELP: log1+
+{ $values { "x" number } { "y" number } }
+{ $description "Takes the natural logarithm of " { $snippet "1 + x" } ". Outputs negative infinity if " { $snippet "1 + x" } " is zero. This word may be more accurate than " { $snippet "1 + log" } " for very small values of " { $snippet "x" } "." } ;
+
HELP: log10
{ $values { "x" number } { "y" number } }
{ $description "Logarithm function base 10. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
[ 0 ] [ 0 3 ^ ] unit-test
[ 0.0 ] [ 1 log ] unit-test
+[ 0.0 ] [ 1.0 log ] unit-test
+[ 1.0 ] [ e log ] unit-test
+
+[ 0.0 ] [ 1.0 log10 ] unit-test
+[ 1.0 ] [ 10.0 log10 ] unit-test
+[ 2.0 ] [ 100.0 log10 ] unit-test
+[ 3.0 ] [ 1000.0 log10 ] unit-test
+[ 4.0 ] [ 10000.0 log10 ] unit-test
+
+[ t ] [ 1 exp e 1.e-10 ~ ] unit-test
+[ t ] [ 1.0 exp e 1.e-10 ~ ] unit-test
+[ t ] [ -1 exp e * 1.0 1.e-10 ~ ] unit-test
[ 1.0 ] [ 0 cosh ] unit-test
+[ 1.0 ] [ 0.0 cosh ] unit-test
[ 0.0 ] [ 1 acosh ] unit-test
+[ 0.0 ] [ 1.0 acosh ] unit-test
[ 1.0 ] [ 0 cos ] unit-test
+[ 1.0 ] [ 0.0 cos ] unit-test
[ 0.0 ] [ 1 acos ] unit-test
+[ 0.0 ] [ 1.0 acos ] unit-test
[ 0.0 ] [ 0 sinh ] unit-test
+[ 0.0 ] [ 0.0 sinh ] unit-test
[ 0.0 ] [ 0 asinh ] unit-test
+[ 0.0 ] [ 0.0 asinh ] unit-test
[ 0.0 ] [ 0 sin ] unit-test
+[ 0.0 ] [ 0.0 sin ] unit-test
[ 0.0 ] [ 0 asin ] unit-test
+[ 0.0 ] [ 0.0 asin ] unit-test
+
+[ 0.0 ] [ 0 tan ] unit-test
+[ t ] [ pi 2 / tan 1.e10 > ] unit-test
[ t ] [ 10 atan real? ] unit-test
+[ t ] [ 10.0 atan real? ] unit-test
[ f ] [ 10 atanh real? ] unit-test
+[ f ] [ 10.0 atanh real? ] unit-test
[ t ] [ 10 asin sin 10 1.e-10 ~ ] unit-test
[ t ] [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test
: >polar ( z -- abs arg )
>float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ; inline
-: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
+: cis ( arg -- z ) >float [ fcos ] [ fsin ] bi rect> ; inline
: polar> ( abs arg -- z ) cis * ; inline
+GENERIC: exp ( x -- y )
+
+M: float exp fexp ; inline
+
+M: real exp >float exp ; inline
+
+M: complex exp >rect swap fexp swap polar> ; inline
+
<PRIVATE
: ^mag ( w abs arg -- magnitude )
- [ >float-rect swap ] [ swap fpow ] [ rot * fexp /f ] tri* ; inline
+ [ >float-rect swap ]
+ [ >float swap >float fpow ]
+ [ rot * exp /f ]
+ tri* ; inline
: ^theta ( w abs arg -- theta )
[ >float-rect ] [ flog * swap ] [ * + ] tri* ; inline
{
{ [ over 0 = ] [ nip 0^ ] }
{ [ dup integer? ] [ integer^ ] }
- { [ 2dup real^? ] [ fpow ] }
+ { [ 2dup real^? ] [ [ >float ] bi@ fpow ] }
[ ^complex ]
} cond ; inline
: >=1? ( x -- ? )
dup complex? [ drop f ] [ 1 >= ] if ; inline
-GENERIC: exp ( x -- y )
+GENERIC: log ( x -- y )
-M: real exp fexp ; inline
+M: float log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline
-M: complex exp >rect swap fexp swap polar> ;
+M: real log >float log ; inline
-GENERIC: log ( x -- y )
+M: complex log >polar [ flog ] dip rect> ; inline
+
+GENERIC: log1+ ( x -- y )
-M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline
+M: object log1+ 1 + log ; inline
-M: complex log >polar swap flog swap rect> ;
+M: float log1+ dup -1.0 >= [ flog1+ ] [ 1.0 + 0.0 rect> log ] if ; inline
: 10^ ( x -- y ) 10 swap ^ ; inline
-: log10 ( x -- y ) log 10 log / ; inline
+GENERIC: log10 ( x -- y ) foldable
+
+M: real log10 >float flog10 ; inline
+
+M: complex log10 log 10 log / ; inline
GENERIC: cos ( x -- y ) foldable
[ [ fcos ] [ fcosh ] bi* * ]
[ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
-M: real cos fcos ; inline
+M: float cos fcos ; inline
+
+M: real cos >float cos ; inline
: sec ( x -- y ) cos recip ; inline
[ [ fcosh ] [ fcos ] bi* * ]
[ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
-M: real cosh fcosh ; inline
+M: float cosh fcosh ; inline
+
+M: real cosh >float cosh ; inline
: sech ( x -- y ) cosh recip ; inline
[ [ fsin ] [ fcosh ] bi* * ]
[ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
-M: real sin fsin ; inline
+M: float sin fsin ; inline
+
+M: real sin >float sin ; inline
: cosec ( x -- y ) sin recip ; inline
[ [ fsinh ] [ fcos ] bi* * ]
[ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
-M: real sinh fsinh ; inline
+M: float sinh fsinh ; inline
+
+M: real sinh >float sinh ; inline
: cosech ( x -- y ) sinh recip ; inline
M: complex tan [ sin ] [ cos ] bi / ;
-M: real tan ftan ; inline
+M: float tan ftan ; inline
+
+M: real tan >float tan ; inline
GENERIC: tanh ( x -- y ) foldable
M: complex tanh [ sinh ] [ cosh ] bi / ;
-M: real tanh ftanh ; inline
+M: float tanh ftanh ; inline
+
+M: real tanh >float tanh ; inline
: cot ( x -- y ) tan recip ; inline
: -i* ( x -- y ) >rect swap neg rect> ;
: asin ( x -- y )
- dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline
+ dup [-1,1]? [ >float fasin ] [ i* asinh -i* ] if ; inline
: acos ( x -- y )
- dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ;
+ dup [-1,1]? [ >float facos ] [ asin pi 2 / swap - ] if ;
inline
GENERIC: atan ( x -- y ) foldable
-M: complex atan i* atanh i* ;
+M: complex atan i* atanh i* ; inline
+
+M: float atan fatan ; inline
-M: real atan fatan ; inline
+M: real atan >float atan ; inline
: asec ( x -- y ) recip acos ; inline
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
SYMBOL: empty-interval
-SYMBOL: full-interval
+SINGLETON: full-interval
TUPLE: interval { from read-only } { to read-only } ;
] 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? [
ARTICLE: "math.libm" "C standard library math functions"
"The words in the " { $vocab-link "math.libm" } " vocabulary call C standard library math functions. They are used to implement words in the " { $vocab-link "math.functions" } " vocabulary."
-$nl
-"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
-{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
-{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." }
+{ $warning
+"These functions are unsafe. The compiler special-cases them to operate on floats only. They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
+{ $example "USE: math.functions" "2.0 acos ." "C{ 0.0 1.316957896924817 }" }
+{ $unchecked-example "USE: math.libm" "2.0 facos ." "0/0." } }
"Trigonometric functions:"
{ $subsection fcos }
{ $subsection fsin }
"Exponentials and logarithms:"
{ $subsection fexp }
{ $subsection flog }
+{ $subsection flog10 }
"Powers:"
{ $subsection fpow }
{ $subsection fsqrt } ;
{ $values { "x" real } { "y" real } }
{ $description "Calls the natural logarithm function from the C standard library. User code should call " { $link log } " instead." } ;
+HELP: flog10
+{ $values { "x" real } { "y" real } }
+{ $description "Calls the base 10 logarithm function from the C standard library. User code should call " { $link log10 } " instead." } ;
+
HELP: fpow
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Calls the power function (" { $snippet "z=x^y" } ") from the C standard library. User code should call " { $link ^ } " instead." } ;
: facos ( x -- y )
"double" "libm" "acos" { "double" } alien-invoke ;
- inline
: fasin ( x -- y )
"double" "libm" "asin" { "double" } alien-invoke ;
- inline
: fatan ( x -- y )
"double" "libm" "atan" { "double" } alien-invoke ;
- inline
: fatan2 ( x y -- z )
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
- inline
: fcos ( x -- y )
"double" "libm" "cos" { "double" } alien-invoke ;
- inline
: fsin ( x -- y )
"double" "libm" "sin" { "double" } alien-invoke ;
- inline
: ftan ( x -- y )
"double" "libm" "tan" { "double" } alien-invoke ;
- inline
: fcosh ( x -- y )
"double" "libm" "cosh" { "double" } alien-invoke ;
- inline
: fsinh ( x -- y )
"double" "libm" "sinh" { "double" } alien-invoke ;
- inline
: ftanh ( x -- y )
"double" "libm" "tanh" { "double" } alien-invoke ;
- inline
: fexp ( x -- y )
"double" "libm" "exp" { "double" } alien-invoke ;
- inline
: flog ( x -- y )
"double" "libm" "log" { "double" } alien-invoke ;
- inline
+
+: flog10 ( x -- y )
+ "double" "libm" "log10" { "double" } alien-invoke ;
: fpow ( x y -- z )
"double" "libm" "pow" { "double" "double" } alien-invoke ;
- inline
: fsqrt ( x -- y )
"double" "libm" "sqrt" { "double" } alien-invoke ;
- inline
! Windows doesn't have these...
+: flog1+ ( x -- y )
+ "double" "libm" "log1p" { "double" } alien-invoke ;
+
: facosh ( x -- y )
"double" "libm" "acosh" { "double" } alien-invoke ;
- inline
: fasinh ( x -- y )
"double" "libm" "asinh" { "double" } alien-invoke ;
- inline
: fatanh ( x -- y )
"double" "libm" "atanh" { "double" } alien-invoke ;
- inline
[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
-[ { 1 2 } { "a" "b" } cross-zip ] unit-test
\ No newline at end of file
+[ { 1 2 } { "a" "b" } cross-zip ] unit-test
+
+[ { { 4181 6765 } { 6765 10946 } } ]
+[ { { 0 1 } { 1 1 } } 20 m^n ] unit-test
: m^n ( m n -- n )
make-bits over first length identity-matrix
- [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
+ [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
\ No newline at end of file
\ <= define-math-ops
\ > define-math-ops
\ >= define-math-ops
+
+ \ u< define-math-ops
+ \ u<= define-math-ops
+ \ u> define-math-ops
+ \ u>= define-math-ops
+
\ number= define-math-ops
{ { shift bignum bignum } bignum-shift } ,
{ { 13 4253 15823 32472893749823741 } } [ 28408516453955558205925627 factors ] unit-test
{ { 1 2 3 4 6 8 12 24 } } [ 24 divisors ] unit-test
{ 24 } [ 360 divisors length ] unit-test
+{ { 1 } } [ 1 divisors ] unit-test
} cond ; foldable
: divisors ( n -- seq )
- group-factors [ first2 [0,b] [ ^ ] with map ] map
- [ product ] product-map natural-sort ;
+ dup 1 = [
+ 1array
+ ] [
+ group-factors [ first2 [0,b] [ ^ ] with map ] map
+ [ product ] product-map natural-sort
+ ] if ;
: 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
: (find-relative-prime) ( n guess -- p )
over 1 <= [ over no-relative-prime ] when
dup 1 <= [ drop 3 ] when
- 2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
+ [ 2dup coprime? ] [ 2 + ] until nip ;
PRIVATE>
--- /dev/null
+USING: help.markup help.syntax math.rectangles ;
+IN: math.rectangles.positioning
+
+HELP: popup-rect
+{ $values { "visible-rect" rect } { "popup-dim" "a pair of real numbers" } { "screen-dim" "a pair of real numbers" } { "rect" rect } }
+{ $description "Calculates the position of a popup with a heuristic:"
+ { $list
+ { "The new rectangle must fit inside " { $snippet "screen-dim" } }
+ { "The new rectangle must not obscure " { $snippet "visible-rect" } }
+ { "The child must otherwise be as close as possible to the edges of " { $snippet "visible-rect" } }
+ }
+ "For example, when displaying a menu, " { $snippet "visible-rect" } " is a single point at the mouse location, and when displaying a completion popup, " { $snippet "visible-rect" } " contains the bounds of the text element being completed."
+} ;
IN: math.rectangles.positioning.tests
[ T{ rect f { 0 1 } { 30 30 } } ] [
- { 0 0 } { 1 1 } <rect>
+ T{ rect f { 0 0 } { 1 1 } }
{ 30 30 }
{ 100 100 }
popup-rect
] unit-test
[ T{ rect f { 10 21 } { 30 30 } } ] [
- { 10 20 } { 1 1 } <rect>
+ T{ rect f { 10 20 } { 1 1 } }
{ 30 30 }
{ 100 100 }
popup-rect
] unit-test
[ T{ rect f { 10 30 } { 30 30 } } ] [
- { 10 20 } { 1 10 } <rect>
+ T{ rect f { 10 20 } { 1 10 } }
{ 30 30 }
{ 100 100 }
popup-rect
] unit-test
[ T{ rect f { 20 20 } { 80 30 } } ] [
- { 40 10 } { 1 10 } <rect>
+ T{ rect f { 40 10 } { 1 10 } }
{ 80 30 }
{ 100 100 }
popup-rect
] unit-test
[ T{ rect f { 50 20 } { 50 50 } } ] [
- { 50 70 } { 0 0 } <rect>
+ T{ rect f { 50 70 } { 0 0 } }
{ 50 50 }
{ 100 100 }
popup-rect
] unit-test
[ T{ rect f { 0 20 } { 50 50 } } ] [
- { -50 70 } { 0 0 } <rect>
+ T{ rect f { -50 70 } { 0 0 } }
{ 50 50 }
{ 100 100 }
popup-rect
] unit-test
[ T{ rect f { 0 50 } { 50 50 } } ] [
- { 0 50 } { 0 0 } <rect>
+ T{ rect f { 0 50 } { 0 0 } }
{ 50 60 }
{ 100 100 }
popup-rect
+] unit-test
+
+[ T{ rect f { 0 90 } { 10 10 } } ] [
+ T{ rect f { 0 1000 } { 0 0 } }
+ { 10 10 }
+ { 100 100 }
+ popup-rect
] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel accessors math math.vectors
-math.rectangles math.order arrays locals
+math.rectangles math.order arrays locals fry
combinators.short-circuit ;
IN: math.rectangles.positioning
! Some geometry code for positioning popups and menus
! in a semi-intelligent manner
+<PRIVATE
+
+: adjust-visible-rect ( visible-rect popup-dim screen-dim -- visible-rect' )
+ [ drop clone ] dip '[ _ vmin ] change-loc ;
+
: popup-x ( visible-rect popup-dim screen-dim -- x )
[ loc>> first ] 2dip swap [ first ] bi@ - min 0 max ;
:: popup-dim ( loc popup-dim screen-dim -- dim )
screen-dim loc v- popup-dim vmin ;
+PRIVATE>
+
: popup-rect ( visible-rect popup-dim screen-dim -- rect )
+ [ adjust-visible-rect ] 2keep
[ popup-loc dup ] 2keep popup-dim <rect> ;
\ No newline at end of file
--- /dev/null
+USING: cpu.architecture math.vectors.simd
+math.vectors.simd.intrinsics accessors math.vectors.simd.alien
+kernel classes.struct tools.test compiler sequences byte-arrays
+alien math kernel.private specialized-arrays combinators ;
+SPECIALIZED-ARRAY: float
+IN: math.vectors.simd.alien.tests
+
+! Vector alien intrinsics
+[ float-4{ 1 2 3 4 } ] [
+ [
+ float-4{ 1 2 3 4 }
+ underlying>> 0 float-4-rep alien-vector
+ ] compile-call float-4 boa
+] unit-test
+
+[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
+ 16 [ 1 ] B{ } replicate-as 16 <byte-array>
+ [
+ 0 [
+ { byte-array c-ptr fixnum } declare
+ float-4-rep set-alien-vector
+ ] compile-call
+ ] keep
+] unit-test
+
+[ float-array{ 1 2 3 4 } ] [
+ [
+ float-array{ 1 2 3 4 } underlying>>
+ float-array{ 4 3 2 1 } clone
+ [ underlying>> 0 float-4-rep set-alien-vector ] keep
+ ] compile-call
+] unit-test
+
+STRUCT: simd-struct
+{ x float-4 }
+{ y double-2 }
+{ z double-4 }
+{ w float-8 } ;
+
+[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
+
+[
+ float-4{ 1 2 3 4 }
+ double-2{ 2 1 }
+ double-4{ 4 3 2 1 }
+ float-8{ 1 2 3 4 5 6 7 8 }
+] [
+ simd-struct <struct>
+ float-4{ 1 2 3 4 } >>x
+ double-2{ 2 1 } >>y
+ double-4{ 4 3 2 1 } >>z
+ float-8{ 1 2 3 4 5 6 7 8 } >>w
+ { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
+] unit-test
+
+[
+ float-4{ 1 2 3 4 }
+ double-2{ 2 1 }
+ double-4{ 4 3 2 1 }
+ float-8{ 1 2 3 4 5 6 7 8 }
+] [
+ [
+ simd-struct <struct>
+ float-4{ 1 2 3 4 } >>x
+ double-2{ 2 1 } >>y
+ double-4{ 4 3 2 1 } >>z
+ float-8{ 1 2 3 4 5 6 7 8 } >>w
+ { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
+ ] compile-call
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien accessors alien.c-types byte-arrays compiler.units
+cpu.architecture locals kernel math math.vectors.simd
+math.vectors.simd.intrinsics ;
+IN: math.vectors.simd.alien
+
+:: define-simd-128-type ( class rep -- )
+ <c-type>
+ byte-array >>class
+ class >>boxed-class
+ [ rep alien-vector class boa ] >>getter
+ [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
+ 16 >>size
+ 8 >>align
+ rep >>rep
+ class name>> typedef ;
+
+:: define-simd-256-type ( class rep -- )
+ <c-type>
+ class >>class
+ class >>boxed-class
+ [
+ [ rep alien-vector ]
+ [ 16 + >fixnum rep alien-vector ] 2bi
+ class boa
+ ] >>getter
+ [
+ [ [ underlying1>> ] 2dip rep set-alien-vector ]
+ [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ]
+ 3bi
+ ] >>setter
+ 32 >>size
+ 8 >>align
+ rep >>rep
+ class name>> typedef ;
+[
+ float-4 float-4-rep define-simd-128-type
+ double-2 double-2-rep define-simd-128-type
+ float-8 float-4-rep define-simd-256-type
+ double-4 double-2-rep define-simd-256-type
+] with-compilation-unit
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types byte-arrays classes functors
+kernel math parser prettyprint.custom sequences
+sequences.private literals ;
+IN: math.vectors.simd.functor
+
+ERROR: bad-length got expected ;
+
+FUNCTOR: define-simd-128 ( T -- )
+
+N [ 16 T heap-size /i ]
+
+A DEFINES-CLASS ${T}-${N}
+>A DEFINES >${A}
+A{ DEFINES ${A}{
+
+NTH [ T dup c-type-getter-boxer array-accessor ]
+SET-NTH [ T dup c-setter array-accessor ]
+
+A-rep IS ${A}-rep
+A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
+
+WHERE
+
+TUPLE: A
+{ underlying byte-array read-only initial: $[ 16 <byte-array> ] } ;
+
+M: A clone underlying>> clone \ A boa ; inline
+
+M: A length drop N ; inline
+
+M: A nth-unsafe underlying>> NTH call ; inline
+
+M: A set-nth-unsafe underlying>> SET-NTH call ; inline
+
+: >A ( seq -- simd-array ) \ A new clone-like ;
+
+M: A like drop dup \ A instance? [ >A ] unless ; inline
+
+M: A new-sequence
+ drop dup N =
+ [ drop 16 <byte-array> \ A boa ]
+ [ N bad-length ]
+ if ; inline
+
+M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
+
+M: A byte-length underlying>> length ; inline
+
+M: A pprint-delims drop \ A{ \ } ;
+
+M: A >pprint-sequence ;
+
+M: A pprint* pprint-object ;
+
+SYNTAX: A{ \ } [ >A ] parse-literal ;
+
+INSTANCE: A sequence
+
+<PRIVATE
+
+: A-vv->v-op ( v1 v2 quot -- v3 )
+ [ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline
+
+: A-v->n-op ( v quot -- n )
+ [ underlying>> A-rep ] dip call ; inline
+
+PRIVATE>
+
+;FUNCTOR
+
+! Synthesize 256-bit vectors from a pair of 128-bit vectors
+FUNCTOR: define-simd-256 ( T -- )
+
+N [ 32 T heap-size /i ]
+
+N/2 [ N 2 / ]
+A/2 IS ${T}-${N/2}
+
+A DEFINES-CLASS ${T}-${N}
+>A DEFINES >${A}
+A{ DEFINES ${A}{
+
+A-deref DEFINES-PRIVATE ${A}-deref
+
+A-rep IS ${A/2}-rep
+A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
+
+WHERE
+
+SLOT: underlying1
+SLOT: underlying2
+
+TUPLE: A
+{ underlying1 byte-array initial: $[ 16 <byte-array> ] read-only }
+{ underlying2 byte-array initial: $[ 16 <byte-array> ] read-only } ;
+
+M: A clone
+ [ underlying1>> clone ] [ underlying2>> clone ] bi
+ \ A boa ; inline
+
+M: A length drop N ; inline
+
+: A-deref ( n seq -- n' seq' )
+ over N/2 < [ underlying1>> ] [ [ N/2 - ] dip underlying2>> ] if \ A/2 boa ; inline
+
+M: A nth-unsafe A-deref nth-unsafe ; inline
+
+M: A set-nth-unsafe A-deref set-nth-unsafe ; inline
+
+: >A ( seq -- simd-array ) \ A new clone-like ;
+
+M: A like drop dup \ A instance? [ >A ] unless ; inline
+
+M: A new-sequence
+ drop dup N =
+ [ drop 16 <byte-array> 16 <byte-array> \ A boa ]
+ [ N bad-length ]
+ if ; inline
+
+M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
+
+M: A byte-length drop 32 ; inline
+
+SYNTAX: A{ \ } [ >A ] parse-literal ;
+
+M: A pprint-delims drop \ A{ \ } ;
+
+M: A >pprint-sequence ;
+
+M: A pprint* pprint-object ;
+
+INSTANCE: A sequence
+
+: A-vv->v-op ( v1 v2 quot -- v3 )
+ [ [ [ underlying1>> ] bi@ A-rep ] dip call ]
+ [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
+ \ A boa ; inline
+
+: A-v->n-op ( v1 combine-quot reduce-quot -- v2 )
+ [ [ [ underlying1>> ] [ underlying2>> ] bi A-rep ] dip call A-rep ]
+ dip call ; inline
+
+;FUNCTOR
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel alien alien.c-types cpu.architecture libc ;
+IN: math.vectors.simd.intrinsics
+
+ERROR: bad-simd-call ;
+
+: (simd-v+) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-v-) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-v*) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-v/) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-vmin) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-vmax) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-vsqrt) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-sum) ( v1 rep -- v2 ) bad-simd-call ;
+: (simd-broadcast) ( x rep -- v ) bad-simd-call ;
+: (simd-gather-2) ( a b rep -- v ) bad-simd-call ;
+: (simd-gather-4) ( a b c d rep -- v ) bad-simd-call ;
+: assert-positive ( x -- y ) ;
+
+: alien-vector ( c-ptr n rep -- value )
+ ! Inefficient version for when intrinsics are missing
+ [ swap <displaced-alien> ] dip rep-size memory>byte-array ;
+
+: set-alien-vector ( value c-ptr n rep -- )
+ ! Inefficient version for when intrinsics are missing
+ [ swap <displaced-alien> swap ] dip rep-size memcpy ;
+
--- /dev/null
+USING: help.markup help.syntax sequences math math.vectors
+multiline kernel.private classes.tuple.private
+math.vectors.simd.intrinsics cpu.architecture ;
+IN: math.vectors.simd
+
+ARTICLE: "math.vectors.simd.intro" "Introduction to SIMD support"
+"Modern CPUs support a form of data-level parallelism, where arithmetic operations on fixed-size short vectors can be done on all components in parallel. This is known as single-instruction-multiple-data (SIMD)."
+$nl
+"SIMD support in the processor takes the form of instruction sets which operate on vector registers. By operating on multiple scalar values at the same time, code which operates on points, colors, and other vector data can be sped up."
+$nl
+"In Factor, SIMD support is exposed in the form of special-purpose SIMD " { $link "sequence-protocol" } " implementations. These are fixed-length, homogeneous sequences. They are referred to as vectors, but should not be confused with Factor's " { $link "vectors" } ", which can hold any type of object and can be resized.)."
+$nl
+"The words in the " { $vocab-link "math.vectors" } " vocabulary, which can be used with any sequence of numbers, are special-cased by the compiler. If the compiler can prove that only SIMD vectors are used, it expands " { $link "math-vectors" } " into " { $link "math.vectors.simd.intrinsics" } ". While in the general case, SIMD intrinsics operate on heap-allocated SIMD vectors, that too can be optimized since in many cases the compiler unbox SIMD vectors, storing them directly in registers."
+$nl
+"Since the only difference between ordinary code and SIMD-accelerated code is that the latter uses special fixed-length SIMD sequences, the SIMD library is very easy to use. To ensure your code compiles to use vector instructions without boxing and unboxing overhead, follow the guidelines for " { $link "math.vectors.simd.efficiency" } "."
+$nl
+"There should never be any reason to use " { $link "math.vectors.simd.intrinsics" } " directly, but they too have a straightforward, but lower-level, interface." ;
+
+ARTICLE: "math.vectors.simd.support" "Supported SIMD instruction sets and operations"
+"At present, the SIMD support makes use of SSE2 and a few SSE3 instructions on x86 CPUs."
+$nl
+"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } ". If SSE3 is not available, software fallbacks are used for " { $link sum } " and related words, decreasing performance."
+$nl
+"On PowerPC, or older x86 chips without SSE2, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance."
+$nl
+"The primities in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary do not have software fallbacks, but they should not be called directly in any case." ;
+
+ARTICLE: "math.vectors.simd.types" "SIMD vector types"
+"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type such as " { $snippet "float" } " or " { $snippet "double" } ", and " { $snippet "count" } " is a vector dimension, such as 2, 4, or 8."
+$nl
+"The following vector types are defined:"
+{ $subsection float-4 }
+{ $subsection double-2 }
+{ $subsection float-8 }
+{ $subsection double-4 }
+"For each vector type, several words are defined:"
+{ $table
+ { "Word" "Stack effect" "Description" }
+ { { $snippet "type-with" } { $snippet "( x -- simd-array )" } "creates a new instance where all components are set to a single scalar" }
+ { { $snippet "type-boa" } { $snippet "( ... -- simd-array )" } "creates a new instance where components are read from the stack" }
+ { { $snippet ">type" } { $snippet "( seq -- simd-array )" } "creates a new instance initialized with the elements of an existing sequence, which must have the correct length" }
+ { { $snippet "type{" } { $snippet "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" }
+}
+"The " { $link float-4 } " and " { $link double-2 } " types correspond to 128-bit vector registers. The " { $link float-8 } " and " { $link double-4 } " types are not directly supported in hardware, and instead unbox to a pair of 128-bit vector registers."
+$nl
+"Operations on " { $link float-4 } " instances:"
+{ $subsection float-4-with }
+{ $subsection float-4-boa }
+{ $subsection POSTPONE: float-4{ }
+"Operations on " { $link double-2 } " instances:"
+{ $subsection double-2-with }
+{ $subsection double-2-boa }
+{ $subsection POSTPONE: double-2{ }
+"Operations on " { $link float-8 } " instances:"
+{ $subsection float-8-with }
+{ $subsection float-8-boa }
+{ $subsection POSTPONE: float-8{ }
+"Operations on " { $link double-4 } " instances:"
+{ $subsection double-4-with }
+{ $subsection double-4-boa }
+{ $subsection POSTPONE: double-4{ }
+"To actually perform vector arithmetic on SIMD vectors, use " { $link "math-vectors" } " words."
+{ $see-also "c-types-specs" } ;
+
+ARTICLE: "math.vectors.simd.efficiency" "Writing efficient SIMD code"
+"Since SIMD vectors are heap-allocated objects, it is important to write code in a style which is conducive to the compiler being able to inline generic dispatch and eliminate allocation."
+$nl
+"If the inputs to a " { $vocab-link "math.vectors" } " word are statically known to be SIMD vectors, the call is converted into an SIMD primitive, and the output is then also known to be an SIMD vector (or scalar, depending on the operation); this information propagates forward within a single word (together with any inlined words and macro expansions). Any intermediate values which are not stored into collections, or returned from the word, are furthermore unboxed."
+$nl
+"To check if optimizations are being performed, pass a quotation to the " { $snippet "optimizer-report." } " and " { $snippet "optimized." } " words in the " { $vocab-link "compiler.tree.debugger" } " vocabulary, and look for calls to " { $link "math.vectors.simd.intrinsics" } " as opposed to high-level " { $link "math-vectors" } "."
+$nl
+"For example, in the following, no SIMD operations are used at all, because the compiler's propagation pass does not consider dynamic variable usage:"
+{ $code
+<" USING: compiler.tree.debugger math.vectors
+math.vectors.simd ;
+SYMBOLS: x y ;
+
+[
+ double-4{ 1.5 2.0 3.7 0.4 } x set
+ double-4{ 1.5 2.0 3.7 0.4 } y set
+ x get y get v+
+] optimizer-report."> }
+"The following word benefits from SIMD optimization, because it begins with an unsafe declaration:"
+{ $code
+<" USING: compiler.tree.debugger kernel.private
+math.vectors math.vectors.simd ;
+
+: interpolate ( v a b -- w )
+ { float-4 float-4 float-4 } declare
+ [ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
+
+\ interpolate optimizer-report. "> }
+"Note that using " { $link declare } " is not recommended. Safer ways of getting type information for the input parameters to a word include defining methods on a generic word (the value being dispatched upon has a statically known type in the method body), as well as using " { $link "hints" } " and " { $link POSTPONE: inline } " declarations."
+$nl
+"Here is a better version of the " { $snippet "interpolate" } " words above that uses hints:"
+{ $code
+<" USING: compiler.tree.debugger hints
+math.vectors math.vectors.simd ;
+
+: interpolate ( v a b -- w )
+ [ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
+
+HINTS: interpolate float-4 float-4 float-4 ;
+
+\ interpolate optimizer-report. "> }
+"This time, the optimizer report lists calls to both SIMD primitives and high-level vector words, because hints cause two code paths to be generated. The " { $snippet "optimized." } " word can be used to make sure that the fast code path consists entirely of calls to primitives."
+$nl
+"If the " { $snippet "interpolate" } " word was to be used in several places with different types of vectors, it would be best to declare it " { $link POSTPONE: inline } "."
+$nl
+"In the " { $snippet "interpolate" } " word, there is still a call to the " { $link <tuple-boa> } " primitive, because the return value at the end is being boxed on the heap. In the next example, no memory allocation occurs at all because the SIMD vectors are stored inside a struct class (see " { $link "classes.struct" } "); also note the use of inlining:"
+{ $code
+<" USING: compiler.tree.debugger math.vectors math.vectors.simd ;
+IN: simd-demo
+
+STRUCT: actor
+{ id int }
+{ position float-4 }
+{ velocity float-4 }
+{ acceleration float-4 } ;
+
+GENERIC: advance ( dt object -- )
+
+: update-velocity ( dt actor -- )
+ [ acceleration>> n*v ] [ velocity>> v+ ] [ ] tri
+ (>>velocity) ; inline
+
+: update-position ( dt actor -- )
+ [ velocity>> n*v ] [ position>> v+ ] [ ] tri
+ (>>position) ; inline
+
+M: actor advance ( dt actor -- )
+ [ >float ] dip
+ [ update-velocity ] [ update-position ] 2bi ;
+
+M\ actor advance optimized.">
+}
+"The " { $vocab-link "compiler.cfg.debugger" } " vocabulary can give a lower-level picture of the generated code, that includes register assignments and other low-level details. To look at low-level optimizer output, call " { $snippet "test-mr mr." } " on a word or quotation:"
+{ $code
+<" USE: compiler.tree.debugger
+
+M\ actor advance test-mr mr."> }
+"An example of a high-performance algorithm that uses SIMD primitives can be found in the " { $vocab-link "benchmark.nbody-simd" } " vocabulary." ;
+
+ARTICLE: "math.vectors.simd.intrinsics" "Low-level SIMD primitives"
+"The words in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary are used to implement SIMD support. These words have three disadvantages compared to the higher-level " { $link "math-vectors" } " words:"
+{ $list
+ "They operate on raw byte arrays, with a separate “representation” parameter passed in to determine the type of the operands and result."
+ "They are unsafe; passing values which are not byte arrays, or byte arrays with the wrong size, will dereference invalid memory and possibly crash Factor."
+ { "They do not have software fallbacks; if the current CPU does not have SIMD support, a " { $link bad-simd-call } " error will be thrown." }
+}
+"The compiler converts " { $link "math-vectors" } " into SIMD primitives automatically in cases where it is safe; this means that the input types are known to be SIMD vectors, and the CPU supports SIMD."
+$nl
+"It is best to avoid calling these primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "."
+{ $subsection (simd-v+) }
+{ $subsection (simd-v-) }
+{ $subsection (simd-v/) }
+{ $subsection (simd-vmin) }
+{ $subsection (simd-vmax) }
+{ $subsection (simd-vsqrt) }
+{ $subsection (simd-sum) }
+{ $subsection (simd-broadcast) }
+{ $subsection (simd-gather-2) }
+{ $subsection (simd-gather-4) }
+"There are two primitives which are used to implement accessing SIMD vector fields of " { $link "classes.struct" } ":"
+{ $subsection alien-vector }
+{ $subsection set-alien-vector }
+"For the most part, the above primitives correspond directly to vector arithmetic words. They take a representation parameter, which is one of the singleton members of the " { $link vector-rep } " union in the " { $vocab-link "cpu.architecture" } " vocabulary." ;
+
+ARTICLE: "math.vectors.simd.alien" "SIMD data in struct classes"
+"Struct classes may contain fields which store SIMD data; use one of the following C type names:"
+{ $code
+<" float-4
+double-2
+float-8
+double-4"> }
+"Passing SIMD data as function parameters is not yet supported." ;
+
+ARTICLE: "math.vectors.simd" "Hardware vector arithmetic (SIMD)"
+"The " { $vocab-link "math.vectors.simd" } " vocabulary extends the " { $vocab-link "math.vectors" } " vocabulary to support efficient vector arithmetic on small, fixed-size vectors."
+{ $subsection "math.vectors.simd.intro" }
+{ $subsection "math.vectors.simd.types" }
+{ $subsection "math.vectors.simd.support" }
+{ $subsection "math.vectors.simd.efficiency" }
+{ $subsection "math.vectors.simd.alien" }
+{ $subsection "math.vectors.simd.intrinsics" } ;
+
+! ! ! float-4
+
+HELP: float-4
+{ $class-description "A sequence of four single-precision floating point values. New instances can be created with " { $link float-4-with } " or " { $link float-4-boa } "." } ;
+
+HELP: float-4-with
+{ $values { "x" float } { "simd-array" float-4 } }
+{ $description "Creates a new vector with all four components equal to a scalar." } ;
+
+HELP: float-4-boa
+{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" float-4 } }
+{ $description "Creates a new vector from four scalar components." } ;
+
+HELP: float-4{
+{ $syntax "float-4{ a b c d }" }
+{ $description "Literal syntax for a " { $link float-4 } "." } ;
+
+! ! ! double-2
+
+HELP: double-2
+{ $class-description "A sequence of two double-precision floating point values. New instances can be created with " { $link double-2-with } " or " { $link double-2-boa } "." } ;
+
+HELP: double-2-with
+{ $values { "x" float } { "simd-array" double-2 } }
+{ $description "Creates a new vector with both components equal to a scalar." } ;
+
+HELP: double-2-boa
+{ $values { "a" float } { "b" float } { "simd-array" double-2 } }
+{ $description "Creates a new vector from two scalar components." } ;
+
+HELP: double-2{
+{ $syntax "double-2{ a b }" }
+{ $description "Literal syntax for a " { $link double-2 } "." } ;
+
+! ! ! float-8
+
+HELP: float-8
+{ $class-description "A sequence of eight single-precision floating point values. New instances can be created with " { $link float-8-with } " or " { $link float-8-boa } "." } ;
+
+HELP: float-8-with
+{ $values { "x" float } { "simd-array" float-8 } }
+{ $description "Creates a new vector with all eight components equal to a scalar." } ;
+
+HELP: float-8-boa
+{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "e" float } { "f" float } { "g" float } { "h" float } { "simd-array" float-8 } }
+{ $description "Creates a new vector from eight scalar components." } ;
+
+HELP: float-8{
+{ $syntax "float-8{ a b c d e f g h }" }
+{ $description "Literal syntax for a " { $link float-8 } "." } ;
+
+! ! ! double-4
+
+HELP: double-4
+{ $class-description "A sequence of four double-precision floating point values. New instances can be created with " { $link double-4-with } " or " { $link double-4-boa } "." } ;
+
+HELP: double-4-with
+{ $values { "x" float } { "simd-array" double-4 } }
+{ $description "Creates a new vector with all four components equal to a scalar." } ;
+
+HELP: double-4-boa
+{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" double-4 } }
+{ $description "Creates a new vector from four scalar components." } ;
+
+HELP: double-4{
+{ $syntax "double-4{ a b c d }" }
+{ $description "Literal syntax for a " { $link double-4 } "." } ;
+
+ABOUT: "math.vectors.simd"
--- /dev/null
+IN: math.vectors.simd.tests
+USING: math math.vectors.simd math.vectors.simd.private
+math.vectors math.functions math.private kernel.private compiler
+sequences tools.test compiler.tree.debugger accessors kernel
+system ;
+
+[ float-4{ 0 0 0 0 } ] [ float-4 new ] unit-test
+
+[ float-4{ 0 0 0 0 } ] [ [ float-4 new ] compile-call ] unit-test
+
+[ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test
+
+[ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test
+
+[ float-4{ 12 12 12 12 } ] [
+ 12 [ float-4-with ] compile-call
+] unit-test
+
+[ float-4{ 1 2 3 4 } ] [
+ 1 2 3 4 [ float-4-boa ] compile-call
+] unit-test
+
+[ float-4{ 11 22 33 44 } ] [
+ float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
+ [ { float-4 float-4 } declare v+ ] compile-call
+] unit-test
+
+[ float-4{ -9 -18 -27 -36 } ] [
+ float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
+ [ { float-4 float-4 } declare v- ] compile-call
+] unit-test
+
+[ float-4{ 10 40 90 160 } ] [
+ float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
+ [ { float-4 float-4 } declare v* ] compile-call
+] unit-test
+
+[ float-4{ 10 100 1000 10000 } ] [
+ float-4{ 100 2000 30000 400000 } float-4{ 10 20 30 40 }
+ [ { float-4 float-4 } declare v/ ] compile-call
+] unit-test
+
+[ float-4{ -10 -20 -30 -40 } ] [
+ float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
+ [ { float-4 float-4 } declare vmin ] compile-call
+] unit-test
+
+[ float-4{ 10 20 30 40 } ] [
+ float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
+ [ { float-4 float-4 } declare vmax ] compile-call
+] unit-test
+
+[ 10.0 ] [
+ float-4{ 1 2 3 4 }
+ [ { float-4 } declare sum ] compile-call
+] unit-test
+
+[ 13.0 ] [
+ float-4{ 1 2 3 4 }
+ [ { float-4 } declare sum 3.0 + ] compile-call
+] unit-test
+
+[ 8.0 ] [
+ float-4{ 1 2 3 4 } float-4{ 2 0 2 0 }
+ [ { float-4 float-4 } declare v. ] compile-call
+] unit-test
+
+[ float-4{ 5 10 15 20 } ] [
+ 5.0 float-4{ 1 2 3 4 }
+ [ { float float-4 } declare n*v ] compile-call
+] unit-test
+
+[ float-4{ 5 10 15 20 } ] [
+ float-4{ 1 2 3 4 } 5.0
+ [ { float float-4 } declare v*n ] compile-call
+] unit-test
+
+[ float-4{ 10 5 2 5 } ] [
+ 10.0 float-4{ 1 2 5 2 }
+ [ { float float-4 } declare n/v ] compile-call
+] unit-test
+
+[ float-4{ 0.5 1 1.5 2 } ] [
+ float-4{ 1 2 3 4 } 2
+ [ { float float-4 } declare v/n ] compile-call
+] unit-test
+
+[ float-4{ 1 0 0 0 } ] [
+ float-4{ 10 0 0 0 }
+ [ { float-4 } declare normalize ] compile-call
+] unit-test
+
+[ 30.0 ] [
+ float-4{ 1 2 3 4 }
+ [ { float-4 } declare norm-sq ] compile-call
+] unit-test
+
+[ t ] [
+ float-4{ 1 0 0 0 }
+ float-4{ 0 1 0 0 }
+ [ { float-4 float-4 } declare distance ] compile-call
+ 2 sqrt 1.0e-6 ~
+] unit-test
+
+[ double-2{ 12 12 } ] [
+ 12 [ double-2-with ] compile-call
+] unit-test
+
+[ double-2{ 1 2 } ] [
+ 1 2 [ double-2-boa ] compile-call
+] unit-test
+
+[ double-2{ 11 22 } ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v+ ] compile-call
+] unit-test
+
+[ double-2{ -9 -18 } ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v- ] compile-call
+] unit-test
+
+[ double-2{ 10 40 } ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v* ] compile-call
+] unit-test
+
+[ double-2{ 10 100 } ] [
+ double-2{ 100 2000 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v/ ] compile-call
+] unit-test
+
+[ double-2{ -10 -20 } ] [
+ double-2{ -10 20 } double-2{ 10 -20 }
+ [ { double-2 double-2 } declare vmin ] compile-call
+] unit-test
+
+[ double-2{ 10 20 } ] [
+ double-2{ -10 20 } double-2{ 10 -20 }
+ [ { double-2 double-2 } declare vmax ] compile-call
+] unit-test
+
+[ 3.0 ] [
+ double-2{ 1 2 }
+ [ { double-2 } declare sum ] compile-call
+] unit-test
+
+[ 7.0 ] [
+ double-2{ 1 2 }
+ [ { double-2 } declare sum 4.0 + ] compile-call
+] unit-test
+
+[ 16.0 ] [
+ double-2{ 1 2 } double-2{ 2 7 }
+ [ { double-2 double-2 } declare v. ] compile-call
+] unit-test
+
+[ double-2{ 5 10 } ] [
+ 5.0 double-2{ 1 2 }
+ [ { float double-2 } declare n*v ] compile-call
+] unit-test
+
+[ double-2{ 5 10 } ] [
+ double-2{ 1 2 } 5.0
+ [ { float double-2 } declare v*n ] compile-call
+] unit-test
+
+[ double-2{ 10 5 } ] [
+ 10.0 double-2{ 1 2 }
+ [ { float double-2 } declare n/v ] compile-call
+] unit-test
+
+[ double-2{ 0.5 1 } ] [
+ double-2{ 1 2 } 2
+ [ { float double-2 } declare v/n ] compile-call
+] unit-test
+
+[ double-2{ 0 0 } ] [ double-2 new ] unit-test
+
+[ double-2{ 1 0 } ] [
+ double-2{ 10 0 }
+ [ { double-2 } declare normalize ] compile-call
+] unit-test
+
+[ 5.0 ] [
+ double-2{ 1 2 }
+ [ { double-2 } declare norm-sq ] compile-call
+] unit-test
+
+[ t ] [
+ double-2{ 1 0 }
+ double-2{ 0 1 }
+ [ { double-2 double-2 } declare distance ] compile-call
+ 2 sqrt 1.0e-6 ~
+] unit-test
+
+[ double-4{ 0 0 0 0 } ] [ double-4 new ] unit-test
+
+[ double-4{ 1 2 3 4 } ] [
+ 1 2 3 4 double-4-boa
+] unit-test
+
+[ double-4{ 1 1 1 1 } ] [
+ 1 double-4-with
+] unit-test
+
+[ double-4{ 0 1 2 3 } ] [
+ 1 double-4-with [ * ] map-index
+] unit-test
+
+[ V{ float } ] [ [ { double-4 } declare norm-sq ] final-classes ] unit-test
+
+[ V{ float } ] [ [ { double-4 } declare norm ] final-classes ] unit-test
+
+[ double-4{ 12 12 12 12 } ] [
+ 12 [ double-4-with ] compile-call
+] unit-test
+
+[ double-4{ 1 2 3 4 } ] [
+ 1 2 3 4 [ double-4-boa ] compile-call
+] unit-test
+
+[ double-4{ 11 22 33 44 } ] [
+ double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
+ [ { double-4 double-4 } declare v+ ] compile-call
+] unit-test
+
+[ double-4{ -9 -18 -27 -36 } ] [
+ double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
+ [ { double-4 double-4 } declare v- ] compile-call
+] unit-test
+
+[ double-4{ 10 40 90 160 } ] [
+ double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
+ [ { double-4 double-4 } declare v* ] compile-call
+] unit-test
+
+[ double-4{ 10 100 1000 10000 } ] [
+ double-4{ 100 2000 30000 400000 } double-4{ 10 20 30 40 }
+ [ { double-4 double-4 } declare v/ ] compile-call
+] unit-test
+
+[ double-4{ -10 -20 -30 -40 } ] [
+ double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
+ [ { double-4 double-4 } declare vmin ] compile-call
+] unit-test
+
+[ double-4{ 10 20 30 40 } ] [
+ double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
+ [ { double-4 double-4 } declare vmax ] compile-call
+] unit-test
+
+[ 10.0 ] [
+ double-4{ 1 2 3 4 }
+ [ { double-4 } declare sum ] compile-call
+] unit-test
+
+[ 13.0 ] [
+ double-4{ 1 2 3 4 }
+ [ { double-4 } declare sum 3.0 + ] compile-call
+] unit-test
+
+[ 8.0 ] [
+ double-4{ 1 2 3 4 } double-4{ 2 0 2 0 }
+ [ { double-4 double-4 } declare v. ] compile-call
+] unit-test
+
+[ double-4{ 5 10 15 20 } ] [
+ 5.0 double-4{ 1 2 3 4 }
+ [ { float double-4 } declare n*v ] compile-call
+] unit-test
+
+[ double-4{ 5 10 15 20 } ] [
+ double-4{ 1 2 3 4 } 5.0
+ [ { float double-4 } declare v*n ] compile-call
+] unit-test
+
+[ double-4{ 10 5 2 5 } ] [
+ 10.0 double-4{ 1 2 5 2 }
+ [ { float double-4 } declare n/v ] compile-call
+] unit-test
+
+[ double-4{ 0.5 1 1.5 2 } ] [
+ double-4{ 1 2 3 4 } 2
+ [ { float double-4 } declare v/n ] compile-call
+] unit-test
+
+[ double-4{ 1 0 0 0 } ] [
+ double-4{ 10 0 0 0 }
+ [ { double-4 } declare normalize ] compile-call
+] unit-test
+
+[ 30.0 ] [
+ double-4{ 1 2 3 4 }
+ [ { double-4 } declare norm-sq ] compile-call
+] unit-test
+
+[ t ] [
+ double-4{ 1 0 0 0 }
+ double-4{ 0 1 0 0 }
+ [ { double-4 double-4 } declare distance ] compile-call
+ 2 sqrt 1.0e-6 ~
+] unit-test
+
+[ float-8{ 0 0 0 0 0 0 0 0 } ] [ float-8 new ] unit-test
+
+[ float-8{ 0 0 0 0 0 0 0 0 } ] [ [ float-8 new ] compile-call ] unit-test
+
+[ float-8{ 1 1 1 1 1 1 1 1 } ] [ 1 float-8-with ] unit-test
+
+[ float-8{ 1 1 1 1 1 1 1 1 } ] [ [ 1 float-8-with ] compile-call ] unit-test
+
+[ float-8{ 1 2 3 4 5 6 7 8 } ] [ 1 2 3 4 5 6 7 8 float-8-boa ] unit-test
+
+[ float-8{ 1 2 3 4 5 6 7 8 } ] [ [ 1 2 3 4 5 6 7 8 float-8-boa ] compile-call ] unit-test
+
+[ float-8{ 3 6 9 12 15 18 21 24 } ] [
+ float-8{ 1 2 3 4 5 6 7 8 }
+ float-8{ 2 4 6 8 10 12 14 16 }
+ [ { float-8 float-8 } declare v+ ] compile-call
+] unit-test
+
+[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+ float-8{ 1 2 3 4 5 6 7 8 }
+ float-8{ 2 4 6 8 10 12 14 16 }
+ [ { float-8 float-8 } declare v- ] compile-call
+] unit-test
+
+[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+ -0.5
+ float-8{ 2 4 6 8 10 12 14 16 }
+ [ { float float-8 } declare n*v ] compile-call
+] unit-test
+
+[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+ float-8{ 2 4 6 8 10 12 14 16 }
+ -0.5
+ [ { float-8 float } declare v*n ] compile-call
+] unit-test
+
+[ float-8{ 256 128 64 32 16 8 4 2 } ] [
+ 256.0
+ float-8{ 1 2 4 8 16 32 64 128 }
+ [ { float float-8 } declare n/v ] compile-call
+] unit-test
+
+[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+ float-8{ 2 4 6 8 10 12 14 16 }
+ -2.0
+ [ { float-8 float } declare v/n ] compile-call
+] unit-test
+
+! Test puns; only on x86
+cpu x86? [
+ [ double-2{ 4 1024 } ] [
+ float-4{ 0 1 0 2 }
+ [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
+ ] unit-test
+
+ [ 33.0 ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call
+ ] unit-test
+] when
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types byte-arrays cpu.architecture
+kernel math math.functions math.vectors
+math.vectors.simd.functor math.vectors.simd.intrinsics
+math.vectors.specialization parser prettyprint.custom sequences
+sequences.private locals assocs words fry ;
+IN: math.vectors.simd
+
+<<
+
+DEFER: float-4
+DEFER: double-2
+DEFER: float-8
+DEFER: double-4
+
+"double" define-simd-128
+"float" define-simd-128
+"double" define-simd-256
+"float" define-simd-256
+
+>>
+
+: float-4-with ( x -- simd-array )
+ [ 4 ] dip >float '[ _ ] \ float-4 new replicate-as ;
+
+: float-4-boa ( a b c d -- simd-array )
+ \ float-4 new 4sequence ;
+
+: double-2-with ( x -- simd-array )
+ [ 2 ] dip >float '[ _ ] \ double-2 new replicate-as ;
+
+: double-2-boa ( a b -- simd-array )
+ \ double-2 new 2sequence ;
+
+! More efficient expansions for the above, used when SIMD is
+! actually available.
+
+<<
+
+\ float-4-with [
+ drop
+ \ (simd-broadcast) "intrinsic" word-prop [
+ [ >float float-4-rep (simd-broadcast) \ float-4 boa ]
+ ] [ \ float-4-with def>> ] if
+] "custom-inlining" set-word-prop
+
+\ float-4-boa [
+ drop
+ \ (simd-gather-4) "intrinsic" word-prop [
+ [| a b c d |
+ a >float b >float c >float d >float
+ float-4-rep (simd-gather-4) \ float-4 boa
+ ]
+ ] [ \ float-4-boa def>> ] if
+] "custom-inlining" set-word-prop
+
+\ double-2-with [
+ drop
+ \ (simd-broadcast) "intrinsic" word-prop [
+ [ >float double-2-rep (simd-broadcast) \ double-2 boa ]
+ ] [ \ double-2-with def>> ] if
+] "custom-inlining" set-word-prop
+
+\ double-2-boa [
+ drop
+ \ (simd-gather-4) "intrinsic" word-prop [
+ [ [ >float ] bi@ double-2-rep (simd-gather-2) \ double-2 boa ]
+ ] [ \ double-2-boa def>> ] if
+] "custom-inlining" set-word-prop
+
+>>
+
+: float-8-with ( x -- simd-array )
+ [ float-4-with ] [ float-4-with ] bi [ underlying>> ] bi@
+ \ float-8 boa ; inline
+
+:: float-8-boa ( a b c d e f g h -- simd-array )
+ a b c d float-4-boa
+ e f g h float-4-boa
+ [ underlying>> ] bi@
+ \ float-8 boa ; inline
+
+: double-4-with ( x -- simd-array )
+ [ double-2-with ] [ double-2-with ] bi [ underlying>> ] bi@
+ \ double-4 boa ; inline
+
+:: double-4-boa ( a b c d -- simd-array )
+ a b double-2-boa
+ c d double-2-boa
+ [ underlying>> ] bi@
+ \ double-4 boa ; inline
+
+<<
+
+<PRIVATE
+
+! Filter out operations that are not available, eg horizontal adds
+! on SSE2. Fallback code in math.vectors is used in that case.
+
+: supported-simd-ops ( assoc -- assoc' )
+ {
+ { v+ (simd-v+) }
+ { v- (simd-v-) }
+ { v* (simd-v*) }
+ { v/ (simd-v/) }
+ { vmin (simd-vmin) }
+ { vmax (simd-vmax) }
+ { sum (simd-sum) }
+ } [ nip "intrinsic" word-prop ] assoc-filter
+ '[ drop _ key? ] assoc-filter ;
+
+! Some SIMD operations are defined in terms of others.
+
+:: high-level-ops ( ctor -- assoc )
+ {
+ { vneg [ [ dup v- ] keep v- ] }
+ { v. [ v* sum ] }
+ { n+v [ [ ctor execute ] dip v+ ] }
+ { v+n [ ctor execute v+ ] }
+ { n-v [ [ ctor execute ] dip v- ] }
+ { v-n [ ctor execute v- ] }
+ { n*v [ [ ctor execute ] dip v* ] }
+ { v*n [ ctor execute v* ] }
+ { n/v [ [ ctor execute ] dip v/ ] }
+ { v/n [ ctor execute v/ ] }
+ { norm-sq [ dup v. assert-positive ] }
+ { norm [ norm-sq sqrt ] }
+ { normalize [ dup norm v/n ] }
+ { distance [ v- norm ] }
+ } ;
+
+:: simd-vector-words ( class ctor elt-type assoc -- )
+ class elt-type assoc supported-simd-ops ctor high-level-ops assoc-union
+ specialize-vector-words ;
+
+PRIVATE>
+
+\ float-4 \ float-4-with float H{
+ { v+ [ [ (simd-v+) ] float-4-vv->v-op ] }
+ { v- [ [ (simd-v-) ] float-4-vv->v-op ] }
+ { v* [ [ (simd-v*) ] float-4-vv->v-op ] }
+ { v/ [ [ (simd-v/) ] float-4-vv->v-op ] }
+ { vmin [ [ (simd-vmin) ] float-4-vv->v-op ] }
+ { vmax [ [ (simd-vmax) ] float-4-vv->v-op ] }
+ { sum [ [ (simd-sum) ] float-4-v->n-op ] }
+} simd-vector-words
+
+\ double-2 \ double-2-with float H{
+ { v+ [ [ (simd-v+) ] double-2-vv->v-op ] }
+ { v- [ [ (simd-v-) ] double-2-vv->v-op ] }
+ { v* [ [ (simd-v*) ] double-2-vv->v-op ] }
+ { v/ [ [ (simd-v/) ] double-2-vv->v-op ] }
+ { vmin [ [ (simd-vmin) ] double-2-vv->v-op ] }
+ { vmax [ [ (simd-vmax) ] double-2-vv->v-op ] }
+ { sum [ [ (simd-sum) ] double-2-v->n-op ] }
+} simd-vector-words
+
+\ float-8 \ float-8-with float H{
+ { v+ [ [ (simd-v+) ] float-8-vv->v-op ] }
+ { v- [ [ (simd-v-) ] float-8-vv->v-op ] }
+ { v* [ [ (simd-v*) ] float-8-vv->v-op ] }
+ { v/ [ [ (simd-v/) ] float-8-vv->v-op ] }
+ { vmin [ [ (simd-vmin) ] float-8-vv->v-op ] }
+ { vmax [ [ (simd-vmax) ] float-8-vv->v-op ] }
+ { sum [ [ (simd-sum) ] [ + ] float-8-v->n-op ] }
+} simd-vector-words
+
+\ double-4 \ double-4-with float H{
+ { v+ [ [ (simd-v+) ] double-4-vv->v-op ] }
+ { v- [ [ (simd-v-) ] double-4-vv->v-op ] }
+ { v* [ [ (simd-v*) ] double-4-vv->v-op ] }
+ { v/ [ [ (simd-v/) ] double-4-vv->v-op ] }
+ { vmin [ [ (simd-vmin) ] double-4-vv->v-op ] }
+ { vmax [ [ (simd-vmax) ] double-4-vv->v-op ] }
+ { sum [ [ (simd-v+) ] [ (simd-sum) ] double-4-v->n-op ] }
+} simd-vector-words
+
+>>
+
+USE: vocabs.loader
+
+"math.vectors.simd.alien" require
IN: math.vectors.specialization.tests
USING: compiler.tree.debugger math.vectors tools.test kernel
-kernel.private math specialized-arrays.double
-specialized-arrays.complex-float
-specialized-arrays.float ;
+kernel.private math specialized-arrays ;
+SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: complex-float
+SPECIALIZED-ARRAY: float
[ V{ t } ] [
[ { double-array double-array } declare distance 0.0 < not ] final-literals
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: words kernel make sequences effects kernel.private accessors
-combinators math math.intervals math.vectors namespaces assocs fry
-splitting classes.algebra generalizations
-compiler.tree.propagation.info ;
+USING: alien.c-types words kernel make sequences effects
+kernel.private accessors combinators math math.intervals
+math.vectors namespaces assocs fry splitting classes.algebra
+generalizations locals compiler.tree.propagation.info ;
IN: math.vectors.specialization
SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ;
{ vmin { +vector+ +vector+ -> +vector+ } }
{ vneg { +vector+ -> +vector+ } }
{ vtruncate { +vector+ -> +vector+ } }
+ { sum { +vector+ -> +scalar+ } }
}
-SYMBOL: specializations
+PREDICATE: vector-word < word vector-words key? ;
-specializations [ vector-words keys [ V{ } clone ] H{ } map>assoc ] initialize
+: specializations ( word -- assoc )
+ dup "specializations" word-prop
+ [ ] [ V{ } clone [ "specializations" set-word-prop ] keep ] ?if ;
+
+M: vector-word subwords specializations values [ word? ] filter ;
: add-specialization ( new-word signature word -- )
- specializations get at set-at ;
+ specializations set-at ;
: word-schema ( word -- schema ) vector-words at ;
: outputs ( schema -- seq ) { -> } split second ;
-: specialize-vector-word ( word array-type elt-type -- word' )
+: loop-vector-op ( word array-type elt-type -- word' )
pick word-schema
[ inputs (specialize-vector-word) ]
[ outputs record-output-signature ] 3bi ;
-: input-signature ( word -- signature ) def>> first ;
+:: specialize-vector-word ( word array-type elt-type simd -- word/quot' )
+ word simd key? [ word simd at ] [ word array-type elt-type loop-vector-op ] if ;
+
+:: input-signature ( word array-type elt-type -- signature )
+ array-type elt-type word word-schema inputs signature-for-schema ;
-: specialize-vector-words ( array-type elt-type -- )
- [ vector-words keys ] 2dip
- '[
- [ _ _ specialize-vector-word ] keep
- [ dup input-signature ] dip
- add-specialization
- ] each ;
+:: specialize-vector-words ( array-type elt-type simd -- )
+ elt-type number class<= [
+ vector-words keys [
+ [ array-type elt-type simd specialize-vector-word ]
+ [ array-type elt-type input-signature ]
+ [ ]
+ tri add-specialization
+ ] each
+ ] when ;
: find-specialization ( classes word -- word/f )
- specializations get at
+ specializations
[ first [ class<= ] 2all? ] with find
swap [ second ] when ;
IN: math.vectors
ARTICLE: "math-vectors" "Vector arithmetic"
-"Any Factor sequence can be used to represent a mathematical vector."
+"Any Factor sequence can be used to represent a mathematical vector, however for best performance, the sequences defined by the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "math.vectors.simd" } " vocabularies should be used."
$nl
"Acting on vectors by a scalar:"
{ $subsection vneg }
{ $subsection n*v }
{ $subsection v/n }
{ $subsection n/v }
+{ $subsection v+n }
+{ $subsection n+v }
+{ $subsection v-n }
+{ $subsection n-v }
"Combining two vectors to form another vector with " { $link 2map } ":"
{ $subsection v+ }
{ $subsection v- }
HELP: HEREDOC:
{ $syntax "HEREDOC: marker\n...text...\nmarker" }
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
-{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: HEREDOC: } " until the end of the line containing the " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." }
+{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after " { $link POSTPONE: HEREDOC: } " until the end of the line containing " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." }
{ $warning "Whitespace is significant." }
{ $examples
{ $example "USING: multiline prettyprint ;"
HELP: DELIMITED:
{ $syntax "DELIMITED: marker\n...text...\nmarker" }
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
-{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: DELIMITED: } " until the end of the line containing the " { $link POSTPONE: DELIMITED: } ". Text is captured until the exact delimiter string is found, regardless of where." }
+{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after " { $link POSTPONE: DELIMITED: } " until the end of the line containing " { $link POSTPONE: DELIMITED: } ". Text is captured until the exact delimiter string is found, regardless of where." }
+{ $warning "Whitespace is significant on the " { $link POSTPONE: DELIMITED: } " line." }
{ $examples
{ $example "USING: multiline prettyprint ;"
"DELIMITED: factor blows my mind"
math.parser opengl.gl combinators combinators.smart arrays
sequences splitting words byte-arrays assocs vocabs
colors colors.constants accessors generalizations locals fry
-specialized-arrays.float specialized-arrays.uint ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: uint
IN: opengl
: gl-color ( color -- ) >rgba-components glColor4d ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien alien.strings libc opengl math sequences combinators
-macros arrays io.encodings.ascii fry specialized-arrays.uint
+macros arrays io.encodings.ascii fry specialized-arrays
destructors accessors ;
+SPECIALIZED-ARRAY: uint
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs cache colors.constants destructors kernel
-opengl opengl.gl opengl.capabilities combinators images
-images.tesselation grouping specialized-arrays.float sequences math
-math.vectors math.matrices generalizations fry arrays namespaces
-system locals literals ;
+USING: accessors assocs cache colors.constants destructors
+kernel opengl opengl.gl opengl.capabilities combinators images
+images.tesselation grouping sequences math math.vectors
+math.matrices generalizations fry arrays namespaces system
+locals literals specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: opengl.textures
SYMBOL: non-power-of-2-textures?
alien.syntax math math.functions math.vectors destructors combinators
colors fonts accessors assocs namespaces kernel pango pango.fonts
pango.cairo cairo cairo.ffi glib unicode.data images cache init
-math.rectangles fry memoize io.encodings.utf8 ;
+math.rectangles fry memoize io.encodings.utf8 classes.struct ;
IN: pango.layouts
LIBRARY: pango
[ set-layout-text ] keep ;
: layout-extents ( layout -- ink-rect logical-rect )
- "PangoRectangle" <c-object>
- "PangoRectangle" <c-object>
+ PangoRectangle <struct>
+ PangoRectangle <struct>
[ pango_layout_get_extents ] 2keep
[ PangoRectangle>rect ] bi@ ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license
USING: arrays system alien.destructors alien.c-types alien.syntax alien
-combinators math.rectangles kernel math alien.libraries ;
+combinators math.rectangles kernel math alien.libraries classes.struct
+accessors ;
IN: pango
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION: PangoContext*
pango_context_new ( ) ;
-C-STRUCT: PangoRectangle
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" } ;
+STRUCT: PangoRectangle
+ { x int }
+ { y int }
+ { width int }
+ { height int } ;
: PangoRectangle>rect ( PangoRectangle -- rect )
- [ [ PangoRectangle-x pango>float ] [ PangoRectangle-y pango>float ] bi 2array ]
- [ [ PangoRectangle-width pango>float ] [ PangoRectangle-height pango>float ] bi 2array ] bi
+ [ [ x>> pango>float ] [ y>> pango>float ] bi 2array ]
+ [ [ width>> pango>float ] [ height>> pango>float ] bi 2array ] bi
<rect> ;
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays byte-vectors generic hashtables
-assocs kernel math namespaces make sequences strings sbufs vectors
-words prettyprint.config prettyprint.custom prettyprint.sections
-quotations io io.pathnames io.styles math.parser effects classes.tuple
-math.order classes.tuple.private classes combinators colors ;
+USING: accessors arrays assocs byte-arrays byte-vectors classes
+classes.tuple classes.tuple.private colors colors.constants
+combinators continuations effects generic hashtables io
+io.pathnames io.styles kernel make math math.order math.parser
+namespaces prettyprint.config prettyprint.custom
+prettyprint.sections prettyprint.stylesheet quotations sbufs
+sequences strings vectors words words.symbol ;
IN: prettyprint.backend
M: effect pprint* effect>string "(" ")" surround text ;
?effect-height 0 < [ end-group ] when ;
! Atoms
-: word-style ( word -- style )
- dup "word-style" word-prop >hashtable [
- [
- [ presented set ]
- [
- [ parsing-word? ] [ delimiter? ] [ t eq? ] tri or or
- [ bold font-style set ] when
- ] bi
- ] bind
- ] keep ;
-
: word-name* ( word -- str )
name>> "( no name )" or ;
] "" make
] [ word-style ] bi styled-text ;
-M: real pprint* number>string text ;
+M: real pprint*
+ number-base get {
+ { 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] }
+ { 8 [ \ OCT: [ 8 >base text ] pprint-prefix ] }
+ { 2 [ \ BIN: [ 2 >base text ] pprint-prefix ] }
+ [ drop number>string text ]
+ } case ;
+
+M: float pprint*
+ dup fp-nan? [
+ \ NAN: [ fp-nan-payload >hex text ] pprint-prefix
+ ] [
+ number-base get {
+ { 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] }
+ [ drop number>string text ]
+ } case
+ ] if ;
M: f pprint* drop \ f pprint-word ;
+: pprint-effect ( effect -- )
+ [ effect>string ] [ effect-style ] bi styled-text ;
+
! Strings
: ch>ascii-escape ( ch -- str )
H{
] when
] when ;
-: string-style ( obj -- hash )
- [
- presented set
- T{ rgba f 0.3 0.3 0.3 1.0 } foreground set
- ] H{ } make-assoc ;
-
: unparse-string ( str prefix suffix -- str )
[ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
M: tuple pprint*
pprint-tuple ;
+: recover-pprint ( try recovery -- )
+ pprinter-stack get clone
+ [ pprinter-stack set ] curry prepose recover ; inline
+
+: pprint-c-object ( object content-quot pointer-quot -- )
+ [ c-object-pointers? get ] 2dip
+ [ nip ]
+ [ [ drop ] prepose [ recover-pprint ] 2curry ] 2bi if ; inline
+
: do-length-limit ( seq -- trimmed n/f )
length-limit get dup [
over length over [-]
{ $var-description "Toggles whether printed strings are truncated to the margin." } ;
HELP: boa-tuples?
-{ $var-description "Toggles whether tuples print in BOA-form or assoc-form." }
+{ $var-description "Toggles whether tuples and structs print in BOA-form or assoc-form." }
{ $notes "See " { $link POSTPONE: T{ } " for a description of both literal tuple forms." } ;
+
+HELP: c-object-pointers?
+{ $var-description "Toggles whether C objects such as structs and direct arrays only print their underlying address. If this flag isn't set, C objects will attempt to print their contents. If a C object points to invalid memory, it will display only its address regardless." } ;
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs io kernel math
-namespaces sequences strings io.styles vectors words
+namespaces sequences strings vectors words
continuations ;
IN: prettyprint.config
SYMBOL: nesting-limit
SYMBOL: length-limit
SYMBOL: line-limit
+SYMBOL: number-base
SYMBOL: string-limit?
SYMBOL: boa-tuples?
+SYMBOL: c-object-pointers?
4 tab-size set-global
64 margin set-global
+10 number-base set-global
{ $subsection line-limit }
{ $subsection string-limit? }
{ $subsection boa-tuples? }
+{ $subsection c-object-pointers? }
"Note that the " { $link short. } " and " { $link pprint-short } " variables override some of these variables."
{
$warning "Treat the global variables as essentially being constants. Only ever rebind them in a nested scope."
IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test
+[ "4096" ] [ 4096 unparse ] unit-test
+[ "BIN: 1000000000000" ] [ 2 number-base [ 4096 unparse ] with-variable ] unit-test
+[ "OCT: 10000" ] [ 8 number-base [ 4096 unparse ] with-variable ] unit-test
+[ "HEX: 1000" ] [ 16 number-base [ 4096 unparse ] with-variable ] unit-test
[ "1.0" ] [ 1.0 unparse ] unit-test
+[ "8.0" ] [ 8.0 unparse ] unit-test
+[ "8.0" ] [ 2 number-base [ 8.0 unparse ] with-variable ] unit-test
+[ "8.0" ] [ 8 number-base [ 8.0 unparse ] with-variable ] unit-test
+[ "HEX: 1.0p3" ] [ 16 number-base [ 8.0 unparse ] with-variable ] unit-test
[ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test
[ "+" ] [ \ + unparse ] unit-test
--- /dev/null
+! Copyright (C) 2009 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel words ;
+IN: prettyprint.stylesheet
+
+HELP: effect-style
+{ $values
+ { "effect" "an effect" }
+ { "style" "a style assoc" }
+}
+{ $description "The styling hook for stack effects" } ;
+
+HELP: string-style
+{ $values
+ { "str" "a string" }
+ { "style" "a style assoc" }
+}
+{ $description "The styling hook for string literals" } ;
+
+HELP: vocab-style
+{ $values
+ { "vocab" "a vocabulary specifier" }
+ { "style" "a style assoc" }
+}
+{ $description "The styling hook for vocab names" } ;
+
+HELP: word-style
+{ $values
+ { "word" "a word" }
+ { "style" "a style assoc" }
+}
+{ $description "The styling hook for word names" } ;
+
+ARTICLE: "prettyprint.stylesheet" "Prettyprinter Formatted Output"
+{ $vocab-link "prettyprint.stylesheet" }
+$nl
+"Control the way that the prettyprinter formats output based on object type. These hooks form a basic \"syntax\" highlighting system."
+{ $subsection word-style }
+{ $subsection string-style }
+{ $subsection vocab-style }
+{ $subsection effect-style }
+;
+
+ABOUT: "prettyprint.stylesheet"
--- /dev/null
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs colors.constants combinators
+combinators.short-circuit hashtables io.styles kernel literals
+namespaces sequences words words.symbol ;
+IN: prettyprint.stylesheet
+
+<PRIVATE
+
+CONSTANT: dim-color COLOR: gray35
+
+{ POSTPONE: USING: POSTPONE: USE: POSTPONE: IN: }
+[
+ { { foreground $ dim-color } }
+ "word-style" set-word-prop
+] each
+
+PREDICATE: highlighted-word < word [ parsing-word? ] [ delimiter? ] bi or ;
+
+PRIVATE>
+
+GENERIC: word-style ( word -- style )
+
+M: word word-style
+ [ presented associate ]
+ [ "word-style" word-prop >hashtable ] bi assoc-union ;
+
+M: highlighted-word word-style
+ call-next-method COLOR: DarkSlateGray foreground associate
+ swap assoc-union ;
+
+<PRIVATE
+
+: colored-presentation-style ( obj color -- style )
+ [ presented associate ] [ foreground associate ] bi* assoc-union ;
+
+PRIVATE>
+
+: string-style ( str -- style )
+ COLOR: LightSalmon4 colored-presentation-style ;
+
+: vocab-style ( vocab -- style )
+ dim-color colored-presentation-style ;
+
+: effect-style ( effect -- style )
+ COLOR: DarkGreen colored-presentation-style ;
--- /dev/null
+prettyprinter syntax highlighting and formatted output
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: kernel math namespaces sequences sequences.private system
init accessors math.ranges random math.bitwise combinators
-specialized-arrays.uint fry ;
+specialized-arrays fry ;
+SPECIALIZED-ARRAY: uint
IN: random.mersenne-twister
<PRIVATE
io.streams.string io.styles kernel make namespaces prettyprint
prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections sequences sets sorting strings summary words
-words.symbol words.constant words.alias vocabs ;
+words.symbol words.constant words.alias vocabs slots ;
IN: see
GENERIC: synopsis* ( defspec -- )
: stack-effect. ( word -- )
[ print-stack-effect? ] [ stack-effect ] bi and
- [ effect>string comment. ] when* ;
+ [ pprint-effect ] when* ;
<PRIVATE
] tri ;
: seeing-implementors ( class -- seq )
- dup implementors [ method ] with map natural-sort ;
+ dup implementors
+ [ [ reader? ] [ writer? ] bi or not ] filter
+ [ method ] with map
+ natural-sort ;
: seeing-methods ( generic -- seq )
"methods" word-prop values natural-sort ;
HELP: complex-sequence
{ $class-description "Sequence wrapper class that transforms a sequence of " { $link real } " number values into a sequence of " { $link complex } " values, treating the underlying sequence as pairs of alternating real and imaginary values." }
{ $examples { $example <"
-USING: prettyprint
-specialized-arrays.double sequences.complex
-sequences arrays ;
+USING: prettyprint specialized-arrays
+sequences.complex sequences arrays ;
+SPECIALIZED-ARRAY: double
double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array .
"> "{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ;
{ $values { "sequence" sequence } { "complex-sequence" complex-sequence } }
{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-sequence } "." }
{ $examples { $example <"
-USING: prettyprint
-specialized-arrays.double sequences.complex
-sequences arrays ;
+USING: prettyprint specialized-arrays
+sequences.complex sequences arrays ;
+SPECIALIZED-ARRAY: double
double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second .
"> "C{ -2.0 2.0 }" } } ;
-USING: specialized-arrays.float sequences.complex
+USING: specialized-arrays sequences.complex
kernel sequences tools.test arrays accessors ;
+SPECIALIZED-ARRAY: float
IN: sequences.complex.tests
: test-array ( -- x )
! See http://factorcode.org/license.txt for BSD license.
!
USING: tools.test kernel serialize io io.streams.byte-array
-alien arrays byte-arrays bit-arrays specialized-arrays.double
+alien arrays byte-arrays bit-arrays specialized-arrays
sequences math prettyprint parser classes math.constants
io.encodings.binary random assocs serialize.private ;
+SPECIALIZED-ARRAY: double
IN: serialize.tests
: test-serialize-cell ( a -- ? )
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.alien
-
-<< "void*" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.bool
-
-<< "bool" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.char
-
-<< "char" define-array >>
\ No newline at end of file
+++ /dev/null
-USING: kernel sequences specialized-arrays.complex-double tools.test ;
-IN: specialized-arrays.complex-double.tests
-
-[ C{ 3.0 2.0 } ]
-[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } second ] unit-test
-
-[ C{ 1.0 0.0 } ]
-[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } first ] unit-test
-
-[ complex-double-array{ 1.0 C{ 6.0 -7.0 } 5.0 } ] [
- complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 }
- dup [ C{ 6.0 -7.0 } 1 ] dip set-nth
-] unit-test
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.complex-double
-
-<< "complex-double" define-array >>
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.complex-float
-
-<< "complex-float" define-array >>
+++ /dev/null
-USING: specialized-arrays.alien specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.alien
-
-<< "void*" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.bool specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.bool
-
-<< "bool" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.char specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.char
-
-<< "char" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.complex-double specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.complex-double
-
-<< "complex-double" define-direct-array >>
+++ /dev/null
-USING: specialized-arrays.complex-float specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.complex-float
-
-<< "complex-float" define-direct-array >>
+++ /dev/null
-USING: help.markup help.syntax byte-arrays alien ;
-IN: specialized-arrays.direct
-
-ARTICLE: "specialized-arrays.direct" "Direct-mapped specialized arrays"
-"The " { $vocab-link "specialized-arrays.direct" } " vocabulary implements fixed-length sequence types for storing machine values in unmanaged C memory."
-$nl
-"For each primitive C type " { $snippet "T" } ", a set of words are defined:"
-{ $table
- { { $snippet "direct-T-array" } { "The class of direct arrays with elements of type " { $snippet "T" } } }
- { { $snippet "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( alien len -- array )" } } }
-}
-"Each direct array has a " { $slot "underlying" } " slot holding an " { $link simple-alien } " pointer to the raw data. This data can be passed to C functions."
-$nl
-"The primitive C types for which direct arrays exist:"
-{ $list
- { $snippet "char" }
- { $snippet "uchar" }
- { $snippet "short" }
- { $snippet "ushort" }
- { $snippet "int" }
- { $snippet "uint" }
- { $snippet "long" }
- { $snippet "ulong" }
- { $snippet "longlong" }
- { $snippet "ulonglong" }
- { $snippet "float" }
- { $snippet "double" }
- { $snippet "void*" }
- { $snippet "bool" }
-}
-"Direct arrays are generated with a functor in the " { $vocab-link "specialized-arrays.direct.functor" } " vocabulary." ;
-
-ABOUT: "specialized-arrays.direct"
+++ /dev/null
-IN: specialized-arrays.direct.tests
-USING: specialized-arrays.direct.ushort tools.test
-specialized-arrays.ushort alien.syntax sequences ;
-
-[ ushort-array{ 0 0 0 } ] [
- 3 ALIEN: 123 100 <direct-ushort-array> new-sequence
-] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: specialized-arrays.direct
+++ /dev/null
-USING: specialized-arrays.double specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.double
-
-<< "double" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.float specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.float
-
-<< "float" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: functors sequences sequences.private kernel words classes
-math alien alien.c-types byte-arrays accessors
-specialized-arrays prettyprint.custom ;
-IN: specialized-arrays.direct.functor
-
-FUNCTOR: define-direct-array ( T -- )
-
-A' IS ${T}-array
->A' IS >${T}-array
-<A'> IS <${A'}>
-A'{ IS ${A'}{
-
-A DEFINES-CLASS direct-${T}-array
-<A> DEFINES <${A}>
-
-NTH [ T dup c-type-getter-boxer array-accessor ]
-SET-NTH [ T dup c-setter array-accessor ]
-
-WHERE
-
-TUPLE: A
-{ underlying c-ptr read-only }
-{ length fixnum read-only } ;
-
-: <A> ( alien len -- direct-array ) A boa ; inline
-M: A length length>> ;
-M: A nth-unsafe underlying>> NTH call ;
-M: A set-nth-unsafe underlying>> SET-NTH call ;
-M: A like drop dup A instance? [ >A' ] unless ;
-M: A new-sequence drop <A'> ;
-
-M: A pprint-delims drop \ A'{ \ } ;
-
-M: A >pprint-sequence ;
-
-M: A pprint* pprint-object ;
-
-INSTANCE: A sequence
-
-;FUNCTOR
+++ /dev/null
-Code generation for direct specialized arrays
+++ /dev/null
-USING: specialized-arrays.int specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.int
-
-<< "int" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.long specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.long
-
-<< "long" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.longlong specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.longlong
-
-<< "longlong" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.short specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.short
-
-<< "short" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.uchar specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.uchar
-
-<< "uchar" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.uint specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.uint
-
-<< "uint" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.ulong specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.ulong
-
-<< "ulong" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.ulonglong specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.ulonglong
-
-<< "ulonglong" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.ushort specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.ushort
-
-<< "ushort" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.double
-
-<< "double" define-array >>
-
-! Specializer hints. These should really be generalized, and placed
-! somewhere else
-USING: hints math.vectors arrays kernel math accessors sequences ;
-
-HINTS: <double-array> { 2 } { 3 } ;
-
-HINTS: (double-array) { 2 } { 3 } ;
-
-! Type functions
-USING: words classes.algebra compiler.tree.propagation.info
-math.intervals ;
-
-\ norm-sq [
- class>> double-array class<= [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
-] "outputs" set-word-prop
-
-\ distance [
- [ class>> double-array class<= ] both?
- [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
-] "outputs" set-word-prop
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.float
-
-<< "float" define-array >>
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: functors sequences sequences.private prettyprint.custom
-kernel words classes math math.vectors.specialization parser
-alien.c-types byte-arrays accessors summary ;
-IN: specialized-arrays.functor
-
-ERROR: bad-byte-array-length byte-array type ;
-
-M: bad-byte-array-length summary
- drop "Byte array length doesn't divide type width" ;
-
-: (c-array) ( n c-type -- array )
- heap-size * (byte-array) ; inline
-
-FUNCTOR: define-array ( T -- )
-
-A DEFINES-CLASS ${T}-array
-<A> DEFINES <${A}>
-(A) DEFINES (${A})
->A DEFINES >${A}
-byte-array>A DEFINES byte-array>${A}
-A{ DEFINES ${A}{
-
-NTH [ T dup c-type-getter-boxer array-accessor ]
-SET-NTH [ T dup c-setter array-accessor ]
-
-WHERE
-
-TUPLE: A
-{ length array-capacity read-only }
-{ underlying byte-array read-only } ;
-
-: <A> ( n -- specialized-array ) dup T <c-array> A boa ; inline
-
-: (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline
-
-: byte-array>A ( byte-array -- specialized-array )
- dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
- swap A boa ; inline
-
-M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; inline
-
-M: A length length>> ; inline
-
-M: A nth-unsafe underlying>> NTH call ; inline
-
-M: A set-nth-unsafe underlying>> SET-NTH call ; inline
-
-: >A ( seq -- specialized-array ) A new clone-like ;
-
-M: A like drop dup A instance? [ >A ] unless ; inline
-
-M: A new-sequence drop (A) ; inline
-
-M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
-
-M: A resize
- [ drop ] [
- [ T heap-size * ] [ underlying>> ] bi*
- resize-byte-array
- ] 2bi
- A boa ; inline
-
-M: A byte-length underlying>> length ; inline
-
-M: A pprint-delims drop \ A{ \ } ;
-
-M: A >pprint-sequence ;
-
-M: A pprint* pprint-object ;
-
-SYNTAX: A{ \ } [ >A ] parse-literal ;
-
-INSTANCE: A sequence
-
-A T c-type-boxed-class specialize-vector-words
-
-;FUNCTOR
+++ /dev/null
-Code generation for specialized arrays
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.int
-
-<< "int" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.long
-
-<< "long" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.longlong
-
-<< "longlong" define-array >>
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel prettyprint.backend
+prettyprint.sections prettyprint.custom
+specialized-arrays ;
+IN: specialized-arrays.prettyprint
+
+: pprint-direct-array ( direct-array -- )
+ dup direct-array-syntax
+ [ [ underlying>> ] [ length>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
+
+M: specialized-array pprint*
+ [ pprint-object ] [ pprint-direct-array ] pprint-c-object ;
+
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.alien
-
-<< "ptrdiff_t" define-array >>
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.short
-
-<< "short" define-array >>
\ No newline at end of file
-USING: help.markup help.syntax byte-arrays ;
+USING: help.markup help.syntax byte-arrays alien ;
IN: specialized-arrays
-ARTICLE: "specialized-arrays" "Specialized arrays"
-"The " { $vocab-link "specialized-arrays" } " vocabulary implements fixed-length sequence types for storing machine values in a space-efficient manner without boxing."
-$nl
-"For each primitive C type " { $snippet "T" } ", a set of words are defined in the vocabulary named " { $snippet "specialized-arrays.T" } ":"
+HELP: SPECIALIZED-ARRAY:
+{ $syntax "SPECIALIZED-ARRAY: type" }
+{ $values { "type" "a C type" } }
+{ $description "Brings a specialized array for holding values of " { $snippet "type" } " into the vocabulary search path. The generated words are documented in " { $link "specialized-array-words" } "." } ;
+
+ARTICLE: "specialized-array-words" "Specialized array words"
+"The " { $link POSTPONE: SPECIALIZED-ARRAY: } " parsing word generates the specialized array type if it hasn't been generated already, and adds the following words to the vocabulary search path, where " { $snippet "T" } " is the C type in question:"
{ $table
{ { $snippet "T-array" } { "The class of arrays with elements of type " { $snippet "T" } } }
{ { $snippet "<T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( len -- array )" } } }
- { { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } }
+ { { $snippet "(T-array)" } { "Constructor for arrays with elements of type " { $snippet "T" } ", where the initial contents are uninitialized; stack effect " { $snippet "( len -- array )" } } }
+ { { $snippet "malloc-T-array" } { "Constructor for arrays with elements of type " { $snippet "T" } " backed by newly-allocated unmanaged memory; stack effect " { $snippet "( alien len -- array )" } } }
+ { { $snippet "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } " backed by raw memory; stack effect " { $snippet "( alien len -- array )" } } }
{ { $snippet "byte-array>T-array" } { "Converts a byte array into a specialized array by interpreting the bytes in as machine-specific values. Code which uses this word is unportable" } }
+ { { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } }
{ { $snippet "T-array{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } }
}
-"Each specialized array has a " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. This data can be passed to C functions."
-$nl
-"The primitive C types for which specialized arrays exist:"
-{ $list
- { $snippet "char" }
- { $snippet "uchar" }
- { $snippet "short" }
- { $snippet "ushort" }
- { $snippet "int" }
- { $snippet "uint" }
- { $snippet "long" }
- { $snippet "ulong" }
- { $snippet "longlong" }
- { $snippet "ulonglong" }
- { $snippet "float" }
- { $snippet "double" }
- { $snippet "complex-float" }
- { $snippet "complex-double" }
- { $snippet "void*" }
- { $snippet "bool" }
-}
-"Note that " { $vocab-link "specialized-arrays.bool" } " behaves like a C " { $snippet "bool[]" } " array, and each element takes up 8 bits of space. For a more space-efficient boolean array, see " { $link "bit-arrays" } "."
-$nl
-"Specialized arrays are generated with a functor in the " { $vocab-link "specialized-arrays.functor" } " vocabulary."
+"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-arrays.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-ARRAY: } ". This ensures that the vocabulary can get generated the first time it is needed." ;
+
+ARTICLE: "specialized-array-c" "Passing specialized arrays to C functions"
+"Each specialized array has a " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized array as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized array." ;
+
+ARTICLE: "specialized-array-math" "Vector arithmetic with specialized arrays"
+"Each specialized array with a numeric type generates specialized versions of the " { $link "math-vectors" } " words. The compiler substitutes calls for these words if it can statically determine input types. The " { $snippet "optimized." } " word in the " { $vocab-link "compiler.tree.debugger" } " vocabulary can be used to determine if this optimization is being performed for a particular piece of code." ;
+
+ARTICLE: "specialized-array-examples" "Specialized array examples"
+"Let's import specialized float arrays:"
+{ $code "USING: specialized-arrays math.constants math.functions ;" "SPECIALIZED-ARRAY: float" }
+"Creating a float array with 3 elements:"
+{ $code "1.0 [ sin ] [ cos ] [ tan ] tri float-array{ } 3sequence ." }
+"Create a float array and sum the elements:"
+{ $code
+ "1000 iota [ 1000 /f pi * sin ] float-array{ } map-as"
+ "0.0 [ + ] reduce ."
+} ;
+
+ARTICLE: "specialized-arrays" "Specialized arrays"
+"The " { $vocab-link "specialized-arrays" } " vocabulary implements fixed-length sequence types for storing machine values in a space-efficient manner without boxing."
$nl
-"The " { $vocab-link "specialized-vectors" } " vocabulary provides resizable versions of the above." ;
+"A specialized array type needs to be generated for each element type. This is done with a parsing word:"
+{ $subsection POSTPONE: SPECIALIZED-ARRAY: }
+"This parsing word adds new words to the search path:"
+{ $subsection "specialized-array-words" }
+{ $subsection "specialized-array-c" }
+{ $subsection "specialized-array-math" }
+{ $subsection "specialized-array-examples" }
+"The " { $vocab-link "specialized-vectors" } " vocabulary provides a resizable version of this abstraction." ;
ABOUT: "specialized-arrays"
IN: specialized-arrays.tests
-USING: tools.test specialized-arrays sequences
-specialized-arrays.int specialized-arrays.bool
-specialized-arrays.ushort alien.c-types accessors kernel
-specialized-arrays.direct.int specialized-arrays.char
-specialized-arrays.uint arrays combinators ;
+USING: tools.test alien.syntax specialized-arrays
+specialized-arrays.private sequences alien.c-types accessors
+kernel arrays combinators compiler compiler.units classes.struct
+combinators.smart compiler.tree.debugger math libc destructors
+sequences.private multiline eval words vocabs namespaces
+assocs prettyprint ;
+
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: bool
+SPECIALIZED-ARRAY: ushort
+SPECIALIZED-ARRAY: char
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: float
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
[ { 3 1 3 3 7 } ] [
int-array{ 3 1 3 3 7 } malloc-byte-array 5 <direct-int-array> >array
-] unit-test
\ No newline at end of file
+] unit-test
+
+[ f ] [ float-array{ 4 3 2 1 } dup clone [ underlying>> ] bi@ eq? ] unit-test
+
+[ f ] [ [ float-array{ 4 3 2 1 } dup clone [ underlying>> ] bi@ eq? ] compile-call ] unit-test
+
+[ ushort-array{ 0 0 0 } ] [
+ 3 ALIEN: 123 100 <direct-ushort-array> new-sequence
+ dup [ drop 0 ] change-each
+] unit-test
+
+STRUCT: test-struct
+ { x int }
+ { y int } ;
+
+SPECIALIZED-ARRAY: test-struct
+
+[ 1 ] [
+ 1 test-struct-array{ } new-sequence length
+] unit-test
+
+[ V{ test-struct } ] [
+ [ [ test-struct-array <struct> ] test-struct-array{ } output>sequence first ] final-classes
+] unit-test
+
+: make-point ( x y -- struct )
+ test-struct <struct-boa> ;
+
+[ 5/4 ] [
+ 2 <test-struct-array>
+ 1 2 make-point over set-first
+ 3 4 make-point over set-second
+ 0 [ [ x>> ] [ y>> ] bi / + ] reduce
+] unit-test
+
+[ 5/4 ] [
+ [
+ 2 malloc-test-struct-array
+ dup &free drop
+ 1 2 make-point over set-first
+ 3 4 make-point over set-second
+ 0 [ [ x>> ] [ y>> ] bi / + ] reduce
+ ] with-destructors
+] unit-test
+
+[ ] [ ALIEN: 123 10 <direct-test-struct-array> drop ] unit-test
+
+[ ] [
+ [
+ 10 malloc-test-struct-array
+ &free drop
+ ] with-destructors
+] unit-test
+
+[ 15 ] [ 15 10 <test-struct-array> resize length ] unit-test
+
+[ S{ test-struct f 12 20 } ] [
+ test-struct-array{
+ S{ test-struct f 4 20 }
+ S{ test-struct f 12 20 }
+ S{ test-struct f 20 20 }
+ } second
+] unit-test
+
+! Regression
+STRUCT: fixed-string { text char[64] } ;
+
+SPECIALIZED-ARRAY: fixed-string
+
+[ { ALIEN: 100 ALIEN: 140 ALIEN: 180 ALIEN: 1c0 } ] [
+ ALIEN: 100 4 <direct-fixed-string-array> [ (underlying)>> ] { } map-as
+] unit-test
+
+! Ensure that byte-length works with direct arrays
+[ 400 ] [
+ ALIEN: 123 100 <direct-int-array> byte-length
+] unit-test
+
+! Test prettyprinting
+[ "int-array{ 1 2 3 }" ] [ int-array{ 1 2 3 } unparse ] unit-test
+[ "int-array@ f 100" ] [ f 100 <direct-int-array> unparse ] unit-test
+
+! If the C type doesn't exist, don't generate a vocab
+[ ] [
+ [ "__does_not_exist__" specialized-array-vocab forget-vocab ] with-compilation-unit
+ "__does_not_exist__" c-types get delete-at
+] unit-test
+
+[
+ <"
+IN: specialized-arrays.tests
+USING: specialized-arrays ;
+
+SPECIALIZED-ARRAY: __does_not_exist__ "> eval( -- )
+] must-fail
+
+[ ] [
+ <"
+IN: specialized-arrays.tests
+USING: classes.struct specialized-arrays ;
+
+STRUCT: __does_not_exist__ { x int } ;
+
+SPECIALIZED-ARRAY: __does_not_exist__
+"> eval( -- )
+] unit-test
+
+[ f ] [
+ "__does_not_exist__-array{"
+ "__does_not_exist__" specialized-array-vocab lookup
+ deferred?
+] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types assocs byte-arrays classes
+compiler.units functors kernel lexer libc math
+math.vectors.specialization namespaces parser prettyprint.custom
+sequences sequences.private strings summary vocabs vocabs.loader
+vocabs.parser words fry combinators ;
IN: specialized-arrays
+
+MIXIN: specialized-array
+
+INSTANCE: specialized-array sequence
+
+GENERIC: direct-array-syntax ( obj -- word )
+
+ERROR: bad-byte-array-length byte-array type ;
+
+M: bad-byte-array-length summary
+ drop "Byte array length doesn't divide type width" ;
+
+: (underlying) ( n c-type -- array )
+ heap-size * (byte-array) ; inline
+
+: <underlying> ( n type -- array )
+ heap-size * <byte-array> ; inline
+
+<PRIVATE
+
+FUNCTOR: define-array ( T -- )
+
+A DEFINES-CLASS ${T}-array
+S DEFINES-CLASS ${T}-sequence
+<A> DEFINES <${A}>
+(A) DEFINES (${A})
+<direct-A> DEFINES <direct-${A}>
+malloc-A DEFINES malloc-${A}
+>A DEFINES >${A}
+byte-array>A DEFINES byte-array>${A}
+
+A{ DEFINES ${A}{
+A@ DEFINES ${A}@
+
+NTH [ T dup c-type-getter-boxer array-accessor ]
+SET-NTH [ T dup c-setter array-accessor ]
+
+WHERE
+
+MIXIN: S
+
+TUPLE: A
+{ underlying c-ptr read-only }
+{ length array-capacity read-only } ;
+
+: <direct-A> ( alien len -- specialized-array ) A boa ; inline
+
+: <A> ( n -- specialized-array ) [ T <underlying> ] keep <direct-A> ; inline
+
+: (A) ( n -- specialized-array ) [ T (underlying) ] keep <direct-A> ; inline
+
+: malloc-A ( len -- specialized-array ) [ T heap-size calloc ] keep <direct-A> ; inline
+
+: byte-array>A ( byte-array -- specialized-array )
+ dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
+ <direct-A> ; inline
+
+M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
+
+M: A length length>> ; inline
+
+M: A nth-unsafe underlying>> NTH call ; inline
+
+M: A set-nth-unsafe underlying>> SET-NTH call ; inline
+
+: >A ( seq -- specialized-array ) A new clone-like ;
+
+M: A like drop dup A instance? [ >A ] unless ; inline
+
+M: A new-sequence drop (A) ; inline
+
+M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
+
+M: A resize
+ [
+ [ T heap-size * ] [ underlying>> ] bi*
+ resize-byte-array
+ ] [ drop ] 2bi
+ <direct-A> ; inline
+
+M: A byte-length length T heap-size * ; inline
+
+M: A direct-array-syntax drop \ A@ ;
+
+M: A pprint-delims drop \ A{ \ } ;
+
+M: A >pprint-sequence ;
+
+SYNTAX: A{ \ } [ >A ] parse-literal ;
+SYNTAX: A@ scan-object scan-object <direct-A> parsed ;
+
+INSTANCE: A specialized-array
+
+A T c-type-boxed-class f specialize-vector-words
+
+;FUNCTOR
+
+: underlying-type ( c-type -- c-type' )
+ dup c-types get at {
+ { [ dup not ] [ drop no-c-type ] }
+ { [ dup string? ] [ nip underlying-type ] }
+ [ drop ]
+ } cond ;
+
+: specialized-array-vocab ( c-type -- vocab )
+ "specialized-arrays.instances." prepend ;
+
+PRIVATE>
+
+: generate-vocab ( vocab-name quot -- vocab )
+ [ dup vocab [ ] ] dip '[
+ [
+ [
+ _ with-current-vocab
+ ] with-compilation-unit
+ ] keep
+ ] ?if ; inline
+
+: define-array-vocab ( type -- vocab )
+ underlying-type
+ [ specialized-array-vocab ] [ '[ _ define-array ] ] bi
+ generate-vocab ;
+
+M: string require-c-array define-array-vocab drop ;
+
+ERROR: specialized-array-vocab-not-loaded c-type ;
+
+M: string c-array-constructor
+ underlying-type
+ dup [ "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup
+ [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+
+M: string c-(array)-constructor
+ underlying-type
+ dup [ "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup
+ [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+
+M: string c-direct-array-constructor
+ underlying-type
+ dup [ "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup
+ [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+
+SYNTAX: SPECIALIZED-ARRAY:
+ scan define-array-vocab use-vocab ;
+
+"prettyprint" vocab [
+ "specialized-arrays.prettyprint" require
+] when
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.uchar
-
-<< "uchar" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.uint
-
-<< "uint" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.ulong
-
-<< "ulong" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.ulonglong
-
-<< "ulonglong" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.ushort
-
-<< "ushort" define-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.alien ;
-IN: specialized-vectors.alien
-
-<< "void*" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.bool ;
-IN: specialized-vectors.bool
-
-<< "bool" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.char ;
-IN: specialized-vectors.char
-
-<< "char" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.double ;
-IN: specialized-vectors.double
-
-<< "double" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.float ;
-IN: specialized-vectors.float
-
-<< "float" define-vector >>
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types functors sequences sequences.private growable
-prettyprint.custom kernel words classes math parser ;
-QUALIFIED: vectors.functor
-IN: specialized-vectors.functor
-
-FUNCTOR: define-vector ( T -- )
-
-V DEFINES-CLASS ${T}-vector
-
-A IS ${T}-array
-<A> IS <${A}>
-
->V DEFERS >${V}
-V{ DEFINES ${V}{
-
-WHERE
-
-V A <A> vectors.functor:define-vector
-
-M: V contract 2drop ;
-
-M: V byte-length underlying>> byte-length ;
-
-M: V pprint-delims drop \ V{ \ } ;
-
-M: V >pprint-sequence ;
-
-M: V pprint* pprint-object ;
-
-SYNTAX: V{ \ } [ >V ] parse-literal ;
-
-INSTANCE: V growable
-
-;FUNCTOR
+++ /dev/null
-Code generation for specialized vectors
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.int ;
-IN: specialized-vectors.int
-
-<< "int" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.long ;
-IN: specialized-vectors.long
-
-<< "long" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.longlong ;
-IN: specialized-vectors.longlong
-
-<< "longlong" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.short ;
-IN: specialized-vectors.short
-
-<< "short" define-vector >>
\ No newline at end of file
-USING: help.markup help.syntax byte-vectors ;
+USING: help.markup help.syntax byte-vectors alien byte-arrays ;
IN: specialized-vectors
-ARTICLE: "specialized-vectors" "Specialized vectors"
-"The " { $vocab-link "specialized-vectors" } " vocabulary implements resizable sequence types for storing machine values in a space-efficient manner without boxing."
-$nl
-"For each primitive C type " { $snippet "T" } ", a set of words are defined:"
+HELP: SPECIALIZED-VECTOR:
+{ $syntax "SPECIALIZED-VECTOR: type" }
+{ $values { "type" "a C type" } }
+{ $description "Brings a specialized vector for holding values of " { $snippet "type" } " into the vocabulary search path. The generated words are documented in " { $link "specialized-vector-words" } "." } ;
+
+ARTICLE: "specialized-vector-words" "Specialized vector words"
+"The " { $link POSTPONE: SPECIALIZED-VECTOR: } " parsing word generates the specialized vector type if it hasn't been generated already, and adds the following words to the vocabulary search path, where " { $snippet "T" } " is the C type in question:"
{ $table
{ { $snippet "T-vector" } { "The class of vectors with elements of type " { $snippet "T" } } }
{ { $snippet "<T-vector>" } { "Constructor for vectors with elements of type " { $snippet "T" } "; stack effect " { $snippet "( len -- vector )" } } }
{ { $snippet ">T-vector" } { "Converts a sequence into a specialized vector of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- vector )" } } }
{ { $snippet "T-vector{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } }
}
-"The primitive C types for which specialized vectors exist:"
-{ $list
- { $snippet "char" }
- { $snippet "uchar" }
- { $snippet "short" }
- { $snippet "ushort" }
- { $snippet "int" }
- { $snippet "uint" }
- { $snippet "long" }
- { $snippet "ulong" }
- { $snippet "longlong" }
- { $snippet "ulonglong" }
- { $snippet "float" }
- { $snippet "double" }
- { $snippet "void*" }
- { $snippet "bool" }
-}
-"Specialized vectors are generated with a functor in the " { $vocab-link "specialized-vectors.functor" } " vocabulary."
-$nl
-"The " { $vocab-link "specialized-arrays" } " vocabulary provides fixed-length versions of the above." ;
+"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-vectors.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-VECTOR: } ". This ensures that the vocabulary can get generated the first time it is needed." ;
+
+ARTICLE: "specialized-vector-c" "Passing specialized arrays to C functions"
+"Each specialized array has a " { $slot "underlying" } " slot holding a specialized array, which in turn has an " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized vector as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized vector." ;
+
+ARTICLE: "specialized-vectors" "Specialized vectors"
+"The " { $vocab-link "specialized-vectors" } " vocabulary implements resizable sequence types for storing machine values in a space-efficient manner without boxing."
+{ $subsection "specialized-vector-words" }
+{ $subsection "specialized-vector-c" }
+"The " { $vocab-link "specialized-arrays" } " vocabulary provides a fixed-length version of this abstraction." ;
ABOUT: "specialized-vectors"
IN: specialized-vectors.tests
-USING: specialized-arrays.float
-specialized-vectors.float
-specialized-vectors.double
+USING: specialized-arrays specialized-vectors
tools.test kernel sequences ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-VECTOR: float
+SPECIALIZED-VECTOR: double
[ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs compiler.units functors
+growable kernel lexer namespaces parser prettyprint.custom
+sequences specialized-arrays specialized-arrays.private strings
+vocabs vocabs.parser fry ;
+QUALIFIED: vectors.functor
IN: specialized-vectors
+
+<PRIVATE
+
+FUNCTOR: define-vector ( T -- )
+
+V DEFINES-CLASS ${T}-vector
+
+A IS ${T}-array
+S IS ${T}-sequence
+<A> IS <${A}>
+
+>V DEFERS >${V}
+V{ DEFINES ${V}{
+
+WHERE
+
+V A <A> vectors.functor:define-vector
+
+M: V contract 2drop ;
+
+M: V byte-length underlying>> byte-length ;
+
+M: V pprint-delims drop \ V{ \ } ;
+
+M: V >pprint-sequence ;
+
+M: V pprint* pprint-object ;
+
+SYNTAX: V{ \ } [ >V ] parse-literal ;
+
+INSTANCE: V growable
+INSTANCE: V S
+
+;FUNCTOR
+
+: specialized-vector-vocab ( type -- vocab )
+ "specialized-vectors.instances." prepend ;
+
+PRIVATE>
+
+: define-vector-vocab ( type -- vocab )
+ underlying-type
+ [ specialized-vector-vocab ] [ '[ _ define-vector ] ] bi
+ generate-vocab ;
+
+SYNTAX: SPECIALIZED-VECTOR:
+ scan
+ [ define-array-vocab use-vocab ]
+ [ define-vector-vocab use-vocab ] bi ;
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.uchar ;
-IN: specialized-vectors.uchar
-
-<< "uchar" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.uint ;
-IN: specialized-vectors.uint
-
-<< "uint" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.ulong ;
-IN: specialized-vectors.ulong
-
-<< "ulong" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.ulonglong ;
-IN: specialized-vectors.ulonglong
-
-<< "ulonglong" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.ushort ;
-IN: specialized-vectors.ushort
-
-<< "ushort" define-vector >>
\ No newline at end of file
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 ;
: 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
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
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
\ float/f { float float } { float } define-primitive
\ float/f make-foldable
-\ float< { float float } { object } define-primitive
-\ float< make-foldable
-
\ float-mod { float float } { float } define-primitive
\ float-mod make-foldable
+\ float< { float float } { object } define-primitive
+\ float< make-foldable
+
\ float<= { float float } { object } define-primitive
\ float<= make-foldable
\ float>= { float float } { object } define-primitive
\ float>= make-foldable
+\ float-u< { float float } { object } define-primitive
+\ float-u< make-foldable
+
+\ float-u<= { float float } { object } define-primitive
+\ float-u<= make-foldable
+
+\ float-u> { float float } { object } define-primitive
+\ float-u> make-foldable
+
+\ float-u>= { float float } { object } define-primitive
+\ float-u>= make-foldable
+
\ <word> { object object } { word } define-primitive
\ <word> make-flushable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-IN: struct-arrays
-USING: help.markup help.syntax alien strings math ;
-
-HELP: struct-array
-{ $class-description "The class of C struct and union arrays."
-$nl
-"The " { $slot "underlying" } " slot holds a " { $link c-ptr } " with the raw data. This pointer can be passed to C functions." } ;
-
-HELP: <struct-array>
-{ $values { "length" integer } { "c-type" string } { "struct-array" struct-array } }
-{ $description "Creates a new array for holding values of the specified C type." } ;
-
-HELP: <direct-struct-array>
-{ $values { "alien" c-ptr } { "length" integer } { "c-type" string } { "struct-array" struct-array } }
-{ $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ;
-
-ARTICLE: "struct-arrays" "C struct and union arrays"
-"The " { $vocab-link "struct-arrays" } " vocabulary implements arrays specialized for holding C struct and union values."
-{ $subsection struct-array }
-{ $subsection <struct-array> }
-{ $subsection <direct-struct-array> } ;
-
-ABOUT: "struct-arrays"
+++ /dev/null
-IN: struct-arrays.tests
-USING: struct-arrays tools.test kernel math sequences
-alien.syntax alien.c-types destructors libc accessors sequences.private ;
-
-C-STRUCT: test-struct
-{ "int" "x" }
-{ "int" "y" } ;
-
-: make-point ( x y -- struct )
- "test-struct" <c-object>
- [ set-test-struct-y ] keep
- [ set-test-struct-x ] keep ;
-
-[ 5/4 ] [
- 2 "test-struct" <struct-array>
- 1 2 make-point over set-first
- 3 4 make-point over set-second
- 0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
-] unit-test
-
-[ 5/4 ] [
- [
- 2 "test-struct" malloc-struct-array
- dup &free drop
- 1 2 make-point over set-first
- 3 4 make-point over set-second
- 0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
- ] with-destructors
-] unit-test
-
-[ ] [ ALIEN: 123 10 "test-struct" <direct-struct-array> drop ] unit-test
-
-[ ] [
- [
- 10 "test-struct" malloc-struct-array
- &free drop
- ] with-destructors
-] unit-test
-
-[ 15 ] [ 15 10 "test-struct" <struct-array> resize length ] unit-test
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types byte-arrays kernel libc
-math sequences sequences.private ;
-IN: struct-arrays
-
-TUPLE: struct-array
-{ underlying c-ptr read-only }
-{ length array-capacity read-only }
-{ element-size array-capacity read-only } ;
-
-M: struct-array length length>> ;
-M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ;
-
-M: struct-array nth-unsafe
- [ element-size>> * ] [ underlying>> ] bi <displaced-alien> ;
-
-M: struct-array set-nth-unsafe
- [ nth-unsafe swap ] [ element-size>> ] bi memcpy ;
-
-M: struct-array new-sequence
- element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline
-
-M: struct-array resize ( n seq -- newseq )
- [ [ element-size>> * ] [ underlying>> ] bi resize ] [ element-size>> ] 2bi
- struct-array boa ;
-
-: <struct-array> ( length c-type -- struct-array )
- heap-size [ * <byte-array> ] 2keep struct-array boa ; inline
-
-ERROR: bad-byte-array-length byte-array ;
-
-: byte-array>struct-array ( byte-array c-type -- struct-array )
- heap-size [
- [ dup length ] dip /mod 0 =
- [ drop bad-byte-array-length ] unless
- ] keep struct-array boa ; inline
-
-: <direct-struct-array> ( alien length c-type -- struct-array )
- heap-size struct-array boa ; inline
-
-: malloc-struct-array ( length c-type -- struct-array )
- [ heap-size calloc ] 2keep <direct-struct-array> ; inline
-
-INSTANCE: struct-array sequence
+++ /dev/null
-Arrays of C structs and unions
+++ /dev/null
-collections
+++ /dev/null
-IN: struct-vectors
-USING: help.markup help.syntax alien strings math ;
-
-HELP: struct-vector
-{ $class-description "The class of growable C struct and union arrays." } ;
-
-HELP: <struct-vector>
-{ $values { "capacity" integer } { "c-type" string } { "struct-vector" struct-vector } }
-{ $description "Creates a new vector with the given initial capacity." } ;
-
-ARTICLE: "struct-vectors" "C struct and union vectors"
-"The " { $vocab-link "struct-vectors" } " vocabulary implements vectors specialized for holding C struct and union values. These are growable versions of " { $vocab-link "struct-arrays" } "."
-{ $subsection struct-vector }
-{ $subsection <struct-vector> } ;
-
-ABOUT: "struct-vectors"
+++ /dev/null
-IN: struct-vectors.tests
-USING: struct-vectors tools.test alien.c-types alien.syntax
-namespaces kernel sequences ;
-
-C-STRUCT: point
- { "float" "x" }
- { "float" "y" } ;
-
-: make-point ( x y -- point )
- "point" <c-object>
- [ set-point-y ] keep
- [ set-point-x ] keep ;
-
-[ ] [ 1 "point" <struct-vector> "v" set ] unit-test
-
-[ 1.5 6.0 ] [
- 1.0 2.0 make-point "v" get push
- 3.0 4.5 make-point "v" get push
- 1.5 6.0 make-point "v" get push
- "v" get pop [ point-x ] [ point-y ] bi
-] unit-test
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types byte-arrays growable kernel math sequences
-sequences.private struct-arrays ;
-IN: struct-vectors
-
-TUPLE: struct-vector
-{ underlying struct-array }
-{ length array-capacity }
-{ c-type read-only } ;
-
-: <struct-vector> ( capacity c-type -- struct-vector )
- [ <struct-array> 0 ] keep struct-vector boa ; inline
-
-M: struct-vector byte-length underlying>> byte-length ;
-M: struct-vector new-sequence
- [ c-type>> <struct-array> ] [ [ >fixnum ] [ c-type>> ] bi* ] 2bi
- struct-vector boa ;
-
-M: struct-vector contract 2drop ;
-
-M: struct-array new-resizable c-type>> <struct-vector> ;
-
-INSTANCE: struct-vector growable
{ $subsection add-timing }
{ $subsection word-timing. }
"All of the above words are implemented using a single combinator which applies a quotation to a word definition to yield a new definition:"
-{ $subsection annotate } ;
+{ $subsection annotate }
+{ $warning
+ "Certain internal words, such as words in the " { $vocab-link "math" } ", " { $vocab-link "sequences" } " and UI vocabularies, cannot be annotated, since the annotated code may end up recursively invoking the word in question. This may crash or hang Factor. It is safest to only define annotations on your own words."
+} ;
ABOUT: "tools.annotations"
\r
os windows? os macosx? or [\r
[ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test\r
+] when\r
+\r
+os macosx? [\r
+ [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test\r
] when
\ No newline at end of file
! 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
] when ;
: strip-destructors ( -- )
- "libc" vocab [
- "Stripping destructor debug code" show
- "vocab:tools/deploy/shaker/strip-destructors.factor"
- run-file
- ] when ;
+ "Stripping destructor debug code" show
+ "vocab:tools/deploy/shaker/strip-destructors.factor"
+ run-file ;
: strip-call ( -- )
"Stripping stack effect checking from call( and execute(" show
"combination"
"compiled-generic-uses"
"compiled-uses"
+ "constant"
"constraints"
"custom-inlining"
"decision-tree"
"local-writer"
"local-writer?"
"local?"
+ "low-order"
"macro"
"members"
"memo-quot"
"slots"
"special"
"specializer"
+ "specializations"
+ "struct-slots"
! UI needs this
! "superclass"
"transform-n"
"disposables" "destructors" lookup ,
+ "functor-words" "functors.backend" lookup ,
+
deploy-threads? [
"initial-thread" "threads" lookup ,
] unless
{ } { "math.partial-dispatch" } strip-vocab-globals %
- { } { "math.vectors.specialization" } strip-vocab-globals %
-
{ } { "peg" } strip-vocab-globals %
] when
[ "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 ;
! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-IN: tools.deploy.shaker.call
-
+USING: combinators.private kernel ;
IN: combinators
-USE: combinators.private
-: call-effect ( word effect -- ) call-effect-unsafe ; inline
+: call-effect ( word effect -- ) call-effect-unsafe ;
+
+: execute-effect ( word effect -- ) execute-effect-unsafe ;
+
+IN: compiler.tree.propagation.call-effect
+
+: call-effect-unsafe? ( quot effect -- ? ) 2drop t ; inline
-: execute-effect ( word effect -- ) execute-effect-unsafe ; inline
\ No newline at end of file
+: execute-effect-unsafe? ( word effect -- ? ) 2drop t ; inline
\ No newline at end of file
: calloc ( size count -- newalien ) (calloc) check-ptr ;
: free ( alien -- ) (free) ;
+
+FORGET: malloc-ptr
+
+FORGET: <malloc-ptr>
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes.struct cocoa cocoa.classes
+cocoa.subclassing core-graphics.types kernel math ;
+IN: tools.deploy.test.14
+
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "Bar" }
+} {
+ "bar:"
+ "float"
+ { "id" "SEL" "NSRect" }
+ [
+ [ origin>> [ x>> ] [ y>> ] bi + ]
+ [ size>> [ w>> ] [ h>> ] bi + ]
+ bi +
+ ]
+} ;
+
+: main ( -- )
+ Bar -> alloc -> init
+ S{ CGRect f S{ CGPoint f 1.0 2.0 } S{ CGSize f 3.0 4.0 } } -> bar:
+ 10.0 assert= ;
+
+MAIN: main
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-math? t }
+ { deploy-io 2 }
+ { deploy-c-types? f }
+ { deploy-reflection 1 }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
+ { deploy-threads? t }
+ { deploy-ui? f }
+ { deploy-unicode? f }
+ { deploy-name "tools.deploy.test.14" }
+}
--- /dev/null
+unportable
] 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
+ os windows? [ 150000 + ] when
+ ] bi*
+ <= ;
: run-temp-image ( -- )
os macosx?
! (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
: 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" ;
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
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
<<
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 ;
--- /dev/null
+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
SYMBOL: file
: file-failure ( error -- )
- f file get f failure ;
+ [ f file get ] keep error-line failure ;
:: (unit-test) ( output input -- error ? )
[ { } input with-datastack output assert-sequence= f f ] [ t ] recover ;
{ +name+ "FactorApplicationDelegate" }
}
-{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
+{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
[ 3drop reset-run-loop ]
} ;
}
{ "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" }
! Rendering
{ "drawRect:" "void" { "id" "SEL" "NSRect" }
- [ 2drop window relayout-1 ]
+ [ 2drop window relayout-1 yield ]
}
! Events
! Copyright (C) 2005, 2006 Doug Coleman.
! Portions copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs ui ui.private
-ui.gadgets ui.gadgets.private ui.backend ui.clipboards
-ui.gadgets.worlds ui.gestures ui.event-loop io kernel math
-math.vectors namespaces make sequences strings vectors words
-windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
-windows.messages windows.types windows.offscreen windows.nt
-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 ;
+USING: alien alien.c-types alien.strings arrays assocs ui
+ui.private ui.gadgets ui.gadgets.private ui.backend
+ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
+kernel math math.vectors namespaces make sequences strings
+vectors words windows.kernel32 windows.gdi32 windows.user32
+windows.opengl32 windows.messages windows.types
+windows.offscreen windows.nt 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
+specialized-arrays classes.struct ;
+SPECIALIZED-ARRAY: POINT
IN: ui.backend.windows
SINGLETON: windows-ui-backend
[ 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*
: 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 )
{
{ 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 ;
window-controls>> window-control>ex-style symbols>flags ;
: get-RECT-top-left ( RECT -- x y )
- [ RECT-left ] keep RECT-top ;
+ [ left>> ] [ top>> ] bi ;
+
+: get-RECT-width/height ( RECT -- width height )
+ [ [ right>> ] [ left>> ] bi - ]
+ [ [ bottom>> ] [ top>> ] bi - ] bi ;
: get-RECT-dimensions ( RECT -- x y width height )
- [ get-RECT-top-left ] keep
- [ RECT-right ] keep [ RECT-left - ] keep
- [ RECT-bottom ] keep RECT-top - ;
+ [ get-RECT-top-left ] [ get-RECT-width/height ] bi ;
: handle-wm-paint ( hWnd uMsg wParam lParam -- )
#! wParam and lParam are unused
] if ;
: make-TRACKMOUSEEVENT ( hWnd -- alien )
- "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
- "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
+ TRACKMOUSEEVENT <struct>
+ swap >>hwndTrack
+ TRACKMOUSEEVENT heap-size >>cbSize ;
: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
2nip
over make-TRACKMOUSEEVENT
- TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
- 0 over set-TRACKMOUSEEVENT-dwHoverTime
+ TME_LEAVE >>dwFlags
+ 0 >>dwHoverTime
TrackMouseEvent drop
>lo-hi swap window move-hand fire-motion ;
] if ;
:: register-window-class ( class-name-ptr -- )
- "WNDCLASSEX" <c-object> f GetModuleHandle
+ WNDCLASSEX <struct> f GetModuleHandle
class-name-ptr pick GetClassInfoEx 0 = [
- "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
- { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
- ui-wndproc over set-WNDCLASSEX-lpfnWndProc
- 0 over set-WNDCLASSEX-cbClsExtra
- 0 over set-WNDCLASSEX-cbWndExtra
- f GetModuleHandle over set-WNDCLASSEX-hInstance
- f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
- over set-WNDCLASSEX-hIcon
- f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
-
- class-name-ptr over set-WNDCLASSEX-lpszClassName
+ WNDCLASSEX heap-size >>cbSize
+ { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags >>style
+ ui-wndproc >>lpfnWndProc
+ 0 >>cbClsExtra
+ 0 >>cbWndExtra
+ f GetModuleHandle >>hInstance
+ f GetModuleHandle "fraptor" utf16n string>alien LoadIcon >>hIcon
+ f IDC_ARROW LoadCursor >>hCursor
+
+ class-name-ptr >>lpszClassName
RegisterClassEx win32-error=0/f
] [ drop ] if ;
: make-RECT ( world -- RECT )
[ window-loc>> ] [ dim>> ] bi <RECT> ;
-: default-position-RECT ( RECT -- )
- dup get-RECT-dimensions [ 2drop ] 2dip
- CW_USEDEFAULT + pick set-RECT-bottom
- CW_USEDEFAULT + over set-RECT-right
- CW_USEDEFAULT over set-RECT-left
- CW_USEDEFAULT swap set-RECT-top ;
+: default-position-RECT ( RECT -- RECT' )
+ dup get-RECT-width/height
+ [ CW_USEDEFAULT + >>right ] dip
+ CW_USEDEFAULT + >>bottom
+ CW_USEDEFAULT >>left
+ CW_USEDEFAULT >>top ;
: make-adjusted-RECT ( rect style ex-style -- RECT )
[
dup get-RECT-top-left [ zero? ] both? swap
dup
] 2dip adjust-RECT
- swap [ dup default-position-RECT ] when ;
+ swap [ default-position-RECT ] when ;
: get-window-class ( -- class-name )
class-name-ptr [
: 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
: fullscreen-RECT ( hwnd -- RECT )
MONITOR_DEFAULTTONEAREST MonitorFromWindow
- "MONITORINFOEX" <c-object> dup length over set-MONITORINFOEX-cbSize
- [ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ;
+ MONITORINFOEX <struct>
+ MONITORINFOEX heap-size >>cbSize
+ [ GetMonitorInfo win32-error=0/f ] keep rcMonitor>> ;
: client-area>RECT ( hwnd -- RECT )
- "RECT" <c-object>
+ RECT <struct>
[ GetClientRect win32-error=0/f ]
- [ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
+ [ >c-ptr byte-array>POINT-array [ ClientToScreen drop ] with each ]
[ nip ] 2tri ;
: hwnd>RECT ( hwnd -- RECT )
- "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep ;
+ RECT <struct> [ GetWindowRect win32-error=0/f ] keep ;
M: windows-ui-backend (grab-input) ( handle -- )
0 ShowCursor drop
! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets
-ui.gadgets.private ui.gestures ui.backend ui.clipboards
-ui.gadgets.worlds ui.render ui.event-loop assocs kernel math
-namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim
-x11.glx x11.clipboard x11.constants x11.windows x11.io
-io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
-command-line math.vectors classes.tuple opengl.gl threads
-math.rectangles environment ascii literals
-ui.pixel-formats ui.pixel-formats.private ;
+USING: accessors alien.c-types arrays ascii assocs
+classes.struct combinators io.encodings.ascii
+io.encodings.string io.encodings.utf8 kernel literals math
+namespaces sequences strings ui ui.backend ui.clipboards
+ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
+ui.gestures ui.pixel-formats ui.pixel-formats.private
+ui.private x11 x11.clipboard x11.constants x11.events x11.glx
+x11.io x11.windows x11.xim x11.xlib environment command-line ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
M: world expose-event nip relayout ;
M: world configure-event
- over configured-loc >>window-loc
- swap configured-dim >>dim
+ swap [ event-loc >>window-loc ] [ event-dim >>dim ] bi
! In case dimensions didn't change
relayout-1 ;
M: x11-ui-backend (make-pixel-format)
[ drop dpy get scr get ] dip
- >glx-visual-int-array glXChooseVisual ;
+ >glx-visual-int-array glXChooseVisual
+ XVisualInfo memory>struct ;
M: x11-ui-backend (free-pixel-format)
handle>> XFree ;
dup key-codes at [ t ] [ 1string f ] ?if ;
: event-modifiers ( event -- seq )
- XKeyEvent-state modifiers modifier ;
+ state>> modifiers modifier ;
: valid-input? ( string gesture -- ? )
over empty? [ 2drop f ] [
[ key-up-event>gesture ] dip propagate-key-gesture ;
: mouse-event>gesture ( event -- modifiers button loc )
- [ event-modifiers ]
- [ XButtonEvent-button ]
- [ mouse-event-loc ]
- tri ;
+ [ event-modifiers ] [ button>> ] [ event-loc ] tri ;
M: world button-down-event
[ mouse-event>gesture [ <button-down> ] dip ] dip
send-button-up ;
: mouse-event>scroll-direction ( event -- pair )
- XButtonEvent-button {
+ button>> {
{ 4 { 0 -1 } }
{ 5 { 0 1 } }
{ 6 { -1 0 } }
} at ;
M: world wheel-event
- [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
+ [ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip
send-wheel ;
M: world enter-event motion-event ;
M: world leave-event 2drop forget-rollover ;
M: world motion-event
- [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
- move-hand fire-motion ;
+ [ event-loc ] dip move-hand fire-motion ;
M: world focus-in-event
- nip
- [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
+ nip [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
M: world focus-out-event
- nip
- [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
+ nip [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
M: world selection-notify-event
[ handle>> window>> selection-from-event ] keep
} case ;
: encode-clipboard ( string type -- bytes )
- XSelectionRequestEvent-target
- XA_UTF8_STRING = utf8 ascii ? encode ;
+ target>> XA_UTF8_STRING = utf8 ascii ? encode ;
: set-selection-prop ( evt -- )
dpy get swap
- [ XSelectionRequestEvent-requestor ] keep
- [ XSelectionRequestEvent-property ] keep
- [ XSelectionRequestEvent-target ] keep
- [ 8 PropModeReplace ] dip
- [
- XSelectionRequestEvent-selection
- clipboard-for-atom contents>>
- ] keep encode-clipboard dup length XChangeProperty drop ;
+ [ requestor>> ] keep
+ [ property>> ] keep
+ [ target>> 8 PropModeReplace ] keep
+ [ selection>> clipboard-for-atom contents>> ] keep
+ encode-clipboard dup length XChangeProperty drop ;
M: world selection-request-event
- drop dup XSelectionRequestEvent-target {
+ drop dup target>> {
{ [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
{ [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
{ [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
] [ wait-for-display wait-event ] if ;
M: x11-ui-backend do-events
- wait-event dup XAnyEvent-window window dup
+ wait-event dup XAnyEvent>> window>> window dup
[ handle-event ] [ 2drop ] if ;
: x-clipboard@ ( gadget clipboard -- prop win )
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
+: make-fullscreen-msg ( world ? -- msg )
+ XClientMessageEvent <struct>
+ ClientMessage >>type
+ dpy get >>display
+ "_NET_WM_STATE" x-atom >>message_type
+ swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
+ swap handle>> window>> >>window
+ 32 >>format
+ "_NET_WM_STATE_FULLSCREEN" x-atom >>data1 ;
+
M: x11-ui-backend (set-fullscreen) ( world ? -- )
- [
- handle>> window>> "XClientMessageEvent" <c-object>
- [ set-XClientMessageEvent-window ] keep
- ] dip
- _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
- over set-XClientMessageEvent-data0
- ClientMessage over set-XClientMessageEvent-type
- dpy get over set-XClientMessageEvent-display
- "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
- 32 over set-XClientMessageEvent-format
- "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
- [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
+ [ dpy get root get 0 SubstructureNotifyMask ] 2dip
+ make-fullscreen-msg XSendEvent drop ;
M: x11-ui-backend (open-window) ( world -- )
dup gadget-window
drop ;
M: x11-ui-backend (open-offscreen-buffer) ( world -- )
- dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ]
- with-world-pixel-format
+ dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ] with-world-pixel-format
<x11-pixmap-handle> >>handle drop ;
+
M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
dpy get swap
[ glx-pixmap>> glXDestroyGLXPixmap ]
$nl
"A button's appearance can vary depending on the state of the mouse button if the " { $snippet "interior" } " or " { $snippet "boundary" } " slots are set to instances of " { $link button-pen } "."
$nl
-"A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by " { $link checkbox } " instances to render themselves when they're checked." } ;
+"A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by " { $link checkbox } " instances to render themselves when they're checked."
+$nl
+"A button can optionally display a message in the window's status bar whenever the mouse cursor hovers over the button. To enable this behavior, just set a string to the button's " { $snippet "tooltip" } " slot." } ;
HELP: <button>
{ $values { "label" gadget } { "quot" { $quotation "( button -- )" } } { "button" "a new " { $link button } } }
FROM: models => change-model ;
IN: ui.gadgets.buttons
-TUPLE: button < border pressed? selected? quot ;
+TUPLE: button < border pressed? selected? quot tooltip ;
<PRIVATE
>>pressed?
relayout-1 ;
+: button-enter ( button -- )
+ dup dup tooltip>> [ swap show-status ] [ drop ] if* button-update ;
+
+: button-leave ( button -- )
+ dup "" swap show-status button-update ;
+
: button-clicked ( button -- )
dup button-update
dup button-rollover?
button H{
{ T{ button-up } [ button-clicked ] }
{ T{ button-down } [ button-update ] }
- { mouse-leave [ button-update ] }
- { mouse-enter [ button-update ] }
+ { mouse-leave [ button-leave ] }
+ { mouse-enter [ button-enter ] }
} set-gestures
: new-button ( label quot class -- button )
[ append theme-image ] tri-curry@ tri
] 2dip <tile-pen> ;
-CONSTANT: button-background
- T{ rgba
- f
- 0.8901960784313725
- 0.8862745098039215
- 0.8588235294117647
- 1.0
- }
-
-CONSTANT: button-clicked-background
- T{ rgba
- f
- 0.2156862745098039
- 0.2431372549019608
- 0.2823529411764706
- 1.0
- }
-
+CONSTANT: button-background COLOR: FactorTan
+CONSTANT: button-clicked-background COLOR: FactorDarkSlateBlue
+
: <border-button-pen> ( -- pen )
- "button" button-background COLOR: black <border-button-state-pen> dup
- "button-clicked" button-clicked-background COLOR: white <border-button-state-pen> dup dup
+ "button" button-background button-clicked-background
+ <border-button-state-pen> dup
+ "button-clicked" button-clicked-background COLOR: white
+ <border-button-state-pen> dup dup
<button-pen> ;
+: border-button-label-theme ( gadget -- )
+ dup label? [ [ clone t >>bold? ] change-font ] when drop ;
+
: border-button-theme ( gadget -- gadget )
+ dup children>> first border-button-label-theme
horizontal >>orientation
<border-button-pen> >>interior
dup dup interior>> pen-pref-dim >>min-dim
: command-button-quot ( target command -- quot )
'[ _ _ invoke-command ] ;
+: gesture>tooltip ( gesture -- str/f )
+ dup [ gesture>string "Shortcut: " prepend ] when ;
+
: <command-button> ( target gesture command -- button )
- [ command-string swap ] keep command-button-quot
- '[ drop @ ] <border-button> ;
+ swapd [ command-name swap ] keep command-button-quot
+ '[ drop @ ] <border-button> swap gesture>tooltip >>tooltip ;
: <toolbar> ( target -- toolbar )
<shelf>
namespaces make opengl sequences strings splitting ui.gadgets
ui.gadgets.tracks ui.gadgets.packs fonts ui.render ui.pens.solid
ui.baseline-alignment ui.text colors colors.constants models
-combinators ;
+combinators opengl.gl ;
IN: ui.gadgets.labels
! A label gadget draws a string.
: apply-page-color-style ( style gadget -- style gadget )
page-color [ <solid> >>interior ] apply-style ;
-: apply-border-width-style ( style gadget -- style gadget )
- border-width [ dup 2array <border> ] apply-style ;
+: apply-inset-style ( style gadget -- style gadget )
+ inset [ <border> ] apply-style ;
: style-pane ( style pane -- pane )
- apply-border-width-style
+ apply-inset-style
apply-border-color-style
apply-page-color-style
apply-presentation-style
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors models models.delay models.arrow
-sequences ui.gadgets.labels ui.gadgets.tracks
-ui.gadgets.worlds ui.gadgets ui ui.private kernel calendar summary ;
+USING: accessors calendar colors colors.constants fonts kernel
+models models.arrow models.delay sequences summary ui
+ui.gadgets ui.gadgets.labels ui.gadgets.tracks
+ui.gadgets.worlds ui.pens.solid ui.private ;
IN: ui.gadgets.status-bar
+: status-bar-font ( -- font )
+ sans-serif-font clone
+ COLOR: FactorDarkSlateBlue >>background
+ COLOR: white >>foreground ;
+
+: status-bar-theme ( label -- label )
+ status-bar-font >>font
+ COLOR: FactorDarkSlateBlue <solid> >>interior ;
+
: <status-bar> ( model -- gadget )
1/10 seconds <delay> [ "" like ] <arrow> <label-control>
- reverse-video-theme
+ status-bar-theme
t >>root? ;
: open-status-window ( gadget title/attributes -- )
HELP: set-title
{ $values { "string" string } { "world" world } }
-{ $description "Sets the title bar of the native window containing the world." }
-{ $notes "This word should not be called directly by user code. Instead, change the " { $snippet "title" } " slot model; see " { $link "models" } "." } ;
+{ $description "Sets the title bar of the native window containing the world." } ;
HELP: set-gl-context
{ $values { "world" world } }
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math math.vectors locals sequences
-specialized-arrays.float colors arrays combinators
+specialized-arrays colors arrays combinators
opengl opengl.gl ui.pens ui.pens.caching ;
+SPECIALIZED-ARRAY: float
IN: ui.pens.gradient
! Gradient pen
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors colors help.markup help.syntax kernel opengl
-opengl.gl sequences specialized-arrays.float math.vectors
-ui.gadgets ui.pens ;
+opengl.gl sequences math.vectors ui.gadgets ui.pens
+specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: ui.pens.polygon
! Polygon pen
USING: accessors assocs classes destructors functors kernel
-lexer math parser sequences specialized-arrays.int ui.backend
+lexer math parser sequences specialized-arrays ui.backend
words ;
+SPECIALIZED-ARRAY: int
IN: ui.pixel-formats
SYMBOLS:
ui.tools.browser.history ;
IN: ui.tools.browser
-TUPLE: browser-gadget < tool history pane scroller search-field popup ;
+TUPLE: browser-gadget < tool history scroller search-field popup ;
{ 650 400 } browser-gadget set-tool-dim
dup <history> >>history
dup <search-field> >>search-field
dup <browser-toolbar> { 3 3 } <border> { 1 0 } >>fill f track-add
- dup <help-pane> >>pane
- dup pane>> <scroller> >>scroller
- dup scroller>> 1 track-add ;
+ dup dup <help-pane> { 10 0 } <border> { 1 1 } >>fill
+ <scroller> >>scroller scroller>> 1 track-add ;
M: browser-gadget graft*
[ add-definition-observer ] [ call-next-method ] bi ;
} 2|| ;
M: browser-gadget definitions-changed ( assoc browser -- )
- model>> [ value>> swap showing-definition? ] keep
- '[ _ notify-connections ] when ;
+ [ model>> value>> swap showing-definition? ] keep
+ '[ _ [ history-value ] keep set-history-value ] when ;
M: browser-gadget focusable-child* search-field>> ;
M: error-renderer column-alignment drop { 0 1 0 0 } ;
: sort-errors ( seq -- seq' )
- [ [ [ line#>> ] [ asset>> unparse-short ] bi 2array ] keep ] { } map>assoc
+ [ [ [ line#>> 0 or ] [ asset>> unparse-short ] bi 2array ] keep ] { } map>assoc
sort-keys values ;
: file-matches? ( error pathname/f -- ? )
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax combinators system vocabs.loader ;
+USING: alien.syntax classes.struct combinators system
+vocabs.loader ;
IN: unix
CONSTANT: MAXPATHLEN 1024
CONSTANT: F_SETFL 4
CONSTANT: FD_CLOEXEC 1
-C-STRUCT: sockaddr-in
- { "uchar" "len" }
- { "uchar" "family" }
- { "ushort" "port" }
- { "in_addr_t" "addr" }
- { "longlong" "unused" } ;
-
-C-STRUCT: sockaddr-in6
- { "uchar" "len" }
- { "uchar" "family" }
- { "ushort" "port" }
- { "uint" "flowinfo" }
- { { "uchar" 16 } "addr" }
- { "uint" "scopeid" } ;
-
-C-STRUCT: sockaddr-un
- { "uchar" "len" }
- { "uchar" "family" }
- { { "char" 104 } "path" } ;
-
-C-STRUCT: passwd
- { "char*" "pw_name" }
- { "char*" "pw_passwd" }
- { "uid_t" "pw_uid" }
- { "gid_t" "pw_gid" }
- { "time_t" "pw_change" }
- { "char*" "pw_class" }
- { "char*" "pw_gecos" }
- { "char*" "pw_dir" }
- { "char*" "pw_shell" }
- { "time_t" "pw_expire" }
- { "int" "pw_fields" } ;
+STRUCT: sockaddr-in
+ { len uchar }
+ { family uchar }
+ { port ushort }
+ { addr in_addr_t }
+ { unused longlong } ;
+
+STRUCT: sockaddr-in6
+ { len uchar }
+ { family uchar }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
+
+STRUCT: sockaddr-un
+ { len uchar }
+ { family uchar }
+ { path char[104] } ;
+
+STRUCT: passwd
+ { pw_name char* }
+ { pw_passwd char* }
+ { pw_uid uid_t }
+ { pw_gid gid_t }
+ { pw_change time_t }
+ { pw_class char* }
+ { pw_gecos char* }
+ { pw_dir char* }
+ { pw_shell char* }
+ { pw_expire time_t }
+ { pw_fields int } ;
CONSTANT: max-un-path 104
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 1024
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { canonname char* }
+ { addr void* }
+ { next addrinfo* } ;
-C-STRUCT: dirent
- { "u_int32_t" "d_fileno" }
- { "u_int16_t" "d_reclen" }
- { "u_int8_t" "d_type" }
- { "u_int8_t" "d_namlen" }
- { { "char" 256 } "d_name" } ;
+STRUCT: dirent
+ { d_fileno u_int32_t }
+ { d_reclen u_int16_t }
+ { d_type u_int8_t }
+ { d_namlen u_int8_t }
+ { d_name char[256] } ;
CONSTANT: EPERM 1
CONSTANT: ENOENT 2
-USING: alien.syntax unix.time ;
+USING: alien.syntax unix.time classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 1024
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { canonname char* }
+ { addr void* }
+ { next addrinfo* } ;
CONSTANT: _UTX_USERSIZE 256
CONSTANT: _UTX_LINESIZE 32
CONSTANT: __DARWIN_MAXNAMELEN 255
CONSTANT: __DARWIN_MAXNAMELEN+1 255
-C-STRUCT: dirent
- { "ino_t" "d_ino" }
- { "__uint16_t" "d_reclen" }
- { "__uint8_t" "d_type" }
- { "__uint8_t" "d_namlen" }
- { { "char" __DARWIN_MAXNAMELEN+1 } "d_name" } ;
+STRUCT: dirent
+ { d_ino ino_t }
+ { d_reclen __uint16_t }
+ { d_type __uint8_t }
+ { d_namlen __uint8_t }
+ { d_name { "char" __DARWIN_MAXNAMELEN+1 } } ;
CONSTANT: EPERM 1
CONSTANT: ENOENT 2
-USING: alien.syntax alien.c-types math vocabs.loader ;
+USING: alien.syntax alien.c-types math vocabs.loader
+classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 256
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { canonname char* }
+ { addr void* }
+ { next addrinfo* } ;
-C-STRUCT: dirent
- { "__uint32_t" "d_fileno" }
- { "__uint16_t" "d_reclen" }
- { "__uint8_t" "d_type" }
- { "__uint8_t" "d_namlen" }
- { { "char" 256 } "d_name" } ;
+STRUCT: dirent
+ { d_fileno __uint32_t }
+ { d_reclen __uint16_t }
+ { d_type __uint8_t }
+ { d_namlen __uint8_t }
+ { d_name char[256] } ;
CONSTANT: EPERM 1
CONSTANT: ENOENT 2
CONSTANT: _UTX_IDSIZE 4
CONSTANT: _UTX_HOSTSIZE 256
-: _SS_MAXSIZE ( -- n )
- 128 ; inline
+CONSTANT: _SS_MAXSIZE 128
: _SS_ALIGNSIZE ( -- n )
"__int64_t" heap-size ; inline
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.time ;
+USING: alien.syntax unix.time classes.struct ;
IN: unix
-C-STRUCT: sockaddr_storage
- { "__uint8_t" "ss_len" }
- { "sa_family_t" "ss_family" }
- { { "char" _SS_PAD1SIZE } "__ss_pad1" }
- { "__int64_t" "__ss_align" }
- { { "char" _SS_PAD2SIZE } "__ss_pad2" } ;
+STRUCT: sockaddr_storage
+ { ss_len __uint8_t }
+ { ss_family sa_family_t }
+ { __ss_pad1 { "char" _SS_PAD1SIZE } }
+ { __ss_align __int64_t }
+ { __ss_pad2 { "char" _SS_PAD2SIZE } } ;
-C-STRUCT: exit_struct
- { "uint16_t" "e_termination" }
- { "uint16_t" "e_exit" } ;
+STRUCT: exit_struct
+ { e_termination uint16_t }
+ { e_exit uint16_t } ;
C-STRUCT: utmpx
{ { "char" _UTX_USERSIZE } "ut_user" }
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 1024
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "void*" "addr" }
- { "char*" "canonname" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { addr void* }
+ { canonname char* }
+ { next addrinfo* } ;
-C-STRUCT: dirent
- { "__uint32_t" "d_fileno" }
- { "__uint16_t" "d_reclen" }
- { "__uint8_t" "d_type" }
- { "__uint8_t" "d_namlen" }
- { { "char" 256 } "d_name" } ;
+STRUCT: dirent
+ { d_fileno __uint32_t }
+ { d_reclen __uint16_t }
+ { d_type __uint8_t }
+ { d_namlen __uint8_t }
+ { d_name char[256] } ;
CONSTANT: EPERM 1
CONSTANT: ENOENT 2
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings io.encodings.utf8
-io.backend.unix kernel math sequences splitting unix strings
+io.backend.unix kernel math sequences splitting strings
combinators.short-circuit byte-arrays combinators
accessors math.parser fry assocs namespaces continuations
-unix.users unix.utilities ;
+unix.users unix.utilities classes.struct ;
IN: unix.groups
+QUALIFIED: unix
+
QUALIFIED: grouping
TUPLE: group id name passwd members ;
<PRIVATE
: group-members ( group-struct -- seq )
- group-gr_mem utf8 alien>strings ;
+ gr_mem>> utf8 alien>strings ;
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
- "group" <c-object> tuck 4096
+ \ unix:group <struct> tuck 4096
[ <byte-array> ] keep f <void*> ;
: check-group-struct ( group-struct ptr -- group-struct/f )
*void* [ drop f ] unless ;
M: integer group-struct ( id -- group/f )
- (group-struct) [ getgrgid_r io-error ] keep check-group-struct ;
+ (group-struct) [ unix:getgrgid_r unix:io-error ] keep check-group-struct ;
M: string group-struct ( string -- group/f )
- (group-struct) [ getgrnam_r io-error ] keep check-group-struct ;
+ (group-struct) [ unix:getgrnam_r unix:io-error ] keep check-group-struct ;
: group-struct>group ( group-struct -- group )
[ \ group new ] dip
{
- [ group-gr_name >>name ]
- [ group-gr_passwd >>passwd ]
- [ group-gr_gid >>id ]
+ [ gr_name>> >>name ]
+ [ gr_passwd>> >>passwd ]
+ [ gr_gid>> >>id ]
[ group-members >>members ]
} cleave ;
dup group-cache get [
?at [ name>> ] [ number>string ] if
] [
- group-struct [ group-gr_name ] [ f ] if*
+ group-struct [ gr_name>> ] [ f ] if*
] if*
[ nip ] [ number>string ] if* ;
: group-id ( string -- id/f )
- group-struct [ group-gr_gid ] [ f ] if* ;
+ group-struct [ gr_gid>> ] [ f ] if* ;
<PRIVATE
: (user-groups) ( string -- seq )
#! first group is -1337, legacy unix code
- -1337 NGROUPS_MAX [ 4 * <byte-array> ] keep
- <int> [ getgrouplist io-error ] 2keep
+ -1337 unix:NGROUPS_MAX [ 4 * <byte-array> ] keep
+ <int> [ unix:getgrouplist unix:io-error ] 2keep
[ 4 tail-slice ] [ *int 1 - ] bi* >groups ;
PRIVATE>
user-name (user-groups) ;
: all-groups ( -- seq )
- [ getgrent dup ] [ group-struct>group ] produce nip ;
+ [ unix:getgrent dup ] [ \ unix:group memory>struct group-struct>group ] produce nip ;
: <group-cache> ( -- assoc )
all-groups [ [ id>> ] keep ] H{ } map>assoc ;
: with-group-cache ( quot -- )
[ <group-cache> group-cache ] dip with-variable ; inline
-: real-group-id ( -- id )
- getgid ; inline
+: real-group-id ( -- id ) unix:getgid ; inline
-: real-group-name ( -- string )
- real-group-id group-name ; inline
+: real-group-name ( -- string ) real-group-id group-name ; inline
-: effective-group-id ( -- string )
- getegid ; inline
+: effective-group-id ( -- string ) unix:getegid ; inline
: effective-group-name ( -- string )
effective-group-id group-name ; inline
<PRIVATE
: (set-real-group) ( id -- )
- setgid io-error ; inline
+ unix:setgid unix:io-error ; inline
: (set-effective-group) ( id -- )
- setegid io-error ; inline
+ unix:setegid unix:io-error ; inline
PRIVATE>
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.kqueue
-C-STRUCT: kevent
- { "ulong" "ident" } ! identifier for this event
- { "short" "filter" } ! filter for event
- { "ushort" "flags" } ! action flags for kqueue
- { "uint" "fflags" } ! filter flag value
- { "long" "data" } ! filter data value
- { "void*" "udata" } ! opaque user data identifier
-;
+STRUCT: kevent
+ { ident ulong }
+ { filter short }
+ { flags ushort }
+ { fflags uint }
+ { data long }
+ { udata void* } ;
FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.kqueue
-C-STRUCT: kevent
- { "ulong" "ident" } ! identifier for this event
- { "short" "filter" } ! filter for event
- { "ushort" "flags" } ! action flags for kqueue
- { "uint" "fflags" } ! filter flag value
- { "long" "data" } ! filter data value
- { "void*" "udata" } ! opaque user data identifier
-;
+STRUCT: kevent
+ { ident ulong }
+ { filter short }
+ { flags ushort }
+ { fflags uint }
+ { data long }
+ { udata void* } ;
FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.kqueue
-C-STRUCT: kevent
- { "ulong" "ident" } ! identifier for this event
- { "uint" "filter" } ! filter for event
- { "uint" "flags" } ! action flags for kqueue
- { "uint" "fflags" } ! filter flag value
- { "longlong" "data" } ! filter data value
- { "void*" "udata" } ! opaque user data identifier
-;
+STRUCT: kevent
+ { ident ulong }
+ { filter uint }
+ { flags uint }
+ { fflags uint }
+ { data longlong }
+ { udata void* } ;
FUNCTION: int kevent ( int kq, kevent* changelist, size_t nchanges, kevent* eventlist, size_t nevents, timespec* timeout ) ;
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.kqueue
-C-STRUCT: kevent
- { "uint" "ident" } ! identifier for this event
- { "short" "filter" } ! filter for event
- { "ushort" "flags" } ! action flags for kqueue
- { "uint" "fflags" } ! filter flag value
- { "int" "data" } ! filter data value
- { "void*" "udata" } ! opaque user data identifier
-;
+STRUCT: kevent
+ { ident uint }
+ { filter short }
+ { flags ushort }
+ { fflags uint }
+ { data int }
+ { udata void* } ;
FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: unix.linux.epoll
-USING: alien.syntax math ;
+USING: alien.syntax classes.struct math ;
FUNCTION: int epoll_create ( int size ) ;
FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ;
-C-STRUCT: epoll-event
- { "uint" "events" }
- { "uint" "fd" }
- { "uint" "padding" } ;
+STRUCT: epoll-event
+{ events uint }
+{ fd uint }
+{ padding uint } ;
FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: alien.syntax math math.bitwise ;\r
+USING: alien.syntax math math.bitwise classes.struct ;\r
IN: unix.linux.inotify\r
\r
-C-STRUCT: inotify-event\r
- { "int" "wd" } ! watch descriptor\r
- { "uint" "mask" } ! watch mask\r
- { "uint" "cookie" } ! cookie to synchronize two events\r
- { "uint" "len" } ! length (including nulls) of name\r
- { "char[0]" "name" } ! stub for possible name\r
- ;\r
+STRUCT: inotify-event\r
+ { wd int }\r
+ { mask uint }\r
+ { cookie uint }\r
+ { len uint }\r
+ { name char[0] } ;\r
\r
CONSTANT: IN_ACCESS HEX: 1 ! File was accessed\r
CONSTANT: IN_MODIFY HEX: 2 ! File was modified\r
CONSTANT: IN_Q_OVERFLOW HEX: 4000 ! Event queued overflowed\r
CONSTANT: IN_IGNORED HEX: 8000 ! File was ignored\r
\r
-: IN_CLOSE ( -- n ) IN_CLOSE_WRITE IN_CLOSE_NOWRITE bitor ; inline ! close\r
-: IN_MOVE ( -- n ) IN_MOVED_FROM IN_MOVED_TO bitor ; inline ! moves\r
+: IN_CLOSE ( -- n ) { IN_CLOSE_WRITE IN_CLOSE_NOWRITE } flags ; foldable ! close\r
+: IN_MOVE ( -- n ) { IN_MOVED_FROM IN_MOVED_TO } flags ; foldable ! moves\r
\r
CONSTANT: IN_ONLYDIR HEX: 1000000 ! only watch the path if it is a directory\r
CONSTANT: IN_DONT_FOLLOW HEX: 2000000 ! don't follow a sym link\r
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien system ;
+USING: alien.syntax alien system classes.struct ;
IN: unix
! Linux.
CONSTANT: F_SETFL 4
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "void*" "addr" }
- { "char*" "canonname" }
- { "addrinfo*" "next" } ;
-
-C-STRUCT: sockaddr-in
- { "ushort" "family" }
- { "ushort" "port" }
- { "in_addr_t" "addr" }
- { "longlong" "unused" } ;
-
-C-STRUCT: sockaddr-in6
- { "ushort" "family" }
- { "ushort" "port" }
- { "uint" "flowinfo" }
- { { "uchar" 16 } "addr" }
- { "uint" "scopeid" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { addr void* }
+ { canonname char* }
+ { next addrinfo* } ;
+
+STRUCT: sockaddr-in
+ { family ushort }
+ { port ushort }
+ { addr in_addr_t }
+ { unused longlong } ;
+
+STRUCT: sockaddr-in6
+ { family ushort }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
CONSTANT: max-un-path 108
-C-STRUCT: sockaddr-un
- { "ushort" "family" }
- { { "char" max-un-path } "path" } ;
+STRUCT: sockaddr-un
+ { family ushort }
+ { path { "char" max-un-path } } ;
CONSTANT: SOCK_STREAM 1
CONSTANT: SOCK_DGRAM 2
CONSTANT: SEEK_CUR 1
CONSTANT: SEEK_END 2
-C-STRUCT: passwd
- { "char*" "pw_name" }
- { "char*" "pw_passwd" }
- { "uid_t" "pw_uid" }
- { "gid_t" "pw_gid" }
- { "char*" "pw_gecos" }
- { "char*" "pw_dir" }
- { "char*" "pw_shell" } ;
+STRUCT: passwd
+ { pw_name char* }
+ { pw_passwd char* }
+ { pw_uid uid_t }
+ { pw_gid gid_t }
+ { pw_gecos char* }
+ { pw_dir char* }
+ { pw_shell char* } ;
! dirent64
-C-STRUCT: dirent
- { "ulonglong" "d_ino" }
- { "longlong" "d_off" }
- { "ushort" "d_reclen" }
- { "uchar" "d_type" }
- { { "char" 256 } "d_name" } ;
+STRUCT: dirent
+ { d_ino ulonglong }
+ { d_off longlong }
+ { d_reclen ushort }
+ { d_type uchar }
+ { d_name char[256] } ;
FUNCTION: int open64 ( char* path, int flags, int prot ) ;
FUNCTION: dirent64* readdir64 ( DIR* dirp ) ;
! Copyright (C) 2006 Patrick Mauritz.
! See http://factorcode.org/license.txt for BSD license.
-IN: unix
USING: alien.syntax system kernel layouts ;
+IN: unix
! Solaris.
CONSTANT: F_SETFL 4 ! set file status flags
CONSTANT: O_NONBLOCK HEX: 80 ! no delay
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
! #ifdef __sparcv9
! int _ai_pad;
! #endif
- { "int" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "void*" "next" } ;
-
-C-STRUCT: sockaddr-in
- { "ushort" "family" }
- { "ushort" "port" }
- { "in_addr_t" "addr" }
- { "longlong" "unused" } ;
-
-C-STRUCT: sockaddr-in6
- { "ushort" "family" }
- { "ushort" "port" }
- { "uint" "flowinfo" }
- { { "uchar" 16 } "addr" }
- { "uint" "scopeid" } ;
+ { addrlen int }
+ { canonname char* }
+ { addr void* }
+ { next void* } ;
+
+STRUCT: sockaddr-in
+ { family ushort }
+ { port ushort }
+ { addr in_addr_t }
+ { unused longlong } ;
+
+STRUCT: sockaddr-in6
+ { family ushort }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
: max-un-path 108 ;
-C-STRUCT: sockaddr-un
- { "ushort" "family" }
- { { "char" max-un-path } "path" } ;
+STRUCT: sockaddr-un
+ { family ushort }
+ { path { "char" max-un-path } } ;
CONSTANT: EINTR 4
CONSTANT: EAGAIN 11
+++ /dev/null
-USING: kernel alien.syntax math ;
-
-IN: unix.stat
-
-! FreeBSD 8.0-CURRENT
-
-C-STRUCT: stat
- { "__dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "__dev_t" "st_rdev" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "off_t" "st_size" }
- { "blkcnt_t" "st_blocks" }
- { "blksize_t" "st_blksize" }
- { "fflags_t" "st_flags" }
- { "__uint32_t" "st_gen" }
- { "__int32_t" "st_lspare" }
- { "timespec" "st_birthtimespec" }
-! not sure about the padding here.
- { "__uint32_t" "pad0" }
- { "__uint32_t" "pad1" } ;
-
-FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
+++ /dev/null
-unportable
+++ /dev/null
-USING: kernel alien.syntax math ;
-IN: unix.stat
-
-! FreeBSD 8.0-CURRENT
-! untested
-
-C-STRUCT: stat
- { "__dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "__dev_t" "st_rdev" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "off_t" "st_size" }
- { "blkcnt_t" "st_blocks" }
- { "blksize_t" "st_blksize" }
- { "fflags_t" "st_flags" }
- { "__uint32_t" "st_gen" }
- { "__int32_t" "st_lspare" }
- { "timespec" "st_birthtimespec" }
-! not sure about the padding here.
- { "__uint32_t" "pad0" }
- { "__uint32_t" "pad1" } ;
-
-FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
+++ /dev/null
-unportable
-USING: layouts combinators vocabs.loader ;
+USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
-cell-bits {
- { 32 [ "unix.stat.freebsd.32" require ] }
- { 64 [ "unix.stat.freebsd.64" require ] }
-} case
+! FreeBSD 8.0-CURRENT
+
+STRUCT: stat
+ { st_dev __dev_t }
+ { st_ino ino_t }
+ { st_mode mode_t }
+ { st_nlink nlink_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { st_rdev __dev_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { st_size off_t }
+ { st_blocks blkcnt_t }
+ { st_blksize blksize_t }
+ { st_flags fflags_t }
+ { st_gen __uint32_t }
+ { st_lspare __int32_t }
+ { st_birthtimespec timespec }
+ { pad0 __int32_t[2] } ;
+
+FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
-USING: kernel alien.syntax math sequences unix
-alien.c-types arrays accessors combinators ;
+USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! stat64
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "ushort" "__pad1" }
- { "__ino_t" "__st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { { "ushort" 2 } "__pad2" }
- { "off64_t" "st_size" }
- { "blksize_t" "st_blksize" }
- { "blkcnt64_t" "st_blocks" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "ulonglong" "st_ino" } ;
+STRUCT: stat
+ { st_dev dev_t }
+ { __pad1 ushort }
+ { __st_ino __ino_t }
+ { st_mode mode_t }
+ { st_nlink nlink_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { st_rdev dev_t }
+ { __pad2 ushort[2] }
+ { st_size off64_t }
+ { st_blksize blksize_t }
+ { st_blocks blkcnt64_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { st_ino ulonglong } ;
FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;
-USING: kernel alien.syntax math sequences unix
-alien.c-types arrays accessors combinators ;
+USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! Ubuntu 7.10 64-bit
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "nlink_t" "st_nlink" }
- { "mode_t" "st_mode" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "int" "pad0" }
- { "dev_t" "st_rdev" }
- { "off64_t" "st_size" }
- { "blksize_t" "st_blksize" }
- { "blkcnt64_t" "st_blocks" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "long" "__unused0" }
- { "long" "__unused1" }
- { "long" "__unused2" } ;
+STRUCT: stat
+ { st_dev dev_t }
+ { st_ino ino_t }
+ { st_nlink nlink_t }
+ { st_mode mode_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { pad0 int }
+ { st_rdev dev_t }
+ { st_size off64_t }
+ { st_blksize blksize_t }
+ { st_blocks blkcnt64_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { __unused0 long[3] } ;
FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;
-USING: kernel alien.syntax math unix math.bitwise
-alien.c-types alien sequences grouping accessors combinators ;
+USING: alien.c-types arrays accessors combinators classes.struct
+alien.syntax ;
IN: unix.stat
! Mac OS X ppc
! stat64 structure
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "ino64_t" "st_ino" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "timespec" "st_birthtimespec" }
- { "off_t" "st_size" }
- { "blkcnt_t" "st_blocks" }
- { "blksize_t" "st_blksize" }
- { "__uint32_t" "st_flags" }
- { "__uint32_t" "st_gen" }
- { "__int32_t" "st_lspare" }
- { "__int64_t" "st_qspare0" }
- { "__int64_t" "st_qspare1" } ;
+STRUCT: stat
+ { st_dev dev_t }
+ { st_mode mode_t }
+ { st_nlink nlink_t }
+ { st_ino ino64_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { st_rdev dev_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { st_birthtimespec timespec }
+ { st_size off_t }
+ { st_blocks blkcnt_t }
+ { st_blksize blksize_t }
+ { st_flags __uint32_t }
+ { st_gen __uint32_t }
+ { st_lspare __int32_t }
+ { st_qspare0 __int64_t }
+ { st_qspare1 __int64_t } ;
FUNCTION: int stat64 ( char* pathname, stat* buf ) ;
FUNCTION: int lstat64 ( char* pathname, stat* buf ) ;
-USING: kernel alien.syntax math ;
+USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! NetBSD 4.0
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "mode_t" "st_mode" }
- { "ino_t" "st_ino" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "timespec" "st_birthtimespec" }
- { "off_t" "st_size" }
- { "blkcnt_t" "st_blocks" }
- { "blksize_t" "st_blksize" }
- { "uint32_t" "st_flags" }
- { "uint32_t" "st_gen" }
- { { "uint32_t" 2 } "st_qspare" } ;
+STRUCT: stat
+ { st_dev dev_t }
+ { st_mode mode_t }
+ { st_ino ino_t }
+ { st_nlink nlink_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { st_rdev dev_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { st_birthtimespec timespec }
+ { st_size off_t }
+ { st_blocks blkcnt_t }
+ { st_blksize blksize_t }
+ { st_flags uint32_t }
+ { st_gen uint32_t }
+ { st_qspare uint32_t[2] } ;
FUNCTION: int __stat30 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat30 ( char* pathname, stat* buf ) ;
-USING: kernel alien.syntax math ;
+USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! NetBSD 4.0
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "off_t" "st_size" }
- { "blkcnt_t" "st_blocks" }
- { "blksize_t" "st_blksize" }
- { "uint32_t" "st_flags" }
- { "uint32_t" "st_gen" }
- { "uint32_t" "st_spare0" }
- { "timespec" "st_birthtimespec" } ;
+STRUCT: stat
+ { st_dev dev_t }
+ { st_ino ino_t }
+ { st_mode mode_t }
+ { st_nlink nlink_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { st_rdev dev_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { st_size off_t }
+ { st_blocks blkcnt_t }
+ { st_blksize blksize_t }
+ { st_flags uint32_t }
+ { st_gen uint32_t }
+ { st_spare0 uint32_t }
+ { st_birthtimespec timespec } ;
FUNCTION: int __stat13 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat13 ( char* pathname, stat* buf ) ;
-USING: kernel alien.syntax math ;
+USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! OpenBSD 4.2
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { "int32_t" "st_lspare0" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "off_t" "st_size" }
- { "int64_t" "st_blocks" }
- { "u_int32_t" "st_blksize" }
- { "u_int32_t" "st_flags" }
- { "u_int32_t" "st_gen" }
- { "int32_t" "st_lspare1" }
- { "timespec" "st_birthtimespec" }
- { { "int64_t" 2 } "st_qspare" } ;
+STRUCT: stat
+ { st_dev dev_t }
+ { st_ino ino_t }
+ { st_mode mode_t }
+ { st_nlink nlink_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { st_rdev dev_t }
+ { st_lspare0 int32_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { st_size off_t }
+ { st_blocks int64_t }
+ { st_blksize u_int32_t }
+ { st_flags u_int32_t }
+ { st_gen u_int32_t }
+ { st_lspare1 int32_t }
+ { st_birthtimespec timespec }
+ { st_qspare int64_t[2] } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;
USING: kernel system combinators alien.syntax alien.c-types
-math io.backend.unix vocabs.loader unix ;
+math io.backend.unix vocabs.loader unix classes.struct ;
IN: unix.stat
! File Types
CONSTANT: S_IFSOCK OCT: 140000 ! Socket.
CONSTANT: S_IFWHT OCT: 160000 ! Whiteout.
-C-STRUCT: fsid
- { { "int" 2 } "__val" } ;
+STRUCT: fsid
+ { __val int[2] } ;
TYPEDEF: fsid __fsid_t
TYPEDEF: fsid fsid_t
} case >>
: file-status ( pathname -- stat )
- "stat" <c-object> [ [ stat ] unix-system-call drop ] keep ;
+ \ stat <struct> [ [ stat ] unix-system-call drop ] keep ;
: link-status ( pathname -- stat )
- "stat" <c-object> [ [ lstat ] unix-system-call drop ] keep ;
+ \ stat <struct> [ [ lstat ] unix-system-call drop ] keep ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.types unix.stat ;
+USING: alien.syntax unix.types unix.stat classes.struct ;
IN: unix.statfs.freebsd
CONSTANT: MFSNAMELEN 16 ! length of type name including null */
CONSTANT: MNAMELEN 88 ! size of on/from name bufs
CONSTANT: STATFS_VERSION HEX: 20030518 ! current version number
-C-STRUCT: statfs
- { "uint32_t" "f_version" }
- { "uint32_t" "f_type" }
- { "uint64_t" "f_flags" }
- { "uint64_t" "f_bsize" }
- { "uint64_t" "f_iosize" }
- { "uint64_t" "f_blocks" }
- { "uint64_t" "f_bfree" }
- { "int64_t" "f_bavail" }
- { "uint64_t" "f_files" }
- { "int64_t" "f_ffree" }
- { "uint64_t" "f_syncwrites" }
- { "uint64_t" "f_asyncwrites" }
- { "uint64_t" "f_syncreads" }
- { "uint64_t" "f_asyncreads" }
- { { "uint64_t" 10 } "f_spare" }
- { "uint32_t" "f_namemax" }
- { "uid_t" "f_owner" }
- { "fsid_t" "f_fsid" }
- { { "char" 80 } "f_charspare" }
- { { "char" MFSNAMELEN } "f_fstypename" }
- { { "char" MNAMELEN } "f_mntfromname" }
- { { "char" MNAMELEN } "f_mntonname" } ;
+STRUCT: statfs
+ { f_version uint32_t }
+ { f_type uint32_t }
+ { f_flags uint64_t }
+ { f_bsize uint64_t }
+ { f_iosize uint64_t }
+ { f_blocks uint64_t }
+ { f_bfree uint64_t }
+ { f_bavail int64_t }
+ { f_files uint64_t }
+ { f_ffree int64_t }
+ { f_syncwrites uint64_t }
+ { f_asyncwrites uint64_t }
+ { f_syncreads uint64_t }
+ { f_asyncreads uint64_t }
+ { f_spare uint64_t[10] }
+ { f_namemax uint32_t }
+ { f_owner uid_t }
+ { f_fsid fsid_t }
+ { f_charspare char[80] }
+ { f_fstypename { "char" MFSNAMELEN } }
+ { f_mntfromname { "char" MNAMELEN } }
+ { f_mntonname { "char" MNAMELEN } } ;
FUNCTION: int statfs ( char* path, statvfs* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.types unix.stat ;
+USING: alien.syntax unix.types unix.stat classes.struct ;
IN: unix.statfs.linux
-C-STRUCT: statfs64
- { "__SWORD_TYPE" "f_type" }
- { "__SWORD_TYPE" "f_bsize" }
- { "__fsblkcnt64_t" "f_blocks" }
- { "__fsblkcnt64_t" "f_bfree" }
- { "__fsblkcnt64_t" "f_bavail" }
- { "__fsfilcnt64_t" "f_files" }
- { "__fsfilcnt64_t" "f_ffree" }
- { "__fsid_t" "f_fsid" }
- { "__SWORD_TYPE" "f_namelen" }
- { "__SWORD_TYPE" "f_frsize" }
- { { "__SWORD_TYPE" 5 } "f_spare" } ;
+STRUCT: statfs64
+ { f_type __SWORD_TYPE }
+ { f_bsize __SWORD_TYPE }
+ { f_blocks __fsblkcnt64_t }
+ { f_bfree __fsblkcnt64_t }
+ { f_bavail __fsblkcnt64_t }
+ { f_files __fsblkcnt64_t }
+ { f_ffree __fsblkcnt64_t }
+ { f_fsid __fsid_t }
+ { f_namelen __SWORD_TYPE }
+ { f_frsize __SWORD_TYPE }
+ { f_spare __SWORD_TYPE[5] } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
USING: alien.c-types io.encodings.utf8 io.encodings.string
kernel sequences unix.stat accessors unix combinators math
grouping system alien.strings math.bitwise alien.syntax
-unix.types ;
+unix.types classes.struct ;
IN: unix.statfs.macosx
CONSTANT: MNT_RDONLY HEX: 00000001
CONSTANT: VFS_CTL_TIMEO HEX: 00010005
CONSTANT: VFS_CTL_NOLOCKS HEX: 00010006
-C-STRUCT: vfsquery
- { "uint32_t" "vq_flags" }
- { { "uint32_t" 31 } "vq_spare" } ;
+STRUCT: vfsquery
+ { vq_flags uint32_t }
+ { vq_spare uint32_t[31] } ;
CONSTANT: VQ_NOTRESP HEX: 0001
CONSTANT: VQ_NEEDAUTH HEX: 0002
CONSTANT: MNAMELEN 90
CONSTANT: MFSTYPENAMELEN 16
-C-STRUCT: fsid_t
- { { "int32_t" 2 } "val" } ;
+STRUCT: fsid_t
+ { val int32_t[2] } ;
-C-STRUCT: statfs64
- { "uint32_t" "f_bsize" }
- { "int32_t" "f_iosize" }
- { "uint64_t" "f_blocks" }
- { "uint64_t" "f_bfree" }
- { "uint64_t" "f_bavail" }
- { "uint64_t" "f_files" }
- { "uint64_t" "f_ffree" }
- { "fsid_t" "f_fsid" }
- { "uid_t" "f_owner" }
- { "uint32_t" "f_type" }
- { "uint32_t" "f_flags" }
- { "uint32_t" "f_fssubtype" }
- { { "char" MFSTYPENAMELEN } "f_fstypename" }
- { { "char" MAXPATHLEN } "f_mntonname" }
- { { "char" MAXPATHLEN } "f_mntfromname" }
- { { "uint32_t" 8 } "f_reserved" } ;
+STRUCT: statfs64
+ { f_bsize uint32_t }
+ { f_iosize int32_t }
+ { f_blocks uint64_t }
+ { f_bfree uint64_t }
+ { f_bavail uint64_t }
+ { f_files uint64_t }
+ { f_ffree uint64_t }
+ { f_fsid fsid_t }
+ { f_owner uid_t }
+ { f_type uint32_t }
+ { f_flags uint32_t }
+ { f_fssubtype uint32_t }
+ { f_fstypename { "char" MFSTYPENAMELEN } }
+ { f_mntonname { "char" MAXPATHLEN } }
+ { f_mntfromname { "char" MAXPATHLEN } }
+ { f_reserved uint32_t[8] } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
FUNCTION: int getmntinfo64 ( statfs64** mntbufp, int flags ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.types unix.stat ;
+USING: alien.syntax unix.types unix.stat classes.struct ;
IN: unix.statfs.openbsd
CONSTANT: MFSNAMELEN 16
CONSTANT: MNAMELEN 90
-C-STRUCT: statfs
- { "u_int32_t" "f_flags" }
- { "u_int32_t" "f_bsize" }
- { "u_int32_t" "f_iosize" }
- { "u_int64_t" "f_blocks" }
- { "u_int64_t" "f_bfree" }
- { "int64_t" "f_bavail" }
- { "u_int64_t" "f_files" }
- { "u_int64_t" "f_ffree" }
- { "int64_t" "f_favail" }
- { "u_int64_t" "f_syncwrites" }
- { "u_int64_t" "f_syncreads" }
- { "u_int64_t" "f_asyncwrites" }
- { "u_int64_t" "f_asyncreads" }
- { "fsid_t" "f_fsid" }
- { "u_int32_t" "f_namemax" }
- { "uid_t" "f_owner" }
- { "u_int32_t" "f_ctime" }
- { { "u_int32_t" 3 } "f_spare" }
- { { "char" MFSNAMELEN } "f_fstypename" }
- { { "char" MNAMELEN } "f_mntonname" }
- { { "char" MNAMELEN } "f_mntfromname" }
- { { "char" 160 } "mount_info" } ;
+STRUCT: statfs
+ { f_flags u_int32_t }
+ { f_bsize u_int32_t }
+ { f_iosize u_int32_t }
+ { f_blocks u_int64_t }
+ { f_bfree u_int64_t }
+ { f_bavail int64_t }
+ { f_files u_int64_t }
+ { f_ffree u_int64_t }
+ { f_favail int64_t }
+ { f_syncwrites u_int64_t }
+ { f_syncreads u_int64_t }
+ { f_asyncwrites u_int64_t }
+ { f_asyncreads u_int64_t }
+ { f_fsid fsid_t }
+ { f_namemax u_int32_t }
+ { f_owner uid_t }
+ { f_ctime u_int32_t }
+ { f_spare u_int32_t[3] }
+ { f_fstypename { "char" MFSNAMELEN } }
+ { f_mntonname { "char" MNAMELEN } }
+ { f_mntfromname { "char" MNAMELEN } }
+ { mount_info char[160] } ;
FUNCTION: int statfs ( char* path, statvfs* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.statvfs.freebsd
-C-STRUCT: statvfs
- { "fsblkcnt_t" "f_bavail" }
- { "fsblkcnt_t" "f_bfree" }
- { "fsblkcnt_t" "f_blocks" }
- { "fsfilcnt_t" "f_favail" }
- { "fsfilcnt_t" "f_ffree" }
- { "fsfilcnt_t" "f_files" }
- { "ulong" "f_bsize" }
- { "ulong" "f_flag" }
- { "ulong" "f_frsize" }
- { "ulong" "f_fsid" }
- { "ulong" "f_namemax" } ;
+STRUCT: statvfs
+ { f_bavail fsblkcnt_t }
+ { f_bfree fsblkcnt_t }
+ { f_blocks fsblkcnt_t }
+ { f_favail fsfilcnt_t }
+ { f_ffree fsfilcnt_t }
+ { f_files fsfilcnt_t }
+ { f_bsize ulong }
+ { f_flag ulong }
+ { f_frsize ulong }
+ { f_fsid ulong }
+ { f_namemax ulong } ;
! Flags
CONSTANT: ST_RDONLY HEX: 1 ! Read-only file system
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.statvfs.linux
-C-STRUCT: statvfs64
- { "ulong" "f_bsize" }
- { "ulong" "f_frsize" }
- { "__fsblkcnt64_t" "f_blocks" }
- { "__fsblkcnt64_t" "f_bfree" }
- { "__fsblkcnt64_t" "f_bavail" }
- { "__fsfilcnt64_t" "f_files" }
- { "__fsfilcnt64_t" "f_ffree" }
- { "__fsfilcnt64_t" "f_favail" }
- { "ulong" "f_fsid" }
- { "ulong" "f_flag" }
- { "ulong" "f_namemax" }
- { { "int" 6 } "__f_spare" } ;
+STRUCT: statvfs64
+ { f_bsize ulong }
+ { f_frsize ulong }
+ { f_blocks __fsblkcnt64_t }
+ { f_bfree __fsblkcnt64_t }
+ { f_bavail __fsblkcnt64_t }
+ { f_files __fsfilcnt64_t }
+ { f_ffree __fsfilcnt64_t }
+ { f_favail __fsfilcnt64_t }
+ { f_fsid ulong }
+ { f_flag ulong }
+ { f_namemax ulong }
+ { __f_spare int[6] } ;
FUNCTION: int statvfs64 ( char* path, statvfs64* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.statvfs.macosx
-C-STRUCT: statvfs
- { "ulong" "f_bsize" }
- { "ulong" "f_frsize" }
- { "fsblkcnt_t" "f_blocks" }
- { "fsblkcnt_t" "f_bfree" }
- { "fsblkcnt_t" "f_bavail" }
- { "fsfilcnt_t" "f_files" }
- { "fsfilcnt_t" "f_ffree" }
- { "fsfilcnt_t" "f_favail" }
- { "ulong" "f_fsid" }
- { "ulong" "f_flag" }
- { "ulong" "f_namemax" } ;
+STRUCT: statvfs
+ { f_bsize ulong }
+ { f_frsize ulong }
+ { f_blocks fsblkcnt_t }
+ { f_bfree fsblkcnt_t }
+ { f_bavail fsblkcnt_t }
+ { f_files fsfilcnt_t }
+ { f_ffree fsfilcnt_t }
+ { f_favail fsfilcnt_t }
+ { f_fsid ulong }
+ { f_flag ulong }
+ { f_namemax ulong } ;
! Flags
CONSTANT: ST_RDONLY HEX: 1 ! Read-only file system
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.statvfs.netbsd
CONSTANT: _VFS_NAMELEN 32
CONSTANT: _VFS_MNAMELEN 1024
-C-STRUCT: statvfs
- { "ulong" "f_flag" }
- { "ulong" "f_bsize" }
- { "ulong" "f_frsize" }
- { "ulong" "f_iosize" }
- { "fsblkcnt_t" "f_blocks" }
- { "fsblkcnt_t" "f_bfree" }
- { "fsblkcnt_t" "f_bavail" }
- { "fsblkcnt_t" "f_bresvd" }
- { "fsfilcnt_t" "f_files" }
- { "fsfilcnt_t" "f_ffree" }
- { "fsfilcnt_t" "f_favail" }
- { "fsfilcnt_t" "f_fresvd" }
- { "uint64_t" "f_syncreads" }
- { "uint64_t" "f_syncwrites" }
- { "uint64_t" "f_asyncreads" }
- { "uint64_t" "f_asyncwrites" }
- { "fsid_t" "f_fsidx" }
- { "ulong" "f_fsid" }
- { "ulong" "f_namemax" }
- { "uid_t" "f_owner" }
- { { "uint32_t" 4 } "f_spare" }
- { { "char" _VFS_NAMELEN } "f_fstypename" }
- { { "char" _VFS_MNAMELEN } "f_mntonname" }
- { { "char" _VFS_MNAMELEN } "f_mntfromname" } ;
+STRUCT: statvfs
+ { f_flag ulong }
+ { f_bsize ulong }
+ { f_frsize ulong }
+ { f_iosize ulong }
+ { f_blocks fsblkcnt_t }
+ { f_bfree fsblkcnt_t }
+ { f_bavail fsblkcnt_t }
+ { f_bresvd fsblkcnt_t }
+ { f_files fsfilcnt_t }
+ { f_ffree fsfilcnt_t }
+ { f_favail fsfilcnt_t }
+ { f_fresvd fsfilcnt_t }
+ { f_syncreads uint64_t }
+ { f_syncwrites uint64_t }
+ { f_asyncreads uint64_t }
+ { f_asyncwrites uint64_t }
+ { f_fsidx fsid_t }
+ { f_fsid ulong }
+ { f_namemax ulong }
+ { f_owner uid_t }
+ { f_spare uint32_t[4] }
+ { f_fstypename { "char" _VFS_NAMELEN } }
+ { f_mntonname { "char" _VFS_MNAMELEN } }
+ { f_mntfromname { "char" _VFS_MNAMELEN } } ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.statvfs.openbsd
-C-STRUCT: statvfs
- { "ulong" "f_bsize" }
- { "ulong" "f_frsize" }
- { "fsblkcnt_t" "f_blocks" }
- { "fsblkcnt_t" "f_bfree" }
- { "fsblkcnt_t" "f_bavail" }
- { "fsfilcnt_t" "f_files" }
- { "fsfilcnt_t" "f_ffree" }
- { "fsfilcnt_t" "f_favail" }
- { "ulong" "f_fsid" }
- { "ulong" "f_flag" }
- { "ulong" "f_namemax" } ;
+STRUCT: statvfs
+ { f_bsize ulong }
+ { f_frsize ulong }
+ { f_blocks fsblkcnt_t }
+ { f_bfree fsblkcnt_t }
+ { f_bavail fsblkcnt_t }
+ { f_files fsfilcnt_t }
+ { f_ffree fsfilcnt_t }
+ { f_favail fsfilcnt_t }
+ { f_fsid ulong }
+ { f_flag ulong }
+ { f_namemax ulong } ;
CONSTANT: ST_RDONLY 1
CONSTANT: ST_NOSUID 2
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien.syntax alien.c-types math unix.types ;
+USING: kernel alien.syntax alien.c-types math unix.types
+classes.struct accessors ;
IN: unix.time
-C-STRUCT: timeval
- { "long" "sec" }
- { "long" "usec" } ;
+STRUCT: timeval
+ { sec long }
+ { usec long } ;
-C-STRUCT: timespec
- { "time_t" "sec" }
- { "long" "nsec" } ;
+STRUCT: timespec
+ { sec time_t }
+ { nsec long } ;
: make-timeval ( us -- timeval )
1000000 /mod
- "timeval" <c-object>
- [ set-timeval-usec ] keep
- [ set-timeval-sec ] keep ;
+ timeval <struct>
+ swap >>usec
+ swap >>sec ;
: make-timespec ( us -- timespec )
1000000 /mod 1000 *
- "timespec" <c-object>
- [ set-timespec-nsec ] keep
- [ set-timespec-sec ] keep ;
+ timespec <struct>
+ swap >>nsec
+ swap >>sec ;
-C-STRUCT: tm
- { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?)
- { "int" "min" } ! Minutes: 0-59
- { "int" "hour" } ! Hours since midnight: 0-23
- { "int" "mday" } ! Day of the month: 1-31
- { "int" "mon" } ! Months *since* january: 0-11
- { "int" "year" } ! Years since 1900
- { "int" "wday" } ! Days since Sunday (0-6)
- { "int" "yday" } ! Days since Jan. 1: 0-365
- { "int" "isdst" } ! +1 Daylight Savings Time, 0 No DST,
- { "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?)
- { "char*" "zone" } ;
+STRUCT: tm
+ { sec int }
+ { min int }
+ { hour int }
+ { mday int }
+ { mon int }
+ { year int }
+ { wday int }
+ { yday int }
+ { isdst int }
+ { gmtoff long }
+ { zone char* } ;
FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: tm* localtime ( time_t* clock ) ;
sequences continuations byte-arrays strings math namespaces
system combinators vocabs.loader accessors
stack-checker macros locals generalizations unix.types
-io vocabs ;
+io vocabs classes.struct ;
IN: unix
CONSTANT: PROT_NONE 0
CONSTANT: DT_SOCK 12
CONSTANT: DT_WHT 14
-C-STRUCT: group
- { "char*" "gr_name" }
- { "char*" "gr_passwd" }
- { "int" "gr_gid" }
- { "char**" "gr_mem" } ;
+STRUCT: group
+ { gr_name char* }
+ { gr_passwd char* }
+ { gr_gid int }
+ { gr_mem char** } ;
LIBRARY: libc
FUNCTION: DIR* opendir ( char* path ) ;
-C-STRUCT: utimbuf
- { "time_t" "actime" }
- { "time_t" "modtime" } ;
+STRUCT: utimbuf
+ { actime time_t }
+ { modtime time_t } ;
-FUNCTION: int utime ( char* path, utimebuf* buf ) ;
+FUNCTION: int utime ( char* path, utimbuf* buf ) ;
: touch ( filename -- ) f [ utime ] unix-system-call drop ;
: change-file-times ( filename access modification -- )
- "utimebuf" <c-object>
- [ set-utimbuf-modtime ] keep
- [ set-utimbuf-actime ] keep
- [ utime ] unix-system-call drop ;
+ utimbuf <struct>
+ swap >>modtime
+ swap >>actime
+ [ utime ] unix-system-call drop ;
FUNCTION: int pclose ( void* file ) ;
FUNCTION: int pipe ( int* filedes ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators accessors kernel unix unix.users
+USING: combinators accessors kernel unix.users
system ;
IN: unix.users.bsd
+QUALIFIED: unix
TUPLE: bsd-passwd < passwd change class expire fields ;
M: bsd passwd>new-passwd ( passwd -- bsd-passwd )
[ call-next-method ] keep
{
- [ passwd-pw_change >>change ]
- [ passwd-pw_class >>class ]
- [ passwd-pw_shell >>shell ]
- [ passwd-pw_expire >>expire ]
- [ passwd-pw_fields >>fields ]
+ [ pw_change>> >>change ]
+ [ pw_class>> >>class ]
+ [ pw_shell>> >>shell ]
+ [ pw_expire>> >>expire ]
+ [ pw_fields>> >>fields ]
} cleave ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings io.encodings.utf8
-io.backend.unix kernel math sequences splitting unix strings
+io.backend.unix kernel math sequences splitting strings
combinators.short-circuit grouping byte-arrays combinators
accessors math.parser fry assocs namespaces continuations
-vocabs.loader system ;
+vocabs.loader system classes.struct ;
IN: unix.users
+QUALIFIED: unix
TUPLE: passwd user-name password uid gid gecos dir shell ;
M: unix passwd>new-passwd ( passwd -- seq )
[ new-passwd ] dip
{
- [ passwd-pw_name >>user-name ]
- [ passwd-pw_passwd >>password ]
- [ passwd-pw_uid >>uid ]
- [ passwd-pw_gid >>gid ]
- [ passwd-pw_gecos >>gecos ]
- [ passwd-pw_dir >>dir ]
- [ passwd-pw_shell >>shell ]
+ [ pw_name>> >>user-name ]
+ [ pw_passwd>> >>password ]
+ [ pw_uid>> >>uid ]
+ [ pw_gid>> >>gid ]
+ [ pw_gecos>> >>gecos ]
+ [ pw_dir>> >>dir ]
+ [ pw_shell>> >>shell ]
} cleave ;
: with-pwent ( quot -- )
- [ endpwent ] [ ] cleanup ; inline
+ [ unix:endpwent ] [ ] cleanup ; inline
PRIVATE>
: all-users ( -- seq )
[
- [ getpwent dup ] [ passwd>new-passwd ] produce nip
+ [ unix:getpwent dup ] [ unix:passwd memory>struct passwd>new-passwd ] produce nip
] with-pwent ;
SYMBOL: user-cache
M: integer user-passwd ( id -- passwd/f )
user-cache get
- [ at ] [ getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ;
+ [ at ] [ unix:getpwuid [ unix:passwd memory>struct passwd>new-passwd ] [ f ] if* ] if* ;
M: string user-passwd ( string -- passwd/f )
- getpwnam dup [ passwd>new-passwd ] when ;
+ unix:getpwnam dup [ unix:passwd memory>struct passwd>new-passwd ] when ;
: user-name ( id -- string )
dup user-passwd
user-passwd uid>> ;
: real-user-id ( -- id )
- getuid ; inline
+ unix:getuid ; inline
: real-user-name ( -- string )
real-user-id user-name ; inline
: effective-user-id ( -- id )
- geteuid ; inline
+ unix:geteuid ; inline
: effective-user-name ( -- string )
effective-user-id user-name ; inline
<PRIVATE
: (set-real-user) ( id -- )
- setuid io-error ; inline
+ unix:setuid unix:io-error ; inline
: (set-effective-user) ( id -- )
- seteuid io-error ; inline
+ unix:seteuid unix:io-error ; inline
PRIVATE>
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings
-combinators.short-circuit fry kernel layouts sequences
-specialized-arrays.alien accessors ;
+combinators.short-circuit fry kernel layouts sequences accessors
+specialized-arrays ;
IN: unix.utilities
+SPECIALIZED-ARRAY: void*
+
: more? ( alien -- ? )
{ [ ] [ *void* ] } 1&& ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sorting sequences vocabs io io.styles arrays assocs
-namespaces sets parser colors prettyprint.backend prettyprint.sections
-vocabs.parser make fry math.order ;
+USING: accessors arrays assocs colors colors.constants fry io
+io.styles kernel make math.order namespaces parser
+prettyprint.backend prettyprint.sections prettyprint.stylesheet
+sequences sets sorting vocabs vocabs.parser ;
+FROM: io.styles => inset ;
IN: vocabs.prettyprint
: pprint-vocab ( vocab -- )
- [ vocab-name ] [ vocab ] bi present-text ;
+ [ vocab-name ] [ vocab vocab-style ] bi styled-text ;
: pprint-in ( vocab -- )
[ \ IN: pprint-word pprint-vocab ] with-pprint ;
"To avoid doing this in the future, add the following forms" print
"at the top of the source file:" print nl
] with-style
- { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } }
- [ manifest get pprint-manifest ] with-nesting
+ {
+ { page-color COLOR: FactorLightTan }
+ { border-color COLOR: FactorDarkTan }
+ { inset { 5 5 } }
+ } [ manifest get pprint-manifest ] with-nesting
nl nl
] print-use-hook set-global
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: windows.com windows.kernel32 windows.ole32
+prettyprint.custom prettyprint.sections sequences ;
+IN: windows.com.prettyprint
+
+M: GUID pprint* guid>string "GUID: " prepend text ;
--- /dev/null
+unportable
USING: alien alien.c-types alien.accessors effects kernel
windows.ole32 parser lexer splitting grouping sequences
namespaces assocs quotations generalizations accessors words
-macros alien.syntax fry arrays layouts math ;
+macros alien.syntax fry arrays layouts math classes.struct
+windows.kernel32 ;
IN: windows.com.syntax
<PRIVATE
-C-STRUCT: com-interface
- { "void*" "vtbl" } ;
-
MACRO: com-invoke ( n return parameters -- )
[ 2nip length ] 3keep
'[
- _ npick com-interface-vtbl _ cell * alien-cell _ _
+ _ npick *void* _ cell * alien-cell _ _
"stdcall" alien-indirect
] ;
dup "f" = [ drop f ] [
dup +com-interface-definitions+ get-global at*
[ nip ]
- [ swap " COM interface hasn't been defined" append throw ]
+ [ " COM interface hasn't been defined" prepend throw ]
if
] if ;
define-words-for-com-interface ;
SYNTAX: GUID: scan string>guid parsed ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [
+ "windows.com.prettyprint" require
+] when
namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units
destructors fry math.parser generalizations sets
-specialized-arrays.alien specialized-arrays.direct.alien ;
+specialized-arrays windows.kernel32 classes.struct ;
+SPECIALIZED-ARRAY: void*
IN: windows.com.wrapper
TUPLE: com-wrapper < disposable callbacks vtbls ;
: (make-query-interface) ( interfaces -- quot )
(query-interface-cases)
'[
- swap 16 memory>byte-array
+ swap GUID memory>struct
_ case
[
"void*" heap-size * rot <displaced-alien> com-add-ref
windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
combinators sequences fry math accessors macros words quotations
libc continuations generalizations splitting locals assocs init
-struct-arrays memoize ;
+specialized-arrays memoize classes.struct ;
+SPECIALIZED-ARRAY: DIOBJECTDATAFORMAT
IN: windows.dinput.constants
! Some global variables aren't provided by the DirectInput DLL (they're in the
: (flags) ( array -- n )
0 [ (flag) bitor ] reduce ;
-: (DIOBJECTDATAFORMAT) ( pguid dwOfs dwType dwFlags alien -- alien )
- [ {
- [ set-DIOBJECTDATAFORMAT-dwFlags ]
- [ set-DIOBJECTDATAFORMAT-dwType ]
- [ set-DIOBJECTDATAFORMAT-dwOfs ]
- [ set-DIOBJECTDATAFORMAT-pguid ]
- } cleave ] keep ;
-
: <DIOBJECTDATAFORMAT> ( struct {pguid-var,field,index,dwType-flags,dwFlags} -- alien )
{
[ first dup word? [ get ] when ]
[ fourth (flags) ]
[ 4 swap nth (flag) ]
} cleave
- "DIOBJECTDATAFORMAT" <c-object> (DIOBJECTDATAFORMAT) ;
+ DIOBJECTDATAFORMAT <struct-boa> ;
-:: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien )
- [let | alien [ array length "DIOBJECTDATAFORMAT" malloc-struct-array ] |
+:: make-DIOBJECTDATAFORMAT-array ( struct array -- alien )
+ [let | alien [ array length malloc-DIOBJECTDATAFORMAT-array ] |
array [| args i |
struct args <DIOBJECTDATAFORMAT>
i alien set-nth
alien
] ;
-: (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien )
- [
- {
- [ set-DIDATAFORMAT-rgodf ]
- [ set-DIDATAFORMAT-dwNumObjs ]
- [ set-DIDATAFORMAT-dwDataSize ]
- [ set-DIDATAFORMAT-dwFlags ]
- [ set-DIDATAFORMAT-dwObjSize ]
- [ set-DIDATAFORMAT-dwSize ]
- } cleave
- ] keep ;
-
: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
- [ "DIDATAFORMAT" heap-size "DIOBJECTDATAFORMAT" heap-size ] 4 ndip
- [ nip length ] [ malloc-DIOBJECTDATAFORMAT-array ] 2bi
- "DIDATAFORMAT" <c-object> (DIDATAFORMAT) ;
+ [ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
+ [ nip length ] [ make-DIOBJECTDATAFORMAT-array ] 2bi
+ DIDATAFORMAT <struct-boa> ;
: initialize ( symbol quot -- )
call swap set-global ; inline
{
c_dfDIKeyboard c_dfDIKeyboard_HID c_dfDIMouse2 c_dfDIJoystick2
- } [ [ DIDATAFORMAT-rgodf free ] uninitialize ] each ;
+ } [ [ rgodf>> free ] uninitialize ] each ;
PRIVATE>
USING: windows.kernel32 windows.ole32 windows.com windows.com.syntax
-alien alien.c-types alien.syntax kernel system namespaces math ;
+alien alien.c-types alien.syntax kernel system namespaces math
+classes.struct ;
IN: windows.dinput
LIBRARY: dinput
TYPEDEF: DWORD D3DCOLOR
-C-STRUCT: DIDEVICEINSTANCEW
- { "DWORD" "dwSize" }
- { "GUID" "guidInstance" }
- { "GUID" "guidProduct" }
- { "DWORD" "dwDevType" }
- { "WCHAR[260]" "tszInstanceName" }
- { "WCHAR[260]" "tszProductName" }
- { "GUID" "guidFFDriver" }
- { "WORD" "wUsagePage" }
- { "WORD" "wUsage" } ;
+STRUCT: DIDEVICEINSTANCEW
+ { dwSize DWORD }
+ { guidInstance GUID }
+ { guidProduct GUID }
+ { dwDevType DWORD }
+ { tszInstanceName WCHAR[260] }
+ { tszProductName WCHAR[260] }
+ { guidFFDriver GUID }
+ { wUsagePage WORD }
+ { wUsage WORD } ;
TYPEDEF: DIDEVICEINSTANCEW* LPDIDEVICEINSTANCEW
TYPEDEF: DIDEVICEINSTANCEW* LPCDIDEVICEINSTANCEW
-C-UNION: DIACTION-union "LPCWSTR" "UINT" ;
-C-STRUCT: DIACTIONW
- { "UINT_PTR" "uAppData" }
- { "DWORD" "dwSemantic" }
- { "DWORD" "dwFlags" }
- { "DIACTION-union" "lptszActionName-or-uResIdString" }
- { "GUID" "guidInstance" }
- { "DWORD" "dwObjID" }
- { "DWORD" "dwHow" } ;
+UNION-STRUCT: DIACTION-union
+ { lptszActionName LPCWSTR }
+ { uResIdString UINT } ;
+STRUCT: DIACTIONW
+ { uAppData UINT_PTR }
+ { dwSemantic DWORD }
+ { dwFlags DWORD }
+ { union DIACTION-union }
+ { guidInstance GUID }
+ { dwObjID DWORD }
+ { dwHow DWORD } ;
TYPEDEF: DIACTIONW* LPDIACTIONW
TYPEDEF: DIACTIONW* LPCDIACTIONW
-C-STRUCT: DIACTIONFORMATW
- { "DWORD" "dwSize" }
- { "DWORD" "dwActionSize" }
- { "DWORD" "dwDataSize" }
- { "DWORD" "dwNumActions" }
- { "LPDIACTIONW" "rgoAction" }
- { "GUID" "guidActionMap" }
- { "DWORD" "dwGenre" }
- { "DWORD" "dwBufferSize" }
- { "LONG" "lAxisMin" }
- { "LONG" "lAxisMax" }
- { "HINSTANCE" "hInstString" }
- { "FILETIME" "ftTimeStamp" }
- { "DWORD" "dwCRC" }
- { "WCHAR[260]" "tszActionMap" } ;
+STRUCT: DIACTIONFORMATW
+ { dwSize DWORD }
+ { dwActionSize DWORD }
+ { dwDataSize DWORD }
+ { dwNumActions DWORD }
+ { rgoAction LPDIACTIONW }
+ { guidActionMap GUID }
+ { dwGenre DWORD }
+ { dwBufferSize DWORD }
+ { lAxisMin LONG }
+ { lAxisMax LONG }
+ { hInstString HINSTANCE }
+ { ftTimeStamp FILETIME }
+ { dwCRC DWORD }
+ { tszActionMap WCHAR[260] } ;
TYPEDEF: DIACTIONFORMATW* LPDIACTIONFORMATW
TYPEDEF: DIACTIONFORMATW* LPCDIACTIONFORMATW
-C-STRUCT: DICOLORSET
- { "DWORD" "dwSize" }
- { "D3DCOLOR" "cTextFore" }
- { "D3DCOLOR" "cTextHighlight" }
- { "D3DCOLOR" "cCalloutLine" }
- { "D3DCOLOR" "cCalloutHighlight" }
- { "D3DCOLOR" "cBorder" }
- { "D3DCOLOR" "cControlFill" }
- { "D3DCOLOR" "cHighlightFill" }
- { "D3DCOLOR" "cAreaFill" } ;
+STRUCT: DICOLORSET
+ { dwSize DWORD }
+ { cTextFore D3DCOLOR }
+ { cTextHighlight D3DCOLOR }
+ { cCalloutLine D3DCOLOR }
+ { cCalloutHighlight D3DCOLOR }
+ { cBorder D3DCOLOR }
+ { cControlFill D3DCOLOR }
+ { cHighlightFill D3DCOLOR }
+ { cAreaFill D3DCOLOR } ;
TYPEDEF: DICOLORSET* LPDICOLORSET
TYPEDEF: DICOLORSET* LPCDICOLORSET
-C-STRUCT: DICONFIGUREDEVICESPARAMSW
- { "DWORD" "dwSize" }
- { "DWORD" "dwcUsers" }
- { "LPWSTR" "lptszUserNames" }
- { "DWORD" "dwcFormats" }
- { "LPDIACTIONFORMATW" "lprgFormats" }
- { "HWND" "hwnd" }
- { "DICOLORSET" "dics" }
- { "IUnknown*" "lpUnkDDSTarget" } ;
+STRUCT: DICONFIGUREDEVICESPARAMSW
+ { dwSize DWORD }
+ { dwcUsers DWORD }
+ { lptszUserNames LPWSTR }
+ { dwcFormats DWORD }
+ { lprgFormats LPDIACTIONFORMATW }
+ { hwnd HWND }
+ { dics DICOLORSET }
+ { lpUnkDDSTarget IUnknown* } ;
TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
-C-STRUCT: DIDEVCAPS
- { "DWORD" "dwSize" }
- { "DWORD" "dwFlags" }
- { "DWORD" "dwDevType" }
- { "DWORD" "dwAxes" }
- { "DWORD" "dwButtons" }
- { "DWORD" "dwPOVs" }
- { "DWORD" "dwFFSamplePeriod" }
- { "DWORD" "dwFFMinTimeResolution" }
- { "DWORD" "dwFirmwareRevision" }
- { "DWORD" "dwHardwareRevision" }
- { "DWORD" "dwFFDriverVersion" } ;
+STRUCT: DIDEVCAPS
+ { dwSize DWORD }
+ { dwFlags DWORD }
+ { dwDevType DWORD }
+ { dwAxes DWORD }
+ { dwButtons DWORD }
+ { dwPOVs DWORD }
+ { dwFFSamplePeriod DWORD }
+ { dwFFMinTimeResolution DWORD }
+ { dwFirmwareRevision DWORD }
+ { dwHardwareRevision DWORD }
+ { dwFFDriverVersion DWORD } ;
TYPEDEF: DIDEVCAPS* LPDIDEVCAPS
TYPEDEF: DIDEVCAPS* LPCDIDEVCAPS
-C-STRUCT: DIDEVICEOBJECTINSTANCEW
- { "DWORD" "dwSize" }
- { "GUID" "guidType" }
- { "DWORD" "dwOfs" }
- { "DWORD" "dwType" }
- { "DWORD" "dwFlags" }
- { "WCHAR[260]" "tszName" }
- { "DWORD" "dwFFMaxForce" }
- { "DWORD" "dwFFForceResolution" }
- { "WORD" "wCollectionNumber" }
- { "WORD" "wDesignatorIndex" }
- { "WORD" "wUsagePage" }
- { "WORD" "wUsage" }
- { "DWORD" "dwDimension" }
- { "WORD" "wExponent" }
- { "WORD" "wReportId" } ;
+STRUCT: DIDEVICEOBJECTINSTANCEW
+ { dwSize DWORD }
+ { guidType GUID }
+ { dwOfs DWORD }
+ { dwType DWORD }
+ { dwFlags DWORD }
+ { tszName WCHAR[260] }
+ { dwFFMaxForce DWORD }
+ { dwFFForceResolution DWORD }
+ { wCollectionNumber WORD }
+ { wDesignatorIndex WORD }
+ { wUsagePage WORD }
+ { wUsage WORD }
+ { dwDimension DWORD }
+ { wExponent WORD }
+ { wReportId WORD } ;
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPDIDEVICEOBJECTINSTANCEW
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPCDIDEVICEOBJECTINSTANCEW
-C-STRUCT: DIDEVICEOBJECTDATA
- { "DWORD" "dwOfs" }
- { "DWORD" "dwData" }
- { "DWORD" "dwTimeStamp" }
- { "DWORD" "dwSequence" }
- { "UINT_PTR" "uAppData" } ;
+STRUCT: DIDEVICEOBJECTDATA
+ { dwOfs DWORD }
+ { dwData DWORD }
+ { dwTimeStamp DWORD }
+ { dwSequence DWORD }
+ { uAppData UINT_PTR } ;
TYPEDEF: DIDEVICEOBJECTDATA* LPDIDEVICEOBJECTDATA
TYPEDEF: DIDEVICEOBJECTDATA* LPCDIDEVICEOBJECTDATA
-C-STRUCT: DIOBJECTDATAFORMAT
- { "GUID*" "pguid" }
- { "DWORD" "dwOfs" }
- { "DWORD" "dwType" }
- { "DWORD" "dwFlags" } ;
+STRUCT: DIOBJECTDATAFORMAT
+ { pguid GUID* }
+ { dwOfs DWORD }
+ { dwType DWORD }
+ { dwFlags DWORD } ;
TYPEDEF: DIOBJECTDATAFORMAT* LPDIOBJECTDATAFORMAT
TYPEDEF: DIOBJECTDATAFORMAT* LPCDIOBJECTDATAFORMAT
-C-STRUCT: DIDATAFORMAT
- { "DWORD" "dwSize" }
- { "DWORD" "dwObjSize" }
- { "DWORD" "dwFlags" }
- { "DWORD" "dwDataSize" }
- { "DWORD" "dwNumObjs" }
- { "LPDIOBJECTDATAFORMAT" "rgodf" } ;
+STRUCT: DIDATAFORMAT
+ { dwSize DWORD }
+ { dwObjSize DWORD }
+ { dwFlags DWORD }
+ { dwDataSize DWORD }
+ { dwNumObjs DWORD }
+ { rgodf LPDIOBJECTDATAFORMAT } ;
TYPEDEF: DIDATAFORMAT* LPDIDATAFORMAT
TYPEDEF: DIDATAFORMAT* LPCDIDATAFORMAT
-C-STRUCT: DIPROPHEADER
- { "DWORD" "dwSize" }
- { "DWORD" "dwHeaderSize" }
- { "DWORD" "dwObj" }
- { "DWORD" "dwHow" } ;
+STRUCT: DIPROPHEADER
+ { dwSize DWORD }
+ { dwHeaderSize DWORD }
+ { dwObj DWORD }
+ { dwHow DWORD } ;
TYPEDEF: DIPROPHEADER* LPDIPROPHEADER
TYPEDEF: DIPROPHEADER* LPCDIPROPHEADER
-C-STRUCT: DIPROPDWORD
- { "DIPROPHEADER" "diph" }
- { "DWORD" "dwData" } ;
+STRUCT: DIPROPDWORD
+ { diph DIPROPHEADER }
+ { dwData DWORD } ;
TYPEDEF: DIPROPDWORD* LPDIPROPDWORD
TYPEDEF: DIPROPDWORD* LPCDIPROPDWORD
-C-STRUCT: DIPROPPOINTER
- { "DIPROPHEADER" "diph" }
- { "UINT_PTR" "uData" } ;
+STRUCT: DIPROPPOINTER
+ { diph DIPROPHEADER }
+ { uData UINT_PTR } ;
TYPEDEF: DIPROPPOINTER* LPDIPROPPOINTER
TYPEDEF: DIPROPPOINTER* LPCDIPROPPOINTER
-C-STRUCT: DIPROPRANGE
- { "DIPROPHEADER" "diph" }
- { "LONG" "lMin" }
- { "LONG" "lMax" } ;
+STRUCT: DIPROPRANGE
+ { diph DIPROPHEADER }
+ { lMin LONG }
+ { lMax LONG } ;
TYPEDEF: DIPROPRANGE* LPDIPROPRANGE
TYPEDEF: DIPROPRANGE* LPCDIPROPRANGE
-C-STRUCT: DIPROPCAL
- { "DIPROPHEADER" "diph" }
- { "LONG" "lMin" }
- { "LONG" "lCenter" }
- { "LONG" "lMax" } ;
+STRUCT: DIPROPCAL
+ { diph DIPROPHEADER }
+ { lMin LONG }
+ { lCenter LONG }
+ { lMax LONG } ;
TYPEDEF: DIPROPCAL* LPDIPROPCAL
TYPEDEF: DIPROPCAL* LPCDIPROPCAL
-C-STRUCT: DIPROPGUIDANDPATH
- { "DIPROPHEADER" "diph" }
- { "GUID" "guidClass" }
- { "WCHAR[260]" "wszPath" } ;
+STRUCT: DIPROPGUIDANDPATH
+ { diph DIPROPHEADER }
+ { guidClass GUID }
+ { wszPath WCHAR[260] } ;
TYPEDEF: DIPROPGUIDANDPATH* LPDIPROPGUIDANDPATH
TYPEDEF: DIPROPGUIDANDPATH* LPCDIPROPGUIDANDPATH
-C-STRUCT: DIPROPSTRING
- { "DIPROPHEADER" "diph" }
- { "WCHAR[260]" "wsz" } ;
+STRUCT: DIPROPSTRING
+ { diph DIPROPHEADER }
+ { wsz WCHAR[260] } ;
TYPEDEF: DIPROPSTRING* LPDIPROPSTRING
TYPEDEF: DIPROPSTRING* LPCDIPROPSTRING
-C-STRUCT: CPOINT
- { "LONG" "lP" }
- { "DWORD" "dwLog" } ;
-C-STRUCT: DIPROPCPOINTS
- { "DIPROPHEADER" "diph" }
- { "DWORD" "dwCPointsNum" }
- { "CPOINT[8]" "cp" } ;
+STRUCT: CPOINT
+ { lP LONG }
+ { dwLog DWORD } ;
+STRUCT: DIPROPCPOINTS
+ { diph DIPROPHEADER }
+ { dwCPointsNum DWORD }
+ { cp CPOINT[8] } ;
TYPEDEF: DIPROPCPOINTS* LPDIPROPCPOINTS
TYPEDEF: DIPROPCPOINTS* LPCDIPROPCPOINTS
-C-STRUCT: DIENVELOPE
- { "DWORD" "dwSize" }
- { "DWORD" "dwAttackLevel" }
- { "DWORD" "dwAttackTime" }
- { "DWORD" "dwFadeLevel" }
- { "DWORD" "dwFadeTime" } ;
+STRUCT: DIENVELOPE
+ { dwSize DWORD }
+ { dwAttackLevel DWORD }
+ { dwAttackTime DWORD }
+ { dwFadeLevel DWORD }
+ { dwFadeTime DWORD } ;
TYPEDEF: DIENVELOPE* LPDIENVELOPE
TYPEDEF: DIENVELOPE* LPCDIENVELOPE
-C-STRUCT: DIEFFECT
- { "DWORD" "dwSize" }
- { "DWORD" "dwFlags" }
- { "DWORD" "dwDuration" }
- { "DWORD" "dwSamplePeriod" }
- { "DWORD" "dwGain" }
- { "DWORD" "dwTriggerButton" }
- { "DWORD" "dwTriggerRepeatInterval" }
- { "DWORD" "cAxes" }
- { "LPDWORD" "rgdwAxes" }
- { "LPLONG" "rglDirection" }
- { "LPDIENVELOPE" "lpEnvelope" }
- { "DWORD" "cbTypeSpecificParams" }
- { "LPVOID" "lpvTypeSpecificParams" }
- { "DWORD" "dwStartDelay" } ;
+STRUCT: DIEFFECT
+ { dwSize DWORD }
+ { dwFlags DWORD }
+ { dwDuration DWORD }
+ { dwSamplePeriod DWORD }
+ { dwGain DWORD }
+ { dwTriggerButton DWORD }
+ { dwTriggerRepeatInterval DWORD }
+ { cAxes DWORD }
+ { rgdwAxes LPDWORD }
+ { rglDirection LPLONG }
+ { lpEnvelope LPDIENVELOPE }
+ { cbTypeSpecificParams DWORD }
+ { lpvTypeSpecificParams LPVOID }
+ { dwStartDelay DWORD } ;
TYPEDEF: DIEFFECT* LPDIEFFECT
TYPEDEF: DIEFFECT* LPCDIEFFECT
-C-STRUCT: DIEFFECTINFOW
- { "DWORD" "dwSize" }
- { "GUID" "guid" }
- { "DWORD" "dwEffType" }
- { "DWORD" "dwStaticParams" }
- { "DWORD" "dwDynamicParams" }
- { "WCHAR[260]" "tszName" } ;
+STRUCT: DIEFFECTINFOW
+ { dwSize DWORD }
+ { guid GUID }
+ { dwEffType DWORD }
+ { dwStaticParams DWORD }
+ { dwDynamicParams DWORD }
+ { tszName WCHAR[260] } ;
TYPEDEF: DIEFFECTINFOW* LPDIEFFECTINFOW
TYPEDEF: DIEFFECTINFOW* LPCDIEFFECTINFOW
-C-STRUCT: DIEFFESCAPE
- { "DWORD" "dwSize" }
- { "DWORD" "dwCommand" }
- { "LPVOID" "lpvInBuffer" }
- { "DWORD" "cbInBuffer" }
- { "LPVOID" "lpvOutBuffer" }
- { "DWORD" "cbOutBuffer" } ;
+STRUCT: DIEFFESCAPE
+ { dwSize DWORD }
+ { dwCommand DWORD }
+ { lpvInBuffer LPVOID }
+ { cbInBuffer DWORD }
+ { lpvOutBuffer LPVOID }
+ { cbOutBuffer DWORD } ;
TYPEDEF: DIEFFESCAPE* LPDIEFFESCAPE
TYPEDEF: DIEFFESCAPE* LPCDIEFFESCAPE
-C-STRUCT: DIFILEEFFECT
- { "DWORD" "dwSize" }
- { "GUID" "GuidEffect" }
- { "LPCDIEFFECT" "lpDiEffect" }
- { "CHAR[260]" "szFriendlyName" } ;
+STRUCT: DIFILEEFFECT
+ { dwSize DWORD }
+ { GuidEffect GUID }
+ { lpDiEffect LPCDIEFFECT }
+ { szFriendlyName CHAR[260] } ;
TYPEDEF: DIFILEEFFECT* LPDIFILEEFFECT
TYPEDEF: DIFILEEFFECT* LPCDIFILEEFFECT
-C-STRUCT: DIDEVICEIMAGEINFOW
- { "WCHAR[260]" "tszImagePath" }
- { "DWORD" "dwFlags" }
- { "DWORD" "dwViewID" }
- { "RECT" "rcOverlay" }
- { "DWORD" "dwObjID" }
- { "DWORD" "dwcValidPts" }
- { "POINT[5]" "rgptCalloutLine" }
- { "RECT" "rcCalloutRect" }
- { "DWORD" "dwTextAlign" } ;
+STRUCT: DIDEVICEIMAGEINFOW
+ { tszImagePath WCHAR[260] }
+ { dwFlags DWORD }
+ { dwViewID DWORD }
+ { rcOverlay RECT }
+ { dwObjID DWORD }
+ { dwcValidPts DWORD }
+ { rgptCalloutLine POINT[5] }
+ { rcCalloutRect RECT }
+ { dwTextAlign DWORD } ;
TYPEDEF: DIDEVICEIMAGEINFOW* LPDIDEVICEIMAGEINFOW
TYPEDEF: DIDEVICEIMAGEINFOW* LPCDIDEVICEIMAGEINFOW
-C-STRUCT: DIDEVICEIMAGEINFOHEADERW
- { "DWORD" "dwSize" }
- { "DWORD" "dwSizeImageInfo" }
- { "DWORD" "dwcViews" }
- { "DWORD" "dwcButtons" }
- { "DWORD" "dwcAxes" }
- { "DWORD" "dwcPOVs" }
- { "DWORD" "dwBufferSize" }
- { "DWORD" "dwBufferUsed" }
- { "DIDEVICEIMAGEINFOW*" "lprgImageInfoArray" } ;
+STRUCT: DIDEVICEIMAGEINFOHEADERW
+ { dwSize DWORD }
+ { dwSizeImageInfo DWORD }
+ { dwcViews DWORD }
+ { dwcButtons DWORD }
+ { dwcAxes DWORD }
+ { dwcPOVs DWORD }
+ { dwBufferSize DWORD }
+ { dwBufferUsed DWORD }
+ { lprgImageInfoArray DIDEVICEIMAGEINFOW* } ;
TYPEDEF: DIDEVICEIMAGEINFOHEADERW* LPDIDEVICEIMAGEINFOHEADERW
TYPEDEF: DIDEVICEIMAGEINFOHEADERW* LPCDIDEVICEIMAGEINFOHEADERW
-C-STRUCT: DIMOUSESTATE2
- { "LONG" "lX" }
- { "LONG" "lY" }
- { "LONG" "lZ" }
- { "BYTE[8]" "rgbButtons" } ;
+STRUCT: DIMOUSESTATE2
+ { lX LONG }
+ { lY LONG }
+ { lZ LONG }
+ { rgbButtons BYTE[8] } ;
TYPEDEF: DIMOUSESTATE2* LPDIMOUSESTATE2
TYPEDEF: DIMOUSESTATE2* LPCDIMOUSESTATE2
-C-STRUCT: DIJOYSTATE2
- { "LONG" "lX" }
- { "LONG" "lY" }
- { "LONG" "lZ" }
- { "LONG" "lRx" }
- { "LONG" "lRy" }
- { "LONG" "lRz" }
- { "LONG[2]" "rglSlider" }
- { "DWORD[4]" "rgdwPOV" }
- { "BYTE[128]" "rgbButtons" }
- { "LONG" "lVX" }
- { "LONG" "lVY" }
- { "LONG" "lVZ" }
- { "LONG" "lVRx" }
- { "LONG" "lVRy" }
- { "LONG" "lVRz" }
- { "LONG[2]" "rglVSlider" }
- { "LONG" "lAX" }
- { "LONG" "lAY" }
- { "LONG" "lAZ" }
- { "LONG" "lARx" }
- { "LONG" "lARy" }
- { "LONG" "lARz" }
- { "LONG[2]" "rglASlider" }
- { "LONG" "lFX" }
- { "LONG" "lFY" }
- { "LONG" "lFZ" }
- { "LONG" "lFRx" }
- { "LONG" "lFRy" }
- { "LONG" "lFRz" }
- { "LONG[2]" "rglFSlider" } ;
+STRUCT: DIJOYSTATE2
+ { lX LONG }
+ { lY LONG }
+ { lZ LONG }
+ { lRx LONG }
+ { lRy LONG }
+ { lRz LONG }
+ { rglSlider LONG[2] }
+ { rgdwPOV DWORD[4] }
+ { rgbButtons BYTE[128] }
+ { lVX LONG }
+ { lVY LONG }
+ { lVZ LONG }
+ { lVRx LONG }
+ { lVRy LONG }
+ { lVRz LONG }
+ { rglVSlider LONG[2] }
+ { lAX LONG }
+ { lAY LONG }
+ { lAZ LONG }
+ { lARx LONG }
+ { lARy LONG }
+ { lARz LONG }
+ { rglASlider LONG[2] }
+ { lFX LONG }
+ { lFY LONG }
+ { lFZ LONG }
+ { lFRx LONG }
+ { lFRy LONG }
+ { lFRz LONG }
+ { rglFSlider LONG[2] } ;
TYPEDEF: DIJOYSTATE2* LPDIJOYSTATE2
TYPEDEF: DIJOYSTATE2* LPCDIJOYSTATE2
-USING: windows.com windows.com.wrapper combinators\r
-windows.kernel32 windows.ole32 windows.shell32 kernel accessors\r
+USING: alien.strings io.encodings.utf16n windows.com\r
+windows.com.wrapper combinators windows.kernel32 windows.ole32\r
+windows.shell32 kernel accessors\r
prettyprint namespaces ui.tools.listener ui.tools.workspace\r
alien.c-types alien sequences math ;\r
IN: windows.dragdrop-listener\r
\r
+<< "WCHAR" require-c-array >>\r
+\r
: filenames-from-hdrop ( hdrop -- filenames )\r
dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files\r
[\r
2dup f 0 DragQueryFile 1 + ! get size of filename buffer\r
dup "WCHAR" <c-array>\r
[ swap DragQueryFile drop ] keep\r
- alien>u16-string\r
+ utf16n alien>string\r
] with map ;\r
\r
: filenames-from-data-object ( data-object -- filenames )\r
arrays literals ;
IN: windows.errors
+<< "TCHAR" require-c-array >>
+
CONSTANT: ERROR_SUCCESS 0
CONSTANT: ERROR_INVALID_FUNCTION 1
CONSTANT: ERROR_FILE_NOT_FOUND 2
: make-lang-id ( lang1 lang2 -- n )
10 shift bitor ; inline
+<< "TCHAR" require-c-array >>
+
ERROR: error-message-failed id ;
:: n>win32-error-string ( id -- string )
{
f
id
LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id
- 32768 [ "TCHAR" <c-array> ] keep
+ 32768 [ "TCHAR" <c-array> ] [ ] bi
f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip
utf16n alien>string [ blank? ] trim ;
-USING: assocs memoize locals kernel accessors init fonts math\r
-combinators windows.errors windows.types windows.gdi32 ;\r
-IN: windows.fonts\r
-\r
-: windows-font-name ( string -- string' )\r
- H{\r
- { "sans-serif" "Tahoma" }\r
- { "serif" "Times New Roman" }\r
- { "monospace" "Courier New" }\r
- } ?at drop ;\r
- \r
-MEMO:: (cache-font) ( font -- HFONT )\r
- font size>> neg ! nHeight\r
- 0 0 0 ! nWidth, nEscapement, nOrientation\r
- font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight\r
- font italic?>> TRUE FALSE ? ! fdwItalic\r
- FALSE ! fdwUnderline\r
- FALSE ! fdWStrikeOut\r
- DEFAULT_CHARSET ! fdwCharSet\r
- OUT_OUTLINE_PRECIS ! fdwOutputPrecision\r
- CLIP_DEFAULT_PRECIS ! fdwClipPrecision\r
- DEFAULT_QUALITY ! fdwQuality\r
- DEFAULT_PITCH ! fdwPitchAndFamily\r
- font name>> windows-font-name\r
- CreateFont\r
- dup win32-error=0/f ;\r
-\r
-: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;\r
-\r
-[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook\r
-\r
-: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )\r
- [ metrics new 0 >>width ] dip {\r
- [ TEXTMETRICW-tmHeight >>height ]\r
- [ TEXTMETRICW-tmAscent >>ascent ]\r
- [ TEXTMETRICW-tmDescent >>descent ]\r
- } cleave ;\r
+USING: assocs memoize locals kernel accessors init fonts math
+combinators windows.errors windows.types windows.gdi32 ;
+IN: windows.fonts
+
+: windows-font-name ( string -- string' )
+ H{
+ { "sans-serif" "Tahoma" }
+ { "serif" "Times New Roman" }
+ { "monospace" "Courier New" }
+ } ?at drop ;
+
+MEMO:: (cache-font) ( font -- HFONT )
+ font size>> neg ! nHeight
+ 0 0 0 ! nWidth, nEscapement, nOrientation
+ font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight
+ font italic?>> TRUE FALSE ? ! fdwItalic
+ FALSE ! fdwUnderline
+ FALSE ! fdWStrikeOut
+ DEFAULT_CHARSET ! fdwCharSet
+ OUT_OUTLINE_PRECIS ! fdwOutputPrecision
+ CLIP_DEFAULT_PRECIS ! fdwClipPrecision
+ DEFAULT_QUALITY ! fdwQuality
+ DEFAULT_PITCH ! fdwPitchAndFamily
+ font name>> windows-font-name
+ CreateFont
+ dup win32-error=0/f ;
+
+: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;
+
+[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook
+
+: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
+ [ metrics new 0 >>width ] dip {
+ [ tmHeight>> >>height ]
+ [ tmAscent>> >>ascent ]
+ [ tmDescent>> >>descent ]
+ } cleave ;
! 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
CONSTANT: FILE_ACTION_RENAMED_OLD_NAME 4
CONSTANT: FILE_ACTION_RENAMED_NEW_NAME 5
-C-STRUCT: FILE_NOTIFY_INFORMATION
- { "DWORD" "NextEntryOffset" }
- { "DWORD" "Action" }
- { "DWORD" "FileNameLength" }
- { "WCHAR[1]" "FileName" } ;
+STRUCT: FILE_NOTIFY_INFORMATION
+ { NextEntryOffset DWORD }
+ { Action DWORD }
+ { FileNameLength DWORD }
+ { FileName WCHAR[1] } ;
+
TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION
CONSTANT: STD_INPUT_HANDLE -10
TYPEDEF: uint COMPUTER_NAME_FORMAT
-C-STRUCT: OVERLAPPED
- { "UINT_PTR" "internal" }
- { "UINT_PTR" "internal-high" }
- { "DWORD" "offset" }
- { "DWORD" "offset-high" }
- { "HANDLE" "event" } ;
-
-C-STRUCT: SYSTEMTIME
- { "WORD" "wYear" }
- { "WORD" "wMonth" }
- { "WORD" "wDayOfWeek" }
- { "WORD" "wDay" }
- { "WORD" "wHour" }
- { "WORD" "wMinute" }
- { "WORD" "wSecond" }
- { "WORD" "wMilliseconds" } ;
-
-C-STRUCT: TIME_ZONE_INFORMATION
- { "LONG" "Bias" }
- { { "WCHAR" 32 } "StandardName" }
- { "SYSTEMTIME" "StandardDate" }
- { "LONG" "StandardBias" }
- { { "WCHAR" 32 } "DaylightName" }
- { "SYSTEMTIME" "DaylightDate" }
- { "LONG" "DaylightBias" } ;
-
-C-STRUCT: FILETIME
- { "DWORD" "dwLowDateTime" }
- { "DWORD" "dwHighDateTime" } ;
-
-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: OVERLAPPED
+ { internal UINT_PTR }
+ { internal-high UINT_PTR }
+ { offset DWORD }
+ { offset-high DWORD }
+ { event HANDLE } ;
+
+STRUCT: SYSTEMTIME
+ { wYear WORD }
+ { wMonth WORD }
+ { wDayOfWeek WORD }
+ { wDay WORD }
+ { wHour WORD }
+ { wMinute WORD }
+ { wSecond WORD }
+ { wMilliseconds WORD } ;
+
+STRUCT: TIME_ZONE_INFORMATION
+ { Bias LONG }
+ { StandardName WCHAR[32] }
+ { StandardDate SYSTEMTIME }
+ { StandardBias LONG }
+ { DaylightName WCHAR[32] }
+ { DaylightDate SYSTEMTIME }
+ { DaylightBias LONG } ;
+
+STRUCT: FILETIME
+ { dwLowDateTime DWORD }
+ { dwHighDateTime DWORD } ;
+
+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" } ;
-
-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: PROCESS_INFORMATION
+ { hProcess HANDLE }
+ { hThread HANDLE }
+ { dwProcessId DWORD }
+ { dwThreadId DWORD } ;
+
+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
-C-STRUCT: OSVERSIONINFO
- { "DWORD" "dwOSVersionInfoSize" }
- { "DWORD" "dwMajorVersion" }
- { "DWORD" "dwMinorVersion" }
- { "DWORD" "dwBuildNumber" }
- { "DWORD" "dwPlatformId" }
- { { "WCHAR" 128 } "szCSDVersion" } ;
+STRUCT: OSVERSIONINFO
+ { dwOSVersionInfoSize DWORD }
+ { dwMajorVersion DWORD }
+ { dwMinorVersion DWORD }
+ { dwBuildNumber DWORD }
+ { dwPlatformId DWORD }
+ { szCSDVersion WCHAR[128] } ;
TYPEDEF: void* LPOSVERSIONINFO
{ "DWORD" "protect" }
{ "DWORD" "type" } ;
-C-STRUCT: GUID
- { "ULONG" "Data1" }
- { "WORD" "Data2" }
- { "WORD" "Data3" }
- { { "UCHAR" 8 } "Data4" } ;
+STRUCT: GUID
+ { Data1 ULONG }
+ { Data2 WORD }
+ { Data3 WORD }
+ { Data4 UCHAR[8] } ;
/*
fBinary :1;
{ "LUID_AND_ATTRIBUTES*" "Privileges" } ;
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
-C-STRUCT: WIN32_FILE_ATTRIBUTE_DATA
- { "DWORD" "dwFileAttributes" }
- { "FILETIME" "ftCreationTime" }
- { "FILETIME" "ftLastAccessTime" }
- { "FILETIME" "ftLastWriteTime" }
- { "DWORD" "nFileSizeHigh" }
- { "DWORD" "nFileSizeLow" } ;
+STRUCT: WIN32_FILE_ATTRIBUTE_DATA
+ { dwFileAttributes DWORD }
+ { ftCreationTime FILETIME }
+ { ftLastAccessTime FILETIME }
+ { ftLastWriteTime FILETIME }
+ { nFileSizeHigh DWORD }
+ { nFileSizeLow DWORD } ;
TYPEDEF: WIN32_FILE_ATTRIBUTE_DATA* LPWIN32_FILE_ATTRIBUTE_DATA
C-STRUCT: BY_HANDLE_FILE_INFORMATION
TYPEDEF: OFSTRUCT* LPOFSTRUCT
-! MAX_PATH = 260
-C-STRUCT: WIN32_FIND_DATA
- { "DWORD" "dwFileAttributes" }
- { "FILETIME" "ftCreationTime" }
- { "FILETIME" "ftLastAccessTime" }
- { "FILETIME" "ftLastWriteTime" }
- { "DWORD" "nFileSizeHigh" }
- { "DWORD" "nFileSizeLow" }
- { "DWORD" "dwReserved0" }
- { "DWORD" "dwReserved1" }
- ! { { "TCHAR" MAX_PATH } "cFileName" }
- { { "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: WIN32_FIND_DATA
+ { dwFileAttributes DWORD }
+ { ftCreationTime FILETIME }
+ { ftLastAccessTime FILETIME }
+ { ftLastWriteTime FILETIME }
+ { nFileSizeHigh DWORD }
+ { nFileSizeLow DWORD }
+ { dwReserved0 DWORD }
+ { dwReserved1 DWORD }
+ { cFileName { "TCHAR" MAX_PATH } }
+ { cAlternateFileName TCHAR[14] } ;
+
+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
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
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel combinators sequences
math windows.gdi32 windows.types images destructors
-accessors fry locals ;
+accessors fry locals classes.struct ;
IN: windows.offscreen
: (bitmap-info) ( dim -- BITMAPINFO )
- "BITMAPINFO" <c-object> [
- BITMAPINFO-bmiHeader {
- [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
- [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
- [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
- [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
- [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
- [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
- [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
- [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
- [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
- [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
- [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
- } 2cleave
- ] keep ;
+ [
+ BITMAPINFO <struct>
+ dup bmiHeader>>
+ BITMAPINFOHEADER heap-size >>biSize
+ ] dip
+ [ first >>biWidth ]
+ [ second >>biHeight ]
+ [ first2 * 4 * >>biSizeImage ] tri
+ 1 >>biPlanes
+ 32 >>biBitCount
+ BI_RGB >>biCompression
+ 72 >>biXPelsPerMeter
+ 72 >>biYPelsPerMeter
+ 0 >>biClrUsed
+ 0 >>biClrImportant
+ drop ;
: make-bitmap ( dim dc -- hBitmap bits )
[ nip ]
-USING: kernel tools.test windows.ole32 alien.c-types ;
+USING: kernel tools.test windows.ole32 alien.c-types
+classes.struct specialized-arrays windows.kernel32
+windows.com.syntax ;
+SPECIALIZED-ARRAY: uchar
IN: windows.ole32.tests
[ t ] [
guid=
] unit-test
-little-endian?
-[ B{
- HEX: 67 HEX: 45 HEX: 23 HEX: 01 HEX: ab HEX: 89 HEX: ef HEX: cd
- HEX: 01 HEX: 23 HEX: 45 HEX: 67 HEX: 89 HEX: ab HEX: cd HEX: ef
-} ]
-[ B{
- HEX: 01 HEX: 23 HEX: 45 HEX: 67 HEX: 89 HEX: ab HEX: cd HEX: ef
- HEX: 01 HEX: 23 HEX: 45 HEX: 67 HEX: 89 HEX: ab HEX: cd HEX: ef
-} ] ?
-[ "{01234567-89ab-cdef-0123-456789abcdef}" string>guid ]
-unit-test
+[
+ GUID: 01234567-89ab-cdef-0123-456789abcdef}
+] [ "{01234567-89ab-cdef-0123-456789abcdef}" string>guid ] unit-test
[ "{01234567-89ab-cdef-0123-456789abcdef}" ]
[ "{01234567-89ab-cdef-0123-456789abcdef}" string>guid guid>string ]
USING: alien alien.syntax alien.c-types alien.strings math
-kernel sequences windows.errors windows.types io
-accessors math.order namespaces make math.parser windows.kernel32
-combinators locals specialized-arrays.direct.uchar ;
+kernel sequences windows.errors windows.types io accessors
+math.order namespaces make math.parser windows.kernel32
+combinators locals specialized-arrays literals splitting
+grouping classes.struct combinators.smart ;
+SPECIALIZED-ARRAY: uchar
IN: windows.ole32
LIBRARY: ole32
: guid= ( a b -- ? )
[ 16 memory>byte-array ] bi@ = ;
-: GUID-STRING-LENGTH ( -- n )
- "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
-
-:: (guid-section>guid) ( string guid start end quot -- )
- start end string subseq hex> guid quot call ; inline
-
-:: (guid-byte>guid) ( string guid start end byte -- )
- start end string subseq hex> byte guid set-nth ; inline
+CONSTANT: GUID-STRING-LENGTH
+ $[ "{01234567-89ab-cdef-0123-456789abcdef}" length ]
: string>guid ( string -- guid )
- "GUID" <c-object> [
- {
- [ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ]
- [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
- [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
- [ ]
- } 2cleave
-
- GUID-Data4 8 <direct-uchar-array> {
- [ 20 22 0 (guid-byte>guid) ]
- [ 22 24 1 (guid-byte>guid) ]
-
- [ 25 27 2 (guid-byte>guid) ]
- [ 27 29 3 (guid-byte>guid) ]
- [ 29 31 4 (guid-byte>guid) ]
- [ 31 33 5 (guid-byte>guid) ]
- [ 33 35 6 (guid-byte>guid) ]
- [ 35 37 7 (guid-byte>guid) ]
- } 2cleave
- ] keep ;
-
-: (guid-section%) ( guid quot len -- )
- [ call >hex ] dip CHAR: 0 pad-head % ; inline
-
-: (guid-byte%) ( guid byte -- )
- swap nth >hex 2 CHAR: 0 pad-head % ; inline
+ "{-}" split harvest
+ [ first3 [ hex> ] tri@ ]
+ [ 3 tail concat 2 group [ hex> ] B{ } map-as ] bi
+ GUID <struct-boa> ;
: guid>string ( guid -- string )
[
- "{" % {
- [ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
- [ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
- [ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
- [ ]
+ [ "{" ] dip {
+ [ Data1>> >hex 8 CHAR: 0 pad-head "-" ]
+ [ Data2>> >hex 4 CHAR: 0 pad-head "-" ]
+ [ Data3>> >hex 4 CHAR: 0 pad-head "-" ]
+ [
+ Data4>> [
+ {
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head "-" ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ } spread
+ ] input<sequence "}"
+ ]
} cleave
- GUID-Data4 8 <direct-uchar-array> {
- [ 0 (guid-byte%) ]
- [ 1 (guid-byte%) "-" % ]
- [ 2 (guid-byte%) ]
- [ 3 (guid-byte%) ]
- [ 4 (guid-byte%) ]
- [ 5 (guid-byte%) ]
- [ 6 (guid-byte%) ]
- [ 7 (guid-byte%) "}" % ]
- } cleave
- ] "" make ;
-
+ ] "" append-outputs-as ;
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax
-combinators io.encodings.utf16n io.files io.pathnames kernel
-windows.errors windows.com windows.com.syntax windows.user32
-windows.ole32 windows ;
+classes.struct combinators io.encodings.utf16n io.files
+io.pathnames kernel windows.errors windows.com
+windows.com.syntax windows.user32 windows.ole32 windows
+specialized-arrays ;
+SPECIALIZED-ARRAY: ushort
IN: windows.shell32
CONSTANT: CSIDL_DESKTOP HEX: 00
: shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT
- MAX_UNICODE_PATH "ushort" <c-array>
+ MAX_UNICODE_PATH <ushort-array>
[ SHGetFolderPath drop ] keep utf16n alien>string ;
: desktop ( -- str )
TYPEDEF: ULONG SFGAOF
-C-STRUCT: DROPFILES
- { "DWORD" "pFiles" }
- { "POINT" "pt" }
- { "BOOL" "fNC" }
- { "BOOL" "fWide" } ;
+STRUCT: DROPFILES
+ { pFiles DWORD }
+ { pt POINT }
+ { fNC BOOL }
+ { fWide BOOL } ;
TYPEDEF: DROPFILES* LPDROPFILES
TYPEDEF: DROPFILES* LPCDROPFILES
TYPEDEF: HANDLE HDROP
-C-STRUCT: SHITEMID
- { "USHORT" "cb" }
- { "BYTE[1]" "abID" } ;
+STRUCT: SHITEMID
+ { cb USHORT }
+ { abID BYTE[1] } ;
TYPEDEF: SHITEMID* LPSHITEMID
TYPEDEF: SHITEMID* LPCSHITEMID
-C-STRUCT: ITEMIDLIST
- { "SHITEMID" "mkid" } ;
+STRUCT: ITEMIDLIST
+ { mkid SHITEMID } ;
TYPEDEF: ITEMIDLIST* LPITEMIDLIST
TYPEDEF: ITEMIDLIST* LPCITEMIDLIST
TYPEDEF: ITEMIDLIST ITEMID_CHILD
CONSTANT: STRRET_OFFSET 1
CONSTANT: STRRET_CSTR 2
-C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
-C-STRUCT: STRRET
- { "int" "uType" }
- { "STRRET-union" "union" } ;
+UNION-STRUCT: STRRET-union
+ { pOleStr LPWSTR }
+ { uOffset UINT }
+ { cStr char[260] } ;
+STRUCT: STRRET
+ { uType int }
+ { value STRRET-union } ;
COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046}
HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched )
! 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 )
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 )
>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 ;
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.struct tools.test windows.types ;
+IN: windows.types.tests
+
+[ S{ RECT { right 100 } { bottom 100 } } ]
+[ { 0 0 } { 100 100 } <RECT> ] unit-test
+
+[ S{ RECT { left 100 } { top 100 } { right 200 } { bottom 200 } } ]
+[ { 100 100 } { 100 100 } <RECT> ] unit-test
! 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 accessors ;
IN: windows.types
TYPEDEF: char CHAR
! typedef LRESULT (CALLBACK* WNDPROC)(HWND, UINT, WPARAM, LPARAM);
-C-STRUCT: WNDCLASS
- { "UINT" "style" }
- { "WNDPROC" "lpfnWndProc" }
- { "int" "cbClsExtra" }
- { "int" "cbWndExtra" }
- { "HINSTANCE" "hInstance" }
- { "HICON" "hIcon" }
- { "HCURSOR" "hCursor" }
- { "HBRUSH" "hbrBackground" }
- { "LPCTSTR" "lpszMenuName" }
- { "LPCTSTR" "lpszClassName" } ;
-
-C-STRUCT: WNDCLASSEX
- { "UINT" "cbSize" }
- { "UINT" "style" }
- { "WNDPROC" "lpfnWndProc" }
- { "int" "cbClsExtra" }
- { "int" "cbWndExtra" }
- { "HINSTANCE" "hInstance" }
- { "HICON" "hIcon" }
- { "HCURSOR" "hCursor" }
- { "HBRUSH" "hbrBackground" }
- { "LPCTSTR" "lpszMenuName" }
- { "LPCTSTR" "lpszClassName" }
- { "HICON" "hIconSm" } ;
-
-C-STRUCT: RECT
- { "LONG" "left" }
- { "LONG" "top" }
- { "LONG" "right" }
- { "LONG" "bottom" } ;
+STRUCT: WNDCLASS
+ { style UINT }
+ { lpfnWndProc WNDPROC }
+ { cbClsExtra int }
+ { cbWndExtra int }
+ { hInstance HINSTANCE }
+ { hIcon HICON }
+ { hCursor HCURSOR }
+ { hbrBackground HBRUSH }
+ { lpszMenuName LPCTSTR }
+ { lpszClassName LPCTSTR } ;
+
+STRUCT: WNDCLASSEX
+ { cbSize UINT }
+ { style UINT }
+ { lpfnWndProc WNDPROC }
+ { cbClsExtra int }
+ { cbWndExtra int }
+ { hInstance HINSTANCE }
+ { hIcon HICON }
+ { hCursor HCURSOR }
+ { hbrBackground HBRUSH }
+ { lpszMenuName LPCTSTR }
+ { lpszClassName LPCTSTR }
+ { hIconSm HICON } ;
+
+STRUCT: RECT
+ { left LONG }
+ { top LONG }
+ { right LONG }
+ { bottom LONG } ;
C-STRUCT: PAINTSTRUCT
{ "HDC" " hdc" }
{ "BYTE[32]" "rgbReserved" }
;
-C-STRUCT: BITMAPINFOHEADER
- { "DWORD" "biSize" }
- { "LONG" "biWidth" }
- { "LONG" "biHeight" }
- { "WORD" "biPlanes" }
- { "WORD" "biBitCount" }
- { "DWORD" "biCompression" }
- { "DWORD" "biSizeImage" }
- { "LONG" "biXPelsPerMeter" }
- { "LONG" "biYPelsPerMeter" }
- { "DWORD" "biClrUsed" }
- { "DWORD" "biClrImportant" } ;
-
-C-STRUCT: RGBQUAD
- { "BYTE" "rgbBlue" }
- { "BYTE" "rgbGreen" }
- { "BYTE" "rgbRed" }
- { "BYTE" "rgbReserved" } ;
-
-C-STRUCT: BITMAPINFO
- { "BITMAPINFOHEADER" "bmiHeader" }
- { "RGBQUAD[1]" "bmiColors" } ;
+STRUCT: BITMAPINFOHEADER
+ { biSize DWORD }
+ { biWidth LONG }
+ { biHeight LONG }
+ { biPlanes WORD }
+ { biBitCount WORD }
+ { biCompression DWORD }
+ { biSizeImage DWORD }
+ { biXPelsPerMeter LONG }
+ { biYPelsPerMeter LONG }
+ { biClrUsed DWORD }
+ { biClrImportant DWORD } ;
+
+STRUCT: RGBQUAD
+ { rgbBlue BYTE }
+ { rgbGreen BYTE }
+ { rgbRed BYTE }
+ { rgbReserved BYTE } ;
+
+STRUCT: BITMAPINFO
+ { bmiHeader BITMAPINFOHEADER }
+ { bimColors RGBQUAD[1] } ;
TYPEDEF: void* LPPAINTSTRUCT
TYPEDEF: void* PAINTSTRUCT
{ "LONG" "x" }
{ "LONG" "y" } ;
-C-STRUCT: SIZE
- { "LONG" "cx" }
- { "LONG" "cy" } ;
+STRUCT: SIZE
+ { cx LONG }
+ { cy LONG } ;
C-STRUCT: MSG
{ "HWND" "hWnd" }
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" } ;
-
-C-STRUCT: RECT
- { "LONG" "left" }
- { "LONG" "top" }
- { "LONG" "right" }
- { "LONG" "bottom" } ;
+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 } ;
: <RECT> ( loc dim -- RECT )
- over v+
- "RECT" <c-object>
- over first over set-RECT-right
- swap second over set-RECT-bottom
- over first over set-RECT-left
- swap second over set-RECT-top ;
+ dupd v+ [ first2 ] bi@ RECT <struct-boa> ;
TYPEDEF: RECT* PRECT
TYPEDEF: RECT* LPRECT
: color>RGB ( color -- COLORREF )
>rgba-components drop [ 255 * >integer ] tri@ RGB ;
-C-STRUCT: TEXTMETRICW
- { "LONG" "tmHeight" }
- { "LONG" "tmAscent" }
- { "LONG" "tmDescent" }
- { "LONG" "tmInternalLeading" }
- { "LONG" "tmExternalLeading" }
- { "LONG" "tmAveCharWidth" }
- { "LONG" "tmMaxCharWidth" }
- { "LONG" "tmWeight" }
- { "LONG" "tmOverhang" }
- { "LONG" "tmDigitizedAspectX" }
- { "LONG" "tmDigitizedAspectY" }
- { "WCHAR" "tmFirstChar" }
- { "WCHAR" "tmLastChar" }
- { "WCHAR" "tmDefaultChar" }
- { "WCHAR" "tmBreakChar" }
- { "BYTE" "tmItalic" }
- { "BYTE" "tmUnderlined" }
- { "BYTE" "tmStruckOut" }
- { "BYTE" "tmPitchAndFamily" }
- { "BYTE" "tmCharSet" } ;
+STRUCT: TEXTMETRICW
+ { tmHeight LONG }
+ { tmAscent LONG }
+ { tmDescent LONG }
+ { tmInternalLeading LONG }
+ { tmExternalLeading LONG }
+ { tmAveCharWidth LONG }
+ { tmMaxCharWidth LONG }
+ { tmWeight LONG }
+ { tmOverhang LONG }
+ { tmDigitizedAspectX LONG }
+ { tmDigitizedAspectY LONG }
+ { tmFirstChar WCHAR }
+ { tmLastChar WCHAR }
+ { tmDefaultChar WCHAR }
+ { tmBreakChar WCHAR }
+ { tmItalic BYTE }
+ { tmUnderlined BYTE }
+ { tmStruckOut BYTE }
+ { tmPitchAndFamily BYTE }
+ { tmCharSet BYTE } ;
TYPEDEF: TEXTMETRICW* LPTEXTMETRIC
io.encodings.utf16n accessors arrays combinators destructors
cache namespaces init fonts alien.c-types windows.usp10
windows.offscreen windows.gdi32 windows.ole32 windows.types
-windows.fonts opengl.textures locals windows.errors ;
+windows.fonts opengl.textures locals windows.errors
+classes.struct ;
IN: windows.uniscribe
TUPLE: script-string < disposable font string metrics ssa size image ;
: script-string-size ( script-string -- dim )
ssa>> ScriptString_pSize
dup win32-error=0/f
- [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
+ SIZE memory>struct
+ [ cx>> ] [ cy>> ] bi 2array ;
: dc-metrics ( dc -- metrics )
- "TEXTMETRICW" <c-object>
+ TEXTMETRICW <struct>
[ GetTextMetrics drop ] keep
TEXTMETRIC>metrics ;
! 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
+literals ;
IN: windows.user32
! HKL for ActivateKeyboardLayout
CONSTANT: WS_EX_CONTROLPARENT HEX: 00010000
CONSTANT: WS_EX_STATICEDGE HEX: 00020000
CONSTANT: WS_EX_APPWINDOW HEX: 00040000
+
: WS_EX_OVERLAPPEDWINDOW ( -- n )
WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable
+
: WS_EX_PALETTEWINDOW ( -- n )
{ WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } flags ; foldable
CONSTANT: TME_QUERY HEX: 40000000
CONSTANT: TME_CANCEL HEX: 80000000
CONSTANT: HOVER_DEFAULT HEX: ffffffff
-C-STRUCT: TRACKMOUSEEVENT
- { "DWORD" "cbSize" }
- { "DWORD" "dwFlags" }
- { "HWND" "hwndTrack" }
- { "DWORD" "dwHoverTime" } ;
+STRUCT: TRACKMOUSEEVENT
+ { cbSize DWORD }
+ { dwFlags DWORD }
+ { hwndTrack HWND }
+ { dwHoverTime DWORD } ;
TYPEDEF: TRACKMOUSEEVENT* LPTRACKMOUSEEVENT
CONSTANT: DBT_DEVICEARRIVAL HEX: 8000
CONSTANT: DEVICE_NOTIFY_ALL_INTERFACE_CLASSES 4
-C-STRUCT: DEV_BROADCAST_HDR
- { "DWORD" "dbch_size" }
- { "DWORD" "dbch_devicetype" }
- { "DWORD" "dbch_reserved" } ;
+STRUCT: DEV_BROADCAST_HDR
+ { dbch_size DWORD }
+ { dbch_devicetype DWORD }
+ { dbch_reserved DWORD } ;
-C-STRUCT: DEV_BROADCAST_DEVICEW
- { "DWORD" "dbcc_size" }
- { "DWORD" "dbcc_devicetype" }
- { "DWORD" "dbcc_reserved" }
- { "GUID" "dbcc_classguid" }
- { { "WCHAR" 1 } "dbcc_name" } ;
+STRUCT: DEV_BROADCAST_DEVICEW
+ { dbcc_size DWORD }
+ { dbcc_devicetype DWORD }
+ { dbcc_reserved DWORD }
+ { dbcc_classguid GUID }
+ { dbcc_name WCHAR[1] } ;
CONSTANT: CCHDEVICENAME 32
-C-STRUCT: MONITORINFOEX
- { "DWORD" "cbSize" }
- { "RECT" "rcMonitor" }
- { "RECT" "rcWork" }
- { "DWORD" "dwFlags" }
- { { "TCHAR" CCHDEVICENAME } "szDevice" } ;
+STRUCT: MONITORINFOEX
+ { cbSize DWORD }
+ { rcMonitor RECT }
+ { rcWork RECT }
+ { dwFlags DWORD }
+ { szDevice { "TCHAR" $ CCHDEVICENAME } } ;
TYPEDEF: MONITORINFOEX* LPMONITORINFOEX
TYPEDEF: MONITORINFOEX* LPMONITORINFO
! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
-byte-arrays kernel math sequences windows.types windows.kernel32
-windows.errors math.bitwise io.encodings.utf16n ;
+byte-arrays kernel literals math sequences windows.types
+windows.kernel32 windows.errors math.bitwise io.encodings.utf16n
+classes.struct windows.com.syntax init ;
IN: windows.winsock
-USE: libc
-: alien>byte-array ( alien str -- byte-array )
- heap-size dup <byte-array> [ -rot memcpy ] keep ;
-
TYPEDEF: void* SOCKET
: <wsadata> ( -- byte-array )
CONSTANT: AI_PASSIVE 1
CONSTANT: AI_CANONNAME 2
CONSTANT: AI_NUMERICHOST 4
-: AI_MASK ( -- n ) { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ;
+
+: AI_MASK ( -- n )
+ { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ; inline
CONSTANT: NI_NUMERICHOST 1
CONSTANT: NI_NUMERICSERV 2
CONSTANT: INADDR_ANY 0
-: INVALID_SOCKET ( -- alien ) -1 <alien> ; inline
+: INVALID_SOCKET ( -- n ) -1 <alien> ; inline
+
CONSTANT: SOCKET_ERROR -1
CONSTANT: SD_RECV 0
CONSTANT: SOL_SOCKET HEX: ffff
-! TYPEDEF: uint in_addr_t
-! C-STRUCT: in_addr
- ! { "in_addr_t" "s_addr" } ;
-
-C-STRUCT: sockaddr-in
- { "short" "family" }
- { "ushort" "port" }
- { "uint" "addr" }
- { { "char" 8 } "pad" } ;
-
-C-STRUCT: sockaddr-in6
- { "uchar" "family" }
- { "ushort" "port" }
- { "uint" "flowinfo" }
- { { "uchar" 16 } "addr" }
- { "uint" "scopeid" } ;
-
-C-STRUCT: hostent
- { "char*" "name" }
- { "void*" "aliases" }
- { "short" "addrtype" }
- { "short" "length" }
- { "void*" "addr-list" } ;
-
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "size_t" "addrlen" }
- { "char*" "canonname" }
- { "sockaddr*" "addr" }
- { "addrinfo*" "next" } ;
+STRUCT: sockaddr-in
+ { family short }
+ { port ushort }
+ { addr uint }
+ { pad char[8] } ;
+
+STRUCT: sockaddr-in6
+ { family uchar }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
+
+STRUCT: hostent
+ { name char* }
+ { aliases void* }
+ { addrtype short }
+ { length short }
+ { addr-list void* } ;
+
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen size_t }
+ { canonname char* }
+ { addr sockaddr* }
+ { next addrinfo* } ;
C-STRUCT: timeval
{ "long" "sec" }
{ "long" "usec" } ;
-: hostent-addr ( hostent -- addr ) hostent-addr-list *void* ; ! *uint ;
-
LIBRARY: winsock
-
FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
FUNCTION: ushort htons ( ushort n ) ;
TYPEDEF: FLOWSPEC* PFLOWSPEC
TYPEDEF: FLOWSPEC* LPFLOWSPEC
-C-STRUCT: WSABUF
- { "ulong" "len" }
- { "void*" "buf" } ;
+STRUCT: WSABUF
+ { len ulong }
+ { buf void* } ;
TYPEDEF: WSABUF* LPWSABUF
C-STRUCT: QOS
BOOL fAlertable ) ;
-
-
LIBRARY: mswsock
! Not in Windows CE
FUNCTION: int AcceptEx ( void* listen, void* accept, void* out-buf, int recv-len, int addr-len, int remote-len, void* out-len, void* overlapped ) ;
-FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, void* f, void* g, void* h ) ;
+
+FUNCTION: void GetAcceptExSockaddrs (
+ PVOID lpOutputBuffer,
+ DWORD dwReceiveDataLength,
+ DWORD dwLocalAddressLength,
+ DWORD dwRemoteAddressLength,
+ LPSOCKADDR* LocalSockaddr,
+ LPINT LocalSockaddrLength,
+ LPSOCKADDR* RemoteSockaddr,
+ LPINT RemoteSockaddrLength
+) ;
CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
-: WSAID_CONNECTEX ( -- GUID )
- "GUID" <c-object>
- HEX: 25a207b9 over set-GUID-Data1
- HEX: ddf3 over set-GUID-Data2
- HEX: 4660 over set-GUID-Data3
- B{
- HEX: 8e HEX: e9 HEX: 76 HEX: e5
- HEX: 8c HEX: 74 HEX: 06 HEX: 3e
- } over set-GUID-Data4 ;
+CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
: winsock-expected-error? ( n -- ? )
- ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING 3array member? ;
+ ${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
: (winsock-error-string) ( n -- str )
! #! WSAStartup returns the error code 'n' directly
: init-winsock ( -- )
HEX: 0202 <wsadata> WSAStartup winsock-return-check ;
+
+[ init-winsock ] "windows.winsock" add-init-hook
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings alien.syntax arrays
-kernel math namespaces sequences io.encodings.string
-io.encodings.utf8 io.encodings.ascii x11 x11.xlib x11.constants
-specialized-arrays.int accessors ;
+USING: accessors alien.c-types alien.strings classes.struct
+io.encodings.utf8 kernel namespaces sequences
+specialized-arrays x11 x11.constants x11.xlib ;
+SPECIALIZED-ARRAY: int
IN: x11.clipboard
! This code was based on by McCLIM's Backends/CLX/port.lisp
[ XGetWindowProperty drop ] keep snarf-property ;
: selection-from-event ( event window -- string )
- swap XSelectionEvent-property zero? [
- drop f
- ] [
- selection-property 1 window-property
- ] if ;
+ swap property>> 0 =
+ [ drop f ] [ selection-property 1 window-property ] if ;
: own-selection ( prop win -- )
[ dpy get ] 2dip CurrentTime XSetSelectionOwner drop
flush-dpy ;
: set-targets-prop ( evt -- )
- dpy get swap
- [ XSelectionRequestEvent-requestor ] keep
- XSelectionRequestEvent-property
+ [ dpy get ] dip [ requestor>> ] [ property>> ] bi
"TARGETS" x-atom 32 PropModeReplace
{
"UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
4 XChangeProperty drop ;
: set-timestamp-prop ( evt -- )
- dpy get swap
- [ XSelectionRequestEvent-requestor ] keep
- [ XSelectionRequestEvent-property ] keep
- [ "TIMESTAMP" x-atom 32 PropModeReplace ] dip
- XSelectionRequestEvent-time <int>
+ [ dpy get ] dip
+ [ requestor>> ]
+ [ property>> "TIMESTAMP" x-atom 32 PropModeReplace ]
+ [ time>> <int> ] tri
1 XChangeProperty drop ;
: send-notify ( evt prop -- )
- "XSelectionEvent" <c-object>
- SelectionNotify over set-XSelectionEvent-type
- [ set-XSelectionEvent-property ] keep
- over XSelectionRequestEvent-display over set-XSelectionEvent-display
- over XSelectionRequestEvent-requestor over set-XSelectionEvent-requestor
- over XSelectionRequestEvent-selection over set-XSelectionEvent-selection
- over XSelectionRequestEvent-target over set-XSelectionEvent-target
- over XSelectionRequestEvent-time over set-XSelectionEvent-time
- [ dpy get swap XSelectionRequestEvent-requestor 0 0 ] dip
+ XSelectionEvent <struct>
+ SelectionNotify >>type
+ swap >>property
+ over display>> >>display
+ over requestor>> >>requestor
+ over selection>> >>selection
+ over target>> >>target
+ over time>> >>time
+ [ [ dpy get ] dip requestor>> 0 0 ] dip
XSendEvent drop
flush-dpy ;
: send-notify-success ( evt -- )
- dup XSelectionRequestEvent-property send-notify ;
+ dup property>> send-notify ;
: send-notify-failure ( evt -- )
0 send-notify ;
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays hashtables io kernel math
-math.order namespaces prettyprint sequences strings combinators
-x11 x11.xlib ;
+USING: accessors arrays classes.struct combinators kernel
+math.order namespaces x11 x11.xlib ;
IN: x11.events
GENERIC: expose-event ( event window -- )
GENERIC: client-event ( event window -- )
: next-event ( -- event )
- dpy get "XEvent" <c-object> [ XNextEvent drop ] keep ;
+ dpy get XEvent <struct> [ XNextEvent drop ] keep ;
: mask-event ( mask -- event )
- [ dpy get ] dip "XEvent" <c-object> [ XMaskEvent drop ] keep ;
+ [ dpy get ] dip XEvent <struct> [ XMaskEvent drop ] keep ;
: events-queued ( mode -- n ) [ dpy get ] dip XEventsQueued ;
-: wheel? ( event -- ? ) XButtonEvent-button 4 7 between? ;
+: wheel? ( event -- ? ) button>> 4 7 between? ;
: button-down-event$ ( event window -- )
over wheel? [ wheel-event ] [ button-down-event ] if ;
over wheel? [ 2drop ] [ button-up-event ] if ;
: handle-event ( event window -- )
- over XAnyEvent-type {
- { Expose [ expose-event ] }
- { ConfigureNotify [ configure-event ] }
- { ButtonPress [ button-down-event$ ] }
- { ButtonRelease [ button-up-event$ ] }
- { EnterNotify [ enter-event ] }
- { LeaveNotify [ leave-event ] }
- { MotionNotify [ motion-event ] }
- { KeyPress [ key-down-event ] }
- { KeyRelease [ key-up-event ] }
- { FocusIn [ focus-in-event ] }
- { FocusOut [ focus-out-event ] }
- { SelectionNotify [ selection-notify-event ] }
- { SelectionRequest [ selection-request-event ] }
- { ClientMessage [ client-event ] }
+ swap dup XAnyEvent>> type>> {
+ { Expose [ XExposeEvent>> swap expose-event ] }
+ { ConfigureNotify [ XConfigureEvent>> swap configure-event ] }
+ { ButtonPress [ XButtonEvent>> swap button-down-event$ ] }
+ { ButtonRelease [ XButtonEvent>> swap button-up-event$ ] }
+ { EnterNotify [ XCrossingEvent>> swap enter-event ] }
+ { LeaveNotify [ XCrossingEvent>> swap leave-event ] }
+ { MotionNotify [ XMotionEvent>> swap motion-event ] }
+ { KeyPress [ XKeyEvent>> swap key-down-event ] }
+ { KeyRelease [ XKeyEvent>> swap key-up-event ] }
+ { FocusIn [ XFocusChangeEvent>> swap focus-in-event ] }
+ { FocusOut [ XFocusChangeEvent>> swap focus-out-event ] }
+ { SelectionNotify [ XSelectionEvent>> swap selection-notify-event ] }
+ { SelectionRequest [ XSelectionRequestEvent>> swap selection-request-event ] }
+ { ClientMessage [ XClientMessageEvent>> swap client-event ] }
[ 3drop ]
} case ;
-: configured-loc ( event -- dim )
- [ XConfigureEvent-x ] [ XConfigureEvent-y ] bi 2array ;
+: event-loc ( event -- loc )
+ [ x>> ] [ y>> ] bi 2array ;
-: configured-dim ( event -- dim )
- [ XConfigureEvent-width ] [ XConfigureEvent-height ] bi 2array ;
-
-: mouse-event-loc ( event -- loc )
- [ XButtonEvent-x ] [ XButtonEvent-y ] bi 2array ;
+: event-dim ( event -- dim )
+ [ width>> ] [ height>> ] bi 2array ;
: close-box? ( event -- ? )
- [ XClientMessageEvent-message_type "WM_PROTOCOLS" x-atom = ]
- [ XClientMessageEvent-data0 "WM_DELETE_WINDOW" x-atom = ]
+ [ message_type>> "WM_PROTOCOLS" x-atom = ]
+ [ data0>> "WM_DELETE_WINDOW" x-atom = ]
bi and ;
!
! based on glx.h from xfree86, and some of glxtokens.h
USING: alien alien.c-types alien.syntax x11 x11.xlib x11.syntax
-namespaces make kernel sequences parser words specialized-arrays.int
-accessors ;
+namespaces make kernel sequences parser words
+specialized-arrays accessors ;
+SPECIALIZED-ARRAY: int
IN: x11.glx
LIBRARY: glx
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types hashtables kernel math math.vectors
-math.bitwise namespaces sequences x11 x11.xlib x11.constants x11.glx
-arrays fry ;
+USING: accessors kernel math math.bitwise math.vectors
+namespaces sequences x11 x11.xlib x11.constants x11.glx arrays
+fry classes.struct ;
IN: x11.windows
: create-window-mask ( -- n )
{ CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
: create-colormap ( visinfo -- colormap )
- [ dpy get root get ] dip XVisualInfo-visual AllocNone
+ [ dpy get root get ] dip visual>> AllocNone
XCreateColormap ;
: event-mask ( -- n )
} flags ;
: window-attributes ( visinfo -- attributes )
- "XSetWindowAttributes" <c-object>
- 0 over set-XSetWindowAttributes-background_pixel
- 0 over set-XSetWindowAttributes-border_pixel
- [ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep
- event-mask over set-XSetWindowAttributes-event_mask ;
+ XSetWindowAttributes <struct>
+ 0 >>background_pixel
+ 0 >>border_pixel
+ event-mask >>event_mask
+ swap create-colormap >>colormap ;
: set-size-hints ( window -- )
- "XSizeHints" <c-object>
- USPosition over set-XSizeHints-flags
+ XSizeHints <struct>
+ USPosition >>flags
[ dpy get ] 2dip XSetWMNormalHints ;
: auto-position ( window loc -- )
: create-window ( loc dim visinfo -- window )
pick [
[ [ [ dpy get root get ] dip >xy ] dip { 1 1 } vmax >xy 0 ] dip
- [ XVisualInfo-depth InputOutput ] keep
- [ XVisualInfo-visual create-window-mask ] keep
+ [ depth>> InputOutput ] keep
+ [ visual>> create-window-mask ] keep
window-attributes XCreateWindow
dup
] dip auto-position ;
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays byte-arrays
hashtables io io.encodings.string kernel math namespaces
-sequences strings continuations x11 x11.xlib specialized-arrays.uint
-accessors io.encodings.utf16n ;
+sequences strings continuations x11 x11.xlib
+specialized-arrays accessors io.encodings.utf16n ;
+SPECIALIZED-ARRAY: uint
IN: x11.xim
SYMBOL: xim
! add to this library and are wondering what part of the file to
! modify, just find the function or data structure in the manual
! and note the section.
-
-USING: kernel arrays alien alien.c-types alien.strings
-alien.syntax math math.bitwise words sequences namespaces
-continuations io io.encodings.ascii x11.syntax ;
+USING: accessors kernel arrays alien alien.c-types alien.strings
+alien.syntax classes.struct math math.bitwise words sequences
+namespaces continuations io io.encodings.ascii x11.syntax ;
IN: x11.xlib
LIBRARY: xlib
!
! This struct is incomplete
-C-STRUCT: Display
-{ "void*" "ext_data" }
-{ "void*" "free_funcs" }
-{ "int" "fd" } ;
+STRUCT: Display
+{ ext_data void* }
+{ free_funcs void* }
+{ fd int } ;
X-FUNCTION: Display* XOpenDisplay ( void* display_name ) ;
: CWColormap ( -- n ) 13 2^ ; inline
: CWCursor ( -- n ) 14 2^ ; inline
-C-STRUCT: XSetWindowAttributes
- { "Pixmap" "background_pixmap" }
- { "ulong" "background_pixel" }
- { "Pixmap" "border_pixmap" }
- { "ulong" "border_pixel" }
- { "int" "bit_gravity" }
- { "int" "win_gravity" }
- { "int" "backing_store" }
- { "ulong" "backing_planes" }
- { "ulong" "backing_pixel" }
- { "Bool" "save_under" }
- { "long" "event_mask" }
- { "long" "do_not_propagate_mask" }
- { "Bool" "override_redirect" }
- { "Colormap" "colormap" }
- { "Cursor" "cursor" } ;
+STRUCT: XSetWindowAttributes
+{ background_pixmap Pixmap }
+{ background_pixel ulong }
+{ border_pixmap Pixmap }
+{ border_pixel ulong }
+{ bit_gravity int }
+{ win_gravity int }
+{ backing_store int }
+{ backing_planes ulong }
+{ backing_pixel ulong }
+{ save_under Bool }
+{ event_mask long }
+{ do_not_propagate_mask long }
+{ override_redirect Bool }
+{ colormap Colormap }
+{ cursor Cursor } ;
CONSTANT: UnmapGravity 0
: CWSibling ( -- n ) 5 2^ ; inline
: CWStackMode ( -- n ) 6 2^ ; inline
-C-STRUCT: XWindowChanges
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "border_width" }
- { "Window" "sibling" }
- { "int" "stack_mode" } ;
+STRUCT: XWindowChanges
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ border_width int }
+{ sibling Window }
+{ stack_mode int } ;
X-FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ;
X-FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ;
Window* parent_return,
Window** children_return, uint* nchildren_return ) ;
-C-STRUCT: XWindowAttributes
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" " height" }
- { "int" "border_width" }
- { "int" "depth" }
- { "Visual*" "visual" }
- { "Window" "root" }
- { "int" "class" }
- { "int" "bit_gravity" }
- { "int" "win_gravity" }
- { "int" "backing_store" }
- { "ulong" "backing_planes" }
- { "ulong" "backing_pixel" }
- { "Bool" "save_under" }
- { "Colormap" "colormap" }
- { "Bool" "map_installed" }
- { "int" "map_state" }
- { "long" "all_event_masks" }
- { "long" "your_event_mask" }
- { "long" "do_not_propagate_mask" }
- { "Bool" "override_redirect" }
- { "Screen*" "screen" } ;
+STRUCT: XWindowAttributes
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ border_width int }
+{ depth int }
+{ visual Visual* }
+{ root Window }
+{ class int }
+{ bit_gravity int }
+{ win_gravity int }
+{ backing_store int }
+{ backing_planes ulong }
+{ backing_pixel ulong }
+{ save_under Bool }
+{ colormap Colormap }
+{ map_installed Bool }
+{ map_state int }
+{ all_event_masks long }
+{ your_event_mask long }
+{ do_not_propagate_mask long }
+{ override_redirect Bool }
+{ screen Screen* } ;
X-FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ;
! 6 - Color Management Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XColor
- { "ulong" "pixel" }
- { "ushort" "red" }
- { "ushort" "green" }
- { "ushort" "blue" }
- { "char" "flags" }
- { "char" "pad" } ;
+STRUCT: XColor
+{ pixel ulong }
+{ red ushort }
+{ green ushort }
+{ blue ushort }
+{ flags char }
+{ pad char } ;
X-FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ;
X-FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ;
CONSTANT: GXnand HEX: e
CONSTANT: GXset HEX: f
-C-STRUCT: XGCValues
- { "int" "function" }
- { "ulong" "plane_mask" }
- { "ulong" "foreground" }
- { "ulong" "background" }
- { "int" "line_width" }
- { "int" "line_style" }
- { "int" "cap_style" }
- { "int" "join_style" }
- { "int" "fill_style" }
- { "int" "fill_rule" }
- { "int" "arc_mode" }
- { "Pixmap" "tile" }
- { "Pixmap" "stipple" }
- { "int" "ts_x_origin" }
- { "int" "ts_y_origin" }
- { "Font" "font" }
- { "int" "subwindow_mode" }
- { "Bool" "graphics_exposures" }
- { "int" "clip_x_origin" }
- { "int" "clip_y_origin" }
- { "Pixmap" "clip_mask" }
- { "int" "dash_offset" }
- { "char" "dashes" } ;
+STRUCT: XGCValues
+{ function int }
+{ plane_mask ulong }
+{ foreground ulong }
+{ background ulong }
+{ line_width int }
+{ line_style int }
+{ cap_style int }
+{ join_style int }
+{ fill_style int }
+{ fill_rule int }
+{ arc_mode int }
+{ tile Pixmap }
+{ stipple Pixmap }
+{ ts_x_origin int }
+{ ts_y_origin int }
+{ font Font }
+{ subwindow_mode int }
+{ graphics_exposures Bool }
+{ clip_x_origin int }
+{ clip_y_origin int }
+{ clip_mask Pixmap }
+{ dash_offset int }
+{ dashes char } ;
X-FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ;
X-FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ;
! 8.5 - Font Metrics
-C-STRUCT: XCharStruct
- { "short" "lbearing" }
- { "short" "rbearing" }
- { "short" "width" }
- { "short" "ascent" }
- { "short" "descent" }
- { "ushort" "attributes" } ;
+STRUCT: XCharStruct
+{ lbearing short }
+{ rbearing short }
+{ width short }
+{ ascent short }
+{ descent short }
+{ attributes ushort } ;
X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
-C-STRUCT: XFontStruct
- { "XExtData*" "ext_data" }
- { "Font" "fid" }
- { "uint" "direction" }
- { "uint" "min_char_or_byte2" }
- { "uint" "max_char_or_byte2" }
- { "uint" "min_byte1" }
- { "uint" "max_byte1" }
- { "Bool" "all_chars_exist" }
- { "uint" "default_char" }
- { "int" "n_properties" }
- { "XFontProp*" "properties" }
- { "XCharStruct" "min_bounds" }
- { "XCharStruct" "max_bounds" }
- { "XCharStruct*" "per_char" }
- { "int" "ascent" }
- { "int" "descent" } ;
+STRUCT: XFontStruct
+{ ext_data XExtData* }
+{ fid Font }
+{ direction uint }
+{ min_char_or_byte2 uint }
+{ max_char_or_byte2 uint }
+{ min_byte1 uint }
+{ max_byte1 uint }
+{ all_chars_exist Bool }
+{ default_char uint }
+{ n_properties int }
+{ properties XFontProp* }
+{ min_bounds XCharStruct }
+{ max_bounds XCharStruct }
+{ per_char XCharStruct* }
+{ ascent int }
+{ descent int } ;
X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ;
CONSTANT: AllPlanes -1
-C-STRUCT: XImage-funcs
- { "void*" "create_image" }
- { "void*" "destroy_image" }
- { "void*" "get_pixel" }
- { "void*" "put_pixel" }
- { "void*" "sub_image" }
- { "void*" "add_pixel" } ;
-
-C-STRUCT: XImage
- { "int" "width" }
- { "int" "height" }
- { "int" "xoffset" }
- { "int" "format" }
- { "char*" "data" }
- { "int" "byte_order" }
- { "int" "bitmap_unit" }
- { "int" "bitmap_bit_order" }
- { "int" "bitmap_pad" }
- { "int" "depth" }
- { "int" "bytes_per_line" }
- { "int" "bits_per_pixel" }
- { "ulong" "red_mask" }
- { "ulong" "green_mask" }
- { "ulong" "blue_mask" }
- { "XPointer" "obdata" }
- { "XImage-funcs" "f" } ;
+STRUCT: XImage-funcs
+{ create_image void* }
+{ destroy_image void* }
+{ get_pixel void* }
+{ put_pixel void* }
+{ sub_image void* }
+{ add_pixel void* } ;
+
+STRUCT: XImage
+{ width int }
+{ height int }
+{ xoffset int }
+{ format int }
+{ data char* }
+{ byte_order int }
+{ bitmap_unit int }
+{ bitmap_bit_order int }
+{ bitmap_pad int }
+{ depth int }
+{ bytes_per_line int }
+{ bits_per_pixel int }
+{ red_mask ulong }
+{ green_mask ulong }
+{ blue_mask ulong }
+{ obdata XPointer }
+{ f XImage-funcs } ;
X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
X-FUNCTION: int XDestroyImage ( XImage* ximage ) ;
: XImage-size ( ximage -- size )
- [ XImage-height ] [ XImage-bytes_per_line ] bi * ;
+ [ height>> ] [ bytes_per_line>> ] bi * ;
: XImage-pixels ( ximage -- byte-array )
- [ XImage-data ] [ XImage-size ] bi memory>byte-array ;
+ [ data>> ] [ XImage-size ] bi memory>byte-array ;
!
! 9 - Window and Session Manager Functions
CONSTANT: MotionNotify 6
CONSTANT: EnterNotify 7
CONSTANT: LeaveNotify 8
-CONSTANT: FocusIn 9
+CONSTANT: FocusIn 9
CONSTANT: FocusOut 10
CONSTANT: KeymapNotify 11
-CONSTANT: Expose 12
-CONSTANT: GraphicsExpose 13
+CONSTANT: Expose 12
+CONSTANT: GraphicsExpose 13
CONSTANT: NoExpose 14
CONSTANT: VisibilityNotify 15
CONSTANT: CreateNotify 16
CONSTANT: UnmapNotify 18
CONSTANT: MapNotify 19
CONSTANT: MapRequest 20
-CONSTANT: ReparentNotify 21
-CONSTANT: ConfigureNotify 22
+CONSTANT: ReparentNotify 21
+CONSTANT: ConfigureNotify 22
CONSTANT: ConfigureRequest 23
CONSTANT: GravityNotify 24
CONSTANT: ResizeRequest 25
-CONSTANT: CirculateNotify 26
+CONSTANT: CirculateNotify 26
CONSTANT: CirculateRequest 27
-CONSTANT: PropertyNotify 28
-CONSTANT: SelectionClear 29
+CONSTANT: PropertyNotify 28
+CONSTANT: SelectionClear 29
CONSTANT: SelectionRequest 30
-CONSTANT: SelectionNotify 31
-CONSTANT: ColormapNotify 32
+CONSTANT: SelectionNotify 31
+CONSTANT: ColormapNotify 32
CONSTANT: ClientMessage 33
CONSTANT: MappingNotify 34
CONSTANT: LASTEvent 35
-C-STRUCT: XAnyEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" } ;
+STRUCT: XAnyEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: Mod4Mask ( -- n ) 1 6 shift ; inline
: Mod5Mask ( -- n ) 1 7 shift ; inline
-C-STRUCT: XButtonEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Window" "root" }
- { "Window" "subwindow" }
- { "Time" "time" }
- { "int" "x" }
- { "int" "y" }
- { "int" "x_root" }
- { "int" "y_root" }
- { "uint" "state" }
- { "uint" "button" }
- { "Bool" "same_screen" } ;
+STRUCT: XButtonEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ root Window }
+{ subwindow Window }
+{ time Time }
+{ x int }
+{ y int }
+{ x_root int }
+{ y_root int }
+{ state uint }
+{ button uint }
+{ same_screen Bool } ;
TYPEDEF: XButtonEvent XButtonPressedEvent
TYPEDEF: XButtonEvent XButtonReleasedEvent
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XKeyEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Window" "root" }
- { "Window" "subwindow" }
- { "Time" "time" }
- { "int" "x" }
- { "int" "y" }
- { "int" "x_root" }
- { "int" "y_root" }
- { "uint" "state" }
- { "uint" "keycode" }
- { "Bool" "same_screen" } ;
+STRUCT: XKeyEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ root Window }
+{ subwindow Window }
+{ time Time }
+{ x int }
+{ y int }
+{ x_root int }
+{ y_root int }
+{ state uint }
+{ keycode uint }
+{ same_screen Bool } ;
TYPEDEF: XKeyEvent XKeyPressedEvent
TYPEDEF: XKeyEvent XKeyReleasedEvent
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XMotionEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Window" "root" }
- { "Window" "subwindow" }
- { "Time" "time" }
- { "int" "x" }
- { "int" "y" }
- { "int" "x_root" }
- { "int" "y_root" }
- { "uint" "state" }
- { "char" "is_hint" }
- { "Bool" "same_screen" } ;
+STRUCT: XMotionEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ root Window }
+{ subwindow Window }
+{ time Time }
+{ x int }
+{ y int }
+{ x_root int }
+{ y_root int }
+{ state uint }
+{ is_hint char }
+{ same_screen Bool } ;
TYPEDEF: XMotionEvent XPointerMovedEvent
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XCrossingEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Window" "root" }
- { "Window" "subwindow" }
- { "Time" "time" }
- { "int" "x" }
- { "int" "y" }
- { "int" "x_root" }
- { "int" "y_root" }
- { "int" "mode" }
- { "int" "detail" }
- { "Bool" "same_screen" }
- { "Bool" "focus" }
- { "uint" "state" } ;
+STRUCT: XCrossingEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ root Window }
+{ subwindow Window }
+{ time Time }
+{ x int }
+{ y int }
+{ x_root int }
+{ y_root int }
+{ mode int }
+{ detail int }
+{ same_screen Bool }
+{ focus Bool }
+{ state uint } ;
TYPEDEF: XCrossingEvent XEnterWindowEvent
TYPEDEF: XCrossingEvent XLeaveWindowEvent
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XFocusChangeEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "int" "mode" }
- { "int" "detail" } ;
+STRUCT: XFocusChangeEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ mode int }
+{ detail int } ;
TYPEDEF: XFocusChangeEvent XFocusInEvent
TYPEDEF: XFocusChangeEvent XFocusOutEvent
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XExposeEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "count" } ;
+STRUCT: XExposeEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ count int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XGraphicsExposeEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Drawable" "drawable" }
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "count" }
- { "int" "major_code" }
- { "int" "minor_code" } ;
-
-C-STRUCT: XNoExposeEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Drawable" "drawable" }
- { "int" "major_code" }
- { "int" "minor_code" } ;
+STRUCT: XGraphicsExposeEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ drawable Drawable }
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ count int }
+{ major_code int }
+{ minor_code int } ;
+
+STRUCT: XNoExposeEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ drawable Drawable }
+{ major_code int }
+{ minor_code int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XVisibilityEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "int" "state" } ;
+STRUCT: XVisibilityEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ state int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XCreateWindowEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "parent" }
- { "Window" "window" }
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "border_width" }
- { "Bool" "override_redirect" } ;
+STRUCT: XCreateWindowEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ parent Window }
+{ window Window }
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ border_width int }
+{ override_redirect Bool } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XDestroyWindowEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" } ;
+STRUCT: XDestroyWindowEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XUnmapEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" }
- { "Bool" "from_configure" } ;
+STRUCT: XUnmapEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window }
+{ from_configure Bool } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XMapEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" }
- { "Bool" "override_redirect" } ;
+STRUCT: XMapEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window }
+{ override_redirect Bool } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XMapRequestEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "parent" }
- { "Window" "window" } ;
+STRUCT: XMapRequestEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ parent Window }
+{ window Window } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XReparentEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" }
- { "Window" "parent" }
- { "int" "x" }
- { "int" "y" }
- { "Bool" "override_redirect" } ;
+STRUCT: XReparentEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window }
+{ parent Window }
+{ x int }
+{ y int }
+{ override_redirect Bool } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XConfigureEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" }
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "border_width" }
- { "Window" "above" }
- { "Bool" "override_redirect" } ;
+STRUCT: XConfigureEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window }
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ border_width int }
+{ above Window }
+{ override_redirect Bool } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XGravityEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" }
- { "int" "x" }
- { "int" "y" } ;
+STRUCT: XGravityEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window }
+{ x int }
+{ y int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XResizeRequestEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "int" "width" }
- { "int" "height" } ;
+STRUCT: XResizeRequestEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ width int }
+{ height int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XConfigureRequestEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "parent" }
- { "Window" "window" }
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "border_width" }
- { "Window" "above" }
- { "int" "detail" }
- { "ulong" "value_mask" } ;
+STRUCT: XConfigureRequestEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ parent Window }
+{ window Window }
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ border_width int }
+{ above Window }
+{ detail int }
+{ value_mask ulong } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XCirculateEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" }
- { "int" "place" } ;
+STRUCT: XCirculateEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window }
+{ place int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XCirculateRequestEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "parent" }
- { "Window" "window" }
- { "int" "place" } ;
+STRUCT: XCirculateRequestEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ parent Window }
+{ window Window }
+{ place int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XPropertyEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Atom" "atom" }
- { "Time" "time" }
- { "int" "state" } ;
+STRUCT: XPropertyEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ atom Atom }
+{ time Time }
+{ state int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XSelectionClearEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Atom" "selection" }
- { "Time" "time" } ;
+STRUCT: XSelectionClearEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ selection Atom }
+{ time Time } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XSelectionRequestEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "owner" }
- { "Window" "requestor" }
- { "Atom" "selection" }
- { "Atom" "target" }
- { "Atom" "property" }
- { "Time" "time" } ;
+STRUCT: XSelectionRequestEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ owner Window }
+{ requestor Window }
+{ selection Atom }
+{ target Atom }
+{ property Atom }
+{ time Time } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XSelectionEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "requestor" }
- { "Atom" "selection" }
- { "Atom" "target" }
- { "Atom" "property" }
- { "Time" "time" } ;
+STRUCT: XSelectionEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ requestor Window }
+{ selection Atom }
+{ target Atom }
+{ property Atom }
+{ time Time } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XColormapEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Colormap" "colormap" }
- { "Bool" "new" }
- { "int" "state" } ;
+STRUCT: XColormapEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ colormap Colormap }
+{ new Bool }
+{ state int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XClientMessageEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Atom" "message_type" }
- { "int" "format" }
- { "long" "data0" }
- { "long" "data1" }
- { "long" "data2" }
- { "long" "data3" }
- { "long" "data4" }
-! union {
-! char b[20];
-! short s[10];
-! long l[5];
-! } data;
-;
+STRUCT: XClientMessageEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ message_type Atom }
+{ format int }
+{ data0 long }
+{ data1 long }
+{ data2 long }
+{ data3 long }
+{ data4 long } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XMappingEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "int" "request" }
- { "int" "first_keycode" }
- { "int" "count" } ;
+STRUCT: XMappingEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ request int }
+{ first_keycode int }
+{ count int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XErrorEvent
- { "int" "type" }
- { "Display*" "display" }
- { "XID" "resourceid" }
- { "ulong" "serial" }
- { "uchar" "error_code" }
- { "uchar" "request_code" }
- { "uchar" "minor_code" } ;
+STRUCT: XErrorEvent
+{ type int }
+{ display Display* }
+{ resourceid XID }
+{ serial ulong }
+{ error_code uchar }
+{ request_code uchar }
+{ minor_code uchar } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XKeymapEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- ! char key_vector[32];
- { "int" "pad" }
- { "int" "pad" }
- { "int" "pad" }
- { "int" "pad" }
- { "int" "pad" }
- { "int" "pad" }
- { "int" "pad" }
- { "int" "pad" } ;
-
-C-UNION: XEvent
- "int"
- "XAnyEvent"
- "XKeyEvent"
- "XButtonEvent"
- "XMotionEvent"
- "XCrossingEvent"
- "XFocusChangeEvent"
- "XExposeEvent"
- "XGraphicsExposeEvent"
- "XNoExposeEvent"
- "XVisibilityEvent"
- "XCreateWindowEvent"
- "XDestroyWindowEvent"
- "XUnmapEvent"
- "XMapEvent"
- "XMapRequestEvent"
- "XReparentEvent"
- "XConfigureEvent"
- "XGravityEvent"
- "XResizeRequestEvent"
- "XConfigureRequestEvent"
- "XCirculateEvent"
- "XCirculateRequestEvent"
- "XPropertyEvent"
- "XSelectionClearEvent"
- "XSelectionRequestEvent"
- "XSelectionEvent"
- "XColormapEvent"
- "XClientMessageEvent"
- "XMappingEvent"
- "XErrorEvent"
- "XKeymapEvent"
- { "long" 24 } ;
+STRUCT: XKeymapEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ pad int }
+{ pad int }
+{ pad int }
+{ pad int }
+{ pad int }
+{ pad int }
+{ pad int }
+{ pad int } ;
+
+UNION-STRUCT: XEvent
+{ int int }
+{ XAnyEvent XAnyEvent }
+{ XKeyEvent XKeyEvent }
+{ XButtonEvent XButtonEvent }
+{ XMotionEvent XMotionEvent }
+{ XCrossingEvent XCrossingEvent }
+{ XFocusChangeEvent XFocusChangeEvent }
+{ XExposeEvent XExposeEvent }
+{ XGraphicsExposeEvent XGraphicsExposeEvent }
+{ XNoExposeEvent XNoExposeEvent }
+{ XVisibilityEvent XVisibilityEvent }
+{ XCreateWindowEvent XCreateWindowEvent }
+{ XDestroyWindowEvent XDestroyWindowEvent }
+{ XUnmapEvent XUnmapEvent }
+{ XMapEvent XMapEvent }
+{ XMapRequestEvent XMapRequestEvent }
+{ XReparentEvent XReparentEvent }
+{ XConfigureEvent XConfigureEvent }
+{ XGravityEvent XGravityEvent }
+{ XResizeRequestEvent XResizeRequestEvent }
+{ XConfigureRequestEvent XConfigureRequestEvent }
+{ XCirculateEvent XCirculateEvent }
+{ XCirculateRequestEvent XCirculateRequestEvent }
+{ XPropertyEvent XPropertyEvent }
+{ XSelectionClearEvent XSelectionClearEvent }
+{ XSelectionRequestEvent XSelectionRequestEvent }
+{ XSelectionEvent XSelectionEvent }
+{ XColormapEvent XColormapEvent }
+{ XClientMessageEvent XClientMessageEvent }
+{ XMappingEvent XMappingEvent }
+{ XErrorEvent XErrorEvent }
+{ XKeymapEvent XKeymapEvent }
+{ padding long[24] } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 11 - Event Handling Functions
: PAllHints ( -- n )
{ PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable
-C-STRUCT: XSizeHints
- { "long" "flags" }
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "min_width" }
- { "int" "min_height" }
- { "int" "max_width" }
- { "int" "max_height" }
- { "int" "width_inc" }
- { "int" "height_inc" }
- { "int" "min_aspect_x" }
- { "int" "min_aspect_y" }
- { "int" "max_aspect_x" }
- { "int" "max_aspect_y" }
- { "int" "base_width" }
- { "int" "base_height" }
- { "int" "win_gravity" } ;
+STRUCT: XSizeHints
+ { flags long }
+ { x int }
+ { y int }
+ { width int }
+ { height int }
+ { min_width int }
+ { min_height int }
+ { max_width int }
+ { max_height int }
+ { width_inc int }
+ { height_inc int }
+ { min_aspect_x int }
+ { min_aspect_y int }
+ { max_aspect_x int }
+ { max_aspect_y int }
+ { base_width int }
+ { base_height int }
+ { win_gravity int } ;
! 14.1.10. Setting and Reading the WM_PROTOCOLS Property
CONSTANT: VisualBitsPerRGBMask HEX: 100
CONSTANT: VisualAllMask HEX: 1FF
-C-STRUCT: XVisualInfo
- { "Visual*" "visual" }
- { "VisualID" "visualid" }
- { "int" "screen" }
- { "uint" "depth" }
- { "int" "class" }
- { "ulong" "red_mask" }
- { "ulong" "green_mask" }
- { "ulong" "blue_mask" }
- { "int" "colormap_size" }
- { "int" "bits_per_rgb" } ;
+STRUCT: XVisualInfo
+ { visual Visual* }
+ { visualid VisualID }
+ { screen int }
+ { depth uint }
+ { class int }
+ { red_mask ulong }
+ { green_mask ulong }
+ { blue_mask ulong }
+ { colormap_size int }
+ { bits_per_rgb int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Appendix D - Compatibility Functions
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel xml arrays math generic http.client
-combinators hashtables namespaces io base64 sequences strings
-calendar xml.data xml.writer xml.traversal assocs math.parser
-debugger calendar.format math.order xml.syntax ;
+USING: accessors arrays assocs base64 calendar calendar.format
+combinators debugger generic hashtables http http.client
+http.client.private io io.encodings.string io.encodings.utf8
+kernel math math.order math.parser namespaces sequences strings
+xml xml.data xml.syntax xml.traversal xml.writer ;
IN: xml-rpc
! * Sending RPC requests
] [ "Bad main tag name" server-error ] if
] if ;
+<PRIVATE
+
+: xml-post-data ( xml -- post-data )
+ xml>string utf8 encode "text/xml" <post-data> swap >>data ;
+
+: rpc-post-request ( xml url -- request )
+ [ send-rpc xml-post-data ] [ "POST" <client-request> ] bi*
+ swap >>post-data ;
+
+PRIVATE>
+
: post-rpc ( rpc url -- rpc )
! This needs to do something in the event of an error
- [ send-rpc ] dip http-post nip string>xml receive-rpc ;
+ rpc-post-request http-request nip string>xml receive-rpc ;
: invoke-method ( params method url -- response )
[ swap <rpc-method> ] dip post-rpc ;
NO_UI=
GIT_PROTOCOL=${GIT_PROTOCOL:="git"}
GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"}
+SCRIPT_ARGS="$*"
test_program_installed() {
if ! [[ -n `type -p $1` ]] ; then
invoke_git clone $GIT_URL
}
-git_pull_factorcode() {
- echo "Updating the git repository from factorcode.org..."
- invoke_git pull $GIT_URL master
+update_script_name() {
+ echo `dirname $0`/_update.sh
+}
+
+update_script() {
+ update_script=`update_script_name`
+
+ echo "#!/bin/sh" >"$update_script"
+ echo "git pull \"$GIT_URL\" master" >>"$update_script"
+ echo "if [[ \$? -eq 0 ]]; then exec \"$0\" $SCRIPT_ARGS; else echo \"git pull failed\"; exit 2; fi" \
+ >>"$update_script"
+ echo "exit 0" >>"$update_script"
+
+ chmod 755 "$update_script"
+ exec "$update_script"
+}
+
+update_script_changed() {
+ invoke_git diff --stat `invoke_git merge-base HEAD FETCH_HEAD` FETCH_HEAD | grep 'build-support.factor\.sh' >/dev/null
+}
+
+git_fetch_factorcode() {
+ echo "Fetching the git repository from factorcode.org..."
+
+ rm -f `update_script_name`
+ invoke_git fetch "$GIT_URL" master
+
+ if update_script_changed; then
+ echo "Updating and restarting the factor.sh script..."
+ update_script
+ else
+ echo "Updating the working tree..."
+ invoke_git pull "$GIT_URL" master
+ fi
}
cd_factor() {
update() {
get_config_info
- git_pull_factorcode
+ git_fetch_factorcode
backup_factor
make_clean
make_factor
] unit-test
] when
-[ "ALIEN: 1234" ] [ 1234 <alien> unparse ] unit-test
+[ "ALIEN: 1234" ] [
HEX: 1234 <alien> unparse ] unit-test
[ ] [ 0 B{ 1 2 3 } <displaced-alien> drop ] unit-test
[ <memory-stream> ] [ <decoder> ] bi*
"\0" swap stream-read-until drop ;
+M: object alien>string
+ [ underlying>> ] dip alien>string ;
+
M: f alien>string
drop ;
[ stream>> >byte-array ]
tri ;
+M: tuple string>alien drop underlying>> ;
+
HOOK: alien>native-string os ( alien -- string )
M: windows alien>native-string utf16n alien>string ;
USING: kernel math namespaces make tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
-continuations specialized-arrays.double ;
+continuations specialized-arrays ;
+SPECIALIZED-ARRAY: double
IN: assocs.tests
[ t ] [ H{ } dup assoc-subset? ] unit-test
{ "float<=" "math.private" (( x y -- ? )) }
{ "float>" "math.private" (( x y -- ? )) }
{ "float>=" "math.private" (( x y -- ? )) }
+ { "float-u<" "math.private" (( x y -- ? )) }
+ { "float-u<=" "math.private" (( x y -- ? )) }
+ { "float-u>" "math.private" (( x y -- ? )) }
+ { "float-u>=" "math.private" (( x y -- ? )) }
{ "<word>" "words" (( name vocab -- word )) }
{ "word-xt" "words" (( word -- start end )) }
{ "getenv" "kernel.private" (( n -- obj )) }
"MAIN:"
"MATH:"
"MIXIN:"
+ "NAN:"
"OCT:"
"P\""
"POSTPONE:"
kernel math namespaces parser prettyprint sequences strings\r
tools.test words quotations classes classes.algebra\r
classes.private classes.union classes.mixin classes.predicate\r
-vectors definitions source-files compiler.units growable\r
-random stack-checker effects kernel.private sbufs math.order\r
+vectors source-files compiler.units growable random\r
+stack-checker effects kernel.private sbufs math.order\r
classes.tuple accessors ;\r
IN: classes.algebra.tests\r
\r
! UNION: u1 sa sb ;\r
! UNION: u2 sc ;\r
\r
-! [ f ] [ u1 u2 classes-intersect? ] unit-test
\ No newline at end of file
+! [ f ] [ u1 u2 classes-intersect? ] unit-test\r
io.streams.string kernel math namespaces parser prettyprint
sequences strings tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
-classes.algebra vectors definitions source-files compiler.units
+classes.algebra definitions source-files compiler.units
kernel.private sorting vocabs memory eval accessors sets ;
IN: classes.tests
" x 3 }"
} "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with
+
+TUPLE: bad-inheritance-tuple ;
+[
+ "IN: classes.tuple.parser.tests TUPLE: bad-inheritance-tuple < bad-inheritance-tuple ;" eval( -- )
+] [ error>> bad-inheritance? ] must-fail-with
+
+TUPLE: bad-inheritance-tuple2 ;
+TUPLE: bad-inheritance-tuple3 < bad-inheritance-tuple2 ;
+[
+ "IN: classes.tuple.parser.tests TUPLE: bad-inheritance-tuple2 < bad-inheritance-tuple3 ;" eval( -- )
+] [ error>> bad-inheritance? ] must-fail-with
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sets namespaces make sequences parser
lexer combinators words classes.parser classes.tuple arrays
-slots math assocs parser.notes ;
+slots math assocs parser.notes classes.algebra ;
IN: classes.tuple.parser
: slot-names ( slots -- seq )
: parse-tuple-slots ( -- )
";" parse-tuple-slots-delim ;
+ERROR: bad-inheritance class superclass ;
+
+: check-inheritance ( class1 class2 -- class1 class2 )
+ 2dup swap class<= [ bad-inheritance ] when ;
+
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
- scan {
+ scan 2dup = [ ] when {
{ ";" [ tuple f ] }
- { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
+ { "<" [
+ scan-word check-inheritance [ parse-tuple-slots ] { } make
+ ] }
[ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
} case
dup check-duplicate-slots
layout-of 3 slot { fixnum } declare ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
- check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
+ check-tuple [ tuple-size iota ] [ ] [ layout-of ] tri ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
M: tuple-class slots>tuple ( seq class -- tuple )
check-slots pad-slots
tuple-layout <tuple> [
- [ tuple-size ]
+ [ tuple-size iota ]
[ [ set-array-nth ] curry ]
bi 2each
] keep ;
slots>tuple ;
: outdated-tuple? ( tuple assoc -- ? )
- over tuple? [
- [ [ layout-of ] dip key? ]
- [ drop class "forgotten" word-prop not ]
- 2bi and
- ] [ 2drop f ] if ;
+ [ [ layout-of ] dip key? ]
+ [ drop class "forgotten" word-prop not ]
+ 2bi and ;
: update-tuples ( -- )
outdated-tuples get
dup assoc-empty? [ drop ] [
- [ outdated-tuple? ] curry instances
+ [ [ tuple? ] instances ] dip [ outdated-tuple? ] curry filter
dup [ update-tuple ] map become
] if ;
[ [ "slots" word-prop ] dip = ]
bi-curry* bi and ;
-: valid-superclass? ( class -- ? )
- [ tuple-class? ] [ tuple eq? ] bi or ;
+GENERIC: valid-superclass? ( class -- ? )
+
+M: tuple-class valid-superclass? drop t ;
+
+M: builtin-class valid-superclass? tuple eq? ;
+
+M: class valid-superclass? drop f ;
: check-superclass ( superclass -- )
dup valid-superclass? [ bad-superclass ] unless drop ;
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
"The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:"
{ $subsection call }
{ $subsection execute }
-"The second set of combinators takes an effect declaration. The stack effect of the quotation or word is checked at runtime:"
+"The second set of combinators takes an effect declaration. Note that the opening parenthesis is actually part of the word name; these are parsing words, and they read a stack effect until the corresponding closing parenthesis. The stack effect of the quotation or word is then checked at runtime:"
{ $subsection POSTPONE: call( }
{ $subsection POSTPONE: execute( }
"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:"
HELP: call-effect
{ $values { "quot" quotation } { "effect" effect } }
-{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
+{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." }
+{ $examples
+ "The following two lines are equivalent:"
+ { $code
+ "call( a b -- c )"
+ "(( a b -- c )) call-effect"
+ }
+} ;
HELP: execute-effect
{ $values { "word" word } { "effect" effect } }
-{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
+{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." }
+{ $examples
+ "The following two lines are equivalent:"
+ { $code
+ "execute( a b -- c )"
+ "(( a b -- c )) execute-effect"
+ }
+} ;
HELP: execute-effect-unsafe
{ $values { "word" word } { "effect" effect } }
-USING: effects tools.test prettyprint accessors sequences ;
+USING: effects kernel tools.test prettyprint accessors
+quotations sequences ;
IN: effects.tests
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
[ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test
[ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test
[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test
+
+[ { object object } ] [ (( a b -- )) effect-in-types ] unit-test
+[ { object sequence } ] [ (( a b: sequence -- )) effect-in-types ] unit-test
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser math.order namespaces make sequences strings
-words assocs combinators accessors arrays ;
+words assocs combinators accessors arrays quotations ;
IN: effects
TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
+GENERIC: effect-length ( obj -- n )
+M: sequence effect-length length ;
+M: integer effect-length ;
+
: <effect> ( in out -- effect )
dup { "*" } sequence= [ drop { } t ] [ f ] if
effect boa ;
: effect-height ( effect -- n )
- [ out>> length ] [ in>> length ] bi - ; inline
+ [ out>> effect-length ] [ in>> effect-length ] bi - ; inline
: effect<= ( effect1 effect2 -- ? )
{
{ [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] }
- { [ 2dup [ in>> length ] bi@ > ] [ f ] }
+ { [ 2dup [ in>> effect-length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ]
} cond 2nip ; inline
: effect= ( effect1 effect2 -- ? )
- [ [ in>> length ] bi@ = ]
- [ [ out>> length ] bi@ = ]
+ [ [ in>> effect-length ] bi@ = ]
+ [ [ out>> effect-length ] bi@ = ]
[ [ terminated?>> ] bi@ = ]
2tri and and ;
")" %
] "" make ;
+GENERIC: effect>type ( obj -- type )
+M: object effect>type drop object ;
+M: word effect>type ;
+! attempting to specialize on callable breaks compiling
+! M: effect effect>type drop callable ;
+M: pair effect>type second effect>type ;
+
GENERIC: stack-effect ( word -- effect/f )
M: word stack-effect "declared-effect" word-prop ;
stack-effect effect-height ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
- in>> length cut* ;
+ in>> effect-length cut* ;
: shuffle-mapping ( effect -- mapping )
[ out>> ] [ in>> ] bi [ index ] curry map ;
over terminated?>> [
drop
] [
- [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
- [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
+ [ [ [ in>> effect-length ] [ out>> effect-length ] bi ] [ in>> effect-length ] bi* swap [-] + ]
+ [ [ out>> effect-length ] [ [ in>> effect-length ] [ out>> effect-length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri
+ [ [ [ "obj" ] replicate ] bi@ ] dip
effect boa
] if ; inline
+
+: effect-in-types ( effect -- input-types )
+ in>> [ effect>type ] map ;
+: effect-out-types ( effect -- input-types )
+ out>> [ effect>type ] map ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: lexer sets sequences kernel splitting effects
-combinators arrays ;
+combinators arrays vocabs.parser classes ;
IN: effects.parser
DEFER: parse-effect
dup { f "(" "((" } member? [ bad-effect ] [
":" ?tail [
scan {
- { "(" [ ")" parse-effect ] }
- { f [ ")" unexpected-eof ] }
+ { [ dup "(" = ] [ drop ")" parse-effect ] }
+ { [ dup search class? ] [ search ] }
+ { [ dup f = ] [ ")" unexpected-eof ] }
[ bad-effect ]
- } case 2array
+ } cond 2array
] when
] if
] if ;
-USING: tools.test math math.functions math.constants generic.standard
-generic.single strings sequences arrays kernel accessors words
-specialized-arrays.double byte-arrays bit-arrays parser namespaces
-make quotations stack-checker vectors growable hashtables sbufs
-prettyprint byte-vectors bit-vectors specialized-vectors.double
+USING: tools.test math math.functions math.constants
+generic.standard generic.single strings sequences arrays kernel
+accessors words byte-arrays bit-arrays parser namespaces make
+quotations stack-checker vectors growable hashtables sbufs
+prettyprint byte-vectors bit-vectors specialized-vectors
definitions generic sets graphs assocs grouping see eval ;
+SPECIALIZED-VECTOR: double
IN: generic.single.tests
GENERIC: lo-tag-test ( obj -- obj' )
"and"
{ $code "[ [ reverse % ] each ] \"\" make" }
"is equivalent to"
-{ $code "[ [ reverse ] map concat" }
+{ $code "[ reverse ] map concat" }
{ $heading "Utilities for simple make patterns" }
"Sometimes, an existing word already implements a specific " { $link make } " usage. For example, " { $link suffix } " is equivalent to the following, with the added caveat that the below example always outputs an array:"
{ $code "[ , % ] { } make" }
HELP: %
{ $values { "seq" sequence } }
-{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ;
\ No newline at end of file
+{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ;
HELP: float>= ( x y -- ? )
{ $values { "x" float } { "y" float } { "?" "a boolean" } }
-{ $description "Primitive version of " { $link >= } "." }
-{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link >= } " instead." } ;
+{ $description "Primitive version of " { $link u>= } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ;
-ARTICLE: "floats" "Floats"
-{ $subsection float }
-"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums."
+HELP: float-u< ( x y -- ? )
+{ $values { "x" float } { "y" float } { "?" "a boolean" } }
+{ $description "Primitive version of " { $link u< } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u< } " instead." } ;
+
+HELP: float-u<= ( x y -- ? )
+{ $values { "x" float } { "y" float } { "?" "a boolean" } }
+{ $description "Primitive version of " { $link u<= } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u<= } " instead." } ;
+
+HELP: float-u> ( x y -- ? )
+{ $values { "x" float } { "y" float } { "?" "a boolean" } }
+{ $description "Primitive version of " { $link u> } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u> } " instead." } ;
+
+HELP: float-u>= ( x y -- ? )
+{ $values { "x" float } { "y" float } { "?" "a boolean" } }
+{ $description "Primitive version of " { $link u>= } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ;
+
+ARTICLE: "math.floats.compare" "Floating point comparison operations"
+"In mathematics, real numbers are linearly ordered; for any two numbers " { $snippet "a" } " and " { $snippet "b" } ", exactly one of the following is true:"
+{ $code
+ "a < b"
+ "a = b"
+ "a > b"
+}
+"With floating point values, there is a fourth possibility; " { $snippet "a" } " and " { $snippet "b" } " may be " { $emphasis "unordered" } ". This happens if one or both values are Not-a-Number values."
$nl
-"Introducing a floating point number in a computation forces the result to be expressed in floating point."
-{ $example "5/4 1/2 + ." "1+3/4" }
-{ $example "5/4 0.5 + ." "1.75" }
-"Integers and rationals can be converted to floats:"
-{ $subsection >float }
-"Two real numbers can be divided yielding a float result:"
-{ $subsection /f }
+"All comparison operators, including " { $link number= } ", return " { $link f } " in the unordered case (and in particular, this means that a NaN is not equal to itself)."
+$nl
+"The " { $emphasis "ordered" } " comparison operators set floating point exception flags if the result of the comparison is unordered. The standard comparison operators (" { $link < } ", " { $link <= } ", " { $link > } ", " { $link >= } ") perform ordered comparisons."
+$nl
+"The " { $link number= } " operation performs an unordered comparison. The following set of operators also perform unordered comparisons:"
+{ $subsection u< }
+{ $subsection u<= }
+{ $subsection u> }
+{ $subsection u>= }
+"A word to check if two values are unordered with respect to each other:"
+{ $subsection unordered? }
+"To test for floating point exceptions, use the " { $vocab-link "math.floats.env" } " vocabulary."
+$nl
+"If neither input to a comparison operator is a floating point value, then " { $link u< } ", " { $link u<= } ", " { $link u> } " and " { $link u>= } " are equivalent to the ordered operators." ;
+
+ARTICLE: "math.floats.bitwise" "Bitwise operations on floats"
"Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes."
{ $subsection float>bits }
{ $subsection double>bits }
{ $subsection fp-snan? }
{ $subsection fp-infinity? }
{ $subsection fp-nan-payload }
-"Comparing two floating point numbers:"
+"Comparing two floating point numbers for bitwise equality:"
{ $subsection fp-bitwise= }
-{ $see-also "syntax-floats" } ;
+{ $see-also POSTPONE: NAN: } ;
+
+ARTICLE: "floats" "Floats"
+{ $subsection float }
+"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums."
+$nl
+"Introducing a floating point number in a computation forces the result to be expressed in floating point."
+{ $example "5/4 1/2 + ." "1+3/4" }
+{ $example "5/4 0.5 + ." "1.75" }
+"Floating point literal syntax is documented in " { $link "syntax-floats" } "."
+$nl
+"Integers and rationals can be converted to floats:"
+{ $subsection >float }
+"Two real numbers can be divided yielding a float result:"
+{ $subsection /f }
+{ $subsection "math.floats.bitwise" }
+{ $subsection "math.floats.compare" }
+"The " { $vocab-link "math.floats.env" } " vocabulary provides functionality for controlling floating point exceptions, rounding modes, and denormal behavior." ;
ABOUT: "floats"
[ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
[ 5 ] [ 10.5 1.9 /i ] unit-test
+
+[ t ] [ 0/0. 0/0. unordered? ] unit-test
+[ t ] [ 1.0 0/0. unordered? ] unit-test
+[ t ] [ 0/0. 1.0 unordered? ] unit-test
+[ f ] [ 1.0 1.0 unordered? ] unit-test
+
+[ t ] [ -0.0 fp-sign ] unit-test
+[ t ] [ -1.0 fp-sign ] unit-test
+[ f ] [ 0.0 fp-sign ] unit-test
+[ f ] [ 1.0 fp-sign ] unit-test
+
+[ t ] [ -0.0 abs 0.0 fp-bitwise= ] unit-test
+[ 1.5 ] [ -1.5 abs ] unit-test
+[ 1.5 ] [ 1.5 abs ] unit-test
USING: kernel math math.private ;
IN: math.floats.private
+: float-unordered? ( x y -- ? ) [ fp-nan? ] bi@ or ;
+: 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
M: float equal? over float? [ float= ] [ 2drop f ] if ; inline
M: float number= float= ; inline
-M: float < float< ; inline
+M: float < float< ; inline
M: float <= float<= ; inline
-M: float > float> ; inline
+M: float > float> ; inline
M: float >= float>= ; inline
+M: float unordered? float-unordered? ; inline
+M: float u< float-u< ; inline
+M: float u<= float-u<= ; inline
+M: float u> float-u> ; inline
+M: float u>= float-u>= ; inline
+
M: float + float+ ; inline
M: float - float- ; inline
M: float * float* ; inline
double>bits 52 2^ 1 - bitand ; inline
M: float fp-nan?
- dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline
+ dup float= not ;
M: float fp-qnan?
dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? not ] [ drop f ] if ; inline
M: float fp-infinity?
dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
-M: float next-float ( m -- n )
+M: float next-float
double>bits
dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
] if
] if ; inline
-M: float prev-float ( m -- n )
+M: float prev-float
double>bits
dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
1 - bits>double ! positive non-zero
] if
] if ; inline
+
+M: float fp-sign double>bits 63 bit? ; inline
+
+M: float abs double>bits 63 2^ bitnot bitand bits>double ; inline
-! 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
M: fixnum > fixnum> ; inline
M: fixnum >= fixnum>= ; inline
+M: fixnum u< fixnum< ; inline
+M: fixnum u<= fixnum<= ; inline
+M: fixnum u> fixnum> ; inline
+M: fixnum u>= fixnum>= ; inline
+
M: fixnum + fixnum+ ; inline
M: fixnum - fixnum- ; inline
M: fixnum * fixnum* ; inline
M: bignum > bignum> ; inline
M: bignum >= bignum>= ; inline
+M: bignum u< bignum< ; inline
+M: bignum u<= bignum<= ; inline
+M: bignum u> bignum> ; inline
+M: bignum u>= bignum>= ; inline
+
M: bignum + bignum+ ; inline
M: bignum - bignum- ; inline
M: bignum * bignum* ; inline
HELP: number=
{ $values { "x" number } { "y" number } { "?" "a boolean" } }
{ $description "Tests if two numbers have the same numeric value." }
-{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers." }
+{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers."
+$nl
+"This word performs an unordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." }
{ $examples
{ $example "USING: math prettyprint ;" "3.0 3 number= ." "t" }
{ $example "USING: kernel math prettyprint ;" "3.0 3 = ." "f" }
HELP: <
{ $values { "x" real } { "y" real } { "?" boolean } }
-{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } ;
+{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." }
+{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: <=
{ $values { "x" real } { "y" real } { "?" boolean } }
-{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } ;
+{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." }
+{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: >
{ $values { "x" real } { "y" real } { "?" boolean } }
-{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } ;
+{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." }
+{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: >=
{ $values { "x" real } { "y" real } { "?" boolean } }
-{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
+{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." }
+{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
+
+HELP: unordered?
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is unordered with respect to " { $snippet "y" } ". This can only occur if one or both values is a floating-point Not-a-Number value." } ;
+HELP: u<
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." }
+{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link < } ". See " { $link "math.floats.compare" } " for an explanation." } ;
+
+HELP: u<=
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." }
+{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link <= } ". See " { $link "math.floats.compare" } " for an explanation." } ;
+
+HELP: u>
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." }
+{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link > } ". See " { $link "math.floats.compare" } " for an explanation." } ;
+
+HELP: u>=
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." }
+{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link >= } ". See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: +
{ $values { "x" number } { "y" number } { "z" number } }
{ "x" float } { "y" float }
{ "?" boolean }
}
-{ $description "Compares two floating point numbers for bit equality." } ;
+{ $description "Compares two floating point numbers for bit equality." }
+{ $notes "Unlike " { $link = } " or " { $link number= } ", this word will consider NaNs with equal payloads to be equal, and positive zero and negative zero to be not equal." }
+{ $examples
+ "Not-a-number equality:"
+ { $example
+ "USING: kernel math prettyprint ;"
+ "0.0 0.0 / dup number= ."
+ "f"
+ }
+ { $example
+ "USING: kernel math prettyprint ;"
+ "0.0 0.0 / dup fp-bitwise= ."
+ "t"
+ }
+ "Signed zero equality:"
+ { $example
+ "USING: math prettyprint ;"
+ "-0.0 0.0 fp-bitwise= ."
+ "f"
+ }
+ { $example
+ "USING: math prettyprint ;"
+ "-0.0 0.0 number= ."
+ "t"
+ }
+} ;
HELP: fp-special?
{ $values { "x" real } { "?" "a boolean" } }
{ $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" }
} ;
+HELP: fp-sign
+{ $values { "x" float } { "?" "a boolean" } }
+{ $description "Outputs the sign bit of " { $snippet "x" } ". For ordered non-zero values, this is equivalent to calling " { $snippet "0 <" } ". For zero values, this outputs the zero's sign bit." } ;
+
HELP: fp-nan-payload
{ $values { "x" real } { "bits" integer } }
{ $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ;
{ $subsection 2/ }
{ $subsection 2^ }
{ $subsection bit? }
+"Advanced topics:"
{ $subsection "math.bitwise" }
{ $subsection "math.bits" }
{ $see-also "booleans" } ;
[ -0.0 ] [ 0.0 prev-float ] unit-test
[ t ] [ 1.0 dup prev-float > ] unit-test
[ t ] [ -1.0 dup prev-float > ] unit-test
+
+[ f ] [ 0/0. 0/0. = ] unit-test
+[ f ] [ 0/0. 1.0 = ] unit-test
+[ f ] [ 0/0. 1/0. = ] unit-test
+[ f ] [ 0/0. -1/0. = ] unit-test
+
+[ f ] [ 0/0. 0/0. = ] unit-test
+[ f ] [ 1.0 0/0. = ] unit-test
+[ f ] [ -1/0. 0/0. = ] unit-test
+[ f ] [ 1/0. 0/0. = ] unit-test
+
+[ f ] [ 0/0. 0/0. < ] unit-test
+[ f ] [ 0/0. 1.0 < ] unit-test
+[ f ] [ 0/0. 1/0. < ] unit-test
+[ f ] [ 0/0. -1/0. < ] unit-test
+
+[ f ] [ 0/0. 0/0. <= ] unit-test
+[ f ] [ 0/0. 1.0 <= ] unit-test
+[ f ] [ 0/0. 1/0. <= ] unit-test
+[ f ] [ 0/0. -1/0. <= ] unit-test
+
+[ f ] [ 0/0. 0/0. > ] unit-test
+[ f ] [ 1.0 0/0. > ] unit-test
+[ f ] [ -1/0. 0/0. > ] unit-test
+[ f ] [ 1/0. 0/0. > ] unit-test
+
+[ f ] [ 0/0. 0/0. >= ] unit-test
+[ f ] [ 1.0 0/0. >= ] unit-test
+[ f ] [ -1/0. 0/0. >= ] unit-test
+[ f ] [ 1/0. 0/0. >= ] unit-test
+
+
-! Copyright (C) 2003, 2009 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private ;
IN: math
MATH: > ( x y -- ? ) foldable
MATH: >= ( x y -- ? ) foldable
+MATH: unordered? ( x y -- ? ) foldable
+MATH: u< ( x y -- ? ) foldable
+MATH: u<= ( x y -- ? ) foldable
+MATH: u> ( x y -- ? ) foldable
+MATH: u>= ( x y -- ? ) foldable
+
+M: object unordered? 2drop f ;
+
MATH: + ( x y -- z ) foldable
MATH: - ( x y -- z ) foldable
MATH: * ( x y -- z ) foldable
GENERIC: fp-snan? ( x -- ? )
GENERIC: fp-infinity? ( x -- ? )
GENERIC: fp-nan-payload ( x -- bits )
+GENERIC: fp-sign ( x -- ? )
M: object fp-special? drop f ; inline
M: object fp-nan? drop f ; inline
M: object fp-qnan? drop f ; inline
M: object fp-snan? drop f ; inline
M: object fp-infinity? drop f ; inline
-M: object fp-nan-payload drop f ; inline
: <fp-nan> ( payload -- nan )
HEX: 7ff0000000000000 bitor bits>double ; inline
} ;
HELP: max
-{ $values { "x" real } { "y" real } { "z" real } }
-{ $description "Outputs the greatest of two real numbers." } ;
+{ $values { "x" object } { "y" object } { "z" object } }
+{ $description "Outputs the greatest of two ordered values." }
+{ $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ;
HELP: min
-{ $values { "x" real } { "y" real } { "z" real } }
-{ $description "Outputs the smallest of two real numbers." } ;
+{ $values { "x" object } { "y" object } { "z" object } }
+{ $description "Outputs the smallest of two ordered values." }
+{ $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ;
HELP: clamp
-{ $values { "x" real } { "min" real } { "max" real } { "y" real } }
+{ $values { "x" object } { "min" object } { "max" object } { "y" object } }
{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or outputs one of the endpoints." } ;
HELP: between?
-{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
+{ $values { "x" object } { "y" object } { "z" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
HELP: before?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: before=?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after=?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
} ;
ARTICLE: "math.order" "Linear order protocol"
-"Some classes have an intrinsic order amongst instances:"
+"Some classes define an intrinsic order amongst instances. This includes numbers, sequences (in particular, strings), and words."
{ $subsection <=> }
{ $subsection >=< }
{ $subsection compare }
{ $subsection before? }
{ $subsection after=? }
{ $subsection before=? }
+"Minimum, maximum, clamping:"
+{ $subsection min }
+{ $subsection max }
+{ $subsection clamp }
"Out of the above generic words, it suffices to implement " { $link <=> } " alone. The others may be provided as an optimization."
{ $subsection "math.order.example" }
{ $see-also "sequences-sorting" } ;
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 -- ? )
ARTICLE: "number-strings" "Converting between numbers and strings"
"These words only convert between real numbers and strings. Complex numbers are constructed by the parser (" { $link "parser" } ") and printed by the prettyprinter (" { $link "prettyprint" } ")."
$nl
-"Note that only integers can be converted to and from strings using a representation other than base 10. Calling a word such as " { $link >oct } " on a float will give a result in base 10."
+"Integers can be converted to and from arbitrary bases. Floating point numbers can only be converted to and from base 10 and 16."
$nl
"Converting numbers to strings:"
{ $subsection number>string }
HELP: >hex
{ $values { "n" real } { "str" string } }
-{ $description "Outputs a string representation of a number using base 16." } ;
+{ $description "Outputs a string representation of a number using base 16." }
+{ $examples
+ { $example
+ "USING: math.parser prettyprint ;"
+ "3735928559 >hex ."
+ "\"deadbeef\""
+ }
+ { $example
+ "USING: math.parser prettyprint ;"
+ "-15.5 >hex ."
+ "\"-1.fp3\""
+ }
+} ;
HELP: string>float ( str -- n/f )
{ $values { "str" string } { "n/f" "a real number or " { $link f } } }
-USING: kernel math math.parser sequences tools.test ;
+USING: kernel literals math math.parser sequences tools.test ;
IN: math.parser.tests
[ f ]
[ "e" string>number ]
unit-test
-[ 100000 ]
-[ "100,000" string>number ]
-unit-test
+[ 100000 ] [ "100,000" string>number ] unit-test
-[ 100000.0 ]
-[ "100,000.0" string>number ]
-unit-test
+[ 100000.0 ] [ "100,000.0" string>number ] unit-test
+
+[ f ] [ "," string>number ] unit-test
+[ f ] [ "-," string>number ] unit-test
+[ f ] [ "1," string>number ] unit-test
+[ f ] [ "-1," string>number ] unit-test
+[ f ] [ ",2" string>number ] unit-test
+[ f ] [ "-,2" string>number ] unit-test
+
+[ 2.0 ] [ "2." string>number ] unit-test
+
+[ 255 ] [ "ff" hex> ] unit-test
[ "100.0" ]
[ "1.0e2" string>number number>string ]
[ "-3/4" ] [ -3/4 number>string ] unit-test
[ "-1-1/4" ] [ -5/4 number>string ] unit-test
+
+[ "1.0p0" ] [ 1.0 >hex ] unit-test
+[ "1.8p2" ] [ 6.0 >hex ] unit-test
+[ "1.8p-2" ] [ 0.375 >hex ] unit-test
+[ "-1.8p2" ] [ -6.0 >hex ] unit-test
+[ "1.8p10" ] [ 1536.0 >hex ] unit-test
+[ "0.0" ] [ 0.0 >hex ] unit-test
+[ "1.0p-1074" ] [ 1 bits>double >hex ] unit-test
+[ "-0.0" ] [ -0.0 >hex ] unit-test
+
+[ 1.0 ] [ "1.0" hex> ] unit-test
+[ 15.5 ] [ "f.8" hex> ] unit-test
+[ 15.53125 ] [ "f.88" hex> ] unit-test
+[ -15.5 ] [ "-f.8" hex> ] unit-test
+[ 15.5 ] [ "f.8p0" hex> ] unit-test
+[ -15.5 ] [ "-f.8p0" hex> ] unit-test
+[ 62.0 ] [ "f.8p2" hex> ] unit-test
+[ 3.875 ] [ "f.8p-2" hex> ] unit-test
+[ $[ 1 bits>double ] ] [ "1.0p-1074" hex> ] unit-test
+[ 0.0 ] [ "1.0p-1075" hex> ] unit-test
+[ 1/0. ] [ "1.0p1024" hex> ] unit-test
+[ -1/0. ] [ "-1.0p1024" hex> ] unit-test
+
string>natural
] if ; inline
-: string>float ( str -- n/f )
+: dec>float ( str -- n/f )
[ CHAR: , eq? not ] filter
>byte-array 0 suffix (string>float) ;
+: hex>float-parts ( str -- neg? mantissa-str expt )
+ "-" ?head swap "p" split1 [ 10 base> ] [ 0 ] if* ;
+
+: make-mantissa ( str -- bits )
+ 16 base> dup log2 52 swap - shift ;
+
+: combine-hex-float-parts ( neg? mantissa expt -- float )
+ dup 2046 > [ 2drop -1/0. 1/0. ? ] [
+ dup 0 <= [ 1 - shift 0 ] when
+ [ HEX: 8000,0000,0000,0000 0 ? ]
+ [ 52 2^ 1 - bitand ]
+ [ 52 shift ] tri* bitor bitor
+ bits>double
+ ] if ;
+
+: hex>float ( str -- n/f )
+ hex>float-parts
+ [ "." split1 [ append make-mantissa ] [ drop 16 base> log2 ] 2bi ]
+ [ + 1023 + ] bi*
+ combine-hex-float-parts ;
+
+: base>float ( str base -- n/f )
+ {
+ { 16 [ hex>float ] }
+ [ drop dec>float ]
+ } case ;
+
+: number-char? ( char -- ? )
+ "0123456789ABCDEFabcdef." member? ;
+
+: numeric-looking? ( str -- ? )
+ "-" ?head drop
+ dup empty? [ drop f ] [
+ dup first number-char? [
+ last number-char?
+ ] [ drop f ] if
+ ] if ;
+
PRIVATE>
+: string>float ( str -- n/f )
+ 10 base>float ;
+
: base> ( str radix -- n/f )
- over empty? [ 2drop f ] [
+ over numeric-looking? [
over [ "/." member? ] find nip {
{ CHAR: / [ string>ratio ] }
- { CHAR: . [ drop string>float ] }
+ { CHAR: . [ base>float ] }
[ drop string>integer ]
} case
- ] if ;
+ ] [ 2drop f ] if ;
: string>number ( str -- n/f ) 10 base> ;
: bin> ( str -- n/f ) 2 base> ;
[ ".0" append ]
} cond ;
-: float>string ( n -- str )
+<PRIVATE
+
+: mantissa-expt-normalize ( mantissa expt -- mantissa' expt' )
+ dup zero?
+ [ over log2 52 swap - [ shift 52 2^ 1 - bitand ] [ 1022 + - ] bi-curry bi* ]
+ [ 1023 - ] if ;
+
+: mantissa-expt ( float -- mantissa expt )
+ [ 52 2^ 1 - bitand ]
+ [ -0.0 double>bits bitnot bitand -52 shift ] bi
+ mantissa-expt-normalize ;
+
+: float>hex-sign ( bits -- str )
+ -0.0 double>bits bitand zero? "" "-" ? ;
+
+: float>hex-value ( mantissa -- str )
+ 16 >base [ CHAR: 0 = ] trim-tail [ "0" ] [ ] if-empty "1." prepend ;
+
+: float>hex-expt ( mantissa -- str )
+ 10 >base "p" prepend ;
+
+: float>hex ( n -- str )
+ double>bits
+ [ float>hex-sign ] [
+ mantissa-expt [ float>hex-value ] [ float>hex-expt ] bi*
+ ] bi 3append ;
+
+: float>decimal ( n -- str )
(float>string)
[ 0 = ] trim-tail >string
fix-float ;
+: float>base ( n base -- str )
+ {
+ { 16 [ float>hex ] }
+ [ drop float>decimal ]
+ } case ;
+
+PRIVATE>
+
+: float>string ( n -- str )
+ 10 float>base ;
+
M: float >base
- drop {
- { [ dup fp-nan? ] [ drop "0/0." ] }
- { [ dup 1/0. = ] [ drop "1/0." ] }
- { [ dup -1/0. = ] [ drop "-1/0." ] }
- { [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
- [ float>string ]
+ {
+ { [ over fp-nan? ] [ 2drop "0/0." ] }
+ { [ over 1/0. = ] [ 2drop "1/0." ] }
+ { [ over -1/0. = ] [ 2drop "-1/0." ] }
+ { [ over 0.0 fp-bitwise= ] [ 2drop "0.0" ] }
+ { [ over -0.0 fp-bitwise= ] [ 2drop "-0.0" ] }
+ [ float>base ]
} cond ;
: number>string ( n -- str ) 10 >base ;
ERROR: bad-number ;
+: scan-base ( base -- n )
+ scan swap base> [ bad-number ] unless* ;
+
: parse-base ( parsed base -- parsed )
- scan swap base> [ bad-number ] unless* parsed ;
+ scan-base parsed ;
SYMBOL: bootstrap-syntax
HELP: accumulate
{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } }
-{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence."
+{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
$nl
"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." }
{ $examples
[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
[ t ] [ 0 array-capacity? ] unit-test
-[ f ] [ -1 array-capacity? ] unit-test
\ No newline at end of file
+[ f ] [ -1 array-capacity? ] unit-test
INSTANCE: f immutable-sequence
-! Integers support the sequence protocol
+! Integers used to support the sequence protocol
M: integer length ; inline
M: integer nth-unsafe drop ; inline
: last-index-from ( obj i seq -- n )
rot [ = ] curry find-last-from drop ;
+<PRIVATE
+
: (indices) ( elt i obj accum -- )
[ swap [ = ] dip ] dip [ push ] 2curry when ; inline
+PRIVATE>
+
: indices ( obj seq -- indices )
swap V{ } clone
[ [ (indices) ] 2curry each-index ] keep ;
<PRIVATE
: generic-flip ( matrix -- newmatrix )
- [ dup first length [ length min ] reduce ] keep
+ [ dup first length [ length min ] reduce iota ] keep
[ [ nth-unsafe ] with { } map-as ] curry { } map-as ; inline
USE: arrays
: array-flip ( matrix -- newmatrix )
{ array } declare
- [ dup first array-length [ array-length min ] reduce ] keep
+ [ dup first array-length [ array-length min ] reduce iota ] keep
[ [ { array } declare array-nth ] with { } map-as ] curry { } map-as ;
PRIVATE>
"More information on ratios can be found in " { $link "rationals" } ;
ARTICLE: "syntax-floats" "Float syntax"
-"Floating point literals must contain a decimal point, and may contain an exponent:"
+"Floating point literals can be input in base 10 or 16. Base 10 literals must contain a decimal point, and may contain an exponent after " { $snippet "e" } ":"
{ $code
"10.5"
"-3.1456"
"7.e13"
"1.0e-5"
}
-"There are three special float values:"
+"Base 16 literals use " { $snippet "p" } " instead of " { $snippet "e" } " for the exponent, which is still decimal:"
+{ $example
+ "10.125 HEX: 1.44p3 = ."
+ "t"
+}
+"Syntax for special float values:"
{ $table
{ "Positive infinity" { $snippet "1/0." } }
{ "Negative infinity" { $snippet "-1/0." } }
{ "Not-a-number" { $snippet "0/0." } }
}
+"A Not-a-number with an arbitrary payload can also be parsed in:"
+{ $subsection POSTPONE: NAN: }
"More information on floats can be found in " { $link "floats" } "." ;
ARTICLE: "syntax-complex-numbers" "Complex number syntax"
{ $description "Parses a complex number given in rectangular form as a pair of real numbers. Literal complex numbers are terminated by " { $link POSTPONE: } } "." } ;
HELP: T{
-{ $syntax "T{ class slots... }" }
+{ $syntax "T{ class }" "T{ class f slot-values... }" "T{ class { slot-name slot-value } ... }" }
{ $values { "class" "a tuple class word" } { "slots" "slot values" } }
{ $description "Marks the beginning of a literal tuple."
$nl
{ $description "Adds an integer read from an binary literal to the parse tree." }
{ $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ;
+HELP: NAN:
+{ $syntax "NAN: payload" }
+{ $values { "payload" "64-bit hexadecimal integer" } }
+{ $description "Adds a floating point Not-a-Number literal to the parse tree." }
+{ $examples
+ { $example
+ "USE: prettyprint"
+ "NAN: 80000deadbeef ."
+ "NAN: 80000deadbeef"
+ }
+} ;
+
HELP: GENERIC:
{ $syntax "GENERIC: word ( stack -- effect )" }
{ $values { "word" "a new word to define" } }
HELP: execute(
{ $syntax "execute( stack -- effect )" }
-{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
+{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." }
+{ $examples
+ { $code
+ "IN: scratchpad"
+ ""
+ ": eat ( -- ) ; : sleep ( -- ) ; : hack ( -- ) ;"
+ "{ eat sleep hack } [ execute( -- ) ] each"
+ }
+} ;
{ POSTPONE: call( POSTPONE: execute( } related-words
"OCT:" [ 8 parse-base ] define-core-syntax
"BIN:" [ 2 parse-base ] define-core-syntax
+ "NAN:" [ 16 scan-base <fp-nan> parsed ] define-core-syntax
+
"f" [ f parsed ] define-core-syntax
"t" "syntax" lookup define-singleton-class
[ manifest get (>>current-vocab) ]
[ words>> <extra-words> (add-qualified) ] bi ;
+: with-current-vocab ( name quot -- )
+ manifest get clone manifest [
+ [ set-current-vocab ] dip call
+ ] with-variable ; inline
+
TUPLE: no-current-vocab ;
: no-current-vocab ( -- vocab )
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?
alien.marshall.private alien.strings byte-arrays classes
combinators combinators.short-circuit destructors fry
io.encodings.utf8 kernel libc sequences
-specialized-arrays.alien specialized-arrays.bool
-specialized-arrays.char specialized-arrays.double
-specialized-arrays.float specialized-arrays.int
-specialized-arrays.long specialized-arrays.longlong
-specialized-arrays.short specialized-arrays.uchar
-specialized-arrays.uint specialized-arrays.ulong
-specialized-arrays.ulonglong specialized-arrays.ushort strings
-unix.utilities vocabs.parser words libc.private struct-arrays
-locals generalizations math ;
+specialized-arrays strings unix.utilities vocabs.parser
+words libc.private locals generalizations math ;
+SPECIALIZED-ARRAY: bool
+SPECIALIZED-ARRAY: char
+SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: long
+SPECIALIZED-ARRAY: longlong
+SPECIALIZED-ARRAY: short
+SPECIALIZED-ARRAY: uchar
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: ulong
+SPECIALIZED-ARRAY: ulonglong
+SPECIALIZED-ARRAY: ushort
+SPECIALIZED-ARRAY: void*
IN: alien.marshall
<< primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
{ [ dup not ] [ ] }
{ [ dup byte-array? ] [ malloc-byte-array ] }
{ [ dup alien-wrapper? ] [ underlying>> ] }
- { [ dup struct-array? ] [ underlying>> ] }
} cond ;
: marshall-primitive ( n -- n )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.inline arrays
combinators fry functors kernel lexer libc macros math
-sequences specialized-arrays.alien libc.private
+sequences specialized-arrays libc.private
combinators.short-circuit ;
+SPECIALIZED-ARRAY: void*
IN: alien.marshall.private
: bool>arg ( ? -- 1/0/obj )
PRIVATE>
-: (run-benchmark) ( vocab -- time )
+: run-benchmark ( vocab -- time )
[ 5 ] dip '[ gc [ _ run ] benchmark ] replicate infimum ;
-: run-benchmark ( vocab -- )
+<PRIVATE
+
+: record-benchmark ( vocab -- )
[ "=== " write print flush ] [
- [ [ require ] [ (run-benchmark) ] [ ] tri timings ]
+ [ [ require ] [ run-benchmark ] [ ] tri timings ]
[ swap errors ]
recover get set-at
] bi ;
+PRIVATE>
+
: run-benchmarks ( -- timings errors )
[
V{ } clone timings set
V{ } clone errors set
"benchmark" child-vocab-names
[ find-vocab-root ] filter
- [ run-benchmark ] each
+ [ record-benchmark ] each
timings get
errors get
] with-scope ;
-USING: sequences hints kernel math specialized-arrays.int fry ;
+USING: sequences kernel math specialized-arrays fry ;
+SPECIALIZED-ARRAY: int
IN: benchmark.dawes
! Phil Dawes's performance problem
: count-ones ( int-array -- n ) [ 1 = ] count ; inline
-HINTS: count-ones int-array ;
-
: make-int-array ( -- int-array )
- 120000 [ 255 bitand ] int-array{ } map-as ;
+ 120000 [ 255 bitand ] int-array{ } map-as ; inline
: dawes-benchmark ( -- )
- make-int-array 200 swap '[ _ count-ones ] replicate drop ;
+ 200 make-int-array '[ _ count-ones ] replicate drop ;
MAIN: dawes-benchmark
USING: make math sequences splitting grouping
-kernel columns specialized-arrays.double bit-arrays ;
+kernel columns specialized-arrays bit-arrays ;
+SPECIALIZED-ARRAY: double
IN: benchmark.dispatch2
: sequences ( -- seq )
USING: sequences math mirrors splitting grouping
kernel make assocs alien.syntax columns
-specialized-arrays.double bit-arrays ;
+specialized-arrays bit-arrays ;
+SPECIALIZED-ARRAY: double
IN: benchmark.dispatch3
GENERIC: g ( obj -- str )
+++ /dev/null
-IN: benchmark.euler186
-USING: kernel project-euler.186 ;
-
-: euler186-benchmark ( -- )
- euler186 2325629 assert= ;
-
-MAIN: euler186-benchmark
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2
USING: math kernel io io.files locals multiline assocs sequences
-sequences.private benchmark.reverse-complement hints io.encodings.ascii
-byte-arrays specialized-arrays.double ;
+sequences.private benchmark.reverse-complement hints
+io.encodings.ascii byte-arrays specialized-arrays ;
+SPECIALIZED-ARRAY: double
IN: benchmark.fasta
CONSTANT: IM 139968
USING: math sequences kernel ;
IN: benchmark.gc1
-: gc1 ( -- ) 6000000 [ >bignum 1 + ] map drop ;
+: gc1 ( -- ) 10 [ 600000 [ >bignum 1 + ] map drop ] times ;
MAIN: gc1
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors fry kernel locals math math.constants
+math.functions math.vectors math.vectors.simd prettyprint
+combinators.smart sequences hints classes.struct
+specialized-arrays ;
+IN: benchmark.nbody-simd
+
+: solar-mass ( -- x ) 4 pi sq * ; inline
+CONSTANT: days-per-year 365.24
+
+STRUCT: body
+{ location double-4 }
+{ velocity double-4 }
+{ mass double } ;
+
+SPECIALIZED-ARRAY: body
+
+: <body> ( location velocity mass -- body )
+ [ days-per-year v*n ] [ solar-mass * ] bi* body <struct-boa> ; inline
+
+: <jupiter> ( -- body )
+ double-4{ 4.84143144246472090e+00 -1.16032004402742839e+00 -1.03622044471123109e-01 0.0 }
+ double-4{ 1.66007664274403694e-03 7.69901118419740425e-03 -6.90460016972063023e-05 0.0 }
+ 9.54791938424326609e-04
+ <body> ;
+
+: <saturn> ( -- body )
+ double-4{ 8.34336671824457987e+00 4.12479856412430479e+00 -4.03523417114321381e-01 0.0 }
+ double-4{ -2.76742510726862411e-03 4.99852801234917238e-03 2.30417297573763929e-05 0.0 }
+ 2.85885980666130812e-04
+ <body> ;
+
+: <uranus> ( -- body )
+ double-4{ 1.28943695621391310e+01 -1.51111514016986312e+01 -2.23307578892655734e-01 0.0 }
+ double-4{ 2.96460137564761618e-03 2.37847173959480950e-03 -2.96589568540237556e-05 0.0 }
+ 4.36624404335156298e-05
+ <body> ;
+
+: <neptune> ( -- body )
+ double-4{ 1.53796971148509165e+01 -2.59193146099879641e+01 1.79258772950371181e-01 0.0 }
+ double-4{ 2.68067772490389322e-03 1.62824170038242295e-03 -9.51592254519715870e-05 0.0 }
+ 5.15138902046611451e-05
+ <body> ;
+
+: <sun> ( -- body )
+ double-4{ 0 0 0 0 } double-4{ 0 0 0 0 } 1 <body> ;
+
+: offset-momentum ( body offset -- body )
+ vneg solar-mass v/n >>velocity ; inline
+
+: init-bodies ( bodies -- )
+ [ first ] [ [ [ velocity>> ] [ mass>> ] bi v*n ] [ v+ ] map-reduce ] bi
+ offset-momentum drop ; inline
+
+: <nbody-system> ( -- system )
+ [ <sun> <jupiter> <saturn> <uranus> <neptune> ]
+ body-array{ } output>sequence
+ dup init-bodies ; inline
+
+:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
+ bodies [| body i |
+ body each-quot call
+ bodies i 1 + tail-slice [
+ body pair-quot call
+ ] each
+ ] each-index ; inline
+
+: update-position ( body dt -- )
+ [ dup velocity>> ] dip '[ _ _ v*n v+ ] change-location drop ; inline
+
+: mag ( dt body other-body -- mag d )
+ [ location>> ] bi@ v- [ norm-sq dup sqrt * / ] keep ; inline
+
+:: update-velocity ( other-body body dt -- )
+ dt body other-body mag
+ [ [ body ] 2dip '[ other-body mass>> _ * _ n*v v- ] change-velocity drop ]
+ [ [ other-body ] 2dip '[ body mass>> _ * _ n*v v+ ] change-velocity drop ] 2bi ; inline
+
+: advance ( system dt -- )
+ [ '[ _ update-velocity ] [ drop ] each-pair ]
+ [ '[ _ update-position ] each ]
+ 2bi ; inline
+
+: inertia ( body -- e )
+ [ mass>> ] [ velocity>> norm-sq ] bi * 0.5 * ; inline
+
+: newton's-law ( other-body body -- e )
+ [ [ mass>> ] bi@ * ] [ [ location>> ] bi@ distance ] 2bi / ; inline
+
+: energy ( system -- x )
+ [ 0.0 ] dip [ newton's-law - ] [ inertia + ] each-pair ; inline
+
+: nbody ( n -- )
+ >fixnum
+ <nbody-system>
+ [ energy . ] [ '[ _ 0.01 advance ] times ] [ energy . ] tri ;
+
+: nbody-main ( -- ) 1000000 nbody ;
+
+MAIN: nbody-main
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors specialized-arrays.double fry kernel locals math
-math.constants math.functions math.vectors prettyprint combinators.smart
-sequences hints arrays ;
+USING: accessors specialized-arrays fry kernel locals math
+math.constants math.functions math.vectors prettyprint
+combinators.smart sequences hints arrays ;
+SPECIALIZED-ARRAY: double
IN: benchmark.nbody
: solar-mass ( -- x ) 4 pi sq * ; inline
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Factor port of the raytracer benchmark from
+! http://www.ffconsultancy.com/free/ray_tracer/languages.html
+
+USING: arrays accessors io io.files io.files.temp
+io.encodings.binary kernel math math.constants math.functions
+math.vectors math.vectors.simd math.parser make sequences
+sequences.private words hints classes.struct ;
+IN: benchmark.raytracer-simd
+
+! parameters
+
+! Normalized { -1 -3 2 }.
+CONSTANT: light
+ double-4{
+ -0.2672612419124244
+ -0.8017837257372732
+ 0.5345224838248488
+ 0.0
+ }
+
+CONSTANT: oversampling 4
+
+CONSTANT: levels 3
+
+CONSTANT: size 200
+
+: delta ( -- n ) epsilon sqrt ; inline
+
+TUPLE: ray { orig double-4 read-only } { dir double-4 read-only } ;
+
+C: <ray> ray
+
+TUPLE: hit { normal double-4 read-only } { lambda float read-only } ;
+
+C: <hit> hit
+
+GENERIC: intersect-scene ( hit ray scene -- hit )
+
+TUPLE: sphere { center double-4 read-only } { radius float read-only } ;
+
+C: <sphere> sphere
+
+: sphere-v ( sphere ray -- v )
+ [ center>> ] [ orig>> ] bi* v- ; inline
+
+: sphere-b ( v ray -- b )
+ dir>> v. ; inline
+
+: sphere-d ( sphere b v -- d )
+ [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline
+
+: -+ ( x y -- x-y x+y )
+ [ - ] [ + ] 2bi ; inline
+
+: sphere-t ( b d -- t )
+ -+ dup 0.0 <
+ [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
+
+: sphere-b&v ( sphere ray -- b v )
+ [ sphere-v ] [ nip ] 2bi
+ [ sphere-b ] [ drop ] 2bi ; inline
+
+: ray-sphere ( sphere ray -- t )
+ [ drop ] [ sphere-b&v ] 2bi
+ [ drop ] [ sphere-d ] 3bi
+ dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline
+
+: if-ray-sphere ( hit ray sphere quot -- hit )
+ #! quot: hit ray sphere l -- hit
+ [
+ [ ] [ swap ray-sphere nip ] [ 2drop lambda>> ] 3tri
+ [ drop ] [ < ] 2bi
+ ] dip [ 3drop ] if ; inline
+
+: sphere-n ( ray sphere l -- n )
+ [ [ orig>> ] [ dir>> ] bi ] [ center>> ] [ ] tri*
+ swap [ v*n ] dip v- v+ ; inline
+
+M: sphere intersect-scene ( hit ray sphere -- hit )
+ [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
+
+HINTS: M\ sphere intersect-scene { hit ray sphere } ;
+
+TUPLE: group < sphere { objs array read-only } ;
+
+: <group> ( objs bound -- group )
+ [ center>> ] [ radius>> ] bi rot group boa ; inline
+
+: make-group ( bound quot -- )
+ swap [ { } make ] dip <group> ; inline
+
+M: group intersect-scene ( hit ray group -- hit )
+ [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
+
+HINTS: M\ group intersect-scene { hit ray group } ;
+
+CONSTANT: initial-hit T{ hit f double-4{ 0.0 0.0 0.0 0.0 } 1/0. }
+
+: initial-intersect ( ray scene -- hit )
+ [ initial-hit ] 2dip intersect-scene ; inline
+
+: ray-o ( ray hit -- o )
+ [ [ orig>> ] [ normal>> delta v*n ] bi* ]
+ [ [ dir>> ] [ lambda>> ] bi* v*n ]
+ 2bi v+ v+ ; inline
+
+: sray-intersect ( ray scene hit -- ray )
+ swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline
+
+: ray-g ( hit -- g ) normal>> light v. ; inline
+
+: cast-ray ( ray scene -- g )
+ 2dup initial-intersect dup lambda>> 1/0. = [
+ 3drop 0.0
+ ] [
+ [ sray-intersect lambda>> 1/0. = ] keep swap
+ [ ray-g neg ] [ drop 0.0 ] if
+ ] if ; inline
+
+: create-center ( c r d -- c2 )
+ [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline
+
+DEFER: create ( level c r -- scene )
+
+: create-step ( level c r d -- scene )
+ over [ create-center ] dip 2.0 / [ 1 - ] 2dip create ;
+
+: create-offsets ( quot -- )
+ {
+ double-4{ -1.0 1.0 -1.0 0.0 }
+ double-4{ 1.0 1.0 -1.0 0.0 }
+ double-4{ -1.0 1.0 1.0 0.0 }
+ double-4{ 1.0 1.0 1.0 0.0 }
+ } swap each ; inline
+
+: create-bound ( c r -- sphere ) 3.0 * <sphere> ;
+
+: create-group ( level c r -- scene )
+ 2dup create-bound [
+ 2dup <sphere> ,
+ [ [ 3dup ] dip create-step , ] create-offsets 3drop
+ ] make-group ;
+
+: create ( level c r -- scene )
+ pick 1 = [ <sphere> nip ] [ create-group ] if ;
+
+: ss-point ( dx dy -- point )
+ [ oversampling /f ] bi@ 0.0 0.0 double-4-boa ;
+
+: ss-grid ( -- ss-grid )
+ oversampling [ oversampling [ ss-point ] with map ] map ;
+
+: ray-grid ( point ss-grid -- ray-grid )
+ [
+ [ v+ normalize double-4{ 0.0 0.0 -4.0 0.0 } swap <ray> ] with map
+ ] with map ;
+
+: ray-pixel ( scene point -- n )
+ ss-grid ray-grid [ 0.0 ] 2dip
+ [ [ swap cast-ray + ] with each ] with each ;
+
+: pixel-grid ( -- grid )
+ size reverse [
+ size [
+ [ size 0.5 * - ] bi@ swap size
+ 0.0 double-4-boa
+ ] with map
+ ] map ;
+
+: pgm-header ( w h -- )
+ "P5\n" % swap # " " % # "\n255\n" % ;
+
+: pgm-pixel ( n -- ) 255 * 0.5 + >fixnum , ;
+
+: ray-trace ( scene -- pixels )
+ pixel-grid [ [ ray-pixel ] with map ] with map ;
+
+: run ( -- string )
+ levels double-4{ 0.0 -1.0 0.0 0.0 } 1.0 create ray-trace [
+ size size pgm-header
+ [ [ oversampling sq / pgm-pixel ] each ] each
+ ] B{ } make ;
+
+: raytracer-main ( -- )
+ run "raytracer.pnm" temp-file binary set-file-contents ;
+
+MAIN: raytracer-main
! Factor port of the raytracer benchmark from
! http://www.ffconsultancy.com/free/ray_tracer/languages.html
-USING: arrays accessors specialized-arrays.double io io.files
-io.files.temp io.encodings.binary kernel math math.functions
-math.vectors math.parser make sequences sequences.private words
-hints ;
+USING: arrays accessors specialized-arrays io io.files
+io.files.temp io.encodings.binary kernel math math.constants
+math.functions math.vectors math.parser make sequences
+sequences.private words hints ;
+SPECIALIZED-ARRAY: double
IN: benchmark.raytracer
! parameters
CONSTANT: size 200
-CONSTANT: delta 1.4901161193847656E-8
+: delta ( -- n ) epsilon sqrt ; inline
TUPLE: ray { orig double-array read-only } { dir double-array read-only } ;
] with map ;
: ray-pixel ( scene point -- n )
- ss-grid ray-grid 0.0 -rot
+ ss-grid ray-grid [ 0.0 ] 2dip
[ [ swap cast-ray + ] with each ] with each ;
: pixel-grid ( -- grid )
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io math math.functions math.parser math.vectors
+math.vectors.simd sequences specialized-arrays ;
+SPECIALIZED-ARRAY: float-4
+IN: benchmark.simd-1
+
+: <point> ( n -- float-4 )
+ >float [ sin ] [ cos 3 * ] [ sin sq 2 / ] tri
+ 0.0 float-4-boa ; inline
+
+: make-points ( len -- points )
+ iota [ <point> ] float-4-array{ } map-as ; inline
+
+: normalize-points ( points -- )
+ [ normalize ] change-each ; inline
+
+: max-points ( points -- point )
+ [ ] [ vmax ] map-reduce ; inline
+
+: print-point ( point -- )
+ [ number>string ] { } map-as ", " join print ; inline
+
+: simd-benchmark ( len -- )
+ >fixnum make-points [ normalize-points ] [ max-points ] bi print-point ;
+
+: main ( -- )
+ 10 [ 500000 simd-benchmark ] times ;
+
+MAIN: main
! Factor port of
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
-USING: specialized-arrays.double kernel math math.functions
+USING: specialized-arrays kernel math math.functions
math.vectors sequences sequences.private prettyprint words hints
locals ;
+SPECIALIZED-ARRAY: double
IN: benchmark.spectral-norm
:: inner-loop ( u n quot -- seq )
--- /dev/null
+! 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
+specialized-arrays io ;
+IN: benchmark.struct-arrays
+
+STRUCT: point { x float } { y float } { z float } ;
+
+SPECIALIZED-ARRAY: point
+
+: 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-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 ( -- ) 10 [ 500000 struct-array-benchmark ] times ;
+
+MAIN: main
--- /dev/null
+! (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
! See http://factorcode.org/license.txt for BSD license.
USING: alien.accessors alien.c-types alien.syntax byte-arrays
destructors generalizations hints kernel libc locals math math.order
-sequences sequences.private ;
+sequences sequences.private classes.struct accessors ;
IN: benchmark.yuv-to-rgb
-C-STRUCT: yuv_buffer
- { "int" "y_width" }
- { "int" "y_height" }
- { "int" "y_stride" }
- { "int" "uv_width" }
- { "int" "uv_height" }
- { "int" "uv_stride" }
- { "void*" "y" }
- { "void*" "u" }
- { "void*" "v" } ;
+STRUCT: yuv_buffer
+ { y_width int }
+ { y_height int }
+ { y_stride int }
+ { uv_width int }
+ { uv_height int }
+ { uv_stride int }
+ { y void* }
+ { u void* }
+ { v void* } ;
:: fake-data ( -- rgb yuv )
[let* | w [ 1600 ]
h [ 1200 ]
- buffer [ "yuv_buffer" <c-object> ]
+ buffer [ yuv_buffer <struct> ]
rgb [ w h * 3 * <byte-array> ] |
- w buffer set-yuv_buffer-y_width
- h buffer set-yuv_buffer-y_height
- h buffer set-yuv_buffer-uv_height
- w buffer set-yuv_buffer-y_stride
- w buffer set-yuv_buffer-uv_stride
- w h * [ dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-y
- w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-u
- w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-v
rgb buffer
+ w >>y_width
+ h >>y_height
+ h >>uv_height
+ w >>y_stride
+ w >>uv_stride
+ w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y
+ w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u
+ w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v
] ;
: clamp ( n -- n )
255 min 0 max ; inline
: stride ( line yuv -- uvy yy )
- [ yuv_buffer-uv_stride swap 2/ * ] [ yuv_buffer-y_stride * ] 2bi ; inline
+ [ uv_stride>> swap 2/ * ] [ y_stride>> * ] 2bi ; inline
: compute-y ( yuv uvy yy x -- y )
- + >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline
+ + >fixnum nip swap y>> swap alien-unsigned-1 16 - ; inline
: compute-v ( yuv uvy yy x -- v )
- nip 2/ + >fixnum swap yuv_buffer-u swap alien-unsigned-1 128 - ; inline
+ nip 2/ + >fixnum swap u>> swap alien-unsigned-1 128 - ; inline
: compute-u ( yuv uvy yy x -- v )
- nip 2/ + >fixnum swap yuv_buffer-v swap alien-unsigned-1 128 - ; inline
+ nip 2/ + >fixnum swap v>> swap alien-unsigned-1 128 - ; inline
:: compute-yuv ( yuv uvy yy x -- y u v )
yuv uvy yy x compute-y
: yuv>rgb-row ( index rgb yuv y -- index )
over stride
- pick yuv_buffer-y_width
+ pick y_width>>
[ yuv>rgb-pixel ] with with with with each ; inline
: yuv>rgb ( rgb yuv -- )
[ 0 ] 2dip
- dup yuv_buffer-y_height
+ dup y_height>>
[ yuv>rgb-row ] with with each
drop ;
-HINTS: yuv>rgb byte-array byte-array ;
+HINTS: yuv>rgb byte-array yuv_buffer ;
: yuv>rgb-benchmark ( -- )
[ fake-data yuv>rgb ] with-destructors ;
[ 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
[ 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
USING: alien.c-types continuations destructors kernel
-opengl opengl.gl bunny.model specialized-arrays.float
-accessors ;
+opengl opengl.gl bunny.model specialized-arrays accessors ;
+SPECIALIZED-ARRAY: float
IN: bunny.fixed-pipeline
TUPLE: bunny-fixed-pipeline ;
http.client io io.encodings.ascii io.files io.files.temp kernel
math math.matrices math.parser math.vectors opengl
opengl.capabilities opengl.gl opengl.demo-support sequences
-splitting vectors words specialized-arrays.float
-specialized-arrays.uint ;
+splitting vectors words specialized-arrays ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: uint
IN: bunny.model
: numbers ( str -- seq )
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: alien arrays classes help.markup help.syntax kernel
-specialized-arrays.direct ;
-QUALIFIED: math
-IN: classes.c-types
-
-HELP: c-type-class
-{ $class-description "This metaclass encompasses the " { $link "classes.c-types" } "." } ;
-
-HELP: char
-{ $class-description "A signed one-byte integer quantity." } ;
-
-HELP: direct-array-of
-{ $values
- { "alien" c-ptr } { "len" math:integer } { "class" c-type-class }
- { "array" "a direct array" }
-}
-{ $description "Constructs one of the " { $link "specialized-arrays.direct" } " over " { $snippet "len" } " elements of type " { $snippet "class" } " located at the referenced location in raw memory." } ;
-
-HELP: int
-{ $class-description "A signed four-byte integer quantity." } ;
-
-HELP: long
-{ $class-description "A signed integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ;
-
-HELP: longlong
-{ $class-description "A signed eight-byte integer quantity." } ;
-
-HELP: short
-{ $class-description "A signed two-byte integer quantity." } ;
-
-HELP: complex-float
-{ $class-description "A single-precision complex floating point quantity." } ;
-
-HELP: complex-double
-{ $class-description "A double-precision complex floating point quantity. This is an alias for the Factor " { $link math:complex } " type." } ;
-
-HELP: float
-{ $class-description "A single-precision floating point quantity." } ;
-
-HELP: double
-{ $class-description "A double-precision floating point quantity. This is an alias for the Factor " { $link math:float } " type." } ;
-
-HELP: uchar
-{ $class-description "An unsigned one-byte integer quantity." } ;
-
-HELP: uint
-{ $class-description "An unsigned four-byte integer quantity." } ;
-
-HELP: ulong
-{ $class-description "An unsigned integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ;
-
-HELP: ulonglong
-{ $class-description "An unsigned eight-byte integer quantity." } ;
-
-HELP: ushort
-{ $class-description "An unsigned two-byte integer quantity." } ;
-
-HELP: bool
-{ $class-description "A boolean value. This is an alias to the Factor " { $link boolean } " class." } ;
-
-HELP: void*
-{ $class-description "A pointer to raw C memory. This is an alias to the Factor " { $link pinned-c-ptr } " class." } ;
-
-ARTICLE: "classes.c-types" "C type classes"
-"The " { $vocab-link "classes.c-types" } " vocabulary defines Factor classes that correspond to C types in the FFI."
-{ $subsection char }
-{ $subsection uchar }
-{ $subsection short }
-{ $subsection ushort }
-{ $subsection int }
-{ $subsection uint }
-{ $subsection long }
-{ $subsection ulong }
-{ $subsection longlong }
-{ $subsection ulonglong }
-{ $subsection float }
-{ $subsection double }
-{ $subsection complex-float }
-{ $subsection complex-double }
-{ $subsection bool }
-{ $subsection void* }
-"The vocabulary also provides a word for constructing " { $link "specialized-arrays.direct" } " of C types over raw memory:"
-{ $subsection direct-array-of } ;
-
-ABOUT: "classes.c-types"
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: alien alien.c-types classes classes.predicate kernel
-math.bitwise math.order namespaces sequences words
-specialized-arrays.direct.alien
-specialized-arrays.direct.bool
-specialized-arrays.direct.char
-specialized-arrays.direct.complex-double
-specialized-arrays.direct.complex-float
-specialized-arrays.direct.double
-specialized-arrays.direct.float
-specialized-arrays.direct.int
-specialized-arrays.direct.long
-specialized-arrays.direct.longlong
-specialized-arrays.direct.short
-specialized-arrays.direct.uchar
-specialized-arrays.direct.uint
-specialized-arrays.direct.ulong
-specialized-arrays.direct.ulonglong
-specialized-arrays.direct.ushort ;
-QUALIFIED: math
-IN: classes.c-types
-
-PREDICATE: char < math:fixnum
- HEX: -80 HEX: 7f between? ;
-
-PREDICATE: uchar < math:fixnum
- HEX: 0 HEX: ff between? ;
-
-PREDICATE: short < math:fixnum
- HEX: -8000 HEX: 7fff between? ;
-
-PREDICATE: ushort < math:fixnum
- HEX: 0 HEX: ffff between? ;
-
-PREDICATE: int < math:integer
- HEX: -8000,0000 HEX: 7fff,ffff between? ;
-
-PREDICATE: uint < math:integer
- HEX: 0 HEX: ffff,ffff between? ;
-
-PREDICATE: longlong < math:integer
- HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ;
-
-PREDICATE: ulonglong < math:integer
- HEX: 0 HEX: ffff,ffff,ffff,ffff between? ;
-
-UNION: double math:float ;
-UNION: complex-double math:complex ;
-
-UNION: bool boolean ;
-UNION: void* pinned-c-ptr ;
-
-UNION: float math:float ;
-UNION: complex-float math:complex ;
-
-SYMBOLS: long ulong long-bits ;
-
-<<
- "long" heap-size 8 =
- [
- \ long math:integer [ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ] define-predicate-class
- \ ulong math:integer [ HEX: 0 HEX: ffff,ffff,ffff,ffff between? ] define-predicate-class
- 64 \ long-bits set-global
- ] [
- \ long math:integer [ HEX: -8000,0000 HEX: 7fff,ffff between? ] define-predicate-class
- \ ulong math:integer [ HEX: 0 HEX: ffff,ffff between? ] define-predicate-class
- 32 \ long-bits set-global
- ] if
->>
-
-: set-class-c-type ( class initial c-type <direct-array> -- )
- [ "initial-value" set-word-prop ]
- [ c-type "class-c-type" set-word-prop ]
- [ "class-direct-array" set-word-prop ] tri-curry* tri ;
-
-: class-c-type ( class -- c-type )
- "class-c-type" word-prop ;
-: class-direct-array ( class -- <direct-array> )
- "class-direct-array" word-prop ;
-
-\ f f "void*" \ <direct-void*-array> set-class-c-type
-void* f "void*" \ <direct-void*-array> set-class-c-type
-pinned-c-ptr f "void*" \ <direct-void*-array> set-class-c-type
-bool f "bool" \ <direct-bool-array> set-class-c-type
-boolean f "bool" \ <direct-bool-array> set-class-c-type
-char 0 "char" \ <direct-char-array> set-class-c-type
-uchar 0 "uchar" \ <direct-uchar-array> set-class-c-type
-short 0 "short" \ <direct-short-array> set-class-c-type
-ushort 0 "ushort" \ <direct-ushort-array> set-class-c-type
-int 0 "int" \ <direct-int-array> set-class-c-type
-uint 0 "uint" \ <direct-uint-array> set-class-c-type
-long 0 "long" \ <direct-long-array> set-class-c-type
-ulong 0 "ulong" \ <direct-ulong-array> set-class-c-type
-longlong 0 "longlong" \ <direct-longlong-array> set-class-c-type
-ulonglong 0 "ulonglong" \ <direct-ulonglong-array> set-class-c-type
-float 0.0 "float" \ <direct-float-array> set-class-c-type
-double 0.0 "double" \ <direct-double-array> set-class-c-type
-complex-float C{ 0.0 0.0 } "complex-float" \ <direct-complex-float-array> set-class-c-type
-complex-double C{ 0.0 0.0 } "complex-double" \ <direct-complex-double-array> set-class-c-type
-
-char [ 8 bits 8 >signed ] "coercer" set-word-prop
-uchar [ 8 bits ] "coercer" set-word-prop
-short [ 16 bits 16 >signed ] "coercer" set-word-prop
-ushort [ 16 bits ] "coercer" set-word-prop
-int [ 32 bits 32 >signed ] "coercer" set-word-prop
-uint [ 32 bits ] "coercer" set-word-prop
-long [ [ bits ] [ >signed ] ] long-bits get-global prefix "coercer" set-word-prop
-ulong [ bits ] long-bits get-global prefix "coercer" set-word-prop
-longlong [ 64 bits 64 >signed ] "coercer" set-word-prop
-ulonglong [ 64 bits ] "coercer" set-word-prop
-
-PREDICATE: c-type-class < class
- "class-c-type" word-prop ;
-
-GENERIC: direct-array-of ( alien len class -- array ) inline
-
-M: c-type-class direct-array-of
- class-direct-array execute( alien len -- array ) ; inline
-
-M: c-type-class c-type class-c-type ;
-M: c-type-class c-type-align class-c-type c-type-align ;
-M: c-type-class c-type-getter class-c-type c-type-getter ;
-M: c-type-class c-type-setter class-c-type c-type-setter ;
-M: c-type-class c-type-boxer-quot class-c-type c-type-boxer-quot ;
-M: c-type-class c-type-unboxer-quot class-c-type c-type-unboxer-quot ;
-M: c-type-class heap-size class-c-type heap-size ;
-
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors assocs classes classes.struct kernel math
-prettyprint.backend prettyprint.custom prettyprint.sections
-see.private sequences words ;
-IN: classes.struct.prettyprint
-
-<PRIVATE
-
-: struct-definer-word ( class -- word )
- struct-slots dup length 2 >=
- [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
- [ drop \ STRUCT: ] if ;
-
-: struct>assoc ( struct -- assoc )
- [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
-
-PRIVATE>
-
-M: struct-class see-class*
- <colon dup struct-definer-word pprint-word dup pprint-word
- <block struct-slots [ pprint-slot ] each
- block> pprint-; block> ;
-
-M: struct pprint-delims
- drop \ S{ \ } ;
-
-M: struct >pprint-sequence
- [ class ] [ struct-slot-values ] bi class-slot-sequence ;
-
-M: struct pprint*
- [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: alien classes help.markup help.syntax kernel libc
-quotations slots ;
-IN: classes.struct
-
-HELP: <struct-boa>
-{ $values
- { "class" class }
-}
-{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
-
-HELP: <struct>
-{ $values
- { "class" class }
- { "struct" struct }
-}
-{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ;
-
-{ <struct> <struct-boa> malloc-struct memory>struct } related-words
-
-HELP: STRUCT:
-{ $syntax "STRUCT: class { slot type } { slot type } ... ;" }
-{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
-{ $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:"
-{ $list
-{ "Struct classes cannot have a superclass defined." }
-{ "The slots of a struct must all have a type declared. The type must be either another struct class, or one of the " { $link "classes.c-types" } "." }
-{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
-} } ;
-
-HELP: S{
-{ $syntax "S{ class slots... }" }
-{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
-{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
-
-HELP: UNION-STRUCT:
-{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
-{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
-{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
-
-HELP: define-struct-class
-{ $values
- { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
-}
-{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
-
-HELP: define-union-struct-class
-{ $values
- { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
-}
-{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ;
-
-HELP: malloc-struct
-{ $values
- { "class" class }
- { "struct" struct }
-}
-{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ;
-
-HELP: memory>struct
-{ $values
- { "ptr" c-ptr } { "class" class }
- { "struct" struct }
-}
-{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
-
-HELP: struct
-{ $class-description "The parent class of all struct types." } ;
-
-{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words
-
-HELP: struct-class
-{ $class-description "The metaclass of all " { $link struct } " classes." } ;
-
-ARTICLE: "classes.struct" "Struct classes"
-{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
-{ $subsection POSTPONE: STRUCT: }
-"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
-{ $subsection <struct> }
-{ $subsection <struct-boa> }
-{ $subsection malloc-struct }
-{ $subsection memory>struct }
-"Structs have literal syntax like tuples:"
-{ $subsection POSTPONE: S{ }
-"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
-{ $subsection POSTPONE: UNION-STRUCT: }
-;
-
-ABOUT: "classes.struct"
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors alien.c-types alien.structs.fields alien.syntax
-classes.c-types classes.struct combinators io.streams.string kernel
-libc literals math multiline namespaces prettyprint prettyprint.config
-see tools.test ;
-FROM: classes.c-types => float ;
-IN: classes.struct.tests
-
-STRUCT: struct-test-foo
- { x char }
- { y int initial: 123 }
- { z bool } ;
-
-STRUCT: struct-test-bar
- { w ushort initial: HEX: ffff }
- { foo struct-test-foo } ;
-
-[ 12 ] [ struct-test-foo heap-size ] unit-test
-[ 16 ] [ struct-test-bar heap-size ] unit-test
-[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
-[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
-
-[ 1 2 3 t ] [
- 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
- {
- [ w>> ]
- [ foo>> x>> ]
- [ foo>> y>> ]
- [ foo>> z>> ]
- } cleave
-] unit-test
-
-[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
-[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
-
-UNION-STRUCT: struct-test-float-and-bits
- { f float }
- { bits uint } ;
-
-[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
-[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
-
-[ ] [ struct-test-foo malloc-struct free ] unit-test
-
-[ "S{ struct-test-foo { y 7654 } }" ]
-[
- f boa-tuples?
- [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
- with-variable
-] unit-test
-
-[ "S{ struct-test-foo f 0 7654 f }" ]
-[
- t boa-tuples?
- [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
- with-variable
-] unit-test
-
-[ <" USING: classes.c-types classes.struct kernel ;
-IN: classes.struct.tests
-STRUCT: struct-test-foo
- { x char initial: 0 } { y int initial: 123 }
- { z boolean initial: f } ;
-"> ]
-[ [ struct-test-foo see ] with-string-writer ] unit-test
-
-[ <" USING: classes.c-types classes.struct ;
-IN: classes.struct.tests
-UNION-STRUCT: struct-test-float-and-bits
- { f float initial: 0.0 } { bits uint initial: 0 } ;
-"> ]
-[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
-
-[ {
- T{ field-spec
- { name "x" }
- { offset 0 }
- { type char }
- { reader x>> }
- { writer (>>x) }
- }
- T{ field-spec
- { name "y" }
- { offset 4 }
- { type int }
- { reader y>> }
- { writer (>>y) }
- }
- T{ field-spec
- { name "z" }
- { offset 8 }
- { type bool }
- { reader z>> }
- { writer (>>z) }
- }
-} ] [ "struct-test-foo" c-type fields>> ] unit-test
-
-[ {
- T{ field-spec
- { name "f" }
- { offset 0 }
- { type float }
- { reader f>> }
- { writer (>>f) }
- }
- T{ field-spec
- { name "bits" }
- { offset 0 }
- { type uint }
- { reader bits>> }
- { writer (>>bits) }
- }
-} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
-
-STRUCT: struct-test-ffi-foo
- { x int }
- { y int } ;
-
-LIBRARY: f-cdecl
-FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
-
-[ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays
-byte-arrays classes classes.c-types classes.parser classes.tuple
-classes.tuple.parser classes.tuple.private combinators
-combinators.smart fry generalizations generic.parser kernel
-kernel.private libc macros make math math.order parser
-quotations sequences slots slots.private struct-arrays words ;
-FROM: slots => reader-word writer-word ;
-IN: classes.struct
-
-! struct class
-
-TUPLE: struct
- { (underlying) c-ptr read-only } ;
-
-PREDICATE: struct-class < tuple-class
- \ struct subclass-of? ;
-
-: struct-slots ( struct -- slots )
- "struct-slots" word-prop ;
-
-! struct allocation
-
-M: struct >c-ptr
- 2 slot { c-ptr } declare ; inline
-
-: memory>struct ( ptr class -- struct )
- over c-ptr? [ swap \ c-ptr bad-slot-value ] unless
- tuple-layout <tuple> [ 2 set-slot ] keep ;
-
-: malloc-struct ( class -- struct )
- [ heap-size malloc ] keep memory>struct ; inline
-
-: (struct) ( class -- struct )
- [ heap-size <byte-array> ] keep memory>struct ; inline
-
-: <struct> ( class -- struct )
- dup "prototype" word-prop
- [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
-
-MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
- [
- [ <wrapper> \ (struct) [ ] 2sequence ]
- [
- struct-slots
- [ length \ ndip ]
- [ [ name>> setter-word 1quotation ] map \ spread ] bi
- ] bi
- ] [ ] output>sequence ;
-
-: pad-struct-slots ( values class -- values' class )
- [ struct-slots [ initial>> ] map over length tail append ] keep ;
-
-: (reader-quot) ( slot -- quot )
- [ class>> c-type-getter-boxer ]
- [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
-
-: (writer-quot) ( slot -- quot )
- [ class>> c-setter ]
- [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
-
-: (boxer-quot) ( class -- quot )
- '[ _ memory>struct ] ;
-
-: (unboxer-quot) ( class -- quot )
- drop [ >c-ptr ] ;
-
-M: struct-class boa>object
- swap pad-struct-slots
- [ (struct) ] [ struct-slots ] bi
- [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
-
-! Struct slot accessors
-
-GENERIC: struct-slot-values ( struct -- sequence )
-
-M: struct-class reader-quot
- nip (reader-quot) ;
-
-M: struct-class writer-quot
- nip (writer-quot) ;
-
-: struct-slot-values-quot ( class -- quot )
- struct-slots
- [ name>> reader-word 1quotation ] map
- \ cleave [ ] 2sequence
- \ output>array [ ] 2sequence ;
-
-: (define-struct-slot-values-method) ( class -- )
- [ \ struct-slot-values create-method-in ]
- [ struct-slot-values-quot ] bi define ;
-
-! Struct as c-type
-
-: slot>field ( slot -- field )
- field-spec new swap {
- [ name>> >>name ]
- [ offset>> >>offset ]
- [ class>> >>type ]
- [ name>> reader-word >>reader ]
- [ name>> writer-word >>writer ]
- } cleave ;
-
-: define-struct-for-class ( class -- )
- [
- {
- [ name>> ]
- [ "struct-size" word-prop ]
- [ "struct-align" word-prop ]
- [ struct-slots [ slot>field ] map ]
- } cleave
- (define-struct)
- ] [
- [ name>> c-type ]
- [ (unboxer-quot) >>unboxer-quot ]
- [ (boxer-quot) >>boxer-quot ] tri drop
- ] bi ;
-
-: align-offset ( offset class -- offset' )
- c-type-align align ;
-
-: struct-offsets ( slots -- size )
- 0 [
- [ class>> align-offset ] keep
- [ (>>offset) ] [ class>> heap-size + ] 2bi
- ] reduce ;
-
-: union-struct-offsets ( slots -- size )
- [ 0 >>offset class>> heap-size ] [ max ] map-reduce ;
-
-: struct-align ( slots -- align )
- [ class>> c-type-align ] [ max ] map-reduce ;
-
-M: struct-class c-type
- name>> c-type ;
-
-M: struct-class c-type-align
- "struct-align" word-prop ;
-
-M: struct-class c-type-getter
- drop [ swap <displaced-alien> ] ;
-
-M: struct-class c-type-setter
- [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
- '[ @ swap @ _ memcpy ] ;
-
-M: struct-class c-type-boxer-quot
- (boxer-quot) ;
-
-M: struct-class c-type-unboxer-quot
- (unboxer-quot) ;
-
-M: struct-class heap-size
- "struct-size" word-prop ;
-
-M: struct-class direct-array-of
- <direct-struct-array> ;
-
-! class definition
-
-: struct-prototype ( class -- prototype )
- [ heap-size <byte-array> ]
- [ memory>struct ]
- [ struct-slots ] tri
- [
- [ initial>> ]
- [ (writer-quot) ] bi
- over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
- ] each ;
-
-: (struct-word-props) ( class slots size align -- )
- [
- [ "struct-slots" set-word-prop ]
- [ define-accessors ] 2bi
- ]
- [ "struct-size" set-word-prop ]
- [ "struct-align" set-word-prop ] tri-curry*
- [ tri ] 3curry
- [ dup struct-prototype "prototype" set-word-prop ]
- [ (define-struct-slot-values-method) ] tri ;
-
-: check-struct-slots ( slots -- )
- [ class>> c-type drop ] each ;
-
-: (define-struct-class) ( class slots offsets-quot -- )
- [ drop struct f define-tuple-class ]
- swap '[
- make-slots dup
- [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
- (struct-word-props)
- ]
- [ drop define-struct-for-class ] 2tri ; inline
-
-: define-struct-class ( class slots -- )
- [ struct-offsets ] (define-struct-class) ;
-
-: define-union-struct-class ( class slots -- )
- [ union-struct-offsets ] (define-struct-class) ;
-
-: parse-struct-definition ( -- class slots )
- CREATE-CLASS [ parse-tuple-slots ] { } make ;
-
-SYNTAX: STRUCT:
- parse-struct-definition define-struct-class ;
-SYNTAX: UNION-STRUCT:
- parse-struct-definition define-union-struct-class ;
-
-USING: vocabs vocabs.loader ;
-
-"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
-
-SYNTAX: S{
- scan-word dup struct-slots parse-tuple-literal-slots parsed ;
! (c)2009 Joe Groff bsd license
-USING: accessors alien.c-types arrays combinators combinators.short-circuit
-game-worlds gpu gpu.buffers gpu.util.wasd gpu.framebuffers gpu.render
-gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images
-images.loader io io.encodings.ascii io.files io.files.temp
-kernel math math.matrices math.parser math.vectors
-method-chains sequences specialized-arrays.direct.float
-specialized-arrays.float specialized-vectors.uint splitting
-struct-vectors threads ui ui.gadgets ui.gadgets.worlds
-ui.pixel-formats ;
+USING: accessors alien.c-types arrays classes.struct combinators
+combinators.short-circuit game-worlds gpu gpu.buffers
+gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
+gpu.textures gpu.util grouping http.client images images.loader
+io io.encodings.ascii io.files io.files.temp kernel math
+math.matrices math.parser math.vectors method-chains sequences
+splitting threads ui ui.gadgets ui.gadgets.worlds
+ui.pixel-formats specialized-arrays specialized-vectors ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-VECTOR: uint
IN: gpu.demos.bunny
GLSL-SHADER-FILE: bunny-vertex-shader vertex-shader "bunny.v.glsl"
{ f float-components 1 f } ;
VERTEX-STRUCT: bunny-vertex-struct bunny-vertex
+SPECIALIZED-VECTOR: bunny-vertex-struct
+
UNIFORM-TUPLE: bunny-uniforms < mvp-uniforms
{ "light-position" vec3-uniform f }
{ "color" vec4-uniform f }
" " split [ string>number ] map sift ;
: <bunny-vertex> ( vertex -- struct )
- >float-array
- "bunny-vertex-struct" <c-object>
- [ set-bunny-vertex-struct-vertex ] keep ;
+ bunny-vertex-struct <struct>
+ swap >float-array >>vertex ; inline
: (parse-bunny-model) ( vs is -- vs is )
readln [
] when* ;
: parse-bunny-model ( -- vertexes indexes )
- 100000 "bunny-vertex-struct" <struct-vector>
+ 100000 <bunny-vertex-struct-vector>
100000 <uint-vector>
(parse-bunny-model) ;
: calc-bunny-normal ( vertexes indexes -- )
swap
- [ [ nth bunny-vertex-struct-vertex 3 <direct-float-array> ] curry { } map-as normal ]
- [
- [
- nth [ bunny-vertex-struct-normal 3 <direct-float-array> v+ ] keep
- set-bunny-vertex-struct-normal
- ] curry with each
- ] 2bi ;
+ [ [ nth vertex>> ] curry { } map-as normal ]
+ [ [ nth [ v+ ] change-normal drop ] curry with each ] 2bi ;
: calc-bunny-normals ( vertexes indexes -- )
3 <groups>
[ calc-bunny-normal ] with each ;
: normalize-bunny-normals ( vertexes -- )
- [
- [ bunny-vertex-struct-normal 3 <direct-float-array> normalize ] keep
- set-bunny-vertex-struct-normal
- ] each ;
+ [ [ normalize ] change-normal drop ] each ;
: bunny-data ( filename -- vertexes indexes )
ascii [ parse-bunny-model ] with-file-reader
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-name "gpu.demos.bunny" }
+ { deploy-word-defs? f }
+ { deploy-io 3 }
+ { "stop-after-last-window?" t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-threads? t }
+ { deploy-c-types? f }
+ { deploy-reflection 2 }
+ { deploy-unicode? f }
+ { deploy-ui? t }
+}
destructors gpu gpu.buffers gpu.private gpu.textures
gpu.textures.private images kernel locals math math.rectangles opengl
opengl.framebuffers opengl.gl opengl.textures sequences
-specialized-arrays.int specialized-arrays.uint
-ui.gadgets.worlds variants ;
+specialized-arrays ui.gadgets.worlds variants ;
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: uint
IN: gpu.framebuffers
SINGLETON: system-framebuffer
USING: alien alien.syntax byte-arrays classes gpu.buffers
gpu.framebuffers gpu.shaders gpu.textures help.markup
help.syntax images kernel math multiline sequences
-specialized-arrays.alien specialized-arrays.uint
-specialized-arrays.ulong strings ;
+specialized-arrays strings ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: ulong
+SPECIALIZED-ARRAY: void*
IN: gpu.render
HELP: <index-elements>
! (c)2009 Joe Groff bsd license
-USING: accessors alien alien.c-types alien.structs arrays
+USING: accessors alien alien.c-types arrays
assocs classes classes.mixin classes.parser classes.singleton
classes.tuple classes.tuple.private combinators combinators.tuple destructors fry
generic generic.parser gpu gpu.buffers gpu.framebuffers
gpu.textures gpu.textures.private half-floats images kernel
lexer locals math math.order math.parser namespaces opengl
opengl.gl parser quotations sequences slots sorting
-specialized-arrays.alien specialized-arrays.float specialized-arrays.int
-specialized-arrays.uint strings ui.gadgets.worlds variants
+specialized-arrays strings ui.gadgets.worlds variants
vocabs.parser words ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: void*
IN: gpu.render
UNION: ?integer integer POSTPONE: f ;
! (c)2009 Joe Groff bsd license
-USING: alien.syntax classes gpu.buffers help.markup help.syntax
-images kernel math multiline quotations sequences strings ;
+USING: classes classes.struct gpu.buffers help.markup help.syntax
+images kernel math multiline quotations sequences strings words ;
IN: gpu.shaders
HELP: <program-instance>
HELP: VERTEX-STRUCT:
{ $syntax <" VERTEX-STRUCT: struct-name format-name "> }
-{ $description "Defines a struct C type (like " { $link POSTPONE: C-STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
+{ $description "Defines a struct class (like " { $link POSTPONE: STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
{ POSTPONE: GLSL-PROGRAM: POSTPONE: GLSL-SHADER-FILE: POSTPONE: GLSL-SHADER: } related-words
HELP: define-vertex-struct
{ $values
- { "struct-name" string } { "vertex-format" vertex-format }
+ { "class" word } { "vertex-format" vertex-format }
}
{ $description "Defines a new struct C type from a " { $link vertex-format } ". The runtime equivalent of " { $link POSTPONE: VERTEX-STRUCT: } ". This word must be called inside a compilation unit." } ;
! (c)2009 Joe Groff bsd license
-USING: accessors alien alien.c-types alien.strings
-alien.structs arrays assocs byte-arrays classes.mixin
-classes.parser classes.singleton combinators
-combinators.short-circuit definitions destructors
-generic.parser gpu gpu.buffers hashtables images
+USING: accessors alien alien.c-types alien.strings arrays assocs
+byte-arrays classes.mixin classes.parser classes.singleton
+classes.struct combinators combinators.short-circuit definitions
+destructors generic.parser gpu gpu.buffers hashtables images
io.encodings.ascii io.files io.pathnames kernel lexer literals
locals math math.parser memoize multiline namespaces opengl
opengl.gl opengl.shaders parser quotations sequences
-specialized-arrays.alien specialized-arrays.int splitting
-strings tr ui.gadgets.worlds variants vectors vocabs vocabs.loader
-vocabs.parser words words.constant ;
+specialized-arrays splitting strings tr ui.gadgets.worlds
+variants vectors vocabs vocabs.loader vocabs.parser words
+words.constant ;
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: void*
IN: gpu.shaders
VARIANT: shader-kind
{ uint-integer-components [ "uint" ] }
} case ;
-: c-array-dim ( dim -- string )
- dup 1 = [ drop "" ] [ number>string "[" "]" surround ] if ;
+: c-array-dim ( type dim -- type' )
+ dup 1 = [ drop ] [ 2array ] if ;
SYMBOL: padding-no
padding-no [ 0 ] initialize
"(" ")" surround
padding-no inc ;
-: vertex-attribute>c-type ( vertex-attribute -- {type,name} )
- [
- [ component-type>> component-type>c-type ]
- [ dim>> c-array-dim ] bi append
- ] [ name>> [ padding-name ] unless* ] bi 2array ;
+: vertex-attribute>struct-slot ( vertex-attribute -- struct-slot-spec )
+ [ name>> [ padding-name ] unless* ]
+ [ [ component-type>> component-type>c-type ] [ dim>> c-array-dim ] bi ] bi
+ { } <struct-slot-spec> ;
: shader-filename ( shader/program -- filename )
dup filename>> [ nip ] [ name>> where first ] if* file-name ;
[ first4 vertex-attribute boa ] map
define-vertex-format ;
-: define-vertex-struct ( struct-name vertex-format -- )
- [ current-vocab ] dip
- "vertex-format-attributes" word-prop [ vertex-attribute>c-type ] map
- define-struct ;
+: define-vertex-struct ( class vertex-format -- )
+ "vertex-format-attributes" word-prop [ vertex-attribute>struct-slot ] map
+ define-struct-class ;
SYNTAX: VERTEX-STRUCT:
- scan scan-word define-vertex-struct ;
+ CREATE-CLASS scan-word define-vertex-struct ;
TUPLE: vertex-array < gpu-object
{ program-instance program-instance read-only }
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types arrays byte-arrays combinators gpu
kernel literals math math.rectangles opengl opengl.gl sequences
-variants specialized-arrays.int specialized-arrays.float ;
+variants specialized-arrays ;
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: float
IN: gpu.state
UNION: ?rect rect POSTPONE: f ;
USING: accessors alien.c-types arrays byte-arrays combinators
destructors fry gpu gpu.buffers images kernel locals math
opengl opengl.gl opengl.textures sequences
-specialized-arrays.float ui.gadgets.worlds variants ;
+specialized-arrays ui.gadgets.worlds variants ;
+SPECIALIZED-ARRAY: float
IN: gpu.textures
TUPLE: texture < gpu-object
! (c)2009 Joe Groff bsd license
USING: gpu.buffers gpu.render gpu.shaders gpu.textures images kernel
-specialized-arrays.float ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: gpu.util
CONSTANT: environment-cube-map-mv-matrices
gpu.render gpu.state kernel literals
locals math math.constants math.functions math.matrices
math.order math.vectors opengl.gl sequences
-specialized-arrays.float ui ui.gadgets.worlds ;
+ui ui.gadgets.worlds specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: gpu.util.wasd
UNIFORM-TUPLE: mvp-uniforms
! (c)2009 Joe Groff bsd license
USING: accessors arrays destructors kernel math opengl
-opengl.gl sequences sequences.product specialized-arrays.float ;
+opengl.gl sequences sequences.product specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: grid-meshes
TUPLE: grid-mesh dim buffer row-length ;
-USING: alien.c-types alien.syntax half-floats kernel math tools.test ;
+USING: alien.c-types alien.syntax half-floats kernel math tools.test
+specialized-arrays ;
+SPECIALIZED-ARRAY: half
IN: half-floats.tests
[ HEX: 0000 ] [ 0.0 half>bits ] unit-test
! (c)2009 Joe Groff bsd license
-USING: accessors alien.c-types alien.syntax kernel math math.order
-specialized-arrays.direct.functor specialized-arrays.functor ;
+USING: accessors alien.c-types alien.syntax kernel math math.order ;
IN: half-floats
: half>bits ( float -- bits )
[ *ushort bits>half ] >>boxer-quot
drop
-"half" define-array
-"half" define-direct-array
-
>>
USING: assocs html.parser kernel math sequences strings ascii
arrays generalizations shuffle namespaces make
splitting http accessors io combinators http.client urls
-urls.encoding fry prettyprint sets ;
+urls.encoding fry prettyprint sets combinators.short-circuit ;
IN: html.parser.analyzer
TUPLE: link attributes clickable ;
[ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ]
find-between-all ;
+: find-images ( vector -- vector' )
+ [
+ {
+ [ name>> "img" = ]
+ [ attributes>> "src" swap at ]
+ } 1&&
+ ] find-all
+ values [ attributes>> "src" swap at ] map ;
+
: <link> ( vector -- link )
[ first attributes>> ]
[ [ name>> { text "img" } member? ] filter ] bi
! Copyright (C) 2009 Tim Wawrzynczak, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences io io.encodings.binary io.files io.pathnames
-strings kernel math io.mmap io.mmap.uchar accessors
-combinators math.ranges unicode.categories byte-arrays
-io.encodings.string io.encodings.utf16 assocs math.parser
-combinators.short-circuit fry namespaces combinators.smart
-splitting io.encodings.ascii arrays io.files.info unicode.case
-io.directories.search literals math.functions continuations ;
+strings kernel math io.mmap accessors combinators math.ranges
+unicode.categories byte-arrays io.encodings.string
+io.encodings.utf16 assocs math.parser combinators.short-circuit
+fry namespaces combinators.smart splitting io.encodings.ascii
+arrays io.files.info unicode.case io.directories.search literals
+math.functions continuations ;
IN: id3
<PRIVATE
CONSTANT: id3v1-length 128
CONSTANT: id3v1-offset 128
CONSTANT: id3v1+-length 227
-CONSTANT: id3v1+-offset $[ 128 227 + ]
+: id3v1+-offset ( -- n ) id3v1-length id3v1+-length + ; inline
: id3v1? ( seq -- ? )
{
: mp3>id3 ( path -- id3/f )
[
- [ <id3> ] dip
- {
- [ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ]
- [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
- [ dup id3v2? [ read-v2-tags ] [ drop ] if ]
- } cleave
- ] with-mapped-uchar-file-reader ;
+ [ <id3> ] dip "uchar" <mapped-array>
+ [ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ]
+ [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
+ [ dup id3v2? [ read-v2-tags ] [ drop ] if ]
+ tri
+ ] with-mapped-file-reader ;
: find-id3-frame ( id3 name -- obj/f )
swap frames>> at* [ data>> ] when ;
--- /dev/null
+! Copyrigt (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators constructors destructors
+images images.loader io io.binary io.buffers
+io.encodings.binary io.encodings.string io.encodings.utf8
+io.files io.files.info io.ports io.streams.limited kernel make
+math math.bitwise math.functions multiline namespaces
+prettyprint sequences ;
+IN: images.gif
+
+SINGLETON: gif-image
+"gif" gif-image register-image-class
+
+TUPLE: loading-gif
+loading?
+magic
+width height
+flags
+background-color
+default-aspect-ratio
+global-color-table
+graphic-control-extensions
+application-extensions
+plain-text-extensions
+comment-extensions
+
+image-descriptor
+local-color-table
+compressed-bytes ;
+
+TUPLE: gif-frame
+image-descriptor
+local-color-table ;
+
+ERROR: unsupported-gif-format magic ;
+ERROR: unknown-extension n ;
+ERROR: gif-unexpected-eof ;
+
+TUPLE: graphics-control-extension
+label block-size raw-data
+packed delay-time color-index
+block-terminator ;
+
+TUPLE: image-descriptor
+separator left top width height flags ;
+
+TUPLE: plain-text-extension
+introducer label block-size text-grid-left text-grid-top text-grid-width
+text-grid-height cell-width cell-height
+text-fg-color-index text-bg-color-index plain-text-data ;
+
+TUPLE: application-extension
+introducer label block-size identifier authentication-code
+application-data ;
+
+TUPLE: comment-extension
+introducer label comment-data ;
+
+TUPLE: trailer byte ;
+CONSTRUCTOR: trailer ( byte -- obj ) ;
+
+CONSTANT: image-descriptor HEX: 2c
+! Extensions
+CONSTANT: extension-identifier HEX: 21
+CONSTANT: plain-text-extension HEX: 01
+CONSTANT: graphic-control-extension HEX: f9
+CONSTANT: comment-extension HEX: fe
+CONSTANT: application-extension HEX: ff
+CONSTANT: trailer HEX: 3b
+
+: <loading-gif> ( -- loading-gif )
+ \ loading-gif new
+ V{ } clone >>graphic-control-extensions
+ V{ } clone >>application-extensions
+ V{ } clone >>plain-text-extensions
+ V{ } clone >>comment-extensions
+ t >>loading? ;
+
+GENERIC: stream-peek1 ( stream -- byte )
+
+M: input-port stream-peek1
+ dup check-disposed dup wait-to-read
+ [ drop f ] [ buffer>> buffer-peek ] if ; inline
+
+: peek1 ( -- byte ) input-stream get stream-peek1 ;
+
+: (read-sub-blocks) ( -- )
+ read1 [ read , (read-sub-blocks) ] unless-zero ;
+
+: read-sub-blocks ( -- bytes )
+ [ (read-sub-blocks) ] { } make B{ } concat-as ;
+
+: read-image-descriptor ( -- image-descriptor )
+ \ image-descriptor new
+ 1 read le> >>separator
+ 2 read le> >>left
+ 2 read le> >>top
+ 2 read le> >>width
+ 2 read le> >>height
+ 1 read le> >>flags ;
+
+: read-graphic-control-extension ( -- graphic-control-extension )
+ \ graphics-control-extension new
+ 1 read le> [ >>block-size ] [ read ] bi
+ >>raw-data
+ 1 read le> >>block-terminator ;
+
+: read-plain-text-extension ( -- plain-text-extension )
+ \ plain-text-extension new
+ 1 read le> >>block-size
+ 2 read le> >>text-grid-left
+ 2 read le> >>text-grid-top
+ 2 read le> >>text-grid-width
+ 2 read le> >>text-grid-height
+ 1 read le> >>cell-width
+ 1 read le> >>cell-height
+ 1 read le> >>text-fg-color-index
+ 1 read le> >>text-bg-color-index
+ read-sub-blocks >>plain-text-data ;
+
+: read-comment-extension ( -- comment-extension )
+ \ comment-extension new
+ read-sub-blocks >>comment-data ;
+
+: read-application-extension ( -- read-application-extension )
+ \ application-extension new
+ 1 read le> >>block-size
+ 8 read utf8 decode >>identifier
+ 3 read >>authentication-code
+ read-sub-blocks >>application-data ;
+
+: read-gif-header ( loading-gif -- loading-gif )
+ 6 read utf8 decode >>magic ;
+
+ERROR: unimplemented message ;
+: read-GIF87a ( loading-gif -- loading-gif )
+ "GIF87a" unimplemented ;
+
+: read-logical-screen-descriptor ( loading-gif -- loading-gif )
+ 2 read le> >>width
+ 2 read le> >>height
+ 1 read le> >>flags
+ 1 read le> >>background-color
+ 1 read le> >>default-aspect-ratio ;
+
+: color-table? ( image -- ? ) flags>> 7 bit? ; inline
+: interlaced? ( image -- ? ) flags>> 6 bit? ; inline
+: sort? ( image -- ? ) flags>> 5 bit? ; inline
+: color-table-size ( image -- ? ) flags>> 3 bits 1 + 2^ 3 * ; inline
+
+: color-resolution ( image -- ? ) flags>> -4 shift 3 bits ; inline
+
+: read-global-color-table ( loading-gif -- loading-gif )
+ dup color-table? [
+ dup color-table-size read >>global-color-table
+ ] when ;
+
+: maybe-read-local-color-table ( loading-gif -- loading-gif )
+ dup image-descriptor>> color-table? [
+ dup color-table-size read >>local-color-table
+ ] when ;
+
+: read-image-data ( loading-gif -- loading-gif )
+ read-sub-blocks >>compressed-bytes ;
+
+: read-table-based-image ( loading-gif -- loading-gif )
+ read-image-descriptor >>image-descriptor
+ maybe-read-local-color-table
+ read-image-data ;
+
+: read-graphic-rendering-block ( loading-gif -- loading-gif )
+ read-table-based-image ;
+
+: read-extension ( loading-gif -- loading-gif )
+ read1 {
+ { plain-text-extension [
+ read-plain-text-extension over plain-text-extensions>> push
+ ] }
+
+ { graphic-control-extension [
+ read-graphic-control-extension
+ over graphic-control-extensions>> push
+ ] }
+ { comment-extension [
+ read-comment-extension over comment-extensions>> push
+ ] }
+ { application-extension [
+ read-application-extension over application-extensions>> push
+ ] }
+ { f [ gif-unexpected-eof ] }
+ [ unknown-extension ]
+ } case ;
+
+ERROR: unhandled-data byte ;
+
+: read-data ( loading-gif -- loading-gif )
+ read1 {
+ { extension-identifier [ read-extension ] }
+ { graphic-control-extension [
+ read-graphic-control-extension
+ over graphic-control-extensions>> push
+ ] }
+ { image-descriptor [ read-table-based-image ] }
+ { trailer [ f >>loading? ] }
+ [ unhandled-data ]
+ } case ;
+
+: read-GIF89a ( loading-gif -- loading-gif )
+ read-logical-screen-descriptor
+ read-global-color-table
+ [ read-data dup loading?>> ] loop ;
+
+: load-gif ( stream -- loading-gif )
+ [
+ <loading-gif>
+ read-gif-header dup magic>> {
+ { "GIF87a" [ read-GIF87a ] }
+ { "GIF89a" [ read-GIF89a ] }
+ [ unsupported-gif-format ]
+ } case
+ ] with-input-stream ;
+
+: loading-gif>image ( loading-gif -- image )
+ ;
+
+ERROR: loading-gif-error gif-image ;
+
+: ensure-loaded ( gif-image -- gif-image )
+ dup loading?>> [ loading-gif-error ] when ;
+
+M: gif-image stream>image ( path gif-image -- image )
+ drop load-gif ensure-loaded loading-gif>image ;
! Copyright (C) 2009 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors grouping sequences combinators
-math specialized-arrays.direct.uint byte-arrays fry
-specialized-arrays.direct.ushort specialized-arrays.uint
-specialized-arrays.ushort specialized-arrays.float images
-half-floats ;
+USING: kernel accessors grouping sequences combinators math
+byte-arrays fry images half-floats specialized-arrays ;
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: ushort
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: half
IN: images.normalization
<PRIVATE
! 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 ;
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
! See http://factorcode.org/license.txt for BSD license.
USING: io.files.windows io.streams.duplex kernel math
math.bitwise windows.kernel32 accessors alien.c-types
-windows io.files.windows fry locals continuations ;
+windows io.files.windows fry locals continuations
+classes.struct ;
IN: io.serial.windows
: <serial-stream> ( path encoding -- duplex )
: get-comm-state ( duplex -- dcb )
in>> handle>>
- "DCB" <c-object> tuck
+ DCB <struct> tuck
GetCommState win32-error=0/f ;
: set-comm-state ( duplex dcb -- )
[ (connect-irc) (do-login) spawn-irc ] with-irc ;
: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc ;
-: detach-chat ( irc-chat -- ) dup [ client>> remove-chat ] with-irc ;
+: detach-chat ( irc-chat -- ) dup client>> [ remove-chat ] with-irc ;
: speak ( message irc-chat -- ) dup client>> [ (speak) ] with-irc ;
: hear ( irc-chat -- message ) in-messages>> mailbox-get ;
: terminate-irc ( irc-client -- ) [ (terminate-irc) ] with-irc ;
USING: accessors alien.c-types jamshred.game jamshred.oint
jamshred.player jamshred.tunnel kernel math math.constants
math.functions math.vectors opengl opengl.gl opengl.glu
-opengl.demo-support sequences specialized-arrays.float ;
+opengl.demo-support sequences specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: jamshred.gl
CONSTANT: min-vertices 6
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors.constants combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle specialized-arrays.float strings system ;
+USING: accessors colors.constants combinators jamshred.log
+jamshred.oint jamshred.sound jamshred.tunnel kernel locals math
+math.constants math.order math.ranges math.vectors math.matrices
+sequences shuffle specialized-arrays strings system ;
+SPECIALIZED-ARRAY: float
IN: jamshred.player
TUPLE: player < oint
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences specialized-arrays.float tools.test ;
+USING: accessors arrays jamshred.oint jamshred.tunnel kernel
+math.vectors sequences specialized-arrays tools.test ;
+SPECIALIZED-ARRAY: float
IN: jamshred.tunnel.tests
[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
USING: accessors arrays colors combinators fry jamshred.oint
kernel literals locals math math.constants math.matrices
math.order math.quadratic math.ranges math.vectors random
-sequences specialized-arrays.float vectors ;
+sequences specialized-arrays vectors ;
FROM: jamshred.oint => distance ;
+SPECIALIZED-ARRAY: float
IN: jamshred.tunnel
CONSTANT: n-segments 5000
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien arrays assocs compiler.units effects
io.backend io.pathnames kernel llvm.core llvm.jit llvm.reader
-llvm.types make namespaces sequences specialized-arrays.alien
+llvm.types make namespaces sequences specialized-arrays
vocabs words ;
-
+SPECIALIZED-ARRAY: void*
IN: llvm.invoker
! get function name, ret type, param types and names
! Copyright (C) 2009 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators kernel llvm.core
-locals math.parser math multiline
-namespaces parser peg.ebnf sequences
-sequences.deep specialized-arrays.alien strings vocabs words ;
-
+USING: accessors arrays combinators kernel llvm.core locals
+math.parser math multiline namespaces parser peg.ebnf sequences
+sequences.deep specialized-arrays strings vocabs words ;
+SPECIALIZED-ARRAY: void*
IN: llvm.types
! Type resolution strategy:
] with-scope
] unit-test
-[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [
+[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" "-sse-version=30" } ] [
[
"winnt" target-os set
"x86.32" target-cpu set
target-os get "winnt" = "./factor.com" "./factor" ? ;
: boot-cmd ( -- cmd )
- factor-vm
- "-i=" boot-image-name append
- "-no-user-init"
- 3array ;
+ [
+ factor-vm ,
+ "-i=" boot-image-name append ,
+ "-no-user-init" ,
+ target-cpu get { "x86.32" "x86.64" } member? [ "-sse-version=30" , ] when
+ ] { } make ;
: boot ( -- )
"factor" [
USING: accessors arrays assocs bson.constants combinators
combinators.smart constructors destructors formatting fry hashtables
io io.pools io.sockets kernel linked-assocs math mongodb.connection
-mongodb.msg parser prettyprint sequences sets splitting strings
+mongodb.msg parser prettyprint prettyprint.custom prettyprint.sections
+sequences sets splitting strings
tools.continuations uuid memoize locals ;
IN: mongodb.driver
ERROR: mdb-error msg ;
+M: mdb-error pprint* ( obj -- )
+ msg>> text ;
+
: >pwd-digest ( user password -- digest )
"mongo" swap 3array ":" join md5-checksum ;
USING: accessors arrays byte-arrays combinators
combinators.short-circuit fry hints images kernel locals math
-math.affine-transforms math.functions math.order
-math.polynomials math.private math.vectors random
-random.mersenne-twister sequences sequences.private
-sequences.product ;
+math.affine-transforms math.functions math.order math.polynomials
+math.vectors random random.mersenne-twister sequences
+sequences.private sequences.product ;
IN: noise
: <perlin-noise-table> ( -- table )
HINTS: grad { fixnum float float float } ;
: unit-cube ( point -- cube )
- [ floor >fixnum 256 rem ] map ;
+ [ floor 256 rem ] map ;
:: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb )
- x table nth-unsafe y fixnum+fast :> a
- x 1 fixnum+fast table nth-unsafe y fixnum+fast :> b
-
- a table nth-unsafe z fixnum+fast :> aa
- b table nth-unsafe z fixnum+fast :> ba
- a 1 fixnum+fast table nth-unsafe z fixnum+fast :> ab
- b 1 fixnum+fast table nth-unsafe z fixnum+fast :> bb
-
- aa table nth-unsafe
- ba table nth-unsafe
- ab table nth-unsafe
- bb table nth-unsafe
- aa 1 fixnum+fast table nth-unsafe
- ba 1 fixnum+fast table nth-unsafe
- ab 1 fixnum+fast table nth-unsafe
- bb 1 fixnum+fast table nth-unsafe ; inline
+ x table nth-unsafe y + :> a
+ x 1 + table nth-unsafe y + :> b
+
+ a table nth-unsafe z + :> aa
+ b table nth-unsafe z + :> ba
+ a 1 + table nth-unsafe z + :> ab
+ b 1 + table nth-unsafe z + :> bb
+
+ aa table nth-unsafe
+ ba table nth-unsafe
+ ab table nth-unsafe
+ bb table nth-unsafe
+ aa 1 + table nth-unsafe
+ ba 1 + table nth-unsafe
+ ab 1 + table nth-unsafe
+ bb 1 + table nth-unsafe ; inline
HINTS: hashes { byte-array fixnum fixnum fixnum } ;
! (c)2009 Joe Groff bsd license
USING: accessors arrays grouping kernel locals math math.order
math.ranges math.vectors math.vectors.homogeneous sequences
-specialized-arrays.float ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: nurbs
TUPLE: nurbs-curve
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors arrays alien system combinators alien.syntax namespaces
- alien.c-types sequences vocabs.loader shuffle
- openal.backend specialized-arrays.uint alien.libraries generalizations ;
+USING: kernel accessors arrays alien system combinators
+alien.syntax namespaces alien.c-types sequences vocabs.loader
+shuffle openal.backend alien.libraries generalizations
+specialized-arrays ;
+SPECIALIZED-ARRAY: uint
IN: openal
<< "alut" {
combinators ;
IN: opengl.glu
+<<
+
os {
{ [ dup macosx? ] [ drop ] }
{ [ dup windows? ] [ drop ] }
{ [ dup unix? ] [ drop "glu" "libGLU.so.1" "cdecl" add-library ] }
} cond
+>>
+
LIBRARY: glu
! These are defined as structs in glu.h, but we only ever use pointers to them
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.ranges math.order
-project-euler.common sequences ;
+project-euler.common sequences layouts ;
IN: project-euler.044
! http://projecteuler.net/index.php?section=problems&id=44
<PRIVATE
: nth-pentagonal ( n -- seq )
- dup 3 * 1 - * 2 / ;
+ dup 3 * 1 - * 2 /i ; inline
: sum-and-diff? ( m n -- ? )
- [ + ] [ - ] 2bi [ pentagonal? ] bi@ and ;
+ [ + ] [ - ] 2bi [ pentagonal? ] bi@ and ; inline
+
+: euler044-step ( min m n -- min' )
+ [ nth-pentagonal ] bi@
+ 2dup sum-and-diff? [ - abs min ] [ 2drop ] if ; inline
PRIVATE>
: euler044 ( -- answer )
- 2500 [1,b] [ nth-pentagonal ] map dup cartesian-product
- [ first2 sum-and-diff? ] filter [ first2 - abs ] [ min ] map-reduce ;
+ most-positive-fixnum >fixnum
+ 2500 [1,b] [
+ dup [1,b] [
+ euler044-step
+ ] with each
+ ] each ;
! [ euler044 ] 10 ave-time
-! 4996 ms ave run time - 87.46 SD (10 trials)
-
-! TODO: this solution is ugly and not very efficient...find a better algorithm
+! 289 ms ave run time - 0.27 SD (10 trials)
SOLUTION: euler044
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel locals make math project-euler.common sequences ;
+USING: kernel locals math project-euler.common sequences ;
IN: project-euler.073
! http://projecteuler.net/index.php?section=problems&id=73
<PRIVATE
-:: (euler073) ( limit lo hi -- )
+:: (euler073) ( counter limit lo hi -- counter' )
[let | m [ lo hi mediant ] |
m denominator limit <= [
- m ,
+ counter 1 +
limit lo m (euler073)
limit m hi (euler073)
- ] when
+ ] [ counter ] if
] ;
PRIVATE>
: euler073 ( -- answer )
- [ 10000 1/3 1/2 (euler073) ] { } make length ;
+ 0 10000 1/3 1/2 (euler073) ;
! [ euler073 ] 10 ave-time
! 20506 ms ave run time - 937.07 SD (10 trials)
--- /dev/null
+USING: project-euler.085 tools.test ;
+IN: project-euler.085.tests
+
+[ 2772 ] [ euler085 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Guillaume Nargeot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math math.ranges project-euler.common
+sequences locals ;
+IN: project-euler.085
+
+! http://projecteuler.net/index.php?section=problems&id=85
+
+! DESCRIPTION
+! -----------
+
+! By counting carefully it can be seen that a rectangular grid measuring
+! 3 by 2 contains eighteen rectangles.
+
+! Although there exists no rectangular grid that contains exactly two million
+! rectangles, find the area of the grid with the nearest solution.
+
+
+! SOLUTION
+! --------
+
+! A grid measuring x by y contains x * (x + 1) * y * (x + 1) rectangles.
+
+<PRIVATE
+
+: distance ( m -- n )
+ 2000000 - abs ; inline
+
+: rectangles-count ( a b -- n )
+ 2dup [ 1 + ] bi@ * * * 4 /i ; inline
+
+:: each-unique-product ( a b quot: ( i j -- ) -- )
+ a b [a,b] [| i |
+ i b [a,b] [| j |
+ i j quot call
+ ] each
+ ] each ; inline
+
+TUPLE: result { area read-only } { distance read-only } ;
+
+C: <result> result
+
+: min-by-distance ( seq seq -- seq )
+ [ [ distance>> ] bi@ < ] most ; inline
+
+: compute-result ( i j -- pair )
+ [ * ] [ rectangles-count distance ] 2bi <result> ; inline
+
+: area-of-nearest ( -- n )
+ T{ result f 0 2000000 } 1 2000
+ [ compute-result min-by-distance ] each-unique-product area>> ;
+
+PRIVATE>
+
+: euler085 ( -- answer )
+ area-of-nearest ;
+
+! [ euler085 ] 100 ave-time
+! 2285 ms ave run time - 4.8 SD (100 trials)
+
+SOLUTION: euler085
--- /dev/null
+USING: project-euler.102 tools.test ;
+IN: project-euler.102.tests
+
+[ 228 ] [ euler102 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Guillaume Nargeot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays grouping io.encodings.ascii io.files kernel math
+math.parser sequences splitting project-euler.common ;
+IN: project-euler.102
+
+! http://projecteuler.net/index.php?section=problems&id=102
+
+! DESCRIPTION
+! -----------
+
+! Three distinct points are plotted at random on a Cartesian plane, for which
+! -1000 ≤ x, y ≤ 1000, such that a triangle is formed.
+
+! Consider the following two triangles:
+
+! A(-340,495), B(-153,-910), C(835,-947)
+! X(-175,41), Y(-421,-714), Z(574,-645)
+
+! It can be verified that triangle ABC contains the origin, whereas triangle
+! XYZ does not.
+
+! Using triangles.txt (right click and 'Save Link/Target As...'), a 27K text
+! file containing the co-ordinates of one thousand "random" triangles, find the
+! number of triangles for which the interior contains the origin.
+
+! NOTE: The first two examples in the file represent the triangles in the
+! example given above.
+
+
+! SOLUTION
+! --------
+
+! A triangle of coordinates (x1, y1) (x2, y2) (x3, y3) contains
+! the origin when (ab * bc > 0) and (bc * ca > 0) where:
+! ab = x1 * (y2 - y1) - y1 * (x2 - x1)
+! bc = x2 * (y3 - y2) - y2 * (x3 - x2)
+! ca = x3 * (y1 - y3) - y3 * (x1 - x3)
+
+<PRIVATE
+
+: source-102 ( -- seq )
+ "resource:extra/project-euler/102/triangles.txt"
+ ascii file-lines [
+ "," split [ string>number ] map 2 group
+ ] map ;
+
+: det ( coord coord -- n )
+ dupd [ [ last ] bi@ - ] [ [ first ] bi@ - ] 2bi 2array
+ [ [ first ] bi@ * ] [ [ last ] bi@ * ] 2bi - ;
+
+: include-origin? ( coord-seq -- ? )
+ dup first suffix 2 clump [ [ first ] [ last ] bi det ] map
+ 2 clump [ product 0 > ] all? ;
+
+PRIVATE>
+
+: euler102 ( -- answer )
+ source-102 [ include-origin? ] count ;
+
+! [ euler102 ] 100 ave-time
+! 12 ms ave run time - 0.92 SD (100 trials)
+
+SOLUTION: euler102
--- /dev/null
+-340,495,-153,-910,835,-947\r
+-175,41,-421,-714,574,-645\r
+-547,712,-352,579,951,-786\r
+419,-864,-83,650,-399,171\r
+-429,-89,-357,-930,296,-29\r
+-734,-702,823,-745,-684,-62\r
+-971,762,925,-776,-663,-157\r
+162,570,628,485,-807,-896\r
+641,91,-65,700,887,759\r
+215,-496,46,-931,422,-30\r
+-119,359,668,-609,-358,-494\r
+440,929,968,214,760,-857\r
+-700,785,838,29,-216,411\r
+-770,-458,-325,-53,-505,633\r
+-752,-805,349,776,-799,687\r
+323,5,561,-36,919,-560\r
+-907,358,264,320,204,274\r
+-728,-466,350,969,292,-345\r
+940,836,272,-533,748,185\r
+411,998,813,520,316,-949\r
+-152,326,658,-762,148,-651\r
+330,507,-9,-628,101,174\r
+551,-496,772,-541,-702,-45\r
+-164,-489,-90,322,631,-59\r
+673,366,-4,-143,-606,-704\r
+428,-609,801,-449,740,-269\r
+453,-924,-785,-346,-853,111\r
+-738,555,-181,467,-426,-20\r
+958,-692,784,-343,505,-569\r
+620,27,263,54,-439,-726\r
+804,87,998,859,871,-78\r
+-119,-453,-709,-292,-115,-56\r
+-626,138,-940,-476,-177,-274\r
+-11,160,142,588,446,158\r
+538,727,550,787,330,810\r
+420,-689,854,-546,337,516\r
+872,-998,-607,748,473,-192\r
+653,440,-516,-985,808,-857\r
+374,-158,331,-940,-338,-641\r
+137,-925,-179,771,734,-715\r
+-314,198,-115,29,-641,-39\r
+759,-574,-385,355,590,-603\r
+-189,-63,-168,204,289,305\r
+-182,-524,-715,-621,911,-255\r
+331,-816,-833,471,168,126\r
+-514,581,-855,-220,-731,-507\r
+129,169,576,651,-87,-458\r
+783,-444,-881,658,-266,298\r
+603,-430,-598,585,368,899\r
+43,-724,962,-376,851,409\r
+-610,-646,-883,-261,-482,-881\r
+-117,-237,978,641,101,-747\r
+579,125,-715,-712,208,534\r
+672,-214,-762,372,874,533\r
+-564,965,38,715,367,242\r
+500,951,-700,-981,-61,-178\r
+-382,-224,-959,903,-282,-60\r
+-355,295,426,-331,-591,655\r
+892,128,958,-271,-993,274\r
+-454,-619,302,138,-790,-874\r
+-642,601,-574,159,-290,-318\r
+266,-109,257,-686,54,975\r
+162,628,-478,840,264,-266\r
+466,-280,982,1,904,-810\r
+721,839,730,-807,777,981\r
+-129,-430,748,263,943,96\r
+434,-94,410,-990,249,-704\r
+237,42,122,-732,44,-51\r
+909,-116,-229,545,292,717\r
+824,-768,-807,-370,-262,30\r
+675,58,332,-890,-651,791\r
+363,825,-717,254,684,240\r
+405,-715,900,166,-589,422\r
+-476,686,-830,-319,634,-807\r
+633,837,-971,917,-764,207\r
+-116,-44,-193,-70,908,809\r
+-26,-252,998,408,70,-713\r
+-601,645,-462,842,-644,-591\r
+-160,653,274,113,-138,687\r
+369,-273,-181,925,-167,-693\r
+-338,135,480,-967,-13,-840\r
+-90,-270,-564,695,161,907\r
+607,-430,869,-713,461,-469\r
+919,-165,-776,522,606,-708\r
+-203,465,288,207,-339,-458\r
+-453,-534,-715,975,838,-677\r
+-973,310,-350,934,546,-805\r
+-835,385,708,-337,-594,-772\r
+-14,914,900,-495,-627,594\r
+833,-713,-213,578,-296,699\r
+-27,-748,484,455,915,291\r
+270,889,739,-57,442,-516\r
+119,811,-679,905,184,130\r
+-678,-469,925,553,612,482\r
+101,-571,-732,-842,644,588\r
+-71,-737,566,616,957,-663\r
+-634,-356,90,-207,936,622\r
+598,443,964,-895,-58,529\r
+847,-467,929,-742,91,10\r
+-633,829,-780,-408,222,-30\r
+-818,57,275,-38,-746,198\r
+-722,-825,-549,597,-391,99\r
+-570,908,430,873,-103,-360\r
+342,-681,512,434,542,-528\r
+297,850,479,609,543,-357\r
+9,784,212,548,56,859\r
+-152,560,-240,-969,-18,713\r
+140,-133,34,-635,250,-163\r
+-272,-22,-169,-662,989,-604\r
+471,-765,355,633,-742,-118\r
+-118,146,942,663,547,-376\r
+583,16,162,264,715,-33\r
+-230,-446,997,-838,561,555\r
+372,397,-729,-318,-276,649\r
+92,982,-970,-390,-922,922\r
+-981,713,-951,-337,-669,670\r
+-999,846,-831,-504,7,-128\r
+455,-954,-370,682,-510,45\r
+822,-960,-892,-385,-662,314\r
+-668,-686,-367,-246,530,-341\r
+-723,-720,-926,-836,-142,757\r
+-509,-134,384,-221,-873,-639\r
+-803,-52,-706,-669,373,-339\r
+933,578,631,-616,770,555\r
+741,-564,-33,-605,-576,275\r
+-715,445,-233,-730,734,-704\r
+120,-10,-266,-685,-490,-17\r
+-232,-326,-457,-946,-457,-116\r
+811,52,639,826,-200,147\r
+-329,279,293,612,943,955\r
+-721,-894,-393,-969,-642,453\r
+-688,-826,-352,-75,371,79\r
+-809,-979,407,497,858,-248\r
+-485,-232,-242,-582,-81,849\r
+141,-106,123,-152,806,-596\r
+-428,57,-992,811,-192,478\r
+864,393,122,858,255,-876\r
+-284,-780,240,457,354,-107\r
+956,605,-477,44,26,-678\r
+86,710,-533,-815,439,327\r
+-906,-626,-834,763,426,-48\r
+201,-150,-904,652,475,412\r
+-247,149,81,-199,-531,-148\r
+923,-76,-353,175,-121,-223\r
+427,-674,453,472,-410,585\r
+931,776,-33,85,-962,-865\r
+-655,-908,-902,208,869,792\r
+-316,-102,-45,-436,-222,885\r
+-309,768,-574,653,745,-975\r
+896,27,-226,993,332,198\r
+323,655,-89,260,240,-902\r
+501,-763,-424,793,813,616\r
+993,375,-938,-621,672,-70\r
+-880,-466,-283,770,-824,143\r
+63,-283,886,-142,879,-116\r
+-964,-50,-521,-42,-306,-161\r
+724,-22,866,-871,933,-383\r
+-344,135,282,966,-80,917\r
+-281,-189,420,810,362,-582\r
+-515,455,-588,814,162,332\r
+555,-436,-123,-210,869,-943\r
+589,577,232,286,-554,876\r
+-773,127,-58,-171,-452,125\r
+-428,575,906,-232,-10,-224\r
+437,276,-335,-348,605,878\r
+-964,511,-386,-407,168,-220\r
+307,513,912,-463,-423,-416\r
+-445,539,273,886,-18,760\r
+-396,-585,-670,414,47,364\r
+143,-506,754,906,-971,-203\r
+-544,472,-180,-541,869,-465\r
+-779,-15,-396,890,972,-220\r
+-430,-564,503,182,-119,456\r
+89,-10,-739,399,506,499\r
+954,162,-810,-973,127,870\r
+890,952,-225,158,828,237\r
+-868,952,349,465,574,750\r
+-915,369,-975,-596,-395,-134\r
+-135,-601,575,582,-667,640\r
+413,890,-560,-276,-555,-562\r
+-633,-269,561,-820,-624,499\r
+371,-92,-784,-593,864,-717\r
+-971,655,-439,367,754,-951\r
+172,-347,36,279,-247,-402\r
+633,-301,364,-349,-683,-387\r
+-780,-211,-713,-948,-648,543\r
+72,58,762,-465,-66,462\r
+78,502,781,-832,713,836\r
+-431,-64,-484,-392,208,-343\r
+-64,101,-29,-860,-329,844\r
+398,391,828,-858,700,395\r
+578,-896,-326,-604,314,180\r
+97,-321,-695,185,-357,852\r
+854,839,283,-375,951,-209\r
+194,96,-564,-847,162,524\r
+-354,532,494,621,580,560\r
+419,-678,-450,926,-5,-924\r
+-661,905,519,621,-143,394\r
+-573,268,296,-562,-291,-319\r
+-211,266,-196,158,564,-183\r
+18,-585,-398,777,-581,864\r
+790,-894,-745,-604,-418,70\r
+848,-339,150,773,11,851\r
+-954,-809,-53,-20,-648,-304\r
+658,-336,-658,-905,853,407\r
+-365,-844,350,-625,852,-358\r
+986,-315,-230,-159,21,180\r
+-15,599,45,-286,-941,847\r
+-613,-68,184,639,-987,550\r
+334,675,-56,-861,923,340\r
+-848,-596,960,231,-28,-34\r
+707,-811,-994,-356,-167,-171\r
+-470,-764,72,576,-600,-204\r
+379,189,-542,-576,585,800\r
+440,540,-445,-563,379,-334\r
+-155,64,514,-288,853,106\r
+-304,751,481,-520,-708,-694\r
+-709,132,594,126,-844,63\r
+723,471,421,-138,-962,892\r
+-440,-263,39,513,-672,-954\r
+775,809,-581,330,752,-107\r
+-376,-158,335,-708,-514,578\r
+-343,-769,456,-187,25,413\r
+548,-877,-172,300,-500,928\r
+938,-102,423,-488,-378,-969\r
+-36,564,-55,131,958,-800\r
+-322,511,-413,503,700,-847\r
+-966,547,-88,-17,-359,-67\r
+637,-341,-437,-181,527,-153\r
+-74,449,-28,3,485,189\r
+-997,658,-224,-948,702,-807\r
+-224,736,-896,127,-945,-850\r
+-395,-106,439,-553,-128,124\r
+-841,-445,-758,-572,-489,212\r
+633,-327,13,-512,952,771\r
+-940,-171,-6,-46,-923,-425\r
+-142,-442,-817,-998,843,-695\r
+340,847,-137,-920,-988,-658\r
+-653,217,-679,-257,651,-719\r
+-294,365,-41,342,74,-892\r
+690,-236,-541,494,408,-516\r
+180,-807,225,790,494,59\r
+707,605,-246,656,284,271\r
+65,294,152,824,442,-442\r
+-321,781,-540,341,316,415\r
+420,371,-2,545,995,248\r
+56,-191,-604,971,615,449\r
+-981,-31,510,592,-390,-362\r
+-317,-968,913,365,97,508\r
+832,63,-864,-510,86,202\r
+-483,456,-636,340,-310,676\r
+981,-847,751,-508,-962,-31\r
+-157,99,73,797,63,-172\r
+220,858,872,924,866,-381\r
+996,-169,805,321,-164,971\r
+896,11,-625,-973,-782,76\r
+578,-280,730,-729,307,-905\r
+-580,-749,719,-698,967,603\r
+-821,874,-103,-623,662,-491\r
+-763,117,661,-644,672,-607\r
+592,787,-798,-169,-298,690\r
+296,644,-526,-762,-447,665\r
+534,-818,852,-120,57,-379\r
+-986,-549,-329,294,954,258\r
+-133,352,-660,-77,904,-356\r
+748,343,215,500,317,-277\r
+311,7,910,-896,-809,795\r
+763,-602,-753,313,-352,917\r
+668,619,-474,-597,-650,650\r
+-297,563,-701,-987,486,-902\r
+-461,-740,-657,233,-482,-328\r
+-446,-250,-986,-458,-629,520\r
+542,-49,-327,-469,257,-947\r
+121,-575,-634,-143,-184,521\r
+30,504,455,-645,-229,-945\r
+-12,-295,377,764,771,125\r
+-686,-133,225,-25,-376,-143\r
+-6,-46,338,270,-405,-872\r
+-623,-37,582,467,963,898\r
+-804,869,-477,420,-475,-303\r
+94,41,-842,-193,-768,720\r
+-656,-918,415,645,-357,460\r
+-47,-486,-911,468,-608,-686\r
+-158,251,419,-394,-655,-895\r
+272,-695,979,508,-358,959\r
+-776,650,-918,-467,-690,-534\r
+-85,-309,-626,167,-366,-429\r
+-880,-732,-186,-924,970,-875\r
+517,645,-274,962,-804,544\r
+721,402,104,640,478,-499\r
+198,684,-134,-723,-452,-905\r
+-245,745,239,238,-826,441\r
+-217,206,-32,462,-981,-895\r
+-51,989,526,-173,560,-676\r
+-480,-659,-976,-580,-727,466\r
+-996,-90,-995,158,-239,642\r
+302,288,-194,-294,17,924\r
+-943,969,-326,114,-500,103\r
+-619,163,339,-880,230,421\r
+-344,-601,-795,557,565,-779\r
+590,345,-129,-202,-125,-58\r
+-777,-195,159,674,775,411\r
+-939,312,-665,810,121,855\r
+-971,254,712,815,452,581\r
+442,-9,327,-750,61,757\r
+-342,869,869,-160,390,-772\r
+620,601,565,-169,-69,-183\r
+-25,924,-817,964,321,-970\r
+-64,-6,-133,978,825,-379\r
+601,436,-24,98,-115,940\r
+-97,502,614,-574,922,513\r
+-125,262,-946,695,99,-220\r
+429,-721,719,-694,197,-558\r
+326,689,-70,-908,-673,338\r
+-468,-856,-902,-254,-358,305\r
+-358,530,542,355,-253,-47\r
+-438,-74,-362,963,988,788\r
+137,717,467,622,319,-380\r
+-86,310,-336,851,918,-288\r
+721,395,646,-53,255,-425\r
+255,175,912,84,-209,878\r
+-632,-485,-400,-357,991,-608\r
+235,-559,992,-297,857,-591\r
+87,-71,148,130,647,578\r
+-290,-584,-639,-788,-21,592\r
+386,984,625,-731,-993,-336\r
+-538,634,-209,-828,-150,-774\r
+-754,-387,607,-781,976,-199\r
+412,-798,-664,295,709,-537\r
+-412,932,-880,-232,561,852\r
+-656,-358,-198,-964,-433,-848\r
+-762,-668,-632,186,-673,-11\r
+-876,237,-282,-312,-83,682\r
+403,73,-57,-436,-622,781\r
+-587,873,798,976,-39,329\r
+-369,-622,553,-341,817,794\r
+-108,-616,920,-849,-679,96\r
+290,-974,234,239,-284,-321\r
+-22,394,-417,-419,264,58\r
+-473,-551,69,923,591,-228\r
+-956,662,-113,851,-581,-794\r
+-258,-681,413,-471,-637,-817\r
+-866,926,992,-653,-7,794\r
+556,-350,602,917,831,-610\r
+188,245,-906,361,492,174\r
+-720,384,-818,329,638,-666\r
+-246,846,890,-325,-59,-850\r
+-118,-509,620,-762,-256,15\r
+-787,-536,-452,-338,-399,813\r
+458,560,525,-311,-608,-419\r
+494,-811,-825,-127,-812,894\r
+-801,890,-629,-860,574,925\r
+-709,-193,-213,138,-410,-403\r
+861,91,708,-187,5,-222\r
+789,646,777,154,90,-49\r
+-267,-830,-114,531,591,-698\r
+-126,-82,881,-418,82,652\r
+-894,130,-726,-935,393,-815\r
+-142,563,654,638,-712,-597\r
+-759,60,-23,977,100,-765\r
+-305,595,-570,-809,482,762\r
+-161,-267,53,963,998,-529\r
+-300,-57,798,353,703,486\r
+-990,696,-764,699,-565,719\r
+-232,-205,566,571,977,369\r
+740,865,151,-817,-204,-293\r
+94,445,-768,229,537,-406\r
+861,620,37,-424,-36,656\r
+390,-369,952,733,-464,569\r
+-482,-604,959,554,-705,-626\r
+-396,-615,-991,108,272,-723\r
+143,780,535,142,-917,-147\r
+138,-629,-217,-908,905,115\r
+915,103,-852,64,-468,-642\r
+570,734,-785,-268,-326,-759\r
+738,531,-332,586,-779,24\r
+870,440,-217,473,-383,415\r
+-296,-333,-330,-142,-924,950\r
+118,120,-35,-245,-211,-652\r
+61,634,153,-243,838,789\r
+726,-582,210,105,983,537\r
+-313,-323,758,234,29,848\r
+-847,-172,-593,733,-56,617\r
+54,255,-512,156,-575,675\r
+-873,-956,-148,623,95,200\r
+700,-370,926,649,-978,157\r
+-639,-202,719,130,747,222\r
+194,-33,955,943,505,114\r
+-226,-790,28,-930,827,783\r
+-392,-74,-28,714,218,-612\r
+209,626,-888,-683,-912,495\r
+487,751,614,933,631,445\r
+-348,-34,-411,-106,835,321\r
+-689,872,-29,-800,312,-542\r
+-52,566,827,570,-862,-77\r
+471,992,309,-402,389,912\r
+24,520,-83,-51,555,503\r
+-265,-317,283,-970,-472,690\r
+606,526,137,71,-651,150\r
+217,-518,663,66,-605,-331\r
+-562,232,-76,-503,205,-323\r
+842,-521,546,285,625,-186\r
+997,-927,344,909,-546,974\r
+-677,419,81,121,-705,771\r
+719,-379,-944,-797,784,-155\r
+-378,286,-317,-797,-111,964\r
+-288,-573,784,80,-532,-646\r
+-77,407,-248,-797,769,-816\r
+-24,-637,287,-858,-927,-333\r
+-902,37,894,-823,141,684\r
+125,467,-177,-516,686,399\r
+-321,-542,641,-590,527,-224\r
+-400,-712,-876,-208,632,-543\r
+-676,-429,664,-242,-269,922\r
+-608,-273,-141,930,687,380\r
+786,-12,498,494,310,326\r
+-739,-617,606,-960,804,188\r
+384,-368,-243,-350,-459,31\r
+-550,397,320,-868,328,-279\r
+969,-179,853,864,-110,514\r
+910,793,302,-822,-285,488\r
+-605,-128,218,-283,-17,-227\r
+16,324,667,708,750,3\r
+485,-813,19,585,71,930\r
+-218,816,-687,-97,-732,-360\r
+-497,-151,376,-23,3,315\r
+-412,-989,-610,-813,372,964\r
+-878,-280,87,381,-311,69\r
+-609,-90,-731,-679,150,585\r
+889,27,-162,605,75,-770\r
+448,617,-988,0,-103,-504\r
+-800,-537,-69,627,608,-668\r
+534,686,-664,942,830,920\r
+-238,775,495,932,-793,497\r
+-343,958,-914,-514,-691,651\r
+568,-136,208,359,728,28\r
+286,912,-794,683,556,-102\r
+-638,-629,-484,445,-64,-497\r
+58,505,-801,-110,872,632\r
+-390,777,353,267,976,369\r
+-993,515,105,-133,358,-572\r
+964,996,355,-212,-667,38\r
+-725,-614,-35,365,132,-196\r
+237,-536,-416,-302,312,477\r
+-664,574,-210,224,48,-925\r
+869,-261,-256,-240,-3,-698\r
+712,385,32,-34,916,-315\r
+895,-409,-100,-346,728,-624\r
+-806,327,-450,889,-781,-939\r
+-586,-403,698,318,-939,899\r
+557,-57,-920,659,333,-51\r
+-441,232,-918,-205,246,1\r
+783,167,-797,-595,245,-736\r
+-36,-531,-486,-426,-813,-160\r
+777,-843,817,313,-228,-572\r
+735,866,-309,-564,-81,190\r
+-413,645,101,719,-719,218\r
+-83,164,767,796,-430,-459\r
+122,779,-15,-295,-96,-892\r
+462,379,70,548,834,-312\r
+-630,-534,124,187,-737,114\r
+-299,-604,318,-591,936,826\r
+-879,218,-642,-483,-318,-866\r
+-691,62,-658,761,-895,-854\r
+-822,493,687,569,910,-202\r
+-223,784,304,-5,541,925\r
+-914,541,737,-662,-662,-195\r
+-622,615,414,358,881,-878\r
+339,745,-268,-968,-280,-227\r
+-364,855,148,-709,-827,472\r
+-890,-532,-41,664,-612,577\r
+-702,-859,971,-722,-660,-920\r
+-539,-605,737,149,973,-802\r
+800,42,-448,-811,152,511\r
+-933,377,-110,-105,-374,-937\r
+-766,152,482,120,-308,390\r
+-568,775,-292,899,732,890\r
+-177,-317,-502,-259,328,-511\r
+612,-696,-574,-660,132,31\r
+-119,563,-805,-864,179,-672\r
+425,-627,183,-331,839,318\r
+-711,-976,-749,152,-916,261\r
+181,-63,497,211,262,406\r
+-537,700,-859,-765,-928,77\r
+892,832,231,-749,-82,613\r
+816,216,-642,-216,-669,-912\r
+-6,624,-937,-370,-344,268\r
+737,-710,-869,983,-324,-274\r
+565,952,-547,-158,374,-444\r
+51,-683,645,-845,515,636\r
+-953,-631,114,-377,-764,-144\r
+-8,470,-242,-399,-675,-730\r
+-540,689,-20,47,-607,590\r
+-329,-710,-779,942,-388,979\r
+123,829,674,122,203,563\r
+46,782,396,-33,386,610\r
+872,-846,-523,-122,-55,-190\r
+388,-994,-525,974,127,596\r
+781,-680,796,-34,-959,-62\r
+-749,173,200,-384,-745,-446\r
+379,618,136,-250,-224,970\r
+-58,240,-921,-760,-901,-626\r
+366,-185,565,-100,515,688\r
+489,999,-893,-263,-637,816\r
+838,-496,-316,-513,419,479\r
+107,676,-15,882,98,-397\r
+-999,941,-903,-424,670,-325\r
+171,-979,835,178,169,-984\r
+-609,-607,378,-681,184,402\r
+-316,903,-575,-800,224,983\r
+591,-18,-460,551,-167,918\r
+-756,405,-117,441,163,-320\r
+456,24,6,881,-836,-539\r
+-489,-585,915,651,-892,-382\r
+-177,-122,73,-711,-386,591\r
+181,724,530,686,-131,241\r
+737,288,886,216,233,33\r
+-548,-386,-749,-153,-85,-982\r
+-835,227,904,160,-99,25\r
+-9,-42,-162,728,840,-963\r
+217,-763,870,771,47,-846\r
+-595,808,-491,556,337,-900\r
+-134,281,-724,441,-134,708\r
+-789,-508,651,-962,661,315\r
+-839,-923,339,402,41,-487\r
+300,-790,48,703,-398,-811\r
+955,-51,462,-685,960,-717\r
+910,-880,592,-255,-51,-776\r
+-885,169,-793,368,-565,458\r
+-905,940,-492,-630,-535,-988\r
+245,797,763,869,-82,550\r
+-310,38,-933,-367,-650,824\r
+-95,32,-83,337,226,990\r
+-218,-975,-191,-208,-785,-293\r
+-672,-953,517,-901,-247,465\r
+681,-148,261,-857,544,-923\r
+640,341,446,-618,195,769\r
+384,398,-846,365,671,815\r
+578,576,-911,907,762,-859\r
+548,-428,144,-630,-759,-146\r
+710,-73,-700,983,-97,-889\r
+-46,898,-973,-362,-817,-717\r
+151,-81,-125,-900,-478,-154\r
+483,615,-537,-932,181,-68\r
+786,-223,518,25,-306,-12\r
+-422,268,-809,-683,635,468\r
+983,-734,-694,-608,-110,4\r
+-786,-196,749,-354,137,-8\r
+-181,36,668,-200,691,-973\r
+-629,-838,692,-736,437,-871\r
+-208,-536,-159,-596,8,197\r
+-3,370,-686,170,913,-376\r
+44,-998,-149,-993,-200,512\r
+-519,136,859,497,536,434\r
+77,-985,972,-340,-705,-837\r
+-381,947,250,360,344,322\r
+-26,131,699,750,707,384\r
+-914,655,299,193,406,955\r
+-883,-921,220,595,-546,794\r
+-599,577,-569,-404,-704,489\r
+-594,-963,-624,-460,880,-760\r
+-603,88,-99,681,55,-328\r
+976,472,139,-453,-531,-860\r
+192,-290,513,-89,666,432\r
+417,487,575,293,567,-668\r
+655,711,-162,449,-980,972\r
+-505,664,-685,-239,603,-592\r
+-625,-802,-67,996,384,-636\r
+365,-593,522,-666,-200,-431\r
+-868,708,560,-860,-630,-355\r
+-702,785,-637,-611,-597,960\r
+-137,-696,-93,-803,408,406\r
+891,-123,-26,-609,-610,518\r
+133,-832,-198,555,708,-110\r
+791,617,-69,487,696,315\r
+-900,694,-565,517,-269,-416\r
+914,135,-781,600,-71,-600\r
+991,-915,-422,-351,-837,313\r
+-840,-398,-302,21,590,146\r
+62,-558,-702,-384,-625,831\r
+-363,-426,-924,-496,792,-908\r
+73,361,-817,-466,400,922\r
+-626,-164,-626,860,-524,286\r
+255,26,-944,809,-606,986\r
+-457,-256,-103,50,-867,-871\r
+-223,803,196,480,612,136\r
+-820,-928,700,780,-977,721\r
+717,332,53,-933,-128,793\r
+-602,-648,562,593,890,702\r
+-469,-875,-527,911,-475,-222\r
+110,-281,-552,-536,-816,596\r
+-981,654,413,-981,-75,-95\r
+-754,-742,-515,894,-220,-344\r
+795,-52,156,408,-603,76\r
+474,-157,423,-499,-807,-791\r
+260,688,40,-52,702,-122\r
+-584,-517,-390,-881,302,-504\r
+61,797,665,708,14,668\r
+366,166,458,-614,564,-983\r
+72,539,-378,796,381,-824\r
+-485,201,-588,842,736,379\r
+-149,-894,-298,705,-303,-406\r
+660,-935,-580,521,93,633\r
+-382,-282,-375,-841,-828,171\r
+-567,743,-100,43,144,122\r
+-281,-786,-749,-551,296,304\r
+11,-426,-792,212,857,-175\r
+594,143,-699,289,315,137\r
+341,596,-390,107,-631,-804\r
+-751,-636,-424,-854,193,651\r
+-145,384,749,675,-786,517\r
+224,-865,-323,96,-916,258\r
+-309,403,-388,826,35,-270\r
+-942,709,222,158,-699,-103\r
+-589,842,-997,29,-195,-210\r
+264,426,566,145,-217,623\r
+217,965,507,-601,-453,507\r
+-206,307,-982,4,64,-292\r
+676,-49,-38,-701,550,883\r
+5,-850,-438,659,745,-773\r
+933,238,-574,-570,91,-33\r
+-866,121,-928,358,459,-843\r
+-568,-631,-352,-580,-349,189\r
+-737,849,-963,-486,-662,970\r
+135,334,-967,-71,-365,-792\r
+789,21,-227,51,990,-275\r
+240,412,-886,230,591,256\r
+-609,472,-853,-754,959,661\r
+401,521,521,314,929,982\r
+-499,784,-208,71,-302,296\r
+-557,-948,-553,-526,-864,793\r
+270,-626,828,44,37,14\r
+-412,224,617,-593,502,699\r
+41,-908,81,562,-849,163\r
+165,917,761,-197,331,-341\r
+-687,314,799,755,-969,648\r
+-164,25,578,439,-334,-576\r
+213,535,874,-177,-551,24\r
+-689,291,-795,-225,-496,-125\r
+465,461,558,-118,-568,-909\r
+567,660,-810,46,-485,878\r
+-147,606,685,-690,-774,984\r
+568,-886,-43,854,-738,616\r
+-800,386,-614,585,764,-226\r
+-518,23,-225,-732,-79,440\r
+-173,-291,-689,636,642,-447\r
+-598,-16,227,410,496,211\r
+-474,-930,-656,-321,-420,36\r
+-435,165,-819,555,540,144\r
+-969,149,828,568,394,648\r
+65,-848,257,720,-625,-851\r
+981,899,275,635,465,-877\r
+80,290,792,760,-191,-321\r
+-605,-858,594,33,706,593\r
+585,-472,318,-35,354,-927\r
+-365,664,803,581,-965,-814\r
+-427,-238,-480,146,-55,-606\r
+879,-193,250,-890,336,117\r
+-226,-322,-286,-765,-836,-218\r
+-913,564,-667,-698,937,283\r
+872,-901,810,-623,-52,-709\r
+473,171,717,38,-429,-644\r
+225,824,-219,-475,-180,234\r
+-530,-797,-948,238,851,-623\r
+85,975,-363,529,598,28\r
+-799,166,-804,210,-769,851\r
+-687,-158,885,736,-381,-461\r
+447,592,928,-514,-515,-661\r
+-399,-777,-493,80,-544,-78\r
+-884,631,171,-825,-333,551\r
+191,268,-577,676,137,-33\r
+212,-853,709,798,583,-56\r
+-908,-172,-540,-84,-135,-56\r
+303,311,406,-360,-240,811\r
+798,-708,824,59,234,-57\r
+491,693,-74,585,-85,877\r
+509,-65,-936,329,-51,722\r
+-122,858,-52,467,-77,-609\r
+850,760,547,-495,-953,-952\r
+-460,-541,890,910,286,724\r
+-914,843,-579,-983,-387,-460\r
+989,-171,-877,-326,-899,458\r
+846,175,-915,540,-1000,-982\r
+-852,-920,-306,496,530,-18\r
+338,-991,160,85,-455,-661\r
+-186,-311,-460,-563,-231,-414\r
+-932,-302,959,597,793,748\r
+-366,-402,-788,-279,514,53\r
+-940,-956,447,-956,211,-285\r
+564,806,-911,-914,934,754\r
+575,-858,-277,15,409,-714\r
+848,462,100,-381,135,242\r
+330,718,-24,-190,860,-78\r
+479,458,941,108,-866,-653\r
+212,980,962,-962,115,841\r
+-827,-474,-206,881,323,765\r
+506,-45,-30,-293,524,-133\r
+832,-173,547,-852,-561,-842\r
+-397,-661,-708,819,-545,-228\r
+521,51,-489,852,36,-258\r
+227,-164,189,465,-987,-882\r
+-73,-997,641,-995,449,-615\r
+151,-995,-638,415,257,-400\r
+-663,-297,-748,537,-734,198\r
+-585,-401,-81,-782,-80,-105\r
+99,-21,238,-365,-704,-368\r
+45,416,849,-211,-371,-1\r
+-404,-443,795,-406,36,-933\r
+272,-363,981,-491,-380,77\r
+713,-342,-366,-849,643,911\r
+-748,671,-537,813,961,-200\r
+-194,-909,703,-662,-601,188\r
+281,500,724,286,267,197\r
+-832,847,-595,820,-316,637\r
+520,521,-54,261,923,-10\r
+4,-808,-682,-258,441,-695\r
+-793,-107,-969,905,798,446\r
+-108,-739,-590,69,-855,-365\r
+380,-623,-930,817,468,713\r
+759,-849,-236,433,-723,-931\r
+95,-320,-686,124,-69,-329\r
+-655,518,-210,-523,284,-866\r
+144,303,639,70,-171,269\r
+173,-333,947,-304,55,40\r
+274,878,-482,-888,-835,375\r
+-982,-854,-36,-218,-114,-230\r
+905,-979,488,-485,-479,114\r
+877,-157,553,-530,-47,-321\r
+350,664,-881,442,-220,-284\r
+434,-423,-365,878,-726,584\r
+535,909,-517,-447,-660,-141\r
+-966,191,50,353,182,-642\r
+-785,-634,123,-907,-162,511\r
+146,-850,-214,814,-704,25\r
+692,1,521,492,-637,274\r
+-662,-372,-313,597,983,-647\r
+-962,-526,68,-549,-819,231\r
+740,-890,-318,797,-666,948\r
+-190,-12,-468,-455,948,284\r
+16,478,-506,-888,628,-154\r
+272,630,-976,308,433,3\r
+-169,-391,-132,189,302,-388\r
+109,-784,474,-167,-265,-31\r
+-177,-532,283,464,421,-73\r
+650,635,592,-138,1,-387\r
+-932,703,-827,-492,-355,686\r
+586,-311,340,-618,645,-434\r
+-951,736,647,-127,-303,590\r
+188,444,903,718,-931,500\r
+-872,-642,-296,-571,337,241\r
+23,65,152,125,880,470\r
+512,823,-42,217,823,-263\r
+180,-831,-380,886,607,762\r
+722,443,-149,-216,-115,759\r
+-19,660,-36,901,923,231\r
+562,-322,-626,-968,194,-825\r
+204,-920,938,784,362,150\r
+-410,-266,-715,559,-672,124\r
+-198,446,-140,454,-461,-447\r
+83,-346,830,-493,-759,-382\r
+-881,601,581,234,-134,-925\r
+-494,914,-42,899,235,629\r
+-390,50,956,437,774,-700\r
+-514,514,44,-512,-576,-313\r
+63,-688,808,-534,-570,-399\r
+-726,572,-896,102,-294,-28\r
+-688,757,401,406,955,-511\r
+-283,423,-485,480,-767,908\r
+-541,952,-594,116,-854,451\r
+-273,-796,236,625,-626,257\r
+-407,-493,373,826,-309,297\r
+-750,955,-476,641,-809,713\r
+8,415,695,226,-111,2\r
+733,209,152,-920,401,995\r
+921,-103,-919,66,871,-947\r
+-907,89,-869,-214,851,-559\r
+-307,748,524,-755,314,-711\r
+188,897,-72,-763,482,103\r
+545,-821,-232,-596,-334,-754\r
+-217,-788,-820,388,-200,-662\r
+779,160,-723,-975,-142,-998\r
+-978,-519,-78,-981,842,904\r
+-504,-736,-295,21,-472,-482\r
+391,115,-705,574,652,-446\r
+813,-988,865,830,-263,487\r
+194,80,774,-493,-761,-872\r
+-415,-284,-803,7,-810,670\r
+-484,-4,881,-872,55,-852\r
+-379,822,-266,324,-48,748\r
+-304,-278,406,-60,959,-89\r
+404,756,577,-643,-332,658\r
+291,460,125,491,-312,83\r
+311,-734,-141,582,282,-557\r
+-450,-661,-981,710,-177,794\r
+328,264,-787,971,-743,-407\r
+-622,518,993,-241,-738,229\r
+273,-826,-254,-917,-710,-111\r
+809,770,96,368,-818,725\r
+-488,773,502,-342,534,745\r
+-28,-414,236,-315,-484,363\r
+179,-466,-566,713,-683,56\r
+560,-240,-597,619,916,-940\r
+893,473,872,-868,-642,-461\r
+799,489,383,-321,-776,-833\r
+980,490,-508,764,-512,-426\r
+917,961,-16,-675,440,559\r
+-812,212,784,-987,-132,554\r
+-886,454,747,806,190,231\r
+910,341,21,-66,708,725\r
+29,929,-831,-494,-303,389\r
+-103,492,-271,-174,-515,529\r
+-292,119,419,788,247,-951\r
+483,543,-347,-673,664,-549\r
+-926,-871,-437,337,162,-877\r
+299,472,-771,5,-88,-643\r
+-103,525,-725,-998,264,22\r
+-505,708,550,-545,823,347\r
+-738,931,59,147,-156,-259\r
+456,968,-162,889,132,-911\r
+535,120,968,-517,-864,-541\r
+24,-395,-593,-766,-565,-332\r
+834,611,825,-576,280,629\r
+211,-548,140,-278,-592,929\r
+-999,-240,-63,-78,793,573\r
+-573,160,450,987,529,322\r
+63,353,315,-187,-461,577\r
+189,-950,-247,656,289,241\r
+209,-297,397,664,-805,484\r
+-655,452,435,-556,917,874\r
+253,-756,262,-888,-778,-214\r
+793,-451,323,-251,-401,-458\r
+-396,619,-651,-287,-668,-781\r
+698,720,-349,742,-807,546\r
+738,280,680,279,-540,858\r
+-789,387,530,-36,-551,-491\r
+162,579,-427,-272,228,710\r
+689,356,917,-580,729,217\r
+-115,-638,866,424,-82,-194\r
+411,-338,-917,172,227,-29\r
+-612,63,630,-976,-64,-204\r
+-200,911,583,-571,682,-579\r
+91,298,396,-183,788,-955\r
+141,-873,-277,149,-396,916\r
+321,958,-136,573,541,-777\r
+797,-909,-469,-877,988,-653\r
+784,-198,129,883,-203,399\r
+-68,-810,223,-423,-467,-512\r
+531,-445,-603,-997,-841,641\r
+-274,-242,174,261,-636,-158\r
+-574,494,-796,-798,-798,99\r
+95,-82,-613,-954,-753,986\r
+-883,-448,-864,-401,938,-392\r
+913,930,-542,-988,310,410\r
+506,-99,43,512,790,-222\r
+724,31,49,-950,260,-134\r
+-287,-947,-234,-700,56,588\r
+-33,782,-144,948,105,-791\r
+548,-546,-652,-293,881,-520\r
+691,-91,76,991,-631,742\r
+-520,-429,-244,-296,724,-48\r
+778,646,377,50,-188,56\r
+-895,-507,-898,-165,-674,652\r
+654,584,-634,177,-349,-620\r
+114,-980,355,62,182,975\r
+516,9,-442,-298,274,-579\r
+-238,262,-431,-896,506,-850\r
+47,748,846,821,-537,-293\r
+839,726,593,285,-297,840\r
+634,-486,468,-304,-887,-567\r
+-864,914,296,-124,335,233\r
+88,-253,-523,-956,-554,803\r
+-587,417,281,-62,-409,-363\r
+-136,-39,-292,-768,-264,876\r
+-127,506,-891,-331,-744,-430\r
+778,584,-750,-129,-479,-94\r
+-876,-771,-987,-757,180,-641\r
+-777,-694,411,-87,329,190\r
+-347,-999,-882,158,-754,232\r
+-105,918,188,237,-110,-591\r
+-209,703,-838,77,838,909\r
+-995,-339,-762,750,860,472\r
+185,271,-289,173,811,-300\r
+2,65,-656,-22,36,-139\r
+765,-210,883,974,961,-905\r
+-212,295,-615,-840,77,474\r
+211,-910,-440,703,-11,859\r
+-559,-4,-196,841,-277,969\r
+-73,-159,-887,126,978,-371\r
+-569,633,-423,-33,512,-393\r
+503,143,-383,-109,-649,-998\r
+-663,339,-317,-523,-2,596\r
+690,-380,570,378,-652,132\r
+72,-744,-930,399,-525,935\r
+865,-983,115,37,995,826\r
+594,-621,-872,443,188,-241\r
+-1000,291,754,234,-435,-869\r
+-868,901,654,-907,59,181\r
+-868,-793,-431,596,-446,-564\r
+900,-944,-680,-796,902,-366\r
+331,430,943,853,-851,-942\r
+315,-538,-354,-909,139,721\r
+170,-884,-225,-818,-808,-657\r
+-279,-34,-533,-871,-972,552\r
+691,-986,-800,-950,654,-747\r
+603,988,899,841,-630,591\r
+876,-949,809,562,602,-536\r
+-693,363,-189,495,738,-1000\r
+-383,431,-633,297,665,959\r
+-740,686,-207,-803,188,-520\r
+-820,226,31,-339,10,121\r
+-312,-844,624,-516,483,621\r
+-822,-529,69,-278,800,328\r
+834,-82,-759,420,811,-264\r
+-960,-240,-921,561,173,46\r
+-324,909,-790,-814,-2,-785\r
+976,334,-290,-891,704,-581\r
+150,-798,689,-823,237,-639\r
+-551,-320,876,-502,-622,-628\r
+-136,845,904,595,-702,-261\r
+-857,-377,-522,-101,-943,-805\r
+-682,-787,-888,-459,-752,-985\r
+-571,-81,623,-133,447,643\r
+-375,-158,72,-387,-324,-696\r
+-660,-650,340,188,569,526\r
+727,-218,16,-7,-595,-988\r
+-966,-684,802,-783,-272,-194\r
+115,-566,-888,47,712,180\r
+-237,-69,45,-272,981,-812\r
+48,897,439,417,50,325\r
+348,616,180,254,104,-784\r
+-730,811,-548,612,-736,790\r
+138,-810,123,930,65,865\r
+-768,-299,-49,-895,-692,-418\r
+487,-531,802,-159,-12,634\r
+808,-179,552,-73,470,717\r
+720,-644,886,-141,625,144\r
+-485,-505,-347,-244,-916,66\r
+600,-565,995,-5,324,227\r
+-771,-35,904,-482,753,-303\r
+-701,65,426,-763,-504,-479\r
+409,733,-823,475,64,718\r
+865,975,368,893,-413,-433\r
+812,-597,-970,819,813,624\r
+193,-642,-381,-560,545,398\r
+711,28,-316,771,717,-865\r
+-509,462,809,-136,786,635\r
+618,-49,484,169,635,547\r
+-747,685,-882,-496,-332,82\r
+-501,-851,870,563,290,570\r
+-279,-829,-509,397,457,816\r
+-508,80,850,-188,483,-326\r
+860,-100,360,119,-205,787\r
+-870,21,-39,-827,-185,932\r
+826,284,-136,-866,-330,-97\r
+-944,-82,745,899,-97,365\r
+929,262,564,632,-115,632\r
+244,-276,713,330,-897,-214\r
+-890,-109,664,876,-974,-907\r
+716,249,816,489,723,141\r
+-96,-560,-272,45,-70,645\r
+762,-503,414,-828,-254,-646\r
+909,-13,903,-422,-344,-10\r
+658,-486,743,545,50,674\r
+-241,507,-367,18,-48,-241\r
+886,-268,884,-762,120,-486\r
+-412,-528,879,-647,223,-393\r
+851,810,234,937,-726,797\r
+-999,942,839,-134,-996,-189\r
+100,979,-527,-521,378,800\r
+544,-844,-832,-530,-77,-641\r
+43,889,31,442,-934,-503\r
+-330,-370,-309,-439,173,547\r
+169,945,62,-753,-542,-597\r
+208,751,-372,-647,-520,70\r
+765,-840,907,-257,379,918\r
+334,-135,-689,730,-427,618\r
+137,-508,66,-695,78,169\r
+-962,-123,400,-417,151,969\r
+328,689,666,427,-555,-642\r
+-907,343,605,-341,-647,582\r
+-667,-363,-571,818,-265,-399\r
+525,-938,904,898,725,692\r
+-176,-802,-858,-9,780,275\r
+580,170,-740,287,691,-97\r
+365,557,-375,361,-288,859\r
+193,737,842,-808,520,282\r
+-871,65,-799,836,179,-720\r
+958,-144,744,-789,797,-48\r
+122,582,662,912,68,757\r
+595,241,-801,513,388,186\r
+-103,-677,-259,-731,-281,-857\r
+921,319,-696,683,-88,-997\r
+775,200,78,858,648,768\r
+316,821,-763,68,-290,-741\r
+564,664,691,504,760,787\r
+694,-119,973,-385,309,-760\r
+777,-947,-57,990,74,19\r
+971,626,-496,-781,-602,-239\r
+-651,433,11,-339,939,294\r
+-965,-728,560,569,-708,-247\r
--- /dev/null
+USING: project-euler.112 tools.test ;
+IN: project-euler.112.tests
+
+[ 1587000 ] [ euler112 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Guillaume Nargeot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math project-euler.common sequences sorting ;
+IN: project-euler.112
+
+! http://projecteuler.net/index.php?section=problems&id=112
+
+! DESCRIPTION
+! -----------
+
+! Working from left-to-right if no digit is exceeded by the digit to its left
+! it is called an increasing number; for example, 134468.
+
+! Similarly if no digit is exceeded by the digit to its right it is called a
+! decreasing number; for example, 66420.
+
+! We shall call a positive integer that is neither increasing nor decreasing a
+! "bouncy" number; for example, 155349.
+
+! Clearly there cannot be any bouncy numbers below one-hundred, but just over
+! half of the numbers below one-thousand (525) are bouncy. In fact, the least
+! number for which the proportion of bouncy numbers first reaches 50% is 538.
+
+! Surprisingly, bouncy numbers become more and more common and by the time we
+! reach 21780 the proportion of bouncy numbers is equal to 90%.
+
+! Find the least number for which the proportion of bouncy numbers is exactly
+! 99%.
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: bouncy? ( n -- ? )
+ number>digits dup natural-sort
+ [ = not ] [ reverse = not ] 2bi and ;
+
+PRIVATE>
+
+: euler112 ( -- answer )
+ 0 0 0 [
+ 2dup swap 99 * = not
+ ] [
+ [ 1 + ] 2dip pick bouncy? [ 1 + ] [ [ 1 + ] dip ] if
+ ] do while 2drop ;
+
+! [ euler112 ] 100 ave-time
+! 2749 ms ave run time - 33.76 SD (100 trials)
+
+SOLUTION: euler112
USING: project-euler.186 tools.test ;
IN: project-euler.186.tests
-[ 2325629 ] [ euler186 ] unit-test
+! Uses too much memory; don't want to run on build machines
+! [ 2325629 ] [ euler186 ] unit-test
Aaron Schaefer
Eric Mertens
+Guillaume Nargeot
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test project-euler.common ;
+IN: project-euler.common.tests
+
+[ 4 ] [ -1000 number-length ] unit-test
+[ 3 ] [ -999 number-length ] unit-test
+[ 3 ] [ -100 number-length ] unit-test
+[ 2 ] [ -99 number-length ] unit-test
+[ 1 ] [ -9 number-length ] unit-test
+[ 1 ] [ -1 number-length ] unit-test
+[ 1 ] [ 0 number-length ] unit-test
+[ 1 ] [ 9 number-length ] unit-test
+[ 2 ] [ 99 number-length ] unit-test
+[ 3 ] [ 100 number-length ] unit-test
+[ 3 ] [ 999 number-length ] unit-test
+[ 4 ] [ 1000 number-length ] unit-test
[ dup 0 = not ] [ 10 /mod ] produce reverse nip ;
: number-length ( n -- m )
- log10 floor 1 + >integer ;
+ abs [
+ 1
+ ] [
+ 1 0 [ 2over >= ]
+ [ [ 10 * ] [ 1 + ] bi* ] while 2nip
+ ] if-zero ;
: nth-prime ( n -- n )
1 - lprimes lnth ;
number>string natural-sort >string "123456789" = ;
: pentagonal? ( n -- ? )
- dup 0 > [ 24 * 1 + sqrt 1 + 6 / 1 mod zero? ] [ drop f ] if ;
+ dup 0 > [ 24 * 1 + sqrt 1 + 6 / 1 mod zero? ] [ drop f ] if ; inline
: penultimate ( seq -- elt )
dup length 2 - swap nth ;
project-euler.055 project-euler.056 project-euler.057 project-euler.058
project-euler.059 project-euler.063 project-euler.067 project-euler.069
project-euler.071 project-euler.073 project-euler.075 project-euler.076
- project-euler.079 project-euler.092 project-euler.097 project-euler.099
- project-euler.100 project-euler.116 project-euler.117 project-euler.134
- project-euler.148 project-euler.150 project-euler.151 project-euler.164
- project-euler.169 project-euler.173 project-euler.175 project-euler.186
- project-euler.190 project-euler.203 project-euler.215 ;
+ project-euler.079 project-euler.085 project-euler.092 project-euler.097
+ project-euler.099 project-euler.100 project-euler.102 project-euler.112
+ project-euler.116 project-euler.117 project-euler.134 project-euler.148
+ project-euler.150 project-euler.151 project-euler.164 project-euler.169
+ project-euler.173 project-euler.175 project-euler.186 project-euler.190
+ project-euler.203 project-euler.215 ;
IN: project-euler
<PRIVATE
--- /dev/null
+USING: classes.struct cocoa core-foundation.strings ;
+IN: qtkit
+
+STRUCT: QTTime
+ { timeValue longlong }
+ { timeScale long }
+ { flags long } ;
+
+STRUCT: QTTimeRange
+ { time QTTime }
+ { duration QTTime } ;
+
+STRUCT: SMPTETime
+ { mSubframes SInt16 }
+ { mSubframeDivisor SInt16 }
+ { mCounter UInt32 }
+ { mType UInt32 }
+ { mFlags UInt32 }
+ { mHours SInt16 }
+ { mMinutes SInt16 }
+ { mSeconds SInt16 }
+ { mFrames SInt16 } ;
+
+CFSTRING: QTKitErrorDomain "QTKitErrorDomain"
+CFSTRING: QTErrorCaptureInputKey "QTErrorCaptureInputKey"
+CFSTRING: QTErrorCaptureOutputKey "QTErrorCaptureOutputKey"
+CFSTRING: QTErrorDeviceKey "QTErrorDeviceKey"
+CFSTRING: QTErrorExcludingDeviceKey "QTErrorExcludingDeviceKey"
+CFSTRING: QTErrorTimeKey "QTErrorTimeKey"
+CFSTRING: QTErrorFileSizeKey "QTErrorFileSizeKey"
+CFSTRING: QTErrorRecordingSuccesfullyFinishedKey "QTErrorRecordingSuccesfullyFinishedKey"
+
+CONSTANT: QTErrorUnknown -1
+CONSTANT: QTErrorIncompatibleInput 1002
+CONSTANT: QTErrorIncompatibleOutput 1003
+CONSTANT: QTErrorInvalidInputsOrOutputs 1100
+CONSTANT: QTErrorDeviceAlreadyUsedbyAnotherSession 1101
+CONSTANT: QTErrorNoDataCaptured 1200
+CONSTANT: QTErrorSessionConfigurationChanged 1201
+CONSTANT: QTErrorDiskFull 1202
+CONSTANT: QTErrorDeviceWasDisconnected 1203
+CONSTANT: QTErrorMediaChanged 1204
+CONSTANT: QTErrorMaximumDurationReached 1205
+CONSTANT: QTErrorMaximumFileSizeReached 1206
+CONSTANT: QTErrorMediaDiscontinuity 1207
+CONSTANT: QTErrorMaximumNumberOfSamplesForFileFormatReached 1208
+CONSTANT: QTErrorDeviceNotConnected 1300
+CONSTANT: QTErrorDeviceInUseByAnotherApplication 1301
+CONSTANT: QTErrorDeviceExcludedByAnotherDevice 1302
+
+FRAMEWORK: /System/Library/Frameworks/QTKit.framework
+
+IMPORT: QTCaptureAudioPreviewOutput
+IMPORT: QTCaptureConnection
+IMPORT: QTCaptureDecompressedAudioOutput
+IMPORT: QTCaptureDecompressedVideoOutput
+IMPORT: QTCaptureDevice
+IMPORT: QTCaptureDeviceInput
+IMPORT: QTCaptureFileOutput
+IMPORT: QTCaptureInput
+IMPORT: QTCaptureLayer
+IMPORT: QTCaptureMovieFileOutput
+IMPORT: QTCaptureOutput
+IMPORT: QTCaptureSession
+IMPORT: QTCaptureVideoPreviewOutput
+IMPORT: QTCaptureView
+IMPORT: QTCompressionOptions
+IMPORT: QTDataReference
+IMPORT: QTFormatDescription
+IMPORT: QTMedia
+IMPORT: QTMovie
+IMPORT: QTMovieLayer
+IMPORT: QTMovieView
+IMPORT: QTSampleBuffer
+IMPORT: QTTrack
+
--- /dev/null
+unportable
[ [ % ] each ] product-each
] "" make
] unit-test
+
+[ { } ] [ { { } { 1 } } [ ] product-map ] unit-test
+[ ] [ { { } { 1 } } [ drop ] product-each ] unit-test
: product-iter ( ns lengths -- )
[ 0 over [ 1 + ] change-nth ] dip carry-ns ;
-: start-product-iter ( sequence-product -- ns lengths )
+: start-product-iter ( sequences -- ns lengths )
[ [ drop 0 ] map ] [ [ length ] map ] bi ;
: end-product-iter? ( ns lengths -- ? )
:: product-each ( sequences quot -- )
sequences start-product-iter :> lengths :> ns
- [ ns lengths end-product-iter? ]
- [ ns sequences nths quot call ns lengths product-iter ] until ; inline
+ lengths [ 0 = ] any? [
+ [ ns lengths end-product-iter? ]
+ [ ns sequences nths quot call ns lengths product-iter ] until
+ ] unless ; inline
:: product-map ( sequences quot -- sequence )
0 :> i!
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged specialized-arrays.uchar specialized-arrays.short ;
+USING: accessors alien.c-types combinators kernel locals math
+math.ranges openal sequences sequences.merged specialized-arrays ;
+SPECIALIZED-ARRAY: uchar
+SPECIALIZED-ARRAY: short
IN: synth.buffers
TUPLE: buffer sample-freq 8bit? id ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: unix alien alien.c-types kernel math sequences strings
-io.backend.unix splitting io.encodings.utf8 io.encodings.string ;
+io.backend.unix splitting io.encodings.utf8 io.encodings.string
+specialized-arrays ;
+SPECIALIZED-ARRAY: char
IN: system-info.linux
: (uname) ( buf -- int )
"int" f "uname" { "char*" } alien-invoke ;
: uname ( -- seq )
- 65536 "char" <c-array> [ (uname) io-error ] keep
+ 65536 <char-array> [ (uname) io-error ] keep
"\0" split harvest [ utf8 decode ] map
6 "" pad-tail ;
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 +
! 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 specialized-arrays ;
+SPECIALIZED-ARRAY: ushort
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>
- "OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize
+ OSVERSIONINFO <struct>
+ OSVERSIONINFO heap-size >>dwOSVersionInfoSize
dup GetVersionEx win32-error=0/f ;
: windows-major ( -- n )
- os-version OSVERSIONINFO-dwMajorVersion ;
+ os-version dwMajorVersion>> ;
: windows-minor ( -- n )
- os-version OSVERSIONINFO-dwMinorVersion ;
+ os-version dwMinorVersion>> ;
: windows-build# ( -- n )
- os-version OSVERSIONINFO-dwBuildNumber ;
+ os-version dwBuildNumber>> ;
: windows-platform-id ( -- n )
- os-version OSVERSIONINFO-dwPlatformId ;
+ os-version dwPlatformId>> ;
: windows-service-pack ( -- string )
- os-version OSVERSIONINFO-szCSDVersion alien>native-string ;
+ os-version szCSDVersion>> alien>native-string ;
: feature-present? ( n -- ? )
IsProcessorFeaturePresent zero? not ;
: sse3? ( -- ? )
PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
-: <u16-string-object> ( n -- obj )
- "ushort" <c-array> ;
-
: get-directory ( word -- str )
- [ MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd ] dip
+ [ MAX_UNICODE_PATH [ <ushort-array> ] keep dupd ] dip
execute win32-error=0/f alien>native-string ; inline
: windows-directory ( -- str )
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs combinators constructors eval help.markup kernel
+multiline namespaces parser sequences sequences.private slides
+vocabs.refresh words fry ;
+IN: tc-lisp-talk
+
+CONSTANT: tc-lisp-slides
+{
+ { $slide "Factor!"
+ { $url "http://factorcode.org" }
+ "Development started in 2003"
+ "Open source (BSD license)"
+ "Influenced by Forth, Lisp, and Smalltalk"
+ "Blurs the line between language and library"
+ "Interactive development"
+ }
+ { $slide "First, some examples"
+ { $code "3 weeks ago noon monday ." }
+ { $code "USE: roman 2009 >roman ." }
+ { $code <" : average ( seq -- x )
+ [ sum ] [ length ] bi / ;"> }
+ { $code "1 miles [ km ] undo >float ." }
+ { $code "[ readln eval>string print t ] loop" }
+ }
+ { $slide "XML Literals"
+ { $code
+ <" USING: splitting xml.writer xml.syntax ;
+{ "one" "two" "three" }
+[ [XML <item><-></item> XML] ] map
+<XML <doc><-></doc> XML> pprint-xml">
+ }
+ }
+ { $slide "Differences between Factor and Lisp"
+ "Single-implementation language"
+ "Less nesting, shorter word length"
+ { "Dynamic reloading of code from files with " { $link refresh-all } }
+ "More generic protocols -- sequences, assocs, streams"
+ "More cross-platform"
+ "No standard for the language"
+ "Evaluates left to right"
+ }
+ { $slide "Terminology"
+ { "Words - functions" }
+ { "Vocabularies - collections of code in the same namespace" }
+ { "Quotations - blocks of code" { $code "[ dup reverse append ]" } }
+ { "Combinators - higher order functions" }
+ { "Static stack effect - known stack effect at compile-time" }
+ }
+ { $slide "Defining a word"
+ "Defined at parse time"
+ "Parts: name, stack effect, definition"
+ "Composed of tokens separated by whitespace"
+ { $code ": palindrome? ( string -- ? ) dup reverse = ;" }
+ }
+ { $slide "Non-static stack effect"
+ "Not a good practice, nor useful"
+ "Not compiled by the optimizing compiler"
+ { $code "100 iota [ ] each" }
+ }
+ { $slide "Module system"
+ "Code divided up into vocabulary roots"
+ "core/ -- just enough code to bootstrap Factor"
+ "basis/ -- optimizing compiler, the UI, tools, libraries"
+ "extra/ -- demos, unpolished code, experiments"
+ "work/ -- your works in progress"
+ }
+ { $slide "Module system (part 2)"
+ "Each vocabulary corresponds to a directory on disk, with documentation and test files"
+ { "Code for the " { $snippet "math" } " vocabulary: " { $snippet "~/factor/core/math/math.factor" } }
+ { "Documentation for the " { $snippet "math" } " vocabulary: " { $snippet "~/factor/core/math/math-docs.factor" } }
+ { "Unit tests for the " { $snippet "math" } " vocabulary: " { $snippet " ~/factor/core/math/math-tests.factor" } }
+ }
+ { $slide "Using a library"
+ "Each file starts with a USING: list"
+ "To use a library, simply include it in this list"
+ "Refreshing code loads dependencies correctly"
+ }
+ { $slide "Object system"
+ "Based on CLOS"
+ { "We define generic words that operate on the top of the stack with " { $link POSTPONE: GENERIC: } " or on an implicit parameter with " { $link POSTPONE: HOOK: } }
+ }
+ { $slide "Object system example: shape protocol"
+ "In ~/factor/work/shapes/shapes.factor"
+ { $code <" IN: shapes
+
+GENERIC: area ( shape -- x )
+GENERIC: perimeter ( shape -- x )">
+ }
+ }
+ { $slide "Implementing the shape protocol: circles"
+ "In ~/factor/work/shapes/circle/circle.factor"
+ { $code <" USING: shapes constructors math
+math.constants ;
+IN: shapes.circle
+
+TUPLE: circle radius ;
+CONSTRUCTOR: circle ( radius -- obj ) ;
+M: circle area radius>> sq pi * ;
+M: circle perimeter radius>> pi * 2 * ;">
+ }
+ }
+ { $slide "Dynamic variables"
+ "Implemented as a stack of hashtables"
+ { "Useful words are " { $link get } ", " { $link set } }
+ "Input, output, error streams are stored in dynamic variables"
+ { $code <" "Today is the first day of the rest of your life."
+[
+ readln print
+] with-string-reader">
+ }
+ }
+ { $slide "The global namespace"
+ "The global namespace is just the namespace at the bottom of the namespace stack"
+ { "Useful words are " { $link get-global } ", " { $link set-global } }
+ "Factor idiom for changing a particular namespace"
+ { $code <" SYMBOL: king
+global [ "Henry VIII" king set ] bind">
+ }
+ { $code "with-scope" }
+ { $code "namestack" }
+ }
+ { $slide "Hooks"
+ "Dispatch on a dynamic variable"
+ { $code <" HOOK: computer-name os ( -- string )
+M: macosx computer-name uname first ;
+macosx \ os set-global
+computer-name">
+ }
+ }
+ { $slide "Interpolate"
+ "Replaces variables in a string"
+ { $code
+<" "Dawg" "name" set
+"rims" "noun" set
+"bling" "verb1" set
+"roll" "verb2" set
+[
+ "Sup ${name}, we heard you liked ${noun}, so we put ${noun} on your car so you can ${verb1} while you ${verb2}."
+ interpolate
+] with-string-writer print ">
+ }
+ }
+ { $slide "Sequence protocol"
+ "All sequences obey a protocol of generics"
+ { "Is an object a " { $link sequence? } }
+ { "Getting the " { $link length } }
+ { "Accessing the " { $link nth } " element" }
+ { "Setting an element - " { $link set-nth } }
+ }
+ { $slide "Examples of sequences in Factor"
+ "Arrays are mutable"
+ "Vectors are mutable and growable"
+ { "Arrays " { $code "{ \"abc\" \"def\" 50 }" } }
+ { "Vectors " { $code "V{ \"abc\" \"def\" 50 }" } }
+ { "Byte-arrays " { $code "B{ 1 2 3 }" } }
+ { "Byte-vectors " { $code "BV{ 11 22 33 }" } }
+ }
+ { $slide "Specialized arrays and vectors"
+ { "Specialized int arrays " { $code "int-array{ -20 -30 40 }" } }
+ { "Specialized uint arrays " { $code "uint-array{ 20 30 40 }" } }
+ { "Specialized float vectors " { $code "float-vector{ 20 30 40 }" } }
+ "35 others C-type arrays"
+ }
+ { $slide "Specialized arrays code"
+ "One line per array/vector"
+ { "In ~/factor/basis/specialized-arrays/float/float.factor"
+ { $code <" << "float" define-array >>"> }
+ }
+ { "In ~/factor/basis/specialized-vectors/float/float.factor"
+ { $code <" << "float" define-vector >>"> }
+ }
+ }
+
+ { $slide "Speciailzied arrays are implemented using functors"
+ "Like C++ templates"
+ "Eliminate boilerplate in ways other abstractions don't"
+ "Contains a definition section and a functor body"
+ "Uses the interpolate vocabulary"
+ }
+ { $slide "Functor for sorting"
+ { $code
+ <" FUNCTOR: define-sorting ( NAME QUOT -- )
+
+NAME<=> DEFINES ${NAME}<=>
+NAME>=< DEFINES ${NAME}>=<
+
+WHERE
+
+: NAME<=> ( obj1 obj2 -- <=> ) QUOT compare ;
+: NAME>=< ( obj1 obj2 -- >=< )
+ NAME<=> invert-comparison ;
+
+;FUNCTOR">
+ }
+ }
+ { $slide "Example of sorting functor"
+ { $code <" USING: sorting.functor ;
+<< "length" [ length ] define-sorting >>">
+ }
+ { $code
+ <" { { 1 2 3 } { 1 2 } { 1 } }
+[ length<=> ] sort">
+ }
+ }
+ { $slide "Combinators"
+ "Used to implement higher order functions (dataflow and control flow)"
+ "Compiler optimizes away quotations completely"
+ "Optimized code is just tight loops in registers"
+ "Most loops can be expressed with combinators or tail-recursion"
+ }
+ { $slide "Combinators that act on one value"
+ { $link bi }
+ { $code "10 [ 1 - ] [ 1 + ] bi" }
+ { $link tri }
+ { $code "10 [ 1 - ] [ 1 + ] [ 2 * ] tri" }
+ }
+ { $slide "Combinators that act on two values"
+ { $link 2bi }
+ { $code "10 1 [ - ] [ + ] 2bi" }
+ { $link bi* }
+ { $code "10 20 [ 1 - ] [ 1 + ] bi*" }
+ { $link bi@ }
+ { $code "5 9 [ sq ] bi@" }
+ }
+ { $slide "Sequence combinators"
+
+ { $link each }
+ { $code "{ 1 2 3 4 5 } [ sq . ] each" }
+ { $link map }
+ { $code "{ 1 2 3 4 5 } [ sq ] map" }
+ { $link filter }
+ { $code "{ 1 2 3 4 5 } [ even? ] filter" }
+ }
+ { $slide "Multiple sequence combinators"
+
+ { $link 2each }
+ { $code "{ 1 2 3 } { 10 20 30 } [ + . ] 2each" }
+ { $link 2map }
+ { $code "{ 1 2 3 } { 10 20 30 } [ + ] 2map" }
+ }
+ { $slide "Control flow: if"
+ { $link if }
+ { $code <" 10 random dup even? [ 2 / ] [ 1 - ] if"> }
+ { $link when }
+ { $code <" 10 random dup even? [ 2 / ] when"> }
+ { $link unless }
+ { $code <" 10 random dup even? [ 1 - ] unless"> }
+ }
+ { $slide "Control flow: case"
+ { $link case }
+ { $code <" ERROR: not-possible obj ;
+10 random 5 <=> {
+ { +lt+ [ "Less" ] }
+ { +gt+ [ "More" ] }
+ { +eq+ [ "Equal" ] }
+ [ not-possible ]
+} case">
+ }
+ }
+ { $slide "Fry"
+ "Used to construct quotations"
+ { "'Holes', represented by " { $snippet "_" } " are filled left to right" }
+ { $code "10 4 '[ _ + ] call" }
+ { $code "3 4 '[ _ sq _ + ] call" }
+ }
+ { $slide "Locals"
+ "When data flow combinators and shuffle words are not enough"
+ "Name your input parameters"
+ "Used in about 1% of all words"
+ }
+ { $slide "Locals example"
+ "Area of a triangle using Heron's formula"
+ { $code
+ <" :: area ( a b c -- x )
+ a b c + + 2 / :> p
+ p
+ p a - *
+ p b - *
+ p c - * sqrt ;">
+ }
+ }
+ { $slide "Previous example without locals"
+ "A bit unwieldy..."
+ { $code
+ <" : area ( a b c -- x )
+ [ ] [ + + 2 / ] 3bi
+ [ '[ _ - ] tri@ ] [ neg ] bi
+ * * * sqrt ;"> }
+ }
+ { $slide "More idiomatic version"
+ "But there's a trick: put the lengths in an array"
+ { $code <" : v-n ( v n -- w ) '[ _ - ] map ;
+
+: area ( seq -- x )
+ [ 0 suffix ] [ sum 2 / ] bi
+ v-n product sqrt ;"> }
+ }
+ { $slide "Implementing an abstraction"
+ { "Suppose we want to get the price of the customer's first order, but any one of the steps along the way could be a nil value (" { $link f } " in Factor):" }
+ { $code
+ "dup [ orders>> ] when"
+ "dup [ first ] when"
+ "dup [ price>> ] when"
+ }
+ }
+ { $slide "This is hard with mainstream syntax!"
+ { $code
+ <" var customer = ...;
+var orders = (customer == null ? null : customer.orders);
+var order = (orders == null ? null : orders[0]);
+var price = (order == null ? null : order.price);"> }
+ }
+ { $slide "An ad-hoc solution"
+ "Something like..."
+ { $code "var price = customer.?orders.?[0].?price;" }
+ }
+ { $slide "Macros in Factor"
+ "Expand at compile-time"
+ "Return a quotation to be compiled"
+ "Can express non-static stack effects"
+ "Not as widely used as combinators, 60 macros so far"
+ { $code "{ 1 2 3 4 5 } 5 firstn" }
+ }
+ { $slide "A macro solution"
+ "Returns a quotation to the compiler"
+ "Constructed using map, fry, and concat"
+ { $code <" MACRO: plox ( seq -- quot )
+ [
+ '[ dup _ when ]
+ ] map [ ] concat-as ;">
+ }
+ }
+ { $slide "Macro example"
+ "Return the caaar of a sequence"
+ { "Return " { $snippet f } " on failure" }
+ { $code <" : caaar ( seq/f -- x/f )
+ {
+ [ first ]
+ [ first ]
+ [ first ]
+ } plox ;">
+ }
+ { $code <" { { f } } caaar"> }
+ { $code <" { { { 1 2 3 } } } caaar"> }
+ }
+ { $slide "Smart combinators"
+ "Use stack checker to infer inputs and outputs"
+ "Even fewer uses than macros"
+ { $code "{ 1 10 20 34 } sum" }
+ { $code "[ 1 10 20 34 ] sum-outputs" }
+ { $code "[ 2 2 [ even? ] both? ] [ + ] [ - ] smart-if" }
+ }
+ { $slide "Fibonacci"
+ "Not tail recursive"
+ "Call tree is huge"
+ { $code <" : fib ( n -- x )
+ dup 1 <= [
+ [ 1 - fib ] [ 2 - fib ] bi +
+ ] unless ;">
+ }
+ { $code "36 iota [ fib ] map ." }
+ }
+ { $slide "Memoized Fibonacci"
+ "Change one word and it's efficient"
+ { $code <" MEMO: fib ( n -- x )
+ dup 1 <= [
+ [ 1 - fib ] [ 2 - fib ] bi +
+ ] unless ;">
+ }
+ { $code "36 iota [ fib ] map ." }
+ }
+ { $slide "Destructors"
+ "Deterministic resource disposal"
+ "Any step can fail and we don't want to leak resources"
+ "We want to conditionally clean up sometimes -- if everything succeeds, we might wish to retain the buffer"
+ }
+
+ { $slide "Example in C"
+ { $code
+<" void do_stuff()
+{
+ void *obj1, *obj2;
+ if(!(*obj1 = malloc(256))) goto end;
+ if(!(*obj2 = malloc(256))) goto cleanup1;
+ ... work goes here...
+cleanup2: free(*obj2);
+cleanup1: free(*obj1);
+end: return;
+}">
+ }
+ }
+ { $slide "Example: allocating and disposing two buffers"
+ { $code <" : do-stuff ( -- )
+ [
+ 256 malloc &free
+ 256 malloc &free
+ ... work goes here ...
+ ] with-destructors ;">
+ }
+ }
+ { $slide "Example: allocating two buffers for later"
+ { $code <" : do-stuff ( -- )
+ [
+ 256 malloc |free
+ 256 malloc |free
+ ... work goes here ...
+ ] with-destructors ;">
+ }
+ }
+ { $slide "Example: disposing of an output port"
+ { $code <" M: output-port dispose*
+ [
+ {
+ [ handle>> &dispose drop ]
+ [ buffer>> &dispose drop ]
+ [ port-flush ]
+ [ handle>> shutdown ]
+ } cleave
+ ] with-destructors ;">
+ }
+ }
+ { $slide "Rapid application development"
+ "We lost the dice to Settlers of Catan: Cities and Knights"
+ "Two regular dice, one special die"
+ { $vocab-link "dice" }
+ }
+ { $slide "The essence of Factor"
+ "Nicely named words abstract away the stack, leaving readable code"
+ { $code <" : surround ( seq left right -- seq' )
+ swapd 3append ;">
+ }
+ { $code <" : glue ( left right middle -- seq' )
+ swap 3append ;">
+ }
+ { $code HEREDOC: xyz
+"a" "b" "c" 3append
+"a" "<" ">" surround
+"a" "b" ", " glue
+xyz
+ }
+ }
+ { $slide "C FFI demo"
+ "Easy to call C functions from Factor"
+ "Handles C structures, C types, callbacks"
+ "Used extensively in the Windows and Unix backends"
+ { $code
+ <" FUNCTION: double pow ( double x, double y ) ;
+2 5.0 pow .">
+ }
+ }
+ { $slide "Windows win32 example"
+ { $code
+<" M: windows gmt-offset
+ ( -- hours minutes seconds )
+ "TIME_ZONE_INFORMATION" <c-object>
+ dup GetTimeZoneInformation {
+ { TIME_ZONE_ID_INVALID [
+ win32-error-string throw
+ ] }
+ { TIME_ZONE_ID_STANDARD [
+ TIME_ZONE_INFORMATION-Bias
+ ] }
+ } case neg 60 /mod 0 ;">
+ }
+ }
+ { $slide "Struct and function"
+ { $code <" C-STRUCT: TIME_ZONE_INFORMATION
+ { "LONG" "Bias" }
+ { { "WCHAR" 32 } "StandardName" }
+ { "SYSTEMTIME" "StandardDate" }
+ { "LONG" "StandardBias" }
+ { { "WCHAR" 32 } "DaylightName" }
+ { "SYSTEMTIME" "DaylightDate" }
+ { "LONG" "DaylightBias" } ;">
+ }
+ { $code <" FUNCTION: DWORD GetTimeZoneInformation (
+ LPTIME_ZONE_INFORMATION
+ lpTimeZoneInformation
+) ;">
+ }
+
+ }
+ { $slide "Cocoa FFI"
+ { $code <" IMPORT: NSAlert [
+ NSAlert -> new
+ [ -> retain ] [
+ "Raptor" <CFString> &CFRelease
+ -> setMessageText:
+ ] [
+ "Look out!" <CFString> &CFRelease
+ -> setInformativeText:
+ ] tri -> runModal drop
+] with-destructors">
+ }
+ }
+ { $slide "Deployment demo"
+ "Vocabularies can be deployed"
+ "Standalone .app on Mac"
+ "An executable and dll on Windows"
+ { $vocab-link "webkit-demo" }
+ }
+ { $slide "Interesting programs"
+ { $vocab-link "terrain" }
+ { $vocab-link "gpu.demos.raytrace" }
+ { $vocab-link "gpu.demos.bunny" }
+ }
+ { $slide "Factor's source tree"
+ "Lines of code in core/: 9,500"
+ "Lines of code in basis/: 120,000"
+ "Lines of code in extra/: 51,000"
+ "Lines of tests: 44,000"
+ "Lines of documentation: 44,500"
+ }
+ { $slide "VM trivia"
+ "Lines of C++ code: 12860"
+ "Generational garbage collection"
+ "Non-optimizing compiler"
+ "Loads an image file and runs it"
+ }
+ { $slide "Why should I use Factor?"
+ "More abstractions over time"
+ "We fix reported bugs quickly"
+ "Stackable, fluent language"
+ "Supports extreme programming"
+ "Beer-friendly programming"
+ }
+ { $slide "Questions?"
+ }
+}
+
+: tc-lisp-talk ( -- ) tc-lisp-slides slides-window ;
+
+MAIN: tc-lisp-talk
math math.constants math.functions math.matrices math.order
math.vectors opengl opengl.capabilities opengl.gl
opengl.shaders opengl.textures opengl.textures.private
-sequences sequences.product specialized-arrays.float
+sequences sequences.product specialized-arrays
terrain.generation terrain.shaders ui ui.gadgets
ui.gadgets.worlds ui.pixel-formats game-worlds method-chains
math.affine-transforms noise ui.gestures combinators.short-circuit
destructors grid-meshes ;
+SPECIALIZED-ARRAY: float
IN: terrain
CONSTANT: FOV $[ 2.0 sqrt 1 + ]
--- /dev/null
+Strongly-typed word definitions
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors combinators combinators.short-circuit
+definitions effects fry hints kernel kernel.private namespaces
+parser quotations see.private sequences words ;
+IN: typed
+
+ERROR: type-mismatch-error word expected-types ;
+ERROR: input-mismatch-error < type-mismatch-error ;
+ERROR: output-mismatch-error < type-mismatch-error ;
+
+! typed inputs
+
+: typed-stack-effect? ( effect -- ? )
+ [ object = ] all? not ;
+
+: input-mismatch-quot ( word types -- quot )
+ [ input-mismatch-error ] 2curry ;
+
+: make-coercer ( types -- quot )
+ [ "coercer" word-prop [ ] or ]
+ [ swap \ dip [ ] 2sequence prepend ]
+ map-reduce ;
+
+: typed-inputs ( quot word types -- quot' )
+ {
+ [ 2nip make-coercer ]
+ [ 2nip make-specializer ]
+ [ nip swap '[ _ declare @ ] ]
+ [ [ drop ] 2dip input-mismatch-quot ]
+ } 3cleave '[ @ @ _ _ if ] ;
+
+! typed outputs
+
+: output-mismatch-quot ( word types -- quot )
+ [ output-mismatch-error ] 2curry ;
+
+: typed-outputs ( quot word types -- quot' )
+ {
+ [ 2drop ]
+ [ 2nip make-coercer ]
+ [ 2nip make-specializer ]
+ [ [ drop ] 2dip output-mismatch-quot ]
+ } 3cleave '[ @ @ @ _ unless ] ;
+
+! defining typed words
+
+: typed-gensym-quot ( def word effect -- quot )
+ [ nip effect-in-types swap '[ _ declare @ ] ]
+ [ effect-out-types dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if ] 2bi ;
+
+: define-typed-gensym ( word def effect -- gensym )
+ [ 3drop gensym dup ]
+ [ [ swap ] dip typed-gensym-quot ]
+ [ 2nip ] 3tri define-declared ;
+
+PREDICATE: typed < word "typed-word" word-prop ;
+
+: typed-quot ( quot word effect -- quot' )
+ [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
+ [ nip effect-out-types dup typed-stack-effect? [ '[ @ _ declare ] ] [ drop ] if ] 2bi ;
+
+: (typed-def) ( word def effect -- quot )
+ [ define-typed-gensym ] 3keep
+ [ drop [ swap "typed-word" set-word-prop ] [ [ 1quotation ] dip ] 2bi ] dip
+ typed-quot ;
+
+: typed-def ( word def effect -- quot )
+ dup {
+ [ effect-in-types typed-stack-effect? ]
+ [ effect-out-types typed-stack-effect? ]
+ } 1|| [ (typed-def) ] [ drop nip ] if ;
+
+: define-typed ( word def effect -- )
+ [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ]
+ [ drop "typed-def" set-word-prop ]
+ [ 2drop "typed-word" word-prop \ word set-global ] 3tri ;
+
+SYNTAX: TYPED:
+ (:) define-typed ;
+
+M: typed definer drop \ TYPED: \ ; ;
+M: typed definition "typed-def" word-prop ;
+M: typed declarations. "typed-word" word-prop declarations. ;
+
"adapted from lisp.vim
if exists("g:factor_norainbow")
- syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
+ syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
else
- syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
- syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
- syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
- syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
- syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
- syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
- syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
- syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
- syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
- syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
+ syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
+ syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
+ syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
+ syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
+ syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
+ syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
+ syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
+ syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
+ syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
+ syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
endif
if exists("g:factor_norainbow")
Teach Vim when to load Factor support files.
ftplugin/factor_settings.vim
Teach Vim to follow the Factor Coding Style guidelines.
+ plugin/factor.vim
+ Teach Vim some commands for navigating Factor source code. See below.
syntax/factor.vim
Syntax highlighting for Factor code.
+The "plugin/factor.vim" file implements the following commands for
+navigating Factor source:
+
+ :FactorVocab factor.vocab.name
+ Opens the source file implementing the "factor.vocab.name"
+ vocabulary.
+ :NewFactorVocab factor.vocab.name
+ Creates a new factor vocabulary under the working vocabulary root.
+ :FactorVocabImpl
+ Opens the main implementation file for the current vocabulary
+ (name.factor). The keyboard shortcut "\fi" is bound to this
+ command.
+ :FactorVocabDocs
+ Opens the documentation file for the current vocabulary
+ (name-docs.factor). The keyboard shortcut "\fd" is bound to this
+ command.
+ :FactorVocabTests
+ Opens the unit test file for the current vocabulary
+ (name-tests.factor). The keyboard shortcut "\ft" is bound to this
+ command.
+
+In order for the ":FactorVocab" command to work, you'll need to set some
+variables in your vimrc file:
+ g:FactorRoot
+ This variable should be set to the root of your Factor
+ installation. The default value is "~/factor".
+ g:FactorVocabRoots
+ This variable should be set to a list of Factor vocabulary roots.
+ The paths may be either relative to g:FactorRoot or absolute paths.
+ The default value is ["core", "basis", "extra", "work"].
+ g:FactorNewVocabRoot
+ This variable should be set to the vocabulary root in which
+ vocabularies created with NewFactorVocab should be created. The
+ default value is "work".
+
Note: The syntax-highlighting file is automatically generated to include the
names of all the vocabularies Factor knows about. To regenerate it manually,
run the following code in the listener:
"editors.vim.generate-syntax" run
-...or run it from the command-line:
+...or run it from the command line:
factor -run=editors.vim.generate-syntax
--- /dev/null
+nmap <silent> <Leader>fi :FactorVocabImpl<CR>
+nmap <silent> <Leader>fd :FactorVocabDocs<CR>
+nmap <silent> <Leader>ft :FactorVocabTests<CR>
+
+if !exists("g:FactorRoot")
+ let g:FactorRoot = "~/factor"
+endif
+
+if !exists("g:FactorVocabRoots")
+ let g:FactorVocabRoots = ["core", "basis", "extra", "work"]
+endif
+
+if !exists("g:FactorNewVocabRoot")
+ let g:FactorNewVocabRoot = "work"
+endif
+
+command! -nargs=1 -complete=customlist,FactorCompleteVocab FactorVocab :call GoToFactorVocab("<args>")
+command! -nargs=1 -complete=customlist,FactorCompleteVocab NewFactorVocab :call MakeFactorVocab("<args>")
+command! FactorVocabImpl :call GoToFactorVocabImpl()
+command! FactorVocabDocs :call GoToFactorVocabDocs()
+command! FactorVocabTests :call GoToFactorVocabTests()
+
+function! FactorVocabRoot(root)
+ let cwd = getcwd()
+ exe "lcd " fnameescape(g:FactorRoot)
+ let vocabroot = fnamemodify(a:root, ":p")
+ exe "lcd " fnameescape(cwd)
+ return vocabroot
+endfunction
+
+function! s:unique(list)
+ let dict = {}
+ for value in a:list
+ let dict[value] = 1
+ endfor
+ return sort(keys(dict))
+endfunction
+
+function! FactorCompleteVocab(arglead, cmdline, cursorpos)
+ let vocabs = []
+ let vocablead = substitute(a:arglead, "\\.", "/", "g")
+ for root in g:FactorVocabRoots
+ let vocabroot = FactorVocabRoot(root)
+ let newvocabs = globpath(vocabroot, vocablead . "*")
+ if newvocabs != ""
+ let newvocabsl = split(newvocabs, "\n")
+ let newvocabsl = filter(newvocabsl, 'getftype(v:val) == "dir"')
+ let newvocabsl = map(newvocabsl, 'substitute(v:val, "^\\V" . escape(vocabroot, "\\"), "\\1", "g")')
+ let vocabs += newvocabsl
+ endif
+ endfor
+ let vocabs = s:unique(vocabs)
+ let vocabs = map(vocabs, 'substitute(v:val, "/\\|\\\\", ".", "g")')
+ return vocabs
+endfunction
+
+function! FactorVocabFile(root, vocab, mustexist)
+ let vocabpath = substitute(a:vocab, "\\.", "/", "g")
+ let vocabfile = FactorVocabRoot(a:root) . vocabpath . "/" . fnamemodify(vocabpath, ":t") . ".factor"
+
+ if !a:mustexist || getftype(vocabfile) != ""
+ return vocabfile
+ else
+ return ""
+ endif
+endfunction
+
+function! GoToFactorVocab(vocab)
+ for root in g:FactorVocabRoots
+ let vocabfile = FactorVocabFile(root, a:vocab, 1)
+ if vocabfile != ""
+ exe "edit " fnameescape(vocabfile)
+ return
+ endif
+ endfor
+ echo "Vocabulary " vocab " not found"
+endfunction
+
+function! MakeFactorVocab(vocab)
+ let vocabfile = FactorVocabFile(g:FactorNewVocabRoot, a:vocab, 0)
+ echo vocabfile
+ let vocabdir = fnamemodify(vocabfile, ":h")
+ echo vocabdir
+ exe "!mkdir -p " shellescape(vocabdir)
+ exe "edit " fnameescape(vocabfile)
+endfunction
+
+function! FactorFileBase()
+ let filename = expand("%:r")
+ let filename = substitute(filename, "-docs", "", "")
+ let filename = substitute(filename, "-tests", "", "")
+ return filename
+endfunction
+
+function! GoToFactorVocabImpl()
+ exe "edit " fnameescape(FactorFileBase() . ".factor")
+endfunction
+
+function! GoToFactorVocabDocs()
+ exe "edit " fnameescape(FactorFileBase() . "-docs.factor")
+endfunction
+
+function! GoToFactorVocabTests()
+ exe "edit " fnameescape(FactorFileBase() . "-tests.factor")
+endfunction
include vm/Config.macosx
include vm/Config.ppc
-CFLAGS += -arch ppc
+CFLAGS += -arch ppc -force_cpusubtype_ALL
include vm/Config.macosx
include vm/Config.x86.32
+CFLAGS += -m32
include vm/Config.unix
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o
CFLAGS += -export-dynamic
-LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib
+LIBPATH = -L/usr/X11R7/lib -Wl,-rpath,/usr/X11R7/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib
LIBS = -lm -lssl -lcrypto $(X11_UI_LIBS)
#define SAVED_FP_REGS_SIZE 144
-#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + 8)
+#define SAVED_V_REGS_SIZE 208
+
+#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + SAVED_V_REGS_SIZE + 8)
#if defined( __APPLE__)
#define LR_SAVE 8
#define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1)
#define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1)
+#define SAVE_V(register,offset) \
+ li r2,SAVE_AT(offset) XX \
+ stvxl register,r2,r1
+
+#define RESTORE_V(register,offset) \
+ li r2,SAVE_AT(offset) XX \
+ lvxl register,r2,r1
+
#define PROLOGUE \
mflr r0 XX /* get caller's return address */ \
stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
SAVE_FP(f30,52)
SAVE_FP(f31,54)
+ SAVE_V(v20,56)
+ SAVE_V(v21,60)
+ SAVE_V(v22,64)
+ SAVE_V(v23,68)
+ SAVE_V(v24,72)
+ SAVE_V(v25,76)
+ SAVE_V(v26,80)
+ SAVE_V(v27,84)
+ SAVE_V(v28,88)
+ SAVE_V(v29,92)
+ SAVE_V(v30,96)
+ SAVE_V(v31,100)
+
+ mfvscr v0
+ li r2,SAVE_AT(104)
+ stvxl v0,r2,r1
+ addi r2,r2,0xc
+ lwzx r4,r2,r1
+ lis r5,0x1
+ andc r4,r4,r5
+ stwx r4,r2,r1
+ subi r2,r2,0xc
+ lvxl v0,r2,r1
+ mtvscr v0
+
SAVE_INT(r3,19) /* save quotation since we're about to mangle it */
mr r3,r1 /* pass call stack pointer as an argument */
RESTORE_INT(r3,19) /* restore quotation */
CALL_QUOT
+ RESTORE_V(v0,104)
+ mtvscr v0
+
+ RESTORE_V(v31,100)
+ RESTORE_V(v30,96)
+ RESTORE_V(v29,92)
+ RESTORE_V(v28,88)
+ RESTORE_V(v27,84)
+ RESTORE_V(v26,80)
+ RESTORE_V(v25,76)
+ RESTORE_V(v24,72)
+ RESTORE_V(v23,68)
+ RESTORE_V(v22,64)
+ RESTORE_V(v21,60)
+ RESTORE_V(v20,56)
+
RESTORE_FP(f31,54)
RESTORE_FP(f30,52)
RESTORE_FP(f29,50)
blr
DEF(void,primitive_inline_cache_miss,(void)):
- mflr r6
+ mflr r6
DEF(void,primitive_inline_cache_miss_tail,(void)):
- PROLOGUE
- mr r3,r6
- bl MANGLE(inline_cache_miss)
- EPILOGUE
- mtctr r3
- bctr
+ PROLOGUE
+ mr r3,r6
+ bl MANGLE(inline_cache_miss)
+ EPILOGUE
+ mtctr r3
+ bctr
+
+DEF(void,get_ppc_fpu_env,(void*)):
+ mffs f0
+ stfd f0,0(r3)
+ blr
+
+DEF(void,set_ppc_fpu_env,(const void*)):
+ lfd f0,0(r3)
+ mtfsf 0xff,f0
+ blr
+
+DEF(void,get_ppc_vmx_env,(void*)):
+ mfvscr v0
+ subi r4,r1,16
+ li r5,0xf
+ andc r4,r4,r5
+ stvxl v0,0,r4
+ li r5,0xc
+ lwzx r6,r5,r4
+ stw r6,0(r3)
+ blr
+
+DEF(void,set_ppc_vmx_env,(const void*)):
+ subi r4,r1,16
+ li r5,0xf
+ andc r4,r4,r5
+ li r5,0xc
+ lwz r6,0(r3)
+ stwx r6,r5,r4
+ lvxl v0,0,r4
+ mtvscr v0
+ blr
+
return (insn & 0x1) == 0;
}
+inline static unsigned int fpu_status(unsigned int status)
+{
+ unsigned int r = 0;
+
+ if (status & 0x20000000)
+ r |= FP_TRAP_INVALID_OPERATION;
+ if (status & 0x10000000)
+ r |= FP_TRAP_OVERFLOW;
+ if (status & 0x08000000)
+ r |= FP_TRAP_UNDERFLOW;
+ if (status & 0x04000000)
+ r |= FP_TRAP_ZERO_DIVIDE;
+ if (status & 0x02000000)
+ r |= FP_TRAP_INEXACT;
+
+ return r;
+}
+
/* Defined in assembly */
VM_ASM_API void c_to_factor(cell quot);
VM_ASM_API void throw_impl(cell quot, stack_frame *rewind);
add $12,%esp /* pop args from the stack */
ret /* return _with new stack_ */
-/* cpu.x86.32 calls this */
-DEF(bool,check_sse2,(void)):
- push %ebx
- mov $1,%eax
- cpuid
- shr $26,%edx
- and $1,%edx
- pop %ebx
- mov %edx,%eax
- ret
-
DEF(long long,read_timestamp_counter,(void)):
rdtsc
ret
add $12,%esp
jmp *%eax
+DEF(void,get_sse_env,(void*)):
+ movl 4(%esp), %eax
+ stmxcsr (%eax)
+ ret
+
+DEF(void,set_sse_env,(const void*)):
+ movl 4(%esp), %eax
+ ldmxcsr (%eax)
+ ret
+
+DEF(void,get_x87_env,(void*)):
+ movl 4(%esp), %eax
+ fnstsw (%eax)
+ fnstcw 2(%eax)
+ ret
+
+DEF(void,set_x87_env,(const void*)):
+ movl 4(%esp), %eax
+ fnclex
+ fldcw 2(%eax)
+ ret
+
#include "cpu-x86.S"
#ifdef WINDOWS
.section .drectve
- .ascii " -export:check_sse2"
.ascii " -export:read_timestamp_counter"
+ .ascii " -export:get_sse_env"
+ .ascii " -export:set_sse_env"
+ .ascii " -export:get_x87_env"
+ .ascii " -export:set_x87_env"
#endif
add $STACK_PADDING,%rsp
jmp *%rax
+DEF(void,get_sse_env,(void*)):
+ stmxcsr (%rdi)
+ ret
+
+DEF(void,set_sse_env,(const void*)):
+ ldmxcsr (%rdi)
+ ret
+
+DEF(void,get_x87_env,(void*)):
+ fnstsw (%rdi)
+ fnstcw 2(%rdi)
+ ret
+
+DEF(void,set_x87_env,(const void*)):
+ fnclex
+ fldcw 2(%rdi)
+ ret
+
#include "cpu-x86.S"
DEF(void,primitive_fixnum_add,(void)):
- mov (DS_REG),ARG0
- mov -CELL_SIZE(DS_REG),ARG1
- sub $CELL_SIZE,DS_REG
- mov ARG1,ARITH_TEMP_1
- add ARG0,ARITH_TEMP_1
- jo MANGLE(overflow_fixnum_add)
- mov ARITH_TEMP_1,(DS_REG)
- ret
+ mov (DS_REG),ARG0
+ mov -CELL_SIZE(DS_REG),ARG1
+ sub $CELL_SIZE,DS_REG
+ mov ARG1,ARITH_TEMP_1
+ add ARG0,ARITH_TEMP_1
+ jo MANGLE(overflow_fixnum_add)
+ mov ARITH_TEMP_1,(DS_REG)
+ ret
DEF(void,primitive_fixnum_subtract,(void)):
- mov (DS_REG),ARG1
- mov -CELL_SIZE(DS_REG),ARG0
- sub $CELL_SIZE,DS_REG
- mov ARG0,ARITH_TEMP_1
- sub ARG1,ARITH_TEMP_1
- jo MANGLE(overflow_fixnum_subtract)
- mov ARITH_TEMP_1,(DS_REG)
- ret
+ mov (DS_REG),ARG1
+ mov -CELL_SIZE(DS_REG),ARG0
+ sub $CELL_SIZE,DS_REG
+ mov ARG0,ARITH_TEMP_1
+ sub ARG1,ARITH_TEMP_1
+ jo MANGLE(overflow_fixnum_subtract)
+ mov ARITH_TEMP_1,(DS_REG)
+ ret
DEF(void,primitive_fixnum_multiply,(void)):
- mov (DS_REG),ARITH_TEMP_1
- mov ARITH_TEMP_1,DIV_RESULT
- mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
- sar $3,ARITH_TEMP_2
- sub $CELL_SIZE,DS_REG
- imul ARITH_TEMP_2
- jo multiply_overflow
- mov DIV_RESULT,(DS_REG)
- ret
+ mov (DS_REG),ARITH_TEMP_1
+ mov ARITH_TEMP_1,DIV_RESULT
+ mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
+ sar $3,ARITH_TEMP_2
+ sub $CELL_SIZE,DS_REG
+ imul ARITH_TEMP_2
+ jo multiply_overflow
+ mov DIV_RESULT,(DS_REG)
+ ret
multiply_overflow:
- sar $3,ARITH_TEMP_1
- mov ARITH_TEMP_1,ARG0
- mov ARITH_TEMP_2,ARG1
- jmp MANGLE(overflow_fixnum_multiply)
+ sar $3,ARITH_TEMP_1
+ mov ARITH_TEMP_1,ARG0
+ mov ARITH_TEMP_2,ARG1
+ jmp MANGLE(overflow_fixnum_multiply)
DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
PUSH_NONVOLATILE
ret
DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
+ /* clear x87 stack, but preserve rounding mode and exception flags */
+ sub $2,STACK_REG
+ fnstcw (STACK_REG)
+ fninit
+ fldcw (STACK_REG)
/* rewind_to */
mov ARG1,STACK_REG
jmp *QUOT_XT_OFFSET(ARG0)
add $STACK_PADDING,STACK_REG
jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
+/* cpu.x86.features calls this */
+DEF(bool,sse_version,(void)):
+ mov $0x1,RETURN_REG
+ cpuid
+ /* test $0x100000,%ecx
+ jnz sse_42
+ test $0x80000,%ecx
+ jnz sse_41
+ test $0x200,%ecx
+ jnz ssse_3 */
+ test $0x1,%ecx
+ jnz sse_3
+ test $0x4000000,%edx
+ jnz sse_2
+ test $0x2000000,%edx
+ jnz sse_1
+ mov $0,%eax
+ ret
+sse_42:
+ mov $42,RETURN_REG
+ ret
+sse_41:
+ mov $41,RETURN_REG
+ ret
+ssse_3:
+ mov $33,RETURN_REG
+ ret
+sse_3:
+ mov $30,RETURN_REG
+ ret
+sse_2:
+ mov $20,RETURN_REG
+ ret
+sse_1:
+ mov $10,RETURN_REG
+ ret
#ifdef WINDOWS
.section .drectve
+ .ascii " -export:sse_version"
.ascii " -export:c_to_factor"
#endif
return call_site_opcode(return_address) == jmp_opcode;
}
+inline static unsigned int fpu_status(unsigned int status)
+{
+ unsigned int r = 0;
+
+ if (status & 0x01)
+ r |= FP_TRAP_INVALID_OPERATION;
+ if (status & 0x04)
+ r |= FP_TRAP_ZERO_DIVIDE;
+ if (status & 0x08)
+ r |= FP_TRAP_OVERFLOW;
+ if (status & 0x10)
+ r |= FP_TRAP_UNDERFLOW;
+ if (status & 0x20)
+ r |= FP_TRAP_INEXACT;
+
+ return r;
+}
+
/* Defined in assembly */
VM_ASM_API void c_to_factor(cell quot);
VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to);
static void copy_registered_locals()
{
- cell scan = gc_locals_region->start;
+ std::vector<cell>::const_iterator iter = gc_locals.begin();
+ std::vector<cell>::const_iterator end = gc_locals.end();
- for(; scan <= gc_locals; scan += sizeof(cell))
- copy_handle(*(cell **)scan);
+ for(; iter < end; iter++)
+ copy_handle((cell *)(*iter));
}
static void copy_registered_bignums()
{
- cell scan = gc_bignums_region->start;
+ std::vector<cell>::const_iterator iter = gc_bignums.begin();
+ std::vector<cell>::const_iterator end = gc_bignums.end();
- for(; scan <= gc_bignums; scan += sizeof(cell))
+ for(; iter < end; iter++)
{
- bignum **handle = *(bignum ***)scan;
+ bignum **handle = (bignum **)(*iter);
bignum *pointer = *handle;
if(pointer)
VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size)
{
for(cell i = 0; i < gc_roots_size; i++)
- gc_local_push((cell)&gc_roots_base[i]);
+ gc_locals.push_back((cell)&gc_roots_base[i]);
garbage_collection(data->nursery(),false,0);
for(cell i = 0; i < gc_roots_size; i++)
- gc_local_pop();
+ gc_locals.pop_back();
}
}
bool secure_gc_)
{
set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
-
- gc_locals_region = alloc_segment(getpagesize());
- gc_locals = gc_locals_region->start - sizeof(cell);
-
- gc_bignums_region = alloc_segment(getpagesize());
- gc_bignums = gc_bignums_region->start - sizeof(cell);
-
secure_gc = secure_gc_;
-
init_data_gc();
}
user-space */
cell signal_number;
cell signal_fault_addr;
+unsigned int signal_fpu_status;
stack_frame *signal_callstack_top;
void out_of_memory()
gc_off = false;
/* Reset local roots */
- gc_locals = gc_locals_region->start - sizeof(cell);
- gc_bignums = gc_bignums_region->start - sizeof(cell);
+ gc_locals.clear();
+ gc_bignums.clear();
/* If we had an underflow or overflow, stack pointers might be
out of bounds */
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
+void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top)
+{
+ general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),F,signal_callstack_top);
+}
+
PRIMITIVE(call_clear)
{
throw_impl(dpop(),stack_chain->callstack_bottom);
signal_error(signal_number,signal_callstack_top);
}
+void fp_signal_handler_impl()
+{
+ fp_trap_error(signal_fpu_status,signal_callstack_top);
+}
+
}
ERROR_RS_UNDERFLOW,
ERROR_RS_OVERFLOW,
ERROR_MEMORY,
+ ERROR_FP_TRAP,
};
void out_of_memory();
void signal_error(int signal, stack_frame *native_stack);
void type_error(cell type, cell tagged);
void not_implemented_error();
+void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top);
PRIMITIVE(call_clear);
PRIMITIVE(unimplemented);
user-space */
extern cell signal_number;
extern cell signal_fault_addr;
+extern unsigned int signal_fpu_status;
extern stack_frame *signal_callstack_top;
void memory_signal_handler_impl();
+void fp_signal_handler_impl();
void misc_signal_handler_impl();
}
representations and vice versa */
union double_bits_pun {
- double x;
- u64 y;
+ double x;
+ u64 y;
};
inline static u64 double_bits(double x)
}
union float_bits_pun {
- float x;
- u32 y;
+ float x;
+ u32 y;
};
inline static u32 float_bits(float x)
/* Not a real type, but code_block's type field can be set to this */
#define PIC_TYPE 69
+/* Constants used when floating-point trap exceptions are thrown */
+enum
+{
+ FP_TRAP_INVALID_OPERATION = 1 << 0,
+ FP_TRAP_OVERFLOW = 1 << 1,
+ FP_TRAP_UNDERFLOW = 1 << 2,
+ FP_TRAP_ZERO_DIVIDE = 1 << 3,
+ FP_TRAP_INEXACT = 1 << 4,
+};
+
inline static bool immediate_p(cell obj)
{
return (obj == F || TAG(obj) == FIXNUM_TYPE);
namespace factor
{
-segment *gc_locals_region;
-cell gc_locals;
+std::vector<cell> gc_locals;
-segment *gc_bignums_region;
-cell gc_bignums;
+std::vector<cell> gc_bignums;
}
/* If a runtime function needs to call another function which potentially
allocates memory, it must wrap any local variable references to Factor
objects in gc_root instances */
-extern segment *gc_locals_region;
-extern cell gc_locals;
-
-DEFPUSHPOP(gc_local_,gc_locals)
+extern std::vector<cell> gc_locals;
template <typename T>
struct gc_root : public tagged<T>
{
- void push() { check_tagged_pointer(tagged<T>::value()); gc_local_push((cell)this); }
+ void push() { check_tagged_pointer(tagged<T>::value()); gc_locals.push_back((cell)this); }
explicit gc_root(cell value_) : tagged<T>(value_) { push(); }
explicit gc_root(T *value_) : tagged<T>(value_) { push(); }
~gc_root() {
#ifdef FACTOR_DEBUG
- cell old = gc_local_pop();
- assert(old == (cell)this);
-#else
- gc_local_pop();
+ assert(gc_locals.back() == (cell)this);
#endif
+ gc_locals.pop_back();
}
};
/* A similar hack for the bignum implementation */
-extern segment *gc_bignums_region;
-extern cell gc_bignums;
-
-DEFPUSHPOP(gc_bignum_,gc_bignums)
+extern std::vector<cell> gc_bignums;
struct gc_bignum
{
gc_bignum(bignum **addr_) : addr(addr_) {
if(*addr_)
check_data_pointer(*addr_);
- gc_bignum_push((cell)addr);
+ gc_bignums.push_back((cell)addr);
}
- ~gc_bignum() { assert((cell)addr == gc_bignum_pop()); }
+ ~gc_bignum() {
+#ifdef FACTOR_DEBUG
+ assert(gc_bignums.back() == (cell)addr);
+#endif
+ gc_bignums.pop_back();
+ }
};
#define GC_BIGNUM(x) gc_bignum x##__gc_root(&x)
/* Modify a suspended thread's thread_state so that when the thread resumes
executing, the call frame of the current C primitive (if any) is rewound, and
the appropriate Factor error is thrown from the top-most Factor frame. */
-static void call_fault_handler(exception_type_t exception,
+static void call_fault_handler(
+ exception_type_t exception,
+ exception_data_type_t code,
MACH_EXC_STATE_TYPE *exc_state,
- MACH_THREAD_STATE_TYPE *thread_state)
+ MACH_THREAD_STATE_TYPE *thread_state,
+ MACH_FLOAT_STATE_TYPE *float_state)
{
/* There is a race condition here, but in practice an exception
delivered during stack frame setup/teardown or while transitioning
signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state);
MACH_PROGRAM_COUNTER(thread_state) = (cell)memory_signal_handler_impl;
}
+ else if(exception == EXC_ARITHMETIC && code != MACH_EXC_INTEGER_DIV)
+ {
+ signal_fpu_status = fpu_status(mach_fpu_status(float_state));
+ mach_clear_fpu_status(float_state);
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)fp_signal_handler_impl;
+ }
else
{
- if(exception == EXC_ARITHMETIC)
- signal_number = SIGFPE;
- else
- signal_number = SIGABRT;
+ signal_number = (exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT);
MACH_PROGRAM_COUNTER(thread_state) = (cell)misc_signal_handler_impl;
}
}
{
MACH_EXC_STATE_TYPE exc_state;
MACH_THREAD_STATE_TYPE thread_state;
- mach_msg_type_number_t state_count;
+ MACH_FLOAT_STATE_TYPE float_state;
+ mach_msg_type_number_t exc_state_count, thread_state_count, float_state_count;
/* Get fault information and the faulting thread's register contents..
See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */
- state_count = MACH_EXC_STATE_COUNT;
+ exc_state_count = MACH_EXC_STATE_COUNT;
if (thread_get_state (thread, MACH_EXC_STATE_FLAVOR,
- (natural_t *)&exc_state, &state_count)
+ (natural_t *)&exc_state, &exc_state_count)
!= KERN_SUCCESS)
{
/* The thread is supposed to be suspended while the exception
return KERN_FAILURE;
}
- state_count = MACH_THREAD_STATE_COUNT;
+ thread_state_count = MACH_THREAD_STATE_COUNT;
if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR,
- (natural_t *)&thread_state, &state_count)
+ (natural_t *)&thread_state, &thread_state_count)
+ != KERN_SUCCESS)
+ {
+ /* The thread is supposed to be suspended while the exception
+ handler is called. This shouldn't fail. */
+ return KERN_FAILURE;
+ }
+
+ float_state_count = MACH_FLOAT_STATE_COUNT;
+ if (thread_get_state (thread, MACH_FLOAT_STATE_FLAVOR,
+ (natural_t *)&float_state, &float_state_count)
!= KERN_SUCCESS)
{
/* The thread is supposed to be suspended while the exception
/* Modify registers so to have the thread resume executing the
fault handler */
- call_fault_handler(exception,&exc_state,&thread_state);
+ call_fault_handler(exception,code[0],&exc_state,&thread_state,&float_state);
/* Set the faulting thread's register contents..
See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_set_state.html. */
+ if (thread_set_state (thread, MACH_FLOAT_STATE_FLAVOR,
+ (natural_t *)&float_state, float_state_count)
+ != KERN_SUCCESS)
+ {
+ return KERN_FAILURE;
+ }
+
if (thread_set_state (thread, MACH_THREAD_STATE_FLAVOR,
- (natural_t *)&thread_state, state_count)
+ (natural_t *)&thread_state, thread_state_count)
!= KERN_SUCCESS)
{
return KERN_FAILURE;
#include <time.h>
/* C++ headers */
+#include <vector>
+
#if __GNUC__ == 4
#include <tr1/unordered_map>
#define unordered_map std::tr1::unordered_map
#include <ucontext.h>
+#include <machine/npx.h>
namespace factor
{
return (void *)ucontext->uc_mcontext.mc_esp;
}
+inline static unsigned int uap_fpu_status(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387)
+ {
+ struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate);
+ return x87->sv_env.en_sw;
+ }
+ else if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
+ {
+ struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate);
+ return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr;
+ }
+ else
+ return 0;
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387)
+ {
+ struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate);
+ x87->sv_env.en_sw = 0;
+ }
+ else if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
+ {
+ struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate);
+ xmm->sv_env.en_sw = 0;
+ xmm->sv_env.en_mxcsr &= 0xffffffc0;
+ }
+}
+
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip)
}
#include <ucontext.h>
+#include <machine/fpu.h>
namespace factor
{
return (void *)ucontext->uc_mcontext.mc_rsp;
}
+inline static unsigned int uap_fpu_status(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
+ {
+ struct savefpu *xmm = (struct savefpu *)(&ucontext->uc_mcontext.mc_fpstate);
+ return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr;
+ }
+ else
+ return 0;
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
+ {
+ struct savefpu *xmm = (struct savefpu *)(&ucontext->uc_mcontext.mc_fpstate);
+ xmm->sv_env.en_sw = 0;
+ xmm->sv_env.en_mxcsr &= 0xffffffc0;
+ }
+}
+
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip)
}
namespace factor
{
+// glibc lies about the contents of the fpstate the kernel provides, hiding the FXSR
+// environment
+struct _fpstate {
+ /* Regular FPU environment */
+ unsigned long cw;
+ unsigned long sw;
+ unsigned long tag;
+ unsigned long ipoff;
+ unsigned long cssel;
+ unsigned long dataoff;
+ unsigned long datasel;
+ struct _fpreg _st[8];
+ unsigned short status;
+ unsigned short magic; /* 0xffff = regular FPU data only */
+
+ /* FXSR FPU environment */
+ unsigned long _fxsr_env[6]; /* FXSR FPU env is ignored */
+ unsigned long mxcsr;
+ unsigned long reserved;
+ struct _fpxreg _fxsr_st[8]; /* FXSR FPU reg data is ignored */
+ struct _xmmreg _xmm[8];
+ unsigned long padding[56];
+};
+
+#define X86_FXSR_MAGIC 0x0000
+
inline static void *ucontext_stack_pointer(void *uap)
{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[7];
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[7];
+}
+
+inline static unsigned int uap_fpu_status(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ struct _fpstate *fpregs = (struct _fpstate *)ucontext->uc_mcontext.fpregs;
+ if (fpregs->magic == X86_FXSR_MAGIC)
+ return fpregs->sw | fpregs->mxcsr;
+ else
+ return fpregs->sw;
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ struct _fpstate *fpregs = (struct _fpstate *)ucontext->uc_mcontext.fpregs;
+ fpregs->sw = 0;
+ if (fpregs->magic == X86_FXSR_MAGIC)
+ fpregs->mxcsr &= 0xffffffc0;
}
#define UAP_PROGRAM_COUNTER(ucontext) \
return (void *)ucontext->uc_mcontext.gregs[15];
}
+inline static unsigned int uap_fpu_status(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return ucontext->uc_mcontext.fpregs->swd
+ | ucontext->uc_mcontext.fpregs->mxcsr;
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ ucontext->uc_mcontext.fpregs->swd = 0;
+ ucontext->uc_mcontext.fpregs->mxcsr &= 0xffffffc0;
+}
+
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
-#include <ucontext.h>
+#include <sys/ucontext.h>
namespace factor
{
#define MACH_EXC_STATE_TYPE ppc_exception_state_t
#define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
#define MACH_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT
+
+#define MACH_EXC_INTEGER_DIV EXC_PPC_ZERO_DIVIDE
+
#define MACH_THREAD_STATE_TYPE ppc_thread_state_t
#define MACH_THREAD_STATE_FLAVOR PPC_THREAD_STATE
#define MACH_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
+#define MACH_FLOAT_STATE_TYPE ppc_float_state_t
+#define MACH_FLOAT_STATE_FLAVOR PPC_FLOAT_STATE
+#define MACH_FLOAT_STATE_COUNT PPC_FLOAT_STATE_COUNT
+
#if __DARWIN_UNIX03
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar
#define MACH_STACK_POINTER(thr_state) (thr_state)->__r1
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+
+ #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss)
+ #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs)
+
+ #define FPSCR(float_state) (float_state)->__fpscr
#else
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar
#define MACH_STACK_POINTER(thr_state) (thr_state)->r1
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
+
+ #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss)
+ #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs)
+
+ #define FPSCR(float_state) (float_state)->fpscr
#endif
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(UAP_SS(ucontext))
+
+inline static unsigned int mach_fpu_status(ppc_float_state_t *float_state)
+{
+ return FPSCR(float_state);
+}
+
+inline static unsigned int uap_fpu_status(void *uap)
+{
+ return mach_fpu_status(UAP_FS(uap));
+}
+
inline static cell fix_stack_pointer(cell sp)
{
return sp;
}
+inline static void mach_clear_fpu_status(ppc_float_state_t *float_state)
+{
+ FPSCR(float_state) &= 0x0007f8ff;
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+ mach_clear_fpu_status(UAP_FS(uap));
+}
+
}
-#include <ucontext.h>
+#include <sys/ucontext.h>
namespace factor
{
#define MACH_EXC_STATE_TYPE i386_exception_state_t
#define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
#define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
+
+#define MACH_EXC_INTEGER_DIV EXC_I386_DIV
+
#define MACH_THREAD_STATE_TYPE i386_thread_state_t
#define MACH_THREAD_STATE_FLAVOR i386_THREAD_STATE
#define MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
+#define MACH_FLOAT_STATE_TYPE i386_float_state_t
+#define MACH_FLOAT_STATE_FLAVOR i386_FLOAT_STATE
+#define MACH_FLOAT_STATE_COUNT i386_FLOAT_STATE_COUNT
+
#if __DARWIN_UNIX03
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
#define MACH_STACK_POINTER(thr_state) (thr_state)->__esp
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+
+ #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss)
+ #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs)
+
+ #define MXCSR(float_state) (float_state)->__fpu_mxcsr
+ #define X87SW(float_state) (float_state)->__fpu_fsw
#else
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
#define MACH_STACK_POINTER(thr_state) (thr_state)->esp
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
+
+ #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss)
+ #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs)
+
+ #define MXCSR(float_state) (float_state)->fpu_mxcsr
+ #define X87SW(float_state) (float_state)->fpu_fsw
#endif
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(UAP_SS(ucontext))
+
+inline static unsigned int mach_fpu_status(i386_float_state_t *float_state)
+{
+ unsigned short x87sw;
+ memcpy(&x87sw, &X87SW(float_state), sizeof(x87sw));
+ return MXCSR(float_state) | x87sw;
+}
+
+inline static unsigned int uap_fpu_status(void *uap)
+{
+ return mach_fpu_status(UAP_FS(uap));
+}
+
inline static cell fix_stack_pointer(cell sp)
{
return ((sp + 4) & ~15) - 4;
}
+inline static void mach_clear_fpu_status(i386_float_state_t *float_state)
+{
+ MXCSR(float_state) &= 0xffffffc0;
+ memset(&X87SW(float_state), 0, sizeof(X87SW(float_state)));
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+ mach_clear_fpu_status(UAP_FS(uap));
+}
+
}
-#include <ucontext.h>
+#include <sys/ucontext.h>
namespace factor
{
#define MACH_EXC_STATE_TYPE x86_exception_state64_t
#define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64
#define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT
+
+#define MACH_EXC_INTEGER_DIV EXC_I386_DIV
+
#define MACH_THREAD_STATE_TYPE x86_thread_state64_t
#define MACH_THREAD_STATE_FLAVOR x86_THREAD_STATE64
#define MACH_THREAD_STATE_COUNT MACHINE_THREAD_STATE_COUNT
+#define MACH_FLOAT_STATE_TYPE x86_float_state64_t
+#define MACH_FLOAT_STATE_FLAVOR x86_FLOAT_STATE64
+#define MACH_FLOAT_STATE_COUNT x86_FLOAT_STATE64_COUNT
+
#if __DARWIN_UNIX03
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
#define MACH_STACK_POINTER(thr_state) (thr_state)->__rsp
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__rip
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+ #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss)
+ #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs)
+
+ #define MXCSR(float_state) (float_state)->__fpu_mxcsr
+ #define X87SW(float_state) (float_state)->__fpu_fsw
#else
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
#define MACH_STACK_POINTER(thr_state) (thr_state)->rsp
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->rip
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
+ #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss)
+ #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs)
+
+ #define MXCSR(float_state) (float_state)->fpu_mxcsr
+ #define X87SW(float_state) (float_state)->fpu_fsw
#endif
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(UAP_SS(ucontext))
+
+inline static unsigned int mach_fpu_status(x86_float_state64_t *float_state)
+{
+ unsigned short x87sw;
+ memcpy(&x87sw, &X87SW(float_state), sizeof(x87sw));
+ return MXCSR(float_state) | x87sw;
+}
+
+inline static unsigned int uap_fpu_status(void *uap)
+{
+ return mach_fpu_status(UAP_FS(uap));
+}
+
inline static cell fix_stack_pointer(cell sp)
{
return ((sp + 8) & ~15) - 8;
}
+inline static void mach_clear_fpu_status(x86_float_state64_t *float_state)
+{
+ MXCSR(float_state) &= 0xffffffc0;
+ memset(&X87SW(float_state), 0, sizeof(X87SW(float_state)));
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+ mach_clear_fpu_status(UAP_FS(uap));
+}
+
}
#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
+static inline unsigned int uap_fpu_status(void *uap) { return 0; }
+static inline void uap_clear_fpu_status(void *uap) { }
+
}
#define ucontext_stack_pointer(uap) \
((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP]))
+static inline unsigned int uap_fpu_status(void *uap) { return 0; }
+static inline void uap_clear_fpu_status(void *uap) { }
+
}
#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap)
-#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
-
}
#define ucontext_stack_pointer openbsd_stack_pointer
#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
+static inline unsigned int uap_fpu_status(void *uap) { return 0; }
+static inline void uap_clear_fpu_status(void *uap) { }
+
}
#define ucontext_stack_pointer openbsd_stack_pointer
#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
+static inline unsigned int uap_fpu_status(void *uap) { return 0; }
+static inline void uap_clear_fpu_status(void *uap) { }
+
}
UAP_PROGRAM_COUNTER(uap) = (cell)misc_signal_handler_impl;
}
+void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+{
+ signal_number = signal;
+ signal_callstack_top = uap_stack_pointer(uap);
+ signal_fpu_status = fpu_status(uap_fpu_status(uap));
+ uap_clear_fpu_status(uap);
+ UAP_PROGRAM_COUNTER(uap) =
+ (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
+ ? (cell)misc_signal_handler_impl
+ : (cell)fp_signal_handler_impl;
+}
+
static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
{
int ret;
{
struct sigaction memory_sigaction;
struct sigaction misc_sigaction;
+ struct sigaction fpe_sigaction;
struct sigaction ignore_sigaction;
memset(&memory_sigaction,0,sizeof(struct sigaction));
sigaction_safe(SIGBUS,&memory_sigaction,NULL);
sigaction_safe(SIGSEGV,&memory_sigaction,NULL);
+ memset(&fpe_sigaction,0,sizeof(struct sigaction));
+ sigemptyset(&fpe_sigaction.sa_mask);
+ fpe_sigaction.sa_sigaction = fpe_signal_handler;
+ fpe_sigaction.sa_flags = SA_SIGINFO;
+
+ sigaction_safe(SIGFPE,&fpe_sigaction,NULL);
+
memset(&misc_sigaction,0,sizeof(struct sigaction));
sigemptyset(&misc_sigaction.sa_mask);
misc_sigaction.sa_sigaction = misc_signal_handler;
misc_sigaction.sa_flags = SA_SIGINFO;
sigaction_safe(SIGABRT,&misc_sigaction,NULL);
- sigaction_safe(SIGFPE,&misc_sigaction,NULL);
sigaction_safe(SIGQUIT,&misc_sigaction,NULL);
sigaction_safe(SIGILL,&misc_sigaction,NULL);
#define ESP Esp
#define EIP Eip
+typedef struct DECLSPEC_ALIGN(16) _M128A {
+ ULONGLONG Low;
+ LONGLONG High;
+} M128A, *PM128A;
+
+/* The ExtendedRegisters field of the x86.32 CONTEXT structure uses this layout; however,
+ * this structure is only made available from winnt.h on x86.64 */
+typedef struct _XMM_SAVE_AREA32 {
+ WORD ControlWord; /* 000 */
+ WORD StatusWord; /* 002 */
+ BYTE TagWord; /* 004 */
+ BYTE Reserved1; /* 005 */
+ WORD ErrorOpcode; /* 006 */
+ DWORD ErrorOffset; /* 008 */
+ WORD ErrorSelector; /* 00c */
+ WORD Reserved2; /* 00e */
+ DWORD DataOffset; /* 010 */
+ WORD DataSelector; /* 014 */
+ WORD Reserved3; /* 016 */
+ DWORD MxCsr; /* 018 */
+ DWORD MxCsr_Mask; /* 01c */
+ M128A FloatRegisters[8]; /* 020 */
+ M128A XmmRegisters[16]; /* 0a0 */
+ BYTE Reserved4[96]; /* 1a0 */
+} XMM_SAVE_AREA32, *PXMM_SAVE_AREA32;
+
+#define X87SW(ctx) (ctx)->FloatSave.StatusWord
+#define MXCSR(ctx) ((XMM_SAVE_AREA32*)((ctx)->ExtendedRegisters))->MxCsr
+
}
#define ESP Rsp
#define EIP Rip
+#define X87SW(ctx) (ctx)->FloatSave.StatusWord
+#define MXCSR(ctx) (ctx)->MxCsr
+
}
else
signal_callstack_top = NULL;
- if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION)
+ switch (e->ExceptionCode)
{
+ case EXCEPTION_ACCESS_VIOLATION:
signal_fault_addr = e->ExceptionInformation[1];
c->EIP = (cell)memory_signal_handler_impl;
- }
- /* If the Widcomm bluetooth stack is installed, the BTTray.exe process
- injects code into running programs. For some reason this results in
- random SEH exceptions with this (undocumented) exception code being
- raised. The workaround seems to be ignoring this altogether, since that
- is what happens if SEH is not enabled. Don't really have any idea what
- this exception means. */
- else if(e->ExceptionCode != 0x40010006)
- {
+ break;
+
+ case STATUS_FLOAT_DENORMAL_OPERAND:
+ case STATUS_FLOAT_DIVIDE_BY_ZERO:
+ case STATUS_FLOAT_INEXACT_RESULT:
+ case STATUS_FLOAT_INVALID_OPERATION:
+ case STATUS_FLOAT_OVERFLOW:
+ case STATUS_FLOAT_STACK_CHECK:
+ case STATUS_FLOAT_UNDERFLOW:
+ case STATUS_FLOAT_MULTIPLE_FAULTS:
+ case STATUS_FLOAT_MULTIPLE_TRAPS:
+ signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c));
+ X87SW(c) = 0;
+ MXCSR(c) &= 0xffffffc0;
+ c->EIP = (cell)fp_signal_handler_impl;
+ break;
+ case 0x40010006:
+ /* If the Widcomm bluetooth stack is installed, the BTTray.exe
+ process injects code into running programs. For some reason this
+ results in random SEH exceptions with this (undocumented)
+ exception code being raised. The workaround seems to be ignoring
+ this altogether, since that is what happens if SEH is not
+ enabled. Don't really have any idea what this exception means. */
+ break;
+ default:
signal_number = e->ExceptionCode;
c->EIP = (cell)misc_signal_handler_impl;
+ break;
}
-
return EXCEPTION_CONTINUE_EXECUTION;
}
FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe);
void open_console();
+// SSE traps raise these exception codes, which are defined in internal NT headers
+// but not winbase.h
+#define STATUS_FLOAT_MULTIPLE_FAULTS 0xC00002B4
+#define STATUS_FLOAT_MULTIPLE_TRAPS 0xC00002B5
+
}
primitive_float_lesseq,
primitive_float_greater,
primitive_float_greatereq,
+ /* The unordered comparison primitives don't have a non-optimizing
+ compiler implementation */
+ primitive_float_less,
+ primitive_float_lesseq,
+ primitive_float_greater,
+ primitive_float_greatereq,
primitive_word,
primitive_word_xt,
primitive_getenv,
projects / factor.git / commitdiff