HELP: <c-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." }
-{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
+{ $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>
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, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
-{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
+{ $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, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
HELP: require-c-array
{ $values { "c-type" "a C type" } }
-{ $description { $link require } "s any unloaded vocabularies needed to construct 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 set for details on the underlying sequence types loaded." } ;
+{ $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, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } ;
+{ $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."
{ getter callable }
{ setter callable }
size
-align
-array-class
-array-constructor
-(array)-constructor
-direct-array-constructor ;
+align ;
TUPLE: c-type < abstract-c-type
boxer
] ?if
] if ;
-: ?require-word ( word/pair -- )
- dup word? [ drop ] [ first require ] ?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: require-c-array ( c-type -- )
-M: object require-c-array
- drop ;
-
-M: c-type require-c-array
- array-class>> ?require-word ;
-
-M: string require-c-array
- c-type require-c-array ;
-
-M: array require-c-array
- first c-type require-c-array ;
-
-ERROR: specialized-array-vocab-not-loaded vocab word ;
+M: array require-c-array first require-c-array ;
-: c-array-constructor ( c-type -- word )
- array-constructor>> dup array?
- [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+GENERIC: c-array-constructor ( c-type -- word )
-: c-(array)-constructor ( c-type -- word )
- (array)-constructor>> dup array?
- [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+GENERIC: c-(array)-constructor ( c-type -- word )
-: c-direct-array-constructor ( c-type -- word )
- direct-array-constructor>> dup array?
- [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+GENERIC: c-direct-array-constructor ( c-type -- word )
GENERIC: <c-array> ( len c-type -- array )
-M: object <c-array>
- c-array-constructor execute( len -- array ) ; inline
+
M: string <c-array>
- c-type <c-array> ; inline
-M: array <c-array>
- first c-type <c-array> ; inline
+ c-array-constructor execute( len -- array ) ; inline
GENERIC: (c-array) ( len c-type -- array )
-M: object (c-array)
- c-(array)-constructor execute( len -- array ) ; inline
+
M: string (c-array)
- c-type (c-array) ; inline
-M: array (c-array)
- first c-type (c-array) ; inline
+ c-(array)-constructor execute( len -- array ) ; inline
GENERIC: <c-direct-array> ( alien len c-type -- array )
-M: object <c-direct-array>
- c-direct-array-constructor execute( alien len -- array ) ; inline
+
M: string <c-direct-array>
- c-type <c-direct-array> ; inline
-M: array <c-direct-array>
- first c-type <c-direct-array> ; inline
+ c-direct-array-constructor execute( alien len -- array ) ; inline
: malloc-array ( n type -- alien )
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
: if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
-: ?lookup ( vocab word -- word/pair )
- over vocab [ swap lookup ] [ 2array ] if ;
-
-: set-array-class* ( c-type vocab-stem type-stem -- c-type )
- {
- [
- [ "specialized-arrays." prepend ]
- [ "-array" append ] bi* ?lookup >>array-class
- ]
- [
- [ "specialized-arrays." prepend ]
- [ "<" "-array>" surround ] bi* ?lookup >>array-constructor
- ]
- [
- [ "specialized-arrays." prepend ]
- [ "(" "-array)" surround ] bi* ?lookup >>(array)-constructor
- ]
- [
- [ "specialized-arrays." prepend ]
- [ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
- ]
- } 2cleave ;
-
-: set-array-class ( c-type stem -- c-type )
- dup set-array-class* ;
-
CONSTANT: primitive-types
{
"char" "uchar"
[ >c-ptr ] >>unboxer-quot
"box_alien" >>boxer
"alien_offset" >>unboxer
- "alien" "void*" set-array-class*
"void*" define-primitive-type
<long-long-type>
8 >>align
"box_signed_8" >>boxer
"to_signed_8" >>unboxer
- "longlong" set-array-class
"longlong" define-primitive-type
<long-long-type>
8 >>align
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
- "ulonglong" set-array-class
"ulonglong" define-primitive-type
<c-type>
bootstrap-cell >>align
"box_signed_cell" >>boxer
"to_fixnum" >>unboxer
- "long" set-array-class
"long" define-primitive-type
<c-type>
bootstrap-cell >>align
"box_unsigned_cell" >>boxer
"to_cell" >>unboxer
- "ulong" set-array-class
"ulong" define-primitive-type
<c-type>
4 >>align
"box_signed_4" >>boxer
"to_fixnum" >>unboxer
- "int" set-array-class
"int" define-primitive-type
<c-type>
4 >>align
"box_unsigned_4" >>boxer
"to_cell" >>unboxer
- "uint" set-array-class
"uint" define-primitive-type
<c-type>
2 >>align
"box_signed_2" >>boxer
"to_fixnum" >>unboxer
- "short" set-array-class
"short" define-primitive-type
<c-type>
2 >>align
"box_unsigned_2" >>boxer
"to_cell" >>unboxer
- "ushort" set-array-class
"ushort" define-primitive-type
<c-type>
1 >>align
"box_signed_1" >>boxer
"to_fixnum" >>unboxer
- "char" set-array-class
"char" define-primitive-type
<c-type>
1 >>align
"box_unsigned_1" >>boxer
"to_cell" >>unboxer
- "uchar" set-array-class
"uchar" define-primitive-type
<c-type>
1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
- "bool" set-array-class
"bool" define-primitive-type
<c-type>
"to_float" >>unboxer
float-rep >>rep
[ >float ] >>unboxer-quot
- "float" set-array-class
"float" define-primitive-type
<c-type>
"to_double" >>unboxer
double-rep >>rep
[ >float ] >>unboxer-quot
- "double" set-array-class
"double" define-primitive-type
"long" "ptrdiff_t" typedef
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
number >>boxed-class
-T set-array-class
drop
;FUNCTOR
}
"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." ;
+"Arrays of C unions can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ;
[ name>> = ] with find nip offset>> ;
USE: vocabs.loader
-"struct-arrays" require
+"specialized-arrays" require
--- /dev/null
+unportable
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
: pprint-struct-slot ( slot -- )
<flow \ { pprint-word
- {
+ f <inset {
[ name>> text ]
[ c-type>> dup string? [ text ] [ pprint* ] if ]
[ read-only>> [ \ read-only pprint-word ] when ]
[ initial>> [ \ initial: pprint-word pprint* ] when* ]
- } cleave
+ } cleave block>
\ } pprint-word block> ;
: pprint-struct ( struct -- )
! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.libraries
-alien.structs.fields alien.syntax ascii assocs byte-arrays
-classes.struct classes.tuple.private combinators
-compiler.tree.debugger compiler.units destructors
+USING: accessors alien alien.c-types alien.structs.fields 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.char
-specialized-arrays.int specialized-arrays.ushort
-struct-arrays system tools.test ;
+prettyprint.config see sequences specialized-arrays system
+tools.test parser lexer eval ;
+SPECIALIZED-ARRAY: char
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: ushort
IN: classes.struct.tests
-<<
-: libfactor-ffi-tests-path ( -- string )
- "resource:" (normalize-path)
- {
- { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
- { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
- { [ os unix? ] [ "libfactor-ffi-test.so" ] }
- } cond append-path ;
-
-"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
-
-"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
->>
-
SYMBOL: struct-test-empty
[ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
] with-destructors
] unit-test
-STRUCT: struct-test-ffi-foo
- { x int }
- { y int } ;
-
-LIBRARY: f-cdecl
-FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
-
-[ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
-
STRUCT: struct-test-array-slots
{ x int }
{ y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
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 struct-test-optimization <direct-struct-array> third y>> ]
+ [ 3 <direct-struct-test-optimization-array> third y>> ]
{ <tuple> <tuple-boa> memory>struct y>> } inlined?
] unit-test
[ -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
classes.tuple classes.tuple.parser classes.tuple.private
combinators combinators.short-circuit combinators.smart
definitions functors.backend fry generalizations generic.parser
-kernel kernel.private lexer libc locals macros make math math.order
-parser quotations sequences slots slots.private struct-arrays vectors
-words compiler.tree.propagation.transforms specialized-arrays.uchar ;
+kernel kernel.private lexer libc locals macros make math
+math.order parser quotations sequences slots slots.private
+specialized-arrays vectors words summary namespaces assocs
+compiler.tree.propagation.transforms ;
FROM: slots => reader-word writer-word ;
IN: classes.struct
-! struct class
+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
c-type ;
-PREDICATE: struct-class < tuple-class \ struct subclass-of? ;
+PREDICATE: struct-class < tuple-class
+ superclass \ struct eq? ;
+
+M: struct-class valid-superclass? drop f ;
-: struct-slots ( struct-class -- slots )
- "struct-slots" word-prop ;
+GENERIC: struct-slots ( struct-class -- slots )
+
+M: struct-class struct-slots "struct-slots" word-prop ;
! struct allocation
[ c-type>> c-type-align ] [ max ] map-reduce ;
PRIVATE>
-M: struct-class c-type
- name>> c-type ;
+M: struct-class c-type name>> c-type ;
-M: struct-class c-type-align
- "struct-align" word-prop ;
+M: struct-class c-type-align c-type c-type-align ;
-M: struct-class c-type-getter
- drop [ swap <displaced-alien> ] ;
+M: struct-class c-type-getter c-type c-type-getter ;
-M: struct-class c-type-setter
- [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
- '[ @ swap @ _ memcpy ] ;
+M: struct-class c-type-setter c-type c-type-setter ;
-M: struct-class c-type-boxer-quot
- (boxer-quot) ;
+M: struct-class c-type-boxer-quot c-type c-type-boxer-quot ;
-M: struct-class c-type-unboxer-quot
- (unboxer-quot) ;
+M: struct-class c-type-unboxer-quot c-type c-type-boxer-quot ;
-M: struct-class heap-size
- "struct-size" word-prop ;
+M: struct-class heap-size c-type heap-size ;
-M: struct byte-length
- class "struct-size" word-prop ; foldable
+M: struct byte-length class "struct-size" word-prop ; foldable
! class definition
<PRIVATE
: make-struct-prototype ( class -- prototype )
- [ heap-size <byte-array> ]
+ [ "struct-size" word-prop <byte-array> ]
[ memory>struct ]
[ struct-slots ] tri
[
: (define-struct-class) ( class slots offsets-quot -- )
[
+ empty?
[ struct-must-have-slots ]
- [ drop redefine-struct-tuple-class ] if-empty
+ [ redefine-struct-tuple-class ] if
]
swap '[
make-slots dup
: 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' )
scan {
{ ";" [ f ] }
{ "{" [ parse-struct-slot over push t ] }
+ { f [ unexpected-eof ] }
[ invalid-struct-slot ]
} case ;
--- /dev/null
+Tuple-like access to structured raw memory
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.alien ;
+generalizations specialized-arrays ;
IN: cocoa.messages
+SPECIALIZED-ARRAY: void*
+
: make-sender ( method function -- quot )
[ over first , f , , second , \ alien-invoke , ] [ ] make ;
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&&
! 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 ;
[ ##dispatch? ]
[ ##compare-branch? ]
[ ##compare-imm-branch? ]
- [ ##compare-float-branch? ]
+ [ ##compare-float-ordered-branch? ]
+ [ ##compare-float-unordered-branch? ]
[ ##fixnum-add? ]
[ ##fixnum-sub? ]
[ ##fixnum-mul? ]
literal: cc
temp: temp/int-rep ;
-INSN: ##compare-float-branch
+INSN: ##compare-float-ordered-branch
use: src1/double-rep src2/double-rep
literal: cc ;
-PURE-INSN: ##compare-float
+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: temp1/int-rep temp2/int-rep
literal: 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
literal: stack-frame ;
constant: src2
literal: cc ;
-INSN: _compare-float-branch
+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 ;
"insn-slots" word-prop [ type>> { def use temp } memq? ] any?
] filter
define-union-class
-] with-compilation-unit
\ No newline at end of file
+] with-compilation-unit
"insn-slots" word-prop
[ type>> def eq? ] find nip ;
-: insn-use-slots ( class -- slot/f )
+: insn-use-slots ( class -- slots )
"insn-slots" word-prop
[ type>> use eq? ] filter ;
-: insn-temp-slots ( class -- slot/f )
+: insn-temp-slots ( class -- slots )
"insn-slots" word-prop
[ type>> temp eq? ] filter ;
[ 2inputs ] dip call ds-push ; inline
: emit-float-comparison ( cc -- )
- [ 2inputs ] dip ^^compare-float ds-push ; inline
+ [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline
: emit-float>fixnum ( -- )
ds-pop ^^float>integer ^^tag-fixnum ds-push ;
{ 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 ( -- )
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
--- /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 ;
: 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 -- ? )
] [ drop f ] if ; inline
: general-compare-expr? ( insn -- ? )
- { [ compare-expr? ] [ compare-imm-expr? ] [ compare-float-expr? ] } 1|| ;
+ {
+ [ compare-expr? ]
+ [ compare-imm-expr? ]
+ [ compare-float-unordered-expr? ]
+ [ compare-float-ordered-expr? ]
+ } 1|| ;
: rewrite-boolean-comparison? ( insn -- ? )
dup ##branch-t? [
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-expr? ] [ >compare-expr< \ ##compare-float-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 -- ? )
[ 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-expr? ] [ >compare-expr< next-vreg \ ##compare-float 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 ;
dup {
[ ##compare? ]
[ ##compare-imm? ]
- [ ##compare-float? ]
+ [ ##compare-float-unordered? ]
+ [ ##compare-float-ordered? ]
} 1|| [ f >>temp ] when
] map ;
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
CODEGEN: ##write-barrier %write-barrier
CODEGEN: ##compare %compare
CODEGEN: ##compare-imm %compare-imm
-CODEGEN: ##compare-float %compare-float
+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: _branch %jump-label
CODEGEN: _compare-branch %compare-branch
CODEGEN: _compare-imm-branch %compare-imm-branch
-CODEGEN: _compare-float-branch %compare-float-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
[ [ 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: ##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
compiler continuations effects io io.backend io.pathnames
io.streams.string kernel math memory namespaces
namespaces.private parser quotations sequences
-specialized-arrays.float stack-checker stack-checker.errors
-system threads tools.test words specialized-arrays.char ;
+specialized-arrays stack-checker stack-checker.errors
+system threads tools.test words ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: char
IN: compiler.tests.alien
<<
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
+specialized-arrays system sorting math.libm
math.intervals quotations effects alien ;
+SPECIALIZED-ARRAY: double
IN: compiler.tree.propagation.tests
[ V{ } ] [ [ ] final-classes ] 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
] [ 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? ;
! 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.alien classes.struct
-specialized-arrays.int specialized-arrays.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
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 rep n -- )
HOOK: %reload cpu ( dst rep n -- )
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 ( -- )
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 ;
+
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
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 ;
: (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
: (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
-:: (%compare-float) ( src1 src2 cc -- branch1 branch2 )
+:: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
cc {
- { cc< [ src1 src2 (%compare-float-ordered) \ BLT f ] }
- { cc<= [ src1 src2 (%compare-float-ordered) \ BLT \ BEQ ] }
- { cc> [ src1 src2 (%compare-float-ordered) \ BGT f ] }
- { cc>= [ src1 src2 (%compare-float-ordered) \ BGT \ BEQ ] }
- { cc= [ src1 src2 (%compare-float-unordered) \ BEQ f ] }
- { cc<> [ src1 src2 (%compare-float-ordered) \ BLT \ BGT ] }
- { cc<>= [ src1 src2 (%compare-float-ordered) \ BNO f ] }
- { cc/< [ src1 src2 (%compare-float-unordered) \ BGE f ] }
- { cc/<= [ src1 src2 (%compare-float-unordered) \ BGT \ BO ] }
- { cc/> [ src1 src2 (%compare-float-unordered) \ BLE f ] }
- { cc/>= [ src1 src2 (%compare-float-unordered) \ BLT \ BO ] }
- { cc/= [ src1 src2 (%compare-float-unordered) \ BNE f ] }
- { cc/<> [ src1 src2 (%compare-float-unordered) \ BEQ \ BO ] }
- { cc/<>= [ src1 src2 (%compare-float-unordered) \ BO f ] }
+ { 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 ( dst src1 src2 cc temp -- )
- cc negate-cc src1 src2 (%compare-float) :> branch2 :> branch1
+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/= [ label BNE ] }
} case ;
-M: ppc %compare-branch [ (%compare) ] 2dip %branch ;
+M:: ppc %compare-branch ( label src1 src2 cc -- )
+ src1 src2 (%compare)
+ label cc %branch ;
-M: ppc %compare-imm-branch [ (%compare-imm) ] 2dip %branch ;
+M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
+ src1 src2 (%compare-imm)
+ label cc %branch ;
-M:: ppc %compare-float-branch ( label src1 src2 cc -- )
- cc src1 src2 (%compare-float) :> branch2 :> branch1
+:: (%branch) ( label branch1 branch2 -- )
label branch1 execute( label -- )
- branch2 [ label branch2 execute( label -- ) ] when ;
+ 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 -- )
{
! 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 "double" c-type (>>align)
] unless
-USE: vocabs.loader
-
"cpu.x86.features" require
-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
--- /dev/null
+unportable
M: x86 %broadcast-vector ( dst src rep -- )
{
- { float-4-rep [ [ MOVAPS ] [ drop dup 0 SHUFPS ] 2bi ] }
- { double-2-rep [ [ MOVAPD ] [ drop dup 0 SHUFPD ] 2bi ] }
+ { 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 -- )
dst src1 MOVSS
dst src2 UNPCKLPS
src3 src4 UNPCKLPS
- dst src3 HEX: 44 SHUFPS
+ dst src3 MOVLHPS
]
}
} case ;
{
double-2-rep
[
- dst src1 MOVAPD
- dst src2 0 SHUFPD
+ dst src1 MOVSD
+ dst src2 UNPCKLPD
]
}
} case ;
! 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
"no-move" resolve-label
] with-scope ;
-M:: x86 %compare-float ( dst src1 src2 cc temp -- )
+:: (%compare-float) ( dst src1 src2 cc temp compare -- )
cc {
- { cc< [ src2 src1 COMISD dst temp \ CMOVA %boolean ] }
- { cc<= [ src2 src1 COMISD dst temp \ CMOVAE %boolean ] }
- { cc> [ src1 src2 COMISD dst temp \ CMOVA %boolean ] }
- { cc>= [ src1 src2 COMISD dst temp \ CMOVAE %boolean ] }
- { cc= [ src1 src2 UCOMISD dst temp \ %cmov-float= %boolean ] }
- { cc<> [ src1 src2 COMISD dst temp \ CMOVNE %boolean ] }
- { cc<>= [ src1 src2 COMISD dst temp \ CMOVNP %boolean ] }
- { cc/< [ src2 src1 UCOMISD dst temp \ CMOVBE %boolean ] }
- { cc/<= [ src2 src1 UCOMISD dst temp \ CMOVB %boolean ] }
- { cc/> [ src1 src2 UCOMISD dst temp \ CMOVBE %boolean ] }
- { cc/>= [ src1 src2 UCOMISD dst temp \ CMOVB %boolean ] }
- { cc/= [ src1 src2 UCOMISD dst temp \ %cmov-float/= %boolean ] }
- { cc/<> [ src1 src2 UCOMISD dst temp \ CMOVE %boolean ] }
- { cc/<>= [ src1 src2 UCOMISD dst temp \ CMOVP %boolean ] }
- } case ;
+ { 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
: %jump-float/= ( label -- )
[ JNE ] [ JP ] bi ;
-M:: x86 %compare-float-branch ( label src1 src2 cc -- )
+:: (%compare-float-branch) ( label src1 src2 cc compare -- )
cc {
- { cc< [ src2 src1 COMISD label JA ] }
- { cc<= [ src2 src1 COMISD label JAE ] }
- { cc> [ src1 src2 COMISD label JA ] }
- { cc>= [ src1 src2 COMISD label JAE ] }
- { cc= [ src1 src2 UCOMISD label %jump-float= ] }
- { cc<> [ src1 src2 COMISD label JNE ] }
- { cc<>= [ src1 src2 COMISD label JNP ] }
- { cc/< [ src2 src1 UCOMISD label JBE ] }
- { cc/<= [ src2 src1 UCOMISD label JB ] }
- { cc/> [ src1 src2 UCOMISD label JBE ] }
- { cc/>= [ src1 src2 UCOMISD label JB ] }
- { cc/= [ src1 src2 UCOMISD label %jump-float/= ] }
- { cc/<> [ src1 src2 UCOMISD label JE ] }
- { cc/<>= [ src1 src2 UCOMISD label JP ] }
+ { 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 %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 %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 ;
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
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 classes.struct ;
+SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
IN: game-input.dinput
+
CONSTANT: MOUSE-BUFFER-SIZE 16
SINGLETON: dinput-game-input-backend
: 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 <struct-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 <struct>
! 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 ;
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
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
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes.struct 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 ;
+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 ;
! 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
-classes.struct ;
+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 ;
: <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 ;
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
-arrays io.files.info.unix classes.struct struct-arrays ;
+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 file-systems ( -- array )
f 0 0 getfsstat dup io-error
- \ statfs <struct-array>
+ <statfs-array>
[ dup byte-length 0 getfsstat io-error ]
[ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ;
! 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.uint arrays
-unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx
-io.files.info.unix io.files.info classes.struct struct-arrays ;
+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 <direct-struct-array>
+ [ *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 ;
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 classes.struct struct-arrays
-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 file-systems ( -- array )
f 0 0 getvfsstat dup io-error
- \ statvfs <struct-array>
+ <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
-arrays io.files.info.unix classes.struct struct-arrays
-io.encodings.utf8 ;
+arrays io.files.info.unix classes.struct
+specialized-arrays io.encodings.utf8 ;
+SPECIALIZED-ARRAY: statvfs
IN: io.files.unix.openbsd
TUPLE: openbsd-file-system-info < unix-file-system-info
M: openbsd file-systems ( -- seq )
f 0 0 getfsstat dup io-error
- \ statfs <struct-array>
+ <statvfs-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 classes.struct struct-arrays ;
+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
: timestamps>byte-array ( timestamps -- byte-array )
[ [ timestamp>timeval ] [ \ timeval <struct> ] if* ] map
- \ timeval >struct-array ;
+ >timeval-array ;
PRIVATE>
generalizations system alien.strings io.encodings.utf16n
sequences splitting windows.errors fry continuations destructors
calendar ascii combinators.short-circuit locals classes.struct
-specialized-arrays.ushort ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: ushort
IN: io.files.info.windows
:: round-up-to ( n multiple -- n' )
[ 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-array> tuck dup length
0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
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 ;
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 specialized-arrays.ushort classes.struct ;
+windows.errors specialized-arrays classes.struct ;
+SPECIALIZED-ARRAY: ushort
IN: io.files.windows.nt
M: winnt cwd
! 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 classes classes.struct ;
+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
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.alien ;
-IN: io.mmap.alien
-
-<< "void*" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.bool ;
-IN: io.mmap.bool
-
-<< "bool" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.char ;
-IN: io.mmap.char
-
-<< "char" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.double ;
-IN: io.mmap.double
-
-<< "double" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.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.int ;
-IN: io.mmap.int
-
-<< "int" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.long ;
-IN: io.mmap.long
-
-<< "long" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.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.short ;
-IN: io.mmap.short
-
-<< "short" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.uchar ;
-IN: io.mmap.uchar
-
-<< "uchar" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.uint ;
-IN: io.mmap.uint
-
-<< "uint" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.ulong ;
-IN: io.mmap.ulong
-
-<< "ulong" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.ulonglong ;
-IN: io.mmap.ulonglong
-
-<< "ulonglong" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.ushort ;
-IN: io.mmap.ushort
-
-<< "ushort" define-mapped-array >>
\ No newline at end of file
! 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 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>) ;
! (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 ;
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.float specialized-arrays.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 ;
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.complex-float specialized-arrays.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 ;
--- /dev/null
+! (c)Joe Groff bsd license
+USING: help help.markup help.syntax 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 "Replaces the floating-point exception mask to enable processor traps to be raised for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask 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 } related-words
+
+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 }
+"Querying and controlling the rounding mode and treatment of denormals:"
+{ $subsection rounding-mode }
+{ $subsection with-rounding-mode }
+{ $subsection denormal-mode }
+{ $subsection with-denormal-mode }
+{ $notes "On PowerPC, the above words only modify the scalar FPU's state (in FPSCR); the AltiVec unit is currently unaffected." } ;
+
+ABOUT: "math.floats.env"
--- /dev/null
+USING: kernel math math.floats.env math.floats.env.private
+math.functions math.libm sequences tools.test ;
+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
+
+[ t ] [
+ [ 1.0 0.0 / drop ] collect-fp-exceptions
+ +fp-zero-divide+ swap member?
+] unit-test
+
+[ t ] [
+ [ 1.0 3.0 / drop ] collect-fp-exceptions
+ +fp-inexact+ swap member?
+] unit-test
+
+[ t ] [
+ [ 1.0e250 1.0e100 * drop ] collect-fp-exceptions
+ +fp-overflow+ swap member?
+] unit-test
+
+[ t ] [
+ [ 1.0e-250 1.0e-100 * drop ] collect-fp-exceptions
+ +fp-underflow+ swap member?
+] unit-test
+
+[ t ] [
+ [ 2.0 100,000.0 ^ drop ] collect-fp-exceptions
+ +fp-overflow+ swap member?
+] unit-test
+
+[ t ] [
+ [ 2.0 -100,000.0 ^ drop ] collect-fp-exceptions
+ +fp-underflow+ swap member?
+] unit-test
+
+[ t ] [
+ [ 0.0 0.0 /f drop ] collect-fp-exceptions
+ +fp-invalid-operation+ swap member?
+] unit-test
+
+[ t ] [
+ [ -1.0 fsqrt drop ] collect-fp-exceptions
+ +fp-invalid-operation+ swap member?
+] 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
+
+[ { +fp-zero-divide+ } [ 1.0 0.0 /f ] with-fp-traps ] must-fail
+[ { +fp-inexact+ } [ 1.0 3.0 /f ] with-fp-traps ] must-fail
+[ { +fp-invalid-operation+ } [ -1.0 fsqrt ] with-fp-traps ] must-fail
+[ { +fp-overflow+ } [ 2.0 100,000.0 ^ ] with-fp-traps ] must-fail
+[ { +fp-underflow+ } [ 2.0 -100,000.0 ^ ] with-fp-traps ] must-fail
+
+! 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 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+ ;
+
+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 ;
+
+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 call fp-exception-flags ; inline
+
+: 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 -- )
+ 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 }
+ { fpcsr 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 ) ;
+
+: <ppc-fpu-env> ( -- ppc-fpu-env )
+ ppc-fpu-env (struct)
+ [ get_ppc_fpu_env ] keep ;
+
+M: ppc-fpu-env (set-fp-env-register)
+ set_ppc_fpu_env ;
+
+M: ppc (fp-env-registers)
+ <ppc-fpu-env> 1array ;
+
+CONSTANT: ppc-exception-flag-bits HEX: 3e00,0000
+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: f80
+CONSTANT: ppc-fp-traps>bit
+ H{
+ { +fp-invalid-operation+ HEX: 8000 }
+ { +fp-overflow+ HEX: 4000 }
+ { +fp-underflow+ HEX: 2000 }
+ { +fp-zero-divide+ HEX: 1000 }
+ { +fp-inexact+ HEX: 0800 }
+ }
+
+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 )
+ fpcsr>> 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-fpcsr ; inline
+
+M: ppc-fpu-env (get-fp-traps) ( register -- exceptions )
+ fpcsr>> not ppc-fp-traps>bit mask> ; inline
+M: ppc-fpu-env (set-fp-traps) ( register exceptions -- register' )
+ [ ppc-fp-traps>bit >mask not ppc-fp-traps-bits remask ] curry change-fpcsr ; inline
+
+M: ppc-fpu-env (get-rounding-mode) ( register -- mode )
+ fpcsr>> 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-fpcsr ; inline
+
+M: ppc-fpu-env (get-denormal-mode) ( register -- mode )
+ fpcsr>> 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-fpcsr ; 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 ;
+
{ $subsection exp }
{ $subsection cis }
{ $subsection log }
+{ $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." } ;
M: real log >float log ; inline
-M: complex log >polar swap flog swap rect> ; inline
+M: complex log >polar [ flog ] dip rect> ; inline
+
+GENERIC: log1+ ( x -- y )
+
+M: object log1+ 1 + log ; inline
+
+M: float log1+ dup -1.0 >= [ flog1+ ] [ 1.0 + 0.0 rect> log ] if ; inline
: 10^ ( x -- y ) 10 swap ^ ; inline
"double" "libm" "sqrt" { "double" } alien-invoke ;
! Windows doesn't have these...
+: flog1+ ( x -- y )
+ "double" "libm" "log1p" { "double" } alien-invoke ;
+
: facosh ( x -- y )
"double" "libm" "acosh" { "double" } alien-invoke ;
: (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
-IN: math.vectors.simd.alien.tests
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.float combinators ;
+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 } ] [
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 locals
-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+ ;
dup "specializations" word-prop
[ ] [ V{ } clone [ "specializations" set-word-prop ] keep ] ?if ;
-M: vector-word subwords specializations values ;
+M: vector-word subwords specializations values [ word? ] filter ;
: add-specialization ( new-word signature word -- )
specializations set-at ;
array-type elt-type word word-schema inputs signature-for-schema ;
:: specialize-vector-words ( array-type elt-type simd -- )
- vector-words keys [
- [ array-type elt-type simd specialize-vector-word ]
- [ array-type elt-type input-signature ]
- [ ]
- tri add-specialization
- ] each ;
+ 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
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?
! 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
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
-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, 2009 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 alien specialized-arrays ;
-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" ;
-
-: (underlying) ( n c-type -- array )
- heap-size * (byte-array) ; inline
-
-: <underlying> ( n type -- array )
- heap-size * <byte-array> ; inline
-
-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}>
->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
-
-: 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 underlying>> length ; inline
-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
-
-T c-type
- \ A >>array-class
- \ <A> >>array-constructor
- \ (A) >>(array)-constructor
- \ <direct-A> >>direct-array-constructor
- drop
-
-;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
-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 "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( alien len -- 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 alien.syntax specialized-arrays sequences
-specialized-arrays.int specialized-arrays.bool
-specialized-arrays.ushort alien.c-types accessors kernel
-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 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[100] } ;
+
+SPECIALIZED-ARRAY: fixed-string
+
+[ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [
+ ALIEN: 123 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, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences vocabs vocabs.loader ;
+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
-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
+++ /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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors arrays kernel prettyprint.backend
-prettyprint.custom prettyprint.sections sequences struct-arrays ;
-IN: struct-arrays.prettyprint
-
-M: struct-array pprint-delims
- drop \ struct-array{ \ } ;
-
-M: struct-array >pprint-sequence
- [ >array ] [ class>> ] bi prefix ;
-
-: pprint-struct-array-pointer ( struct-array -- )
- \ struct-array@
- [ [ class>> pprint-word ] [ underlying>> pprint* ] [ length>> pprint* ] tri ]
- pprint-prefix ;
-
-M: struct-array pprint*
- [ pprint-object ]
- [ pprint-struct-array-pointer ] pprint-c-object ;
-
+++ /dev/null
-IN: struct-arrays
-USING: classes.struct help.markup help.syntax alien strings math multiline ;
-
-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 } { "struct-class" struct-class } { "struct-array" struct-array } }
-{ $description "Creates a new array for holding values of the specified struct type." } ;
-
-HELP: <direct-struct-array>
-{ $values { "alien" c-ptr } { "length" integer } { "struct-class" struct-class } { "struct-array" struct-array } }
-{ $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ;
-
-HELP: struct-array-on
-{ $values { "struct" struct } { "length" integer } { "struct-array" struct-array } }
-{ $description "Create a new array for holding values of " { $snippet "struct" } "'s C type, backed by the memory starting at " { $snippet "struct" } "'s address." }
-{ $examples
-"This word is useful with the FFI. When a C function has a pointer to a struct as its return type (or a C callback has a struct pointer as an argument type), Factor automatically wraps the pointer in a " { $link struct } " object. If the pointer actually references an array of objects, this word will convert the struct object to a struct array object:"
-{ $code <" USING: alien.syntax classes.struct struct-arrays ;
-IN: scratchpad
-
-STRUCT: zim { zang int } { zung int } ;
-
-FUNCTION: zim* zingle ( ) ; ! Returns a pointer to 20 zims
-
-zingle 20 struct-array-on "> }
-} ;
-
-HELP: struct-array{
-{ $syntax "struct-array{ class value value value ... }" }
-{ $description "Literal syntax for a " { $link struct-array } " containing structs of the given " { $link struct } " class." } ;
-
-HELP: struct-array@
-{ $syntax "struct-array@ class alien length" }
-{ $description "Literal syntax for a " { $link struct-array } " at a particular memory address. The prettyprinter uses this syntax when the memory backing a struct array object is invalid. This syntax should not generally be used in source code." } ;
-
-{ POSTPONE: struct-array{ POSTPONE: struct-array@ } related-words
-
-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> }
-{ $subsection struct-array-on }
-"Struct arrays have literal syntax:"
-{ $subsection POSTPONE: struct-array{ } ;
-
-ABOUT: "struct-arrays"
+++ /dev/null
-IN: struct-arrays.tests
-USING: classes.struct struct-arrays tools.test kernel math sequences
-alien.syntax alien.c-types destructors libc accessors sequences.private
-compiler.tree.debugger combinators.smart ;
-
-STRUCT: test-struct-array
- { x int }
- { y int } ;
-
-[ 1 ] [
- 1 struct-array{ test-struct-array } new-sequence length
-] unit-test
-
-[ V{ test-struct-array } ] [
- [ [ test-struct-array <struct> ] struct-array{ test-struct-array } output>sequence first ] final-classes
-] unit-test
-
-: make-point ( x y -- struct )
- test-struct-array <struct-boa> ;
-
-[ 5/4 ] [
- 2 test-struct-array <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 test-struct-array malloc-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 test-struct-array <direct-struct-array> drop ] unit-test
-
-[ ] [
- [
- 10 test-struct-array malloc-struct-array
- &free drop
- ] with-destructors
-] unit-test
-
-[ 15 ] [ 15 10 test-struct-array <struct-array> resize length ] unit-test
-
-[ S{ test-struct-array f 12 20 } ] [
- struct-array{ test-struct-array
- S{ test-struct-array f 4 20 }
- S{ test-struct-array f 12 20 }
- S{ test-struct-array f 20 20 }
- } second
-] unit-test
-
-! Regression
-STRUCT: fixed-string { text char[100] } ;
-
-[ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [
- ALIEN: 123 4 fixed-string <direct-struct-array> [ (underlying)>> ] { } map-as
-] unit-test
-
-[ 10 "int" <struct-array> ] must-fail
-
-STRUCT: wig { x int } ;
-: <bacon> ( -- wig ) 0 wig <struct-boa> ; inline
-: waterfall ( -- a b ) 1 wig <struct-array> <bacon> swap first x>> ; inline
-
-[ t ] [ [ waterfall ] { x>> } inlined? ] 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 alien.structs byte-arrays
-classes classes.struct kernel libc math parser sequences
-sequences.private words fry memoize compiler.units ;
-IN: struct-arrays
-
-TUPLE: struct-array
-{ underlying c-ptr read-only }
-{ length array-capacity read-only }
-{ element-size array-capacity read-only }
-{ class read-only }
-{ ctor read-only } ;
-
-<PRIVATE
-
-: (nth-ptr) ( i struct-array -- alien )
- [ element-size>> * >fixnum ] [ underlying>> ] bi <displaced-alien> ; inline
-
-: (struct-element-constructor) ( struct-class -- word )
- [
- "struct-array-ctor" f <word>
- [ swap '[ _ memory>struct ] (( alien -- object )) define-inline ] keep
- ] with-compilation-unit ;
-
-! Foldable memo word. This is an optimization; by precompiling a
-! constructor for array elements, we avoid memory>struct's slow path.
-MEMO: struct-element-constructor ( struct-class -- word )
- (struct-element-constructor) ; foldable
-
-PRIVATE>
-
-M: struct-array length length>> ; inline
-
-M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
-
-M: struct-array nth-unsafe
- [ (nth-ptr) ] [ ctor>> ] bi execute( alien -- object ) ; inline
-
-M: struct-array set-nth-unsafe
- [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
-
-ERROR: not-a-struct-class struct-class ;
-
-: <direct-struct-array> ( alien length struct-class -- struct-array )
- dup struct-class? [ not-a-struct-class ] unless
- [ heap-size ] [ ] [ struct-element-constructor ]
- tri struct-array boa ; inline
-
-M: struct-array new-sequence
- [ element-size>> * (byte-array) ] [ class>> ] 2bi
- <direct-struct-array> ; inline
-
-M: struct-array resize ( n seq -- newseq )
- [ [ element-size>> * ] [ underlying>> ] bi resize ] [ class>> ] 2bi
- <direct-struct-array> ; inline
-
-: <struct-array> ( length struct-class -- struct-array )
- [ heap-size * <byte-array> ] 2keep <direct-struct-array> ; 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 <direct-struct-array> ; inline
-
-: struct-array-on ( struct length -- struct-array )
- [ [ >c-ptr ] [ class ] bi ] dip swap <direct-struct-array> ; inline
-
-: malloc-struct-array ( length c-type -- struct-array )
- [ heap-size calloc ] 2keep <direct-struct-array> ; inline
-
-INSTANCE: struct-array sequence
-
-M: struct-type <c-array> ( len c-type -- array )
- dup c-array-constructor
- [ execute( len -- array ) ]
- [ <struct-array> ] ?if ; inline
-
-M: struct-type <c-direct-array> ( alien len c-type -- array )
- dup c-direct-array-constructor
- [ execute( alien len -- array ) ]
- [ <direct-struct-array> ] ?if ; inline
-
-: >struct-array ( sequence class -- struct-array )
- [ dup length ] dip <struct-array>
- [ 0 swap copy ] keep ; inline
-
-SYNTAX: struct-array{
- \ } scan-word [ >struct-array ] curry parse-literal ;
-
-SYNTAX: struct-array@
- scan-word [ scan-object scan-object ] dip <direct-struct-array> parsed ;
-
-USING: vocabs vocabs.loader ;
-
-"prettyprint" vocab [ "struct-arrays.prettyprint" require ] when
+++ /dev/null
-Arrays of C structs and unions
+++ /dev/null
-collections
+++ /dev/null
-IN: struct-vectors
-USING: help.markup help.syntax classes.struct alien strings math ;
-
-HELP: struct-vector
-{ $class-description "The class of growable C struct and union arrays." } ;
-
-HELP: <struct-vector>
-{ $values { "capacity" integer } { "struct-class" struct-class } { "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 classes.struct accessors
-namespaces kernel sequences ;
-
-STRUCT: point { x float } { y float } ;
-
-: make-point ( x y -- point ) point <struct-boa> ;
-
-[ ] [ 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 [ x>> ] [ 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 struct-class -- 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"
"vocab:tools/deploy/shaker/strip-destructors.factor"
run-file ;
-: strip-struct-arrays ( -- )
- "struct-arrays" vocab [
- "Stripping dynamic struct array code" show
- "vocab:tools/deploy/shaker/strip-struct-arrays.factor"
- run-file
- ] when ;
-
: strip-call ( -- )
"Stripping stack effect checking from call( and execute(" show
"vocab:tools/deploy/shaker/strip-call.factor" run-file ;
: strip ( -- )
init-stripper
strip-libc
- strip-struct-arrays
strip-destructors
strip-call
strip-cocoa
+++ /dev/null
-USING: kernel stack-checker.transforms ;
-IN: struct-arrays.private
-
-: struct-element-constructor ( c-type -- word )
- "Struct array usages must be compiled" throw ;
-
-<<
-
-\ struct-element-constructor [
- (struct-element-constructor) [ ] curry
-] 1 define-transform
-
->>
\ No newline at end of file
! 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 classes.struct ;
+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
: client-area>RECT ( hwnd -- RECT )
RECT <struct>
[ GetClientRect win32-error=0/f ]
- [ >c-ptr "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 )
<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 font>> t >>bold? drop
+ dup children>> first border-button-label-theme
horizontal >>orientation
<border-button-pen> >>interior
dup dup interior>> pen-pref-dim >>min-dim
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:
} 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>> ;
! 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&& ;
namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units
destructors fry math.parser generalizations sets
-specialized-arrays.alien windows.kernel32 classes.struct ;
+specialized-arrays windows.kernel32 classes.struct ;
+SPECIALIZED-ARRAY: void*
IN: windows.com.wrapper
TUPLE: com-wrapper < disposable callbacks vtbls ;
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 classes.struct ;
+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
DIOBJECTDATAFORMAT <struct-boa> ;
:: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien )
- [let | alien [ array length DIOBJECTDATAFORMAT malloc-struct-array ] |
+ [let | alien [ array length malloc-DIOBJECTDATAFORMAT-array ] |
array [| args i |
struct args <DIOBJECTDATAFORMAT>
i alien set-nth
USING: kernel tools.test windows.ole32 alien.c-types
-classes.struct specialized-arrays.uchar windows.kernel32
+classes.struct specialized-arrays windows.kernel32
windows.com.syntax ;
+SPECIALIZED-ARRAY: uchar
IN: windows.ole32.tests
[ t ] [
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.uchar
-literals splitting grouping classes.struct combinators.smart ;
+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
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.ushort ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: ushort
IN: windows.shell32
CONSTANT: CSIDL_DESKTOP HEX: 00
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings classes.struct
io.encodings.utf8 kernel namespaces sequences
-specialized-arrays.int x11 x11.constants x11.xlib ;
+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
!
! 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
! 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
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
[ [ "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 ;
-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 } ;
")" %
] "" 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 ;
[ [ [ "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' )
[ 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
+
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
] if
] if ; inline
+M: float unordered? [ fp-nan? ] bi@ or ; inline
+
M: float prev-float ( m -- n )
double>bits
dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
MATH: <= ( x y -- ? ) foldable
MATH: > ( x y -- ? ) foldable
MATH: >= ( x y -- ? ) foldable
+MATH: unordered? ( x y -- ? ) foldable
+
+M: object unordered? 2drop f ;
MATH: + ( x y -- z ) foldable
MATH: - ( x y -- z ) foldable
-USING: kernel math math.parser sequences tools.test ;
+USING: kernel literals math math.parser sequences tools.test ;
IN: math.parser.tests
[ f ]
[ "-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 )
+ {
+ { 10 [ dec>float ] }
+ { 16 [ hex>float ] }
+ [ "Floats can only be converted from strings in base 10 or 16" throw ]
+ } case ;
+
: number-char? ( char -- ? )
"0123456789ABCDEFabcdef." member? ;
PRIVATE>
+: string>float ( str -- n/f )
+ 10 base>float ;
+
: base> ( str radix -- n/f )
over numeric-looking? [
over [ "/." member? ] find nip {
{ CHAR: / [ string>ratio ] }
- { CHAR: . [ drop string>float ] }
+ { CHAR: . [ base>float ] }
[ drop string>integer ]
} case
] [ 2drop f ] if ;
[ ".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 )
+ {
+ { 10 [ float>decimal ] }
+ { 16 [ float>hex ] }
+ [ "Floats can only be converted to strings in base 10 or 16" throw ]
+ } 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 ;
: 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 ;
{ $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
[ 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 )
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 )
! 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
! 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 struct-arrays classes.struct ;
+combinators.smart sequences hints classes.struct
+specialized-arrays ;
IN: benchmark.nbody-simd
: solar-mass ( -- x ) 4 pi sq * ; inline
{ 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
: offset-momentum ( body offset -- body )
vneg solar-mass v/n >>velocity ; inline
-TUPLE: nbody-system { bodies struct-array read-only } ;
-
: 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> ]
- struct-array{ body } output>sequence nbody-system boa
- dup bodies>> init-bodies ; inline
+ body-array{ } output>sequence
+ dup init-bodies ; inline
:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
bodies [| body i |
[ [ other-body ] 2dip '[ body mass>> _ * _ n*v v+ ] change-velocity drop ] 2bi ; inline
: advance ( system dt -- )
- [ bodies>> ] dip
[ '[ _ update-velocity ] [ drop ] each-pair ]
[ '[ _ update-position ] each ]
2bi ; inline
[ [ mass>> ] bi@ * ] [ [ location>> ] bi@ distance ] 2bi / ; inline
: energy ( system -- x )
- [ 0.0 ] dip bodies>> [ newton's-law - ] [ inertia + ] each-pair ; inline
+ [ 0.0 ] dip [ newton's-law - ] [ inertia + ] each-pair ; inline
: nbody ( n -- )
>fixnum
! 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
+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
--- /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 ( -- )
+ 5000000 simd-benchmark ;
+
+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 )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes.struct combinators.smart fry kernel
math math.functions math.order math.parser sequences
-struct-arrays io ;
+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
1 + ; inline
: make-points ( len -- points )
- point <struct-array> dup 0 [ init-point ] reduce drop ; inline
+ <point-array> dup 0 [ init-point ] reduce drop ; inline
: point-norm ( point -- norm )
[ xyz [ absq ] tri@ ] sum-outputs sqrt ; inline
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 )
! (c)2009 Joe Groff bsd license
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 specialized-arrays.float specialized-vectors.uint
-splitting struct-vectors threads ui ui.gadgets ui.gadgets.worlds
-ui.pixel-formats ;
+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 }
] when* ;
: parse-bunny-model ( -- vertexes indexes )
- 100000 bunny-vertex-struct <struct-vector>
+ 100000 <bunny-vertex-struct-vector>
100000 <uint-vector>
(parse-bunny-model) ;
--- /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>
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: 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
+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
! (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.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
-
>>
! 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 ;
! Copyright (C) 2009 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors grouping sequences combinators math
-byte-arrays fry specialized-arrays.uint specialized-arrays.ushort
-specialized-arrays.float images half-floats ;
+byte-arrays fry images half-floats specialized-arrays ;
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: ushort
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: half
IN: images.normalization
<PRIVATE
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
! (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" {
! 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] [
+ 2500 [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
-
SOLUTION: euler044
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 ;
! 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 ;
! 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
-specialized-arrays.char ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: char
IN: system-info.linux
: (uname) ( buf -- int )
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.ushort ;
+alien.strings windows.errors specialized-arrays ;
+SPECIALIZED-ARRAY: ushort
IN: system-info.windows
: system-info ( -- SYSTEM_INFO )
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. ;
+
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.
+ :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"].
+
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
+
+command! -nargs=1 -complete=customlist,FactorCompleteVocab FactorVocab :call GoToFactorVocab("<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)
+ let vocabpath = substitute(a:vocab, "\\.", "/", "g")
+ let vocabfile = FactorVocabRoot(a:root) . vocabpath . "/" . fnamemodify(vocabpath, ":t") . ".factor"
+
+ if getftype(vocabfile) != ""
+ return vocabfile
+ else
+ return ""
+ endif
+endfunction
+
+function! GoToFactorVocab(vocab)
+ for root in g:FactorVocabRoots
+ let vocabfile = FactorVocabFile(root, a:vocab)
+ if vocabfile != ""
+ exe "edit " fnameescape(vocabfile)
+ return
+ endif
+ endfor
+ echo "Vocabulary " vocab " not found"
+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
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
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: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"
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
+void fp_trap_error()
+{
+ general_error(ERROR_FP_TRAP,F,F,NULL);
+}
+
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();
+}
+
}
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();
PRIMITIVE(call_clear);
PRIMITIVE(unimplemented);
extern stack_frame *signal_callstack_top;
void memory_signal_handler_impl();
+void fp_signal_handler_impl();
void misc_signal_handler_impl();
}
~gc_root() {
#ifdef FACTOR_DEBUG
assert(gc_locals.back() == (cell)this);
-#else
- gc_locals.pop_back();
#endif
+ gc_locals.pop_back();
}
};
/* 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)
{
signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state);
MACH_PROGRAM_COUNTER(thread_state) = (cell)memory_signal_handler_impl;
}
- else
- {
- if(exception == EXC_ARITHMETIC)
- signal_number = SIGFPE;
- else
- signal_number = SIGABRT;
+ else if(exception == EXC_ARITHMETIC && code != MACH_EXC_INTEGER_DIV)
+ {
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)fp_signal_handler_impl;
+ }
+ else
+ {
+ signal_number = exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT;
MACH_PROGRAM_COUNTER(thread_state) = (cell)misc_signal_handler_impl;
}
}
/* 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);
/* Set the faulting thread's register contents..
#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_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_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
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);
+ 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);
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;
- }
+ break;
+
+ case EXCEPTION_FLT_DENORMAL_OPERAND:
+ case EXCEPTION_FLT_DIVIDE_BY_ZERO:
+ case EXCEPTION_FLT_INEXACT_RESULT:
+ case EXCEPTION_FLT_INVALID_OPERATION:
+ case EXCEPTION_FLT_OVERFLOW:
+ case EXCEPTION_FLT_STACK_CHECK:
+ case EXCEPTION_FLT_UNDERFLOW:
+ c->EIP = (cell)fp_signal_handler_impl;
+ break;
+
/* 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)
- {
+ 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. */
+ case 0x40010006:
+ break;
+
+ default:
signal_number = e->ExceptionCode;
c->EIP = (cell)misc_signal_handler_impl;
- }
-
- return EXCEPTION_CONTINUE_EXECUTION;
+ break;
+ }
+ return EXCEPTION_CONTINUE_EXECUTION;
}
void c_to_factor_toplevel(cell quot)
projects / factor.git / commitdiff