steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-08-31 04:18:59 -05:00
parent 6f1a7c731c 6ed46177e9
commit 41e83d2246
51 changed files with 1259 additions and 1379 deletions
basis
calendar/windows
classes/struct
compiler
environment/winnt
game-input/dinput
io
backend/unix
directories
files
info
unix/openbsd
windows
windows/nt
monitors/windows/nt
sockets
unix
windows/nt
ui/backend
unix
windows
x11
core/alien/strings
extra
io/serial/windows
system-info/windows

14
basis/calendar/windows/windows.factor
View File

@ -1,15 +1,13 @@
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 ;

27
basis/classes/struct/struct-tests.factor
View File

@ -6,7 +6,7 @@ kernel libc literals math multiline namespaces prettyprint
prettyprint.config see sequences specialized-arrays.ushort
system tools.test compiler.tree.debugger struct-arrays
classes.tuple.private specialized-arrays.direct.int
compiler.units ;
compiler.units byte-arrays specialized-arrays.char ;
IN: classes.struct.tests
<<
@ -204,4 +204,27 @@ STRUCT: struct-test-optimization
[ 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

30
basis/classes/struct/struct.factor
View File

@ -46,9 +46,6 @@ M: struct equal?
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
@ -58,13 +55,13 @@ PRIVATE>
[ 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 ) )
[
@ -119,13 +116,24 @@ M: struct-class writer-quot
\ 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 {
@ -207,7 +215,9 @@ M: struct-class heap-size
: (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 -- )
[

257
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -1,6 +1,6 @@
! 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
@ -25,201 +25,120 @@ QUALIFIED: math.floats.private
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 -- ) ;

10
basis/compiler/tests/codegen.factor
View File

@ -3,7 +3,7 @@ math hashtables.private math.private namespaces sequences tools.test
namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make alien.c-types combinators.short-circuit
math.order math.libm ;
math.order math.libm math.parser ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
@ -409,7 +409,7 @@ cell 4 = [
[ ] [ 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
[ 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

4
basis/environment/winnt/winnt.factor
View File

@ -6,8 +6,10 @@ alien.c-types sequences windows.errors io.streams.memory
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
] [

22
basis/game-input/dinput/dinput.factor
View File

@ -6,7 +6,7 @@ math.rectangles namespaces parser sequences shuffle
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
@ -162,7 +162,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
[ 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 ;
@ -185,9 +185,9 @@ TUPLE: window-rect < rect window-loc ;
{ 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
@ -239,11 +239,13 @@ M: dinput-game-input-backend (close-game-input)
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

25
basis/io/backend/unix/multiplexers/kqueue/kqueue.factor
View File

@ -2,28 +2,28 @@
! 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 ;
@ -63,13 +63,14 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
] 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

3
basis/io/backend/unix/unix-tests.factor
View File

@ -74,8 +74,7 @@ yield
[ datagram-client delete-file ] ignore-errors
datagram-client <local> <datagram>
"d" set
[ ] [ datagram-client <local> <datagram> "d" set ] unit-test
[ ] [
"hello" >byte-array

7
basis/io/directories/unix/linux/linux.factor
View File

@ -1,10 +1,11 @@
! 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 ;

8
basis/io/directories/unix/unix.factor
View File

@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings combinators
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 )
@ -37,7 +37,7 @@ M: unix copy-file ( from to -- )
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 ;
@ -57,8 +57,8 @@ M: unix find-next-file ( DIR* -- byte-array )
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 )

15
basis/io/directories/windows/windows.factor
View File

@ -4,7 +4,7 @@ USING: system io.directories io.encodings.utf16n alien.strings
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 -- )
@ -33,12 +33,12 @@ M: windows delete-directory ( 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
@ -48,10 +48,11 @@ M: windows delete-directory ( path -- )
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 )

4
basis/io/files/info/unix/openbsd/openbsd.factor
View File

@ -47,6 +47,6 @@ M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-in
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 ;

24
basis/io/files/info/windows/windows.factor
View File

@ -5,7 +5,8 @@ io.files.windows io.files.windows.nt kernel windows.kernel32
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' )
@ -35,20 +36,17 @@ TUPLE: windows-file-info < file-info attributes ;
: 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
@ -147,7 +145,7 @@ M: winnt file-system-info ( path -- file-system-info )
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
] [

12
basis/io/files/windows/nt/nt.factor
View File

@ -5,19 +5,18 @@ windows.kernel32 kernel libc math threads system environment
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 -- ? )
{
@ -48,10 +47,9 @@ M: winnt CreateFile-flags ( DWORD -- DWORD )
<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>

15
basis/io/monitors/windows/nt/nt.factor
View File

@ -7,7 +7,7 @@ system accessors threads splitting io.backend io.backend.windows
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 )
@ -55,17 +55,14 @@ TUPLE: win32-monitor < monitor port ;
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 ;

6
basis/io/sockets/unix/unix.factor
View File

@ -61,8 +61,8 @@ M: object ((client)) ( addrspec -- fd )
: 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 )
[
@ -148,7 +148,7 @@ M: local make-sockaddr
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

21
basis/io/sockets/windows/nt/nt.factor
View File

@ -2,7 +2,8 @@ USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.ports io.timeouts io.sockets
io namespaces io.streams.duplex io.backend.windows
io.sockets.windows io.backend.windows.nt windows.winsock kernel
libc math sequences threads system combinators accessors ;
libc math sequences threads system combinators accessors
classes.struct windows.kernel32 ;
IN: io.sockets.windows.nt
: malloc-int ( object -- object )
@ -14,7 +15,7 @@ M: winnt WSASocket-flags ( -- DWORD )
: get-ConnectEx-ptr ( socket -- void* )
SIO_GET_EXTENSION_FUNCTION_POINTER
WSAID_CONNECTEX
"GUID" heap-size
GUID heap-size
"void*" <c-object>
[
"void*" heap-size
@ -127,9 +128,9 @@ TUPLE: WSARecvFrom-args port
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
@ -158,7 +159,7 @@ TUPLE: WSARecvFrom-args port
} 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 )
@ -175,11 +176,9 @@ TUPLE: WSASendTo-args port
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

63
basis/ui/backend/windows/windows.factor
View File

@ -260,12 +260,14 @@ CONSTANT: window-control>ex-style
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
@ -503,14 +505,15 @@ SYMBOL: nc-buttons
] 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 ;
@ -588,19 +591,18 @@ M: windows-ui-backend do-events
] 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
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 over set-WNDCLASSEX-lpszClassName
class-name-ptr >>lpszClassName
RegisterClassEx win32-error=0/f
] [ drop ] if ;
@ -610,12 +612,12 @@ M: windows-ui-backend do-events
: 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 )
[
@ -623,7 +625,7 @@ M: windows-ui-backend do-events
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 [
@ -749,17 +751,18 @@ M: windows-ui-backend beep ( -- )
: 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

85
basis/ui/backend/x11/x11.factor
View File

@ -1,14 +1,13 @@
! 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
@ -25,8 +24,7 @@ C: <x11-pixmap-handle> x11-pixmap-handle
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 ;
@ -51,7 +49,8 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{
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 ;
@ -103,7 +102,7 @@ CONSTANT: key-codes
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 ] [
@ -132,10 +131,7 @@ M: world key-up-event
[ 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
@ -146,7 +142,7 @@ M: world button-up-event
send-button-up ;
: mouse-event>scroll-direction ( event -- pair )
XButtonEvent-button {
button>> {
{ 4 { 0 -1 } }
{ 5 { 0 1 } }
{ 6 { -1 0 } }
@ -154,7 +150,7 @@ M: world button-up-event
} 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 ;
@ -162,16 +158,13 @@ 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
@ -189,22 +182,18 @@ M: world selection-notify-event
} 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 ] }
@ -235,7 +224,7 @@ M: world client-event
] [ 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 )
@ -269,17 +258,13 @@ M: x11-ui-backend set-title ( string world -- )
[ 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 -- )
@ -312,9 +297,9 @@ M: x11-pixmap-handle flush-gl-context ( handle -- )
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 ]

