From 5bd2ba3aa0c27b847bde8d9f2a2a5a0a2a87884c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Jun 2008 20:06:38 -0700 Subject: [PATCH 1/4] bit-array<>integer conversion functions. ui.backend beep method to ring the system alert sound --- core/bit-arrays/bit-arrays-docs.factor | 17 +++++++++-- core/bit-arrays/bit-arrays-tests.factor | 20 +++++++++++++ core/bit-arrays/bit-arrays.factor | 13 ++++++++ extra/cocoa/application/application.factor | 4 ++- extra/ui/backend/backend.factor | 4 ++- extra/ui/cocoa/cocoa.factor | 3 ++ extra/ui/windows/windows.factor | 3 ++ extra/ui/x11/x11.factor | 3 ++ framebuffers-docs.factor | 35 ++++++++++++++++++++++ 9 files changed, 98 insertions(+), 4 deletions(-) create mode 100644 framebuffers-docs.factor diff --git a/core/bit-arrays/bit-arrays-docs.factor b/core/bit-arrays/bit-arrays-docs.factor index f804ed21f4..6f3afe0867 100644 --- a/core/bit-arrays/bit-arrays-docs.factor +++ b/core/bit-arrays/bit-arrays-docs.factor @@ -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 } "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." } ; diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index e28c16c3c2..03961c2db6 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -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 diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor index ffb9f5d195..4446bb5556 100755 --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -51,4 +51,17 @@ M: bit-array equal? M: bit-array resize resize-bit-array ; +: integer>bit-array ( int -- bit-array ) + [ log2 1+ 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 diff --git a/extra/cocoa/application/application.factor b/extra/cocoa/application/application.factor index 90159c1656..e237302744 100755 --- a/extra/cocoa/application/application.factor +++ b/extra/cocoa/application/application.factor @@ -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 ; diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor index 7ca09b89b4..68d280fc50 100755 --- a/extra/ui/backend/backend.factor +++ b/extra/ui/backend/backend.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces opengl opengl.gl ; +USING: io kernel namespaces opengl opengl.gl ; IN: ui.backend SYMBOL: ui-backend @@ -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 diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index d1b7f22b41..0db38e5eca 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -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 diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 5e17d02542..6b2abcbd76 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -503,6 +503,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 diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 50d383e6b8..1ba0c96a4d 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -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" ? ] diff --git a/framebuffers-docs.factor b/framebuffers-docs.factor new file mode 100644 index 0000000000..c5507dcce1 --- /dev/null +++ b/framebuffers-docs.factor @@ -0,0 +1,35 @@ +USING: help.markup help.syntax io kernel math quotations +opengl.gl multiline assocs ; +IN: opengl.framebuffers + +HELP: gen-framebuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ; + +HELP: gen-renderbuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ; + +HELP: delete-framebuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ; + +HELP: delete-renderbuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ; + +{ gen-framebuffer delete-framebuffer } related-words +{ gen-renderbuffer delete-renderbuffer } related-words + +HELP: framebuffer-incomplete? +{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } } +{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ; + +HELP: check-framebuffer +{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ; + +HELP: with-framebuffer +{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } } +{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ; + +ABOUT: "gl-utilities" \ No newline at end of file From efc69b5c4054c372d94d6fed8ec9d80b90ff137c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Jun 2008 20:10:42 -0700 Subject: [PATCH 2/4] remove unnecessary io usage i introduced to ui.backend --- extra/ui/backend/backend.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor index 68d280fc50..0840d07cbc 100755 --- a/extra/ui/backend/backend.factor +++ b/extra/ui/backend/backend.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io kernel namespaces opengl opengl.gl ; +USING: kernel namespaces opengl opengl.gl ; IN: ui.backend SYMBOL: ui-backend From 6c7b2202177274e24a34c69aad83aeca0d1b2966 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Jun 2008 20:14:18 -0700 Subject: [PATCH 3/4] Use define-declared to stick explicit stack effects on windows.com words --- extra/windows/com/com-tests.factor | 14 ++++++++++++-- extra/windows/com/syntax/syntax.factor | 22 ++++++++++++++++------ extra/windows/com/wrapper/wrapper.factor | 7 ++++--- 3 files changed, 32 insertions(+), 11 deletions(-) diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor index abba8874d6..c04fd8f544 100755 --- a/extra/windows/com/com-tests.factor +++ b/extra/windows/com/com-tests.factor @@ -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 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 diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index ac2b5122c0..80a4a040c4 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -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 ; @@ -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* + ; + : (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 diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor index 78073dbdc8..972a75ecb9 100755 --- a/extra/windows/com/wrapper/wrapper.factor +++ b/extra/windows/com/wrapper/wrapper.factor @@ -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 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 [ ] ] From adbcd7342972afb7cb746e5de0884b463a1ad83c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Jun 2008 20:31:39 -0700 Subject: [PATCH 4/4] oops... accidentally moved opengl.framebuffer docs into root! --- .../framebuffers/framebuffer-docs.factor | 35 ------------------- .../framebuffers/framebuffers-docs.factor | 0 2 files changed, 35 deletions(-) delete mode 100644 extra/opengl/framebuffers/framebuffer-docs.factor rename framebuffers-docs.factor => extra/opengl/framebuffers/framebuffers-docs.factor (100%) diff --git a/extra/opengl/framebuffers/framebuffer-docs.factor b/extra/opengl/framebuffers/framebuffer-docs.factor deleted file mode 100644 index c5507dcce1..0000000000 --- a/extra/opengl/framebuffers/framebuffer-docs.factor +++ /dev/null @@ -1,35 +0,0 @@ -USING: help.markup help.syntax io kernel math quotations -opengl.gl multiline assocs ; -IN: opengl.framebuffers - -HELP: gen-framebuffer -{ $values { "id" integer } } -{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ; - -HELP: gen-renderbuffer -{ $values { "id" integer } } -{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ; - -HELP: delete-framebuffer -{ $values { "id" integer } } -{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ; - -HELP: delete-renderbuffer -{ $values { "id" integer } } -{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ; - -{ gen-framebuffer delete-framebuffer } related-words -{ gen-renderbuffer delete-renderbuffer } related-words - -HELP: framebuffer-incomplete? -{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } } -{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ; - -HELP: check-framebuffer -{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ; - -HELP: with-framebuffer -{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } } -{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ; - -ABOUT: "gl-utilities" \ No newline at end of file diff --git a/framebuffers-docs.factor b/extra/opengl/framebuffers/framebuffers-docs.factor similarity index 100% rename from framebuffers-docs.factor rename to extra/opengl/framebuffers/framebuffers-docs.factor