USING: calendar namespaces alien.c-types system
-windows.kernel32 kernel math combinators windows.errors ;
+windows.kernel32 kernel math combinators windows.errors
+accessors classes.struct ;
IN: calendar.windows
M: windows gmt-offset ( -- hours minutes seconds )
- "TIME_ZONE_INFORMATION" <c-object>
+ TIME_ZONE_INFORMATION <struct>
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_INVALID [ win32-error-string throw ] }
- { TIME_ZONE_ID_UNKNOWN [ TIME_ZONE_INFORMATION-Bias ] }
- { TIME_ZONE_ID_STANDARD [ TIME_ZONE_INFORMATION-Bias ] }
- { TIME_ZONE_ID_DAYLIGHT [
- [ TIME_ZONE_INFORMATION-Bias ]
- [ TIME_ZONE_INFORMATION-DaylightBias ] bi +
- ] }
+ { TIME_ZONE_ID_UNKNOWN [ Bias>> ] }
+ { TIME_ZONE_ID_STANDARD [ Bias>> ] }
+ { TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] }
} case neg 60 /mod 0 ;
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
<<
[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
-[ f ] [ struct-test-foo <struct> dup clone [ >c-ptr ] bi@ eq? ] 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
dup struct-class? [ '[ _ boa ] ] [ drop f ] if
] 1 define-partial-eval
-M: struct clone
- [ >c-ptr ] [ byte-length memory>byte-array ] [ class memory>struct ] tri ;
-
<PRIVATE
: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
'[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline
[ heap-size malloc ] keep memory>struct ; inline
: malloc-struct ( class -- struct )
- [ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ;
+ [ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ; inline
: (struct) ( class -- struct )
[ heap-size (byte-array) ] keep memory>struct ; inline
: <struct> ( class -- struct )
- [ >c-ptr clone ] [ heap-size <byte-array> ] (init-struct) ;
+ [ >c-ptr clone ] [ heap-size <byte-array> ] (init-struct) ; inline
MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
[
\ 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 ;
+
+: 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-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 -- )
[
! 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
- math.libm:fasin
- math.libm:fatan
- math.libm:fatan2
- math.libm:fcos
- math.libm:fsin
- math.libm:ftan
- math.libm:fcosh
- math.libm:fsinh
- math.libm:ftanh
- math.libm:fexp
- math.libm:flog
- math.libm:fpow
- math.libm:facosh
- math.libm:fasinh
- math.libm:fatanh
+ { 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 ] }
- { \ 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 ] }
- { \ 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 -- ) ;
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.libm ;
+math.order math.libm math.parser ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
[ ] [ missing-gc-check-2 ] unit-test
-[ 1 0.169967142900241 ] [ 1.4 [ 1 swap fcos ] compile-call ] unit-test
-[ 1 0.169967142900241 ] [ 1.4 1 [ swap fcos ] compile-call ] unit-test
-[ 0.169967142900241 0.9854497299884601 ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call ] unit-test
-[ 1 0.169967142900241 0.9854497299884601 ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call ] unit-test
\ No newline at end of file
+[ 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
io.encodings io ;
IN: environment.winnt
+<< "TCHAR" require-c-type-arrays >>
+
M: winnt os-env ( key -- value )
- MAX_UNICODE_PATH "TCHAR" <c-array>
+ MAX_UNICODE_PATH "TCHAR" <c-type-array>
[ dup length GetEnvironmentVariable ] keep over 0 = [
2drop f
] [
struct-arrays ui.backend.windows vectors windows.com
windows.dinput windows.dinput.constants windows.errors
windows.kernel32 windows.messages windows.ole32
-windows.user32 ;
+windows.user32 classes.struct ;
IN: game-input.dinput
CONSTANT: MOUSE-BUFFER-SIZE 16
[ remove-controller ] each ;
: device-interface? ( dbt-broadcast-hdr -- ? )
- DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
+ dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = ;
: device-arrived ( dbt-broadcast-hdr -- )
device-interface? [ find-controllers ] when ;
{ 0 0 } >>dim ;
: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
- "DEV_BROADCAST_DEVICEW" <c-object>
- "DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
- DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
+ DEV_BROADCAST_DEVICEW <struct>
+ DEV_BROADCAST_DEVICEW heap-size >>dbcc_size
+ DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ;
: create-device-change-window ( -- )
<zero-window-rect> WS_OVERLAPPEDWINDOW 0 create-window
delete-dinput ;
M: dinput-game-input-backend (reset-game-input)
- {
- +dinput+ +keyboard-device+ +keyboard-state+
- +controller-devices+ +controller-guids+
- +device-change-window+ +device-change-handle+
- } [ f swap set-global ] each ;
+ global [
+ {
+ +dinput+ +keyboard-device+ +keyboard-state+
+ +controller-devices+ +controller-guids+
+ +device-change-window+ +device-change-handle+
+ } [ off ] each
+ ] bind ;
M: dinput-game-input-backend get-controllers
+controller-devices+ get
! 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 )
io.pathnames io.backend io.files.windows destructors
kernel accessors calendar windows windows.errors
windows.kernel32 alien.c-types sequences splitting
-fry continuations ;
+fry continuations classes.struct ;
IN: io.directories.windows
M: windows touch-file ( path -- )
RemoveDirectory win32-error=0/f ;
: find-first-file ( path -- WIN32_FIND_DATA handle )
- "WIN32_FIND_DATA" <c-object>
+ WIN32_FIND_DATA <struct>
[ nip ] [ FindFirstFile ] 2bi
[ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
: find-next-file ( path -- WIN32_FIND_DATA/f )
- "WIN32_FIND_DATA" <c-object>
+ WIN32_FIND_DATA <struct>
[ nip ] [ FindNextFile ] 2bi 0 = [
GetLastError ERROR_NO_MORE_FILES = [
win32-error
TUPLE: windows-directory-entry < directory-entry attributes ;
M: windows >directory-entry ( byte-array -- directory-entry )
- [ WIN32_FIND_DATA-cFileName utf16n alien>string ]
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
- tri
+ [ cFileName>> utf16n alien>string ]
+ [
+ dwFileAttributes>>
+ [ win32-file-type ] [ win32-file-attributes ] bi
+ ] bi
dupd remove windows-directory-entry boa ;
M: windows (directory-entries) ( path -- seq )
M: openbsd file-systems ( -- seq )
f 0 0 getfsstat dup io-error
- statfs <c-type-array> dup dup length 0 getfsstat io-error
- statfs heap-size group
+ \ statfs <c-type-array> dup dup length 0 getfsstat io-error
+ \ statfs heap-size group
[ f_mntonname>> alien>native-string file-system-info ] map ;
windows.time windows accessors alien.c-types combinators
generalizations system alien.strings io.encodings.utf16n
sequences splitting windows.errors fry continuations destructors
-calendar ascii combinators.short-circuit locals classes.struct ;
+calendar ascii combinators.short-circuit locals classes.struct
+specialized-arrays.ushort ;
IN: io.files.info.windows
:: round-up-to ( n multiple -- n' )
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
[ \ windows-file-info new ] dip
{
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ]
- [
- [ WIN32_FIND_DATA-nFileSizeLow ]
- [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
- ]
- [ WIN32_FIND_DATA-dwFileAttributes >>permissions ]
- [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ]
- [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ]
- [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ]
+ [ dwFileAttributes>> win32-file-type >>type ]
+ [ dwFileAttributes>> win32-file-attributes >>attributes ]
+ [ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit >>size ]
+ [ dwFileAttributes>> >>permissions ]
+ [ ftCreationTime>> FILETIME>timestamp >>created ]
+ [ ftLastWriteTime>> FILETIME>timestamp >>modified ]
+ [ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
} cleave ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
- "WIN32_FIND_DATA" <c-object> [
+ WIN32_FIND_DATA <struct> [
FindFirstFile
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
FindClose win32-error=0/f
calculate-file-system-info ;
: volume>paths ( string -- array )
- 16384 "ushort" <c-array> tuck dup length
+ 16384 <ushort-array> tuck dup length
0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
win32-error-string throw
] [
alien.c-types alien.arrays alien.strings sequences combinators
combinators.short-circuit ascii splitting alien strings assocs
namespaces make accessors tr windows.time windows.shell32
-windows.errors ;
+windows.errors specialized-arrays.ushort classes.struct ;
IN: io.files.windows.nt
M: winnt cwd
- MAX_UNICODE_PATH dup "ushort" <c-array>
+ MAX_UNICODE_PATH dup <ushort-array>
[ GetCurrentDirectory win32-error=0/f ] keep
utf16n alien>string ;
M: winnt cd
SetCurrentDirectory win32-error=0/f ;
-: unicode-prefix ( -- seq )
- "\\\\?\\" ; inline
+CONSTANT: unicode-prefix "\\\\?\\"
M: winnt root-directory? ( path -- ? )
{
<PRIVATE
: windows-file-size ( path -- size )
- normalize-path 0 "WIN32_FILE_ATTRIBUTE_DATA" <c-object>
+ normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
[ GetFileAttributesEx win32-error=0/f ] keep
- [ WIN32_FILE_ATTRIBUTE_DATA-nFileSizeLow ]
- [ WIN32_FILE_ATTRIBUTE_DATA-nFileSizeHigh ] bi >64bit ;
+ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ;
PRIVATE>
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
io.buffers io.files io.timeouts io.encodings.string
io.encodings.utf16n io windows.errors windows.kernel32 windows.types
-io.pathnames ;
+io.pathnames classes.struct ;
IN: io.monitors.windows.nt
: open-directory ( path -- handle )
memory>byte-array utf16n decode ;
: parse-notify-record ( buffer -- path changed )
- [
- [ FILE_NOTIFY_INFORMATION-FileName ]
- [ FILE_NOTIFY_INFORMATION-FileNameLength ]
- bi memory>u16-string
- ]
- [ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ;
+ [ [ FileName>> ] [ FileNameLength>> ] bi memory>u16-string ]
+ [ Action>> parse-action ] bi ;
: (file-notify-records) ( buffer -- buffer )
+ FILE_NOTIFY_INFORMATION memory>struct
dup ,
- dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [
- [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien>
+ dup NextEntryOffset>> zero? [
+ [ NextEntryOffset>> ] [ >c-ptr <displaced-alien> ] bi
(file-notify-records)
] unless ;
: 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
continuations destructors io.ports io.timeouts io.sockets
io namespaces io.streams.duplex io.backend.windows
io.sockets.windows io.backend.windows.nt windows.winsock kernel
-libc math sequences threads system combinators accessors ;
+libc math sequences threads system combinators accessors
+classes.struct windows.kernel32 ;
IN: io.sockets.windows.nt
: malloc-int ( object -- object )
: get-ConnectEx-ptr ( socket -- void* )
SIO_GET_EXTENSION_FUNCTION_POINTER
WSAID_CONNECTEX
- "GUID" heap-size
+ GUID heap-size
"void*" <c-object>
[
"void*" heap-size
lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
: make-receive-buffer ( -- WSABUF )
- "WSABUF" malloc-object &free
- default-buffer-size get over set-WSABUF-len
- default-buffer-size get malloc &free over set-WSABUF-buf ; inline
+ WSABUF malloc-struct &free
+ default-buffer-size get
+ [ >>len ] [ malloc &free >>buf ] bi ; inline
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
WSARecvFrom-args new
} cleave WSARecvFrom socket-error* ; inline
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
- [ lpBuffers>> WSABUF-buf swap memory>byte-array ]
+ [ lpBuffers>> buf>> swap memory>byte-array ]
[ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
M: winnt (receive) ( datagram -- packet addrspec )
dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
: make-send-buffer ( packet -- WSABUF )
- "WSABUF" malloc-object &free
- [ [ malloc-byte-array &free ] dip set-WSABUF-buf ]
- [ [ length ] dip set-WSABUF-len ]
- [ nip ]
- 2tri ; inline
+ [ WSABUF malloc-struct &free ] dip
+ [ malloc-byte-array &free >>buf ]
+ [ length >>len ] bi ; inline
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
WSASendTo-args new
window-controls>> window-control>ex-style symbols>flags ;
: get-RECT-top-left ( RECT -- x y )
- [ RECT-left ] keep RECT-top ;
+ [ left>> ] [ top>> ] bi ;
+
+: get-RECT-width/height ( RECT -- width height )
+ [ [ right>> ] [ left>> ] bi - ]
+ [ [ bottom>> ] [ top>> ] bi - ] bi ;
: get-RECT-dimensions ( RECT -- x y width height )
- [ get-RECT-top-left ] keep
- [ RECT-right ] keep [ RECT-left - ] keep
- [ RECT-bottom ] keep RECT-top - ;
+ [ get-RECT-top-left ] [ get-RECT-width/height ] bi ;
: handle-wm-paint ( hWnd uMsg wParam lParam -- )
#! wParam and lParam are unused
] if ;
: make-TRACKMOUSEEVENT ( hWnd -- alien )
- "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
- "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
+ TRACKMOUSEEVENT <struct>
+ swap >>hwndTrack
+ TRACKMOUSEEVENT heap-size >>cbSize ;
: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
2nip
over make-TRACKMOUSEEVENT
- TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
- 0 over set-TRACKMOUSEEVENT-dwHoverTime
+ TME_LEAVE >>dwFlags
+ 0 >>dwHoverTime
TrackMouseEvent drop
>lo-hi swap window move-hand fire-motion ;
] if ;
:: register-window-class ( class-name-ptr -- )
- "WNDCLASSEX" <c-object> f GetModuleHandle
+ WNDCLASSEX <struct> f GetModuleHandle
class-name-ptr pick GetClassInfoEx 0 = [
- "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
- { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
- ui-wndproc over set-WNDCLASSEX-lpfnWndProc
- 0 over set-WNDCLASSEX-cbClsExtra
- 0 over set-WNDCLASSEX-cbWndExtra
- f GetModuleHandle over set-WNDCLASSEX-hInstance
- f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
- over set-WNDCLASSEX-hIcon
- f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
-
- class-name-ptr over set-WNDCLASSEX-lpszClassName
+ WNDCLASSEX heap-size >>cbSize
+ { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags >>style
+ ui-wndproc >>lpfnWndProc
+ 0 >>cbClsExtra
+ 0 >>cbWndExtra
+ f GetModuleHandle >>hInstance
+ f GetModuleHandle "fraptor" utf16n string>alien LoadIcon >>hIcon
+ f IDC_ARROW LoadCursor >>hCursor
+
+ class-name-ptr >>lpszClassName
RegisterClassEx win32-error=0/f
] [ drop ] if ;
: make-RECT ( world -- RECT )
[ window-loc>> ] [ dim>> ] bi <RECT> ;
-: default-position-RECT ( RECT -- )
- dup get-RECT-dimensions [ 2drop ] 2dip
- CW_USEDEFAULT + pick set-RECT-bottom
- CW_USEDEFAULT + over set-RECT-right
- CW_USEDEFAULT over set-RECT-left
- CW_USEDEFAULT swap set-RECT-top ;
+: default-position-RECT ( RECT -- RECT' )
+ dup get-RECT-width/height
+ [ CW_USEDEFAULT + >>bottom ] dip
+ CW_USEDEFAULT + >>right
+ CW_USEDEFAULT >>left
+ CW_USEDEFAULT >>top ;
: make-adjusted-RECT ( rect style ex-style -- RECT )
[
dup get-RECT-top-left [ zero? ] both? swap
dup
] 2dip adjust-RECT
- swap [ dup default-position-RECT ] when ;
+ swap [ default-position-RECT ] when ;
: get-window-class ( -- class-name )
class-name-ptr [
: fullscreen-RECT ( hwnd -- RECT )
MONITOR_DEFAULTTONEAREST MonitorFromWindow
- "MONITORINFOEX" <c-object> dup length over set-MONITORINFOEX-cbSize
- [ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ;
+ MONITORINFOEX <struct>
+ MONITORINFOEX heap-size >>cbSize
+ [ GetMonitorInfo win32-error=0/f ] keep rcMonitor>> ;
: client-area>RECT ( hwnd -- RECT )
- "RECT" <c-object>
+ RECT <struct>
[ GetClientRect win32-error=0/f ]
[ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
[ nip ] 2tri ;
: hwnd>RECT ( hwnd -- RECT )
- "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep ;
+ RECT <struct> [ GetWindowRect win32-error=0/f ] keep ;
M: windows-ui-backend (grab-input) ( handle -- )
0 ShowCursor drop
! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets
-ui.gadgets.private ui.gestures ui.backend ui.clipboards
-ui.gadgets.worlds ui.render ui.event-loop assocs kernel math
-namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim
-x11.glx x11.clipboard x11.constants x11.windows x11.io
-io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
-command-line math.vectors classes.tuple opengl.gl threads
-math.rectangles environment ascii literals
-ui.pixel-formats ui.pixel-formats.private ;
+USING: accessors alien.c-types arrays ascii assocs
+classes.struct combinators io.encodings.ascii
+io.encodings.string io.encodings.utf8 kernel literals math
+namespaces sequences strings ui ui.backend ui.clipboards
+ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
+ui.gestures ui.pixel-formats ui.pixel-formats.private
+ui.private x11 x11.clipboard x11.constants x11.events x11.glx
+x11.io x11.windows x11.xim x11.xlib environment command-line ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
M: world expose-event nip relayout ;
M: world configure-event
- over configured-loc >>window-loc
- swap configured-dim >>dim
+ swap [ event-loc >>window-loc ] [ event-dim >>dim ] bi
! In case dimensions didn't change
relayout-1 ;
M: x11-ui-backend (make-pixel-format)
[ drop dpy get scr get ] dip
- >glx-visual-int-array glXChooseVisual ;
+ >glx-visual-int-array glXChooseVisual
+ XVisualInfo memory>struct ;
M: x11-ui-backend (free-pixel-format)
handle>> XFree ;
dup key-codes at [ t ] [ 1string f ] ?if ;
: event-modifiers ( event -- seq )
- XKeyEvent-state modifiers modifier ;
+ state>> modifiers modifier ;
: valid-input? ( string gesture -- ? )
over empty? [ 2drop f ] [
[ key-up-event>gesture ] dip propagate-key-gesture ;
: mouse-event>gesture ( event -- modifiers button loc )
- [ event-modifiers ]
- [ XButtonEvent-button ]
- [ mouse-event-loc ]
- tri ;
+ [ event-modifiers ] [ button>> ] [ event-loc ] tri ;
M: world button-down-event
[ mouse-event>gesture [ <button-down> ] dip ] dip
send-button-up ;
: mouse-event>scroll-direction ( event -- pair )
- XButtonEvent-button {
+ button>> {
{ 4 { 0 -1 } }
{ 5 { 0 1 } }
{ 6 { -1 0 } }
} at ;
M: world wheel-event
- [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
+ [ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip
send-wheel ;
M: world enter-event motion-event ;
M: world leave-event 2drop forget-rollover ;
M: world motion-event
- [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
- move-hand fire-motion ;
+ [ event-loc ] dip move-hand fire-motion ;
M: world focus-in-event
- nip
- [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
+ nip [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
M: world focus-out-event
- nip
- [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
+ nip [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
M: world selection-notify-event
[ handle>> window>> selection-from-event ] keep
} case ;
: encode-clipboard ( string type -- bytes )
- XSelectionRequestEvent-target
- XA_UTF8_STRING = utf8 ascii ? encode ;
+ target>> XA_UTF8_STRING = utf8 ascii ? encode ;
: set-selection-prop ( evt -- )
dpy get swap
- [ XSelectionRequestEvent-requestor ] keep
- [ XSelectionRequestEvent-property ] keep
- [ XSelectionRequestEvent-target ] keep
- [ 8 PropModeReplace ] dip
- [
- XSelectionRequestEvent-selection
- clipboard-for-atom contents>>
- ] keep encode-clipboard dup length XChangeProperty drop ;
+ [ requestor>> ] keep
+ [ property>> ] keep
+ [ target>> 8 PropModeReplace ] keep
+ [ selection>> clipboard-for-atom contents>> ] keep
+ encode-clipboard dup length XChangeProperty drop ;
M: world selection-request-event
- drop dup XSelectionRequestEvent-target {
+ drop dup target>> {
{ [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
{ [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
{ [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
] [ wait-for-display wait-event ] if ;
M: x11-ui-backend do-events
- wait-event dup XAnyEvent-window window dup
+ wait-event dup XAnyEvent>> window>> window dup
[ handle-event ] [ 2drop ] if ;
: x-clipboard@ ( gadget clipboard -- prop win )
[ 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 ) ;
{ st_mode mode_t }
{ st_nlink nlink_t }
{ st_uid uid_t }
- { st_gid git_t }
+ { st_gid gid_t }
{ st_rdev __dev_t }
{ st_atimespec timespec }
{ st_mtimespec timespec }
{ st_blocks blkcnt_t }
{ st_blksize blksize_t }
{ st_flags fflags_t }
- { st_gen _uint32_t }
+ { st_gen __uint32_t }
{ st_lspare __int32_t }
{ st_birthtimespec timespec }
- { pad0 __int32_t[2] }
+ { pad0 __int32_t[2] } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;
USING: alien alien.c-types alien.accessors effects kernel
windows.ole32 parser lexer splitting grouping sequences
namespaces assocs quotations generalizations accessors words
-macros alien.syntax fry arrays layouts math ;
+macros alien.syntax fry arrays layouts math classes.struct
+windows.kernel32 prettyprint.custom prettyprint.sections ;
IN: windows.com.syntax
<PRIVATE
-C-STRUCT: com-interface
- { "void*" "vtbl" } ;
-
MACRO: com-invoke ( n return parameters -- )
[ 2nip length ] 3keep
'[
- _ npick com-interface-vtbl _ cell * alien-cell _ _
+ _ npick *void* _ cell * alien-cell _ _
"stdcall" alien-indirect
] ;
dup "f" = [ drop f ] [
dup +com-interface-definitions+ get-global at*
[ nip ]
- [ swap " COM interface hasn't been defined" append throw ]
+ [ " COM interface hasn't been defined" prepend throw ]
if
] if ;
define-words-for-com-interface ;
SYNTAX: GUID: scan string>guid parsed ;
+
+M: GUID pprint* guid>string "GUID: " prepend text ;
: (make-query-interface) ( interfaces -- quot )
(query-interface-cases)
'[
- swap 16 memory>byte-array
+ swap GUID memory>struct
_ case
[
"void*" heap-size * rot <displaced-alien> com-add-ref
: make-lang-id ( lang1 lang2 -- n )
10 shift bitor ; inline
+<< "TCHAR" require-c-type-arrays >>
+
ERROR: error-message-failed id ;
:: n>win32-error-string ( id -- string )
{
f
id
LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id
- 32768 [ "TCHAR" <c-array> ] keep
+ 32768 [ "TCHAR" <c-type-array> ] [ ] bi
f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip
utf16n alien>string [ blank? ] trim ;
-USING: assocs memoize locals kernel accessors init fonts math\r
-combinators windows.errors windows.types windows.gdi32 ;\r
-IN: windows.fonts\r
-\r
-: windows-font-name ( string -- string' )\r
- H{\r
- { "sans-serif" "Tahoma" }\r
- { "serif" "Times New Roman" }\r
- { "monospace" "Courier New" }\r
- } ?at drop ;\r
- \r
-MEMO:: (cache-font) ( font -- HFONT )\r
- font size>> neg ! nHeight\r
- 0 0 0 ! nWidth, nEscapement, nOrientation\r
- font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight\r
- font italic?>> TRUE FALSE ? ! fdwItalic\r
- FALSE ! fdwUnderline\r
- FALSE ! fdWStrikeOut\r
- DEFAULT_CHARSET ! fdwCharSet\r
- OUT_OUTLINE_PRECIS ! fdwOutputPrecision\r
- CLIP_DEFAULT_PRECIS ! fdwClipPrecision\r
- DEFAULT_QUALITY ! fdwQuality\r
- DEFAULT_PITCH ! fdwPitchAndFamily\r
- font name>> windows-font-name\r
- CreateFont\r
- dup win32-error=0/f ;\r
-\r
-: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;\r
-\r
-[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook\r
-\r
-: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )\r
- [ metrics new 0 >>width ] dip {\r
- [ TEXTMETRICW-tmHeight >>height ]\r
- [ TEXTMETRICW-tmAscent >>ascent ]\r
- [ TEXTMETRICW-tmDescent >>descent ]\r
- } cleave ;\r
+USING: assocs memoize locals kernel accessors init fonts math
+combinators windows.errors windows.types windows.gdi32 ;
+IN: windows.fonts
+
+: windows-font-name ( string -- string' )
+ H{
+ { "sans-serif" "Tahoma" }
+ { "serif" "Times New Roman" }
+ { "monospace" "Courier New" }
+ } ?at drop ;
+
+MEMO:: (cache-font) ( font -- HFONT )
+ font size>> neg ! nHeight
+ 0 0 0 ! nWidth, nEscapement, nOrientation
+ font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight
+ font italic?>> TRUE FALSE ? ! fdwItalic
+ FALSE ! fdwUnderline
+ FALSE ! fdWStrikeOut
+ DEFAULT_CHARSET ! fdwCharSet
+ OUT_OUTLINE_PRECIS ! fdwOutputPrecision
+ CLIP_DEFAULT_PRECIS ! fdwClipPrecision
+ DEFAULT_QUALITY ! fdwQuality
+ DEFAULT_PITCH ! fdwPitchAndFamily
+ font name>> windows-font-name
+ CreateFont
+ dup win32-error=0/f ;
+
+: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;
+
+[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook
+
+: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
+ [ metrics new 0 >>width ] dip {
+ [ tmHeight>> >>height ]
+ [ tmAscent>> >>ascent ]
+ [ tmDescent>> >>descent ]
+ } cleave ;
CONSTANT: FILE_ACTION_RENAMED_OLD_NAME 4
CONSTANT: FILE_ACTION_RENAMED_NEW_NAME 5
-C-STRUCT: FILE_NOTIFY_INFORMATION
- { "DWORD" "NextEntryOffset" }
- { "DWORD" "Action" }
- { "DWORD" "FileNameLength" }
- { "WCHAR[1]" "FileName" } ;
+STRUCT: FILE_NOTIFY_INFORMATION
+ { NextEntryOffset DWORD }
+ { Action DWORD }
+ { FileNameLength DWORD }
+ { FileName WCHAR[1] } ;
+
TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION
CONSTANT: STD_INPUT_HANDLE -10
{ wSecond WORD }
{ wMilliseconds WORD } ;
-C-STRUCT: TIME_ZONE_INFORMATION
- { "LONG" "Bias" }
- { { "WCHAR" 32 } "StandardName" }
- { "SYSTEMTIME" "StandardDate" }
- { "LONG" "StandardBias" }
- { { "WCHAR" 32 } "DaylightName" }
- { "SYSTEMTIME" "DaylightDate" }
- { "LONG" "DaylightBias" } ;
+STRUCT: TIME_ZONE_INFORMATION
+ { Bias LONG }
+ { StandardName WCHAR[32] }
+ { StandardDate SYSTEMTIME }
+ { StandardBias LONG }
+ { DaylightName WCHAR[32] }
+ { DaylightDate SYSTEMTIME }
+ { DaylightBias LONG } ;
STRUCT: FILETIME
{ dwLowDateTime DWORD }
TYPEDEF: void* LPMEMORYSTATUSEX
-C-STRUCT: OSVERSIONINFO
- { "DWORD" "dwOSVersionInfoSize" }
- { "DWORD" "dwMajorVersion" }
- { "DWORD" "dwMinorVersion" }
- { "DWORD" "dwBuildNumber" }
- { "DWORD" "dwPlatformId" }
- { { "WCHAR" 128 } "szCSDVersion" } ;
+STRUCT: OSVERSIONINFO
+ { dwOSVersionInfoSize DWORD }
+ { dwMajorVersion DWORD }
+ { dwMinorVersion DWORD }
+ { dwBuildNumber DWORD }
+ { dwPlatformId DWORD }
+ { szCSDVersion WCHAR[128] } ;
TYPEDEF: void* LPOSVERSIONINFO
{ "DWORD" "protect" }
{ "DWORD" "type" } ;
-C-STRUCT: GUID
- { "ULONG" "Data1" }
- { "WORD" "Data2" }
- { "WORD" "Data3" }
- { { "UCHAR" 8 } "Data4" } ;
+STRUCT: GUID
+ { Data1 ULONG }
+ { Data2 WORD }
+ { Data3 WORD }
+ { Data4 UCHAR[8] } ;
/*
fBinary :1;
{ "LUID_AND_ATTRIBUTES*" "Privileges" } ;
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
-C-STRUCT: WIN32_FILE_ATTRIBUTE_DATA
- { "DWORD" "dwFileAttributes" }
- { "FILETIME" "ftCreationTime" }
- { "FILETIME" "ftLastAccessTime" }
- { "FILETIME" "ftLastWriteTime" }
- { "DWORD" "nFileSizeHigh" }
- { "DWORD" "nFileSizeLow" } ;
+STRUCT: WIN32_FILE_ATTRIBUTE_DATA
+ { dwFileAttributes DWORD }
+ { ftCreationTime FILETIME }
+ { ftLastAccessTime FILETIME }
+ { ftLastWriteTime FILETIME }
+ { nFileSizeHigh DWORD }
+ { nFileSizeLow DWORD } ;
TYPEDEF: WIN32_FILE_ATTRIBUTE_DATA* LPWIN32_FILE_ATTRIBUTE_DATA
C-STRUCT: BY_HANDLE_FILE_INFORMATION
TYPEDEF: OFSTRUCT* LPOFSTRUCT
-! MAX_PATH = 260
-C-STRUCT: WIN32_FIND_DATA
- { "DWORD" "dwFileAttributes" }
- { "FILETIME" "ftCreationTime" }
- { "FILETIME" "ftLastAccessTime" }
- { "FILETIME" "ftLastWriteTime" }
- { "DWORD" "nFileSizeHigh" }
- { "DWORD" "nFileSizeLow" }
- { "DWORD" "dwReserved0" }
- { "DWORD" "dwReserved1" }
- ! { { "TCHAR" MAX_PATH } "cFileName" }
- { { "TCHAR" 260 } "cFileName" }
- { { "TCHAR" 14 } "cAlternateFileName" } ;
+STRUCT: WIN32_FIND_DATA
+ { dwFileAttributes DWORD }
+ { ftCreationTime FILETIME }
+ { ftLastAccessTime FILETIME }
+ { ftLastWriteTime FILETIME }
+ { nFileSizeHigh DWORD }
+ { nFileSizeLow DWORD }
+ { dwReserved0 DWORD }
+ { dwReserved1 DWORD }
+ { cFileName { "TCHAR" MAX_PATH } }
+ { cAlternateFileName TCHAR[14] } ;
STRUCT: BY_HANDLE_FILE_INFORMATION
{ dwFileAttributes DWORD }
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel combinators sequences
math windows.gdi32 windows.types images destructors
-accessors fry locals ;
+accessors fry locals classes.struct ;
IN: windows.offscreen
: (bitmap-info) ( dim -- BITMAPINFO )
- "BITMAPINFO" <c-object> [
- BITMAPINFO-bmiHeader {
- [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
- [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
- [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
- [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
- [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
- [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
- [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
- [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
- [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
- [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
- [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
- } 2cleave
- ] keep ;
+ [
+ BITMAPINFO <struct>
+ dup bmiHeader>>
+ BITMAPINFOHEADER heap-size >>biSize
+ ] dip
+ [ first >>biWidth ]
+ [ second >>biHeight ]
+ [ first2 * 4 * >>biSizeImage ] tri
+ 1 >>biPlanes
+ 32 >>biBitCount
+ BI_RGB >>biCompression
+ 72 >>biXPelsPerMeter
+ 72 >>biYPelsPerMeter
+ 0 >>biClrUsed
+ 0 >>biClrImportant
+ drop ;
: make-bitmap ( dim dc -- hBitmap bits )
[ nip ]
-USING: kernel tools.test windows.ole32 alien.c-types ;
+USING: kernel tools.test windows.ole32 alien.c-types
+classes.struct specialized-arrays.uchar windows.kernel32 ;
IN: windows.ole32.tests
[ t ] [
guid=
] unit-test
-little-endian?
-[ B{
- HEX: 67 HEX: 45 HEX: 23 HEX: 01 HEX: ab HEX: 89 HEX: ef HEX: cd
- HEX: 01 HEX: 23 HEX: 45 HEX: 67 HEX: 89 HEX: ab HEX: cd HEX: ef
-} ]
-[ B{
- HEX: 01 HEX: 23 HEX: 45 HEX: 67 HEX: 89 HEX: ab HEX: cd HEX: ef
- HEX: 01 HEX: 23 HEX: 45 HEX: 67 HEX: 89 HEX: ab HEX: cd HEX: ef
-} ] ?
-[ "{01234567-89ab-cdef-0123-456789abcdef}" string>guid ]
-unit-test
+[
+ GUID: 01234567-89ab-cdef-0123-456789abcdef}
+] [ "{01234567-89ab-cdef-0123-456789abcdef}" string>guid ] unit-test
[ "{01234567-89ab-cdef-0123-456789abcdef}" ]
[ "{01234567-89ab-cdef-0123-456789abcdef}" string>guid guid>string ]
USING: alien alien.syntax alien.c-types alien.strings math
kernel sequences windows.errors windows.types io
accessors math.order namespaces make math.parser windows.kernel32
-combinators locals specialized-arrays.direct.uchar ;
+combinators locals specialized-arrays.direct.uchar
+literals splitting grouping classes.struct combinators.smart ;
IN: windows.ole32
LIBRARY: ole32
: guid= ( a b -- ? )
[ 16 memory>byte-array ] bi@ = ;
-: GUID-STRING-LENGTH ( -- n )
- "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
-
-:: (guid-section>guid) ( string guid start end quot -- )
- start end string subseq hex> guid quot call ; inline
-
-:: (guid-byte>guid) ( string guid start end byte -- )
- start end string subseq hex> byte guid set-nth ; inline
+CONSTANT: GUID-STRING-LENGTH
+ $[ "{01234567-89ab-cdef-0123-456789abcdef}" length ]
: string>guid ( string -- guid )
- "GUID" <c-object> [
- {
- [ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ]
- [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
- [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
- [ ]
- } 2cleave
-
- GUID-Data4 {
- [ 20 22 0 (guid-byte>guid) ]
- [ 22 24 1 (guid-byte>guid) ]
-
- [ 25 27 2 (guid-byte>guid) ]
- [ 27 29 3 (guid-byte>guid) ]
- [ 29 31 4 (guid-byte>guid) ]
- [ 31 33 5 (guid-byte>guid) ]
- [ 33 35 6 (guid-byte>guid) ]
- [ 35 37 7 (guid-byte>guid) ]
- } 2cleave
- ] keep ;
-
-: (guid-section%) ( guid quot len -- )
- [ call >hex ] dip CHAR: 0 pad-head % ; inline
-
-: (guid-byte%) ( guid byte -- )
- swap nth >hex 2 CHAR: 0 pad-head % ; inline
+ "{-}" split harvest
+ [ first3 [ hex> ] tri@ ]
+ [ 3 tail concat 2 group [ hex> ] B{ } map-as ] bi
+ GUID <struct-boa> ;
: guid>string ( guid -- string )
[
- "{" % {
- [ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
- [ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
- [ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
- [ ]
+ [ "{" ] dip {
+ [ Data1>> >hex 8 CHAR: 0 pad-head "-" ]
+ [ Data2>> >hex 4 CHAR: 0 pad-head "-" ]
+ [ Data3>> >hex 4 CHAR: 0 pad-head "-" ]
+ [
+ Data4>> [
+ {
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head "-" ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ } spread
+ ] input<sequence "}"
+ ]
} cleave
- GUID-Data4 {
- [ 0 (guid-byte%) ]
- [ 1 (guid-byte%) "-" % ]
- [ 2 (guid-byte%) ]
- [ 3 (guid-byte%) ]
- [ 4 (guid-byte%) ]
- [ 5 (guid-byte%) ]
- [ 6 (guid-byte%) ]
- [ 7 (guid-byte%) "}" % ]
- } cleave
- ] "" make ;
-
+ ] "" append-outputs-as ;
USING: alien alien.c-types alien.strings alien.syntax
combinators io.encodings.utf16n io.files io.pathnames kernel
windows.errors windows.com windows.com.syntax windows.user32
-windows.ole32 windows ;
+windows.ole32 windows specialized-arrays.ushort classes.struct ;
IN: windows.shell32
CONSTANT: CSIDL_DESKTOP HEX: 00
: shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT
- MAX_UNICODE_PATH "ushort" <c-array>
+ MAX_UNICODE_PATH <ushort-array>
[ SHGetFolderPath drop ] keep utf16n alien>string ;
: desktop ( -- str )
TYPEDEF: ULONG SFGAOF
-C-STRUCT: DROPFILES
- { "DWORD" "pFiles" }
- { "POINT" "pt" }
- { "BOOL" "fNC" }
- { "BOOL" "fWide" } ;
+STRUCT: DROPFILES
+ { pFiles DWORD }
+ { pt POINT }
+ { fNC BOOL }
+ { fWide BOOL } ;
TYPEDEF: DROPFILES* LPDROPFILES
TYPEDEF: DROPFILES* LPCDROPFILES
TYPEDEF: HANDLE HDROP
-C-STRUCT: SHITEMID
- { "USHORT" "cb" }
- { "BYTE[1]" "abID" } ;
+STRUCT: SHITEMID
+ { cb USHORT }
+ { abID BYTE[1] } ;
TYPEDEF: SHITEMID* LPSHITEMID
TYPEDEF: SHITEMID* LPCSHITEMID
-C-STRUCT: ITEMIDLIST
- { "SHITEMID" "mkid" } ;
+STRUCT: ITEMIDLIST
+ { mkid SHITEMID } ;
TYPEDEF: ITEMIDLIST* LPITEMIDLIST
TYPEDEF: ITEMIDLIST* LPCITEMIDLIST
TYPEDEF: ITEMIDLIST ITEMID_CHILD
CONSTANT: STRRET_CSTR 2
C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
-C-STRUCT: STRRET
- { "int" "uType" }
- { "STRRET-union" "union" } ;
+STRUCT: STRRET
+ { uType int }
+ { union STRRET-union } ;
COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046}
HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched )
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.struct tools.test windows.types ;
+IN: windows.types.tests
+
+[ S{ RECT { right 100 } { bottom 100 } } ]
+[ { 0 0 } { 100 100 } <RECT> ] unit-test
+
+[ S{ RECT { left 100 } { top 100 } { right 200 } { bottom 200 } } ]
+[ { 100 100 } { 100 100 } <RECT> ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax namespaces kernel words
sequences math math.bitwise math.vectors colors
-io.encodings.utf16n classes.struct ;
+io.encodings.utf16n classes.struct accessors ;
IN: windows.types
TYPEDEF: char CHAR
! typedef LRESULT (CALLBACK* WNDPROC)(HWND, UINT, WPARAM, LPARAM);
-C-STRUCT: WNDCLASS
- { "UINT" "style" }
- { "WNDPROC" "lpfnWndProc" }
- { "int" "cbClsExtra" }
- { "int" "cbWndExtra" }
- { "HINSTANCE" "hInstance" }
- { "HICON" "hIcon" }
- { "HCURSOR" "hCursor" }
- { "HBRUSH" "hbrBackground" }
- { "LPCTSTR" "lpszMenuName" }
- { "LPCTSTR" "lpszClassName" } ;
-
-C-STRUCT: WNDCLASSEX
- { "UINT" "cbSize" }
- { "UINT" "style" }
- { "WNDPROC" "lpfnWndProc" }
- { "int" "cbClsExtra" }
- { "int" "cbWndExtra" }
- { "HINSTANCE" "hInstance" }
- { "HICON" "hIcon" }
- { "HCURSOR" "hCursor" }
- { "HBRUSH" "hbrBackground" }
- { "LPCTSTR" "lpszMenuName" }
- { "LPCTSTR" "lpszClassName" }
- { "HICON" "hIconSm" } ;
-
-C-STRUCT: RECT
- { "LONG" "left" }
- { "LONG" "top" }
- { "LONG" "right" }
- { "LONG" "bottom" } ;
+STRUCT: WNDCLASS
+ { style UINT }
+ { lpfnWndProc WNDPROC }
+ { cbClsExtra int }
+ { cbWndExtra int }
+ { hInstance HINSTANCE }
+ { hIcon HICON }
+ { hCursor HCURSOR }
+ { hbrBackground HBRUSH }
+ { lpszMenuName LPCTSTR }
+ { lpszClassName LPCTSTR } ;
+
+STRUCT: WNDCLASSEX
+ { cbSize UINT }
+ { style UINT }
+ { lpfnWndProc WNDPROC }
+ { cbClsExtra int }
+ { cbWndExtra int }
+ { hInstance HINSTANCE }
+ { hIcon HICON }
+ { hCursor HCURSOR }
+ { hbrBackground HBRUSH }
+ { lpszMenuName LPCTSTR }
+ { lpszClassName LPCTSTR }
+ { hIconSm HICON } ;
+
+STRUCT: RECT
+ { left LONG }
+ { top LONG }
+ { right LONG }
+ { bottom LONG } ;
C-STRUCT: PAINTSTRUCT
{ "HDC" " hdc" }
{ "BYTE[32]" "rgbReserved" }
;
-C-STRUCT: BITMAPINFOHEADER
- { "DWORD" "biSize" }
- { "LONG" "biWidth" }
- { "LONG" "biHeight" }
- { "WORD" "biPlanes" }
- { "WORD" "biBitCount" }
- { "DWORD" "biCompression" }
- { "DWORD" "biSizeImage" }
- { "LONG" "biXPelsPerMeter" }
- { "LONG" "biYPelsPerMeter" }
- { "DWORD" "biClrUsed" }
- { "DWORD" "biClrImportant" } ;
-
-C-STRUCT: RGBQUAD
- { "BYTE" "rgbBlue" }
- { "BYTE" "rgbGreen" }
- { "BYTE" "rgbRed" }
- { "BYTE" "rgbReserved" } ;
-
-C-STRUCT: BITMAPINFO
- { "BITMAPINFOHEADER" "bmiHeader" }
- { "RGBQUAD[1]" "bmiColors" } ;
+STRUCT: BITMAPINFOHEADER
+ { biSize DWORD }
+ { biWidth LONG }
+ { biHeight LONG }
+ { biPlanes WORD }
+ { biBitCount WORD }
+ { biCompression DWORD }
+ { biSizeImage DWORD }
+ { biXPelsPerMeter LONG }
+ { biYPelsPerMeter LONG }
+ { biClrUsed DWORD }
+ { biClrImportant DWORD } ;
+
+STRUCT: RGBQUAD
+ { rgbBlue BYTE }
+ { rgbGreen BYTE }
+ { rgbRed BYTE }
+ { rgbReserved BYTE } ;
+
+STRUCT: BITMAPINFO
+ { bmiHeader BITMAPINFOHEADER }
+ { bimColors RGBQUAD[1] } ;
TYPEDEF: void* LPPAINTSTRUCT
TYPEDEF: void* PAINTSTRUCT
{ "LONG" "x" }
{ "LONG" "y" } ;
-C-STRUCT: SIZE
- { "LONG" "cx" }
- { "LONG" "cy" } ;
+STRUCT: SIZE
+ { cx LONG }
+ { cy LONG } ;
C-STRUCT: MSG
{ "HWND" "hWnd" }
{ dwVisibleMask DWORD }
{ dwDamageMask DWORD } ;
-C-STRUCT: RECT
- { "LONG" "left" }
- { "LONG" "top" }
- { "LONG" "right" }
- { "LONG" "bottom" } ;
-
: <RECT> ( loc dim -- RECT )
- over v+
- "RECT" <c-object>
- over first over set-RECT-right
- swap second over set-RECT-bottom
- over first over set-RECT-left
- swap second over set-RECT-top ;
+ [ RECT <struct> ] 2dip
+ [ drop [ first >>left ] [ second >>top ] bi ]
+ [ v+ [ first >>right ] [ second >>bottom ] bi ] 2bi ;
TYPEDEF: RECT* PRECT
TYPEDEF: RECT* LPRECT
: color>RGB ( color -- COLORREF )
>rgba-components drop [ 255 * >integer ] tri@ RGB ;
-C-STRUCT: TEXTMETRICW
- { "LONG" "tmHeight" }
- { "LONG" "tmAscent" }
- { "LONG" "tmDescent" }
- { "LONG" "tmInternalLeading" }
- { "LONG" "tmExternalLeading" }
- { "LONG" "tmAveCharWidth" }
- { "LONG" "tmMaxCharWidth" }
- { "LONG" "tmWeight" }
- { "LONG" "tmOverhang" }
- { "LONG" "tmDigitizedAspectX" }
- { "LONG" "tmDigitizedAspectY" }
- { "WCHAR" "tmFirstChar" }
- { "WCHAR" "tmLastChar" }
- { "WCHAR" "tmDefaultChar" }
- { "WCHAR" "tmBreakChar" }
- { "BYTE" "tmItalic" }
- { "BYTE" "tmUnderlined" }
- { "BYTE" "tmStruckOut" }
- { "BYTE" "tmPitchAndFamily" }
- { "BYTE" "tmCharSet" } ;
+STRUCT: TEXTMETRICW
+ { tmHeight LONG }
+ { tmAscent LONG }
+ { tmDescent LONG }
+ { tmInternalLeading LONG }
+ { tmExternalLeading LONG }
+ { tmAveCharWidth LONG }
+ { tmMaxCharWidth LONG }
+ { tmWeight LONG }
+ { tmOverhang LONG }
+ { tmDigitizedAspectX LONG }
+ { tmDigitizedAspectY LONG }
+ { tmFirstChar WCHAR }
+ { tmLastChar WCHAR }
+ { tmDefaultChar WCHAR }
+ { tmBreakChar WCHAR }
+ { tmItalic BYTE }
+ { tmUnderlined BYTE }
+ { tmStruckOut BYTE }
+ { tmPitchAndFamily BYTE }
+ { tmCharSet BYTE } ;
TYPEDEF: TEXTMETRICW* LPTEXTMETRIC
io.encodings.utf16n accessors arrays combinators destructors
cache namespaces init fonts alien.c-types windows.usp10
windows.offscreen windows.gdi32 windows.ole32 windows.types
-windows.fonts opengl.textures locals windows.errors ;
+windows.fonts opengl.textures locals windows.errors
+classes.struct ;
IN: windows.uniscribe
TUPLE: script-string < disposable font string metrics ssa size image ;
: script-string-size ( script-string -- dim )
ssa>> ScriptString_pSize
dup win32-error=0/f
- [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
+ SIZE memory>struct
+ [ cx>> ] [ cy>> ] bi 2array ;
: dc-metrics ( dc -- metrics )
- "TEXTMETRICW" <c-object>
+ TEXTMETRICW <struct>
[ GetTextMetrics drop ] keep
TEXTMETRIC>metrics ;
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax parser namespaces kernel math
-windows.types generalizations math.bitwise classes.struct ;
+windows.types generalizations math.bitwise classes.struct
+literals ;
IN: windows.user32
! HKL for ActivateKeyboardLayout
CONSTANT: WS_EX_CONTROLPARENT HEX: 00010000
CONSTANT: WS_EX_STATICEDGE HEX: 00020000
CONSTANT: WS_EX_APPWINDOW HEX: 00040000
+
: WS_EX_OVERLAPPEDWINDOW ( -- n )
WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable
+
: WS_EX_PALETTEWINDOW ( -- n )
{ WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } flags ; foldable
CONSTANT: TME_QUERY HEX: 40000000
CONSTANT: TME_CANCEL HEX: 80000000
CONSTANT: HOVER_DEFAULT HEX: ffffffff
-C-STRUCT: TRACKMOUSEEVENT
- { "DWORD" "cbSize" }
- { "DWORD" "dwFlags" }
- { "HWND" "hwndTrack" }
- { "DWORD" "dwHoverTime" } ;
+STRUCT: TRACKMOUSEEVENT
+ { cbSize DWORD }
+ { dwFlags DWORD }
+ { hwndTrack HWND }
+ { dwHoverTime DWORD } ;
TYPEDEF: TRACKMOUSEEVENT* LPTRACKMOUSEEVENT
CONSTANT: DBT_DEVICEARRIVAL HEX: 8000
CONSTANT: DEVICE_NOTIFY_ALL_INTERFACE_CLASSES 4
-C-STRUCT: DEV_BROADCAST_HDR
- { "DWORD" "dbch_size" }
- { "DWORD" "dbch_devicetype" }
- { "DWORD" "dbch_reserved" } ;
+STRUCT: DEV_BROADCAST_HDR
+ { dbch_size DWORD }
+ { dbch_devicetype DWORD }
+ { dbch_reserved DWORD } ;
-C-STRUCT: DEV_BROADCAST_DEVICEW
- { "DWORD" "dbcc_size" }
- { "DWORD" "dbcc_devicetype" }
- { "DWORD" "dbcc_reserved" }
- { "GUID" "dbcc_classguid" }
- { { "WCHAR" 1 } "dbcc_name" } ;
+STRUCT: DEV_BROADCAST_DEVICEW
+ { dbcc_size DWORD }
+ { dbcc_devicetype DWORD }
+ { dbcc_reserved DWORD }
+ { dbcc_classguid GUID }
+ { dbcc_name WCHAR[1] } ;
CONSTANT: CCHDEVICENAME 32
-C-STRUCT: MONITORINFOEX
- { "DWORD" "cbSize" }
- { "RECT" "rcMonitor" }
- { "RECT" "rcWork" }
- { "DWORD" "dwFlags" }
- { { "TCHAR" CCHDEVICENAME } "szDevice" } ;
+STRUCT: MONITORINFOEX
+ { cbSize DWORD }
+ { rcMonitor RECT }
+ { rcWork RECT }
+ { dwFlags DWORD }
+ { szDevice { "TCHAR" $ CCHDEVICENAME } } ;
TYPEDEF: MONITORINFOEX* LPMONITORINFOEX
TYPEDEF: MONITORINFOEX* LPMONITORINFO
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
byte-arrays kernel math sequences windows.types windows.kernel32
-windows.errors math.bitwise io.encodings.utf16n ;
+windows.errors math.bitwise io.encodings.utf16n classes.struct
+literals windows.com.syntax ;
IN: windows.winsock
USE: libc
{ { "uchar" 16 } "addr" }
{ "uint" "scopeid" } ;
-C-STRUCT: hostent
- { "char*" "name" }
- { "void*" "aliases" }
- { "short" "addrtype" }
- { "short" "length" }
- { "void*" "addr-list" } ;
+STRUCT: hostent
+ { name char* }
+ { aliases void* }
+ { addrtype short }
+ { length short }
+ { addr-list void* } ;
C-STRUCT: addrinfo
{ "int" "flags" }
{ "long" "sec" }
{ "long" "usec" } ;
-: hostent-addr ( hostent -- addr ) hostent-addr-list *void* ; ! *uint ;
-
LIBRARY: winsock
-
FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
FUNCTION: ushort htons ( ushort n ) ;
TYPEDEF: FLOWSPEC* PFLOWSPEC
TYPEDEF: FLOWSPEC* LPFLOWSPEC
-C-STRUCT: WSABUF
- { "ulong" "len" }
- { "void*" "buf" } ;
+STRUCT: WSABUF
+ { len ulong }
+ { buf void* } ;
TYPEDEF: WSABUF* LPWSABUF
C-STRUCT: QOS
BOOL fAlertable ) ;
-
-
LIBRARY: mswsock
! Not in Windows CE
CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
-: WSAID_CONNECTEX ( -- GUID )
- "GUID" <c-object>
- HEX: 25a207b9 over set-GUID-Data1
- HEX: ddf3 over set-GUID-Data2
- HEX: 4660 over set-GUID-Data3
- B{
- HEX: 8e HEX: e9 HEX: 76 HEX: e5
- HEX: 8c HEX: 74 HEX: 06 HEX: 3e
- } over set-GUID-Data4 ;
+CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
: winsock-expected-error? ( n -- ? )
- ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING 3array member? ;
+ ${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
: (winsock-error-string) ( n -- str )
! #! WSAStartup returns the error code 'n' directly
! 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 ] }
+ swap dup XAnyEvent>> type>> {
+ { Expose [ XExposeEvent>> swap expose-event ] }
+ { ConfigureNotify [ XConfigureEvent>> swap configure-event ] }
+ { ButtonPress [ XButtonEvent>> swap button-down-event$ ] }
+ { ButtonRelease [ XButtonEvent>> swap button-up-event$ ] }
+ { EnterNotify [ XCrossingEvent>> swap enter-event ] }
+ { LeaveNotify [ XCrossingEvent>> swap leave-event ] }
+ { MotionNotify [ XMotionEvent>> swap motion-event ] }
+ { KeyPress [ XKeyEvent>> swap key-down-event ] }
+ { KeyRelease [ XKeyEvent>> swap key-up-event ] }
+ { FocusIn [ XFocusChangeEvent>> swap focus-in-event ] }
+ { FocusOut [ XFocusChangeEvent>> swap focus-out-event ] }
+ { SelectionNotify [ XSelectionEvent>> swap selection-notify-event ] }
+ { SelectionRequest [ XSelectionRequestEvent>> swap selection-request-event ] }
+ { ClientMessage [ XClientMessageEvent>> swap client-event ] }
[ 3drop ]
} case ;
-: configured-loc ( event -- dim )
- [ XConfigureEvent-x ] [ XConfigureEvent-y ] bi 2array ;
+: event-loc ( event -- loc )
+ [ x>> ] [ y>> ] bi 2array ;
-: configured-dim ( event -- dim )
- [ XConfigureEvent-width ] [ XConfigureEvent-height ] bi 2array ;
-
-: mouse-event-loc ( event -- loc )
- [ XButtonEvent-x ] [ XButtonEvent-y ] bi 2array ;
+: event-dim ( event -- dim )
+ [ width>> ] [ height>> ] bi 2array ;
: close-box? ( event -- ? )
- [ XClientMessageEvent-message_type "WM_PROTOCOLS" x-atom = ]
- [ XClientMessageEvent-data0 "WM_DELETE_WINDOW" x-atom = ]
+ [ message_type>> "WM_PROTOCOLS" x-atom = ]
+ [ data0>> "WM_DELETE_WINDOW" x-atom = ]
bi and ;
! 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
[ stream>> >byte-array ]
tri ;
+M: tuple string>alien drop underlying>> ;
+
HOOK: alien>native-string os ( alien -- string )
M: windows alien>native-string utf16n alien>string ;
! See http://factorcode.org/license.txt for BSD license.
USING: io.files.windows io.streams.duplex kernel math
math.bitwise windows.kernel32 accessors alien.c-types
-windows io.files.windows fry locals continuations ;
+windows io.files.windows fry locals continuations
+classes.struct ;
IN: io.serial.windows
: <serial-stream> ( path encoding -- duplex )
: get-comm-state ( duplex -- dcb )
in>> handle>>
- "DCB" <c-object> tuck
+ DCB <struct> tuck
GetCommState win32-error=0/f ;
: set-comm-state ( duplex dcb -- )
system-info dwOemId>> HEX: ffff0000 bitand ;
: os-version ( -- os-version )
- "OSVERSIONINFO" <c-object>
- "OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize
+ OSVERSIONINFO <struct>
+ OSVERSIONINFO heap-size >>dwOSVersionInfoSize
dup GetVersionEx win32-error=0/f ;
: windows-major ( -- n )
- os-version OSVERSIONINFO-dwMajorVersion ;
+ os-version dwMajorVersion>> ;
: windows-minor ( -- n )
- os-version OSVERSIONINFO-dwMinorVersion ;
+ os-version dwMinorVersion>> ;
: windows-build# ( -- n )
- os-version OSVERSIONINFO-dwBuildNumber ;
+ os-version dwBuildNumber>> ;
: windows-platform-id ( -- n )
- os-version OSVERSIONINFO-dwPlatformId ;
+ os-version dwPlatformId>> ;
: windows-service-pack ( -- string )
- os-version OSVERSIONINFO-szCSDVersion alien>native-string ;
+ os-version szCSDVersion>> alien>native-string ;
: feature-present? ( n -- ? )
IsProcessorFeaturePresent zero? not ;
projects / factor.git / commitdiff