14
basis/unix/bsd/freebsd/freebsd.factor
View File

@ -1,4 +1,4 @@
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 1024
@ -13,12 +13,12 @@ C-STRUCT: addrinfo
{ "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

14
basis/unix/bsd/macosx/macosx.factor
View File

@ -1,4 +1,4 @@
USING: alien.syntax unix.time ;
USING: alien.syntax unix.time classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 1024
@ -32,12 +32,12 @@ CONSTANT: __DARWIN_MAXPATHLEN 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

18
basis/unix/bsd/netbsd/netbsd.factor
View File

@ -1,4 +1,5 @@
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
@ -13,12 +14,12 @@ C-STRUCT: addrinfo
{ "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
@ -126,8 +127,7 @@ CONSTANT: _UTX_LINESIZE 32
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

14
basis/unix/bsd/openbsd/openbsd.factor
View File

@ -1,4 +1,4 @@
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 1024
@ -13,12 +13,12 @@ C-STRUCT: addrinfo
{ "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

17
basis/unix/kqueue/freebsd/freebsd.factor
View File

@ -1,14 +1,13 @@
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 ) ;

17
basis/unix/kqueue/macosx/macosx.factor
View File

@ -1,14 +1,13 @@
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 ) ;

17
basis/unix/kqueue/netbsd/netbsd.factor
View File

@ -1,14 +1,13 @@
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 ) ;

