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

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

db4
John Benediktsson 2009-05-12 07:31:12 -07:00
parent ac523051ec 5a8e7d1c76
commit f0129799ca
66 changed files with 680 additions and 241 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
basis/alien/arrays/arrays.factor
View File

@ -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

1
basis/bootstrap/image/image.factor
View File

@ -448,7 +448,6 @@ M: quotation '
array>> '
quotation [
emit ! array
f ' emit ! compiled
f ' emit ! cached-effect
f ' emit ! cache-counter
0 emit ! xt

12
basis/bootstrap/stage2.factor
View File

@ -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

2
basis/compiler/constants/constants.factor
View File

@ -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

5
basis/io/backend/unix/unix.factor
View File

@ -173,10 +173,11 @@ M: stdin refill
size-read-fd <fd> init-fd <input-port> >>size
data-read-fd <fd> >>data ;
M: unix (init-stdio)
M: unix init-stdio
<stdin> <input-port>
1 <fd> <output-port>
2 <fd> <output-port> t ;
2 <fd> <output-port>
set-stdio ;
! mx io-task for embedding an fd-based mx inside another mx
TUPLE: mx-port < port mx ;

18
basis/io/backend/windows/nt/nt.factor
View File

@ -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

10
basis/io/directories/unix/linux/linux.factor Normal file
View File

@ -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" <c-object>
f <void*>
[ readdir64_r 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;

1
basis/io/directories/unix/linux/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

12
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 ;
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" <c-object>
f <void*>
[ 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_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

5
basis/io/files/info/info.factor
View File

@ -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 )

27
basis/io/launcher/launcher.factor
View File

@ -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 <process-reader*>
[ 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

0
core/io/streams/null/authors.txt → basis/io/streams/null/authors.txt
View File

0
core/io/streams/null/null-docs.factor → basis/io/streams/null/null-docs.factor
View File

0
core/io/streams/null/null.factor → basis/io/streams/null/null.factor
View File

0
core/io/streams/null/summary.txt → basis/io/streams/null/summary.txt
View File

2
basis/struct-arrays/struct-arrays.factor
View File

@ -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 <direct-struct-array> ;
[ heap-size calloc ] 2keep <direct-struct-array> ; inline
INSTANCE: struct-array sequence

4
basis/tools/deploy/deploy-tests.factor
View File

@ -98,3 +98,7 @@ M: quit-responder call-responder*
run-temp-image
] curry unit-test
] each
os windows? os macosx? or [
[ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test
] when

61
basis/tools/deploy/shaker/shaker.factor
View File

@ -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

21
basis/tools/deploy/test/8/8.factor Normal file
View File

@ -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

14
basis/tools/deploy/test/8/deploy.factor Normal file
View File

@ -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 }
}

9
basis/tools/deploy/test/test.factor
View File

@ -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
<process> swap >>command +closed+ >>stdin try-process ;
os macosx?
"resource:Factor.app/Contents/MacOS/factor" normalize-path vm ?
"-i=" "test.image" temp-file append 2array try-output-process ;

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

@ -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 ;

19
basis/ui/debugger/debugger.factor Executable file
View File

@ -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> ( error -- pane )
<pane> [ [ print-error ] with-pane ] keep ; inline
: error-window ( error -- )
<error-pane> "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. ;

2
basis/ui/gadgets/presentations/presentations.factor Normal file → Executable file
View File

@ -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 ;

12
basis/ui/gadgets/worlds/worlds-docs.factor
View File

@ -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." }
}

22
basis/ui/gadgets/worlds/worlds.factor
View File

@ -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>> ;

2
basis/ui/operations/operations.factor Normal file → Executable file
View File

@ -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+

11
basis/ui/tools/debugger/debugger.factor Normal file → Executable file
View File

