$nl\r
"C type specifiers for array types are documented in " { $link "c-types-specs" } "."\r
$nl\r
-"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets. They can also be loaded and constructed through their primitive C types:"\r
-{ $subsection require-c-arrays }\r
+"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " vocabulary set. They can also be loaded and constructed through their primitive C types:"\r
+{ $subsection require-c-array }\r
{ $subsection <c-array> }\r
{ $subsection <c-direct-array> } ;\r
M: array c-type-boxer-quot
unclip
[ array-length ]
- [ [ require-c-arrays ] keep ] bi*
+ [ [ require-c-array ] keep ] bi*
[ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
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-arrays } " 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, 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." }
{ $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 direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." }
+{ $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." }
{ $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-arrays
+HELP: require-c-array
{ $values { "c-type" "a C type" } }
-{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
-{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets for details on the underlying sequence types loaded." } ;
+{ $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." } ;
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 direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ;
+{ $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." } ;
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."
array-class
array-constructor
(array)-constructor
-direct-array-class
-direct-array-constructor
-sequence-mixin-class ;
+direct-array-constructor ;
TUPLE: c-type < abstract-c-type
boxer
M: abstract-c-type heap-size size>> ;
-GENERIC: require-c-arrays ( c-type -- )
+GENERIC: require-c-array ( c-type -- )
-M: object require-c-arrays
+M: object require-c-array
drop ;
-M: c-type require-c-arrays
- [ array-class>> ?require-word ]
- [ sequence-mixin-class>> ?require-word ]
- [ direct-array-class>> ?require-word ] tri ;
+M: c-type require-c-array
+ array-class>> ?require-word ;
-M: string require-c-arrays
- c-type require-c-arrays ;
+M: string require-c-array
+ c-type require-c-array ;
-M: array require-c-arrays
- first c-type require-c-arrays ;
+M: array require-c-array
+ first c-type require-c-array ;
ERROR: specialized-array-vocab-not-loaded vocab word ;
]
[
[ "specialized-arrays." prepend ]
- [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class
- ]
- [
- [ "specialized-arrays.direct." prepend ]
- [ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class
- ]
- [
- [ "specialized-arrays.direct." prepend ]
[ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
]
} 2cleave ;
] bi append ;
M: struct make-mirror <struct-mirror> ;
+
+INSTANCE: struct-mirror assoc
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.direct.int specialized-arrays.ushort
+specialized-arrays.int specialized-arrays.ushort
struct-arrays system tools.test ;
IN: classes.struct.tests
[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+[ t ] [
+ [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
+ { x>> } inlined?
+] unit-test
+
! Test cloning structs
STRUCT: clone-test-struct { x int } { y char[3] } ;
: struct-that's-a-word ( -- ) "OOPS" throw ;
[ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
+
alien.structs.fields arrays byte-arrays classes classes.parser
classes.tuple classes.tuple.parser classes.tuple.private
combinators combinators.short-circuit combinators.smart
-functors.backend fry generalizations generic.parser kernel
-kernel.private lexer libc locals macros make math math.order parser
-quotations sequences slots slots.private struct-arrays vectors
-words compiler.tree.propagation.transforms specialized-arrays.direct.uchar ;
+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 ;
FROM: slots => reader-word writer-word ;
IN: classes.struct
TUPLE: struct-slot-spec < slot-spec
c-type ;
-PREDICATE: struct-class < tuple-class
- { [ \ struct subclass-of? ] [ all-slots length 1 = ] } 1&& ;
+PREDICATE: struct-class < tuple-class \ struct subclass-of? ;
: struct-slots ( struct-class -- slots )
"struct-slots" word-prop ;
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
: memory>struct ( ptr class -- struct )
- [ 1array ] dip slots>tuple ;
-
-\ memory>struct [
- dup struct-class? [ '[ _ boa ] ] [ drop f ] if
-] 1 define-partial-eval
+ ! This is sub-optimal if the class is not literal, but gets
+ ! optimized down to efficient code if it is.
+ '[ _ boa ] call( ptr -- struct ) ; inline
<PRIVATE
: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
[ \ struct-slot-values ] [ struct-slot-values-quot ] bi
define-inline-method ;
-: (define-byte-length-method) ( class -- )
- [ \ byte-length ] [ heap-size \ drop swap [ ] 2sequence ] bi
- define-inline-method ;
-
: clone-underlying ( struct -- byte-array )
[ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
M: struct-class heap-size
"struct-size" word-prop ;
+M: struct byte-length
+ class "struct-size" word-prop ; foldable
+
! class definition
<PRIVATE
: (struct-methods) ( class -- )
[ (define-struct-slot-values-method) ]
- [ (define-byte-length-method) ]
[ (define-clone-method) ]
- tri ;
+ bi ;
: (struct-word-props) ( class slots size align -- )
[
: check-struct-slots ( slots -- )
[ c-type>> c-type drop ] each ;
+: redefine-struct-tuple-class ( class -- )
+ [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
+
: (define-struct-class) ( class slots offsets-quot -- )
[
[ struct-must-have-slots ]
- [ drop struct f define-tuple-class ] if-empty
+ [ drop redefine-struct-tuple-class ] if-empty
]
swap '[
make-slots dup
locals math sequences vectors fry libc destructors ;
IN: cocoa.enumeration
-<< "id" require-c-arrays >>
+<< "id" require-c-array >>
CONSTANT: NS-EACH-BUFFER-SIZE 16
stack-checker kernel math namespaces make quotations sequences
strings words cocoa.runtime io macros memoize io.encodings.utf8
effects libc libc.private lexer init core-foundation fry
-generalizations specialized-arrays.direct.alien ;
+generalizations specialized-arrays.alien ;
IN: cocoa.messages
: make-sender ( method function -- quot )
USING: assocs math.order sequences ;
IN: compiler.cfg.comparisons
-SYMBOLS: cc< cc<= cc= cc> cc>= cc/= ;
+SYMBOL: +unordered+
+
+SYMBOLS:
+ cc< cc<= cc= cc> cc>= cc<> cc<>=
+ cc/< cc/<= cc/= cc/> cc/>= cc/<> cc/<>= ;
: negate-cc ( cc -- cc' )
H{
- { cc< cc>= }
- { cc<= cc> }
- { cc> cc<= }
- { cc>= cc< }
- { cc= cc/= }
- { cc/= cc= }
+ { cc< cc/< }
+ { cc<= cc/<= }
+ { cc> cc/> }
+ { cc>= cc/>= }
+ { cc= cc/= }
+ { cc<> cc/<> }
+ { cc<>= cc/<>= }
+ { cc/< cc< }
+ { cc/<= cc<= }
+ { cc/> cc> }
+ { cc/>= cc>= }
+ { cc/= cc= }
+ { cc/<> cc<> }
+ { cc/<>= cc<>= }
} at ;
: swap-cc ( cc -- cc' )
H{
- { cc< cc> }
- { cc<= cc>= }
- { cc> cc< }
- { cc>= cc<= }
- { cc= cc= }
- { cc/= cc/= }
+ { cc< cc> }
+ { cc<= cc>= }
+ { cc> cc< }
+ { cc>= cc<= }
+ { cc= cc= }
+ { cc<> cc<> }
+ { cc<>= cc<>= }
+ { cc/< cc/> }
+ { cc/<= cc/>= }
+ { cc/> cc/< }
+ { cc/>= cc/<= }
+ { cc/= cc/= }
+ { cc/<> cc/<> }
+ { cc/<>= cc/<>= }
+ } at ;
+
+: order-cc ( cc -- cc' )
+ H{
+ { cc< cc< }
+ { cc<= cc<= }
+ { cc> cc> }
+ { cc>= cc>= }
+ { cc= cc= }
+ { cc<> cc/= }
+ { cc<>= t }
+ { cc/< cc>= }
+ { cc/<= cc> }
+ { cc/> cc<= }
+ { cc/>= cc< }
+ { cc/= cc/= }
+ { cc/<> cc= }
+ { cc/<>= f }
} at ;
: evaluate-cc ( result cc -- ? )
H{
- { cc< { +lt+ } }
- { cc<= { +lt+ +eq+ } }
- { cc= { +eq+ } }
- { cc>= { +eq+ +gt+ } }
- { cc> { +gt+ } }
- { cc/= { +lt+ +gt+ } }
- } at memq? ;
\ No newline at end of file
+ { cc< { +lt+ } }
+ { cc<= { +lt+ +eq+ } }
+ { cc= { +eq+ } }
+ { cc>= { +eq+ +gt+ } }
+ { cc> { +gt+ } }
+ { cc<> { +lt+ +gt+ } }
+ { cc<>= { +lt+ +eq+ +gt+ } }
+ { cc/< { +eq+ +gt+ +unordered+ } }
+ { cc/<= { +gt+ +unordered+ } }
+ { cc/= { +lt+ +gt+ +unordered+ } }
+ { cc/>= { +lt+ +unordered+ } }
+ { cc/> { +lt+ +eq+ +unordered+ } }
+ { cc/<> { +eq+ +unordered+ } }
+ { cc/<>= { +unordered+ } }
+ } at memq? ;
+
T{ ##load-reference f 1 + }
T{ ##peek f 2 D 0 }
T{ ##compare f 4 2 1 cc<= }
- T{ ##compare f 6 2 1 cc> }
+ T{ ##compare f 6 2 1 cc/<= }
T{ ##replace f 6 D 0 }
}
] [
T{ ##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 f 14 10 11 cc/< }
T{ ##replace f 14 D 0 }
}
] [
[ t ] [ [ 2 '[ _ ] 1 '[ _ + ] compose ] final-info first infer-value (( -- object )) effect= ] unit-test
[ t ] [ [ 2 '[ _ + ] ] final-info first infer-value (( object -- object )) effect= ] unit-test
[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
-[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
+[ t ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value (( -- object )) effect= ] unit-test
[ f ] [ [ dup drop ] final-info first infer-value ] unit-test
! This should not hang
[ ] [ [ [ dup call( quot -- ) ] dup call( quot -- ) ] final-info drop ] unit-test
-[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
\ No newline at end of file
+[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
+
+! This should get inlined, because the parameter to the curry is literal even though
+! [ boa ] by itself doesn't infer
+TUPLE: a-tuple x ;
+
+[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test
\ No newline at end of file
M: compose cached-effect
[ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
+: safe-infer ( quot -- effect )
+ [ infer ] [ 2drop +unknown+ ] recover ;
+
M: quotation cached-effect
dup cached-effect>>
- [ ] [
- [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
- (>>cached-effect)
- ] ?if ;
+ [ ] [ [ safe-infer dup ] keep (>>cached-effect) ] ?if ;
: call-effect-unsafe? ( quot effect -- ? )
[ cached-effect ] dip
: execute-effect>quot ( effect -- quot )
inline-cache new '[ drop _ _ execute-effect-ic ] ;
+! Some bookkeeping to make sure that crap like
+! [ dup curry call( quot -- ) ] dup curry call( quot -- ) ]
+! doesn't hang the compiler.
+GENERIC: already-inlined-quot? ( quot -- ? )
+
+M: curry already-inlined-quot? quot>> already-inlined-quot? ;
+
+M: compose already-inlined-quot?
+ [ first>> already-inlined-quot? ]
+ [ second>> already-inlined-quot? ] bi or ;
+
+M: quotation already-inlined-quot? already-inlined? ;
+
+GENERIC: add-quot-to-history ( quot -- )
+
+M: curry add-quot-to-history quot>> add-quot-to-history ;
+
+M: compose add-quot-to-history
+ [ first>> add-quot-to-history ]
+ [ second>> add-quot-to-history ] bi ;
+
+M: quotation add-quot-to-history add-to-history ;
+
: last2 ( seq -- penultimate ultimate )
2 tail* first2 ;
(( -- object )) swap compose-effects ;
: (infer-value) ( value-info -- effect )
- dup class>> {
- { \ quotation [
- literal>> [ uninferable ] unless*
- dup already-inlined? [ uninferable ] when
- cached-effect dup +unknown+ = [ uninferable ] when
- ] }
- { \ curry [
- slots>> third (infer-value)
- remove-effect-input
- ] }
- { \ compose [
- slots>> last2 [ (infer-value) ] bi@
- compose-effects
- ] }
- [ uninferable ]
- } case ;
+ dup literal?>> [
+ literal>>
+ [ callable? [ uninferable ] unless ]
+ [ already-inlined-quot? [ uninferable ] when ]
+ [ safe-infer dup +unknown+ = [ uninferable ] when ] tri
+ ] [
+ dup class>> {
+ { \ curry [ slots>> third (infer-value) remove-effect-input ] }
+ { \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
+ [ uninferable ]
+ } case
+ ] if ;
: infer-value ( value-info -- effect/f )
[ (infer-value) ]
recover ;
: (value>quot) ( value-info -- quot )
- dup class>> {
- { \ quotation [ literal>> dup add-to-history '[ drop @ ] ] }
- { \ curry [
- slots>> third (value>quot)
- '[ [ obj>> ] [ quot>> @ ] bi ]
- ] }
- { \ compose [
- slots>> last2 [ (value>quot) ] bi@
- '[ [ first>> @ ] [ second>> @ ] bi ]
- ] }
- } case ;
+ dup literal?>> [
+ literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
+ ] [
+ dup class>> {
+ { \ curry [
+ slots>> third (value>quot)
+ '[ [ obj>> ] [ quot>> @ ] bi ]
+ ] }
+ { \ compose [
+ slots>> last2 [ (value>quot) ] bi@
+ '[ [ first>> @ ] [ second>> @ ] bi ]
+ ] }
+ } case
+ ] if ;
: value>quot ( value-info -- quot: ( code effect -- ) )
(value>quot) '[ drop @ ] ;
:: inline-word ( #call word -- ? )
word already-inlined? [ f ] [
#call word splicing-body [
- [
- word add-to-history
- dup (propagate)
- ] with-scope
- #call (>>body) t
+ word add-to-history
+ #call (>>body)
+ #call propagate-body
] [ f ] if*
] if ;
#! Note the logic here: if there's a custom inlining hook,
#! it is permitted to return f, which means that we try the
#! normal inlining heuristic.
- dup custom-inlining? [ 2dup inline-custom ] [ f ] if
- [ 2drop t ] [ (do-inlining) ] if ;
+ [
+ dup custom-inlining? [ 2dup inline-custom ] [ f ] if
+ [ 2drop t ] [ (do-inlining) ] if
+ ] with-scope ;
[ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
first simple-alien class=
] unit-test
+
+! Don't crash if bad literal inputs are passed to unsafe words
+[ f ] [ [ { } 1 fixnum+fast ] final-info first literal?>> ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors kernel sequences sequences.private assocs words
-namespaces classes.algebra combinators classes classes.tuple
-classes.tuple.private continuations arrays alien.c-types
-math math.private slots generic definitions
-stack-checker.state
+USING: fry accessors kernel sequences sequences.private assocs
+words namespaces classes.algebra combinators
+combinators.short-circuit classes classes.tuple
+classes.tuple.private continuations arrays alien.c-types math
+math.private slots generic definitions stack-checker.state
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.nodes
[ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi*
with-datastack ;
+: literal-inputs? ( #call -- ? )
+ in-d>> [ value-info literal?>> ] all? ;
+
+: input-classes-match? ( #call word -- ? )
+ [ in-d>> ] [ "input-classes" word-prop ] bi*
+ [ [ value-info literal>> ] dip instance? ] 2all? ;
+
: foldable-call? ( #call word -- ? )
- "foldable" word-prop
- [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
+ {
+ [ nip "foldable" word-prop ]
+ [ drop literal-inputs? ]
+ [ input-classes-match? ]
+ } 2&& ;
: (fold-call) ( #call word -- info )
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors
continuations combinators io.encodings.utf8 destructors locals
-arrays specialized-arrays.direct.alien classes.struct
-specialized-arrays.direct.int specialized-arrays.direct.longlong
+arrays specialized-arrays.alien classes.struct
+specialized-arrays.int specialized-arrays.longlong
core-foundation core-foundation.run-loop core-foundation.strings
core-foundation.time ;
IN: core-foundation.fsevents
[ [ 1 1 ] dip ADDI ] bi
0 MTLR ;
-:: (%boolean) ( dst temp word -- )
+:: (%boolean) ( dst temp branch1 branch2 -- )
"end" define-label
dst \ f tag-number %load-immediate
- "end" get word execute
+ "end" get branch1 execute( label -- )
+ branch2 [ "end" get branch2 execute( label -- ) ] when
dst \ t %load-reference
"end" get resolve-label ; inline
-: %boolean ( dst cc temp -- )
- swap negate-cc {
- { cc< [ \ BLT (%boolean) ] }
- { cc<= [ \ BLE (%boolean) ] }
- { cc> [ \ BGT (%boolean) ] }
- { cc>= [ \ BGE (%boolean) ] }
- { cc= [ \ BEQ (%boolean) ] }
- { cc/= [ \ BNE (%boolean) ] }
+:: %boolean ( dst cc temp -- )
+ cc negate-cc order-cc {
+ { cc< [ dst temp \ BLT f (%boolean) ] }
+ { cc<= [ dst temp \ BLE f (%boolean) ] }
+ { cc> [ dst temp \ BGT f (%boolean) ] }
+ { cc>= [ dst temp \ BGE f (%boolean) ] }
+ { cc= [ dst temp \ BEQ f (%boolean) ] }
+ { cc/= [ dst temp \ BNE f (%boolean) ] }
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
: (%compare-imm) ( src1 src2 -- ) [ 0 ] 2dip CMPI ; inline
-: (%compare-float) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
+: (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
+: (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
+
+:: (%compare-float) ( src1 src2 cc -- 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 ] }
+ } case ; inline
M: ppc %compare [ (%compare) ] 2dip %boolean ;
+
M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
-M: ppc %compare-float [ (%compare-float) ] 2dip %boolean ;
-: %branch ( label cc -- )
- {
- { cc< [ BLT ] }
- { cc<= [ BLE ] }
- { cc> [ BGT ] }
- { cc>= [ BGE ] }
- { cc= [ BEQ ] }
- { cc/= [ BNE ] }
+M:: ppc %compare-float ( dst src1 src2 cc temp -- )
+ cc negate-cc src1 src2 (%compare-float) :> branch2 :> branch1
+ dst temp branch1 branch2 (%boolean) ;
+
+:: %branch ( label cc -- )
+ cc order-cc {
+ { cc< [ label BLT ] }
+ { cc<= [ label BLE ] }
+ { cc> [ label BGT ] }
+ { cc>= [ label BGE ] }
+ { cc= [ label BEQ ] }
+ { cc/= [ label BNE ] }
} case ;
M: ppc %compare-branch [ (%compare) ] 2dip %branch ;
+
M: ppc %compare-imm-branch [ (%compare-imm) ] 2dip %branch ;
-M: ppc %compare-float-branch [ (%compare-float) ] 2dip %branch ;
+
+M:: ppc %compare-float-branch ( label src1 src2 cc -- )
+ cc src1 src2 (%compare-float) :> branch2 :> branch1
+ label branch1 execute( label -- )
+ branch2 [ label branch2 execute( label -- ) ] when ;
: load-from-frame ( dst n rep -- )
{
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
dst temp word execute ; inline
M: x86 %compare ( dst src1 src2 cc temp -- )
- [ CMP ] 2dip swap {
- { cc< [ \ CMOVL %boolean ] }
- { cc<= [ \ CMOVLE %boolean ] }
- { cc> [ \ CMOVG %boolean ] }
- { cc>= [ \ CMOVGE %boolean ] }
- { cc= [ \ CMOVE %boolean ] }
- { cc/= [ \ CMOVNE %boolean ] }
+ src1 src2 CMP
+ cc order-cc {
+ { cc< [ dst temp \ CMOVL %boolean ] }
+ { cc<= [ dst temp \ CMOVLE %boolean ] }
+ { cc> [ dst temp \ CMOVG %boolean ] }
+ { cc>= [ dst temp \ CMOVGE %boolean ] }
+ { cc= [ dst temp \ CMOVE %boolean ] }
+ { cc/= [ dst temp \ CMOVNE %boolean ] }
} case ;
M: x86 %compare-imm ( dst src1 src2 cc temp -- )
%compare ;
-M: x86 %compare-float ( dst src1 src2 cc temp -- )
- [ UCOMISD ] 2dip swap {
- { cc< [ \ CMOVB %boolean ] }
- { cc<= [ \ CMOVBE %boolean ] }
- { cc> [ \ CMOVA %boolean ] }
- { cc>= [ \ CMOVAE %boolean ] }
- { cc= [ \ CMOVE %boolean ] }
- { cc/= [ \ CMOVNE %boolean ] }
+: %cmov-float= ( dst src -- )
+ [
+ "no-move" define-label
+
+ "no-move" get [ JNE ] [ JP ] bi
+ MOV
+ "no-move" resolve-label
+ ] with-scope ;
+
+: %cmov-float/= ( dst src -- )
+ [
+ "no-move" define-label
+ "move" define-label
+
+ "move" get JP
+ "no-move" get JE
+ "move" resolve-label
+ MOV
+ "no-move" resolve-label
+ ] with-scope ;
+
+M:: x86 %compare-float ( dst src1 src2 cc temp -- )
+ 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 ;
-M: x86 %compare-branch ( label src1 src2 cc -- )
- [ CMP ] dip {
- { cc< [ JL ] }
- { cc<= [ JLE ] }
- { cc> [ JG ] }
- { cc>= [ JGE ] }
- { cc= [ JE ] }
- { cc/= [ JNE ] }
+M:: x86 %compare-branch ( label src1 src2 cc -- )
+ src1 src2 CMP
+ cc order-cc {
+ { cc< [ label JL ] }
+ { cc<= [ label JLE ] }
+ { cc> [ label JG ] }
+ { cc>= [ label JGE ] }
+ { cc= [ label JE ] }
+ { cc/= [ label JNE ] }
} case ;
M: x86 %compare-imm-branch ( label src1 src2 cc -- )
%compare-branch ;
-M: x86 %compare-float-branch ( label src1 src2 cc -- )
- [ UCOMISD ] dip {
- { cc< [ JB ] }
- { cc<= [ JBE ] }
- { cc> [ JA ] }
- { cc>= [ JAE ] }
- { cc= [ JE ] }
- { cc/= [ JNE ] }
+: %jump-float= ( label -- )
+ [
+ "no-jump" define-label
+ "no-jump" get JP
+ JE
+ "no-jump" resolve-label
+ ] with-scope ;
+
+: %jump-float/= ( label -- )
+ [ JNE ] [ JP ] bi ;
+
+M:: x86 %compare-float-branch ( label src1 src2 cc -- )
+ 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 ] }
} case ;
M:: x86 %spill ( src rep n -- )
io.encodings io ;
IN: environment.winnt
-<< "TCHAR" require-c-arrays >>
+<< "TCHAR" require-c-array >>
M: winnt os-env ( key -- value )
MAX_UNICODE_PATH "TCHAR" <c-array>
io.streams.c io.streams.null libc kernel math namespaces sequences
threads windows windows.errors windows.kernel32 strings splitting
ascii system accessors locals classes.struct combinators.short-circuit ;
-QUALIFIED: windows.winsock
IN: io.backend.windows.nt
! Global variable with assoc mapping overlapped to threads
C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext )
- "OVERLAPPED" malloc-object &free ;
+ OVERLAPPED malloc-struct &free ;
: make-overlapped ( port -- overlapped-ext )
[ (make-overlapped) ] dip
- handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
+ handle>> ptr>> [ >>offset ] when* ;
M: winnt FileArgs-overlapped ( port -- overlapped )
make-overlapped ;
: twiddle-thumbs ( overlapped port -- bytes-transferred )
[
drop
- [ pending-overlapped get-global set-at ] curry "I/O" suspend
+ [ >c-ptr pending-overlapped get-global set-at ] curry "I/O" suspend
{
{ [ dup integer? ] [ ] }
{ [ dup array? ] [
f <void*> [ ! overlapped
us [ 1000 /i ] [ INFINITE ] if* ! timeout
GetQueuedCompletionStatus zero?
- ] keep *void*
+ ] keep
+ *void* dup [ OVERLAPPED memory>struct ] when
] keep *int spin ;
: resume-callback ( result overlapped -- )
- pending-overlapped get-global delete-at* drop resume-with ;
+ >c-ptr pending-overlapped get-global delete-at* drop resume-with ;
: handle-overlapped ( us -- ? )
wait-for-overlapped [
M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global
- H{ } clone pending-overlapped set-global
- windows.winsock:init-winsock ;
+ H{ } clone pending-overlapped set-global ;
ERROR: invalid-file-size n ;
\r
: make-token-privileges ( name ? -- obj )\r
"TOKEN_PRIVILEGES" <c-object>\r
- 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep\r
- "LUID_AND_ATTRIBUTES" malloc-array &free\r
+ 1 over set-TOKEN_PRIVILEGES-PrivilegeCount\r
+ "LUID_AND_ATTRIBUTES" malloc-object &free\r
over set-TOKEN_PRIVILEGES-Privileges\r
\r
swap [\r
USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.ports io.binary io.timeouts system
strings kernel math namespaces sequences windows.errors
-windows.kernel32 windows.shell32 windows.types windows.winsock
-splitting continuations math.bitwise accessors init sets assocs
+windows.kernel32 windows.shell32 windows.types splitting
+continuations math.bitwise accessors init sets assocs
classes.struct classes ;
IN: io.backend.windows
: default-security-attributes ( -- obj )
SECURITY_ATTRIBUTES <struct>
- dup class heap-size >>nLength ;
+ SECURITY_ATTRIBUTES heap-size >>nLength ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings combinators
grouping io.encodings.utf8 io.files kernel math sequences
-system unix io.files.unix specialized-arrays.direct.uint arrays
+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 ;
IN: io.files.info.unix.macosx
console-vm "-run=listener" 2array >>command
+closed+ >>stdin
+stdout+ >>stderr
- ascii [ contents ] with-process-reader
+ ascii [ lines last ] with-process-reader
] unit-test
: launcher-test-path ( -- str )
[ "( scratchpad ) " ] [
console-vm "-run=listener" 2array
- ascii [ "USE: system 0 exit" print flush readln ] with-process-stream
+ ascii [ "USE: system 0 exit" print flush lines last ] with-process-stream
] unit-test
[ ] [
-USING: io.mmap.functor specialized-arrays.direct.alien ;
+USING: io.mmap.functor specialized-arrays.alien ;
IN: io.mmap.alien
<< "void*" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.bool ;
+USING: io.mmap.functor specialized-arrays.bool ;
IN: io.mmap.bool
<< "bool" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.char ;
+USING: io.mmap.functor specialized-arrays.char ;
IN: io.mmap.char
<< "char" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.double ;
+USING: io.mmap.functor specialized-arrays.double ;
IN: io.mmap.double
<< "double" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.float ;
+USING: io.mmap.functor specialized-arrays.float ;
IN: io.mmap.float
<< "float" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.int ;
+USING: io.mmap.functor specialized-arrays.int ;
IN: io.mmap.int
<< "int" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.long ;
+USING: io.mmap.functor specialized-arrays.long ;
IN: io.mmap.long
<< "long" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.longlong ;
+USING: io.mmap.functor specialized-arrays.longlong ;
IN: io.mmap.longlong
<< "longlong" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.short ;
+USING: io.mmap.functor specialized-arrays.short ;
IN: io.mmap.short
<< "short" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.uchar ;
+USING: io.mmap.functor specialized-arrays.uchar ;
IN: io.mmap.uchar
<< "uchar" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.uint ;
+USING: io.mmap.functor specialized-arrays.uint ;
IN: io.mmap.uint
<< "uint" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.ulong ;
+USING: io.mmap.functor specialized-arrays.ulong ;
IN: io.mmap.ulong
<< "ulong" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.ulonglong ;
+USING: io.mmap.functor specialized-arrays.ulonglong ;
IN: io.mmap.ulonglong
<< "ulonglong" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.ushort ;
+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: accessors kernel namespaces continuations
-destructors io debugger io.sockets sequences summary calendar
-delegate system vocabs.loader combinators present ;
+USING: accessors kernel namespaces continuations destructors io
+debugger io.sockets io.sockets.private sequences summary
+calendar delegate system vocabs.loader combinators present ;
IN: io.sockets.secure
SYMBOL: secure-socket-timeout
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors unix byte-arrays kernel sequences
-namespaces math math.order combinators init alien alien.c-types
+USING: accessors unix byte-arrays kernel sequences namespaces
+math math.order combinators init alien alien.c-types
alien.strings libc continuations destructors openssl
openssl.libcrypto openssl.libssl io io.files io.ports
io.backend.unix io.sockets.unix io.encodings.ascii io.buffers
-io.sockets io.sockets.secure io.sockets.secure.openssl
-io.timeouts system summary fry ;
+io.sockets io.sockets.private io.sockets.secure
+io.sockets.secure.openssl io.timeouts system summary fry ;
FROM: io.ports => shutdown ;
IN: io.sockets.secure.unix
IN: io.sockets.tests
-USING: io.sockets sequences math tools.test namespaces accessors
-kernel destructors calendar io.timeouts io.encodings.utf8 io
-concurrency.promises threads io.streams.string ;
+USING: io.sockets io.sockets.private sequences math tools.test
+namespaces accessors kernel destructors calendar io.timeouts
+io.encodings.utf8 io concurrency.promises threads
+io.streams.string ;
[ B{ 1 2 3 4 } ]
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
arrays io.encodings io.ports io.streams.duplex io.encodings.ascii
alien.strings io.binary accessors destructors classes byte-arrays
parser alien.c-types math.parser splitting grouping math assocs
-summary system vocabs.loader combinators present fry vocabs.parser ;
+summary system vocabs.loader combinators present fry vocabs.parser
+classes.struct ;
IN: io.sockets
<< {
} cond use-vocab >>
! Addressing
+<PRIVATE
+
GENERIC: protocol-family ( addrspec -- af )
GENERIC: sockaddr-size ( addrspec -- n )
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
-TUPLE: local path ;
+HOOK: sockaddr-of-family os ( alien af -- sockaddr )
-: <local> ( path -- addrspec )
- normalize-path local boa ;
+HOOK: addrspec-of-family os ( af -- addrspec )
-M: local present path>> "Unix domain socket: " prepend ;
+PRIVATE>
TUPLE: abstract-inet host port ;
M: abstract-inet present
[ host>> ":" ] [ port>> number>string ] bi 3append ;
+TUPLE: local path ;
+
+: <local> ( path -- addrspec )
+ normalize-path local boa ;
+
+M: local present path>> "Unix domain socket: " prepend ;
+
TUPLE: inet4 < abstract-inet ;
C: <inet4> inet4
M: inet4 protocol-family drop PF_INET ;
-M: inet4 sockaddr-size drop "sockaddr-in" heap-size ;
+M: inet4 sockaddr-size drop sockaddr-in heap-size ;
-M: inet4 empty-sockaddr drop "sockaddr-in" <c-object> ;
+M: inet4 empty-sockaddr drop sockaddr-in <struct> ;
M: inet4 make-sockaddr ( inet -- sockaddr )
- "sockaddr-in" <c-object>
- AF_INET over set-sockaddr-in-family
- over port>> htons over set-sockaddr-in-port
- over host>>
- "0.0.0.0" or
- rot inet-pton *uint over set-sockaddr-in-addr ;
+ sockaddr-in <struct>
+ AF_INET >>family
+ swap [ port>> htons >>port ]
+ [ host>> "0.0.0.0" or ]
+ [ inet-pton *uint >>addr ] tri ;
-M: inet4 parse-sockaddr
- [ dup sockaddr-in-addr <uint> ] dip inet-ntop
- swap sockaddr-in-port ntohs <inet4> ;
+M: inet4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
+ [ [ addr>> <uint> ] dip inet-ntop ]
+ [ drop port>> ntohs ] 2bi <inet4> ;
TUPLE: inet6 < abstract-inet ;
M: inet6 protocol-family drop PF_INET6 ;
-M: inet6 sockaddr-size drop "sockaddr-in6" heap-size ;
+M: inet6 sockaddr-size drop sockaddr-in6 heap-size ;
-M: inet6 empty-sockaddr drop "sockaddr-in6" <c-object> ;
+M: inet6 empty-sockaddr drop sockaddr-in6 <struct> ;
M: inet6 make-sockaddr ( inet -- sockaddr )
- "sockaddr-in6" <c-object>
- AF_INET6 over set-sockaddr-in6-family
- over port>> htons over set-sockaddr-in6-port
- over host>> "::" or
- rot inet-pton over set-sockaddr-in6-addr ;
+ sockaddr-in6 <struct>
+ AF_INET6 >>family
+ swap [ port>> htons >>port ]
+ [ host>> "::" or ]
+ [ inet-pton >>addr ] tri ;
M: inet6 parse-sockaddr
- [ dup sockaddr-in6-addr ] dip inet-ntop
- swap sockaddr-in6-port ntohs <inet6> ;
-
-: addrspec-of-family ( af -- addrspec )
- {
- { AF_INET [ T{ inet4 } ] }
- { AF_INET6 [ T{ inet6 } ] }
- { AF_UNIX [ T{ local } ] }
- [ drop f ]
- } case ;
+ [ [ addr>> ] dip inet-ntop ]
+ [ drop port>> ntohs ] 2bi <inet6> ;
M: f parse-sockaddr nip ;
+<PRIVATE
+
GENERIC: (get-local-address) ( handle remote -- sockaddr )
: get-local-address ( handle remote -- local )
2bi
] with-destructors ;
+TUPLE: server-port < port addr encoding ;
+
+: check-server-port ( port -- port )
+ dup check-disposed
+ dup server-port? [ "Not a server port" throw ] unless ; inline
+
+GENERIC: (server) ( addrspec -- handle )
+
+GENERIC: (accept) ( server addrspec -- handle sockaddr )
+
+TUPLE: datagram-port < port addr ;
+
+HOOK: (datagram) io-backend ( addr -- datagram )
+
+: check-datagram-port ( port -- port )
+ dup check-disposed
+ dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
+
+HOOK: (receive) io-backend ( datagram -- packet addrspec )
+
+: check-datagram-send ( packet addrspec port -- packet addrspec port )
+ check-datagram-port
+ 2dup addr>> [ class ] bi@ assert=
+ pick class byte-array assert= ;
+
+HOOK: (send) io-backend ( packet addrspec datagram -- )
+
+: addrinfo>addrspec ( addrinfo -- addrspec )
+ [ [ addr>> ] [ family>> ] bi sockaddr-of-family ]
+ [ family>> addrspec-of-family ] bi
+ parse-sockaddr ;
+
+: parse-addrinfo-list ( addrinfo -- seq )
+ [ next>> dup [ addrinfo memory>struct ] when ] follow
+ [ addrinfo>addrspec ] map
+ sift ;
+
+HOOK: addrinfo-error io-backend ( n -- )
+
+: resolve-passive-host ( -- addrspecs )
+ { T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ;
+
+: prepare-addrinfo ( -- addrinfo )
+ addrinfo <struct>
+ PF_UNSPEC >>family
+ IPPROTO_TCP >>protocol ;
+
+: fill-in-ports ( addrspecs port -- addrspecs )
+ '[ _ >>port ] map ;
+
+PRIVATE>
+
: <client> ( remote encoding -- stream local )
[ (client) ] dip swap [ <encoder-duplex> ] dip ;
] dip with-stream
] with-scope ; inline
-TUPLE: server-port < port addr encoding ;
-
-: check-server-port ( port -- port )
- dup check-disposed
- dup server-port? [ "Not a server port" throw ] unless ; inline
-
-GENERIC: (server) ( addrspec -- handle )
-
: <server> ( addrspec encoding -- server )
[
[ (server) ] keep
>>addr
] dip >>encoding ;
-GENERIC: (accept) ( server addrspec -- handle sockaddr )
-
: accept ( server -- client remote )
[
dup addr>>
<ports>
] keep encoding>> <encoder-duplex> swap ;
-TUPLE: datagram-port < port addr ;
-
-HOOK: (datagram) io-backend ( addr -- datagram )
-
: <datagram> ( addrspec -- datagram )
[
[ (datagram) |dispose ] keep
>>addr
] with-destructors ;
-: check-datagram-port ( port -- port )
- dup check-disposed
- dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
-
-HOOK: (receive) io-backend ( datagram -- packet addrspec )
-
: receive ( datagram -- packet addrspec )
check-datagram-port
[ (receive) ] [ addr>> ] bi parse-sockaddr ;
-: check-datagram-send ( packet addrspec port -- packet addrspec port )
- check-datagram-port
- 2dup addr>> [ class ] bi@ assert=
- pick class byte-array assert= ;
-
-HOOK: (send) io-backend ( packet addrspec datagram -- )
-
: send ( packet addrspec datagram -- )
check-datagram-send (send) ;
-: addrinfo>addrspec ( addrinfo -- addrspec )
- [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi
- parse-sockaddr ;
-
-: parse-addrinfo-list ( addrinfo -- seq )
- [ addrinfo-next ] follow
- [ addrinfo>addrspec ] map
- sift ;
-
-HOOK: addrinfo-error io-backend ( n -- )
-
GENERIC: resolve-host ( addrspec -- seq )
TUPLE: inet < abstract-inet ;
C: <inet> inet
-: resolve-passive-host ( -- addrspecs )
- { T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ;
-
-: prepare-addrinfo ( -- addrinfo )
- "addrinfo" <c-object>
- PF_UNSPEC over set-addrinfo-family
- IPPROTO_TCP over set-addrinfo-protocol ;
-
-: fill-in-ports ( addrspecs port -- addrspecs )
- '[ _ >>port ] map ;
-
M: inet resolve-host
[ port>> ] [ host>> ] bi [
f prepare-addrinfo f <void*>
- [ getaddrinfo addrinfo-error ] keep *void*
+ [ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct
[ parse-addrinfo-list ] keep freeaddrinfo
] [ resolve-passive-host ] if*
swap fill-in-ports ;
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings generic kernel math threads
-sequences byte-arrays io.binary io.backend.unix io.streams.duplex
-io.backend io.pathnames io.files.private io.encodings.utf8 math.parser
-continuations libc combinators system accessors destructors unix
-locals init ;
+USING: alien alien.c-types alien.strings generic kernel math
+threads sequences byte-arrays io.binary io.backend.unix
+io.streams.duplex io.backend io.pathnames io.sockets.private
+io.files.private io.encodings.utf8 math.parser continuations
+libc combinators system accessors destructors unix locals init
+classes.struct ;
EXCLUDE: namespaces => bind ;
EXCLUDE: io => read write ;
M: unix addrinfo-error ( n -- )
[ gai_strerror throw ] unless-zero ;
+M: unix sockaddr-of-family ( alien af -- addrspec )
+ {
+ { AF_INET [ sockaddr-in memory>struct ] }
+ { AF_INET6 [ sockaddr-in6 memory>struct ] }
+ { AF_UNIX [ sockaddr-un memory>struct ] }
+ [ 2drop f ]
+ } case ;
+
+M: unix addrspec-of-family ( af -- addrspec )
+ {
+ { AF_INET [ T{ inet4 } ] }
+ { AF_INET6 [ T{ inet6 } ] }
+ { AF_UNIX [ T{ local } ] }
+ [ drop f ]
+ } case ;
+
! Client sockets - TCP and Unix domain
M: object (get-local-address) ( handle remote -- sockaddr )
[ handle-fd ] dip empty-sockaddr/size <int>
[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-init-hook
:: do-receive ( port -- packet sockaddr )
- port addr>> empty-sockaddr/size [| sockaddr len |
- port handle>> handle-fd ! s
- receive-buffer get-global ! buf
- packet-size ! nbytes
- 0 ! flags
- sockaddr ! from
- len <int> ! fromlen
- recvfrom dup 0 >= [
- receive-buffer get-global swap memory>byte-array sockaddr
- ] [
- drop f f
- ] if
- ] call ;
+ port addr>> empty-sockaddr/size :> len :> sockaddr
+ port handle>> handle-fd ! s
+ receive-buffer get-global ! buf
+ packet-size ! nbytes
+ 0 ! flags
+ sockaddr ! from
+ len <int> ! fromlen
+ recvfrom dup 0 >=
+ [ receive-buffer get-global swap memory>byte-array sockaddr ]
+ [ drop f f ]
+ if ;
M: unix (receive) ( datagram -- packet sockaddr )
dup do-receive dup [ [ drop ] 2dip ] [
! Unix domain sockets
M: local protocol-family drop PF_UNIX ;
-M: local sockaddr-size drop "sockaddr-un" heap-size ;
+M: local sockaddr-size drop sockaddr-un heap-size ;
-M: local empty-sockaddr drop "sockaddr-un" <c-object> ;
+M: local empty-sockaddr drop sockaddr-un <struct> ;
M: local make-sockaddr
path>> (normalize-path)
dup length 1 + max-un-path > [ "Path too long" throw ] when
- "sockaddr-un" <c-object>
- AF_UNIX over set-sockaddr-un-family
- [ [ utf8 string>alien ] dip set-sockaddr-un-path ] keep ;
+ sockaddr-un <struct>
+ AF_UNIX >>family
+ swap utf8 string>alien >>path ;
M: local parse-sockaddr
drop
- sockaddr-un-path utf8 alien>string <local> ;
+ path>> utf8 alien>string <local> ;
USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.ports io.timeouts io.sockets
-io namespaces io.streams.duplex io.backend.windows
-io.sockets.windows io.backend.windows.nt windows.winsock kernel
-libc math sequences threads system combinators accessors
-classes.struct windows.kernel32 ;
+io.sockets.private io namespaces io.streams.duplex
+io.backend.windows io.sockets.windows io.backend.windows.nt
+windows.winsock kernel libc math sequences threads system
+combinators accessors classes.struct windows.kernel32 ;
IN: io.sockets.windows.nt
-: malloc-int ( object -- object )
- "int" heap-size malloc [ nip ] [ 0 set-alien-signed-4 ] 2bi ; inline
+: malloc-int ( n -- alien )
+ <int> malloc-byte-array ; inline
M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;
} cleave AcceptEx drop
winsock-error-string [ throw ] when* ; inline
+: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
+ f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
+
: extract-remote-address ( AcceptEx -- sockaddr )
- {
- [ lpOutputBuffer>> ]
- [ dwReceiveDataLength>> ]
- [ dwLocalAddressLength>> ]
- [ dwRemoteAddressLength>> ]
- } cleave
- f <void*>
- 0 <int>
- f <void*>
- [ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
+ [
+ {
+ [ lpOutputBuffer>> ]
+ [ dwReceiveDataLength>> ]
+ [ dwLocalAddressLength>> ]
+ [ dwRemoteAddressLength>> ]
+ } cleave
+ (extract-remote-address)
+ ] [ port>> addr>> protocol-family ] bi
+ sockaddr-of-family ; inline
M: object (accept) ( server addr -- handle sockaddr )
[
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
[ lpBuffers>> buf>> swap memory>byte-array ]
- [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
+ [
+ [ port>> addr>> empty-sockaddr dup ]
+ [ lpFrom>> ]
+ [ lpFromLen>> *int ]
+ tri memcpy
+ ] bi ; inline
M: winnt (receive) ( datagram -- packet addrspec )
[
-USING: kernel accessors io.sockets io.backend.windows io.backend\r
-windows.winsock system destructors alien.c-types ;\r
+USING: kernel accessors io.sockets io.sockets.private\r
+io.backend.windows io.backend windows.winsock system destructors\r
+alien.c-types classes.struct combinators ;\r
IN: io.sockets.windows\r
\r
+M: windows addrinfo-error ( n -- )\r
+ winsock-return-check ;\r
+\r
+M: windows sockaddr-of-family ( alien af -- addrspec )\r
+ {\r
+ { AF_INET [ sockaddr-in memory>struct ] }\r
+ { AF_INET6 [ sockaddr-in6 memory>struct ] }\r
+ [ 2drop f ]\r
+ } case ;\r
+\r
+M: windows addrspec-of-family ( af -- addrspec )\r
+ {\r
+ { AF_INET [ T{ inet4 } ] }\r
+ { AF_INET6 [ T{ inet6 } ] }\r
+ [ drop f ]\r
+ } case ;\r
+\r
HOOK: WSASocket-flags io-backend ( -- DWORD )\r
\r
TUPLE: win32-socket < win32-file ;\r
handle>> closesocket drop ;\r
\r
: unspecific-sockaddr/size ( addrspec -- sockaddr len )\r
- [ empty-sockaddr/size ] [ protocol-family ] bi\r
- pick set-sockaddr-in-family ;\r
+ [ empty-sockaddr/size ] [ protocol-family ] bi pick (>>family) ;\r
\r
: opened-socket ( handle -- win32-socket )\r
<win32-socket> |dispose dup add-completion ;\r
\r
M: windows (datagram) ( addrspec -- handle )\r
[ SOCK_DGRAM server-socket ] with-destructors ;\r
-\r
-M: windows addrinfo-error ( n -- )\r
- winsock-return-check ;\r
dup length zero? not [ rest ] [ drop f ] if ;
: (match-first) ( seq pattern-seq -- bindings leftover/f )
- 2dup [ length ] bi@ < [ 2drop f f ]
- [
+ 2dup shorter? [ 2drop f f ] [
2dup length head over match
- [ nip swap ?1-tail ] [ [ rest ] dip (match-first) ] if*
+ [ swap ?1-tail ] [ [ rest ] dip (match-first) ] ?if
] if ;
: match-first ( seq pattern-seq -- bindings )
: (match-all) ( seq pattern-seq -- )
[ nip ] [ (match-first) swap ] 2bi
- [
- , [ swap (match-all) ] [ drop ] if*
- ] [ 2drop ] if* ;
+ [ , [ swap (match-all) ] [ drop ] if* ] [ 2drop ] if* ;
: match-all ( seq pattern-seq -- bindings-seq )
[ (match-all) ] { } make ;
-
math math.blas.ffi math.blas.vectors math.blas.vectors.private
math.complex math.functions math.order functors words
sequences sequences.merged sequences.private shuffle
-specialized-arrays.direct.float specialized-arrays.direct.double
specialized-arrays.float specialized-arrays.double
-specialized-arrays.direct.complex-float specialized-arrays.direct.complex-double
specialized-arrays.complex-float specialized-arrays.complex-double
parser prettyprint.backend prettyprint.custom ascii ;
IN: math.blas.matrices
math.complex math.functions math.order sequences sequences.private
functors words locals parser prettyprint.backend prettyprint.custom
specialized-arrays.float specialized-arrays.double
-specialized-arrays.direct.float specialized-arrays.direct.double
-specialized-arrays.complex-float specialized-arrays.complex-double
-specialized-arrays.direct.complex-float
-specialized-arrays.direct.complex-double ;
+specialized-arrays.complex-float specialized-arrays.complex-double ;
IN: math.blas.vectors
TUPLE: blas-vector-base underlying length inc ;
+++ /dev/null
-USING: specialized-arrays.alien specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.alien
-
-<< "void*" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.bool specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.bool
-
-<< "bool" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.char specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.char
-
-<< "char" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.complex-double specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.complex-double
-
-<< "complex-double" define-direct-array >>
+++ /dev/null
-USING: specialized-arrays.complex-float specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.complex-float
-
-<< "complex-float" define-direct-array >>
+++ /dev/null
-USING: help.markup help.syntax byte-arrays alien ;
-IN: specialized-arrays.direct
-
-ARTICLE: "specialized-arrays.direct" "Direct-mapped specialized arrays"
-"The " { $vocab-link "specialized-arrays.direct" } " vocabulary implements fixed-length sequence types for storing machine values in unmanaged C memory."
-$nl
-"For each primitive C type " { $snippet "T" } ", a set of words are defined:"
-{ $table
- { { $snippet "direct-T-array" } { "The class of direct arrays with elements of type " { $snippet "T" } } }
- { { $snippet "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( alien len -- array )" } } }
-}
-"Each direct array has a " { $slot "underlying" } " slot holding an " { $link simple-alien } " pointer to the raw data. This data can be passed to C functions."
-$nl
-"The primitive C types for which direct arrays exist:"
-{ $list
- { $snippet "char" }
- { $snippet "uchar" }
- { $snippet "short" }
- { $snippet "ushort" }
- { $snippet "int" }
- { $snippet "uint" }
- { $snippet "long" }
- { $snippet "ulong" }
- { $snippet "longlong" }
- { $snippet "ulonglong" }
- { $snippet "float" }
- { $snippet "double" }
- { $snippet "void*" }
- { $snippet "bool" }
-}
-"Direct arrays are generated with a functor in the " { $vocab-link "specialized-arrays.direct.functor" } " vocabulary." ;
-
-ABOUT: "specialized-arrays.direct"
+++ /dev/null
-IN: specialized-arrays.direct.tests
-USING: specialized-arrays.direct.ushort tools.test
-specialized-arrays.ushort alien.syntax sequences ;
-
-[ ushort-array{ 0 0 0 } ] [
- 3 ALIEN: 123 100 <direct-ushort-array> new-sequence
-] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: specialized-arrays.direct
+++ /dev/null
-USING: specialized-arrays.double specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.double
-
-<< "double" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.float specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.float
-
-<< "float" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: functors sequences sequences.private kernel words classes
-math alien alien.c-types byte-arrays accessors
-specialized-arrays parser
-prettyprint.backend prettyprint.custom prettyprint.sections ;
-IN: specialized-arrays.direct.functor
-
-<PRIVATE
-
-: pprint-direct-array ( direct-array tag -- )
- [ [ underlying>> ] [ length>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
-
-PRIVATE>
-
-FUNCTOR: define-direct-array ( T -- )
-
-A' IS ${T}-array
-S IS ${T}-sequence
->A' IS >${T}-array
-<A'> IS <${A'}>
-A'{ IS ${A'}{
-
-A DEFINES-CLASS direct-${T}-array
-<A> DEFINES <${A}>
-A'@ DEFINES ${A'}@
-
-NTH [ T dup c-type-getter-boxer array-accessor ]
-SET-NTH [ T dup c-setter array-accessor ]
-
-WHERE
-
-TUPLE: A
-{ underlying c-ptr read-only }
-{ length fixnum read-only } ;
-
-: <A> ( alien len -- direct-array ) A boa ; inline
-M: A length length>> ; inline
-M: A nth-unsafe underlying>> NTH call ; inline
-M: A set-nth-unsafe underlying>> SET-NTH call ; inline
-M: A like drop dup A instance? [ >A' ] unless ; inline
-M: A new-sequence drop <A'> ; inline
-
-M: A byte-length length>> T heap-size * ; inline
-
-SYNTAX: A'@
- scan-object scan-object <A> parsed ;
-
-M: A pprint-delims drop \ A'{ \ } ;
-
-M: A >pprint-sequence ;
-
-M: A pprint*
- [ pprint-object ]
- [ \ A'@ pprint-direct-array ]
- pprint-c-object ;
-
-INSTANCE: A sequence
-INSTANCE: A S
-
-T c-type
- \ A >>direct-array-class
- \ <A> >>direct-array-constructor
- drop
-
-;FUNCTOR
+++ /dev/null
-Code generation for direct specialized arrays
+++ /dev/null
-USING: specialized-arrays.int specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.int
-
-<< "int" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.long specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.long
-
-<< "long" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.longlong specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.longlong
-
-<< "longlong" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.short specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.short
-
-<< "short" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.uchar specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.uchar
-
-<< "uchar" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.uint specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.uint
-
-<< "uint" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.ulong specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.ulong
-
-<< "ulong" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.ulonglong specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.ulonglong
-
-<< "ulonglong" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.ushort specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.ushort
-
-<< "ushort" define-direct-array >>
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! 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.c-types byte-arrays accessors summary alien specialized-arrays ;
IN: specialized-arrays.functor
ERROR: bad-byte-array-length byte-array type ;
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 ]
MIXIN: S
TUPLE: A
-{ length array-capacity read-only }
-{ underlying byte-array read-only } ;
+{ underlying c-ptr read-only }
+{ length array-capacity read-only } ;
+
+: <direct-A> ( alien len -- specialized-array ) A boa ; inline
-: <A> ( n -- specialized-array ) dup T <underlying> A boa ; inline
+: <A> ( n -- specialized-array ) [ T <underlying> ] keep <direct-A> ; inline
-: (A) ( n -- specialized-array ) dup T (underlying) A boa ; 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
- swap A boa ; inline
+ <direct-A> ; inline
-M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; inline
+M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
M: A length length>> ; inline
M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
M: A resize
- [ drop ] [
+ [
[ T heap-size * ] [ underlying>> ] bi*
resize-byte-array
- ] 2bi
- A boa ; inline
+ ] [ drop ] 2bi
+ <direct-A> ; inline
M: A byte-length underlying>> length ; inline
-
M: A pprint-delims drop \ A{ \ } ;
-
M: A >pprint-sequence ;
-M: A pprint* pprint-object ;
-
SYNTAX: A{ \ } [ >A ] parse-literal ;
+SYNTAX: A@ scan-object scan-object <direct-A> parsed ;
-INSTANCE: A sequence
-INSTANCE: A S
+INSTANCE: A specialized-array
A T c-type-boxed-class f specialize-vector-words
\ A >>array-class
\ <A> >>array-constructor
\ (A) >>(array)-constructor
- \ S >>sequence-mixin-class
+ \ <direct-A> >>direct-array-constructor
drop
;FUNCTOR
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel prettyprint.backend
+prettyprint.sections prettyprint.custom
+specialized-arrays ;
+IN: specialized-arrays.prettyprint
+
+: pprint-direct-array ( direct-array -- )
+ dup direct-array-syntax
+ [ [ underlying>> ] [ length>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
+
+M: specialized-array pprint*
+ [ pprint-object ] [ pprint-direct-array ] pprint-c-object ;
+
{ $table
{ { $snippet "T-array" } { "The class of arrays with elements of type " { $snippet "T" } } }
{ { $snippet "<T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( len -- array )" } } }
- { { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } }
+ { { $snippet "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; 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."
IN: specialized-arrays.tests
-USING: tools.test specialized-arrays sequences
+USING: tools.test alien.syntax specialized-arrays sequences
specialized-arrays.int specialized-arrays.bool
specialized-arrays.ushort alien.c-types accessors kernel
-specialized-arrays.direct.int specialized-arrays.char
-specialized-arrays.uint specialized-arrays.float
-arrays combinators compiler ;
+specialized-arrays.char specialized-arrays.uint arrays combinators ;
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
[ f ] [ float-array{ 4 3 2 1 } dup clone [ underlying>> ] bi@ eq? ] unit-test
-[ f ] [ [ float-array{ 4 3 2 1 } dup clone [ underlying>> ] bi@ eq? ] compile-call ] unit-test
\ No newline at end of file
+[ f ] [ [ float-array{ 4 3 2 1 } dup clone [ underlying>> ] bi@ eq? ] compile-call ] unit-test
+
+[ ushort-array{ 0 0 0 } ] [
+ 3 ALIEN: 123 100 <direct-ushort-array> new-sequence
+ dup [ drop 0 ] change-each
+] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences vocabs vocabs.loader ;
IN: specialized-arrays
+
+MIXIN: specialized-array
+INSTANCE: specialized-array sequence
+
+GENERIC: direct-array-syntax ( obj -- word )
+
+"prettyprint" vocab [
+ "specialized-arrays.prettyprint" require
+] when
ALIEN: 123 4 fixed-string <direct-struct-array> [ (underlying)>> ] { } map-as
] unit-test
-[ 10 "int" <struct-array> ] must-fail
\ No newline at end of file
+[ 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
\r
os windows? os macosx? or [\r
[ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test\r
+] when\r
+\r
+os macosx? [\r
+ [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test\r
] when
\ No newline at end of file
"slots"
"special"
"specializer"
+ "struct-slots"
! UI needs this
! "superclass"
"transform-n"
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes.struct cocoa cocoa.classes
+cocoa.subclassing core-graphics.types kernel math ;
+IN: tools.deploy.test.14
+
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "Bar" }
+} {
+ "bar:"
+ "float"
+ { "id" "SEL" "NSRect" }
+ [
+ [ origin>> [ x>> ] [ y>> ] bi + ]
+ [ size>> [ w>> ] [ h>> ] bi + ]
+ bi +
+ ]
+} ;
+
+: main ( -- )
+ Bar -> alloc -> init
+ S{ CGRect f S{ CGPoint f 1.0 2.0 } S{ CGSize f 3.0 4.0 } } -> bar:
+ 10.0 assert= ;
+
+MAIN: main
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-math? t }
+ { deploy-io 2 }
+ { deploy-c-types? f }
+ { deploy-reflection 1 }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
+ { deploy-threads? t }
+ { deploy-ui? f }
+ { deploy-unicode? f }
+ { deploy-name "tools.deploy.test.14" }
+}
--- /dev/null
+unportable
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
-M: x11-ui-backend (set-fullscreen) ( world ? -- )
+: make-fullscreen-msg ( world ? -- msg )
XClientMessageEvent <struct>
- swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
- swap handle>> window>> >>window
+ ClientMessage >>type
dpy get >>display
"_NET_WM_STATE" x-atom >>message_type
+ swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
+ swap handle>> window>> >>window
32 >>format
- "_NET_WM_STATE_FULLSCREEN" x-atom >>data1
- [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
+ "_NET_WM_STATE_FULLSCREEN" x-atom >>data1 ;
+
+M: x11-ui-backend (set-fullscreen) ( world ? -- )
+ [ dpy get root get 0 SubstructureNotifyMask ] 2dip
+ make-fullscreen-msg XSendEvent drop ;
M: x11-ui-backend (open-window) ( world -- )
dup gadget-window
CONSTANT: F_SETFL 4
CONSTANT: FD_CLOEXEC 1
-C-STRUCT: sockaddr-in
- { "uchar" "len" }
- { "uchar" "family" }
- { "ushort" "port" }
- { "in_addr_t" "addr" }
- { "longlong" "unused" } ;
-
-C-STRUCT: sockaddr-in6
- { "uchar" "len" }
- { "uchar" "family" }
- { "ushort" "port" }
- { "uint" "flowinfo" }
- { { "uchar" 16 } "addr" }
- { "uint" "scopeid" } ;
-
-C-STRUCT: sockaddr-un
- { "uchar" "len" }
- { "uchar" "family" }
- { { "char" 104 } "path" } ;
+STRUCT: sockaddr-in
+ { len uchar }
+ { family uchar }
+ { port ushort }
+ { addr in_addr_t }
+ { unused longlong } ;
+
+STRUCT: sockaddr-in6
+ { len uchar }
+ { family uchar }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
+
+STRUCT: sockaddr-un
+ { len uchar }
+ { family uchar }
+ { path char[104] } ;
STRUCT: passwd
{ pw_name char* }
CONSTANT: FD_SETSIZE 1024
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { canonname char* }
+ { addr void* }
+ { next addrinfo* } ;
STRUCT: dirent
{ d_fileno u_int32_t }
CONSTANT: FD_SETSIZE 1024
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { canonname char* }
+ { addr void* }
+ { next addrinfo* } ;
CONSTANT: _UTX_USERSIZE 256
CONSTANT: _UTX_LINESIZE 32
CONSTANT: FD_SETSIZE 256
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { canonname char* }
+ { addr void* }
+ { next addrinfo* } ;
STRUCT: dirent
{ d_fileno __uint32_t }
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.time ;
+USING: alien.syntax unix.time classes.struct ;
IN: unix
-C-STRUCT: sockaddr_storage
- { "__uint8_t" "ss_len" }
- { "sa_family_t" "ss_family" }
- { { "char" _SS_PAD1SIZE } "__ss_pad1" }
- { "__int64_t" "__ss_align" }
- { { "char" _SS_PAD2SIZE } "__ss_pad2" } ;
+STRUCT: sockaddr_storage
+ { ss_len __uint8_t }
+ { ss_family sa_family_t }
+ { __ss_pad1 { "char" _SS_PAD1SIZE } }
+ { __ss_align __int64_t }
+ { __ss_pad2 { "char" _SS_PAD2SIZE } } ;
-C-STRUCT: exit_struct
- { "uint16_t" "e_termination" }
- { "uint16_t" "e_exit" } ;
+STRUCT: exit_struct
+ { e_termination uint16_t }
+ { e_exit uint16_t } ;
C-STRUCT: utmpx
{ { "char" _UTX_USERSIZE } "ut_user" }
CONSTANT: FD_SETSIZE 1024
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "void*" "addr" }
- { "char*" "canonname" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { addr void* }
+ { canonname char* }
+ { next addrinfo* } ;
STRUCT: dirent
{ d_fileno __uint32_t }
CONSTANT: F_SETFL 4
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "void*" "addr" }
- { "char*" "canonname" }
- { "addrinfo*" "next" } ;
-
-C-STRUCT: sockaddr-in
- { "ushort" "family" }
- { "ushort" "port" }
- { "in_addr_t" "addr" }
- { "longlong" "unused" } ;
-
-C-STRUCT: sockaddr-in6
- { "ushort" "family" }
- { "ushort" "port" }
- { "uint" "flowinfo" }
- { { "uchar" 16 } "addr" }
- { "uint" "scopeid" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { addr void* }
+ { canonname char* }
+ { next addrinfo* } ;
+
+STRUCT: sockaddr-in
+ { family ushort }
+ { port ushort }
+ { addr in_addr_t }
+ { unused longlong } ;
+
+STRUCT: sockaddr-in6
+ { family ushort }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
CONSTANT: max-un-path 108
-C-STRUCT: sockaddr-un
- { "ushort" "family" }
- { { "char" max-un-path } "path" } ;
+STRUCT: sockaddr-un
+ { family ushort }
+ { path { "char" max-un-path } } ;
CONSTANT: SOCK_STREAM 1
CONSTANT: SOCK_DGRAM 2
! Copyright (C) 2006 Patrick Mauritz.
! See http://factorcode.org/license.txt for BSD license.
-IN: unix
USING: alien.syntax system kernel layouts ;
+IN: unix
! Solaris.
CONSTANT: F_SETFL 4 ! set file status flags
CONSTANT: O_NONBLOCK HEX: 80 ! no delay
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
! #ifdef __sparcv9
! int _ai_pad;
! #endif
- { "int" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "void*" "next" } ;
-
-C-STRUCT: sockaddr-in
- { "ushort" "family" }
- { "ushort" "port" }
- { "in_addr_t" "addr" }
- { "longlong" "unused" } ;
-
-C-STRUCT: sockaddr-in6
- { "ushort" "family" }
- { "ushort" "port" }
- { "uint" "flowinfo" }
- { { "uchar" 16 } "addr" }
- { "uint" "scopeid" } ;
+ { addrlen int }
+ { canonname char* }
+ { addr void* }
+ { next void* } ;
+
+STRUCT: sockaddr-in
+ { family ushort }
+ { port ushort }
+ { addr in_addr_t }
+ { unused longlong } ;
+
+STRUCT: sockaddr-in6
+ { family ushort }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
: max-un-path 108 ;
-C-STRUCT: sockaddr-un
- { "ushort" "family" }
- { { "char" max-un-path } "path" } ;
+STRUCT: sockaddr-un
+ { family ushort }
+ { path { "char" max-un-path } } ;
CONSTANT: EINTR 4
CONSTANT: EAGAIN 11
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: windows.com windows.kernel32 windows.ole32
+prettyprint.custom prettyprint.sections sequences ;
+IN: windows.com.prettyprint
+
+M: GUID pprint* guid>string "GUID: " prepend text ;
--- /dev/null
+unportable
windows.ole32 parser lexer splitting grouping sequences
namespaces assocs quotations generalizations accessors words
macros alien.syntax fry arrays layouts math classes.struct
-windows.kernel32 prettyprint.custom prettyprint.sections ;
+windows.kernel32 ;
IN: windows.com.syntax
<PRIVATE
SYNTAX: GUID: scan string>guid parsed ;
-M: GUID pprint* guid>string "GUID: " prepend text ;
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [
+ "windows.com.prettyprint" require
+] when
namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units
destructors fry math.parser generalizations sets
-specialized-arrays.alien specialized-arrays.direct.alien
-windows.kernel32 classes.struct ;
+specialized-arrays.alien windows.kernel32 classes.struct ;
IN: windows.com.wrapper
TUPLE: com-wrapper < disposable callbacks vtbls ;
alien.c-types alien sequences math ;\r
IN: windows.dragdrop-listener\r
\r
-<< "WCHAR" require-c-arrays >>\r
+<< "WCHAR" require-c-array >>\r
\r
: filenames-from-hdrop ( hdrop -- filenames )\r
dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files\r
arrays literals ;
IN: windows.errors
-<< "TCHAR" require-c-arrays >>
+<< "TCHAR" require-c-array >>
CONSTANT: ERROR_SUCCESS 0
CONSTANT: ERROR_INVALID_FUNCTION 1
: make-lang-id ( lang1 lang2 -- n )
10 shift bitor ; inline
-<< "TCHAR" require-c-arrays >>
+<< "TCHAR" require-c-array >>
ERROR: error-message-failed id ;
:: n>win32-error-string ( id -- string )
TYPEDEF: uint COMPUTER_NAME_FORMAT
-C-STRUCT: OVERLAPPED
- { "UINT_PTR" "internal" }
- { "UINT_PTR" "internal-high" }
- { "DWORD" "offset" }
- { "DWORD" "offset-high" }
- { "HANDLE" "event" } ;
+STRUCT: OVERLAPPED
+ { internal UINT_PTR }
+ { internal-high UINT_PTR }
+ { offset DWORD }
+ { offset-high DWORD }
+ { event HANDLE } ;
STRUCT: SYSTEMTIME
{ wYear WORD }
USING: alien alien.syntax alien.c-types alien.strings math
kernel sequences windows.errors windows.types io
accessors math.order namespaces make math.parser windows.kernel32
-combinators locals specialized-arrays.direct.uchar
+combinators locals specialized-arrays.uchar
literals splitting grouping classes.struct combinators.smart ;
IN: windows.ole32
! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
-byte-arrays kernel math sequences windows.types windows.kernel32
-windows.errors math.bitwise io.encodings.utf16n classes.struct
-literals windows.com.syntax ;
+byte-arrays kernel literals math sequences windows.types
+windows.kernel32 windows.errors math.bitwise io.encodings.utf16n
+classes.struct windows.com.syntax init ;
IN: windows.winsock
-USE: libc
-: alien>byte-array ( alien str -- byte-array )
- heap-size dup <byte-array> [ -rot memcpy ] keep ;
-
TYPEDEF: void* SOCKET
: <wsadata> ( -- byte-array )
CONSTANT: AI_PASSIVE 1
CONSTANT: AI_CANONNAME 2
CONSTANT: AI_NUMERICHOST 4
-: AI_MASK ( -- n ) { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ;
+
+: AI_MASK ( -- n )
+ { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ; inline
CONSTANT: NI_NUMERICHOST 1
CONSTANT: NI_NUMERICSERV 2
CONSTANT: INADDR_ANY 0
-: INVALID_SOCKET ( -- alien ) -1 <alien> ; inline
+: INVALID_SOCKET ( -- n ) -1 <alien> ; inline
+
CONSTANT: SOCKET_ERROR -1
CONSTANT: SD_RECV 0
CONSTANT: SOL_SOCKET HEX: ffff
-! TYPEDEF: uint in_addr_t
-! C-STRUCT: in_addr
- ! { "in_addr_t" "s_addr" } ;
+STRUCT: sockaddr-in
+ { family short }
+ { port ushort }
+ { addr uint }
+ { pad char[8] } ;
-C-STRUCT: sockaddr-in
- { "short" "family" }
- { "ushort" "port" }
- { "uint" "addr" }
- { { "char" 8 } "pad" } ;
-
-C-STRUCT: sockaddr-in6
- { "uchar" "family" }
- { "ushort" "port" }
- { "uint" "flowinfo" }
- { { "uchar" 16 } "addr" }
- { "uint" "scopeid" } ;
+STRUCT: sockaddr-in6
+ { family uchar }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
STRUCT: hostent
{ name char* }
{ length short }
{ addr-list void* } ;
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "size_t" "addrlen" }
- { "char*" "canonname" }
- { "sockaddr*" "addr" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen size_t }
+ { canonname char* }
+ { addr sockaddr* }
+ { next addrinfo* } ;
C-STRUCT: timeval
{ "long" "sec" }
! Not in Windows CE
FUNCTION: int AcceptEx ( void* listen, void* accept, void* out-buf, int recv-len, int addr-len, int remote-len, void* out-len, void* overlapped ) ;
-FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, void* f, void* g, void* h ) ;
+
+FUNCTION: void GetAcceptExSockaddrs (
+ PVOID lpOutputBuffer,
+ DWORD dwReceiveDataLength,
+ DWORD dwLocalAddressLength,
+ DWORD dwRemoteAddressLength,
+ LPSOCKADDR* LocalSockaddr,
+ LPINT LocalSockaddrLength,
+ LPSOCKADDR* RemoteSockaddr,
+ LPINT RemoteSockaddrLength
+) ;
CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
: init-winsock ( -- )
HEX: 0202 <wsadata> WSAStartup winsock-return-check ;
+
+[ init-winsock ] "windows.winsock" add-init-hook
"and"
{ $code "[ [ reverse % ] each ] \"\" make" }
"is equivalent to"
-{ $code "[ [ reverse ] map concat" }
+{ $code "[ reverse ] map concat" }
{ $heading "Utilities for simple make patterns" }
"Sometimes, an existing word already implements a specific " { $link make } " usage. For example, " { $link suffix } " is equivalent to the following, with the added caveat that the below example always outputs an array:"
{ $code "[ , % ] { } make" }
HELP: %
{ $values { "seq" sequence } }
-{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ;
\ No newline at end of file
+{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ;
[ -0.0 ] [ 0.0 prev-float ] unit-test
[ t ] [ 1.0 dup prev-float > ] unit-test
[ t ] [ -1.0 dup prev-float > ] unit-test
+
+[ f ] [ 0/0. 0/0. = ] unit-test
+[ f ] [ 0/0. 1.0 = ] unit-test
+[ f ] [ 0/0. 1/0. = ] unit-test
+[ f ] [ 0/0. -1/0. = ] unit-test
+
+[ f ] [ 0/0. 0/0. = ] unit-test
+[ f ] [ 1.0 0/0. = ] unit-test
+[ f ] [ -1/0. 0/0. = ] unit-test
+[ f ] [ 1/0. 0/0. = ] unit-test
+
+[ f ] [ 0/0. 0/0. < ] unit-test
+[ f ] [ 0/0. 1.0 < ] unit-test
+[ f ] [ 0/0. 1/0. < ] unit-test
+[ f ] [ 0/0. -1/0. < ] unit-test
+
+[ f ] [ 0/0. 0/0. <= ] unit-test
+[ f ] [ 0/0. 1.0 <= ] unit-test
+[ f ] [ 0/0. 1/0. <= ] unit-test
+[ f ] [ 0/0. -1/0. <= ] unit-test
+
+[ f ] [ 0/0. 0/0. > ] unit-test
+[ f ] [ 1.0 0/0. > ] unit-test
+[ f ] [ -1/0. 0/0. > ] unit-test
+[ f ] [ 1/0. 0/0. > ] unit-test
+
+[ f ] [ 0/0. 0/0. >= ] unit-test
+[ f ] [ 1.0 0/0. >= ] unit-test
+[ f ] [ -1/0. 0/0. >= ] unit-test
+[ f ] [ 1/0. 0/0. >= ] unit-test
+
+
HELP: accumulate
{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } }
-{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence."
+{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
$nl
"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." }
{ $examples
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types alien.syntax kernel math math.order
-specialized-arrays.direct.functor specialized-arrays.functor ;
+specialized-arrays.functor ;
IN: half-floats
: half>bits ( float -- bits )
drop
"half" define-array
-"half" define-direct-array
>>
! Copyright (C) 2009 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors grouping sequences combinators
-math specialized-arrays.direct.uint byte-arrays fry
-specialized-arrays.direct.ushort specialized-arrays.uint
-specialized-arrays.ushort specialized-arrays.float images
-half-floats ;
+USING: kernel accessors grouping sequences combinators math
+byte-arrays fry specialized-arrays.uint specialized-arrays.ushort
+specialized-arrays.float images half-floats ;
IN: images.normalization
<PRIVATE
combinators ;
IN: opengl.glu
+<<
+
os {
{ [ dup macosx? ] [ drop ] }
{ [ dup windows? ] [ drop ] }
{ [ dup unix? ] [ drop "glu" "libGLU.so.1" "cdecl" add-library ] }
} cond
+>>
+
LIBRARY: glu
! These are defined as structs in glu.h, but we only ever use pointers to them
--- /dev/null
+USING: project-euler.085 tools.test ;
+IN: project-euler.085.tests
+
+[ 2772 ] [ euler085 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Guillaume Nargeot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math math.ranges project-euler.common sequences ;
+IN: project-euler.085
+
+! http://projecteuler.net/index.php?section=problems&id=85
+
+! DESCRIPTION
+! -----------
+
+! By counting carefully it can be seen that a rectangular grid measuring
+! 3 by 2 contains eighteen rectangles.
+
+! Although there exists no rectangular grid that contains exactly two million
+! rectangles, find the area of the grid with the nearest solution.
+
+
+! SOLUTION
+! --------
+
+! A grid measuring x by y contains x * (x + 1) * y * (x + 1) rectangles.
+
+<PRIVATE
+
+: distance ( m -- n )
+ 2000000 - abs ;
+
+: rectangles-count ( a b -- n )
+ 2dup [ 1 + ] bi@ * * * 4 / ;
+
+: unique-products ( a b -- seq )
+ tuck [a,b] [
+ over dupd [a,b] [ 2array ] with map
+ ] map concat nip ;
+
+: max-by-last ( seq seq -- seq )
+ [ [ last ] bi@ < ] most ;
+
+: array2 ( seq -- a b )
+ [ first ] [ last ] bi ;
+
+: convert ( seq -- seq )
+ array2 [ * ] [ rectangles-count distance ] 2bi 2array ;
+
+: area-of-nearest ( -- n )
+ 1 2000 unique-products
+ [ convert ] [ max-by-last ] map-reduce first ;
+
+PRIVATE>
+
+: euler085 ( -- answer )
+ area-of-nearest ;
+
+! [ euler085 ] 100 ave-time
+! 2285 ms ave run time - 4.8 SD (100 trials)
+
+SOLUTION: euler085
Aaron Schaefer
Eric Mertens
+Guillaume Nargeot
project-euler.055 project-euler.056 project-euler.057 project-euler.058
project-euler.059 project-euler.063 project-euler.067 project-euler.069
project-euler.071 project-euler.073 project-euler.075 project-euler.076
- project-euler.079 project-euler.092 project-euler.097 project-euler.099
- project-euler.100 project-euler.116 project-euler.117 project-euler.134
- project-euler.148 project-euler.150 project-euler.151 project-euler.164
- project-euler.169 project-euler.173 project-euler.175 project-euler.186
- project-euler.190 project-euler.203 project-euler.215 ;
+ project-euler.079 project-euler.085 project-euler.092 project-euler.097
+ project-euler.099 project-euler.100 project-euler.116 project-euler.117
+ project-euler.134 project-euler.148 project-euler.150 project-euler.151
+ project-euler.164 project-euler.169 project-euler.173 project-euler.175
+ project-euler.186 project-euler.190 project-euler.203 project-euler.215 ;
IN: project-euler
<PRIVATE
[ [ % ] each ] product-each
] "" make
] unit-test
+
+[ { } ] [ { { } { 1 } } [ ] product-map ] unit-test
+[ ] [ { { } { 1 } } [ drop ] product-each ] unit-test
: product-iter ( ns lengths -- )
[ 0 over [ 1 + ] change-nth ] dip carry-ns ;
-: start-product-iter ( sequence-product -- ns lengths )
+: start-product-iter ( sequences -- ns lengths )
[ [ drop 0 ] map ] [ [ length ] map ] bi ;
: end-product-iter? ( ns lengths -- ? )
:: product-each ( sequences quot -- )
sequences start-product-iter :> lengths :> ns
- [ ns lengths end-product-iter? ]
- [ ns sequences nths quot call ns lengths product-iter ] until ; inline
+ lengths [ 0 = ] any? [
+ [ ns lengths end-product-iter? ]
+ [ ns sequences nths quot call ns lengths product-iter ] until
+ ] unless ; inline
:: product-map ( sequences quot -- sequence )
0 :> i!
"adapted from lisp.vim
if exists("g:factor_norainbow")
- syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
+ syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
else
- syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
- syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
- syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
- syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
- syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
- syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
- syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
- syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
- syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
- syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
+ syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
+ syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
+ syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
+ syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
+ syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
+ syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
+ syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
+ syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
+ syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
+ syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
endif
if exists("g:factor_norainbow")
projects / factor.git / commitdiff