17
basis/unix/kqueue/openbsd/openbsd.factor
View File

@ -1,14 +1,13 @@
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 ) ;

14
basis/unix/linux/linux.factor
View File

@ -1,6 +1,6 @@
! 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.
@ -94,12 +94,12 @@ C-STRUCT: passwd
{ "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 ) ;

6
basis/unix/stat/freebsd/freebsd.factor
View File

@ -9,7 +9,7 @@ STRUCT: stat
{ 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 }
@ -18,10 +18,10 @@ STRUCT: stat
{ 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 ) ;

12
basis/windows/com/syntax/syntax.factor
View File

@ -1,18 +1,16 @@
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
] ;
@ -31,7 +29,7 @@ unless
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 ;
@ -100,3 +98,5 @@ SYNTAX: COM-INTERFACE:
define-words-for-com-interface ;
SYNTAX: GUID: scan string>guid parsed ;
M: GUID pprint* guid>string "GUID: " prepend text ;

2
basis/windows/com/wrapper/wrapper.factor
View File

@ -48,7 +48,7 @@ unless
: (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

4
basis/windows/errors/errors.factor
View File

@ -696,6 +696,8 @@ CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF
: 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 )
{
@ -705,7 +707,7 @@ ERROR: error-message-failed id ;
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 ;

74
basis/windows/fonts/fonts.factor
View File

@ -1,37 +1,37 @@
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 {
[ TEXTMETRICW-tmHeight >>height ]
[ TEXTMETRICW-tmAscent >>ascent ]
[ TEXTMETRICW-tmDescent >>descent ]
} cleave ;
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 ;

89
basis/windows/kernel32/kernel32.factor
View File

@ -90,11 +90,12 @@ CONSTANT: FILE_ACTION_MODIFIED 3
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
@ -226,14 +227,14 @@ STRUCT: SYSTEMTIME
{ 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 }
@ -306,13 +307,13 @@ STRUCT: MEMORYSTATUSEX
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
@ -325,11 +326,11 @@ C-STRUCT: MEMORY_BASIC_INFORMATION
{ "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;
@ -659,13 +660,13 @@ C-STRUCT: TOKEN_PRIVILEGES
{ "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
@ -694,19 +695,17 @@ C-STRUCT: OFSTRUCT
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 }

33
basis/windows/offscreen/offscreen.factor
View File

@ -2,25 +2,26 @@
! 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 ]

17
basis/windows/ole32/ole32-tests.factor
View File

@ -1,4 +1,5 @@
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 ] [
@ -19,17 +20,9 @@ IN: windows.ole32.tests
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 ]

79
basis/windows/ole32/ole32.factor
View File

@ -1,7 +1,8 @@
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
@ -130,60 +131,34 @@ TUPLE: ole32-error code message ;
: 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 ;

30
basis/windows/shell32/shell32.factor
View File

@ -3,7 +3,7 @@
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
@ -90,7 +90,7 @@ ALIAS: ShellExecute ShellExecuteW
: 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 )
@ -167,23 +167,23 @@ CONSTANT: SFGAO_NEWCONTENT HEX: 00200000
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
@ -195,9 +195,9 @@ CONSTANT: STRRET_OFFSET 1
CONSTANT: STRRET_CSTR 2
C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
C-STRUCT: STRRET
{ "int" "uType" }
{ "STRRET-union" "union" } ;
STRUCT: STRRET
{ uType int }
{ union STRRET-union } ;
COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046}
HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched )

10
basis/windows/types/types-tests.factor Executable file
View File

@ -0,0 +1,10 @@
! 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

163
basis/windows/types/types.factor
View File