@ -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> ( error -- pane )
<pane> [ [ print-error ] with-pane ] keep ; inline
: <error-display> ( debugger -- gadget )
[ <filled-pile> ] dip
[ error>> <error-pane> 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

4
basis/ui/ui-docs.factor
View File

@ -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." } ;

24
basis/ui/ui.factor
View File

@ -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 ]
[
[ [ title>> ] keep set-title ]
[ begin-world ]
[ [ handle>> (close-window) ] [ ui-error ] bi* ]
recover
]
[ 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

13
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 ;
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

25
basis/unix/stat/linux/32/32.factor
View File

@ -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" }
{ "__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" }
{ { "ushort" 2 } "__pad2" }
{ "off64_t" "st_size" }
{ "blksize_t" "st_blksize" }
{ "blkcnt_t" "st_blocks" }
{ "blkcnt64_t" "st_blocks" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
{ "ulong" "unused4" }
{ "ulong" "unused5" } ;
{ "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 ;

26
basis/unix/stat/linux/64/64.factor
View File

@ -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" }
{ "ushort" "__pad1" }
{ "__ino_t" "__st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "int" "pad0" }
{ "dev_t" "st_rdev" }
{ "off_t" "st_size" }
{ { "ushort" 2 } "__pad2" }
{ "off64_t" "st_size" }
{ "blksize_t" "st_blksize" }
{ "blkcnt_t" "st_blocks" }
{ "blkcnt64_t" "st_blocks" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
{ "long" "__unused0" }
{ "long" "__unused1" }
{ "long" "__unused2" } ;
{ "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 ;

4
basis/unix/types/linux/linux.factor
View File

@ -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

7
basis/unix/unix.factor
View File

@ -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

12
basis/windows/dinput/constants/constants.factor
View File

@ -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:
<PRIVATE
MEMO: c-type* ( name -- c-type ) c-type ;
MEMO: heap-size* ( c-type -- n ) heap-size ;
: (field-spec-of) ( field struct -- field-spec )
c-type fields>> [ 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" <c-object> (DIDATAFORMAT) ;
: initialize ( symbol quot -- )
call swap set-global ; inline
: (malloc-guid-symbol) ( symbol guid -- )
'[
_ execute( -- value )

5
basis/windows/types/types.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.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

2
core/bootstrap/primitives.factor
View File

@ -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

22
core/io/backend/backend.factor
View File

@ -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 <decoder> ]
[ utf8 <encoder> ]
[ utf8 <encoder> ] tri*
] [
3drop
null-reader null-writer null-writer
] if set-stdio ;
: set-stdio ( input output error -- )
[ utf8 <decoder> input-stream set-global ]
[ utf8 <encoder> output-stream set-global ]
[ utf8 <encoder> error-stream set-global ] tri* ;
HOOK: io-multiplex io-backend ( us -- )

7
core/io/streams/c/c.factor
View File

@ -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 <c-reader>
stdout-handle <c-writer>
stderr-handle <c-writer> ;
stderr-handle <c-writer>
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) ;

1
extra/bloom-filters/authors.txt Normal file
View File

@ -0,0 +1 @@
Alec Berryman

38
extra/bloom-filters/bloom-filters-docs.factor Normal file
View File

@ -0,0 +1,38 @@
USING: help.markup help.syntax kernel math ;
IN: bloom-filters
HELP: <bloom-filter>
{ $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 <bloom-filter> }
{ $subsection bloom-filter-insert }
{ $subsection bloom-filter-member? } ;
ABOUT: "bloom-filters"

81
extra/bloom-filters/bloom-filters-tests.factor Normal file
View File

@ -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 <bloom-filter> n-hashes>> ] unit-test
[ 47965 ] [ 0.01 5000 <bloom-filter> bits>> length ] unit-test
[ 5000 ] [ 0.01 5000 <bloom-filter> maximum-n-objects>> ] unit-test
[ 0 ] [ 0.01 5000 <bloom-filter> 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 <bloom-filter> ] [ capacity-error? ] must-fail-with
! Other error conditions.
[ 1.0 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
[ 20 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
[ 0.0 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
[ -2 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
[ 0.5 0 <bloom-filter> ] [ invalid-n-objects? ] must-fail-with
[ 0.5 -5 <bloom-filter> ] [ 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 <bit-array> [ set-indices ] keep ] unit-test
: empty-bloom-filter ( -- bloom-filter )
0.01 2000 <bloom-filter> ;
[ 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

158
extra/bloom-filters/bloom-filters.factor Normal file
View File

@ -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 ;
<PRIVATE
! infix doesn't like ^
: pow ( x y -- z )
^ ; inline
:: bits-to-satisfy-error-rate ( hashes error objects -- size )
[infix -(objects * hashes) / log(1 - pow(error, (1/hashes))) infix]
ceiling >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>
: <bloom-filter> ( error-rate number-objects -- bloom-filter )
[ validate-constraints ] 2keep
[ size-bloom-filter <bit-array> ] keep
0 ! initially empty
bloom-filter boa ;
<PRIVATE
! See "Bloom Filters in Probabilistic Verification" by Peter C. Dillinger and
! Panagiotis Manolios, section 5.2, "Enhanced Double Hashing":
! http://www.cc.gatech.edu/~manolios/research/bloom-filters-verification.html
:: enhanced-double-hash ( index hash0 hash1 -- hash )
[infix hash0 + (index * hash1) + ((pow(index, 3) - index) / 6) infix] ;
: enhanced-double-hashes ( hash0 hash1 n -- seq )
[0,b)
[ '[ _ _ enhanced-double-hash ] ] dip
swap map ;
! Make sure it's a fixnum here to speed up double-hashing.
: hashcodes-from-hashcode ( n -- n n )
dup most-positive-fixnum >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? ;

9
extra/bson/reader/reader.factor
View File

@ -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 )
<state> dup state
[ read-int32 >>size read-elements ] with-variable

26
extra/bson/writer/writer.factor
View File

@ -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,22 +112,9 @@ 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 ]
[ options>> write-cstring ] bi ;
@ -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>

8
extra/game-input/game-input-tests.factor
View File

@ -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

2
extra/game-worlds/game-worlds.factor
View File

@ -21,5 +21,3 @@ M: game-world end-world
[ [ stop-loop ] when* f ] change-game-loop
drop ;
M: game-world focusable-child* drop t ;

14
extra/hello-ui/deploy.factor
View File

@ -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 }
}

12
extra/mason/common/common.factor
View File

@ -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 <process-reader*>
[ stream-contents ] [ dup wait-for-process ] bi*
0 = [ 2drop ] [ output-process-error ] if ;
HOOK: really-delete-tree os ( path -- )
M: windows really-delete-tree

2
extra/mason/notify/notify.factor
View File

@ -16,8 +16,8 @@ IN: mason.notify
] { } make prepend
[ 5 ] 2dip '[
<process>
_ >>command
_ [ +closed+ ] unless* >>stdin
_ >>command
try-output-process
] retry
] [ 2drop ] if ;

4
extra/mongodb/tuple/collection/collection.factor
View File

@ -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 )

17
extra/mongodb/tuple/tuple.factor
View File

@ -54,19 +54,30 @@ M: mdb-persistent id-selector
<update> >upsert update ] assoc-each ; inline
PRIVATE>
: save-tuple ( tuple -- )
: save-tuple-deep ( tuple -- )
tuple>storable [ (save-tuples) ] assoc-each ;
: update-tuple ( tuple -- )
save-tuple ;
[ tuple-collection name>> ]
[ id-selector ]
[ tuple>assoc ] tri
<update> 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 <query> ;

