: malloc-array ( n type -- alien )
[ heap-size calloc ] [ <c-type-direct-array> ] 2bi ; inline
+: (malloc-array) ( n type -- alien )
+ [ heap-size * malloc ] [ <c-type-direct-array> ] 2bi ; inline
+
: malloc-object ( type -- alien )
1 swap heap-size calloc ; inline
+: (malloc-object) ( type -- alien )
+ heap-size malloc ; inline
+
: malloc-byte-array ( byte-array -- alien )
dup byte-length [ nip malloc dup ] 2keep memcpy ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.structs alien.c-types classes.struct math
+USING: accessors alien alien.structs alien.c-types classes.struct math
math.functions sequences arrays kernel functors vocabs.parser
namespaces quotations ;
IN: alien.complex.functor
STRUCT: T-class { real N } { imaginary N } ;
: <T> ( z -- alien )
- >rect T-class <struct-boa> ;
+ >rect T-class <struct-boa> >c-ptr ;
: *T ( alien -- z )
T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax arrays calendar
-kernel math unix unix.time unix.types namespaces system ;
+kernel math unix unix.time unix.types namespaces system
+accessors classes.struct ;
IN: calendar.unix
: timeval>seconds ( timeval -- seconds )
- [ timeval-sec seconds ] [ timeval-usec microseconds ] bi
- time+ ;
+ [ sec>> seconds ] [ usec>> microseconds ] bi time+ ;
: timeval>unix-time ( timeval -- timestamp )
timeval>seconds since-1970 ;
: timespec>seconds ( timespec -- seconds )
- [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi
- time+ ;
+ [ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
: timespec>unix-time ( timespec -- timestamp )
timespec>seconds since-1970 ;
: get-time ( -- alien )
- f time <time_t> localtime ;
+ f time <time_t> localtime tm memory>struct ;
: timezone-name ( -- string )
- get-time tm-zone ;
+ get-time zone>> ;
M: unix gmt-offset ( -- hours minutes seconds )
- get-time tm-gmtoff 3600 /mod 60 /mod ;
+ get-time gmtoff>> 3600 /mod 60 /mod ;
}
{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
+HELP: (struct)
+{ $values
+ { "class" class }
+ { "struct" struct }
+}
+{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; in most cases, the " { $link <struct> } " word, which initializes the struct's slots with their initial values, should be used instead." } ;
+
+{ (struct) (malloc-struct) } related-words
+
HELP: <struct>
{ $values
{ "class" class }
{ "class" class }
{ "struct" struct }
}
-{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are zeroed out. The struct should be " { $link free } "d when it is no longer needed." } ;
+{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized to their initial values. The struct should be " { $link free } "d when it is no longer needed." } ;
+
+HELP: (malloc-struct)
+{ $values
+ { "class" class }
+ { "struct" struct }
+}
+{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; to initialize the allocated memory with the slots' initial values, use " { $link malloc-struct } ". The struct should be " { $link free } "d when it is no longer needed." } ;
HELP: memory>struct
{ $values
{ $subsection <struct-boa> }
{ $subsection malloc-struct }
{ $subsection memory>struct }
+"When the contents of a struct will be immediately reset, faster primitive words are available that will create a struct without initializing its contents:"
+{ $subsection (struct) }
+{ $subsection (malloc-struct) }
"Structs have literal syntax like tuples:"
{ $subsection POSTPONE: S{ }
"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
! (c)Joe Groff bsd license
-USING: accessors alien.c-types alien.libraries
+USING: accessors alien alien.c-types alien.libraries
alien.structs.fields alien.syntax ascii classes.struct combinators
destructors io.encodings.utf8 io.pathnames io.streams.string
kernel libc literals math multiline namespaces prettyprint
prettyprint.config see sequences specialized-arrays.ushort
system tools.test compiler.tree.debugger struct-arrays
classes.tuple.private specialized-arrays.direct.int
-compiler.units ;
+compiler.units byte-arrays specialized-arrays.char ;
IN: classes.struct.tests
<<
[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
-[ ] [ [ struct-test-foo malloc-struct &free drop ] with-destructors ] unit-test
+[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
STRUCT: struct-test-string-ptr
{ x char* } ;
] unit-test
[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+
+! Test cloning structs
+STRUCT: clone-test-struct { x int } { y char[3] } ;
+
+[ 1 char-array{ 9 1 1 } ] [
+ clone-test-struct <struct>
+ 1 >>x char-array{ 9 1 1 } >>y
+ clone
+ [ x>> ] [ y>> >char-array ] bi
+] unit-test
+
+[ t 1 char-array{ 9 1 1 } ] [
+ [
+ clone-test-struct malloc-struct &free
+ 1 >>x char-array{ 9 1 1 } >>y
+ clone
+ [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
+ ] with-destructors
+] unit-test
+
+STRUCT: struct-that's-a-word { x int } ;
+
+: struct-that's-a-word ( -- ) "OOPS" throw ;
+
+[ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
[ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
} 2&& ;
+: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
+
: memory>struct ( ptr class -- struct )
[ 1array ] dip slots>tuple ;
dup struct-class? [ '[ _ boa ] ] [ drop f ] if
] 1 define-partial-eval
+<PRIVATE
+: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
+ '[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline
+PRIVATE>
+
+: (malloc-struct) ( class -- struct )
+ [ heap-size malloc ] keep memory>struct ; inline
+
: malloc-struct ( class -- struct )
- [ 1 swap heap-size calloc ] keep memory>struct ; inline
+ [ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ; inline
: (struct) ( class -- struct )
- [ heap-size <byte-array> ] keep memory>struct ; inline
-
-: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
+ [ heap-size (byte-array) ] keep memory>struct ; inline
: <struct> ( class -- struct )
- dup struct-prototype
- [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
+ [ >c-ptr clone ] [ heap-size <byte-array> ] (init-struct) ; inline
MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
[
] bi
] [ ] output>sequence ;
+<PRIVATE
: pad-struct-slots ( values class -- values' class )
[ struct-slots [ initial>> ] map over length tail append ] keep ;
: (unboxer-quot) ( class -- quot )
drop [ >c-ptr ] ;
+PRIVATE>
M: struct-class boa>object
swap pad-struct-slots
M: struct-class writer-quot
nip (writer-quot) ;
+! c-types
+
+<PRIVATE
: struct-slot-values-quot ( class -- quot )
struct-slots
[ name>> reader-word 1quotation ] map
\ cleave [ ] 2sequence
\ output>array [ ] 2sequence ;
+: define-inline-method ( class generic quot -- )
+ [ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ;
+
: (define-struct-slot-values-method) ( class -- )
- [ \ struct-slot-values create-method-in ]
- [ struct-slot-values-quot ] bi define ;
+ [ \ struct-slot-values ] [ struct-slot-values-quot ] bi
+ define-inline-method ;
: (define-byte-length-method) ( class -- )
- [ \ byte-length create-method-in ]
- [ heap-size \ drop swap [ ] 2sequence ] bi define ;
+ [ \ byte-length ] [ heap-size \ drop swap [ ] 2sequence ] bi
+ define-inline-method ;
-! Struct as c-type
+: clone-underlying ( struct -- byte-array )
+ [ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
+
+: (define-clone-method) ( class -- )
+ [ \ clone ]
+ [ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
+ define-inline-method ;
: slot>field ( slot -- field )
field-spec new swap {
: struct-align ( slots -- align )
[ c-type>> c-type-align ] [ max ] map-reduce ;
+PRIVATE>
M: struct-class c-type
name>> c-type ;
! class definition
+<PRIVATE
: make-struct-prototype ( class -- prototype )
[ heap-size <byte-array> ]
[ memory>struct ]
: (struct-methods) ( class -- )
[ (define-struct-slot-values-method) ]
- [ (define-byte-length-method) ] bi ;
+ [ (define-byte-length-method) ]
+ [ (define-clone-method) ]
+ tri ;
: (struct-word-props) ( class slots size align -- )
[
(struct-word-props)
]
[ drop define-struct-for-class ] 2tri ; inline
+PRIVATE>
: define-struct-class ( class slots -- )
[ struct-offsets ] (define-struct-class) ;
ERROR: invalid-struct-slot token ;
+<PRIVATE
: struct-slot-class ( c-type -- class' )
c-type c-type-boxed-class
dup \ byte-array = [ drop \ c-ptr ] when ;
: parse-struct-definition ( -- class slots )
CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
+PRIVATE>
SYNTAX: STRUCT:
parse-struct-definition define-struct-class ;
SYNTAX: S{
scan-word dup struct-slots parse-tuple-literal-slots parsed ;
+! functor support
+
+<PRIVATE
: scan-c-type` ( -- c-type/param )
scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
{ "{" [ parse-struct-slot` t ] }
[ invalid-struct-slot ]
} case ;
+PRIVATE>
FUNCTOR-SYNTAX: STRUCT:
scan-param parsed
frame-required? on
stack-frame [ max-stack-frame ] change ;
-M: ##alien-invoke compute-stack-frame*
- stack-frame>> request-stack-frame ;
-
-M: ##alien-indirect compute-stack-frame*
- stack-frame>> request-stack-frame ;
+UNION: stack-frame-insn
+ ##alien-invoke
+ ##alien-indirect
+ ##alien-callback ;
-M: ##alien-callback compute-stack-frame*
+M: stack-frame-insn compute-stack-frame*
stack-frame>> request-stack-frame ;
M: ##call compute-stack-frame*
] when ;
\ _spill t frame-required? set-word-prop
+\ ##unary-float-function t frame-required? set-word-prop
+\ ##binary-float-function t frame-required? set-word-prop
: compute-stack-frame ( insns -- )
frame-required? off
M: ##set-slot temp-vregs temp>> 1array ;
M: ##string-nth temp-vregs temp>> 1array ;
M: ##set-string-nth-fast temp-vregs temp>> 1array ;
-M: ##box-displaced-alien temp-vregs temp>> 1array ;
+M: ##box-displaced-alien temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##compare temp-vregs temp>> 1array ;
M: ##compare-imm temp-vregs temp>> 1array ;
M: ##compare-float temp-vregs temp>> 1array ;
: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
: ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline
: ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-float ; inline
+: ^^unary-float-function ( src func -- dst ) ^^r2 ##unary-float-function ; inline
+: ^^binary-float-function ( src1 src2 func -- dst ) ^^r3 ##binary-float-function ; inline
: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
: ^^box-displaced-alien ( base displacement base-class -- dst )
- ^^r3 [ next-vreg ] dip ##box-displaced-alien ; inline
+ ^^r3 [ next-vreg next-vreg ] dip ##box-displaced-alien ; inline
: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
INSN: ##max-float < ##binary ;
INSN: ##sqrt < ##unary ;
+! libc intrinsics
+INSN: ##unary-float-function < ##unary func ;
+INSN: ##binary-float-function < ##binary func ;
+
! Float/integer conversion
INSN: ##float>integer < ##unary ;
INSN: ##integer>float < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary/temp ;
INSN: ##box-float < ##unary/temp ;
INSN: ##box-alien < ##unary/temp ;
-INSN: ##box-displaced-alien < ##binary temp base-class ;
+INSN: ##box-displaced-alien < ##binary temp1 temp2 base-class ;
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
_compare-imm-branch
_dispatch ;
+! Instructions that kill all live vregs but cannot trigger GC
+UNION: partial-sync-insn
+ ##unary-float-function
+ ##binary-float-function ;
+
! Instructions that kill all live vregs
UNION: kill-vreg-insn
##call
##min-float
##max-float
##sqrt
+ ##unary-float-function
+ ##binary-float-function
##integer>float
##unbox-float
##alien-float
##min-float
##max-float
##sqrt
+ ##unary-float-function
+ ##binary-float-function
##float>integer
##box-float
##set-alien-float
: emit-fsqrt ( -- )
ds-pop ^^sqrt ds-push ;
+
+: emit-unary-float-function ( func -- )
+ [ ds-pop ] dip ^^unary-float-function ds-push ;
+
+: emit-binary-float-function ( func -- )
+ [ 2inputs ] dip ^^binary-float-function ds-push ;
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: words sequences kernel combinators cpu.architecture
+USING: words sequences kernel combinators cpu.architecture assocs
compiler.cfg.hats
compiler.cfg.instructions
compiler.cfg.intrinsics.alien
QUALIFIED: math.libm
IN: compiler.cfg.intrinsics
-: enable-intrinsics ( words -- )
- [ t "intrinsic" set-word-prop ] each ;
+: enable-intrinsics ( alist -- )
+ [ "intrinsic" set-word-prop ] assoc-each ;
{
- kernel.private:tag
- kernel.private:getenv
- math.private:both-fixnums?
- math.private:fixnum+
- math.private:fixnum-
- math.private:fixnum*
- math.private:fixnum+fast
- math.private:fixnum-fast
- math.private:fixnum-bitand
- math.private:fixnum-bitor
- math.private:fixnum-bitxor
- math.private:fixnum-shift-fast
- math.private:fixnum-bitnot
- math.private:fixnum*fast
- math.private:fixnum<
- math.private:fixnum<=
- math.private:fixnum>=
- math.private:fixnum>
- ! math.private:bignum>fixnum
- ! math.private:fixnum>bignum
- kernel:eq?
- slots.private:slot
- slots.private:set-slot
- strings.private:string-nth
- strings.private:set-string-nth-fast
- classes.tuple.private:<tuple-boa>
- arrays:<array>
- byte-arrays:<byte-array>
- byte-arrays:(byte-array)
- kernel:<wrapper>
- alien:<displaced-alien>
- alien.accessors:alien-unsigned-1
- alien.accessors:set-alien-unsigned-1
- alien.accessors:alien-signed-1
- alien.accessors:set-alien-signed-1
- alien.accessors:alien-unsigned-2
- alien.accessors:set-alien-unsigned-2
- alien.accessors:alien-signed-2
- alien.accessors:set-alien-signed-2
- alien.accessors:alien-cell
- alien.accessors:set-alien-cell
+ { kernel.private:tag [ drop emit-tag ] }
+ { kernel.private:getenv [ emit-getenv ] }
+ { math.private:both-fixnums? [ drop emit-both-fixnums? ] }
+ { math.private:fixnum+ [ drop emit-fixnum+ ] }
+ { math.private:fixnum- [ drop emit-fixnum- ] }
+ { math.private:fixnum* [ drop emit-fixnum* ] }
+ { math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
+ { math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
+ { math.private:fixnum*fast [ drop emit-fixnum*fast ] }
+ { math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
+ { math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
+ { math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
+ { math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
+ { math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+ { math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
+ { math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
+ { math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
+ { math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
+ { kernel:eq? [ drop cc= emit-fixnum-comparison ] }
+ { slots.private:slot [ emit-slot ] }
+ { slots.private:set-slot [ emit-set-slot ] }
+ { strings.private:string-nth [ drop emit-string-nth ] }
+ { strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
+ { classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
+ { arrays:<array> [ emit-<array> ] }
+ { byte-arrays:<byte-array> [ emit-<byte-array> ] }
+ { byte-arrays:(byte-array) [ emit-(byte-array) ] }
+ { kernel:<wrapper> [ emit-simple-allot ] }
+ { alien:<displaced-alien> [ emit-<displaced-alien> ] }
+ { alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
+ { alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
+ { alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
+ { alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
+ { alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
+ { alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
+ { alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
+ { alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
+ { alien.accessors:alien-cell [ emit-alien-cell-getter ] }
+ { alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
} enable-intrinsics
: enable-alien-4-intrinsics ( -- )
{
- alien.accessors:alien-unsigned-4
- alien.accessors:set-alien-unsigned-4
- alien.accessors:alien-signed-4
- alien.accessors:set-alien-signed-4
+ { alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
+ { alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
+ { alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
+ { alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
} enable-intrinsics ;
: enable-float-intrinsics ( -- )
{
- math.private:float+
- math.private:float-
- math.private:float*
- math.private:float/f
- math.private:fixnum>float
- math.private:float>fixnum
- math.private:float<
- math.private:float<=
- math.private:float>
- math.private:float>=
- math.private:float=
- alien.accessors:alien-float
- alien.accessors:set-alien-float
- alien.accessors:alien-double
- alien.accessors:set-alien-double
+ { math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
+ { math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
+ { math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
+ { math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+ { math.private:float< [ drop cc< emit-float-comparison ] }
+ { math.private:float<= [ drop cc<= emit-float-comparison ] }
+ { math.private:float>= [ drop cc>= emit-float-comparison ] }
+ { math.private:float> [ drop cc> emit-float-comparison ] }
+ { math.private:float= [ drop cc= emit-float-comparison ] }
+ { math.private:float>fixnum [ drop emit-float>fixnum ] }
+ { math.private:fixnum>float [ drop emit-fixnum>float ] }
+ { alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] }
+ { alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] }
+ { alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] }
+ { alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] }
} enable-intrinsics ;
: enable-fsqrt ( -- )
- \ math.libm:fsqrt t "intrinsic" set-word-prop ;
+ {
+ { math.libm:fsqrt [ drop emit-fsqrt ] }
+ } enable-intrinsics ;
: enable-float-min/max ( -- )
{
- math.floats.private:float-min
- math.floats.private:float-max
+ { math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
+ { math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
+ } enable-intrinsics ;
+
+: enable-float-functions ( -- )
+ ! Everything except for fsqrt
+ {
+ { math.libm:facos [ drop "acos" emit-unary-float-function ] }
+ { math.libm:fasin [ drop "asin" emit-unary-float-function ] }
+ { math.libm:fatan [ drop "atan" emit-unary-float-function ] }
+ { math.libm:fatan2 [ drop "atan2" emit-binary-float-function ] }
+ { math.libm:fcos [ drop "cos" emit-unary-float-function ] }
+ { math.libm:fsin [ drop "sin" emit-unary-float-function ] }
+ { math.libm:ftan [ drop "tan" emit-unary-float-function ] }
+ { math.libm:fcosh [ drop "cosh" emit-unary-float-function ] }
+ { math.libm:fsinh [ drop "sinh" emit-unary-float-function ] }
+ { math.libm:ftanh [ drop "tanh" emit-unary-float-function ] }
+ { math.libm:fexp [ drop "exp" emit-unary-float-function ] }
+ { math.libm:flog [ drop "log" emit-unary-float-function ] }
+ { math.libm:fpow [ drop "pow" emit-binary-float-function ] }
+ { math.libm:facosh [ drop "acosh" emit-unary-float-function ] }
+ { math.libm:fasinh [ drop "asinh" emit-unary-float-function ] }
+ { math.libm:fatanh [ drop "atanh" emit-unary-float-function ] }
} enable-intrinsics ;
: enable-min/max ( -- )
{
- math.integers.private:fixnum-min
- math.integers.private:fixnum-max
+ { math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] }
+ { math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] }
} enable-intrinsics ;
: enable-fixnum-log2 ( -- )
- { math.integers.private:fixnum-log2 } enable-intrinsics ;
+ {
+ { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
+ } enable-intrinsics ;
: emit-intrinsic ( node word -- )
- {
- { \ kernel.private:tag [ drop emit-tag ] }
- { \ kernel.private:getenv [ emit-getenv ] }
- { \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
- { \ math.private:fixnum+ [ drop emit-fixnum+ ] }
- { \ math.private:fixnum- [ drop emit-fixnum- ] }
- { \ math.private:fixnum* [ drop emit-fixnum* ] }
- { \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
- { \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
- { \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
- { \ math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
- { \ math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
- { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
- { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
- { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
- { \ math.private:fixnum*fast [ drop emit-fixnum*fast ] }
- { \ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
- { \ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
- { \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
- { \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
- { \ kernel:eq? [ drop cc= emit-fixnum-comparison ] }
- { \ math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] }
- { \ math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] }
- { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
- { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
- { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
- { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
- { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
- { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
- { \ math.private:float< [ drop cc< emit-float-comparison ] }
- { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
- { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
- { \ math.private:float> [ drop cc> emit-float-comparison ] }
- { \ math.private:float= [ drop cc= emit-float-comparison ] }
- { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
- { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
- { \ math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
- { \ math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
- { \ math.libm:fsqrt [ drop emit-fsqrt ] }
- { \ slots.private:slot [ emit-slot ] }
- { \ slots.private:set-slot [ emit-set-slot ] }
- { \ strings.private:string-nth [ drop emit-string-nth ] }
- { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
- { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
- { \ arrays:<array> [ emit-<array> ] }
- { \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
- { \ byte-arrays:(byte-array) [ emit-(byte-array) ] }
- { \ kernel:<wrapper> [ emit-simple-allot ] }
- { \ alien:<displaced-alien> [ emit-<displaced-alien> ] }
- { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
- { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
- { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
- { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
- { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
- { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
- { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
- { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
- { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
- { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
- { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
- { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
- { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
- { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
- { \ alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] }
- { \ alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] }
- { \ alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] }
- { \ alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] }
- } case ;
+ "intrinsic" word-prop call( node -- ) ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs heaps kernel namespaces sequences fry math
-math.order combinators arrays sorting compiler.utilities
+math.order combinators arrays sorting compiler.utilities locals
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.splitting
[ drop assign-blocked-register ]
} cond ;
-: handle-interval ( live-interval -- )
- [
- start>>
+: handle-sync-point ( n -- )
+ [ active-intervals get values ] dip
+ [ '[ [ _ spill ] each ] each ]
+ [ drop [ delete-all ] each ]
+ 2bi ;
+
+:: handle-progress ( n sync? -- )
+ n {
[ progress set ]
[ deactivate-intervals ]
- [ activate-intervals ] tri
- ] [ assign-register ] bi ;
+ [ sync? [ handle-sync-point ] [ drop ] if ]
+ [ activate-intervals ]
+ } cleave ;
+
+GENERIC: handle ( obj -- )
+
+M: live-interval handle ( live-interval -- )
+ [ start>> f handle-progress ] [ assign-register ] bi ;
+
+M: sync-point handle ( sync-point -- )
+ n>> t handle-progress ;
+
+: smallest-heap ( heap1 heap2 -- heap )
+ ! If heap1 and heap2 have the same key, favors heap1.
+ [ [ heap-peek nip ] bi@ <= ] most ;
: (allocate-registers) ( -- )
- unhandled-intervals get [ handle-interval ] slurp-heap ;
+ {
+ { [ unhandled-intervals get heap-empty? ] [ unhandled-sync-points get ] }
+ { [ unhandled-sync-points get heap-empty? ] [ unhandled-intervals get ] }
+ ! If a live interval begins at the same location as a sync point,
+ ! process the sync point before the live interval. This ensures that the
+ ! return value of C function calls doesn't get spilled and reloaded
+ ! unnecessarily.
+ [ unhandled-sync-points get unhandled-intervals get smallest-heap ]
+ } cond dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
: finish-allocation ( -- )
active-intervals inactive-intervals
[ get values [ handled-intervals get push-all ] each ] bi@ ;
-: allocate-registers ( live-intervals machine-registers -- live-intervals )
+: allocate-registers ( live-intervals sync-point machine-registers -- live-intervals )
init-allocator
init-unhandled
(allocate-registers)
2bi ;
: assign-spill ( live-interval -- )
- dup vreg>> assign-spill-slot >>spill-to drop ;
+ dup vreg>> vreg-spill-slot >>spill-to drop ;
: spill-before ( before -- before/f )
! If the interval does not have any usages before the spill location,
] if ;
: assign-reload ( live-interval -- )
- dup vreg>> assign-spill-slot >>reload-from drop ;
+ dup vreg>> vreg-spill-slot >>reload-from drop ;
: spill-after ( after -- after/f )
! If the interval has no more usages after the spill location,
rep-size cfg get
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ;
+! Minheap of sync points which still need to be processed
+SYMBOL: unhandled-sync-points
+
! Mapping from vregs to spill slots
SYMBOL: spill-slots
-: assign-spill-slot ( vreg -- n )
+: vreg-spill-slot ( vreg -- n )
spill-slots get [ rep-of next-spill-slot ] cache ;
: init-allocator ( registers -- )
registers set
<min-heap> unhandled-intervals set
+ <min-heap> unhandled-sync-points set
[ V{ } clone ] reg-class-assoc active-intervals set
[ V{ } clone ] reg-class-assoc inactive-intervals set
V{ } clone handled-intervals set
H{ } clone spill-slots set
-1 progress set ;
-: init-unhandled ( live-intervals -- )
- [ [ start>> ] keep ] { } map>assoc
- unhandled-intervals get heap-push-all ;
+: init-unhandled ( live-intervals sync-points -- )
+ [ [ [ start>> ] keep ] { } map>assoc unhandled-intervals get heap-push-all ]
+ [ [ [ n>> ] keep ] { } map>assoc unhandled-sync-points get heap-push-all ]
+ bi* ;
! A utility used by register-status and spill-status words
: free-positions ( new -- assoc )
: remove-pending ( live-interval -- )
vreg>> pending-interval-assoc get delete-at ;
+: (vreg>reg) ( vreg pending -- reg )
+ ! If a live vreg is not in the pending set, then it must
+ ! have been spilled.
+ ?at [ spill-slots get at <spill-slot> ] unless ;
+
+: vreg>reg ( vreg -- reg )
+ pending-interval-assoc get (vreg>reg) ;
+
+: vregs>regs ( vregs -- assoc )
+ dup assoc-empty? [
+ pending-interval-assoc get
+ '[ _ (vreg>reg) ] assoc-map
+ ] unless ;
+
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
GENERIC: assign-registers-in-insn ( insn -- )
-: vreg>reg ( vreg -- reg ) pending-interval-assoc get at ;
-
RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
M: vreg-insn assign-registers-in-insn
[
[
2dup spill-on-gc?
- [ swap [ assign-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
+ [ swap [ vreg-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
] assoc-each
] { } make ;
M: insn assign-registers-in-insn drop ;
-: compute-live-values ( vregs -- assoc )
- ! If a live vreg is not in active or inactive, then it must have been
- ! spilled.
- dup assoc-empty? [
- pending-interval-assoc get
- '[ _ ?at [ ] [ spill-slots get at <spill-slot> ] if ] assoc-map
- ] unless ;
-
: begin-block ( bb -- )
dup basic-block set
dup block-from activate-new-intervals
- [ live-in compute-live-values ] keep
- register-live-ins get set-at ;
+ [ live-in vregs>regs ] keep register-live-ins get set-at ;
: end-block ( bb -- )
- [ live-out compute-live-values ] keep
- register-live-outs get set-at ;
+ [ live-out vregs>regs ] keep register-live-outs get set-at ;
ERROR: bad-vreg vreg ;
[
[ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc
live-intervals set
+ f
] dip
allocate-registers drop ;
covers?
] if ;
-ERROR: dead-value-error vreg ;
+: add-new-range ( from to live-interval -- )
+ [ <live-range> ] dip ranges>> push ;
: shorten-range ( n live-interval -- )
dup ranges>> empty?
- [ vreg>> dead-value-error ] [ ranges>> last (>>from) ] if ;
+ [ dupd add-new-range ] [ ranges>> last (>>from) ] if ;
: extend-range ( from to live-range -- )
ranges>> last
[ min ] change-from
drop ;
-: add-new-range ( from to live-interval -- )
- [ <live-range> ] dip ranges>> push ;
-
: extend-range? ( to live-interval -- ? )
ranges>> [ drop f ] [ last from>> >= ] if-empty ;
2dup extend-range?
[ extend-range ] [ add-new-range ] if ;
-: add-use ( n live-interval -- )
- uses>> push ;
+GENERIC: operands-in-registers? ( insn -- ? )
+
+M: vreg-insn operands-in-registers? drop t ;
+
+M: partial-sync-insn operands-in-registers? drop f ;
+
+: add-def ( insn live-interval -- )
+ [ insn#>> ] [ uses>> ] bi* push ;
+
+: add-use ( insn live-interval -- )
+ ! Every use is a potential def, no SSA here baby!
+ over operands-in-registers? [ add-def ] [ 2drop ] if ;
: <live-interval> ( vreg -- live-interval )
\ live-interval new
M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ;
-M: live-interval clone
- call-next-method [ clone ] change-uses ;
-
! Mapping from vreg to live-interval
SYMBOL: live-intervals
-: live-interval ( vreg live-intervals -- live-interval )
- [ <live-interval> ] cache ;
+: live-interval ( vreg -- live-interval )
+ live-intervals get [ <live-interval> ] cache ;
GENERIC: compute-live-intervals* ( insn -- )
M: insn compute-live-intervals* drop ;
-: handle-output ( n vreg live-intervals -- )
+: handle-output ( insn vreg -- )
live-interval
- [ add-use ] [ shorten-range ] 2bi ;
+ [ [ insn#>> ] dip shorten-range ] [ add-def ] 2bi ;
-: handle-input ( n vreg live-intervals -- )
+: handle-input ( insn vreg -- )
live-interval
- [ [ basic-block get block-from ] 2dip add-range ] [ add-use ] 2bi ;
+ [ [ [ basic-block get block-from ] dip insn#>> ] dip add-range ] [ add-use ] 2bi ;
-: handle-temp ( n vreg live-intervals -- )
+: handle-temp ( insn vreg -- )
live-interval
- [ dupd add-range ] [ add-use ] 2bi ;
+ [ [ insn#>> dup ] dip add-range ] [ add-use ] 2bi ;
M: vreg-insn compute-live-intervals*
- dup insn#>>
- live-intervals get
- [ [ defs-vreg ] 2dip '[ [ _ ] dip _ handle-output ] when* ]
- [ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
- [ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
- 3tri ;
+ [ dup defs-vreg [ handle-output ] with when* ]
+ [ dup uses-vregs [ handle-input ] with each ]
+ [ dup temp-vregs [ handle-temp ] with each ]
+ tri ;
: handle-live-out ( bb -- )
- live-out keys
- basic-block get [ block-from ] [ block-to ] bi
- live-intervals get '[
- [ _ _ ] dip _ live-interval add-range
- ] each ;
+ [ block-from ] [ block-to ] [ live-out keys ] tri
+ [ live-interval add-range ] with with each ;
+
+! A location where all registers have to be spilled
+TUPLE: sync-point n ;
+
+C: <sync-point> sync-point
+
+! Sequence of sync points
+SYMBOL: sync-points
+
+GENERIC: compute-sync-points* ( insn -- )
+
+M: partial-sync-insn compute-sync-points*
+ insn#>> <sync-point> sync-points get push ;
+
+M: insn compute-sync-points* drop ;
: compute-live-intervals-step ( bb -- )
[ basic-block set ]
[ handle-live-out ]
- [ instructions>> <reversed> [ compute-live-intervals* ] each ] tri ;
-
+ [
+ instructions>> <reversed> [
+ [ compute-live-intervals* ]
+ [ compute-sync-points* ]
+ bi
+ ] each
+ ] tri ;
+
+: init-live-intervals ( -- )
+ H{ } clone live-intervals set
+ V{ } clone sync-points set ;
+
: compute-start/end ( live-interval -- )
dup ranges>> [ first from>> ] [ last to>> ] bi
[ >>start ] [ >>end ] bi* drop ;
: check-start ( live-interval -- )
dup start>> -1 = [ bad-live-interval ] [ drop ] if ;
-: finish-live-intervals ( live-intervals -- )
+: finish-live-intervals ( live-intervals -- seq )
! Since live intervals are computed in a backward order, we have
! to reverse some sequences, and compute the start and end.
- [
+ values dup [
{
[ ranges>> reverse-here ]
[ uses>> reverse-here ]
} cleave
] each ;
-: compute-live-intervals ( cfg -- live-intervals )
- H{ } clone [
- live-intervals set
- linearization-order <reversed>
- [ compute-live-intervals-step ] each
- ] keep values dup finish-live-intervals ;
+: compute-live-intervals ( cfg -- live-intervals sync-points )
+ init-live-intervals
+ linearization-order <reversed> [ compute-live-intervals-step ] each
+ live-intervals get finish-live-intervals
+ sync-points get ;
: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
TEMP-QUOT change-temp drop ;
M: ##box-displaced-alien rename-insn-temps
- TEMP-QUOT change-temp drop ;
+ TEMP-QUOT change-temp1
+ TEMP-QUOT change-temp2
+ drop ;
M: ##compare rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##set-slot temp-vreg-reps drop { int-rep } ;
M: ##string-nth temp-vreg-reps drop { int-rep } ;
M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
-M: ##box-displaced-alien temp-vreg-reps drop { int-rep } ;
+M: ##box-displaced-alien temp-vreg-reps drop { int-rep int-rep } ;
M: ##compare temp-vreg-reps drop { int-rep } ;
M: ##compare-imm temp-vreg-reps drop { int-rep } ;
M: ##compare-float temp-vreg-reps drop { int-rep } ;
TUPLE: compare-expr < binary-expr cc ;
TUPLE: constant-expr < expr value ;
TUPLE: reference-expr < expr value ;
+TUPLE: unary-float-function-expr < expr in func ;
+TUPLE: binary-float-function-expr < expr in1 in2 func ;
TUPLE: box-displaced-alien-expr < expr displacement base base-class ;
: <constant> ( constant -- expr )
[ base-class>> ]
} cleave box-displaced-alien-expr boa ;
+M: ##unary-float-function >expr
+ [ class ] [ src>> vreg>vn ] [ func>> ] tri
+ unary-float-function-expr boa ;
+
+M: ##binary-float-function >expr
+ {
+ [ class ]
+ [ src1>> vreg>vn ]
+ [ src2>> vreg>vn ]
+ [ func>> ]
+ } cleave
+ binary-float-function-expr boa ;
+
M: ##flushable >expr drop next-input-expr ;
: init-expressions ( -- )
M: ##sqrt generate-insn dst/src %sqrt ;
+M: ##unary-float-function generate-insn
+ [ dst/src ] [ func>> ] bi %unary-float-function ;
+
+M: ##binary-float-function generate-insn
+ [ dst/src1/src2 ] [ func>> ] bi %binary-float-function ;
+
M: ##integer>float generate-insn dst/src %integer>float ;
M: ##float>integer generate-insn dst/src %float>integer ;
M: ##box-alien generate-insn dst/src/temp %box-alien ;
M: ##box-displaced-alien generate-insn
- [ dst/src1/src2 ] [ temp>> ] bi %box-displaced-alien ;
+ [ dst/src1/src2 ] [ temp1>> ] [ temp2>> ] tri %box-displaced-alien ;
M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make alien.c-types combinators.short-circuit
-math.order ;
+math.order math.libm math.parser ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
: missing-gc-check-1 ( a -- b ) { fixnum } declare <alien> ;
: missing-gc-check-2 ( -- ) 10000000 [ missing-gc-check-1 drop ] each-integer ;
-[ ] [ missing-gc-check-2 ] unit-test
\ No newline at end of file
+[ ] [ missing-gc-check-2 ] unit-test
+
+[ 1 "0.169967142900241" ] [ 1.4 [ 1 swap fcos ] compile-call number>string ] unit-test
+[ 1 "0.169967142900241" ] [ 1.4 1 [ swap fcos ] compile-call number>string ] unit-test
+[ "0.169967142900241" "0.9854497299884601" ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
+[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
\ No newline at end of file
underlying>>
] unit-test
+[ ALIEN: 1234 ALIEN: 2234 ] [
+ ALIEN: 234 [
+ { c-ptr } declare
+ [ 1000 swap <displaced-alien> ]
+ [ 2000 swap <displaced-alien> ] bi
+ ] compile-call
+] unit-test
+
[
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
] must-fail
HOOK: %min-float cpu ( dst src1 src2 -- )
HOOK: %max-float cpu ( dst src1 src2 -- )
HOOK: %sqrt cpu ( dst src -- )
+HOOK: %unary-float-function cpu ( dst src func -- )
+HOOK: %binary-float-function cpu ( dst src1 src2 func -- )
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %box-float cpu ( dst src temp -- )
HOOK: %box-alien cpu ( dst src temp -- )
-HOOK: %box-displaced-alien cpu ( dst displacement base temp -- )
+HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 -- )
HOOK: %alien-unsigned-1 cpu ( dst src -- )
HOOK: %alien-unsigned-2 cpu ( dst src -- )
"f" resolve-label
] with-scope ;
-M:: ppc %box-displaced-alien ( dst displacement base temp -- )
+M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- )
[
"end" define-label
"ok" define-label
dst base MR
0 displacement 0 CMPI
"end" get BEQ
+ ! Quickly use displacement' before its needed for real, as allot temporary
+ displacement' :> temp
+ dst 4 cells alien temp %allot
! If base is already a displaced alien, unpack it
+ base' base MR
+ displacement' displacement MR
0 base \ f tag-number CMPI
"ok" get BEQ
temp base header-offset LWZ
"ok" get BNE
! displacement += base.displacement
temp base 3 alien@ LWZ
- displacement displacement temp ADD
+ displacement' displacement temp ADD
! base = base.base
- base base 1 alien@ LWZ
+ base' base 1 alien@ LWZ
"ok" resolve-label
- dst displacement base temp %allot-alien
+ ! Store underlying-alien slot
+ base' dst 1 alien@ STW
+ ! Store offset
+ displacement' dst 3 alien@ STW
+ ! Store expired slot (its ok to clobber displacement')
+ temp \ f tag-number %load-immediate
+ temp dst 2 alien@ STW
"end" resolve-label
] with-scope ;
! Unbox former top of data stack to return registers
unbox-return ;
+: float-function-param ( i spill-slot -- )
+ [ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ;
+
+: float-function-return ( reg -- )
+ float-regs return-reg double-float-rep copy-register ;
+
+M:: x86.64 %unary-float-function ( dst src func -- )
+ 0 src float-function-param
+ func f %alien-invoke
+ dst float-function-return ;
+
+M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
+ 0 src1 float-function-param
+ 1 src2 float-function-param
+ func f %alien-invoke
+ dst float-function-return ;
+
! The result of reading 4 bytes from memory is a fixnum on
! x86-64.
enable-alien-4-intrinsics
! SSE2 is always available on x86-64.
enable-sse2
+! Enable fast calling of libc math functions
+enable-float-functions
+
USE: vocabs.loader
{
"end" resolve-label
] with-scope ;
-M:: x86 %box-displaced-alien ( dst displacement base temp -- )
+M:: x86 %box-displaced-alien ( dst displacement base displacement' base' -- )
[
"end" define-label
"ok" define-label
dst base MOV
displacement 0 CMP
"end" get JE
+ ! Quickly use displacement' before its needed for real, as allot temporary
+ dst 4 cells alien displacement' %allot
! If base is already a displaced alien, unpack it
+ base' base MOV
+ displacement' displacement MOV
base \ f tag-number CMP
"ok" get JE
base header-offset [+] alien type-number tag-fixnum CMP
"ok" get JNE
! displacement += base.displacement
- displacement base 3 alien@ ADD
+ displacement' base 3 alien@ ADD
! base = base.base
- base base 1 alien@ MOV
+ base' base 1 alien@ MOV
"ok" resolve-label
- dst displacement base temp %allot-alien
+ dst 1 alien@ base' MOV ! alien
+ dst 2 alien@ \ f tag-number MOV ! expired
+ dst 3 alien@ displacement' MOV ! displacement
"end" resolve-label
] with-scope ;
{ $subsection "complex-numbers" }
"Advanced features:"
{ $subsection "math-vectors" }
-{ $subsection "math-intervals" }
-{ $subsection "math-bitfields" }
-"Implementation:"
-{ $subsection "math.libm" } ;
+{ $subsection "math-intervals" } ;
USE: io.buffers
io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces
-sequences sequences.deep images.loader ;
+sequences sequences.deep images.loader io.streams.limited ;
IN: images.jpeg
QUALIFIED-WITH: bitstreams bs
] with-byte-reader ;
: decode-huff-table ( chunk -- )
- data>>
- binary
- [
- 1 ! %fixme: Should handle multiple tables at once
+ data>> [ binary <byte-reader> ] [ length ] bi
+ stream-throws limit
+ [
+ [ input-stream get [ count>> ] [ limit>> ] bi < ]
[
read4/4 swap 2 * +
16 read
dup [ ] [ + ] map-reduce read
binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
swap jpeg> huff-tables>> set-nth
- ] times
- ] with-byte-reader ;
+ ] while
+ ] with-input-stream* ;
: decode-scan ( chunk -- )
data>>
: singleton-first ( seq -- elt )
[ length 1 assert= ] [ first ] bi ;
+ERROR: not-a-baseline-jpeg-image ;
+
: baseline-parse ( -- )
+ jpeg> headers>> [ type>> { SOF 0 } = ] any? [ not-a-baseline-jpeg-image ] unless
jpeg> headers>>
{
[ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
: V.M ( x A -- x.A ) Mtranspose swap M.V ;
: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
-: idct ( b -- b' ) idct-blas ;
+: idct ( b -- b' ) idct-factor ;
:: draw-block ( block x,y color-id jpeg-image -- )
block dup length>> sqrt >fixnum group flip
! 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 ;
+unix.kqueue unix.time assocs io.backend.unix.multiplexers
+classes.struct ;
IN: io.backend.unix.multiplexers.kqueue
TUPLE: kqueue-mx < mx events ;
-: max-events ( -- n )
- #! We read up to 256 events at a time. This is an arbitrary
- #! constant...
- 256 ; inline
+! We read up to 256 events at a time. This is an arbitrary
+! constant...
+CONSTANT: max-events 256
: <kqueue-mx> ( -- mx )
kqueue-mx new-mx
kqueue dup io-error >>fd
- max-events "kevent" <struct-array> >>events ;
+ max-events \ kevent <struct-array> >>events ;
M: kqueue-mx dispose* fd>> close-file ;
: make-kevent ( fd filter flags -- event )
- "kevent" <c-object>
- [ set-kevent-flags ] keep
- [ set-kevent-filter ] keep
- [ set-kevent-ident ] keep ;
+ \ kevent <struct>
+ swap >>flags
+ swap >>filter
+ swap >>ident ;
: register-kevent ( kevent mx -- )
fd>> swap 1 f 0 f kevent io-error ;
] dip kevent multiplexer-error ;
: handle-kevent ( mx kevent -- )
- [ kevent-ident swap ] [ kevent-filter ] bi {
+ [ ident>> swap ] [ filter>> ] bi {
{ EVFILT_READ [ input-available ] }
{ EVFILT_WRITE [ output-available ] }
} case ;
: handle-kevents ( mx n -- )
- [ dup events>> ] dip head-slice [ handle-kevent ] with each ;
+ [ dup events>> ] dip head-slice
+ [ handle-kevent ] with each ;
M: kqueue-mx wait-for-events ( us mx -- )
swap dup [ make-timespec ] when
[ datagram-client delete-file ] ignore-errors
-datagram-client <local> <datagram>
-"d" set
+[ ] [ datagram-client <local> <datagram> "d" set ] unit-test
[ ] [
"hello" >byte-array
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types io.directories.unix kernel system unix ;
+USING: alien.c-types io.directories.unix kernel system unix
+classes.struct ;
IN: io.directories.unix.linux
-M: unix find-next-file ( DIR* -- byte-array )
- "dirent" <c-object>
+M: unix find-next-file ( DIR* -- dirent )
+ dirent <struct>
f <void*>
[ readdir64_r 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;
continuations destructors fry io io.backend io.backend.unix
io.directories io.encodings.binary io.encodings.utf8 io.files
io.pathnames io.files.types kernel math.bitwise sequences system
-unix unix.stat vocabs.loader ;
+unix unix.stat vocabs.loader classes.struct ;
IN: io.directories.unix
: touch-mode ( -- n )
HOOK: find-next-file os ( DIR* -- byte-array )
M: unix find-next-file ( DIR* -- byte-array )
- "dirent" <c-object>
+ dirent <struct>
f <void*>
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;
M: unix >directory-entry ( byte-array -- directory-entry )
{
- [ dirent-d_name underlying>> utf8 alien>string ]
- [ dirent-d_type dirent-type>file-type ]
+ [ d_name>> underlying>> utf8 alien>string ]
+ [ d_type>> dirent-type>file-type ]
} cleave directory-entry boa ;
M: unix (directory-entries) ( path -- seq )
M: bsd stat>file-info ( stat -- file-info )
[ call-next-method ] keep
{
- [ stat-st_flags >>flags ]
- [ stat-st_gen >>gen ]
- [
- stat-st_birthtimespec timespec>unix-time
- >>birth-time
- ]
+ [ st_flags>> >>flags ]
+ [ st_gen>> >>gen ]
+ [ st_birthtimespec>> timespec>unix-time >>birth-time ]
} cleave ;
io.backend io.files io.files.info io.files.unix kernel math system unix
unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
sequences grouping alien.strings io.encodings.utf8 unix.types
-specialized-arrays.direct.uint arrays io.files.info.unix ;
+arrays io.files.info.unix classes.struct ;
IN: io.files.info.unix.freebsd
TUPLE: freebsd-file-system-info < unix-file-system-info
M: freebsd new-file-system-info freebsd-file-system-info new ;
M: freebsd file-system-statfs ( path -- byte-array )
- "statfs" <c-object> [ statfs io-error ] keep ;
+ \ statfs <struct> [ statfs io-error ] keep ;
M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
- [ statfs-f_version >>version ]
- [ statfs-f_type >>type ]
- [ statfs-f_flags >>flags ]
- [ statfs-f_bsize >>block-size ]
- [ statfs-f_iosize >>io-size ]
- [ statfs-f_blocks >>blocks ]
- [ statfs-f_bfree >>blocks-free ]
- [ statfs-f_bavail >>blocks-available ]
- [ statfs-f_files >>files ]
- [ statfs-f_ffree >>files-free ]
- [ statfs-f_syncwrites >>syncwrites ]
- [ statfs-f_asyncwrites >>asyncwrites ]
- [ statfs-f_syncreads >>syncreads ]
- [ statfs-f_asyncreads >>asyncreads ]
- [ statfs-f_namemax >>name-max ]
- [ statfs-f_owner >>owner ]
- [ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
- [ statfs-f_fstypename utf8 alien>string >>type ]
- [ statfs-f_mntfromname utf8 alien>string >>device-name ]
- [ statfs-f_mntonname utf8 alien>string >>mount-point ]
+ [ f_version>> >>version ]
+ [ f_type>> >>type ]
+ [ f_flags>> >>flags ]
+ [ f_bsize>> >>block-size ]
+ [ f_iosize>> >>io-size ]
+ [ f_blocks>> >>blocks ]
+ [ f_bfree>> >>blocks-free ]
+ [ f_bavail>> >>blocks-available ]
+ [ f_files>> >>files ]
+ [ f_ffree>> >>files-free ]
+ [ f_syncwrites>> >>syncwrites ]
+ [ f_asyncwrites>> >>asyncwrites ]
+ [ f_syncreads>> >>syncreads ]
+ [ f_asyncreads>> >>asyncreads ]
+ [ f_namemax>> >>name-max ]
+ [ f_owner>> >>owner ]
+ [ f_fsid>> >>id ]
+ [ f_fstypename>> utf8 alien>string >>type ]
+ [ f_mntfromname>> utf8 alien>string >>device-name ]
+ [ f_mntonname>> utf8 alien>string >>mount-point ]
} cleave ;
M: freebsd file-system-statvfs ( path -- byte-array )
- "statvfs" <c-object> [ statvfs io-error ] keep ;
+ \ statvfs <struct> [ \ statvfs io-error ] keep ;
M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
- [ statvfs-f_favail >>files-available ]
- [ statvfs-f_frsize >>preferred-block-size ]
+ [ f_favail>> >>files-available ]
+ [ f_frsize>> >>preferred-block-size ]
} cleave ;
M: freebsd file-systems ( -- array )
f 0 0 getfsstat dup io-error
- "statfs" <c-array> dup dup length 0 getfsstat io-error
- "statfs" heap-size group
- [ statfs-f_mntonname alien>native-string file-system-info ] map ;
+ \ statfs <struct> dup dup length 0 getfsstat io-error
+ statfs heap-size group
+ [ f_mntonname>> alien>native-string file-system-info ] map ;
io.backend io.encodings.utf8 io.files io.files.info io.streams.string
io.files.unix kernel math.order namespaces sequences sorting
system unix unix.statfs.linux unix.statvfs.linux io.files.links
-specialized-arrays.direct.uint arrays io.files.info.unix assocs
-io.pathnames unix.types ;
+arrays io.files.info.unix assocs io.pathnames unix.types
+classes.struct ;
FROM: csv => delimiter ;
IN: io.files.info.unix.linux
M: linux new-file-system-info linux-file-system-info new ;
M: linux file-system-statfs ( path -- byte-array )
- "statfs64" <c-object> [ statfs64 io-error ] keep ;
+ \ statfs64 <struct> [ statfs64 io-error ] keep ;
M: linux statfs>file-system-info ( struct -- statfs )
{
- [ statfs64-f_type >>type ]
- [ statfs64-f_bsize >>block-size ]
- [ statfs64-f_blocks >>blocks ]
- [ statfs64-f_bfree >>blocks-free ]
- [ statfs64-f_bavail >>blocks-available ]
- [ statfs64-f_files >>files ]
- [ statfs64-f_ffree >>files-free ]
- [ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
- [ statfs64-f_namelen >>namelen ]
- [ statfs64-f_frsize >>preferred-block-size ]
+ [ f_type>> >>type ]
+ [ f_bsize>> >>block-size ]
+ [ f_blocks>> >>blocks ]
+ [ f_bfree>> >>blocks-free ]
+ [ f_bavail>> >>blocks-available ]
+ [ f_files>> >>files ]
+ [ f_ffree>> >>files-free ]
+ [ f_fsid>> >>id ]
+ [ f_namelen>> >>namelen ]
+ [ f_frsize>> >>preferred-block-size ]
! [ statfs64-f_spare >>spare ]
} cleave ;
M: linux file-system-statvfs ( path -- byte-array )
- "statvfs64" <c-object> [ statvfs64 io-error ] keep ;
+ \ statvfs64 <struct> [ statvfs64 io-error ] keep ;
M: linux statvfs>file-system-info ( struct -- statfs )
{
- [ statvfs64-f_flag >>flags ]
- [ statvfs64-f_namemax >>name-max ]
+ [ f_flag>> >>flags ]
+ [ f_namemax>> >>name-max ]
} cleave ;
TUPLE: mtab-entry file-system-name mount-point type options
grouping io.encodings.utf8 io.files kernel math sequences
system unix io.files.unix specialized-arrays.direct.uint arrays
unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx
-io.files.info.unix io.files.info ;
+io.files.info.unix io.files.info classes.struct struct-arrays ;
IN: io.files.info.unix.macosx
TUPLE: macosx-file-system-info < unix-file-system-info
M: macosx file-systems ( -- array )
f <void*> dup 0 getmntinfo64 dup io-error
- [ *void* ] dip
- "statfs64" heap-size [ * memory>byte-array ] keep group
- [ statfs64-f_mntonname utf8 alien>string file-system-info ] map ;
- ! [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
+ [ *void* ] dip \ statfs64 <direct-struct-array>
+ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ;
M: macosx new-file-system-info macosx-file-system-info new ;
M: macosx file-system-statfs ( normalized-path -- statfs )
- "statfs64" <c-object> [ statfs64 io-error ] keep ;
+ \ statfs64 <struct> [ statfs64 io-error ] keep ;
M: macosx file-system-statvfs ( normalized-path -- statvfs )
- "statvfs" <c-object> [ statvfs io-error ] keep ;
+ \ statvfs <struct> [ statvfs io-error ] keep ;
M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{
- [ statfs64-f_bsize >>block-size ]
- [ statfs64-f_iosize >>io-size ]
- [ statfs64-f_blocks >>blocks ]
- [ statfs64-f_bfree >>blocks-free ]
- [ statfs64-f_bavail >>blocks-available ]
- [ statfs64-f_files >>files ]
- [ statfs64-f_ffree >>files-free ]
- [ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
- [ statfs64-f_owner >>owner ]
- [ statfs64-f_type >>type-id ]
- [ statfs64-f_flags >>flags ]
- [ statfs64-f_fssubtype >>filesystem-subtype ]
- [ statfs64-f_fstypename utf8 alien>string >>type ]
- [ statfs64-f_mntonname utf8 alien>string >>mount-point ]
- [ statfs64-f_mntfromname utf8 alien>string >>device-name ]
+ [ f_bsize>> >>block-size ]
+ [ f_iosize>> >>io-size ]
+ [ f_blocks>> >>blocks ]
+ [ f_bfree>> >>blocks-free ]
+ [ f_bavail>> >>blocks-available ]
+ [ f_files>> >>files ]
+ [ f_ffree>> >>files-free ]
+ [ f_fsid>> >>id ]
+ [ f_owner>> >>owner ]
+ [ f_type>> >>type-id ]
+ [ f_flags>> >>flags ]
+ [ f_fssubtype>> >>filesystem-subtype ]
+ [ f_fstypename>> utf8 alien>string >>type ]
+ [ f_mntonname>> utf8 alien>string >>mount-point ]
+ [ f_mntfromname>> utf8 alien>string >>device-name ]
} cleave ;
M: macosx statvfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{
- [ statvfs-f_frsize >>preferred-block-size ]
- [ statvfs-f_favail >>files-available ]
- [ statvfs-f_namemax >>name-max ]
+ [ f_frsize>> >>preferred-block-size ]
+ [ f_favail>> >>files-available ]
+ [ f_namemax>> >>name-max ]
} cleave ;
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types io.files.unix
io.files io.files.info unix.statvfs.netbsd unix.getfsstat.netbsd arrays
-grouping sequences io.encodings.utf8
-specialized-arrays.direct.uint io.files.info.unix ;
+grouping sequences io.encodings.utf8 classes.struct
+io.files.info.unix ;
IN: io.files.info.unix.netbsd
TUPLE: netbsd-file-system-info < unix-file-system-info
M: netbsd new-file-system-info netbsd-file-system-info new ;
M: netbsd file-system-statvfs
- "statvfs" <c-object> [ statvfs io-error ] keep ;
+ \ statvfs <struct> [ statvfs io-error ] keep ;
M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{
- [ statvfs-f_flag >>flags ]
- [ statvfs-f_bsize >>block-size ]
- [ statvfs-f_frsize >>preferred-block-size ]
- [ statvfs-f_iosize >>io-size ]
- [ statvfs-f_blocks >>blocks ]
- [ statvfs-f_bfree >>blocks-free ]
- [ statvfs-f_bavail >>blocks-available ]
- [ statvfs-f_bresvd >>blocks-reserved ]
- [ statvfs-f_files >>files ]
- [ statvfs-f_ffree >>files-free ]
- [ statvfs-f_favail >>files-available ]
- [ statvfs-f_fresvd >>files-reserved ]
- [ statvfs-f_syncreads >>sync-reads ]
- [ statvfs-f_syncwrites >>sync-writes ]
- [ statvfs-f_asyncreads >>async-reads ]
- [ statvfs-f_asyncwrites >>async-writes ]
- [ statvfs-f_fsidx 2 <direct-uint-array> >array >>idx ]
- [ statvfs-f_fsid >>id ]
- [ statvfs-f_namemax >>name-max ]
- [ statvfs-f_owner >>owner ]
- ! [ statvfs-f_spare >>spare ]
- [ statvfs-f_fstypename utf8 alien>string >>type ]
- [ statvfs-f_mntonname utf8 alien>string >>mount-point ]
- [ statvfs-f_mntfromname utf8 alien>string >>device-name ]
+ [ f_flag>> >>flags ]
+ [ f_bsize>> >>block-size ]
+ [ f_frsize>> >>preferred-block-size ]
+ [ f_iosize>> >>io-size ]
+ [ f_blocks>> >>blocks ]
+ [ f_bfree>> >>blocks-free ]
+ [ f_bavail>> >>blocks-available ]
+ [ f_bresvd>> >>blocks-reserved ]
+ [ f_files>> >>files ]
+ [ f_ffree>> >>files-free ]
+ [ f_favail>> >>files-available ]
+ [ f_fresvd>> >>files-reserved ]
+ [ f_syncreads>> >>sync-reads ]
+ [ f_syncwrites>> >>sync-writes ]
+ [ f_asyncreads>> >>async-reads ]
+ [ f_asyncwrites>> >>async-writes ]
+ [ f_fsidx>> >>idx ]
+ [ f_fsid>> >>id ]
+ [ f_namemax>> >>name-max ]
+ [ f_owner>> >>owner ]
+ [ f_fstypename>> utf8 alien>string >>type ]
+ [ f_mntonname>> utf8 alien>string >>mount-point ]
+ [ f_mntfromname>> utf8 alien>string >>device-name ]
} cleave ;
M: netbsd file-systems ( -- array )
f 0 0 getvfsstat dup io-error
- "statvfs" <c-array> dup dup length 0 getvfsstat io-error
- "statvfs" heap-size group
- [ statvfs-f_mntonname utf8 alien>string file-system-info ] map ;
+ \ statvfs <c-type-array> dup dup length 0 getvfsstat io-error
+ \ statvfs heap-size group
+ [ f_mntonname>> utf8 alien>string file-system-info ] map ;
combinators io.backend io.files io.files.info io.files.unix kernel math
sequences system unix unix.getfsstat.openbsd grouping
unix.statfs.openbsd unix.statvfs.openbsd unix.types
-specialized-arrays.direct.uint arrays io.files.info.unix ;
+arrays io.files.info.unix classes.struct ;
IN: io.files.unix.openbsd
TUPLE: freebsd-file-system-info < unix-file-system-info
M: openbsd new-file-system-info freebsd-file-system-info new ;
M: openbsd file-system-statfs
- "statfs" <c-object> [ statfs io-error ] keep ;
+ \ statfs <struct> [ statfs io-error ] keep ;
M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' )
{
- [ statfs-f_flags >>flags ]
- [ statfs-f_bsize >>block-size ]
- [ statfs-f_iosize >>io-size ]
- [ statfs-f_blocks >>blocks ]
- [ statfs-f_bfree >>blocks-free ]
- [ statfs-f_bavail >>blocks-available ]
- [ statfs-f_files >>files ]
- [ statfs-f_ffree >>files-free ]
- [ statfs-f_favail >>files-available ]
- [ statfs-f_syncwrites >>sync-writes ]
- [ statfs-f_syncreads >>sync-reads ]
- [ statfs-f_asyncwrites >>async-writes ]
- [ statfs-f_asyncreads >>async-reads ]
- [ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
- [ statfs-f_namemax >>name-max ]
- [ statfs-f_owner >>owner ]
- ! [ statfs-f_spare >>spare ]
- [ statfs-f_fstypename alien>native-string >>type ]
- [ statfs-f_mntonname alien>native-string >>mount-point ]
- [ statfs-f_mntfromname alien>native-string >>device-name ]
+ [ f_flags>> >>flags ]
+ [ f_bsize>> >>block-size ]
+ [ f_iosize>> >>io-size ]
+ [ f_blocks>> >>blocks ]
+ [ f_bfree>> >>blocks-free ]
+ [ f_bavail>> >>blocks-available ]
+ [ f_files>> >>files ]
+ [ f_ffree>> >>files-free ]
+ [ f_favail>> >>files-available ]
+ [ f_syncwrites>> >>sync-writes ]
+ [ f_syncreads>> >>sync-reads ]
+ [ f_asyncwrites>> >>async-writes ]
+ [ f_asyncreads>> >>async-reads ]
+ [ f_fsid>> >>id ]
+ [ f_namemax>> >>name-max ]
+ [ f_owner>> >>owner ]
+ [ f_fstypename>> alien>native-string >>type ]
+ [ f_mntonname>> alien>native-string >>mount-point ]
+ [ f_mntfromname>> alien>native-string >>device-name ]
} cleave ;
M: openbsd file-system-statvfs ( normalized-path -- statvfs )
- "statvfs" <c-object> [ statvfs io-error ] keep ;
+ \ statvfs <struct> [ statvfs io-error ] keep ;
M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
- {
- [ statvfs-f_frsize >>preferred-block-size ]
- } cleave ;
+ f_frsize>> >>preferred-block-size ;
M: openbsd file-systems ( -- seq )
f 0 0 getfsstat dup io-error
- "statfs" <c-array> dup dup length 0 getfsstat io-error
- "statfs" heap-size group
- [ statfs-f_mntonname alien>native-string file-system-info ] map ;
+ \ statfs <c-type-array> dup dup length 0 getfsstat io-error
+ \ statfs heap-size group
+ [ f_mntonname>> alien>native-string file-system-info ] map ;
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 ;
+unix.groups classes.struct struct-arrays ;
IN: io.files.info.unix
TUPLE: unix-file-system-info < file-system-info
[ new-file-info ] dip
{
[ stat>type >>type ]
- [ stat-st_size >>size ]
- [ stat-st_mode >>permissions ]
- [ stat-st_ctimespec timespec>unix-time >>created ]
- [ stat-st_mtimespec timespec>unix-time >>modified ]
- [ stat-st_atimespec timespec>unix-time >>accessed ]
- [ stat-st_uid >>uid ]
- [ stat-st_gid >>gid ]
- [ stat-st_dev >>dev ]
- [ stat-st_ino >>ino ]
- [ stat-st_nlink >>nlink ]
- [ stat-st_rdev >>rdev ]
- [ stat-st_blocks >>blocks ]
- [ stat-st_blksize >>blocksize ]
+ [ st_size>> >>size ]
+ [ st_mode>> >>permissions ]
+ [ st_ctimespec>> timespec>unix-time >>created ]
+ [ st_mtimespec>> timespec>unix-time >>modified ]
+ [ st_atimespec>> timespec>unix-time >>accessed ]
+ [ st_uid>> >>uid ]
+ [ st_gid>> >>gid ]
+ [ st_dev>> >>dev ]
+ [ st_ino>> >>ino ]
+ [ st_nlink>> >>nlink ]
+ [ st_rdev>> >>rdev ]
+ [ st_blocks>> >>blocks ]
+ [ st_blksize>> >>blocksize ]
[ drop dup blocks>> standard-unix-block-size * >>size-on-disk ]
} cleave ;
} case ;
M: unix stat>type ( stat -- type )
- stat-st_mode n>file-type ;
+ st_mode>> n>file-type ;
<PRIVATE
: stat-mode ( path -- mode )
- normalize-path file-status stat-st_mode ;
+ normalize-path file-status st_mode>> ;
: chmod-set-bit ( path mask ? -- )
[ dup stat-mode ] 2dip
<PRIVATE
-: make-timeval-array ( array -- byte-array )
- [ [ "timeval" <c-object> ] unless* ] map concat ;
-
: timestamp>timeval ( timestamp -- timeval )
unix-1970 time- duration>microseconds make-timeval ;
: timestamps>byte-array ( timestamps -- byte-array )
- [ dup [ timestamp>timeval ] when ] map make-timeval-array ;
+ [ [ timestamp>timeval ] [ \ timeval <struct> ] if* ] map
+ \ timeval >struct-array ;
PRIVATE>
f swap 2array set-file-times ;
: set-file-ids ( path uid gid -- )
- [ normalize-path ] 2dip
- [ [ -1 ] unless* ] bi@ chown io-error ;
+ [ normalize-path ] 2dip [ -1 or ] bi@ chown io-error ;
GENERIC: set-file-user ( path string/id -- )
: server-socket-fd ( addrspec type -- fd )
[ dup protocol-family ] dip socket-fd
- dup init-server-socket
- dup handle-fd rot make-sockaddr/size bind io-error ;
+ [ init-server-socket ] keep
+ [ handle-fd swap make-sockaddr/size bind io-error ] keep ;
M: object (server) ( addrspec -- handle )
[
dup length 1 + max-un-path > [ "Path too long" throw ] when
"sockaddr-un" <c-object>
AF_UNIX over set-sockaddr-un-family
- dup sockaddr-un-path rot utf8 string>alien dup length memcpy ;
+ [ [ utf8 string>alien ] dip set-sockaddr-un-path ] keep ;
M: local parse-sockaddr
drop
ABOUT: "math.bits"
ARTICLE: "math.bits" "Number bits virtual sequence"
+"The " { $vocab-link "math.bits" } " vocabulary implements a virtual sequence which presents an integer as a sequence of bits, with the first element of the sequence being the least significant bit of the integer."
{ $subsection bits }
{ $subsection <bits> }
{ $subsection make-bits } ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private
-math.libm math.functions arrays math.functions.private sequences
-parser ;
+math.functions arrays math.functions.private sequences parser ;
IN: math.complex.private
M: real real-part ; inline
M: complex / [ / ] complex/ ; inline
M: complex /f [ /f ] complex/ ; inline
M: complex /i [ /i ] complex/ ; inline
-M: complex abs absq >float fsqrt ; inline
-M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; inline
+M: complex abs absq sqrt ; inline
+M: complex sqrt >polar [ sqrt ] [ 2.0 / ] bi* polar> ; inline
IN: syntax
[ 0 ] [ 0 3 ^ ] unit-test
[ 0.0 ] [ 1 log ] unit-test
+[ 0.0 ] [ 1.0 log ] unit-test
+[ 1.0 ] [ e log ] unit-test
+
+[ t ] [ 1 exp e = ] unit-test
+[ t ] [ 1.0 exp e = ] unit-test
+[ 1.0 ] [ -1 exp e * ] unit-test
[ 1.0 ] [ 0 cosh ] unit-test
+[ 1.0 ] [ 0.0 cosh ] unit-test
[ 0.0 ] [ 1 acosh ] unit-test
+[ 0.0 ] [ 1.0 acosh ] unit-test
[ 1.0 ] [ 0 cos ] unit-test
+[ 1.0 ] [ 0.0 cos ] unit-test
[ 0.0 ] [ 1 acos ] unit-test
+[ 0.0 ] [ 1.0 acos ] unit-test
[ 0.0 ] [ 0 sinh ] unit-test
+[ 0.0 ] [ 0.0 sinh ] unit-test
[ 0.0 ] [ 0 asinh ] unit-test
+[ 0.0 ] [ 0.0 asinh ] unit-test
[ 0.0 ] [ 0 sin ] unit-test
+[ 0.0 ] [ 0.0 sin ] unit-test
[ 0.0 ] [ 0 asin ] unit-test
+[ 0.0 ] [ 0.0 asin ] unit-test
+
+[ 0.0 ] [ 0 tan ] unit-test
+[ t ] [ pi 2 / tan 1.e10 > ] unit-test
[ t ] [ 10 atan real? ] unit-test
+[ t ] [ 10.0 atan real? ] unit-test
[ f ] [ 10 atanh real? ] unit-test
+[ f ] [ 10.0 atanh real? ] unit-test
[ t ] [ 10 asin sin 10 1.e-10 ~ ] unit-test
[ t ] [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test
: >polar ( z -- abs arg )
>float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ; inline
-: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
+: cis ( arg -- z ) >float [ fcos ] [ fsin ] bi rect> ; inline
: polar> ( abs arg -- z ) cis * ; inline
+GENERIC: exp ( x -- y )
+
+M: float exp fexp ; inline
+
+M: real exp >float exp ; inline
+
+M: complex exp >rect swap fexp swap polar> ; inline
+
<PRIVATE
: ^mag ( w abs arg -- magnitude )
- [ >float-rect swap ] [ swap fpow ] [ rot * fexp /f ] tri* ; inline
+ [ >float-rect swap ]
+ [ >float swap >float fpow ]
+ [ rot * exp /f ]
+ tri* ; inline
: ^theta ( w abs arg -- theta )
[ >float-rect ] [ flog * swap ] [ * + ] tri* ; inline
{
{ [ over 0 = ] [ nip 0^ ] }
{ [ dup integer? ] [ integer^ ] }
- { [ 2dup real^? ] [ fpow ] }
+ { [ 2dup real^? ] [ [ >float ] bi@ fpow ] }
[ ^complex ]
} cond ; inline
: >=1? ( x -- ? )
dup complex? [ drop f ] [ 1 >= ] if ; inline
-GENERIC: exp ( x -- y )
-
-M: real exp fexp ; inline
-
-M: complex exp >rect swap fexp swap polar> ;
-
GENERIC: log ( x -- y )
-M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline
+M: float log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline
-M: complex log >polar swap flog swap rect> ;
+M: real log >float log ; inline
+
+M: complex log >polar swap flog swap rect> ; inline
: 10^ ( x -- y ) 10 swap ^ ; inline
[ [ fcos ] [ fcosh ] bi* * ]
[ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
-M: real cos fcos ; inline
+M: float cos fcos ; inline
+
+M: real cos >float cos ; inline
: sec ( x -- y ) cos recip ; inline
[ [ fcosh ] [ fcos ] bi* * ]
[ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
-M: real cosh fcosh ; inline
+M: float cosh fcosh ; inline
+
+M: real cosh >float cosh ; inline
: sech ( x -- y ) cosh recip ; inline
[ [ fsin ] [ fcosh ] bi* * ]
[ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
-M: real sin fsin ; inline
+M: float sin fsin ; inline
+
+M: real sin >float sin ; inline
: cosec ( x -- y ) sin recip ; inline
[ [ fsinh ] [ fcos ] bi* * ]
[ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
-M: real sinh fsinh ; inline
+M: float sinh fsinh ; inline
+
+M: real sinh >float sinh ; inline
: cosech ( x -- y ) sinh recip ; inline
M: complex tan [ sin ] [ cos ] bi / ;
-M: real tan ftan ; inline
+M: float tan ftan ; inline
+
+M: real tan >float tan ; inline
GENERIC: tanh ( x -- y ) foldable
M: complex tanh [ sinh ] [ cosh ] bi / ;
-M: real tanh ftanh ; inline
+M: float tanh ftanh ; inline
+
+M: real tanh >float tanh ; inline
: cot ( x -- y ) tan recip ; inline
: -i* ( x -- y ) >rect swap neg rect> ;
: asin ( x -- y )
- dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline
+ dup [-1,1]? [ >float fasin ] [ i* asinh -i* ] if ; inline
: acos ( x -- y )
- dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ;
+ dup [-1,1]? [ >float facos ] [ asin pi 2 / swap - ] if ;
inline
GENERIC: atan ( x -- y ) foldable
-M: complex atan i* atanh i* ;
+M: complex atan i* atanh i* ; inline
+
+M: float atan fatan ; inline
-M: real atan fatan ; inline
+M: real atan >float atan ; inline
: asec ( x -- y ) recip acos ; inline
ARTICLE: "math.libm" "C standard library math functions"
"The words in the " { $vocab-link "math.libm" } " vocabulary call C standard library math functions. They are used to implement words in the " { $vocab-link "math.functions" } " vocabulary."
-$nl
-"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
-{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
-{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." }
+{ $warning
+"These functions are unsafe. The compiler special-cases them to operate on floats only. They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
+{ $example "USE: math.functions" "2.0 acos ." "C{ 0.0 1.316957896924817 }" }
+{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." } }
"Trigonometric functions:"
{ $subsection fcos }
{ $subsection fsin }
IN: math.libm
: facos ( x -- y )
- "double" "libm" "acos" { "double" } alien-invoke ; inline
+ "double" "libm" "acos" { "double" } alien-invoke ;
: fasin ( x -- y )
- "double" "libm" "asin" { "double" } alien-invoke ; inline
+ "double" "libm" "asin" { "double" } alien-invoke ;
: fatan ( x -- y )
- "double" "libm" "atan" { "double" } alien-invoke ; inline
+ "double" "libm" "atan" { "double" } alien-invoke ;
: fatan2 ( x y -- z )
- "double" "libm" "atan2" { "double" "double" } alien-invoke ; inline
+ "double" "libm" "atan2" { "double" "double" } alien-invoke ;
: fcos ( x -- y )
- "double" "libm" "cos" { "double" } alien-invoke ; inline
+ "double" "libm" "cos" { "double" } alien-invoke ;
: fsin ( x -- y )
- "double" "libm" "sin" { "double" } alien-invoke ; inline
+ "double" "libm" "sin" { "double" } alien-invoke ;
: ftan ( x -- y )
- "double" "libm" "tan" { "double" } alien-invoke ; inline
+ "double" "libm" "tan" { "double" } alien-invoke ;
: fcosh ( x -- y )
- "double" "libm" "cosh" { "double" } alien-invoke ; inline
+ "double" "libm" "cosh" { "double" } alien-invoke ;
: fsinh ( x -- y )
- "double" "libm" "sinh" { "double" } alien-invoke ; inline
+ "double" "libm" "sinh" { "double" } alien-invoke ;
: ftanh ( x -- y )
- "double" "libm" "tanh" { "double" } alien-invoke ; inline
+ "double" "libm" "tanh" { "double" } alien-invoke ;
: fexp ( x -- y )
- "double" "libm" "exp" { "double" } alien-invoke ; inline
+ "double" "libm" "exp" { "double" } alien-invoke ;
: flog ( x -- y )
- "double" "libm" "log" { "double" } alien-invoke ; inline
+ "double" "libm" "log" { "double" } alien-invoke ;
: fpow ( x y -- z )
- "double" "libm" "pow" { "double" "double" } alien-invoke ; inline
+ "double" "libm" "pow" { "double" "double" } alien-invoke ;
-! Don't inline fsqrt -- its an intrinsic!
: fsqrt ( x -- y )
"double" "libm" "sqrt" { "double" } alien-invoke ;
! Windows doesn't have these...
: facosh ( x -- y )
- "double" "libm" "acosh" { "double" } alien-invoke ; inline
+ "double" "libm" "acosh" { "double" } alien-invoke ;
: fasinh ( x -- y )
- "double" "libm" "asinh" { "double" } alien-invoke ; inline
+ "double" "libm" "asinh" { "double" } alien-invoke ;
: fatanh ( x -- y )
- "double" "libm" "atanh" { "double" } alien-invoke ; inline
+ "double" "libm" "atanh" { "double" } alien-invoke ;
[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
-[ { 1 2 } { "a" "b" } cross-zip ] unit-test
\ No newline at end of file
+[ { 1 2 } { "a" "b" } cross-zip ] unit-test
+
+[ { { 4181 6765 } { 6765 10946 } } ]
+[ { { 0 1 } { 1 1 } } 20 m^n ] unit-test
: m^n ( m n -- n )
make-bits over first length identity-matrix
- [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
+ [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
\ No newline at end of file
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
: random-prime ( numbits -- p )
- random-bits* next-prime ;
+ [ ] [ 2^ ] [ random-bits* next-prime ] tri
+ 2dup < [ 2drop random-prime ] [ 2nip ] if ;
: estimated-primes ( m -- n )
dup log / ; foldable
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
"disposables" "destructors" lookup ,
+ "functor-words" "functors.backend" lookup ,
+
deploy-threads? [
"initial-thread" "threads" lookup ,
] unless
USING: tools.disassembler namespaces combinators
alien alien.syntax alien.c-types lexer parser kernel
sequences layouts math math.order alien.libraries
-math.parser system make fry arrays libc destructors ;
+math.parser system make fry arrays libc destructors
+tools.disassembler.utils splitting ;
IN: tools.disassembler.udis
<<
dup UD_SYN_INTEL ud_set_syntax ;
: with-ud ( quot: ( ud -- ) -- )
- [ [ <ud> ] dip call ] with-destructors ; inline
+ [ [ [ <ud> ] dip call ] with-destructors ] with-words-xt ; inline
SINGLETON: udis-disassembler
: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
+: resolve-call ( str -- str' ) "0x" split1-last [ resolve-xt append ] when* ;
+
: format-disassembly ( lines -- lines' )
dup [ second length ] [ max ] map-reduce
'[
[
[ first >hex cell 2 * CHAR: 0 pad-head % ": " % ]
[ second _ CHAR: \s pad-tail % " " % ]
- [ third % ]
+ [ third resolve-call % ]
tri
] "" make
] map ;
--- /dev/null
+USING: accessors arrays binary-search kernel math math.order
+math.parser namespaces sequences sorting splitting vectors vocabs words ;
+IN: tools.disassembler.utils
+
+SYMBOL: words-xt
+SYMBOL: smallest-xt
+SYMBOL: greatest-xt
+
+: (words-xt) ( -- assoc )
+ vocabs [ words ] map concat [ [ word-xt ] keep 3array ] map
+ [ [ first ] bi@ <=> ] sort >vector ;
+
+: complete-address ( n seq -- str )
+ [ first - ] [ third name>> ] bi
+ over zero? [ nip ] [ swap 16 >base "0x" prepend "+" glue ] if ;
+
+: search-xt ( n -- str/f )
+ dup [ smallest-xt get < ] [ greatest-xt get > ] bi or [
+ drop f
+ ] [
+ words-xt get over [ swap first <=> ] curry search nip
+ 2dup second <= [
+ [ complete-address ] [ drop f ] if*
+ ] [
+ 2drop f
+ ] if
+ ] if ;
+
+: resolve-xt ( str -- str' )
+ [ "0x" prepend ] [ 16 base> ] bi
+ [ search-xt [ " (" ")" surround append ] when* ] when* ;
+
+: resolve-call ( str -- str' )
+ "0x" split1-last [ resolve-xt "0x" glue ] when* ;
+
+: with-words-xt ( quot -- )
+ [ (words-xt)
+ [ words-xt set ]
+ [ first first smallest-xt set ]
+ [ last second greatest-xt set ] tri
+ ] prepose with-scope ; inline
! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets
-ui.gadgets.private ui.gestures ui.backend ui.clipboards
-ui.gadgets.worlds ui.render ui.event-loop assocs kernel math
-namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim
-x11.glx x11.clipboard x11.constants x11.windows x11.io
-io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
-command-line math.vectors classes.tuple opengl.gl threads
-math.rectangles environment ascii literals
-ui.pixel-formats ui.pixel-formats.private ;
+USING: accessors alien.c-types arrays ascii assocs
+classes.struct combinators io.encodings.ascii
+io.encodings.string io.encodings.utf8 kernel literals math
+namespaces sequences strings ui ui.backend ui.clipboards
+ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
+ui.gestures ui.pixel-formats ui.pixel-formats.private
+ui.private x11 x11.clipboard x11.constants x11.events x11.glx
+x11.io x11.windows x11.xim x11.xlib environment command-line ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
M: world expose-event nip relayout ;
M: world configure-event
- over configured-loc >>window-loc
- swap configured-dim >>dim
+ swap [ event-loc >>window-loc ] [ event-dim >>dim ] bi
! In case dimensions didn't change
relayout-1 ;
dup key-codes at [ t ] [ 1string f ] ?if ;
: event-modifiers ( event -- seq )
- XKeyEvent-state modifiers modifier ;
+ state>> modifiers modifier ;
: valid-input? ( string gesture -- ? )
over empty? [ 2drop f ] [
[ key-up-event>gesture ] dip propagate-key-gesture ;
: mouse-event>gesture ( event -- modifiers button loc )
- [ event-modifiers ]
- [ XButtonEvent-button ]
- [ mouse-event-loc ]
- tri ;
+ [ event-modifiers ] [ button>> ] [ event-loc ] tri ;
M: world button-down-event
[ mouse-event>gesture [ <button-down> ] dip ] dip
send-button-up ;
: mouse-event>scroll-direction ( event -- pair )
- XButtonEvent-button {
+ button>> {
{ 4 { 0 -1 } }
{ 5 { 0 1 } }
{ 6 { -1 0 } }
} at ;
M: world wheel-event
- [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
+ [ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip
send-wheel ;
M: world enter-event motion-event ;
M: world leave-event 2drop forget-rollover ;
M: world motion-event
- [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
- move-hand fire-motion ;
+ [ event-loc ] dip move-hand fire-motion ;
M: world focus-in-event
- nip
- [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
+ nip [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
M: world focus-out-event
- nip
- [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
+ nip [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
M: world selection-notify-event
[ handle>> window>> selection-from-event ] keep
} case ;
: encode-clipboard ( string type -- bytes )
- XSelectionRequestEvent-target
- XA_UTF8_STRING = utf8 ascii ? encode ;
+ target>> XA_UTF8_STRING = utf8 ascii ? encode ;
: set-selection-prop ( evt -- )
dpy get swap
- [ XSelectionRequestEvent-requestor ] keep
- [ XSelectionRequestEvent-property ] keep
- [ XSelectionRequestEvent-target ] keep
- [ 8 PropModeReplace ] dip
- [
- XSelectionRequestEvent-selection
- clipboard-for-atom contents>>
- ] keep encode-clipboard dup length XChangeProperty drop ;
+ [ requestor>> ] keep
+ [ property>> ] keep
+ [ target>> 8 PropModeReplace ] keep
+ [ selection>> clipboard-for-atom contents>> ] keep
+ encode-clipboard dup length XChangeProperty drop ;
M: world selection-request-event
- drop dup XSelectionRequestEvent-target {
+ drop dup target>> {
{ [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
{ [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
{ [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
] [ wait-for-display wait-event ] if ;
M: x11-ui-backend do-events
- wait-event dup XAnyEvent-window window dup
+ wait-event dup window>> window dup
[ handle-event ] [ 2drop ] if ;
: x-clipboard@ ( gadget clipboard -- prop win )
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
M: x11-ui-backend (set-fullscreen) ( world ? -- )
- [
- handle>> window>> "XClientMessageEvent" <c-object>
- [ set-XClientMessageEvent-window ] keep
- ] dip
- _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
- over set-XClientMessageEvent-data0
- ClientMessage over set-XClientMessageEvent-type
- dpy get over set-XClientMessageEvent-display
- "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
- 32 over set-XClientMessageEvent-format
- "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
+ XClientMessageEvent <struct>
+ swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
+ swap handle>> window>> >>window
+ dpy get >>display
+ "_NET_WM_STATE" x-atom >>message_type
+ 32 >>format
+ "_NET_WM_STATE_FULLSCREEN" x-atom >>data1
[ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
M: x11-ui-backend (open-window) ( world -- )
drop ;
M: x11-ui-backend (open-offscreen-buffer) ( world -- )
- dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ]
- with-world-pixel-format
+ dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ] with-world-pixel-format
<x11-pixmap-handle> >>handle drop ;
+
M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
dpy get swap
[ glx-pixmap>> glXDestroyGLXPixmap ]
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 1024
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
-C-STRUCT: dirent
- { "u_int32_t" "d_fileno" }
- { "u_int16_t" "d_reclen" }
- { "u_int8_t" "d_type" }
- { "u_int8_t" "d_namlen" }
- { { "char" 256 } "d_name" } ;
+STRUCT: dirent
+ { d_fileno u_int32_t }
+ { d_reclen u_int16_t }
+ { d_type u_int8_t }
+ { d_namlen u_int8_t }
+ { d_name char[256] } ;
CONSTANT: EPERM 1
CONSTANT: ENOENT 2
-USING: alien.syntax unix.time ;
+USING: alien.syntax unix.time classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 1024
CONSTANT: __DARWIN_MAXNAMELEN 255
CONSTANT: __DARWIN_MAXNAMELEN+1 255
-C-STRUCT: dirent
- { "ino_t" "d_ino" }
- { "__uint16_t" "d_reclen" }
- { "__uint8_t" "d_type" }
- { "__uint8_t" "d_namlen" }
- { { "char" __DARWIN_MAXNAMELEN+1 } "d_name" } ;
+STRUCT: dirent
+ { d_ino ino_t }
+ { d_reclen __uint16_t }
+ { d_type __uint8_t }
+ { d_namlen __uint8_t }
+ { d_name { "char" __DARWIN_MAXNAMELEN+1 } } ;
CONSTANT: EPERM 1
CONSTANT: ENOENT 2
-USING: alien.syntax alien.c-types math vocabs.loader ;
+USING: alien.syntax alien.c-types math vocabs.loader
+classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 256
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
-C-STRUCT: dirent
- { "__uint32_t" "d_fileno" }
- { "__uint16_t" "d_reclen" }
- { "__uint8_t" "d_type" }
- { "__uint8_t" "d_namlen" }
- { { "char" 256 } "d_name" } ;
+STRUCT: dirent
+ { d_fileno __uint32_t }
+ { d_reclen __uint16_t }
+ { d_type __uint8_t }
+ { d_namlen __uint8_t }
+ { d_name char[256] } ;
CONSTANT: EPERM 1
CONSTANT: ENOENT 2
CONSTANT: _UTX_IDSIZE 4
CONSTANT: _UTX_HOSTSIZE 256
-: _SS_MAXSIZE ( -- n )
- 128 ; inline
+CONSTANT: _SS_MAXSIZE 128
: _SS_ALIGNSIZE ( -- n )
"__int64_t" heap-size ; inline
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 1024
{ "char*" "canonname" }
{ "addrinfo*" "next" } ;
-C-STRUCT: dirent
- { "__uint32_t" "d_fileno" }
- { "__uint16_t" "d_reclen" }
- { "__uint8_t" "d_type" }
- { "__uint8_t" "d_namlen" }
- { { "char" 256 } "d_name" } ;
+STRUCT: dirent
+ { d_fileno __uint32_t }
+ { d_reclen __uint16_t }
+ { d_type __uint8_t }
+ { d_namlen __uint8_t }
+ { d_name char[256] } ;
CONSTANT: EPERM 1
CONSTANT: ENOENT 2
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.kqueue
-C-STRUCT: kevent
- { "ulong" "ident" } ! identifier for this event
- { "short" "filter" } ! filter for event
- { "ushort" "flags" } ! action flags for kqueue
- { "uint" "fflags" } ! filter flag value
- { "long" "data" } ! filter data value
- { "void*" "udata" } ! opaque user data identifier
-;
+STRUCT: kevent
+ { ident ulong }
+ { filter short }
+ { flags ushort }
+ { fflags uint }
+ { data long }
+ { udata void* } ;
FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.kqueue
-C-STRUCT: kevent
- { "ulong" "ident" } ! identifier for this event
- { "short" "filter" } ! filter for event
- { "ushort" "flags" } ! action flags for kqueue
- { "uint" "fflags" } ! filter flag value
- { "long" "data" } ! filter data value
- { "void*" "udata" } ! opaque user data identifier
-;
+STRUCT: kevent
+ { ident ulong }
+ { filter short }
+ { flags ushort }
+ { fflags uint }
+ { data long }
+ { udata void* } ;
FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.kqueue
-C-STRUCT: kevent
- { "ulong" "ident" } ! identifier for this event
- { "uint" "filter" } ! filter for event
- { "uint" "flags" } ! action flags for kqueue
- { "uint" "fflags" } ! filter flag value
- { "longlong" "data" } ! filter data value
- { "void*" "udata" } ! opaque user data identifier
-;
+STRUCT: kevent
+ { ident ulong }
+ { filter uint }
+ { flags uint }
+ { fflags uint }
+ { data longlong }
+ { udata void* } ;
FUNCTION: int kevent ( int kq, kevent* changelist, size_t nchanges, kevent* eventlist, size_t nevents, timespec* timeout ) ;
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.kqueue
-C-STRUCT: kevent
- { "uint" "ident" } ! identifier for this event
- { "short" "filter" } ! filter for event
- { "ushort" "flags" } ! action flags for kqueue
- { "uint" "fflags" } ! filter flag value
- { "int" "data" } ! filter data value
- { "void*" "udata" } ! opaque user data identifier
-;
+STRUCT: kevent
+ { ident uint }
+ { filter short }
+ { flags ushort }
+ { fflags uint }
+ { data int }
+ { udata void* } ;
FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien system ;
+USING: alien.syntax alien system classes.struct ;
IN: unix
! Linux.
{ "char*" "pw_shell" } ;
! dirent64
-C-STRUCT: dirent
- { "ulonglong" "d_ino" }
- { "longlong" "d_off" }
- { "ushort" "d_reclen" }
- { "uchar" "d_type" }
- { { "char" 256 } "d_name" } ;
+STRUCT: dirent
+ { d_ino ulonglong }
+ { d_off longlong }
+ { d_reclen ushort }
+ { d_type uchar }
+ { d_name char[256] } ;
FUNCTION: int open64 ( char* path, int flags, int prot ) ;
FUNCTION: dirent64* readdir64 ( DIR* dirp ) ;
+++ /dev/null
-USING: kernel alien.syntax math ;
-
-IN: unix.stat
-
-! FreeBSD 8.0-CURRENT
-
-C-STRUCT: stat
- { "__dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "__dev_t" "st_rdev" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "off_t" "st_size" }
- { "blkcnt_t" "st_blocks" }
- { "blksize_t" "st_blksize" }
- { "fflags_t" "st_flags" }
- { "__uint32_t" "st_gen" }
- { "__int32_t" "st_lspare" }
- { "timespec" "st_birthtimespec" }
-! not sure about the padding here.
- { "__uint32_t" "pad0" }
- { "__uint32_t" "pad1" } ;
-
-FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
+++ /dev/null
-unportable
+++ /dev/null
-USING: kernel alien.syntax math ;
-IN: unix.stat
-
-! FreeBSD 8.0-CURRENT
-! untested
-
-C-STRUCT: stat
- { "__dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "__dev_t" "st_rdev" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "off_t" "st_size" }
- { "blkcnt_t" "st_blocks" }
- { "blksize_t" "st_blksize" }
- { "fflags_t" "st_flags" }
- { "__uint32_t" "st_gen" }
- { "__int32_t" "st_lspare" }
- { "timespec" "st_birthtimespec" }
-! not sure about the padding here.
- { "__uint32_t" "pad0" }
- { "__uint32_t" "pad1" } ;
-
-FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
+++ /dev/null
-unportable
-USING: layouts combinators vocabs.loader ;
+USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
-cell-bits {
- { 32 [ "unix.stat.freebsd.32" require ] }
- { 64 [ "unix.stat.freebsd.64" require ] }
-} case
+! FreeBSD 8.0-CURRENT
+
+STRUCT: stat
+ { st_dev __dev_t }
+ { st_ino ino_t }
+ { st_mode mode_t }
+ { st_nlink nlink_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { st_rdev __dev_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { st_size off_t }
+ { st_blocks blkcnt_t }
+ { st_blksize blksize_t }
+ { st_flags fflags_t }
+ { st_gen __uint32_t }
+ { st_lspare __int32_t }
+ { st_birthtimespec timespec }
+ { pad0 __int32_t[2] } ;
+
+FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
-USING: kernel alien.syntax math sequences unix
-alien.c-types arrays accessors combinators ;
+USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! stat64
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "ushort" "__pad1" }
- { "__ino_t" "__st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { { "ushort" 2 } "__pad2" }
- { "off64_t" "st_size" }
- { "blksize_t" "st_blksize" }
- { "blkcnt64_t" "st_blocks" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "ulonglong" "st_ino" } ;
+STRUCT: stat
+ { st_dev dev_t }
+ { __pad1 ushort }
+ { __st_ino __ino_t }
+ { st_mode mode_t }
+ { st_nlink nlink_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { st_rdev dev_t }
+ { __pad2 ushort[2] }
+ { st_size off64_t }
+ { st_blksize blksize_t }
+ { st_blocks blkcnt64_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { st_ino ulonglong } ;
FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;
-USING: kernel alien.syntax math sequences unix
-alien.c-types arrays accessors combinators ;
+USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! Ubuntu 7.10 64-bit
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "nlink_t" "st_nlink" }
- { "mode_t" "st_mode" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "int" "pad0" }
- { "dev_t" "st_rdev" }
- { "off64_t" "st_size" }
- { "blksize_t" "st_blksize" }
- { "blkcnt64_t" "st_blocks" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "long" "__unused0" }
- { "long" "__unused1" }
- { "long" "__unused2" } ;
+STRUCT: stat
+ { st_dev dev_t }
+ { st_ino ino_t }
+ { st_nlink nlink_t }
+ { st_mode mode_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { pad0 int }
+ { st_rdev dev_t }
+ { st_size off64_t }
+ { st_blksize blksize_t }
+ { st_blocks blkcnt64_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { __unused0 long[3] } ;
FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;
-USING: kernel alien.syntax math unix math.bitwise
-alien.c-types alien sequences grouping accessors combinators ;
+USING: alien.c-types arrays accessors combinators classes.struct
+alien.syntax ;
IN: unix.stat
! Mac OS X ppc
! stat64 structure
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "ino64_t" "st_ino" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "timespec" "st_birthtimespec" }
- { "off_t" "st_size" }
- { "blkcnt_t" "st_blocks" }
- { "blksize_t" "st_blksize" }
- { "__uint32_t" "st_flags" }
- { "__uint32_t" "st_gen" }
- { "__int32_t" "st_lspare" }
- { "__int64_t" "st_qspare0" }
- { "__int64_t" "st_qspare1" } ;
+STRUCT: stat
+ { st_dev dev_t }
+ { st_mode mode_t }
+ { st_nlink nlink_t }
+ { st_ino ino64_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { st_rdev dev_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { st_birthtimespec timespec }
+ { st_size off_t }
+ { st_blocks blkcnt_t }
+ { st_blksize blksize_t }
+ { st_flags __uint32_t }
+ { st_gen __uint32_t }
+ { st_lspare __int32_t }
+ { st_qspare0 __int64_t }
+ { st_qspare1 __int64_t } ;
FUNCTION: int stat64 ( char* pathname, stat* buf ) ;
FUNCTION: int lstat64 ( char* pathname, stat* buf ) ;
-USING: kernel alien.syntax math ;
+USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! NetBSD 4.0
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "mode_t" "st_mode" }
- { "ino_t" "st_ino" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "timespec" "st_birthtimespec" }
- { "off_t" "st_size" }
- { "blkcnt_t" "st_blocks" }
- { "blksize_t" "st_blksize" }
- { "uint32_t" "st_flags" }
- { "uint32_t" "st_gen" }
- { { "uint32_t" 2 } "st_qspare" } ;
+STRUCT: stat
+ { st_dev dev_t }
+ { st_mode mode_t }
+ { st_ino ino_t }
+ { st_nlink nlink_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { st_rdev dev_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { st_birthtimespec timespec }
+ { st_size off_t }
+ { st_blocks blkcnt_t }
+ { st_blksize blksize_t }
+ { st_flags uint32_t }
+ { st_gen uint32_t }
+ { st_qspare uint32_t[2] } ;
FUNCTION: int __stat30 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat30 ( char* pathname, stat* buf ) ;
-USING: kernel alien.syntax math ;
+USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! NetBSD 4.0
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "off_t" "st_size" }
- { "blkcnt_t" "st_blocks" }
- { "blksize_t" "st_blksize" }
- { "uint32_t" "st_flags" }
- { "uint32_t" "st_gen" }
- { "uint32_t" "st_spare0" }
- { "timespec" "st_birthtimespec" } ;
+STRUCT: stat
+ { st_dev dev_t }
+ { st_ino ino_t }
+ { st_mode mode_t }
+ { st_nlink nlink_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { st_rdev dev_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { st_size off_t }
+ { st_blocks blkcnt_t }
+ { st_blksize blksize_t }
+ { st_flags uint32_t }
+ { st_gen uint32_t }
+ { st_spare0 uint32_t }
+ { st_birthtimespec timespec } ;
FUNCTION: int __stat13 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat13 ( char* pathname, stat* buf ) ;
-USING: kernel alien.syntax math ;
+USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! OpenBSD 4.2
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { "int32_t" "st_lspare0" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "off_t" "st_size" }
- { "int64_t" "st_blocks" }
- { "u_int32_t" "st_blksize" }
- { "u_int32_t" "st_flags" }
- { "u_int32_t" "st_gen" }
- { "int32_t" "st_lspare1" }
- { "timespec" "st_birthtimespec" }
- { { "int64_t" 2 } "st_qspare" } ;
+STRUCT: stat
+ { st_dev dev_t }
+ { st_ino ino_t }
+ { st_mode mode_t }
+ { st_nlink nlink_t }
+ { st_uid uid_t }
+ { st_gid gid_t }
+ { st_rdev dev_t }
+ { st_lspare0 int32_t }
+ { st_atimespec timespec }
+ { st_mtimespec timespec }
+ { st_ctimespec timespec }
+ { st_size off_t }
+ { st_blocks int64_t }
+ { st_blksize u_int32_t }
+ { st_flags u_int32_t }
+ { st_gen u_int32_t }
+ { st_lspare1 int32_t }
+ { st_birthtimespec timespec }
+ { st_qspare int64_t[2] } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;
USING: kernel system combinators alien.syntax alien.c-types
-math io.backend.unix vocabs.loader unix ;
+math io.backend.unix vocabs.loader unix classes.struct ;
IN: unix.stat
! File Types
CONSTANT: S_IFSOCK OCT: 140000 ! Socket.
CONSTANT: S_IFWHT OCT: 160000 ! Whiteout.
-C-STRUCT: fsid
- { { "int" 2 } "__val" } ;
+STRUCT: fsid
+ { __val int[2] } ;
TYPEDEF: fsid __fsid_t
TYPEDEF: fsid fsid_t
} case >>
: file-status ( pathname -- stat )
- "stat" <c-object> [ [ stat ] unix-system-call drop ] keep ;
+ \ stat <struct> [ [ stat ] unix-system-call drop ] keep ;
: link-status ( pathname -- stat )
- "stat" <c-object> [ [ lstat ] unix-system-call drop ] keep ;
+ \ stat <struct> [ [ lstat ] unix-system-call drop ] keep ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.types unix.stat ;
+USING: alien.syntax unix.types unix.stat classes.struct ;
IN: unix.statfs.freebsd
CONSTANT: MFSNAMELEN 16 ! length of type name including null */
CONSTANT: MNAMELEN 88 ! size of on/from name bufs
CONSTANT: STATFS_VERSION HEX: 20030518 ! current version number
-C-STRUCT: statfs
- { "uint32_t" "f_version" }
- { "uint32_t" "f_type" }
- { "uint64_t" "f_flags" }
- { "uint64_t" "f_bsize" }
- { "uint64_t" "f_iosize" }
- { "uint64_t" "f_blocks" }
- { "uint64_t" "f_bfree" }
- { "int64_t" "f_bavail" }
- { "uint64_t" "f_files" }
- { "int64_t" "f_ffree" }
- { "uint64_t" "f_syncwrites" }
- { "uint64_t" "f_asyncwrites" }
- { "uint64_t" "f_syncreads" }
- { "uint64_t" "f_asyncreads" }
- { { "uint64_t" 10 } "f_spare" }
- { "uint32_t" "f_namemax" }
- { "uid_t" "f_owner" }
- { "fsid_t" "f_fsid" }
- { { "char" 80 } "f_charspare" }
- { { "char" MFSNAMELEN } "f_fstypename" }
- { { "char" MNAMELEN } "f_mntfromname" }
- { { "char" MNAMELEN } "f_mntonname" } ;
+STRUCT: statfs
+ { f_version uint32_t }
+ { f_type uint32_t }
+ { f_flags uint64_t }
+ { f_bsize uint64_t }
+ { f_iosize uint64_t }
+ { f_blocks uint64_t }
+ { f_bfree uint64_t }
+ { f_bavail int64_t }
+ { f_files uint64_t }
+ { f_ffree int64_t }
+ { f_syncwrites uint64_t }
+ { f_asyncwrites uint64_t }
+ { f_syncreads uint64_t }
+ { f_asyncreads uint64_t }
+ { f_spare uint64_t[10] }
+ { f_namemax uint32_t }
+ { f_owner uid_t }
+ { f_fsid fsid_t }
+ { f_charspare char[80] }
+ { f_fstypename { "char" MFSNAMELEN } }
+ { f_mntfromname { "char" MNAMELEN } }
+ { f_mntonname { "char" MNAMELEN } } ;
FUNCTION: int statfs ( char* path, statvfs* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.types unix.stat ;
+USING: alien.syntax unix.types unix.stat classes.struct ;
IN: unix.statfs.linux
-C-STRUCT: statfs64
- { "__SWORD_TYPE" "f_type" }
- { "__SWORD_TYPE" "f_bsize" }
- { "__fsblkcnt64_t" "f_blocks" }
- { "__fsblkcnt64_t" "f_bfree" }
- { "__fsblkcnt64_t" "f_bavail" }
- { "__fsfilcnt64_t" "f_files" }
- { "__fsfilcnt64_t" "f_ffree" }
- { "__fsid_t" "f_fsid" }
- { "__SWORD_TYPE" "f_namelen" }
- { "__SWORD_TYPE" "f_frsize" }
- { { "__SWORD_TYPE" 5 } "f_spare" } ;
+STRUCT: statfs64
+ { f_type __SWORD_TYPE }
+ { f_bsize __SWORD_TYPE }
+ { f_blocks __fsblkcnt64_t }
+ { f_bfree __fsblkcnt64_t }
+ { f_bavail __fsblkcnt64_t }
+ { f_files __fsblkcnt64_t }
+ { f_ffree __fsblkcnt64_t }
+ { f_fsid __fsid_t }
+ { f_namelen __SWORD_TYPE }
+ { f_frsize __SWORD_TYPE }
+ { f_spare __SWORD_TYPE[5] } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
USING: alien.c-types io.encodings.utf8 io.encodings.string
kernel sequences unix.stat accessors unix combinators math
grouping system alien.strings math.bitwise alien.syntax
-unix.types ;
+unix.types classes.struct ;
IN: unix.statfs.macosx
CONSTANT: MNT_RDONLY HEX: 00000001
CONSTANT: VFS_CTL_TIMEO HEX: 00010005
CONSTANT: VFS_CTL_NOLOCKS HEX: 00010006
-C-STRUCT: vfsquery
- { "uint32_t" "vq_flags" }
- { { "uint32_t" 31 } "vq_spare" } ;
+STRUCT: vfsquery
+ { vq_flags uint32_t }
+ { vq_spare uint32_t[31] } ;
CONSTANT: VQ_NOTRESP HEX: 0001
CONSTANT: VQ_NEEDAUTH HEX: 0002
CONSTANT: MNAMELEN 90
CONSTANT: MFSTYPENAMELEN 16
-C-STRUCT: fsid_t
- { { "int32_t" 2 } "val" } ;
+STRUCT: fsid_t
+ { val int32_t[2] } ;
-C-STRUCT: statfs64
- { "uint32_t" "f_bsize" }
- { "int32_t" "f_iosize" }
- { "uint64_t" "f_blocks" }
- { "uint64_t" "f_bfree" }
- { "uint64_t" "f_bavail" }
- { "uint64_t" "f_files" }
- { "uint64_t" "f_ffree" }
- { "fsid_t" "f_fsid" }
- { "uid_t" "f_owner" }
- { "uint32_t" "f_type" }
- { "uint32_t" "f_flags" }
- { "uint32_t" "f_fssubtype" }
- { { "char" MFSTYPENAMELEN } "f_fstypename" }
- { { "char" MAXPATHLEN } "f_mntonname" }
- { { "char" MAXPATHLEN } "f_mntfromname" }
- { { "uint32_t" 8 } "f_reserved" } ;
+STRUCT: statfs64
+ { f_bsize uint32_t }
+ { f_iosize int32_t }
+ { f_blocks uint64_t }
+ { f_bfree uint64_t }
+ { f_bavail uint64_t }
+ { f_files uint64_t }
+ { f_ffree uint64_t }
+ { f_fsid fsid_t }
+ { f_owner uid_t }
+ { f_type uint32_t }
+ { f_flags uint32_t }
+ { f_fssubtype uint32_t }
+ { f_fstypename { "char" MFSTYPENAMELEN } }
+ { f_mntonname { "char" MAXPATHLEN } }
+ { f_mntfromname { "char" MAXPATHLEN } }
+ { f_reserved uint32_t[8] } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
FUNCTION: int getmntinfo64 ( statfs64** mntbufp, int flags ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.types unix.stat ;
+USING: alien.syntax unix.types unix.stat classes.struct ;
IN: unix.statfs.openbsd
CONSTANT: MFSNAMELEN 16
CONSTANT: MNAMELEN 90
-C-STRUCT: statfs
- { "u_int32_t" "f_flags" }
- { "u_int32_t" "f_bsize" }
- { "u_int32_t" "f_iosize" }
- { "u_int64_t" "f_blocks" }
- { "u_int64_t" "f_bfree" }
- { "int64_t" "f_bavail" }
- { "u_int64_t" "f_files" }
- { "u_int64_t" "f_ffree" }
- { "int64_t" "f_favail" }
- { "u_int64_t" "f_syncwrites" }
- { "u_int64_t" "f_syncreads" }
- { "u_int64_t" "f_asyncwrites" }
- { "u_int64_t" "f_asyncreads" }
- { "fsid_t" "f_fsid" }
- { "u_int32_t" "f_namemax" }
- { "uid_t" "f_owner" }
- { "u_int32_t" "f_ctime" }
- { { "u_int32_t" 3 } "f_spare" }
- { { "char" MFSNAMELEN } "f_fstypename" }
- { { "char" MNAMELEN } "f_mntonname" }
- { { "char" MNAMELEN } "f_mntfromname" }
- { { "char" 160 } "mount_info" } ;
+STRUCT: statfs
+ { f_flags u_int32_t }
+ { f_bsize u_int32_t }
+ { f_iosize u_int32_t }
+ { f_blocks u_int64_t }
+ { f_bfree u_int64_t }
+ { f_bavail int64_t }
+ { f_files u_int64_t }
+ { f_ffree u_int64_t }
+ { f_favail int64_t }
+ { f_syncwrites u_int64_t }
+ { f_syncreads u_int64_t }
+ { f_asyncwrites u_int64_t }
+ { f_asyncreads u_int64_t }
+ { f_fsid fsid_t }
+ { f_namemax u_int32_t }
+ { f_owner uid_t }
+ { f_ctime u_int32_t }
+ { f_spare u_int32_t[3] }
+ { f_fstypename { "char" MFSNAMELEN } }
+ { f_mntonname { "char" MNAMELEN } }
+ { f_mntfromname { "char" MNAMELEN } }
+ { mount_info char[160] } ;
FUNCTION: int statfs ( char* path, statvfs* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.statvfs.freebsd
-C-STRUCT: statvfs
- { "fsblkcnt_t" "f_bavail" }
- { "fsblkcnt_t" "f_bfree" }
- { "fsblkcnt_t" "f_blocks" }
- { "fsfilcnt_t" "f_favail" }
- { "fsfilcnt_t" "f_ffree" }
- { "fsfilcnt_t" "f_files" }
- { "ulong" "f_bsize" }
- { "ulong" "f_flag" }
- { "ulong" "f_frsize" }
- { "ulong" "f_fsid" }
- { "ulong" "f_namemax" } ;
+STRUCT: statvfs
+ { f_bavail fsblkcnt_t }
+ { f_bfree fsblkcnt_t }
+ { f_blocks fsblkcnt_t }
+ { f_favail fsfilcnt_t }
+ { f_ffree fsfilcnt_t }
+ { f_files fsfilcnt_t }
+ { f_bsize ulong }
+ { f_flag ulong }
+ { f_frsize ulong }
+ { f_fsid ulong }
+ { f_namemax ulong } ;
! Flags
CONSTANT: ST_RDONLY HEX: 1 ! Read-only file system
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.statvfs.linux
-C-STRUCT: statvfs64
- { "ulong" "f_bsize" }
- { "ulong" "f_frsize" }
- { "__fsblkcnt64_t" "f_blocks" }
- { "__fsblkcnt64_t" "f_bfree" }
- { "__fsblkcnt64_t" "f_bavail" }
- { "__fsfilcnt64_t" "f_files" }
- { "__fsfilcnt64_t" "f_ffree" }
- { "__fsfilcnt64_t" "f_favail" }
- { "ulong" "f_fsid" }
- { "ulong" "f_flag" }
- { "ulong" "f_namemax" }
- { { "int" 6 } "__f_spare" } ;
+STRUCT: statvfs64
+ { f_bsize ulong }
+ { f_frsize ulong }
+ { f_blocks __fsblkcnt64_t }
+ { f_bfree __fsblkcnt64_t }
+ { f_bavail __fsblkcnt64_t }
+ { f_files __fsfilcnt64_t }
+ { f_ffree __fsfilcnt64_t }
+ { f_favail __fsfilcnt64_t }
+ { f_fsid ulong }
+ { f_flag ulong }
+ { f_namemax ulong }
+ { __f_spare int[6] } ;
FUNCTION: int statvfs64 ( char* path, statvfs64* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.statvfs.macosx
-C-STRUCT: statvfs
- { "ulong" "f_bsize" }
- { "ulong" "f_frsize" }
- { "fsblkcnt_t" "f_blocks" }
- { "fsblkcnt_t" "f_bfree" }
- { "fsblkcnt_t" "f_bavail" }
- { "fsfilcnt_t" "f_files" }
- { "fsfilcnt_t" "f_ffree" }
- { "fsfilcnt_t" "f_favail" }
- { "ulong" "f_fsid" }
- { "ulong" "f_flag" }
- { "ulong" "f_namemax" } ;
+STRUCT: statvfs
+ { f_bsize ulong }
+ { f_frsize ulong }
+ { f_blocks fsblkcnt_t }
+ { f_bfree fsblkcnt_t }
+ { f_bavail fsblkcnt_t }
+ { f_files fsfilcnt_t }
+ { f_ffree fsfilcnt_t }
+ { f_favail fsfilcnt_t }
+ { f_fsid ulong }
+ { f_flag ulong }
+ { f_namemax ulong } ;
! Flags
CONSTANT: ST_RDONLY HEX: 1 ! Read-only file system
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.statvfs.netbsd
CONSTANT: _VFS_NAMELEN 32
CONSTANT: _VFS_MNAMELEN 1024
-C-STRUCT: statvfs
- { "ulong" "f_flag" }
- { "ulong" "f_bsize" }
- { "ulong" "f_frsize" }
- { "ulong" "f_iosize" }
- { "fsblkcnt_t" "f_blocks" }
- { "fsblkcnt_t" "f_bfree" }
- { "fsblkcnt_t" "f_bavail" }
- { "fsblkcnt_t" "f_bresvd" }
- { "fsfilcnt_t" "f_files" }
- { "fsfilcnt_t" "f_ffree" }
- { "fsfilcnt_t" "f_favail" }
- { "fsfilcnt_t" "f_fresvd" }
- { "uint64_t" "f_syncreads" }
- { "uint64_t" "f_syncwrites" }
- { "uint64_t" "f_asyncreads" }
- { "uint64_t" "f_asyncwrites" }
- { "fsid_t" "f_fsidx" }
- { "ulong" "f_fsid" }
- { "ulong" "f_namemax" }
- { "uid_t" "f_owner" }
- { { "uint32_t" 4 } "f_spare" }
- { { "char" _VFS_NAMELEN } "f_fstypename" }
- { { "char" _VFS_MNAMELEN } "f_mntonname" }
- { { "char" _VFS_MNAMELEN } "f_mntfromname" } ;
+STRUCT: statvfs
+ { f_flag ulong }
+ { f_bsize ulong }
+ { f_frsize ulong }
+ { f_iosize ulong }
+ { f_blocks fsblkcnt_t }
+ { f_bfree fsblkcnt_t }
+ { f_bavail fsblkcnt_t }
+ { f_bresvd fsblkcnt_t }
+ { f_files fsfilcnt_t }
+ { f_ffree fsfilcnt_t }
+ { f_favail fsfilcnt_t }
+ { f_fresvd fsfilcnt_t }
+ { f_syncreads uint64_t }
+ { f_syncwrites uint64_t }
+ { f_asyncreads uint64_t }
+ { f_asyncwrites uint64_t }
+ { f_fsidx fsid_t }
+ { f_fsid ulong }
+ { f_namemax ulong }
+ { f_owner uid_t }
+ { f_spare uint32_t[4] }
+ { f_fstypename { "char" _VFS_NAMELEN } }
+ { f_mntonname { "char" _VFS_MNAMELEN } }
+ { f_mntfromname { "char" _VFS_MNAMELEN } } ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
IN: unix.statvfs.openbsd
-C-STRUCT: statvfs
- { "ulong" "f_bsize" }
- { "ulong" "f_frsize" }
- { "fsblkcnt_t" "f_blocks" }
- { "fsblkcnt_t" "f_bfree" }
- { "fsblkcnt_t" "f_bavail" }
- { "fsfilcnt_t" "f_files" }
- { "fsfilcnt_t" "f_ffree" }
- { "fsfilcnt_t" "f_favail" }
- { "ulong" "f_fsid" }
- { "ulong" "f_flag" }
- { "ulong" "f_namemax" } ;
+STRUCT: statvfs
+ { f_bsize ulong }
+ { f_frsize ulong }
+ { f_blocks fsblkcnt_t }
+ { f_bfree fsblkcnt_t }
+ { f_bavail fsblkcnt_t }
+ { f_files fsfilcnt_t }
+ { f_ffree fsfilcnt_t }
+ { f_favail fsfilcnt_t }
+ { f_fsid ulong }
+ { f_flag ulong }
+ { f_namemax ulong } ;
CONSTANT: ST_RDONLY 1
CONSTANT: ST_NOSUID 2
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien.syntax alien.c-types math unix.types ;
+USING: kernel alien.syntax alien.c-types math unix.types
+classes.struct accessors ;
IN: unix.time
-C-STRUCT: timeval
- { "long" "sec" }
- { "long" "usec" } ;
+STRUCT: timeval
+ { sec long }
+ { usec long } ;
-C-STRUCT: timespec
- { "time_t" "sec" }
- { "long" "nsec" } ;
+STRUCT: timespec
+ { sec time_t }
+ { nsec long } ;
: make-timeval ( us -- timeval )
1000000 /mod
- "timeval" <c-object>
- [ set-timeval-usec ] keep
- [ set-timeval-sec ] keep ;
+ timeval <struct>
+ swap >>usec
+ swap >>sec ;
: make-timespec ( us -- timespec )
1000000 /mod 1000 *
- "timespec" <c-object>
- [ set-timespec-nsec ] keep
- [ set-timespec-sec ] keep ;
+ timespec <struct>
+ swap >>nsec
+ swap >>sec ;
-C-STRUCT: tm
- { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?)
- { "int" "min" } ! Minutes: 0-59
- { "int" "hour" } ! Hours since midnight: 0-23
- { "int" "mday" } ! Day of the month: 1-31
- { "int" "mon" } ! Months *since* january: 0-11
- { "int" "year" } ! Years since 1900
- { "int" "wday" } ! Days since Sunday (0-6)
- { "int" "yday" } ! Days since Jan. 1: 0-365
- { "int" "isdst" } ! +1 Daylight Savings Time, 0 No DST,
- { "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?)
- { "char*" "zone" } ;
+STRUCT: tm
+ { sec int }
+ { min int }
+ { hour int }
+ { mday int }
+ { mon int }
+ { year int }
+ { wday int }
+ { yday int }
+ { isdst int }
+ { gmtoff long }
+ { zone char* } ;
FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: tm* localtime ( time_t* clock ) ;
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings alien.syntax arrays
-kernel math namespaces sequences io.encodings.string
-io.encodings.utf8 io.encodings.ascii x11 x11.xlib x11.constants
-specialized-arrays.int accessors ;
+USING: accessors alien.c-types alien.strings classes.struct
+io.encodings.utf8 kernel namespaces sequences
+specialized-arrays.int x11 x11.constants x11.xlib ;
IN: x11.clipboard
! This code was based on by McCLIM's Backends/CLX/port.lisp
[ XGetWindowProperty drop ] keep snarf-property ;
: selection-from-event ( event window -- string )
- swap XSelectionEvent-property zero? [
- drop f
- ] [
- selection-property 1 window-property
- ] if ;
+ swap property>> 0 =
+ [ drop f ] [ selection-property 1 window-property ] if ;
: own-selection ( prop win -- )
[ dpy get ] 2dip CurrentTime XSetSelectionOwner drop
flush-dpy ;
: set-targets-prop ( evt -- )
- dpy get swap
- [ XSelectionRequestEvent-requestor ] keep
- XSelectionRequestEvent-property
+ [ dpy get ] dip [ requestor>> ] [ property>> ] bi
"TARGETS" x-atom 32 PropModeReplace
{
"UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
4 XChangeProperty drop ;
: set-timestamp-prop ( evt -- )
- dpy get swap
- [ XSelectionRequestEvent-requestor ] keep
- [ XSelectionRequestEvent-property ] keep
- [ "TIMESTAMP" x-atom 32 PropModeReplace ] dip
- XSelectionRequestEvent-time <int>
+ [ dpy get ] dip
+ [ requestor>> ]
+ [ property>> "TIMESTAMP" x-atom 32 PropModeReplace ]
+ [ time>> <int> ] tri
1 XChangeProperty drop ;
: send-notify ( evt prop -- )
- "XSelectionEvent" <c-object>
- SelectionNotify over set-XSelectionEvent-type
- [ set-XSelectionEvent-property ] keep
- over XSelectionRequestEvent-display over set-XSelectionEvent-display
- over XSelectionRequestEvent-requestor over set-XSelectionEvent-requestor
- over XSelectionRequestEvent-selection over set-XSelectionEvent-selection
- over XSelectionRequestEvent-target over set-XSelectionEvent-target
- over XSelectionRequestEvent-time over set-XSelectionEvent-time
- [ dpy get swap XSelectionRequestEvent-requestor 0 0 ] dip
+ XSelectionEvent <struct>
+ SelectionNotify >>type
+ swap >>property
+ over display>> >>display
+ over requestor>> >>requestor
+ over selection>> >>selection
+ over target>> >>target
+ over time>> >>time
+ [ [ dpy get ] dip requestor>> 0 0 ] dip
XSendEvent drop
flush-dpy ;
: send-notify-success ( evt -- )
- dup XSelectionRequestEvent-property send-notify ;
+ dup property>> send-notify ;
: send-notify-failure ( evt -- )
0 send-notify ;
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays hashtables io kernel math
-math.order namespaces prettyprint sequences strings combinators
-x11 x11.xlib ;
+USING: accessors arrays classes.struct combinators kernel
+math.order namespaces x11 x11.xlib ;
IN: x11.events
GENERIC: expose-event ( event window -- )
GENERIC: client-event ( event window -- )
: next-event ( -- event )
- dpy get "XEvent" <c-object> [ XNextEvent drop ] keep ;
+ dpy get XEvent <struct> [ XNextEvent drop ] keep ;
: mask-event ( mask -- event )
- [ dpy get ] dip "XEvent" <c-object> [ XMaskEvent drop ] keep ;
+ [ dpy get ] dip XEvent <struct> [ XMaskEvent drop ] keep ;
: events-queued ( mode -- n ) [ dpy get ] dip XEventsQueued ;
-: wheel? ( event -- ? ) XButtonEvent-button 4 7 between? ;
+: wheel? ( event -- ? ) button>> 4 7 between? ;
: button-down-event$ ( event window -- )
over wheel? [ wheel-event ] [ button-down-event ] if ;
over wheel? [ 2drop ] [ button-up-event ] if ;
: handle-event ( event window -- )
- over XAnyEvent-type {
- { Expose [ expose-event ] }
- { ConfigureNotify [ configure-event ] }
- { ButtonPress [ button-down-event$ ] }
- { ButtonRelease [ button-up-event$ ] }
- { EnterNotify [ enter-event ] }
- { LeaveNotify [ leave-event ] }
- { MotionNotify [ motion-event ] }
- { KeyPress [ key-down-event ] }
- { KeyRelease [ key-up-event ] }
- { FocusIn [ focus-in-event ] }
- { FocusOut [ focus-out-event ] }
- { SelectionNotify [ selection-notify-event ] }
- { SelectionRequest [ selection-request-event ] }
- { ClientMessage [ client-event ] }
+ over type>> {
+ { Expose [ XExposeEvent>> expose-event ] }
+ { ConfigureNotify [ XConfigureEvent>> configure-event ] }
+ { ButtonPress [ XButtonEvent>> button-down-event$ ] }
+ { ButtonRelease [ XButtonEvent>> button-up-event$ ] }
+ { EnterNotify [ XCrossingEvent>> enter-event ] }
+ { LeaveNotify [ XCrossingEvent>> leave-event ] }
+ { MotionNotify [ XMotionEvent>> motion-event ] }
+ { KeyPress [ XKeyEvent>> key-down-event ] }
+ { KeyRelease [ XKeyEvent>> key-up-event ] }
+ { FocusIn [ XFocusChangeEvent>> focus-in-event ] }
+ { FocusOut [ XFocusChangeEvent>> focus-out-event ] }
+ { SelectionNotify [ XSelectionEvent>> selection-notify-event ] }
+ { SelectionRequest [ XSelectionRequestEvent>> selection-request-event ] }
+ { ClientMessage [ XClientMessageEvent>> client-event ] }
[ 3drop ]
} case ;
-: configured-loc ( event -- dim )
- [ XConfigureEvent-x ] [ XConfigureEvent-y ] bi 2array ;
+: event-loc ( event -- loc )
+ [ x>> ] [ y>> ] bi 2array ;
-: configured-dim ( event -- dim )
- [ XConfigureEvent-width ] [ XConfigureEvent-height ] bi 2array ;
-
-: mouse-event-loc ( event -- loc )
- [ XButtonEvent-x ] [ XButtonEvent-y ] bi 2array ;
+: event-dim ( event -- dim )
+ [ width>> ] [ height>> ] bi 2array ;
: close-box? ( event -- ? )
- [ XClientMessageEvent-message_type "WM_PROTOCOLS" x-atom = ]
- [ XClientMessageEvent-data0 "WM_DELETE_WINDOW" x-atom = ]
+ [ message_type>> "WM_PROTOCOLS" x-atom = ]
+ [ data0>> "WM_DELETE_WINDOW" x-atom = ]
bi and ;
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types hashtables kernel math math.vectors
-math.bitwise namespaces sequences x11 x11.xlib x11.constants x11.glx
-arrays fry ;
+USING: accessors kernel math math.bitwise math.vectors
+namespaces sequences x11 x11.xlib x11.constants x11.glx arrays
+fry classes.struct ;
IN: x11.windows
: create-window-mask ( -- n )
{ CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
: create-colormap ( visinfo -- colormap )
- [ dpy get root get ] dip XVisualInfo-visual AllocNone
+ [ dpy get root get ] dip visual>> AllocNone
XCreateColormap ;
: event-mask ( -- n )
} flags ;
: window-attributes ( visinfo -- attributes )
- "XSetWindowAttributes" <c-object>
- 0 over set-XSetWindowAttributes-background_pixel
- 0 over set-XSetWindowAttributes-border_pixel
- [ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep
- event-mask over set-XSetWindowAttributes-event_mask ;
+ XSetWindowAttributes <struct>
+ 0 >>background_pixel
+ 0 >>border_pixel
+ event-mask >>event_mask
+ swap create-colormap >>colormap ;
: set-size-hints ( window -- )
- "XSizeHints" <c-object>
- USPosition over set-XSizeHints-flags
+ XSizeHints <struct>
+ USPosition >>flags
[ dpy get ] 2dip XSetWMNormalHints ;
: auto-position ( window loc -- )
: create-window ( loc dim visinfo -- window )
pick [
[ [ [ dpy get root get ] dip >xy ] dip { 1 1 } vmax >xy 0 ] dip
- [ XVisualInfo-depth InputOutput ] keep
- [ XVisualInfo-visual create-window-mask ] keep
+ [ depth>> InputOutput ] keep
+ [ visual>> create-window-mask ] keep
window-attributes XCreateWindow
dup
] dip auto-position ;
! add to this library and are wondering what part of the file to
! modify, just find the function or data structure in the manual
! and note the section.
-
-USING: kernel arrays alien alien.c-types alien.strings
-alien.syntax math math.bitwise words sequences namespaces
-continuations io io.encodings.ascii x11.syntax ;
+USING: accessors kernel arrays alien alien.c-types alien.strings
+alien.syntax classes.struct math math.bitwise words sequences
+namespaces continuations io io.encodings.ascii x11.syntax ;
IN: x11.xlib
LIBRARY: xlib
!
! This struct is incomplete
-C-STRUCT: Display
-{ "void*" "ext_data" }
-{ "void*" "free_funcs" }
-{ "int" "fd" } ;
+STRUCT: Display
+{ ext_data void* }
+{ free_funcs void* }
+{ fd int } ;
X-FUNCTION: Display* XOpenDisplay ( void* display_name ) ;
: CWColormap ( -- n ) 13 2^ ; inline
: CWCursor ( -- n ) 14 2^ ; inline
-C-STRUCT: XSetWindowAttributes
- { "Pixmap" "background_pixmap" }
- { "ulong" "background_pixel" }
- { "Pixmap" "border_pixmap" }
- { "ulong" "border_pixel" }
- { "int" "bit_gravity" }
- { "int" "win_gravity" }
- { "int" "backing_store" }
- { "ulong" "backing_planes" }
- { "ulong" "backing_pixel" }
- { "Bool" "save_under" }
- { "long" "event_mask" }
- { "long" "do_not_propagate_mask" }
- { "Bool" "override_redirect" }
- { "Colormap" "colormap" }
- { "Cursor" "cursor" } ;
+STRUCT: XSetWindowAttributes
+{ background_pixmap Pixmap }
+{ background_pixel ulong }
+{ border_pixmap Pixmap }
+{ border_pixel ulong }
+{ bit_gravity int }
+{ win_gravity int }
+{ backing_store int }
+{ backing_planes ulong }
+{ backing_pixel ulong }
+{ save_under Bool }
+{ event_mask long }
+{ do_not_propagate_mask long }
+{ override_redirect Bool }
+{ colormap Colormap }
+{ cursor Cursor } ;
CONSTANT: UnmapGravity 0
: CWSibling ( -- n ) 5 2^ ; inline
: CWStackMode ( -- n ) 6 2^ ; inline
-C-STRUCT: XWindowChanges
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "border_width" }
- { "Window" "sibling" }
- { "int" "stack_mode" } ;
+STRUCT: XWindowChanges
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ border_width int }
+{ sibling Window }
+{ stack_mode int } ;
X-FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ;
X-FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ;
Window* parent_return,
Window** children_return, uint* nchildren_return ) ;
-C-STRUCT: XWindowAttributes
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" " height" }
- { "int" "border_width" }
- { "int" "depth" }
- { "Visual*" "visual" }
- { "Window" "root" }
- { "int" "class" }
- { "int" "bit_gravity" }
- { "int" "win_gravity" }
- { "int" "backing_store" }
- { "ulong" "backing_planes" }
- { "ulong" "backing_pixel" }
- { "Bool" "save_under" }
- { "Colormap" "colormap" }
- { "Bool" "map_installed" }
- { "int" "map_state" }
- { "long" "all_event_masks" }
- { "long" "your_event_mask" }
- { "long" "do_not_propagate_mask" }
- { "Bool" "override_redirect" }
- { "Screen*" "screen" } ;
+STRUCT: XWindowAttributes
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ border_width int }
+{ depth int }
+{ visual Visual* }
+{ root Window }
+{ class int }
+{ bit_gravity int }
+{ win_gravity int }
+{ backing_store int }
+{ backing_planes ulong }
+{ backing_pixel ulong }
+{ save_under Bool }
+{ colormap Colormap }
+{ map_installed Bool }
+{ map_state int }
+{ all_event_masks long }
+{ your_event_mask long }
+{ do_not_propagate_mask long }
+{ override_redirect Bool }
+{ screen Screen* } ;
X-FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ;
! 6 - Color Management Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XColor
- { "ulong" "pixel" }
- { "ushort" "red" }
- { "ushort" "green" }
- { "ushort" "blue" }
- { "char" "flags" }
- { "char" "pad" } ;
+STRUCT: XColor
+{ pixel ulong }
+{ red ushort }
+{ green ushort }
+{ blue ushort }
+{ flags char }
+{ pad char } ;
X-FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ;
X-FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ;
CONSTANT: GXnand HEX: e
CONSTANT: GXset HEX: f
-C-STRUCT: XGCValues
- { "int" "function" }
- { "ulong" "plane_mask" }
- { "ulong" "foreground" }
- { "ulong" "background" }
- { "int" "line_width" }
- { "int" "line_style" }
- { "int" "cap_style" }
- { "int" "join_style" }
- { "int" "fill_style" }
- { "int" "fill_rule" }
- { "int" "arc_mode" }
- { "Pixmap" "tile" }
- { "Pixmap" "stipple" }
- { "int" "ts_x_origin" }
- { "int" "ts_y_origin" }
- { "Font" "font" }
- { "int" "subwindow_mode" }
- { "Bool" "graphics_exposures" }
- { "int" "clip_x_origin" }
- { "int" "clip_y_origin" }
- { "Pixmap" "clip_mask" }
- { "int" "dash_offset" }
- { "char" "dashes" } ;
+STRUCT: XGCValues
+{ function int }
+{ plane_mask ulong }
+{ foreground ulong }
+{ background ulong }
+{ line_width int }
+{ line_style int }
+{ cap_style int }
+{ join_style int }
+{ fill_style int }
+{ fill_rule int }
+{ arc_mode int }
+{ tile Pixmap }
+{ stipple Pixmap }
+{ ts_x_origin int }
+{ ts_y_origin int }
+{ font Font }
+{ subwindow_mode int }
+{ graphics_exposures Bool }
+{ clip_x_origin int }
+{ clip_y_origin int }
+{ clip_mask Pixmap }
+{ dash_offset int }
+{ dashes char } ;
X-FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ;
X-FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ;
! 8.5 - Font Metrics
-C-STRUCT: XCharStruct
- { "short" "lbearing" }
- { "short" "rbearing" }
- { "short" "width" }
- { "short" "ascent" }
- { "short" "descent" }
- { "ushort" "attributes" } ;
+STRUCT: XCharStruct
+{ lbearing short }
+{ rbearing short }
+{ width short }
+{ ascent short }
+{ descent short }
+{ attributes ushort } ;
X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
-C-STRUCT: XFontStruct
- { "XExtData*" "ext_data" }
- { "Font" "fid" }
- { "uint" "direction" }
- { "uint" "min_char_or_byte2" }
- { "uint" "max_char_or_byte2" }
- { "uint" "min_byte1" }
- { "uint" "max_byte1" }
- { "Bool" "all_chars_exist" }
- { "uint" "default_char" }
- { "int" "n_properties" }
- { "XFontProp*" "properties" }
- { "XCharStruct" "min_bounds" }
- { "XCharStruct" "max_bounds" }
- { "XCharStruct*" "per_char" }
- { "int" "ascent" }
- { "int" "descent" } ;
+STRUCT: XFontStruct
+{ ext_data XExtData* }
+{ fid Font }
+{ direction uint }
+{ min_char_or_byte2 uint }
+{ max_char_or_byte2 uint }
+{ min_byte1 uint }
+{ max_byte1 uint }
+{ all_chars_exist Bool }
+{ default_char uint }
+{ n_properties int }
+{ properties XFontProp* }
+{ min_bounds XCharStruct }
+{ max_bounds XCharStruct }
+{ per_char XCharStruct* }
+{ ascent int }
+{ descent int } ;
X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ;
CONSTANT: AllPlanes -1
-C-STRUCT: XImage-funcs
- { "void*" "create_image" }
- { "void*" "destroy_image" }
- { "void*" "get_pixel" }
- { "void*" "put_pixel" }
- { "void*" "sub_image" }
- { "void*" "add_pixel" } ;
-
-C-STRUCT: XImage
- { "int" "width" }
- { "int" "height" }
- { "int" "xoffset" }
- { "int" "format" }
- { "char*" "data" }
- { "int" "byte_order" }
- { "int" "bitmap_unit" }
- { "int" "bitmap_bit_order" }
- { "int" "bitmap_pad" }
- { "int" "depth" }
- { "int" "bytes_per_line" }
- { "int" "bits_per_pixel" }
- { "ulong" "red_mask" }
- { "ulong" "green_mask" }
- { "ulong" "blue_mask" }
- { "XPointer" "obdata" }
- { "XImage-funcs" "f" } ;
+STRUCT: XImage-funcs
+{ create_image void* }
+{ destroy_image void* }
+{ get_pixel void* }
+{ put_pixel void* }
+{ sub_image void* }
+{ add_pixel void* } ;
+
+STRUCT: XImage
+{ width int }
+{ height int }
+{ xoffset int }
+{ format int }
+{ data char* }
+{ byte_order int }
+{ bitmap_unit int }
+{ bitmap_bit_order int }
+{ bitmap_pad int }
+{ depth int }
+{ bytes_per_line int }
+{ bits_per_pixel int }
+{ red_mask ulong }
+{ green_mask ulong }
+{ blue_mask ulong }
+{ obdata XPointer }
+{ f XImage-funcs } ;
X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
X-FUNCTION: int XDestroyImage ( XImage* ximage ) ;
: XImage-size ( ximage -- size )
- [ XImage-height ] [ XImage-bytes_per_line ] bi * ;
+ [ height>> ] [ bytes_per_line>> ] bi * ;
: XImage-pixels ( ximage -- byte-array )
- [ XImage-data ] [ XImage-size ] bi memory>byte-array ;
+ [ data>> ] [ XImage-size ] bi memory>byte-array ;
!
! 9 - Window and Session Manager Functions
CONSTANT: MotionNotify 6
CONSTANT: EnterNotify 7
CONSTANT: LeaveNotify 8
-CONSTANT: FocusIn 9
+CONSTANT: FocusIn 9
CONSTANT: FocusOut 10
CONSTANT: KeymapNotify 11
-CONSTANT: Expose 12
-CONSTANT: GraphicsExpose 13
+CONSTANT: Expose 12
+CONSTANT: GraphicsExpose 13
CONSTANT: NoExpose 14
CONSTANT: VisibilityNotify 15
CONSTANT: CreateNotify 16
CONSTANT: UnmapNotify 18
CONSTANT: MapNotify 19
CONSTANT: MapRequest 20
-CONSTANT: ReparentNotify 21
-CONSTANT: ConfigureNotify 22
+CONSTANT: ReparentNotify 21
+CONSTANT: ConfigureNotify 22
CONSTANT: ConfigureRequest 23
CONSTANT: GravityNotify 24
CONSTANT: ResizeRequest 25
-CONSTANT: CirculateNotify 26
+CONSTANT: CirculateNotify 26
CONSTANT: CirculateRequest 27
-CONSTANT: PropertyNotify 28
-CONSTANT: SelectionClear 29
+CONSTANT: PropertyNotify 28
+CONSTANT: SelectionClear 29
CONSTANT: SelectionRequest 30
-CONSTANT: SelectionNotify 31
-CONSTANT: ColormapNotify 32
+CONSTANT: SelectionNotify 31
+CONSTANT: ColormapNotify 32
CONSTANT: ClientMessage 33
CONSTANT: MappingNotify 34
CONSTANT: LASTEvent 35
-C-STRUCT: XAnyEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" } ;
+STRUCT: XAnyEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: Mod4Mask ( -- n ) 1 6 shift ; inline
: Mod5Mask ( -- n ) 1 7 shift ; inline
-C-STRUCT: XButtonEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Window" "root" }
- { "Window" "subwindow" }
- { "Time" "time" }
- { "int" "x" }
- { "int" "y" }
- { "int" "x_root" }
- { "int" "y_root" }
- { "uint" "state" }
- { "uint" "button" }
- { "Bool" "same_screen" } ;
+STRUCT: XButtonEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ root Window }
+{ subwindow Window }
+{ time Time }
+{ x int }
+{ y int }
+{ x_root int }
+{ y_root int }
+{ state uint }
+{ button uint }
+{ same_screen Bool } ;
TYPEDEF: XButtonEvent XButtonPressedEvent
TYPEDEF: XButtonEvent XButtonReleasedEvent
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XKeyEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Window" "root" }
- { "Window" "subwindow" }
- { "Time" "time" }
- { "int" "x" }
- { "int" "y" }
- { "int" "x_root" }
- { "int" "y_root" }
- { "uint" "state" }
- { "uint" "keycode" }
- { "Bool" "same_screen" } ;
+STRUCT: XKeyEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ root Window }
+{ subwindow Window }
+{ time Time }
+{ x int }
+{ y int }
+{ x_root int }
+{ y_root int }
+{ state uint }
+{ keycode uint }
+{ same_screen Bool } ;
TYPEDEF: XKeyEvent XKeyPressedEvent
TYPEDEF: XKeyEvent XKeyReleasedEvent
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XMotionEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Window" "root" }
- { "Window" "subwindow" }
- { "Time" "time" }
- { "int" "x" }
- { "int" "y" }
- { "int" "x_root" }
- { "int" "y_root" }
- { "uint" "state" }
- { "char" "is_hint" }
- { "Bool" "same_screen" } ;
+STRUCT: XMotionEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ root Window }
+{ subwindow Window }
+{ time Time }
+{ x int }
+{ y int }
+{ x_root int }
+{ y_root int }
+{ state uint }
+{ is_hint char }
+{ same_screen Bool } ;
TYPEDEF: XMotionEvent XPointerMovedEvent
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XCrossingEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Window" "root" }
- { "Window" "subwindow" }
- { "Time" "time" }
- { "int" "x" }
- { "int" "y" }
- { "int" "x_root" }
- { "int" "y_root" }
- { "int" "mode" }
- { "int" "detail" }
- { "Bool" "same_screen" }
- { "Bool" "focus" }
- { "uint" "state" } ;
+STRUCT: XCrossingEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ root Window }
+{ subwindow Window }
+{ time Time }
+{ x int }
+{ y int }
+{ x_root int }
+{ y_root int }
+{ mode int }
+{ detail int }
+{ same_screen Bool }
+{ focus Bool }
+{ state uint } ;
TYPEDEF: XCrossingEvent XEnterWindowEvent
TYPEDEF: XCrossingEvent XLeaveWindowEvent
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XFocusChangeEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "int" "mode" }
- { "int" "detail" } ;
+STRUCT: XFocusChangeEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ mode int }
+{ detail int } ;
TYPEDEF: XFocusChangeEvent XFocusInEvent
TYPEDEF: XFocusChangeEvent XFocusOutEvent
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XExposeEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "count" } ;
+STRUCT: XExposeEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ count int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XGraphicsExposeEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Drawable" "drawable" }
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "count" }
- { "int" "major_code" }
- { "int" "minor_code" } ;
-
-C-STRUCT: XNoExposeEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Drawable" "drawable" }
- { "int" "major_code" }
- { "int" "minor_code" } ;
+STRUCT: XGraphicsExposeEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ drawable Drawable }
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ count int }
+{ major_code int }
+{ minor_code int } ;
+
+STRUCT: XNoExposeEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ drawable Drawable }
+{ major_code int }
+{ minor_code int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XVisibilityEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "int" "state" } ;
+STRUCT: XVisibilityEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ state int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XCreateWindowEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "parent" }
- { "Window" "window" }
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "border_width" }
- { "Bool" "override_redirect" } ;
+STRUCT: XCreateWindowEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ parent Window }
+{ window Window }
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ border_width int }
+{ override_redirect Bool } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XDestroyWindowEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" } ;
+STRUCT: XDestroyWindowEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XUnmapEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" }
- { "Bool" "from_configure" } ;
+STRUCT: XUnmapEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window }
+{ from_configure Bool } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XMapEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" }
- { "Bool" "override_redirect" } ;
+STRUCT: XMapEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window }
+{ override_redirect Bool } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XMapRequestEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "parent" }
- { "Window" "window" } ;
+STRUCT: XMapRequestEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ parent Window }
+{ window Window } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XReparentEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" }
- { "Window" "parent" }
- { "int" "x" }
- { "int" "y" }
- { "Bool" "override_redirect" } ;
+STRUCT: XReparentEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window }
+{ parent Window }
+{ x int }
+{ y int }
+{ override_redirect Bool } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XConfigureEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" }
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "border_width" }
- { "Window" "above" }
- { "Bool" "override_redirect" } ;
+STRUCT: XConfigureEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window }
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ border_width int }
+{ above Window }
+{ override_redirect Bool } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XGravityEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" }
- { "int" "x" }
- { "int" "y" } ;
+STRUCT: XGravityEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window }
+{ x int }
+{ y int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XResizeRequestEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "int" "width" }
- { "int" "height" } ;
+STRUCT: XResizeRequestEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ width int }
+{ height int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XConfigureRequestEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "parent" }
- { "Window" "window" }
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "border_width" }
- { "Window" "above" }
- { "int" "detail" }
- { "ulong" "value_mask" } ;
+STRUCT: XConfigureRequestEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ parent Window }
+{ window Window }
+{ x int }
+{ y int }
+{ width int }
+{ height int }
+{ border_width int }
+{ above Window }
+{ detail int }
+{ value_mask ulong } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XCirculateEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "event" }
- { "Window" "window" }
- { "int" "place" } ;
+STRUCT: XCirculateEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ event Window }
+{ window Window }
+{ place int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XCirculateRequestEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "parent" }
- { "Window" "window" }
- { "int" "place" } ;
+STRUCT: XCirculateRequestEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ parent Window }
+{ window Window }
+{ place int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XPropertyEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Atom" "atom" }
- { "Time" "time" }
- { "int" "state" } ;
+STRUCT: XPropertyEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ atom Atom }
+{ time Time }
+{ state int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XSelectionClearEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Atom" "selection" }
- { "Time" "time" } ;
+STRUCT: XSelectionClearEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ selection Atom }
+{ time Time } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XSelectionRequestEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "owner" }
- { "Window" "requestor" }
- { "Atom" "selection" }
- { "Atom" "target" }
- { "Atom" "property" }
- { "Time" "time" } ;
+STRUCT: XSelectionRequestEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ owner Window }
+{ requestor Window }
+{ selection Atom }
+{ target Atom }
+{ property Atom }
+{ time Time } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XSelectionEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "requestor" }
- { "Atom" "selection" }
- { "Atom" "target" }
- { "Atom" "property" }
- { "Time" "time" } ;
+STRUCT: XSelectionEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ requestor Window }
+{ selection Atom }
+{ target Atom }
+{ property Atom }
+{ time Time } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XColormapEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Colormap" "colormap" }
- { "Bool" "new" }
- { "int" "state" } ;
+STRUCT: XColormapEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ colormap Colormap }
+{ new Bool }
+{ state int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XClientMessageEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "Atom" "message_type" }
- { "int" "format" }
- { "long" "data0" }
- { "long" "data1" }
- { "long" "data2" }
- { "long" "data3" }
- { "long" "data4" }
-! union {
-! char b[20];
-! short s[10];
-! long l[5];
-! } data;
-;
+STRUCT: XClientMessageEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ message_type Atom }
+{ format int }
+{ data0 long }
+{ data1 long }
+{ data2 long }
+{ data3 long }
+{ data4 long } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XMappingEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- { "int" "request" }
- { "int" "first_keycode" }
- { "int" "count" } ;
+STRUCT: XMappingEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ request int }
+{ first_keycode int }
+{ count int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XErrorEvent
- { "int" "type" }
- { "Display*" "display" }
- { "XID" "resourceid" }
- { "ulong" "serial" }
- { "uchar" "error_code" }
- { "uchar" "request_code" }
- { "uchar" "minor_code" } ;
+STRUCT: XErrorEvent
+{ type int }
+{ display Display* }
+{ resourceid XID }
+{ serial ulong }
+{ error_code uchar }
+{ request_code uchar }
+{ minor_code uchar } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-C-STRUCT: XKeymapEvent
- { "int" "type" }
- { "ulong" "serial" }
- { "Bool" "send_event" }
- { "Display*" "display" }
- { "Window" "window" }
- ! char key_vector[32];
- { "int" "pad" }
- { "int" "pad" }
- { "int" "pad" }
- { "int" "pad" }
- { "int" "pad" }
- { "int" "pad" }
- { "int" "pad" }
- { "int" "pad" } ;
-
-C-UNION: XEvent
- "int"
- "XAnyEvent"
- "XKeyEvent"
- "XButtonEvent"
- "XMotionEvent"
- "XCrossingEvent"
- "XFocusChangeEvent"
- "XExposeEvent"
- "XGraphicsExposeEvent"
- "XNoExposeEvent"
- "XVisibilityEvent"
- "XCreateWindowEvent"
- "XDestroyWindowEvent"
- "XUnmapEvent"
- "XMapEvent"
- "XMapRequestEvent"
- "XReparentEvent"
- "XConfigureEvent"
- "XGravityEvent"
- "XResizeRequestEvent"
- "XConfigureRequestEvent"
- "XCirculateEvent"
- "XCirculateRequestEvent"
- "XPropertyEvent"
- "XSelectionClearEvent"
- "XSelectionRequestEvent"
- "XSelectionEvent"
- "XColormapEvent"
- "XClientMessageEvent"
- "XMappingEvent"
- "XErrorEvent"
- "XKeymapEvent"
- { "long" 24 } ;
+STRUCT: XKeymapEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ window Window }
+{ pad int }
+{ pad int }
+{ pad int }
+{ pad int }
+{ pad int }
+{ pad int }
+{ pad int }
+{ pad int } ;
+
+UNION-STRUCT: XEvent
+{ int int }
+{ XAnyEvent XAnyEvent }
+{ XKeyEvent XKeyEvent }
+{ XButtonEvent XButtonEvent }
+{ XMotionEvent XMotionEvent }
+{ XCrossingEvent XCrossingEvent }
+{ XFocusChangeEvent XFocusChangeEvent }
+{ XExposeEvent XExposeEvent }
+{ XGraphicsExposeEvent XGraphicsExposeEvent }
+{ XNoExposeEvent XNoExposeEvent }
+{ XVisibilityEvent XVisibilityEvent }
+{ XCreateWindowEvent XCreateWindowEvent }
+{ XDestroyWindowEvent XDestroyWindowEvent }
+{ XUnmapEvent XUnmapEvent }
+{ XMapEvent XMapEvent }
+{ XMapRequestEvent XMapRequestEvent }
+{ XReparentEvent XReparentEvent }
+{ XConfigureEvent XConfigureEvent }
+{ XGravityEvent XGravityEvent }
+{ XResizeRequestEvent XResizeRequestEvent }
+{ XConfigureRequestEvent XConfigureRequestEvent }
+{ XCirculateEvent XCirculateEvent }
+{ XCirculateRequestEvent XCirculateRequestEvent }
+{ XPropertyEvent XPropertyEvent }
+{ XSelectionClearEvent XSelectionClearEvent }
+{ XSelectionRequestEvent XSelectionRequestEvent }
+{ XSelectionEvent XSelectionEvent }
+{ XColormapEvent XColormapEvent }
+{ XClientMessageEvent XClientMessageEvent }
+{ XMappingEvent XMappingEvent }
+{ XErrorEvent XErrorEvent }
+{ XKeymapEvent XKeymapEvent }
+{ padding long[24] } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 11 - Event Handling Functions
: PAllHints ( -- n )
{ PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable
-C-STRUCT: XSizeHints
- { "long" "flags" }
- { "int" "x" }
- { "int" "y" }
- { "int" "width" }
- { "int" "height" }
- { "int" "min_width" }
- { "int" "min_height" }
- { "int" "max_width" }
- { "int" "max_height" }
- { "int" "width_inc" }
- { "int" "height_inc" }
- { "int" "min_aspect_x" }
- { "int" "min_aspect_y" }
- { "int" "max_aspect_x" }
- { "int" "max_aspect_y" }
- { "int" "base_width" }
- { "int" "base_height" }
- { "int" "win_gravity" } ;
+STRUCT: XSizeHints
+ { flags long }
+ { x int }
+ { y int }
+ { width int }
+ { height int }
+ { min_width int }
+ { min_height int }
+ { max_width int }
+ { max_height int }
+ { width_inc int }
+ { height_inc int }
+ { min_aspect_x int }
+ { min_aspect_y int }
+ { max_aspect_x int }
+ { max_aspect_y int }
+ { base_width int }
+ { base_height int }
+ { win_gravity int } ;
! 14.1.10. Setting and Reading the WM_PROTOCOLS Property
CONSTANT: VisualBitsPerRGBMask HEX: 100
CONSTANT: VisualAllMask HEX: 1FF
-C-STRUCT: XVisualInfo
- { "Visual*" "visual" }
- { "VisualID" "visualid" }
- { "int" "screen" }
- { "uint" "depth" }
- { "int" "class" }
- { "ulong" "red_mask" }
- { "ulong" "green_mask" }
- { "ulong" "blue_mask" }
- { "int" "colormap_size" }
- { "int" "bits_per_rgb" } ;
+STRUCT: XVisualInfo
+ { visual Visual* }
+ { visualid VisualID }
+ { screen int }
+ { depth uint }
+ { class int }
+ { red_mask ulong }
+ { green_mask ulong }
+ { blue_mask ulong }
+ { colormap_size int }
+ { bits_per_rgb int } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Appendix D - Compatibility Functions
{ $subsection 2/ }
{ $subsection 2^ }
{ $subsection bit? }
+"Advanced topics:"
{ $subsection "math.bitwise" }
{ $subsection "math.bits" }
{ $see-also "booleans" } ;
! 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 hints io ;
+struct-arrays io ;
IN: benchmark.struct-arrays
STRUCT: point { x float } { y float } { z float } ;
: struct-array-benchmark ( len -- )
make-points [ normalize-points ] [ max-points ] bi print-point ;
-HINTS: struct-array-benchmark fixnum ;
-
: main ( -- ) 5000000 struct-array-benchmark ;
MAIN: main
: terrain-generation-benchmark ( -- )
"Generating terrain segment..." write flush yield
- <terrain> { 0.0 0.0 } terrain-segment drop
+ <terrain> { 0 0 } terrain-segment drop
"done" print ;
MAIN: terrain-generation-benchmark
USING: accessors arrays assocs bson.constants combinators
combinators.smart constructors destructors formatting fry hashtables
io io.pools io.sockets kernel linked-assocs math mongodb.connection
-mongodb.msg parser prettyprint sequences sets splitting strings
+mongodb.msg parser prettyprint prettyprint.custom prettyprint.sections
+sequences sets splitting strings
tools.continuations uuid memoize locals ;
IN: mongodb.driver
ERROR: mdb-error msg ;
+M: mdb-error pprint* ( obj -- )
+ msg>> text ;
+
: >pwd-digest ( user password -- digest )
"mongo" swap 3array ":" join md5-checksum ;
projects / factor.git / commitdiff