@ -2,7 +2,7 @@
! 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
@ -216,37 +216,37 @@ CONSTANT: TRUE 1
! 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" } ;
STRUCT: WNDCLASS
{ style UINT }
{ lpfnWndProc WNDPROC }
{ cbClsExtra int }
{ cbWndExtra int }
{ hInstance HINSTANCE }
{ hIcon HICON }
{ hCursor HCURSOR }
{ hbrBackground HBRUSH }
{ lpszMenuName LPCTSTR }
{ lpszClassName LPCTSTR } ;
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" } ;
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 } ;
C-STRUCT: RECT
{ "LONG" "left" }
{ "LONG" "top" }
{ "LONG" "right" }
{ "LONG" "bottom" } ;
STRUCT: RECT
{ left LONG }
{ top LONG }
{ right LONG }
{ bottom LONG } ;
C-STRUCT: PAINTSTRUCT
{ "HDC" " hdc" }
@ -257,28 +257,28 @@ C-STRUCT: PAINTSTRUCT
{ "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" } ;
STRUCT: BITMAPINFOHEADER
{ biSize DWORD }
{ biWidth LONG }
{ biHeight LONG }
{ biPlanes WORD }
{ biBitCount WORD }
{ biCompression DWORD }
{ biSizeImage DWORD }
{ biXPelsPerMeter LONG }
{ biYPelsPerMeter LONG }
{ biClrUsed DWORD }
{ biClrImportant DWORD } ;
C-STRUCT: RGBQUAD
{ "BYTE" "rgbBlue" }
{ "BYTE" "rgbGreen" }
{ "BYTE" "rgbRed" }
{ "BYTE" "rgbReserved" } ;
STRUCT: RGBQUAD
{ rgbBlue BYTE }
{ rgbGreen BYTE }
{ rgbRed BYTE }
{ rgbReserved BYTE } ;
C-STRUCT: BITMAPINFO
{ "BITMAPINFOHEADER" "bmiHeader" }
{ "RGBQUAD[1]" "bmiColors" } ;
STRUCT: BITMAPINFO
{ bmiHeader BITMAPINFOHEADER }
{ bimColors RGBQUAD[1] } ;
TYPEDEF: void* LPPAINTSTRUCT
TYPEDEF: void* PAINTSTRUCT
@ -287,9 +287,9 @@ C-STRUCT: POINT
{ "LONG" "x" }
{ "LONG" "y" } ;
C-STRUCT: SIZE
{ "LONG" "cx" }
{ "LONG" "cy" } ;
STRUCT: SIZE
{ cx LONG }
{ cy LONG } ;
C-STRUCT: MSG
{ "HWND" "hWnd" }
@ -329,19 +329,10 @@ STRUCT: PIXELFORMATDESCRIPTOR
{ 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
@ -389,26 +380,26 @@ TYPEDEF: DWORD* LPCOLORREF
: 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

8
basis/windows/uniscribe/uniscribe.factor
View File

@ -4,7 +4,8 @@ USING: kernel assocs math sequences fry io.encodings.string
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 ;
@ -81,10 +82,11 @@ 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 ;

47
basis/windows/user32/user32.factor
View File

@ -1,7 +1,8 @@
! 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
@ -74,8 +75,10 @@ CONSTANT: WS_EX_RIGHTSCROLLBAR HEX: 00000000
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
@ -521,11 +524,11 @@ CONSTANT: TME_NONCLIENT 16
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
@ -538,26 +541,26 @@ CONSTANT: DEVICE_NOTIFY_SERVICE_HANDLE 1
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

38
basis/windows/winsock/winsock.factor
View File

@ -2,7 +2,8 @@
! 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
@ -121,12 +122,12 @@ C-STRUCT: sockaddr-in6
{ { "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" }
@ -142,11 +143,8 @@ C-STRUCT: timeval
{ "long" "sec" }
{ "long" "usec" } ;
: hostent-addr ( hostent -- addr ) hostent-addr-list *void* ; ! *uint ;
LIBRARY: winsock
FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
FUNCTION: ushort htons ( ushort n ) ;
@ -195,9 +193,9 @@ C-STRUCT: FLOWSPEC
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
@ -377,8 +375,6 @@ FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
BOOL fAlertable ) ;
LIBRARY: mswsock
! Not in Windows CE
@ -387,18 +383,10 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
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

47
basis/x11/clipboard/clipboard.factor
View File

@ -1,9 +1,8 @@
! 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
@ -34,20 +33,15 @@ TUPLE: x-clipboard atom contents ;
[ 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"
@ -55,28 +49,27 @@ TUPLE: x-clipboard atom contents ;
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 ;

56
basis/x11/events/events.factor
View File

@ -1,8 +1,7 @@
! 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 -- )
@ -36,14 +35,14 @@ GENERIC: selection-request-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 ;
@ -52,34 +51,31 @@ GENERIC: client-event ( event window -- )
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 ;

26
basis/x11/windows/windows.factor
View File

@ -1,15 +1,15 @@
! 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 )
@ -28,15 +28,15 @@ IN: x11.windows
} 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 -- )
@ -47,8 +47,8 @@ IN: x11.windows
: 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 ;

1082
basis/x11/xlib/xlib.factor
View File

File diff suppressed because it is too large Load Diff

2
core/alien/strings/strings.factor
View File

@ -35,6 +35,8 @@ M: string string>alien
[ 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 ;

5
extra/io/serial/windows/windows.factor
View File

@ -2,7 +2,8 @@
! 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 )
@ -10,7 +11,7 @@ IN: io.serial.windows
: get-comm-state ( duplex -- dcb )
in>> handle>>
"DCB" <c-object> tuck
DCB <struct> tuck
GetCommState win32-error=0/f ;
: set-comm-state ( duplex dcb -- )

14
extra/system-info/windows/windows.factor
View File

@ -21,24 +21,24 @@ IN: system-info.windows
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 ;