3
extra/opengl/demo-support/demo-support.factor
View File

@ -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 } ;

14
extra/spheres/deploy.factor
View File

@ -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 }
}

7
extra/terrain/shaders/shaders.factor
View File

@ -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;
}
;

8
vm/code_block.cpp
View File

@ -68,10 +68,10 @@ static void *xt_pic(word *w, cell tagged_quot)
else
{
quotation *quot = untag<quotation>(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;
}

4
vm/code_heap.cpp
View File

@ -158,7 +158,7 @@ void forward_object_xts()
{
quotation *quot = untag<quotation>(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<quotation>(obj);
if(quot->compiledp != F)
if(quot->code)
set_quot_xt(quot,quot->code);
break;
}

2
vm/cpu-ppc.S
View File

@ -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 \

2
vm/cpu-x86.32.S
View File

@ -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

2
vm/cpu-x86.64.S
View File

@ -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

6
vm/image.cpp
View File

@ -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(&quot->xt);
code_fixup(&quot->code);
}
else
quot->xt = (void *)lazy_jit_compile;
}
static void fixup_alien(alien *d)

2
vm/layouts.hpp
View File

@ -269,8 +269,6 @@ struct quotation : public object {
/* tagged */
cell array;
/* tagged */
cell compiledp;
/* tagged */
cell cached_effect;
/* tagged */
cell cache_counter;

1
vm/primitives.cpp
View File

@ -155,6 +155,7 @@ const primitive_type primitives[] = {
primitive_reset_inline_cache_stats,
primitive_inline_cache_stats,
primitive_optimized_p,
primitive_quot_compiled_p,
};
}

14
vm/quotations.cpp
View File

@ -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<quotation> 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<quotation>(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<quotation>(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<quotation> quot(dpop());
quot.untag_check();
dpush(tag_boolean(quot->code != NULL));
}
}

2
vm/quotations.hpp
View File

@ -35,4 +35,6 @@ PRIMITIVE(quotation_xt);
VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack);
PRIMITIVE(quot_compiled_p);
}