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

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

release
Eduardo Cavazos 2007-11-21 06:52:49 -06:00
parent ddf932efd4 0714bb7a86
commit 9b2dd5de1a
25 changed files with 281 additions and 245 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

0
core/alien/c-types/c-types.factor Normal file → Executable file
View File

5
core/alien/compiler/compiler.factor
View File

@ -5,7 +5,8 @@ hashtables kernel math namespaces sequences words
inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators ;
kernel.private threads continuations.private libc combinators
init ;
IN: alien.compiler
! Common protocol for alien-invoke/alien-callback/alien-indirect
@ -301,7 +302,7 @@ M: alien-indirect generate-node
! this hashtable, they will all be blown away by code GC, beware
SYMBOL: callbacks
H{ } clone callbacks set-global
[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
: register-callback ( word -- ) dup callbacks get set-at ;

4
core/combinators/combinators.factor Normal file → Executable file
View File

@ -38,9 +38,7 @@ TUPLE: no-case ;
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
M: sequence hashcode*
[
0 -rot [ hashcode* bitxor ] curry* each
] recursive-hashcode ;
[ sequence-hashcode ] recursive-hashcode ;
: alist>quot ( default assoc -- quot )
[ rot \ if 3array append [ ] like ] assoc-each ;

0
core/io/io.factor Normal file → Executable file
View File

8
core/io/streams/lines/lines-tests.factor Normal file → Executable file
View File

@ -41,6 +41,14 @@ unit-test
4 swap stream-read
] unit-test
[
"1234"
] [
"Hello world\r\n1234" <string-reader>
dup stream-readln drop
4 swap stream-read-partial
] unit-test
[
CHAR: 1
] [

23
core/io/streams/lines/lines.factor Normal file → Executable file
View File

@ -32,15 +32,26 @@ M: line-reader stream-readln ( stream -- str )
"\r\n" over delegate stream-read-until handle-readln ;
: fix-read ( stream string -- string )
"\n" ?head [ swap stream-read1 [ add ] when* ] [ nip ] if ;
over line-reader-cr [
over cr-
"\n" ?head [
swap stream-read1 [ add ] when*
] [ nip ] if
] [ nip ] if ;
M: line-reader stream-read
tuck delegate stream-read
over line-reader-cr [ over cr- fix-read ] [ nip ] if ;
tuck delegate stream-read fix-read ;
M: line-reader stream-read-partial
tuck delegate stream-read-partial fix-read ;
: fix-read1 ( stream char -- char )
dup CHAR: \n = [ drop stream-read1 ] [ nip ] if ;
over line-reader-cr [
over cr-
dup CHAR: \n = [
drop stream-read1
] [ nip ] if
] [ nip ] if ;
M: line-reader stream-read1 ( stream -- char )
dup delegate stream-read1
over line-reader-cr [ over cr- fix-read1 ] [ nip ] if ;
dup delegate stream-read1 fix-read1 ;

7
core/sequences/sequences.factor
View File

@ -44,7 +44,7 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
TUPLE: bounds-error index seq ;
: bounds-error ( n seq -- * )
\ bounds-error construct-boa throw ;
die \ bounds-error construct-boa throw ;
: bounds-check ( n seq -- n seq )
2dup bounds-check? [ bounds-error ] unless ; inline
@ -666,3 +666,8 @@ PRIVATE>
: infimum ( seq -- n ) dup first [ min ] reduce ;
: supremum ( seq -- n ) dup first [ max ] reduce ;
: sequence-hashcode ( n seq -- x )
0 -rot [
hashcode* >fixnum swap 31 fixnum*fast fixnum+fast
] curry* each ; inline

3
core/strings/strings.factor Normal file → Executable file
View File

@ -13,8 +13,7 @@ IN: strings
: reset-string-hashcode f swap set-string-hashcode ; inline
: rehash-string ( str -- )
dup 0 [ swap 31 fixnum*fast fixnum+fast ] reduce
swap set-string-hashcode ; inline
1 over sequence-hashcode swap set-string-hashcode ; inline
PRIVATE>

1
extra/io/launcher/launcher.factor Normal file → Executable file
View File

@ -59,3 +59,4 @@ HOOK: process-stream* io-backend ( desc -- stream )
USE-IF: unix? io.unix.launcher
USE-IF: windows? io.windows.launcher
USE-IF: winnt? io.windows.nt.launcher

8
extra/io/windows/ce/backend/backend.factor
View File

@ -13,7 +13,7 @@ M: windows-ce-io add-completion ( port -- ) drop ;
GENERIC: wince-read ( port port-handle -- )
M: input-port (wait-to-read) ( port -- )
dup port-handle wince-read ;
dup dup port-handle wince-read pending-error ;
GENERIC: wince-write ( port port-handle -- )
@ -41,7 +41,5 @@ M: windows-ce-io init-stdio ( -- )
] [
0 _getstdfilex _fileno
1 _getstdfilex _fileno
] if
>r f <win32-file> <reader>
r> f <win32-file> <writer>
] with-variable <duplex-stream> stdio set ;
] if <win32-duplex-stream>
] with-variable stdio set ;

