Merge branch 'master' of git://repo.or.cz/factor/jcg
commit
28e6bf2e8a
|
@ -1,5 +1,5 @@
|
|||
USING: arrays help.markup help.syntax kernel
|
||||
kernel.private prettyprint strings vectors sbufs ;
|
||||
kernel.private math prettyprint strings vectors sbufs ;
|
||||
IN: bit-arrays
|
||||
|
||||
ARTICLE: "bit-arrays" "Bit arrays"
|
||||
|
@ -17,7 +17,10 @@ $nl
|
|||
{ $subsection <bit-array> }
|
||||
"Efficiently setting and clearing all bits in a bit array:"
|
||||
{ $subsection set-bits }
|
||||
{ $subsection clear-bits } ;
|
||||
{ $subsection clear-bits }
|
||||
"Converting between unsigned integers and their binary representation:"
|
||||
{ $subsection integer>bit-array }
|
||||
{ $subsection bit-array>integer } ;
|
||||
|
||||
ABOUT: "bit-arrays"
|
||||
|
||||
|
@ -47,3 +50,13 @@ HELP: set-bits
|
|||
{ $code "[ drop t ] change-each" }
|
||||
}
|
||||
{ $side-effects "bit-array" } ;
|
||||
|
||||
HELP: integer>bit-array
|
||||
{ $values { "integer" integer } { "bit-array" bit-array } }
|
||||
{ $description "Outputs a freshly-allocated bit array whose elements correspond to the bits in the binary representation of the given unsigned integer value." }
|
||||
{ $notes "The bits of the integer are stored in the resulting bit array in order of ascending significance, least significant bit first. This word will fail if passed a negative integer. If you want the two's-complement binary representation of a negative number, use " { $link bitnot } " to get the complement of the number first. This word works with fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;
|
||||
|
||||
HELP: bit-array>integer
|
||||
{ $values { "bit-array" bit-array } { "integer" integer } }
|
||||
{ $description "Outputs the unsigned integer whose binary representation corresponds to the contents of the given bit array." }
|
||||
{ $notes "The bits of the integer are taken from the bit array in order of ascending significance, least significant bit first. This word is able to return fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;
|
||||
|
|
|
@ -52,3 +52,23 @@ IN: bit-arrays.tests
|
|||
[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test
|
||||
|
||||
[ -10 ?{ } resize-bit-array ] must-fail
|
||||
|
||||
[ -1 integer>bit-array ] must-fail
|
||||
[ ?{ f t } ] [ 2 integer>bit-array ] unit-test
|
||||
[ ?{ t t t t t t t t t } ] [ 511 integer>bit-array ] unit-test
|
||||
[ ?{
|
||||
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
|
||||
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
|
||||
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
|
||||
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
|
||||
} ] [
|
||||
HEX: ffffffffffffffffffffffffffffffff integer>bit-array
|
||||
] unit-test
|
||||
|
||||
[ 14 ] [ ?{ f t t t } bit-array>integer ] unit-test
|
||||
[ HEX: ffffffffffffffffffffffffffffffff ] [ ?{
|
||||
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
|
||||
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
|
||||
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
|
||||
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
|
||||
} bit-array>integer ] unit-test
|
||||
|
|
|
@ -51,4 +51,17 @@ M: bit-array equal?
|
|||
M: bit-array resize
|
||||
resize-bit-array ;
|
||||
|
||||
: integer>bit-array ( int -- bit-array )
|
||||
[ log2 1+ <bit-array> 0 ] keep
|
||||
[ dup zero? not ] [
|
||||
[ -8 shift ] [ 255 bitand ] bi
|
||||
-roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip
|
||||
] [ ] while
|
||||
2drop ;
|
||||
|
||||
: bit-array>integer ( bit-array -- int )
|
||||
dup >r length 7 + n>byte 0 r> [
|
||||
swap alien-unsigned-1 swap 8 shift bitor
|
||||
] curry reduce ;
|
||||
|
||||
INSTANCE: bit-array sequence
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien io kernel namespaces core-foundation
|
||||
USING: alien alien.syntax io kernel namespaces core-foundation
|
||||
core-foundation.run-loop cocoa.messages cocoa cocoa.classes
|
||||
cocoa.runtime sequences threads debugger init inspector
|
||||
kernel.private ;
|
||||
|
@ -19,6 +19,8 @@ IN: cocoa.application
|
|||
|
||||
: NSApp ( -- app ) NSApplication -> sharedApplication ;
|
||||
|
||||
FUNCTION: void NSBeep ( ) ;
|
||||
|
||||
: with-cocoa ( quot -- )
|
||||
[ NSApp drop call ] with-autorelease-pool ;
|
||||
|
||||
|
|
|
@ -23,6 +23,8 @@ HOOK: select-gl-context ui-backend ( handle -- )
|
|||
|
||||
HOOK: flush-gl-context ui-backend ( handle -- )
|
||||
|
||||
HOOK: beep ui-backend ( -- )
|
||||
|
||||
: with-gl-context ( handle quot -- )
|
||||
swap [ select-gl-context call ] keep
|
||||
glFlush flush-gl-context gl-error ; inline
|
||||
|
|
|
@ -101,6 +101,9 @@ M: cocoa-ui-backend select-gl-context ( handle -- )
|
|||
M: cocoa-ui-backend flush-gl-context ( handle -- )
|
||||
handle-view -> openGLContext -> flushBuffer ;
|
||||
|
||||
M: cocoa-ui-backend beep ( -- )
|
||||
NSBeep ;
|
||||
|
||||
SYMBOL: cocoa-init-hook
|
||||
|
||||
M: cocoa-ui-backend ui
|
||||
|
|
|
@ -506,6 +506,9 @@ M: windows-ui-backend ui
|
|||
] [ cleanup-win32-ui ] [ ] cleanup
|
||||
] ui-running ;
|
||||
|
||||
M: windows-ui-backend beep ( -- )
|
||||
0 MessageBeep drop ;
|
||||
|
||||
windows-ui-backend ui-backend set-global
|
||||
|
||||
[ "ui" ] main-vocab-hook set-global
|
||||
|
|
|
@ -257,6 +257,9 @@ M: x11-ui-backend ui ( -- )
|
|||
] with-x
|
||||
] ui-running ;
|
||||
|
||||
M: x11-ui-backend beep ( -- )
|
||||
dpy 100 XBell drop ;
|
||||
|
||||
x11-ui-backend ui-backend set-global
|
||||
|
||||
[ "DISPLAY" system:os-env "ui" "listener" ? ]
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
USING: kernel windows.com windows.com.syntax windows.ole32
|
||||
alien alien.syntax tools.test libc alien.c-types arrays.lib
|
||||
namespaces arrays continuations accessors math windows.com.wrapper
|
||||
windows.com.wrapper.private destructors ;
|
||||
windows.com.wrapper.private destructors effects ;
|
||||
IN: windows.com.tests
|
||||
|
||||
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
|
||||
|
@ -21,6 +21,12 @@ COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
|
|||
"{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
|
||||
"{b06ac3f4-30e4-406b-a7cd-c29cead4552c}" string>guid 1array [ IUnrelated-iid ] unit-test
|
||||
|
||||
{ (( -- iid )) } [ \ ISimple-iid stack-effect ] unit-test
|
||||
{ (( this -- HRESULT )) } [ \ ISimple::returnOK stack-effect ] unit-test
|
||||
{ (( this -- int )) } [ \ IInherited::getX stack-effect ] unit-test
|
||||
{ (( this newX -- )) } [ \ IInherited::setX stack-effect ] unit-test
|
||||
{ (( this mul add -- int )) } [ \ IUnrelated::xMulAdd stack-effect ] unit-test
|
||||
|
||||
SYMBOL: +test-wrapper+
|
||||
SYMBOL: +guinea-pig-implementation+
|
||||
SYMBOL: +orig-wrapped-objects+
|
||||
|
@ -49,7 +55,11 @@ dup +test-wrapper+ set [
|
|||
|
||||
S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
|
||||
E_FAIL <long> *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
|
||||
20 1array [ +guinea-pig-implementation+ get dup 20 IInherited::setX IInherited::getX ] unit-test
|
||||
20 1array [
|
||||
+guinea-pig-implementation+ get
|
||||
[ 20 IInherited::setX ]
|
||||
[ IInherited::getX ] bi
|
||||
] unit-test
|
||||
420 1array [
|
||||
+guinea-pig-implementation+ get
|
||||
IUnrelated-iid com-query-interface
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
USING: alien alien.c-types kernel windows.ole32 combinators.lib
|
||||
USING: alien alien.c-types effects kernel windows.ole32 combinators.lib
|
||||
parser splitting grouping sequences.lib sequences namespaces
|
||||
assocs quotations shuffle accessors words macros alien.syntax
|
||||
fry ;
|
||||
fry arrays ;
|
||||
IN: windows.com.syntax
|
||||
|
||||
<PRIVATE
|
||||
|
@ -41,7 +41,7 @@ unless
|
|||
: (parse-com-function) ( tokens -- definition )
|
||||
[ second ]
|
||||
[ first ]
|
||||
[ 3 tail 2 group [ first ] map "void*" prefix ]
|
||||
[ 3 tail [ CHAR: , swap remove ] map 2 group { "void*" "this" } prefix ]
|
||||
tri
|
||||
<com-function-definition> ;
|
||||
|
||||
|
@ -63,14 +63,24 @@ unless
|
|||
dup parent>> [ family-tree-functions ] [ { } ] if*
|
||||
swap functions>> append ;
|
||||
|
||||
: (invocation-quot) ( function return parameters -- quot )
|
||||
[ first ] map [ com-invoke ] 3curry ;
|
||||
|
||||
: (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect )
|
||||
swap
|
||||
[ [ second ] map ]
|
||||
[ dup "void" = [ drop { } ] [ 1array ] if ] bi*
|
||||
<effect> ;
|
||||
|
||||
: (define-word-for-function) ( function interface n -- )
|
||||
-rot [ (function-word) swap ] 2keep drop
|
||||
{ return>> parameters>> } get-slots
|
||||
[ com-invoke ] 3curry
|
||||
define ;
|
||||
[ (invocation-quot) ] 2keep
|
||||
(stack-effect-from-return-and-parameters)
|
||||
define-declared ;
|
||||
|
||||
: define-words-for-com-interface ( definition -- )
|
||||
[ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
|
||||
[ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ]
|
||||
[ name>> "com-interface" swap typedef ]
|
||||
[
|
||||
dup family-tree-functions
|
||||
|
|
|
@ -29,7 +29,7 @@ unless
|
|||
>r find-com-interface-definition family-tree
|
||||
r> 1quotation [ >r iid>> r> 2array ] curry map
|
||||
] map-index concat
|
||||
[ f ] suffix ,
|
||||
[ drop f ] suffix ,
|
||||
\ case ,
|
||||
"void*" heap-size
|
||||
[ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
|
||||
|
@ -69,13 +69,14 @@ unless
|
|||
|
||||
: compile-alien-callback ( return parameters abi quot -- alien )
|
||||
[ alien-callback ] 4 ncurry
|
||||
[ gensym [ swap define ] keep ] with-compilation-unit
|
||||
[ gensym [ swap (( -- alien )) define-declared ] keep ]
|
||||
with-compilation-unit
|
||||
execute ;
|
||||
|
||||
: (make-vtbl) ( interface-name quots iunknown-methods n -- )
|
||||
(thunk) (thunked-quots)
|
||||
swap find-com-interface-definition family-tree-functions [
|
||||
{ return>> parameters>> } get-slots
|
||||
[ return>> ] [ parameters>> [ first ] map ] bi
|
||||
dup length 1- roll [
|
||||
first dup empty?
|
||||
[ 2drop [ ] ]
|
||||
|
|
Loading…
Reference in New Issue