diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 15e67bf0fe..e4a0e4dcf0 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.strings alien.c-types alien.accessors alien.structs arrays words sequences math kernel namespaces fry libc cpu.architecture -io.encodings.utf8 io.encodings.utf16n ; +io.encodings.utf8 ; IN: alien.arrays UNION: value-type array struct-type ; @@ -95,5 +95,4 @@ M: string-type c-type-setter { "char*" utf8 } "char*" typedef "char*" "uchar*" typedef -{ "char*" utf16n } "wchar_t*" typedef diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 92d75604e0..4a7a558703 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -448,7 +448,6 @@ M: quotation ' array>> ' quotation [ emit ! array - f ' emit ! compiled f ' emit ! cached-effect f ' emit ! cache-counter 0 emit ! xt diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 9d19e4a231..3cbe155dd2 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -12,6 +12,16 @@ SYMBOL: core-bootstrap-time SYMBOL: bootstrap-time +: strip-encodings ( -- ) + os unix? [ + [ + P" resource:core/io/encodings/utf16/utf16.factor" + P" resource:core/io/encodings/utf16n/utf16n.factor" [ forget ] bi@ + "io.encodings.utf16" + "io.encodings.utf16n" [ child-vocabs [ forget-vocab ] each ] bi@ + ] with-compilation-unit + ] when ; + : default-image-name ( -- string ) vm file-name os windows? [ "." split1-last drop ] when ".image" append resource-path ; @@ -55,6 +65,8 @@ SYMBOL: bootstrap-time "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global "" "exclude" set-global + strip-encodings + (command-line) parse-command-line ! Set dll paths diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 6b383388ef..b795862970 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -20,7 +20,7 @@ CONSTANT: deck-bits 18 : underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline : word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline -: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline +: quot-xt-offset ( -- n ) 4 bootstrap-cells quotation tag-number - ; inline : word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline : array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index f210180517..1a52ce6f34 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -173,10 +173,11 @@ M: stdin refill size-read-fd init-fd >>size data-read-fd >>data ; -M: unix (init-stdio) +M: unix init-stdio 1 - 2 t ; + 2 + set-stdio ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port < port mx ; diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 4dfe02d651..69a695ac72 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -1,9 +1,9 @@ -USING: alien alien.c-types arrays assocs combinators -continuations destructors io io.backend io.ports io.timeouts -io.backend.windows io.files.windows io.files.windows.nt io.files -io.pathnames io.buffers io.streams.c libc kernel math namespaces -sequences threads windows windows.errors windows.kernel32 -strings splitting ascii system accessors locals ; +USING: alien alien.c-types arrays assocs combinators continuations +destructors io io.backend io.ports io.timeouts io.backend.windows +io.files.windows io.files.windows.nt io.files io.pathnames io.buffers +io.streams.c io.streams.null libc kernel math namespaces sequences +threads windows windows.errors windows.kernel32 strings splitting +ascii system accessors locals ; QUALIFIED: windows.winsock IN: io.backend.windows.nt @@ -140,7 +140,9 @@ M: winnt (wait-to-read) ( port -- ) : console-app? ( -- ? ) GetConsoleWindow >boolean ; -M: winnt (init-stdio) - console-app? [ init-c-stdio t ] [ f f f f ] if ; +M: winnt init-stdio + console-app? + [ init-c-stdio ] + [ null-reader null-writer null-writer set-stdio ] if ; winnt set-io-backend diff --git a/basis/io/directories/unix/linux/linux.factor b/basis/io/directories/unix/linux/linux.factor new file mode 100644 index 0000000000..ba5b27dacd --- /dev/null +++ b/basis/io/directories/unix/linux/linux.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types io.directories.unix kernel system unix ; +IN: io.directories.unix.linux + +M: unix find-next-file ( DIR* -- byte-array ) + "dirent" + f + [ readdir64_r 0 = [ (io-error) ] unless ] 2keep + *void* [ drop f ] unless ; diff --git a/basis/io/directories/unix/linux/tags.txt b/basis/io/directories/unix/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/directories/unix/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index 395ce73d7c..b8b781ec12 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -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 ; +unix unix.stat vocabs.loader ; IN: io.directories.unix : touch-mode ( -- n ) @@ -34,7 +34,9 @@ M: unix copy-file ( from to -- ) [ opendir dup [ (io-error) ] unless ] dip dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline -: find-next-file ( DIR* -- byte-array ) +HOOK: find-next-file os ( DIR* -- byte-array ) + +M: unix find-next-file ( DIR* -- byte-array ) "dirent" f [ readdir_r 0 = [ (io-error) ] unless ] 2keep @@ -54,8 +56,10 @@ M: unix copy-file ( from to -- ) } case ; M: unix >directory-entry ( byte-array -- directory-entry ) - [ dirent-d_name utf8 alien>string ] - [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ; + { + [ dirent-d_name utf8 alien>string ] + [ dirent-d_type dirent-type>file-type ] + } cleave directory-entry boa ; M: unix (directory-entries) ( path -- seq ) [ @@ -63,3 +67,5 @@ M: unix (directory-entries) ( path -- seq ) [ >directory-entry ] produce nip ] with-unix-directory ; + +os linux? [ "io.directories.unix.linux" require ] when diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor index 5c5d2c93d2..f16db428a8 100644 --- a/basis/io/files/info/info.factor +++ b/basis/io/files/info/info.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel system sequences combinators -vocabs.loader io.files.types ; +vocabs.loader io.files.types math ; IN: io.files.info ! File info @@ -14,6 +14,9 @@ HOOK: link-info os ( path -- info ) : directory? ( file-info -- ? ) type>> +directory+ = ; +: sparse-file? ( file-info -- ? ) + [ size-on-disk>> ] [ size>> ] bi < ; + ! File systems HOOK: file-systems os ( -- array ) diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 838c09c657..7451499978 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system kernel namespaces strings hashtables sequences -assocs combinators vocabs.loader init threads continuations -math accessors concurrency.flags destructors environment -io io.encodings.ascii io.backend io.timeouts io.pipes -io.pipes.private io.encodings io.streams.duplex io.ports -debugger prettyprint summary calendar ; +USING: system kernel namespaces strings hashtables sequences assocs +combinators vocabs.loader init threads continuations math accessors +concurrency.flags destructors environment io io.encodings.ascii +io.backend io.timeouts io.pipes io.pipes.private io.encodings +io.encodings.utf8 io.streams.duplex io.ports debugger prettyprint +summary calendar ; IN: io.launcher TUPLE: process < identity-tuple @@ -254,6 +254,21 @@ M: object run-pipeline-element swap [ with-stream ] dip wait-for-success ; inline +ERROR: output-process-error { output string } { process process } ; + +M: output-process-error error. + [ "Process:" print process>> . nl ] + [ "Output:" print output>> print ] + bi ; + +: try-output-process ( command -- ) + >process + +stdout+ >>stderr + +closed+ >>stdin + utf8 + [ stream-contents ] [ dup wait-for-process ] bi* + 0 = [ 2drop ] [ output-process-error ] if ; + : notify-exit ( process status -- ) >>status [ processes get delete-at* drop [ resume ] each ] keep diff --git a/core/io/streams/null/authors.txt b/basis/io/streams/null/authors.txt similarity index 100% rename from core/io/streams/null/authors.txt rename to basis/io/streams/null/authors.txt diff --git a/core/io/streams/null/null-docs.factor b/basis/io/streams/null/null-docs.factor similarity index 100% rename from core/io/streams/null/null-docs.factor rename to basis/io/streams/null/null-docs.factor diff --git a/core/io/streams/null/null.factor b/basis/io/streams/null/null.factor similarity index 100% rename from core/io/streams/null/null.factor rename to basis/io/streams/null/null.factor diff --git a/core/io/streams/null/summary.txt b/basis/io/streams/null/summary.txt similarity index 100% rename from core/io/streams/null/summary.txt rename to basis/io/streams/null/summary.txt diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor index ba0524009f..5aaf2c2ea6 100755 --- a/basis/struct-arrays/struct-arrays.factor +++ b/basis/struct-arrays/struct-arrays.factor @@ -35,6 +35,6 @@ ERROR: bad-byte-array-length byte-array ; heap-size struct-array boa ; inline : malloc-struct-array ( length c-type -- struct-array ) - [ heap-size calloc ] 2keep ; + [ heap-size calloc ] 2keep ; inline INSTANCE: struct-array sequence diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 842faba640..9cf21d1716 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -97,4 +97,8 @@ M: quit-responder call-responder* shake-and-bake run-temp-image ] curry unit-test -] each \ No newline at end of file +] each + +os windows? os macosx? or [ + [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test +] when \ No newline at end of file diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index d79326ddc4..6816445508 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays accessors io.backend io.streams.c init fry namespaces -make assocs kernel parser lexer strings.parser vocabs sequences words -memory kernel.private continuations io vocabs.loader system strings -sets vectors quotations byte-arrays sorting compiler.units definitions -generic generic.standard tools.deploy.config combinators classes ; +math make assocs kernel parser lexer strings.parser vocabs sequences +sequences.private words memory kernel.private continuations io +vocabs.loader system strings sets vectors quotations byte-arrays +sorting compiler.units definitions generic generic.standard +generic.single tools.deploy.config combinators classes +slots.private ; QUALIFIED: bootstrap.stage2 QUALIFIED: command-line QUALIFIED: compiler.errors @@ -38,10 +40,11 @@ IN: tools.deploy.shaker strip-io? [ "io.files" init-hooks get delete-at "io.backend" init-hooks get delete-at + "io.thread" init-hooks get delete-at ] when strip-dictionary? [ { - "compiler.units" + ! "compiler.units" "vocabs" "vocabs.cache" "source-files.errors" @@ -193,7 +196,8 @@ IN: tools.deploy.shaker : strip-compiler-classes ( -- ) "Stripping compiler classes" show - "compiler" child-vocabs [ words ] map concat [ class? ] filter + { "compiler" "stack-checker" } + [ child-vocabs [ words ] map concat [ class? ] filter ] map concat [ dup implementors [ "methods" word-prop delete-at ] with each ] each ; : strip-default-methods ( -- ) @@ -271,7 +275,7 @@ IN: tools.deploy.shaker compiled-generic-crossref compiler-impl compiler.errors:compiler-errors - definition-observers + ! definition-observers interactive-vocabs lexer-factory print-use-hook @@ -301,16 +305,16 @@ IN: tools.deploy.shaker compiler.errors:compiler-errors continuations:thread-error-hook } % + + deploy-ui? get [ + "ui-error-hook" "ui.gadgets.worlds" lookup , + ] when ] when deploy-c-types? get [ "c-types" "alien.c-types" lookup , ] unless - deploy-ui? get [ - "ui-error-hook" "ui.gadgets.worlds" lookup , - ] when - "windows-messages" "windows.messages" lookup [ , ] when* ] { } make ; @@ -325,12 +329,17 @@ IN: tools.deploy.shaker ] [ drop ] if ; : strip-c-io ( -- ) - deploy-io get 2 = os windows? or [ + strip-io? + deploy-io get 3 = os windows? not and + or [ [ c-io-backend forget "io.streams.c" forget-vocab + "io-thread-running?" "io.thread" lookup [ + global delete-at + ] when* ] with-compilation-unit - ] unless ; + ] when ; : compress ( pred post-process string -- ) "Compressing " prepend show @@ -353,7 +362,7 @@ IN: tools.deploy.shaker #! Quotations which were formerly compiled must remain #! compiled. 2dup [ - 2dup [ compiled>> ] [ compiled>> not ] bi* and + 2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and [ nip jit-compile ] [ 2drop ] if ] 2each ; @@ -406,6 +415,23 @@ SYMBOL: deploy-vocab ] each "vocab:tools/deploy/shaker/next-methods.factor" run-file ; +: (clear-megamorphic-cache) ( i array -- ) + 2dup 1 slot < [ + 2dup [ f ] 2dip set-array-nth + [ 1 + ] dip (clear-megamorphic-cache) + ] [ 2drop ] if ; + +: clear-megamorphic-cache ( array -- ) + [ 0 ] dip (clear-megamorphic-cache) ; + +: find-megamorphic-caches ( -- seq ) + "Finding megamorphic caches" show + [ standard-generic? ] instances [ def>> third ] map ; + +: clear-megamorphic-caches ( cache -- ) + "Clearing megamorphic caches" show + [ clear-megamorphic-cache ] each ; + : strip ( -- ) init-stripper strip-libc @@ -419,11 +445,13 @@ SYMBOL: deploy-vocab strip-default-methods f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore deploy-vocab get vocab-main deploy-boot-quot + find-megamorphic-caches stripped-word-props stripped-globals strip-globals compress-objects compress-quotations - strip-words ; + strip-words + clear-megamorphic-caches ; : deploy-error-handler ( quot -- ) [ @@ -443,6 +471,9 @@ SYMBOL: deploy-vocab strip-debugger? [ "debugger" require "inspector" require + deploy-ui? get [ + "ui.debugger" require + ] when ] unless deploy-vocab set deploy-vocab get require diff --git a/basis/tools/deploy/test/8/8.factor b/basis/tools/deploy/test/8/8.factor new file mode 100644 index 0000000000..ddf08d3654 --- /dev/null +++ b/basis/tools/deploy/test/8/8.factor @@ -0,0 +1,21 @@ +USING: calendar game-input threads ui ui.gadgets.worlds kernel +method-chains system ; +IN: tools.deploy.test.8 + +TUPLE: my-world < world ; + +BEFORE: my-world begin-world drop open-game-input ; + +AFTER: my-world end-world drop close-game-input ; + +: test-game-input ( -- ) + [ + f T{ world-attributes + { world-class my-world } + { title "Test" } + } open-window + 1 seconds sleep + 0 exit + ] with-ui ; + +MAIN: test-game-input \ No newline at end of file diff --git a/basis/tools/deploy/test/8/deploy.factor b/basis/tools/deploy/test/8/deploy.factor new file mode 100644 index 0000000000..1f7fb4d7ee --- /dev/null +++ b/basis/tools/deploy/test/8/deploy.factor @@ -0,0 +1,14 @@ +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-unicode? f } + { deploy-word-defs? f } + { deploy-name "tools.deploy.test.8" } + { "stop-after-last-window?" t } + { deploy-reflection 1 } + { deploy-ui? t } + { deploy-math? t } + { deploy-io 2 } + { deploy-word-props? f } + { deploy-threads? t } +} diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor index f997a6eb3a..9a54e65f1a 100644 --- a/basis/tools/deploy/test/test.factor +++ b/basis/tools/deploy/test/test.factor @@ -1,5 +1,5 @@ USING: accessors arrays continuations io.directories io.files.info -io.files.temp io.launcher kernel layouts math sequences system +io.files.temp io.launcher io.backend kernel layouts math sequences system tools.deploy.backend tools.deploy.config.editor ; IN: tools.deploy.test @@ -14,7 +14,6 @@ IN: tools.deploy.test [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ; : run-temp-image ( -- ) - vm - "-i=" "test.image" temp-file append - 2array - swap >>command +closed+ >>stdin try-process ; \ No newline at end of file + os macosx? + "resource:Factor.app/Contents/MacOS/factor" normalize-path vm ? + "-i=" "test.image" temp-file append 2array try-output-process ; \ No newline at end of file diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 2cf4091937..afed121fb6 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -616,10 +616,8 @@ M: windows-ui-backend do-events GetDoubleClickTime milliseconds double-click-timeout set-global ; : cleanup-win32-ui ( -- ) - class-name-ptr [ - [ [ f UnregisterClass drop ] [ free ] bi ] when* f - ] change-global - msg-obj change-global [ [ free ] when* f ] ; + class-name-ptr [ [ [ f UnregisterClass drop ] [ free ] bi ] when* f ] change-global + msg-obj [ [ free ] when* f ] change-global ; : get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ; diff --git a/basis/ui/debugger/debugger.factor b/basis/ui/debugger/debugger.factor new file mode 100755 index 0000000000..e2c8b06bdd --- /dev/null +++ b/basis/ui/debugger/debugger.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2006, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors debugger io kernel namespaces prettyprint +ui.gadgets.panes ui.gadgets.worlds ui ; +IN: ui.debugger + +: ( error -- pane ) + [ [ print-error ] with-pane ] keep ; inline + +: error-window ( error -- ) + "Error" open-window ; + +[ error-window ] ui-error-hook set-global + +M: world-error error. + "An error occurred while drawing the world " write + dup world>> pprint-short "." print + "This world has been deactivated to prevent cascading errors." print + error>> error. ; diff --git a/basis/ui/gadgets/presentations/presentations.factor b/basis/ui/gadgets/presentations/presentations.factor old mode 100644 new mode 100755 index a0799c7b86..93a585e330 --- a/basis/ui/gadgets/presentations/presentations.factor +++ b/basis/ui/gadgets/presentations/presentations.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays accessors definitions hashtables io kernel sequences -strings words help math models namespaces quotations ui.gadgets +strings words math models namespaces quotations ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.buttons.private ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds ui.gadgets.status-bar ui.commands ui.operations ui.gestures ; diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor index d4e9790d89..c12c6b93aa 100755 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -13,6 +13,17 @@ HELP: origin HELP: hand-world { $var-description "Global variable. The " { $link world } " containing the gadget at the mouse location." } ; +HELP: grab-input +{ $values { "gadget" gadget } } +{ $description "Sets the " { $link world } " containing " { $snippet "gadget" } " to grab mouse and keyboard input while focused." } +{ $notes "Normal mouse gestures may not be available while input is grabbed." } ; + +HELP: ungrab-input +{ $values { "gadget" gadget } } +{ $description "Sets the " { $link world } " containing " { $snippet "gadget" } " not to grab mouse and keyboard input while focused." } ; + +{ grab-input ungrab-input } related-words + HELP: set-title { $values { "string" string } { "world" world } } { $description "Sets the title bar of the native window containing the world." } @@ -42,6 +53,7 @@ HELP: world { { $snippet "focus" } " - the current owner of the keyboard focus in the world." } { { $snippet "focused?" } " - a boolean indicating if the native window containing the world has keyboard focus." } { { $snippet "fonts" } " - a hashtable used by the " { $link font-renderer } "." } + { { $snippet "grab-input?" } " - if set to " { $link t } ", the world will hide the mouse cursor and disable normal mouse input while focused. Use " { $link grab-input } " and " { $link ungrab-input } " to change this setting." } { { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." } { { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." } } diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 2e7b84ef6e..38fb220c69 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl opengl.textures sequences io combinators combinators.short-circuit fry math.vectors math.rectangles cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -ui.pixel-formats destructors literals ; +ui.pixel-formats destructors literals strings ; IN: ui.gadgets.worlds CONSTANT: default-world-pixel-format-attributes @@ -21,7 +21,7 @@ TUPLE: world < track TUPLE: world-attributes { world-class initial: world } grab-input? - title + { title string initial: "Factor Window" } status gadgets { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ; @@ -31,6 +31,20 @@ TUPLE: world-attributes : find-world ( gadget -- world/f ) [ world? ] find-parent ; +: grab-input ( gadget -- ) + find-world dup grab-input?>> + [ drop ] [ + t >>grab-input? + dup focused?>> [ handle>> (grab-input) ] [ drop ] if + ] if ; + +: ungrab-input ( gadget -- ) + find-world dup grab-input?>> + [ + f >>grab-input? + dup focused?>> [ handle>> (ungrab-input) ] [ drop ] if + ] [ drop ] if ; + : show-status ( string/f gadget -- ) dup find-world dup [ dup status>> [ @@ -63,7 +77,7 @@ M: world request-focus-on ( child gadget -- ) : new-world ( class -- world ) vertical swap new-track t >>root? - t >>active? + f >>active? { 0 0 } >>window-loc f >>grab-input? ; @@ -87,7 +101,7 @@ M: world layout* [ call-next-method ] [ dup layers>> [ as-big-as-possible ] with each ] bi ; -M: world focusable-child* gadget-child ; +M: world focusable-child* children>> [ t ] [ first ] if-empty ; M: world children-on nip children>> ; diff --git a/basis/ui/operations/operations.factor b/basis/ui/operations/operations.factor old mode 100644 new mode 100755 index db6048061e..a502707ee6 --- a/basis/ui/operations/operations.factor +++ b/basis/ui/operations/operations.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions kernel ui.commands ui.gestures sequences strings math words generic namespaces -hashtables help.markup quotations assocs fry linked-assocs ; +hashtables quotations assocs fry linked-assocs ; IN: ui.operations SYMBOL: +keyboard+ diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor old mode 100644 new mode 100755 index 42666ab064..f3f533e681 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -8,7 +8,7 @@ ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback -ui.tools.inspector ui.tools.browser ; +ui.tools.inspector ui.tools.browser ui.debugger ; IN: ui.tools.debugger TUPLE: debugger < track error restarts restart-hook restart-list continuation ; @@ -27,9 +27,6 @@ M: restart-renderer row-columns t >>selection-required? t >>single-click? ; inline -: ( error -- pane ) - [ [ print-error ] with-pane ] keep ; inline - : ( debugger -- gadget ) [ ] dip [ error>> add-gadget ] @@ -72,12 +69,6 @@ M: object error-in-debugger? drop f ; [ rethrow ] [ error-continuation get debugger-window ] if ] ui-error-hook set-global -M: world-error error. - "An error occurred while drawing the world " write - dup world>> pprint-short "." print - "This world has been deactivated to prevent cascading errors." print - error>> error. ; - debugger "gestures" f { { T{ button-down } request-focus } } define-command-map diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index 397fc419fa..e206c7d408 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -40,12 +40,12 @@ HELP: find-window { $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ; HELP: register-window -{ $values { "world" world } { "handle" "a baackend-specific handle" } } +{ $values { "world" world } { "handle" "a backend-specific handle" } } { $description "Adds a window to the global " { $link windows } " variable." } { $notes "This word should only be called by the UI backend. User code can open new windows with " { $link open-window } "." } ; HELP: unregister-window -{ $values { "handle" "a baackend-specific handle" } } +{ $values { "handle" "a backend-specific handle" } } { $description "Removes a window from the global " { $link windows } " variable." } { $notes "This word should only be called only by the UI backend, and not user code." } ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index d53d4c6753..0a6f26fd5b 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -59,22 +59,28 @@ SYMBOL: windows [ ?ungrab-input ] [ focus-path f swap focus-gestures ] bi ; -: try-to-open-window ( world -- ) +: set-up-window ( world -- ) { - [ (open-window) ] [ handle>> select-gl-context ] - [ - [ begin-world ] - [ [ handle>> (close-window) ] [ ui-error ] bi* ] - recover - ] + [ [ title>> ] keep set-title ] + [ begin-world ] [ resize-world ] + [ t >>active? drop ] + [ request-focus ] } cleave ; +: clean-up-broken-window ( world -- ) + [ + dup { [ focused?>> ] [ grab-input?>> ] } 1&& + [ handle>> (ungrab-input) ] [ drop ] if + ] [ handle>> (close-window) ] bi ; + M: world graft* - [ try-to-open-window ] - [ [ title>> ] keep set-title ] - [ request-focus ] tri ; + [ (open-window) ] + [ + [ set-up-window ] + [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover + ] bi ; : reset-world ( world -- ) #! This is used when a window is being closed, but also diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor index 0cf33be1bf..43a66f2dbe 100644 --- a/basis/unix/linux/linux.factor +++ b/basis/unix/linux/linux.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax alien system ; IN: unix ! Linux. @@ -93,13 +93,20 @@ C-STRUCT: passwd { "char*" "pw_dir" } { "char*" "pw_shell" } ; +! dirent64 C-STRUCT: dirent - { "__ino_t" "d_ino" } - { "__off_t" "d_off" } + { "ulonglong" "d_ino" } + { "longlong" "d_off" } { "ushort" "d_reclen" } { "uchar" "d_type" } { { "char" 256 } "d_name" } ; +FUNCTION: int open64 ( char* path, int flags, int prot ) ; +FUNCTION: dirent64* readdir64 ( DIR* dirp ) ; +FUNCTION: int readdir64_r ( void* dirp, dirent* entry, dirent** result ) ; + +M: linux open-file [ open64 ] unix-system-call ; + CONSTANT: EPERM 1 CONSTANT: ENOENT 2 CONSTANT: ESRCH 3 diff --git a/basis/unix/stat/linux/32/32.factor b/basis/unix/stat/linux/32/32.factor index 35963cf4ed..98c4b90f32 100644 --- a/basis/unix/stat/linux/32/32.factor +++ b/basis/unix/stat/linux/32/32.factor @@ -1,29 +1,28 @@ -USING: kernel alien.syntax math ; +USING: kernel alien.syntax math sequences unix +alien.c-types arrays accessors combinators ; IN: unix.stat -! Ubuntu 8.04 32-bit - +! stat64 C-STRUCT: stat - { "dev_t" "st_dev" } - { "ushort" "__pad1" } - { "ino_t" "st_ino" } - { "mode_t" "st_mode" } - { "nlink_t" "st_nlink" } - { "uid_t" "st_uid" } - { "gid_t" "st_gid" } - { "dev_t" "st_rdev" } - { "ushort" "__pad2" } - { "off_t" "st_size" } - { "blksize_t" "st_blksize" } - { "blkcnt_t" "st_blocks" } - { "timespec" "st_atimespec" } - { "timespec" "st_mtimespec" } - { "timespec" "st_ctimespec" } - { "ulong" "unused4" } - { "ulong" "unused5" } ; + { "dev_t" "st_dev" } + { "ushort" "__pad1" } + { "__ino_t" "__st_ino" } + { "mode_t" "st_mode" } + { "nlink_t" "st_nlink" } + { "uid_t" "st_uid" } + { "gid_t" "st_gid" } + { "dev_t" "st_rdev" } + { { "ushort" 2 } "__pad2" } + { "off64_t" "st_size" } + { "blksize_t" "st_blksize" } + { "blkcnt64_t" "st_blocks" } + { "timespec" "st_atimespec" } + { "timespec" "st_mtimespec" } + { "timespec" "st_ctimespec" } + { "ulonglong" "st_ino" } ; -FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ; -FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ; +FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ; +FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ; -: stat ( pathname buf -- int ) [ 3 ] 2dip __xstat ; -: lstat ( pathname buf -- int ) [ 3 ] 2dip __lxstat ; +: stat ( pathname buf -- int ) [ 1 ] 2dip __xstat64 ; +: lstat ( pathname buf -- int ) [ 1 ] 2dip __lxstat64 ; diff --git a/basis/unix/stat/linux/64/64.factor b/basis/unix/stat/linux/64/64.factor index 81b33f3227..98c4b90f32 100644 --- a/basis/unix/stat/linux/64/64.factor +++ b/basis/unix/stat/linux/64/64.factor @@ -2,29 +2,27 @@ USING: kernel alien.syntax math sequences unix alien.c-types arrays accessors combinators ; IN: unix.stat -! Ubuntu 7.10 64-bit - +! stat64 C-STRUCT: stat - { "dev_t" "st_dev" } - { "ino_t" "st_ino" } - { "nlink_t" "st_nlink" } - { "mode_t" "st_mode" } - { "uid_t" "st_uid" } - { "gid_t" "st_gid" } - { "int" "pad0" } - { "dev_t" "st_rdev" } - { "off_t" "st_size" } - { "blksize_t" "st_blksize" } - { "blkcnt_t" "st_blocks" } - { "timespec" "st_atimespec" } - { "timespec" "st_mtimespec" } - { "timespec" "st_ctimespec" } - { "long" "__unused0" } - { "long" "__unused1" } - { "long" "__unused2" } ; + { "dev_t" "st_dev" } + { "ushort" "__pad1" } + { "__ino_t" "__st_ino" } + { "mode_t" "st_mode" } + { "nlink_t" "st_nlink" } + { "uid_t" "st_uid" } + { "gid_t" "st_gid" } + { "dev_t" "st_rdev" } + { { "ushort" 2 } "__pad2" } + { "off64_t" "st_size" } + { "blksize_t" "st_blksize" } + { "blkcnt64_t" "st_blocks" } + { "timespec" "st_atimespec" } + { "timespec" "st_mtimespec" } + { "timespec" "st_ctimespec" } + { "ulonglong" "st_ino" } ; -FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ; -FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ; +FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ; +FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ; -: stat ( pathname buf -- int ) [ 1 ] 2dip __xstat ; -: lstat ( pathname buf -- int ) [ 1 ] 2dip __lxstat ; +: stat ( pathname buf -- int ) [ 1 ] 2dip __xstat64 ; +: lstat ( pathname buf -- int ) [ 1 ] 2dip __lxstat64 ; diff --git a/basis/unix/types/linux/linux.factor b/basis/unix/types/linux/linux.factor index bf5d4b7f1d..b0340c1778 100644 --- a/basis/unix/types/linux/linux.factor +++ b/basis/unix/types/linux/linux.factor @@ -23,7 +23,11 @@ TYPEDEF: __slongword_type blkcnt_t TYPEDEF: __sword_type ssize_t TYPEDEF: __s32_type pid_t TYPEDEF: __slongword_type time_t +TYPEDEF: __slongword_type __time_t TYPEDEF: ssize_t __SWORD_TYPE +TYPEDEF: ulonglong blkcnt64_t TYPEDEF: ulonglong __fsblkcnt64_t TYPEDEF: ulonglong __fsfilcnt64_t +TYPEDEF: ulonglong ino64_t +TYPEDEF: ulonglong off64_t diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 10fb2ad64f..95dca2cb34 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -140,9 +140,11 @@ FUNCTION: int shutdown ( int fd, int how ) ; FUNCTION: int open ( char* path, int flags, int prot ) ; -FUNCTION: DIR* opendir ( char* path ) ; +HOOK: open-file os ( path flags mode -- fd ) -: open-file ( path flags mode -- fd ) [ open ] unix-system-call ; +M: unix open-file [ open ] unix-system-call ; + +FUNCTION: DIR* opendir ( char* path ) ; C-STRUCT: utimbuf { "time_t" "actime" } @@ -165,7 +167,6 @@ FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ; FUNCTION: dirent* readdir ( DIR* dirp ) ; FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ; - FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ; CONSTANT: PATH_MAX 1024 diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index 74238abed2..ccc28c00e9 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -2,7 +2,7 @@ USING: windows.dinput windows.kernel32 windows.ole32 windows.com windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces combinators sequences fry math accessors macros words quotations libc continuations generalizations splitting locals assocs init -struct-arrays ; +struct-arrays memoize ; IN: windows.dinput.constants ! Some global variables aren't provided by the DirectInput DLL (they're in the @@ -18,12 +18,15 @@ SYMBOLS: > [ name>> = ] with find nip ; + c-type* fields>> [ name>> = ] with find nip ; : (offsetof) ( field struct -- offset ) [ (field-spec-of) offset>> ] [ drop 0 ] if* ; : (sizeof) ( field struct -- size ) - [ (field-spec-of) type>> "[" split1 drop heap-size ] [ drop 1 ] if* ; + [ (field-spec-of) type>> "[" split1 drop heap-size* ] [ drop 1 ] if* ; : (flag) ( thing -- integer ) { @@ -79,6 +82,9 @@ SYMBOLS: [ nip length ] [ malloc-DIOBJECTDATAFORMAT-array ] 2bi "DIDATAFORMAT" (DIDATAFORMAT) ; +: initialize ( symbol quot -- ) + call swap set-global ; inline + : (malloc-guid-symbol) ( symbol guid -- ) '[ _ execute( -- value ) diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 062196c3f8..b99e7ffe6f 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! 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 ; +sequences math math.bitwise math.vectors colors +io.encodings.utf16n ; IN: windows.types TYPEDEF: char CHAR @@ -68,6 +69,8 @@ TYPEDEF: ulonglong ULARGE_INTEGER TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER +<< { "char*" utf16n } "wchar_t*" typedef >> + TYPEDEF: wchar_t* LPCSTR TYPEDEF: wchar_t* LPWSTR TYPEDEF: WCHAR TCHAR diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 57bc61a005..d94cd45c3d 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -211,7 +211,6 @@ bi "quotation" "quotations" create { { "array" { "array" "arrays" } read-only } - { "compiled" read-only } "cached-effect" "cache-counter" } define-builtin @@ -514,6 +513,7 @@ tuple { "reset-inline-cache-stats" "generic.single" (( -- )) } { "inline-cache-stats" "generic.single" (( -- stats )) } { "optimized?" "words" (( word -- ? )) } + { "quot-compiled?" "quotations" (( quot -- ? )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 4c91a519c6..ac3fbef8d0 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init kernel system namespaces io io.encodings -io.encodings.utf8 init assocs splitting alien io.streams.null ; +io.encodings.utf8 init assocs splitting alien ; IN: io.backend SYMBOL: io-backend @@ -12,22 +12,12 @@ io-backend [ c-io-backend ] initialize HOOK: init-io io-backend ( -- ) -HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ? ) +HOOK: init-stdio io-backend ( -- ) -: set-stdio ( input-handle output-handle error-handle -- ) - [ input-stream set-global ] - [ output-stream set-global ] - [ error-stream set-global ] tri* ; - -: init-stdio ( -- ) - (init-stdio) [ - [ utf8 ] - [ utf8 ] - [ utf8 ] tri* - ] [ - 3drop - null-reader null-writer null-writer - ] if set-stdio ; +: set-stdio ( input output error -- ) + [ utf8 input-stream set-global ] + [ utf8 output-stream set-global ] + [ utf8 error-stream set-global ] tri* ; HOOK: io-multiplex io-backend ( us -- ) diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index d3fd593a7b..7a7ac5a97c 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -60,12 +60,13 @@ M: c-io-backend init-io ; : stdout-handle ( -- alien ) 12 getenv ; : stderr-handle ( -- alien ) 61 getenv ; -: init-c-stdio ( -- stdin stdout stderr ) +: init-c-stdio ( -- ) stdin-handle stdout-handle - stderr-handle ; + stderr-handle + set-stdio ; -M: c-io-backend (init-stdio) init-c-stdio t ; +M: c-io-backend init-stdio init-c-stdio ; M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ; diff --git a/extra/bloom-filters/authors.txt b/extra/bloom-filters/authors.txt new file mode 100644 index 0000000000..528e5dfe6b --- /dev/null +++ b/extra/bloom-filters/authors.txt @@ -0,0 +1 @@ +Alec Berryman diff --git a/extra/bloom-filters/bloom-filters-docs.factor b/extra/bloom-filters/bloom-filters-docs.factor new file mode 100644 index 0000000000..bc5df8611c --- /dev/null +++ b/extra/bloom-filters/bloom-filters-docs.factor @@ -0,0 +1,38 @@ +USING: help.markup help.syntax kernel math ; +IN: bloom-filters + +HELP: +{ $values { "error-rate" "The desired false positive rate. A " { $link float } " between 0 and 1." } + { "number-objects" "The expected number of object in the set. A positive " { $link integer } "." } + { "bloom-filter" bloom-filter } } +{ $description "Creates an empty Bloom filter." } +{ $errors "Throws a " { $link capacity-error } " when unable to produce a filter meeting the given constraints. Throws a " { $link invalid-error-rate } " or a " { $link invalid-n-objects } " when input is invalid." } ; + + +HELP: bloom-filter-insert +{ $values { "object" object } + { "bloom-filter" bloom-filter } } +{ $description "Records the item as a member of the filter." } +{ $side-effects "bloom-filter" } ; + +HELP: bloom-filter-member? +{ $values { "object" object } + { "bloom-filter" bloom-filter } + { "?" boolean } } +{ $description "Returns " { $link t } " if the object may be a member of Bloom filter, " { $link f } " otherwise. The false positive rate is configurable; there are no false negatives." } ; + +HELP: bloom-filter +{ $class-description "This is the class for Bloom filters. These provide constant-time insertion and probabilistic membership-testing operations, but do not actually store any elements." } ; + +ARTICLE: "bloom-filters" "Bloom filters" +"This is a library for Bloom filters, sets that provide a constant-time insertion operation and probabilistic membership tests, but do not actually store any elements." +$nl +"The accuracy of the membership test is configurable; a Bloom filter will never incorrectly report an item is not a member of the set, but may incorrectly report than an item is a member of the set." +$nl +"Bloom filters cannot be resized and do not support removal." +$nl +{ $subsection } +{ $subsection bloom-filter-insert } +{ $subsection bloom-filter-member? } ; + +ABOUT: "bloom-filters" diff --git a/extra/bloom-filters/bloom-filters-tests.factor b/extra/bloom-filters/bloom-filters-tests.factor new file mode 100644 index 0000000000..6dce1c2ca9 --- /dev/null +++ b/extra/bloom-filters/bloom-filters-tests.factor @@ -0,0 +1,81 @@ +USING: accessors bit-arrays bloom-filters bloom-filters.private kernel layouts +math random sequences tools.test ; +IN: bloom-filters.tests + + +[ { 200 5 } ] [ { 100 7 } { 200 5 } smaller-second ] unit-test +[ { 200 5 } ] [ { 200 5 } { 100 7 } smaller-second ] unit-test + +! The sizing information was generated using the subroutine +! calculate_shortest_filter_length from +! http://www.perl.com/pub/a/2004/04/08/bloom_filters.html. + +! Test bloom-filter creation +[ 47965 ] [ 7 0.01 5000 bits-to-satisfy-error-rate ] unit-test +[ 7 47965 ] [ 0.01 5000 size-bloom-filter ] unit-test +[ 7 ] [ 0.01 5000 n-hashes>> ] unit-test +[ 47965 ] [ 0.01 5000 bits>> length ] unit-test +[ 5000 ] [ 0.01 5000 maximum-n-objects>> ] unit-test +[ 0 ] [ 0.01 5000 current-n-objects>> ] unit-test + +! Should return the fewest hashes to satisfy the bits requested, not the most. +[ 32 ] [ 4 0.05 5 bits-to-satisfy-error-rate ] unit-test +[ 32 ] [ 5 0.05 5 bits-to-satisfy-error-rate ] unit-test +[ 4 32 ] [ 0.05 5 size-bloom-filter ] unit-test + +! This is a lot of bits. +: oversized-filter-params ( -- error-rate n-objects ) + 0.00000001 400000000000000 ; +! [ oversized-filter-params size-bloom-filter ] [ capacity-error? ] must-fail-with +! [ oversized-filter-params ] [ capacity-error? ] must-fail-with + +! Other error conditions. +[ 1.0 2000 ] [ invalid-error-rate? ] must-fail-with +[ 20 2000 ] [ invalid-error-rate? ] must-fail-with +[ 0.0 2000 ] [ invalid-error-rate? ] must-fail-with +[ -2 2000 ] [ invalid-error-rate? ] must-fail-with +[ 0.5 0 ] [ invalid-n-objects? ] must-fail-with +[ 0.5 -5 ] [ invalid-n-objects? ] must-fail-with + +! Should not generate bignum hash codes. Enhanced double hashing may generate a +! lot of hash codes, and it's better to do this earlier than later. +[ t ] [ 10000 iota [ hashcodes-from-object [ fixnum? ] both? ] map [ ] all? ] unit-test + +[ ?{ t f t f t f } ] [ { 0 2 4 } 6 [ set-indices ] keep ] unit-test + +: empty-bloom-filter ( -- bloom-filter ) + 0.01 2000 ; + +[ 1 ] [ empty-bloom-filter dup increment-n-objects current-n-objects>> ] unit-test + +: basic-insert-test-setup ( -- bloom-filter ) + 1 empty-bloom-filter [ bloom-filter-insert ] keep ; + +! Basic tests that insert does something +[ t ] [ basic-insert-test-setup bits>> [ ] any? ] unit-test +[ 1 ] [ basic-insert-test-setup current-n-objects>> ] unit-test + +: non-empty-bloom-filter ( -- bloom-filter ) + 1000 iota + empty-bloom-filter + [ [ bloom-filter-insert ] curry each ] keep ; + +: full-bloom-filter ( -- bloom-filter ) + 2000 iota + empty-bloom-filter + [ [ bloom-filter-insert ] curry each ] keep ; + +! Should find what we put in there. +[ t ] [ 2000 iota + full-bloom-filter + [ bloom-filter-member? ] curry map + [ ] all? ] unit-test + +! We shouldn't have more than 0.01 false-positive rate. +[ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map + full-bloom-filter + [ bloom-filter-member? ] curry map + [ ] filter + ! TODO: This should be 10, but the false positive rate is currently very + ! high. It shouldn't be much more than this. + length 150 <= ] unit-test diff --git a/extra/bloom-filters/bloom-filters.factor b/extra/bloom-filters/bloom-filters.factor new file mode 100644 index 0000000000..308d10ad84 --- /dev/null +++ b/extra/bloom-filters/bloom-filters.factor @@ -0,0 +1,158 @@ +! Copyright (C) 2009 Alec Berryman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays bit-arrays fry infix kernel layouts locals math +math.functions multiline sequences ; +IN: bloom-filters + +FROM: math.ranges => [1,b] [0,b) ; +FROM: math.intervals => (a,b) interval-contains? ; + +/* + +TODO: + +- The false positive rate is 10x what it should be, based on informal testing. + Better object hashes or a better method of generating extra hash codes would + help. Another way is to increase the number of bits used. + + - Try something smarter than the bitwise complement for a second hash code. + + - http://spyced.blogspot.com/2009/01/all-you-ever-wanted-to-know-about.html + makes a case for http://murmurhash.googlepages.com/ instead of enhanced + double-hashing. + + - Be sure to adjust the test that asserts the number of false positives isn't + unreasonable. + +- Could round bits up to next power of two and use wrap instead of mod. This + would cost a lot of bits on 32-bit platforms, though, and limit the bit-array + to 8MB. + +- Should allow user to specify the hash codes, either as inputs to enhanced + double hashing or for direct use. + +- Support for serialization. + +- Wrappers for combining filters. + +- Should we signal an error when inserting past the number of objects the filter + is sized for? The filter will continue to work, just not very well. + +*/ + +TUPLE: bloom-filter +{ n-hashes fixnum read-only } +{ bits bit-array read-only } +{ maximum-n-objects fixnum read-only } +{ current-n-objects fixnum } ; + +ERROR: capacity-error ; +ERROR: invalid-error-rate ; +ERROR: invalid-n-objects ; + +integer ; + +! 100 hashes ought to be enough for anybody. +: n-hashes-range ( -- range ) + 100 [1,b] ; + +! { n-hashes n-bits } +: identity-configuration ( -- 2seq ) + 0 max-array-capacity 2array ; + +: smaller-second ( 2seq 2seq -- 2seq ) + [ [ second ] bi@ <= ] most ; + +! If the number of hashes isn't positive, we haven't found anything smaller than the +! identity configuration. +: validate-sizes ( 2seq -- ) + first 0 <= [ capacity-error ] when ; + +! The consensus on the tradeoff between increasing the number of bits and +! increasing the number of hash functions seems to be "go for the smallest +! number of bits", probably because most implementations just generate one hash +! value and cheaply mangle it into the number of hashes they need. I have not +! seen any usage studies from the implementations that made this tradeoff to +! support it, and I haven't done my own, but we'll go with it anyway. +! +: size-bloom-filter ( error-rate number-objects -- number-hashes number-bits ) + [ n-hashes-range identity-configuration ] 2dip + '[ dup [ _ _ bits-to-satisfy-error-rate ] + call 2array smaller-second ] + reduce + dup validate-sizes + first2 ; + +: validate-n-objects ( n-objects -- ) + 0 <= [ invalid-n-objects ] when ; + +: valid-error-rate-interval ( -- interval ) + 0 1 (a,b) ; + +: validate-error-rate ( error-rate -- ) + valid-error-rate-interval interval-contains? + [ invalid-error-rate ] unless ; + +: validate-constraints ( error-rate n-objects -- ) + validate-n-objects validate-error-rate ; + +PRIVATE> + +: ( error-rate number-objects -- bloom-filter ) + [ validate-constraints ] 2keep + [ size-bloom-filter ] keep + 0 ! initially empty + bloom-filter boa ; + +fixnum bitxor ; + +: hashcodes-from-object ( obj -- n n ) + hashcode abs hashcodes-from-hashcode ; + +: set-indices ( indices bit-array -- ) + [ [ drop t ] change-nth ] curry each ; + +: increment-n-objects ( bloom-filter -- ) + [ 1 + ] change-current-n-objects drop ; + +: n-hashes-and-length ( bloom-filter -- n-hashes length ) + [ n-hashes>> ] [ bits>> length ] bi ; + +: relevant-indices ( value bloom-filter -- indices ) + [ hashcodes-from-object ] [ n-hashes-and-length ] bi* + [ enhanced-double-hashes ] dip '[ _ mod ] map ; + +PRIVATE> + +: bloom-filter-insert ( object bloom-filter -- ) + [ increment-n-objects ] + [ relevant-indices ] + [ bits>> set-indices ] + tri ; + +: bloom-filter-member? ( object bloom-filter -- ? ) + [ relevant-indices ] keep + bits>> nths [ ] all? ; diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor index 96cde41c2b..9f1d8c31d2 100644 --- a/extra/bson/reader/reader.factor +++ b/extra/bson/reader/reader.factor @@ -181,19 +181,16 @@ M: bson-oid element-data-read ( type -- oid ) read-longlong read-int32 oid boa ; -M: bson-binary-custom element-binary-read ( size type -- dbref ) - 2drop - read-cstring - read-cstring objref boa ; - M: bson-binary-bytes element-binary-read ( size type -- bytes ) drop read ; -M: bson-binary-function element-binary-read ( size type -- quot ) +M: bson-binary-custom element-binary-read ( size type -- quot ) drop read bytes>object ; PRIVATE> +USE: tools.continuations + : stream>assoc ( exemplar -- assoc bytes-read ) dup state [ read-int32 >>size read-elements ] with-variable diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor index 1b9d45b124..682257558f 100644 --- a/extra/bson/writer/writer.factor +++ b/extra/bson/writer/writer.factor @@ -62,7 +62,6 @@ M: t bson-type? ( boolean -- type ) drop T_Boolean ; M: f bson-type? ( boolean -- type ) drop T_Boolean ; M: real bson-type? ( real -- type ) drop T_Double ; -M: word bson-type? ( word -- type ) drop T_String ; M: tuple bson-type? ( tuple -- type ) drop T_Object ; M: sequence bson-type? ( seq -- type ) drop T_Array ; M: string bson-type? ( string -- type ) drop T_String ; @@ -73,6 +72,7 @@ M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ; M: oid bson-type? ( word -- type ) drop T_OID ; M: objref bson-type? ( objref -- type ) drop T_Binary ; +M: word bson-type? ( word -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; @@ -112,21 +112,8 @@ M: byte-array bson-write ( binary -- ) T_Binary_Bytes write-byte write ; -M: quotation bson-write ( quotation -- ) - object>bytes [ length write-int32 ] keep - T_Binary_Function write-byte - write ; - M: oid bson-write ( oid -- ) [ a>> write-longlong ] [ b>> write-int32 ] bi ; - -M: objref bson-write ( objref -- ) - [ binary ] dip - '[ _ - [ ns>> write-cstring ] - [ objid>> write-cstring ] bi ] with-byte-writer - [ length write-int32 ] keep - T_Binary_Custom write-byte write ; M: mdbregexp bson-write ( regexp -- ) [ regexp>> write-cstring ] @@ -149,7 +136,16 @@ M: assoc bson-write ( assoc -- ) [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each write-eoo ] with-length-prefix ; -M: word bson-write name>> bson-write ; +: (serialize-code) ( code -- ) + object>bytes [ length write-int32 ] keep + T_Binary_Custom write-byte + write ; + +M: quotation bson-write ( quotation -- ) + (serialize-code) ; + +M: word bson-write ( word -- ) + (serialize-code) ; PRIVATE> diff --git a/extra/game-input/game-input-tests.factor b/extra/game-input/game-input-tests.factor index 2bf923c12b..3cce0da575 100644 --- a/extra/game-input/game-input-tests.factor +++ b/extra/game-input/game-input-tests.factor @@ -1,11 +1,7 @@ IN: game-input.tests -USING: ui game-input tools.test kernel system threads -combinators.short-circuit calendar ; +USING: ui game-input tools.test kernel system threads calendar ; -{ - [ os windows? ui-running? and ] - [ os macosx? ] -} 0|| [ +os windows? os macosx? or [ [ ] [ open-game-input ] unit-test [ ] [ 1 seconds sleep ] unit-test [ ] [ close-game-input ] unit-test diff --git a/extra/game-worlds/game-worlds.factor b/extra/game-worlds/game-worlds.factor index fa6b326fa9..c9ea03e333 100644 --- a/extra/game-worlds/game-worlds.factor +++ b/extra/game-worlds/game-worlds.factor @@ -21,5 +21,3 @@ M: game-world end-world [ [ stop-loop ] when* f ] change-game-loop drop ; -M: game-world focusable-child* drop t ; - diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor index 7fcc167cea..784c34cf70 100644 --- a/extra/hello-ui/deploy.factor +++ b/extra/hello-ui/deploy.factor @@ -1,14 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-ui? t } - { deploy-reflection 1 } - { deploy-unicode? f } - { deploy-math? t } - { deploy-io 2 } { deploy-c-types? f } - { deploy-name "Hello world" } - { deploy-word-props? f } + { deploy-unicode? f } { deploy-word-defs? f } + { deploy-name "Hello world" } { "stop-after-last-window?" t } + { deploy-reflection 1 } + { deploy-ui? t } + { deploy-math? t } + { deploy-io 1 } + { deploy-word-props? f } { deploy-threads? t } } diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index b7545a3c9e..a743c3fe9a 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -10,18 +10,6 @@ IN: mason.common SYMBOL: current-git-id -ERROR: output-process-error { output string } { process process } ; - -M: output-process-error error. - [ "Process:" print process>> . nl ] - [ "Output:" print output>> print ] - bi ; - -: try-output-process ( command -- ) - >process +stdout+ >>stderr utf8 - [ stream-contents ] [ dup wait-for-process ] bi* - 0 = [ 2drop ] [ output-process-error ] if ; - HOOK: really-delete-tree os ( path -- ) M: windows really-delete-tree diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index c75014e1b0..6c643d64d5 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -16,8 +16,8 @@ IN: mason.notify ] { } make prepend [ 5 ] 2dip '[ - _ >>command _ [ +closed+ ] unless* >>stdin + _ >>command try-output-process ] retry ] [ 2drop ] if ; @@ -47,4 +47,4 @@ IN: mason.notify ] bi ; : notify-release ( archive-name -- ) - "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ; \ No newline at end of file + "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ; diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor index 1bd2d94e69..60b2d25764 100644 --- a/extra/mongodb/tuple/collection/collection.factor +++ b/extra/mongodb/tuple/collection/collection.factor @@ -92,6 +92,8 @@ GENERIC: mdb-index-map ( tuple -- sequence ) [ ] [ name>> ] bi H{ } clone [ set-at ] keep ] [ 2drop H{ } clone ] if ; + + PRIVATE> : MDB_ADDON_SLOTS ( -- slots ) @@ -116,7 +118,7 @@ PRIVATE> [ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline : set-index-map ( class index-list -- ) - [ [ dup user-defined-key-index ] dip index-list>map ] output>sequence + [ dup user-defined-key-index ] dip index-list>map 2array assoc-combine MDB_INDEX_MAP set-word-prop ; inline M: tuple-class tuple-collection ( tuple -- mdb-collection ) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index 9173957979..677fa09bf9 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -54,19 +54,30 @@ M: mdb-persistent id-selector >upsert update ] assoc-each ; inline PRIVATE> -: save-tuple ( tuple -- ) - tuple>storable [ (save-tuples) ] assoc-each ; +: save-tuple-deep ( tuple -- ) + tuple>storable [ (save-tuples) ] assoc-each ; : update-tuple ( tuple -- ) - save-tuple ; + [ tuple-collection name>> ] + [ id-selector ] + [ tuple>assoc ] tri + update ; + +: save-tuple ( tuple -- ) + update-tuple ; : insert-tuple ( tuple -- ) - save-tuple ; + [ tuple-collection name>> ] + [ tuple>assoc ] bi + save ; : delete-tuple ( tuple -- ) [ tuple-collection name>> ] keep id-selector delete ; +: delete-tuples ( seq -- ) + [ delete-tuple ] each ; + : tuple>query ( tuple -- query ) [ tuple-collection name>> ] keep tuple>selector ; diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 8afbd52647..e627a745cd 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -36,9 +36,6 @@ M: demo-world distance-step ( gadget -- dz ) : zoom-demo-world ( distance gadget -- ) [ + ] with change-distance relayout-1 ; -M: demo-world focusable-child* ( world -- gadget ) - drop t ; - M: demo-world pref-dim* ( gadget -- dim ) drop { 640 480 } ; diff --git a/extra/spheres/deploy.factor b/extra/spheres/deploy.factor index df314317cf..8c72e4a26c 100644 --- a/extra/spheres/deploy.factor +++ b/extra/spheres/deploy.factor @@ -1,14 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-ui? t } - { deploy-reflection 1 } - { deploy-unicode? f } - { deploy-math? t } - { deploy-io 2 } { deploy-c-types? f } - { deploy-name "Spheres" } - { deploy-word-props? f } + { deploy-unicode? f } { deploy-word-defs? f } + { deploy-name "Spheres" } { "stop-after-last-window?" t } + { deploy-reflection 1 } + { deploy-ui? t } + { deploy-math? t } + { deploy-io 1 } + { deploy-word-props? f } { deploy-threads? t } } diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index bfb46b8ba1..e5b517ad59 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/extra/terrain/shaders/shaders.factor @@ -8,11 +8,14 @@ varying vec3 direction; void main() { - vec4 v = vec4(gl_Vertex.xy, -1.0, 1.0); + vec4 v = vec4(gl_Vertex.xy, 1.0, 1.0); gl_Position = v; + + vec4 p = (gl_ProjectionMatrixInverse * v) * vec4(1,1,-1,1); + float s = sin(sky_theta), c = cos(sky_theta); direction = mat3(1, 0, 0, 0, c, s, 0, -s, c) - * (gl_ModelViewMatrixInverse * vec4(v.xyz, 0.0)).xyz; + * (gl_ModelViewMatrixInverse * vec4(p.xyz, 0.0)).xyz; } ; diff --git a/vm/code_block.cpp b/vm/code_block.cpp index c34f651750..2ce69ebfde 100755 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -68,10 +68,10 @@ static void *xt_pic(word *w, cell tagged_quot) else { quotation *quot = untag(tagged_quot); - if(quot->compiledp == F) - return w->xt; - else + if(quot->code) return quot->xt; + else + return w->xt; } } @@ -409,7 +409,7 @@ void mark_object_code_block(object *object) case QUOTATION_TYPE: { quotation *q = (quotation *)object; - if(q->compiledp != F) + if(q->code) mark_code_block(q->code); break; } diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index c8c7639930..2260d133fc 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -158,7 +158,7 @@ void forward_object_xts() { quotation *quot = untag(obj); - if(quot->compiledp != F) + if(quot->code) quot->code = forward_xt(quot->code); } break; @@ -194,7 +194,7 @@ void fixup_object_xts() case QUOTATION_TYPE: { quotation *quot = untag(obj); - if(quot->compiledp != F) + if(quot->code) set_quot_xt(quot,quot->code); break; } diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index a372b2b1f5..964882c8ae 100755 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -45,7 +45,7 @@ multiply_overflow: /* Note that the XT is passed to the quotation in r11 */ #define CALL_OR_JUMP_QUOT \ - lwz r11,16(r3) /* load quotation-xt slot */ XX \ + lwz r11,12(r3) /* load quotation-xt slot */ XX \ #define CALL_QUOT \ CALL_OR_JUMP_QUOT XX \ diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index ff45f48066..afda9d31cd 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -25,7 +25,7 @@ pop %ebp ; \ pop %ebx -#define QUOT_XT_OFFSET 16 +#define QUOT_XT_OFFSET 12 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 6b2faa1c0b..8cf7423239 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -61,7 +61,7 @@ #endif -#define QUOT_XT_OFFSET 36 +#define QUOT_XT_OFFSET 28 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative diff --git a/vm/image.cpp b/vm/image.cpp index 9205aad260..f8aa07ded9 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -187,13 +187,13 @@ static void fixup_word(word *word) static void fixup_quotation(quotation *quot) { - if(quot->compiledp == F) - quot->xt = (void *)lazy_jit_compile; - else + if(quot->code) { code_fixup("->xt); code_fixup("->code); } + else + quot->xt = (void *)lazy_jit_compile; } static void fixup_alien(alien *d) diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 40fd699e18..f8672e4522 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -269,8 +269,6 @@ struct quotation : public object { /* tagged */ cell array; /* tagged */ - cell compiledp; - /* tagged */ cell cached_effect; /* tagged */ cell cache_counter; diff --git a/vm/primitives.cpp b/vm/primitives.cpp index bd761625d8..2359173d9b 100755 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -155,6 +155,7 @@ const primitive_type primitives[] = { primitive_reset_inline_cache_stats, primitive_inline_cache_stats, primitive_optimized_p, + primitive_quot_compiled_p, }; } diff --git a/vm/quotations.cpp b/vm/quotations.cpp index b049f528e4..e96af39766 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -272,14 +272,13 @@ void set_quot_xt(quotation *quot, code_block *code) quot->code = code; quot->xt = code->xt(); - quot->compiledp = T; } /* Allocates memory */ void jit_compile(cell quot_, bool relocating) { gc_root quot(quot_); - if(quot->compiledp != F) return; + if(quot->code) return; quotation_jit compiler(quot.value(),true,relocating); compiler.iterate_quotation(); @@ -300,10 +299,10 @@ PRIMITIVE(array_to_quotation) { quotation *quot = allot(sizeof(quotation)); quot->array = dpeek(); - quot->xt = (void *)lazy_jit_compile; - quot->compiledp = F; quot->cached_effect = F; quot->cache_counter = F; + quot->xt = (void *)lazy_jit_compile; + quot->code = NULL; drepl(tag(quot)); } @@ -354,4 +353,11 @@ VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack) return quot.value(); } +PRIMITIVE(quot_compiled_p) +{ + tagged quot(dpop()); + quot.untag_check(); + dpush(tag_boolean(quot->code != NULL)); +} + } diff --git a/vm/quotations.hpp b/vm/quotations.hpp index 719a94176e..c1a2a92bd1 100755 --- a/vm/quotations.hpp +++ b/vm/quotations.hpp @@ -35,4 +35,6 @@ PRIMITIVE(quotation_xt); VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack); +PRIMITIVE(quot_compiled_p); + }