12
extra/io/windows/ce/files/files.factor
View File

@ -10,12 +10,16 @@ IN: windows.ce.files
M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ;
M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
: finish-read ( port status bytes-ret -- )
swap [ drop port-errored ] [ swap n>buffer ] if ;
M: win32-file wince-read
drop dup make-FileArgs dup setup-read ReadFile zero? [
drop port-errored
drop
dup make-FileArgs dup setup-read ReadFile zero?
swap FileArgs-lpNumberOfBytesRet *uint dup zero? [
2drop t swap set-port-eof?
] [
FileArgs-lpNumberOfBytesRet *uint dup zero?
[ drop t swap set-port-eof? ] [ swap n>buffer ] if
finish-read
] if ;
M: win32-file wince-write ( port port-handle -- )

143
extra/io/windows/launcher/launcher.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system ;
IN: io.windows.launcher
! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed."
TUPLE: CreateProcess-args
lpApplicationName
lpCommandLine
@ -20,6 +20,8 @@ TUPLE: CreateProcess-args
stdout-pipe stdin-pipe ;
: dispose-CreateProcess-args ( args -- )
#! From MSDN: "Handles in PROCESS_INFORMATION must be closed
#! with CloseHandle when they are no longer needed."
CreateProcess-args-lpProcessInformation dup
PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
@ -75,7 +77,7 @@ TUPLE: CreateProcess-args
: fill-dwCreateFlags
0
pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
+detached+ get [ DETACHED_PROCESS bitor ] when
+detached+ get winnt? and [ DETACHED_PROCESS bitor ] when
over set-CreateProcess-args-dwCreateFlags ;
: fill-lpEnvironment
@ -93,137 +95,16 @@ TUPLE: CreateProcess-args
PROCESS_INFORMATION-hProcess INFINITE
WaitForSingleObject drop ;
: make-CreateProcess-args ( -- args )
default-CreateProcess-args
wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
fill-dwCreateFlags
fill-lpEnvironment ;
M: windows-io run-process* ( desc -- )
[
default-CreateProcess-args
wince? [
fill-lpApplicationName
] [
fill-lpCommandLine
] if
fill-dwCreateFlags
fill-lpEnvironment
make-CreateProcess-args
dup call-CreateProcess
+detached+ get [ dup wait-for-process ] unless
dispose-CreateProcess-args
] with-descriptor ;
! : default-security-attributes ( -- obj )
! "SECURITY_ATTRIBUTES" <c-object>
! "SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ;
!
! : security-attributes-inherit ( -- obj )
! default-security-attributes
! TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ;
!
! : set-inherit ( handle ? -- )
! >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
!
! ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
!
! TUPLE: pipe hRead hWrite ;
!
! C: <pipe> pipe
!
! : factor-pipe-name
! "\\\\.\\pipe\\Factor" ;
!
! : create-named-pipe ( str -- handle )
! PIPE_ACCESS_DUPLEX FILE_FLAG_OVERLAPPED bitor
! PIPE_TYPE_BYTE PIPE_READMODE_BYTE PIPE_NOWAIT bitor bitor
! PIPE_UNLIMITED_INSTANCES
! default-buffer-size get
! default-buffer-size get
! 0
! security-attributes-inherit
! CreateNamedPipe dup invalid-handle? ;
!
! : ERROR_PIPE_CONNECT 535 ; inline
!
! : pipe-connect-error? ( n -- ? )
! ERROR_SUCCESS ERROR_PIPE_CONNECT 2array member? not ;
!
! clear "ls" <process-stream> contents
! M: windows-nt-io <process-stream> ( command -- stream )
! [
! [
! default-CreateProcess-args
! fill-lpCommandLine
! TRUE over set-CreateProcess-args-bInheritHandles
!
! dup CreateProcess-args-lpStartupInfo
! STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
!
! factor-pipe-name create-named-pipe
! global [ "Named pipe: " write dup . ] bind
! dup t set-inherit
! [ add-completion ] keep
!
! ! CreateFile
! ! factor-pipe-name open-pipe-r/w
! factor-pipe-name GENERIC_READ GENERIC_WRITE bitor
! 0 f OPEN_EXISTING FILE_FLAG_OVERLAPPED f
! CreateFile
! global [ "Created File: " write dup . ] bind
! dup invalid-handle? dup close-later
! dup add-completion
!
! swap (make-overlapped) ConnectNamedPipe zero? [
! GetLastError pipe-connect-error? [
! win32-error-string throw
! ] when
! ] when
! dup t set-inherit
!
! ! ERROR_PIPE_CONNECTED
! [ pick set-CreateProcess-args-stdin-pipe ] keep
! global [ "Setting the stdios to: " write dup . ] bind
! [ over set-STARTUPINFO-hStdOutput ] keep
! [ over set-STARTUPINFO-hStdInput ] keep
! swap set-STARTUPINFO-hStdError
! !
! [ call-CreateProcess ] keep
! [ CreateProcess-args-stdin-pipe f <win32-file> dup handle>duplex-stream ] keep
! drop ! TODO: close handles instead of drop
! ] with-destructors
! ] with-descriptor ;
!
! : create-pipe ( -- pipe )
! "HANDLE" <c-object>
! "HANDLE" <c-object>
! [
! security-attributes-inherit
! 0
! CreatePipe win32-error=0/f
! ] 2keep
! [ *void* dup close-later ] 2apply <pipe> ;
!
! M: windows-ce-io process-stream*
! [
! default-CreateProcess-args
! TRUE over set-CreateProcess-args-bInheritHandles
!
! create-pipe ! for child's STDOUT
! dup pipe-hRead f set-inherit
! over set-CreateProcess-args-stdout-pipe
!
! create-pipe ! for child's STDIN
! dup pipe-hWrite f set-inherit
! over set-CreateProcess-args-stdin-pipe
!
! dup CreateProcess-args-lpStartupInfo
! STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
!
! over CreateProcess-args-stdout-pipe
! pipe-hWrite over set-STARTUPINFO-hStdOutput
! over CreateProcess-args-stdout-pipe
! pipe-hWrite over set-STARTUPINFO-hStdError
! over CreateProcess-args-stdin-pipe
! pipe-hRead swap set-STARTUPINFO-hStdInput
!
! [ call-CreateProcess ] keep
! [ CreateProcess-args-stdin-pipe pipe-hRead f <win32-file> <reader> ] keep
! [ CreateProcess-args-stdout-pipe pipe-hWrite f <win32-file> <writer> <duplex-stream> ] keep
! drop ! TODO: close handles instead of drop
! ] with-destructors ;
!

2
extra/io/windows/mmap/mmap.factor
View File

@ -78,7 +78,7 @@ M: windows-io <mapped-file> ( path length -- mmap )
PAGE_READWRITE SEC_COMMIT bitor
FILE_MAP_ALL_ACCESS mmap-open
-rot 2array
\ mapped-file construct-boa
f \ mapped-file construct-boa
] with-destructors ;
M: windows-io (close-mapped-file) ( mapped-file -- )

83
extra/io/windows/nt/backend/backend.factor
View File

@ -42,7 +42,8 @@ M: windows-nt-io normalize-pathname ( string -- string )
SYMBOL: io-hash
TUPLE: io-callback port continuation ;
TUPLE: io-callback continuation port ;
C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext )
@ -74,53 +75,55 @@ SYMBOL: master-completion-port
M: windows-nt-io add-completion ( handle -- )
master-completion-port get-global <completion-port> drop ;
TUPLE: GetOverlappedResult-args hFile* lpOverlapped* lpNumberOfBytesTransferred* bWait* port ;
: eof? ( error -- ? )
dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ;
C: <GetOverlappedResult-args> GetOverlappedResult-args
: overlapped-error? ( port n -- ? )
zero? [
GetLastError {
{ [ dup expected-io-error? ] [ 2drop t ] }
{ [ dup eof? ] [ drop t swap set-port-eof? f ] }
{ [ t ] [ (win32-error-string) throw ] }
} cond
] [
drop t
] if ;
: get-overlapped-result ( port -- n )
[
port-handle dup win32-file-handle
swap win32-file-overlapped 0 <int> 0
] keep <GetOverlappedResult-args> [
\ GetOverlappedResult-args >tuple<
>r GetOverlappedResult r> swap overlapped-error? drop
] keep GetOverlappedResult-args-lpNumberOfBytesTransferred* *int ;
: (save-callback) ( io-callback -- )
dup io-callback-port port-handle win32-file-overlapped
io-hash get-global set-at ;
: get-overlapped-result ( port -- bytes-transferred )
dup
port-handle
dup win32-file-handle
swap win32-file-overlapped
0 <uint> [
0
GetOverlappedResult overlapped-error? drop
] keep *uint ;
: save-callback ( port -- )
[
<io-callback> (save-callback) stop
] callcc0 drop ;
[ <io-callback> ] keep port-handle win32-file-overlapped
io-hash get-global set-at stop
] curry callcc0 ;
TUPLE: GetQueuedCompletionStatusParams hCompletionPort* lpNumberOfBytes* lpCompletionKey* lpOverlapped* dwMilliseconds* ;
C: <GetQueuedCompletionStatusParams> GetQueuedCompletionStatusParams
: wait-for-overlapped ( ms -- GetQueuedCompletionStatus-Params ret )
>r master-completion-port get-global 0 <int> 0 <int> 0 <int>
r> <GetQueuedCompletionStatusParams> [
GetQueuedCompletionStatusParams >tuple*<
GetQueuedCompletionStatus
] keep swap ;
: wait-for-overlapped ( ms -- overlapped ? )
>r master-completion-port get-global r> ! port ms
0 <int> ! bytes
f <void*> ! key
f <void*> ! overlapped
[ roll GetQueuedCompletionStatus ] keep *void* swap zero? ;
: lookup-callback ( GetQueuedCompletion-args -- callback )
GetQueuedCompletionStatusParams-lpOverlapped* *void*
io-hash get-global delete-at* drop ;
: wait-for-io ( timeout -- continuation/f )
wait-for-overlapped
zero? [
GetLastError dup (expected-io-error?) [
wait-for-overlapped [
GetLastError dup expected-io-error? [
2drop f
] [
dup ERROR_HANDLE_EOF = [
drop lookup-callback [
io-callback-port t swap set-port-eof?
] keep io-callback-continuation
dup eof? [
drop lookup-callback
dup io-callback-port t swap set-port-eof?
io-callback-continuation
] [
(win32-error-string) swap lookup-callback
[ io-callback-port set-port-error ] keep
@ -146,10 +149,6 @@ M: windows-nt-io io-multiplex ( ms -- )
cancel-timeout wait-for-io [ schedule-thread ] when* ;
M: windows-nt-io init-io ( -- )
#! Should only be called on startup. Calling this at any
#! other time can have unintended consequences.
global [
<master-completion-port> master-completion-port set
H{ } clone io-hash set
windows.winsock:init-winsock
] bind ;
<master-completion-port> master-completion-port set-global
H{ } clone io-hash set-global
windows.winsock:init-winsock ;

64
extra/io/windows/nt/launcher/launcher.factor Executable file
View File

@ -0,0 +1,64 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system
io.windows.launcher io.windows.nt.pipes ;
IN: io.windows.nt.launcher
! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
: set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
: add-pipe-dtors ( pipe -- )
dup
pipe-in close-later
pipe-out close-later ;
: fill-stdout-pipe
<unique-incoming-pipe>
dup add-pipe-dtors
dup pipe-in f set-inherit
over set-CreateProcess-args-stdout-pipe ;
: fill-stdin-pipe
<unique-outgoing-pipe>
dup add-pipe-dtors
dup pipe-out f set-inherit
over set-CreateProcess-args-stdin-pipe ;
: fill-startup-info
dup CreateProcess-args-lpStartupInfo
STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
over CreateProcess-args-stdout-pipe
pipe-out over set-STARTUPINFO-hStdOutput
over CreateProcess-args-stdout-pipe
pipe-out over set-STARTUPINFO-hStdError
over CreateProcess-args-stdin-pipe
pipe-in swap set-STARTUPINFO-hStdInput ;
M: windows-io process-stream*
[
[
make-CreateProcess-args
TRUE over set-CreateProcess-args-bInheritHandles
fill-stdout-pipe
fill-stdin-pipe
fill-startup-info
dup call-CreateProcess
dup CreateProcess-args-stdin-pipe pipe-in CloseHandle drop
dup CreateProcess-args-stdout-pipe pipe-out CloseHandle drop
dup CreateProcess-args-stdout-pipe pipe-in
over CreateProcess-args-stdin-pipe pipe-out <win32-duplex-stream>
swap dispose-CreateProcess-args
] with-destructors
] with-descriptor ;

75
extra/io/windows/nt/pipes/pipes.factor Executable file
View File

@ -0,0 +1,75 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.windows libc
windows.types math windows.kernel32 windows namespaces kernel
sequences windows.errors assocs math.parser system random ;
IN: io.windows.nt.pipes
! This code is based on
! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
: default-security-attributes ( -- obj )
"SECURITY_ATTRIBUTES" <c-object>
"SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ;
: security-attributes-inherit ( -- obj )
default-security-attributes
TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable
: create-named-pipe ( name mode -- handle )
FILE_FLAG_OVERLAPPED bitor
PIPE_TYPE_BYTE
1
4096
4096
0
security-attributes-inherit
CreateNamedPipe
dup win32-error=0/f
dup add-completion ;
: open-other-end ( name mode -- handle )
FILE_SHARE_READ FILE_SHARE_WRITE bitor
security-attributes-inherit
OPEN_EXISTING
FILE_FLAG_OVERLAPPED
f
CreateFile
dup win32-error=0/f
dup add-completion ;
TUPLE: pipe in out ;
: <pipe> ( name in-mode out-mode -- pipe )
[
>r over >r create-named-pipe dup close-later
r> r> open-other-end dup close-later
pipe construct-boa
] with-destructors ;
: close-pipe ( pipe -- )
dup
pipe-in CloseHandle drop
pipe-out CloseHandle drop ;
: <incoming-pipe> ( name -- pipe )
PIPE_ACCESS_INBOUND GENERIC_WRITE <pipe> ;
: <outgoing-pipe> ( name -- pipe )
PIPE_ACCESS_DUPLEX GENERIC_READ <pipe> ;
: unique-pipe-name ( -- string )
[
"\\\\.\\pipe\\factor-" %
pipe counter #
"-" %
(random) #
"-" %
millis #
] "" make ;
: <unique-incoming-pipe> ( -- pipe )
unique-pipe-name <incoming-pipe> ;
: <unique-outgoing-pipe> ( -- pipe )
unique-pipe-name <outgoing-pipe> ;

16
extra/io/windows/windows-tests.factor
View File

@ -1,16 +0,0 @@
USING: io.files kernel tools.test ;
IN: temporary
[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
[ "c:\\" ] [ "c:\\" parent-directory ] unit-test
[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test
[ "c:" ] [ "c:" parent-directory ] unit-test
[ "Z:" ] [ "Z:" parent-directory ] unit-test
[ t ] [ "c:\\" root-directory? ] unit-test
[ t ] [ "Z:\\" root-directory? ] unit-test
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test

3
extra/io/windows/windows.factor
View File

@ -20,6 +20,9 @@ TUPLE: win32-file handle ptr overlapped ;
: <win32-file> ( handle ptr -- obj )
f win32-file construct-boa ;
: <win32-duplex-stream> ( in out -- stream )
>r f <win32-file> r> f <win32-file> handle>duplex-stream ;
HOOK: CreateFile-flags io-backend ( -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- )

16
extra/tools/deploy/shaker/shaker.factor Normal file → Executable file
View File

@ -24,7 +24,6 @@ IN: tools.deploy.shaker
"Stripping debugger" show
"resource:extra/tools/deploy/shaker/strip-debugger.factor"
run-file
do-parse-hook
] when ;
: strip-libc ( -- )
@ -32,7 +31,6 @@ IN: tools.deploy.shaker
"Stripping manual memory management debug code" show
"resource:extra/tools/deploy/shaker/strip-libc.factor"
run-file
do-parse-hook
] when ;
: strip-cocoa ( -- )
@ -40,7 +38,6 @@ IN: tools.deploy.shaker
"Stripping unused Cocoa methods" show
"resource:extra/tools/deploy/shaker/strip-cocoa.factor"
run-file
do-parse-hook
] when ;
: strip-assoc ( retained-keys assoc -- newassoc )
@ -116,7 +113,6 @@ SYMBOL: deploy-vocab
strip-dictionary? [
{
builtins
dictionary
inspector-hook
lexer-factory
@ -142,6 +138,10 @@ SYMBOL: deploy-vocab
"c-types" "alien.c-types" lookup ,
] when
native-io? [
"default-buffer-size" "io.nonblocking" lookup ,
] when
deploy-ui? get [
"ui" child-vocabs
"cocoa" child-vocabs
@ -152,10 +152,11 @@ SYMBOL: deploy-vocab
] when
] { } make dup . ;
: strip ( -- )
strip-libc
: strip ( hook -- )
>r strip-libc
strip-cocoa
strip-debugger
r> [ call ] when*
strip-init-hooks
deploy-vocab get vocab-main set-boot-quot*
retained-props >r
@ -168,10 +169,9 @@ SYMBOL: deploy-vocab
[
[
deploy-vocab set
parse-hook get >r
parse-hook get
parse-hook off
deploy-vocab get require
r> [ call ] when*
strip
finish-deploy
] [

0
extra/tools/deploy/shaker/strip-debugger.factor Normal file → Executable file
View File

8
extra/ui/gadgets/editors/editors-tests.factor
View File

@ -1,7 +1,7 @@
USING: ui.gadgets.editors tools.test kernel io io.streams.plain
definitions namespaces ui.gadgets
ui.gadgets.grids prettyprint documents ui.gestures
tools.test.inference tools.test.ui ;
tools.test.inference tools.test.ui models ;
[ "foo bar" ] [
<editor> "editor" set
@ -31,3 +31,9 @@ tools.test.inference tools.test.ui ;
] unit-test
{ 0 1 } [ <editor> ] unit-test-effect
"hello" <model> <field> "field" set
"field" get [
[ "hello" ] [ "field" get field-model model-value ] unit-test
] with-grafted-gadget

8
extra/ui/gadgets/gadgets.factor
View File

@ -70,8 +70,12 @@ M: gadget model-changed 2drop ;
>r <gadget> r> construct-delegate ; inline
: activate-control ( gadget -- )
dup gadget-model dup [ 2dup add-connection ] when drop
dup gadget-model swap model-changed ;
dup gadget-model dup [
2dup add-connection
swap model-changed
] [
2drop
] if ;
: deactivate-control ( gadget -- )
dup gadget-model dup [ 2dup remove-connection ] when 2drop ;

11
extra/ui/windows/windows.factor
View File

@ -280,10 +280,13 @@ SYMBOL: hWnd
mouse-captured? [ release-capture ] when
prepare-mouse send-button-up ;
: make-TRACKMOUSEEVENT ( hWnd -- alien )
"TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
"TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
2nip
over "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
"TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize
over make-TRACKMOUSEEVENT
TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
0 over set-TRACKMOUSEEVENT-dwHoverTime
TrackMouseEvent drop
@ -387,10 +390,10 @@ SYMBOL: hWnd
dup SetForegroundWindow drop
SetFocus drop ;
: init-win32-ui
: init-win32-ui ( -- )
"MSG" <c-object> msg-obj set
"Factor-window" malloc-u16-string class-name-ptr set-global
register-wndclassex
register-wndclassex drop
GetDoubleClickTime double-click-timeout set-global ;
: cleanup-win32-ui ( -- )

1
extra/windows/errors/errors.factor Normal file → Executable file
View File

@ -3,6 +3,7 @@ IN: windows.errors
: ERROR_SUCCESS 0 ; inline
: ERROR_HANDLE_EOF 38 ; inline
: ERROR_BROKEN_PIPE 109 ; inline
: ERROR_IO_INCOMPLETE 996 ; inline
: ERROR_IO_PENDING 997 ; inline

25
extra/windows/windows.factor Normal file → Executable file
View File

@ -39,30 +39,21 @@ FUNCTION: void* error_message ( DWORD id ) ;
win32-error-string throw
] when ;
: (expected-io-error?) ( error-code -- ? )
: expected-io-errors
ERROR_SUCCESS
ERROR_IO_INCOMPLETE
ERROR_IO_PENDING
WAIT_TIMEOUT 4array member? ;
WAIT_TIMEOUT 4array ; foldable
: expected-io-error? ( error-code -- )
dup (expected-io-error?) [
: expected-io-error? ( error-code -- ? )
expected-io-errors member? ;
: expected-io-error ( error-code -- )
dup expected-io-error? [
drop
] [
(win32-error-string) throw
] if ;
: io-error ( return-value -- )
{ 0 f } member? [ GetLastError expected-io-error? ] when ;
: overlapped-error? ( port n -- ? )
zero? [
GetLastError
{
{ [ dup (expected-io-error?) ] [ 2drop t ] }
{ [ dup ERROR_HANDLE_EOF = ] [ drop t swap set-port-eof? f ] }
{ [ t ] [ (win32-error-string) throw ] }
} cond
] [
drop t
] if ;
{ 0 f } member? [ GetLastError expected-io-error ] when ;