Merge commit 'dharmatech/master'

release
Slava Pestov 2007-11-23 14:38:55 -05:00
commit 070a41f60f
19 changed files with 259 additions and 94 deletions

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 4 swap stream-read
] unit-test ] unit-test
[
"1234"
] [
"Hello world\r\n1234" <string-reader>
dup stream-readln drop
4 swap stream-read-partial
] unit-test
[ [
CHAR: 1 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 ; "\r\n" over delegate stream-read-until handle-readln ;
: fix-read ( stream string -- string ) : 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 M: line-reader stream-read
tuck delegate stream-read tuck delegate stream-read fix-read ;
over line-reader-cr [ over cr- fix-read ] [ nip ] if ;
M: line-reader stream-read-partial
tuck delegate stream-read-partial fix-read ;
: fix-read1 ( stream char -- char ) : 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 ) M: line-reader stream-read1 ( stream -- char )
dup delegate stream-read1 dup delegate stream-read1 fix-read1 ;
over line-reader-cr [ over cr- fix-read1 ] [ nip ] if ;

View File

@ -1,6 +1,6 @@
USING: kernel parser namespaces quotations vectors strings USING: kernel parser namespaces quotations arrays vectors strings
sequences assocs tuples math combinators ; sequences assocs tuples math combinators ;
IN: bake IN: bake
@ -22,6 +22,10 @@ C: <splice-quot> splice-quot
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ,u ( seq -- seq ) unclip building get push ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: exemplar SYMBOL: exemplar
: reset-building ( -- ) 1024 <vector> building set ; : reset-building ( -- ) 1024 <vector> building set ;
@ -35,6 +39,7 @@ DEFER: bake
: bake-item ( item -- ) : bake-item ( item -- )
{ { [ dup \ , = ] [ drop , ] } { { [ dup \ , = ] [ drop , ] }
{ [ dup \ % = ] [ drop % ] } { [ dup \ % = ] [ drop % ] }
{ [ dup \ ,u = ] [ drop ,u ] }
{ [ dup insert-quot? ] [ insert-quot-expr call , ] } { [ dup insert-quot? ] [ insert-quot-expr call , ] }
{ [ dup splice-quot? ] [ splice-quot-expr call % ] } { [ dup splice-quot? ] [ splice-quot-expr call % ] }
{ [ dup integer? ] [ , ] } { [ dup integer? ] [ , ] }
@ -48,4 +53,9 @@ DEFER: bake
: bake-items ( seq -- ) [ bake-item ] each ; : bake-items ( seq -- ) [ bake-item ] each ;
: bake ( seq -- seq ) : bake ( seq -- seq )
[ reset-building save-exemplar bake-items finish-baking ] with-scope ; [ reset-building save-exemplar bake-items finish-baking ] with-scope ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing

View File

@ -1,5 +1,7 @@
USING: namespaces unix.linux.if unix.linux.ifreq unix.linux.route ; USING: namespaces threads
unix.process unix.linux.if unix.linux.ifreq unix.linux.route
raptor.cron ;
IN: raptor IN: raptor
@ -24,9 +26,20 @@ IN: raptor
configure-route configure-route
] networking-hook set-global ] networking-hook set-global
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Filesystems
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
"/dev/hda1" root-device set-global
{ "/dev/hda5" } swap-devices set-global
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! boot-hook
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ [
start-wait-loop
! rcS.d ! rcS.d
@ -38,7 +51,12 @@ IN: raptor
"mountdevsubfs" start-service "mountdevsubfs" start-service
"module-init-tools" start-service "module-init-tools" start-service
"procps.sh" start-service "procps.sh" start-service
"checkroot.sh" start-service
! "checkroot.sh" start-service
activate-swap
mount-root
"mtab" start-service "mtab" start-service
"checkfs.sh" start-service "checkfs.sh" start-service
"mountall.sh" start-service "mountall.sh" start-service
@ -76,11 +94,17 @@ IN: raptor
"rmnologin" start-service "rmnologin" start-service
schedule-cron-jobs schedule-cron-jobs
start-listeners
start-gettys [ [ "/dev/tty2" tty-listener ] forever ] in-thread
[ [ "/dev/tty3" tty-listener ] forever ] in-thread
[ [ "/dev/tty4" tty-listener ] forever ] in-thread
[ [ "/dev/tty5" getty ] forever ] in-thread
[ [ "/dev/tty6" getty ] forever ] in-thread
] boot-hook set-global ] boot-hook set-global
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! reboot-hook
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ [
@ -108,6 +132,8 @@ IN: raptor
"reboot" stop-service "reboot" stop-service
] reboot-hook set-global ] reboot-hook set-global
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! shutdown-hook
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ [

View File

@ -1,5 +1,6 @@
USING: kernel threads sequences calendar combinators.cleave combinators.lib ; USING: kernel namespaces threads sequences calendar
combinators.cleave combinators.lib ;
IN: raptor.cron IN: raptor.cron
@ -46,3 +47,16 @@ C: <when> when
: schedule ( when quot -- ) [ recurring-job ] curry curry in-thread ; : schedule ( when quot -- ) [ recurring-job ] curry curry in-thread ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: cron-jobs-hourly
SYMBOL: cron-jobs-daily
SYMBOL: cron-jobs-weekly
SYMBOL: cron-jobs-monthly
: schedule-cron-jobs ( -- )
{ 17 } f f f f <when> [ cron-jobs-hourly get call ] schedule
{ 25 } { 6 } f f f <when> [ cron-jobs-daily get call ] schedule
{ 47 } { 6 } f f { 7 } <when> [ cron-jobs-weekly get call ] schedule
{ 52 } { 6 } { 1 } f f <when> [ cron-jobs-monthly get call ] schedule ;

View File

@ -1,5 +1,6 @@
USING: kernel threads arrays sequences combinators.cleave raptor raptor.cron ; USING: kernel namespaces threads arrays sequences combinators.cleave
raptor raptor.cron ;
IN: raptor IN: raptor
@ -7,41 +8,33 @@ IN: raptor
: fork-exec-args-wait ( args -- ) [ first ] [ ] bi fork-exec-wait ; : fork-exec-args-wait ( args -- ) [ first ] [ ] bi fork-exec-wait ;
: run-script ( path -- ) 1array [ fork-exec-args-wait ] curry in-thread ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cron-hourly ( -- ) ; [
"/etc/cron.daily/apt" run-script
: cron-daily ( -- ) "/etc/cron.daily/aptitude" run-script
{ "/etc/cron.daily/apt" "/etc/cron.daily/bsdmainutils" run-script
"/etc/cron.daily/aptitude" "/etc/cron.daily/find.notslocate" run-script
"/etc/cron.daily/bsdmainutils" "/etc/cron.daily/logrotate" run-script
"/etc/cron.daily/find.notslocate" "/etc/cron.daily/man-db" run-script
"/etc/cron.daily/logrotate" "/etc/cron.daily/ntp-server" run-script
"/etc/cron.daily/man-db" "/etc/cron.daily/slocate" run-script
"/etc/cron.daily/ntp-server" "/etc/cron.daily/standard" run-script
"/etc/cron.daily/slocate" "/etc/cron.daily/sysklogd" run-script
"/etc/cron.daily/standard" "/etc/cron.daily/tetex-bin" run-script
"/etc/cron.daily/sysklogd" ] cron-jobs-daily set-global
"/etc/cron.daily/tetex-bin" }
[ 1array [ fork-exec-args-wait ] in-thread drop ] each ;
: cron-weekly ( -- ) [
{ "/etc/cron.weekly/cvs" "/etc/cron.weekly/cvs" run-script
"/etc/cron.weekly/man-db" "/etc/cron.weekly/man-db" run-script
"/etc/cron.weekly/ntp-server" "/etc/cron.weekly/ntp-server" run-script
"/etc/cron.weekly/popularity-contest" "/etc/cron.weekly/popularity-contest" run-script
"/etc/cron.weekly/sysklogd" } "/etc/cron.weekly/sysklogd" run-script
[ 1array [ fork-exec-args-wait ] in-thread drop ] each ; ] cron-jobs-weekly set-global
: cron-monthly ( -- ) [
{ "/etc/cron.monthly/scrollkeeper" "/etc/cron.monthly/scrollkeeper" run-script
"/etc/cron.monthly/standard" } "/etc/cron.monthly/standard" run-script
[ 1array [ fork-exec-args-wait ] in-thread drop ] each ; ] cron-jobs-monthly set-global
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: schedule-cron-jobs ( -- )
{ 17 } f f f f <when> [ cron-hourly ] schedule
{ 25 } { 6 } f f f <when> [ cron-daily ] schedule
{ 47 } { 6 } f f { 7 } <when> [ cron-weekly ] schedule
{ 52 } { 6 } { 1 } f f <when> [ cron-monthly ] schedule ;

View File

@ -1,5 +1,6 @@
USING: kernel parser namespaces threads unix.process combinators.cleave ; USING: kernel parser namespaces threads sequences unix unix.process
combinators.cleave bake ;
IN: raptor IN: raptor
@ -10,29 +11,29 @@ SYMBOL: reboot-hook
SYMBOL: shutdown-hook SYMBOL: shutdown-hook
SYMBOL: networking-hook SYMBOL: networking-hook
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: reload-raptor-config ( -- ) : reload-raptor-config ( -- )
"/etc/raptor/config.factor" run-file "/etc/raptor/config.factor" run-file
"/etc/raptor/cronjobs.factor" run-file ; "/etc/raptor/cronjobs.factor" run-file ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: sequences unix ; : fork-exec-wait ( pathname args -- )
fork dup 0 = [ drop exec drop ] [ 2nip wait-for-pid drop ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: forever ( quot -- ) [ call ] [ forever ] bi ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: start-service ( name -- ) "/etc/init.d/" swap " start" 3append system drop ; : start-service ( name -- ) "/etc/init.d/" swap " start" 3append system drop ;
: stop-service ( name -- ) "/etc/init.d/" swap " stop" 3append system drop ; : stop-service ( name -- ) "/etc/init.d/" swap " stop" 3append system drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fork-exec-wait ( pathname args -- ) : getty ( tty -- ) `{ "/sbin/getty" "38400" , } fork-exec-args-wait ;
fork dup 0 = [ drop exec drop ] [ 2nip wait-for-pid ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: respawn ( pathname args -- ) [ fork-exec-wait ] [ respawn ] 2bi ;
: start-gettys ( -- )
[ "/sbin/getty" { "getty" "38400" "tty5" } respawn ] in-thread
[ "/sbin/getty" { "getty" "38400" "tty6" } respawn ] in-thread ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -40,16 +41,19 @@ USING: io io.files io.streams.lines io.streams.plain io.streams.duplex
listener ; listener ;
: tty-listener ( tty -- ) : tty-listener ( tty -- )
[ <file-reader> <line-reader> ] [ <file-reader> ] [ <file-writer> ] bi <duplex-stream>
[ <file-writer> <plain-writer> ] [ listener ] with-stream ;
bi <duplex-stream> [ listener ] with-stream ;
: forever ( quot -- ) [ call ] [ forever ] bi ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: start-listeners ( -- ) USING: unix.linux.swap unix.linux.fs ;
[ [ "/dev/tty2" tty-listener ] forever ] in-thread
[ [ "/dev/tty3" tty-listener ] forever ] in-thread SYMBOL: root-device
[ [ "/dev/tty4" tty-listener ] forever ] in-thread ; SYMBOL: swap-devices
: activate-swap ( -- ) swap-devices get [ 0 swapon drop ] each ;
: mount-root ( -- ) root-device get "/" "ext3" MS_REMOUNT f mount drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -60,3 +64,4 @@ USING: io io.files io.streams.lines io.streams.plain io.streams.duplex
: shutdown ( -- ) shutdown-hook get call ; : shutdown ( -- ) shutdown-hook get call ;
MAIN: boot MAIN: boot

View File

@ -8,9 +8,22 @@ Raptor Linux is a mod of Ubuntu 6.06 (Dapper Drake)
This is unlikely to work on another version of Ubuntu, much less This is unlikely to work on another version of Ubuntu, much less
another Linux distribution. another Linux distribution.
*** Features ***
* /sbin/init is replaced with Factor
* Virtual terminals managed by Factor
* Listeners run on virtual terminals
* Native support for static ip networking
* Crontab replacement
*** Install *** *** Install ***
# mkdir -v /etc/raptor
# cp -v /scratch/factor/extra/raptor/{config,cronjobs}.factor /etc/raptor
( scratchpad ) USE: raptor ( scratchpad ) USE: raptor
( scratchpad ) reload-raptor-config
( scratchpad ) save ( scratchpad ) save
# mv -v /sbin/{init,init.orig} # mv -v /sbin/{init,init.orig}
@ -19,10 +32,6 @@ another Linux distribution.
# cp -v /scratch/factor/factor.image /sbin/init.image # cp -v /scratch/factor/factor.image /sbin/init.image
# mkdir -v /etc/raptor
# cp -v /scratch/factor/extra/raptor/config.factor /etc/raptor/config.factor
*** Static IP networking *** *** Static IP networking ***
If you use a static IP in your network then Factor can take care of If you use a static IP in your network then Factor can take care of

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

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

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

View File

@ -1,7 +1,7 @@
USING: ui.gadgets.editors tools.test kernel io io.streams.plain USING: ui.gadgets.editors tools.test kernel io io.streams.plain
definitions namespaces ui.gadgets definitions namespaces ui.gadgets
ui.gadgets.grids prettyprint documents ui.gestures ui.gadgets.grids prettyprint documents ui.gestures
tools.test.inference tools.test.ui ; tools.test.inference tools.test.ui models ;
[ "foo bar" ] [ [ "foo bar" ] [
<editor> "editor" set <editor> "editor" set
@ -31,3 +31,9 @@ tools.test.inference tools.test.ui ;
] unit-test ] unit-test
{ 0 1 } [ <editor> ] unit-test-effect { 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

View File

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

View File

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

View File

@ -0,0 +1,25 @@
USING: alien.syntax ;
IN: unix.linux.fs
: MS_RDONLY 1 ; ! Mount read-only.
: MS_NOSUID 2 ; ! Ignore suid and sgid bits.
: MS_NODEV 4 ; ! Disallow access to device special files.
: MS_NOEXEC 8 ; ! Disallow program execution.
: MS_SYNCHRONOUS 16 ; ! Writes are synced at once.
: MS_REMOUNT 32 ; ! Alter flags of a mounted FS.
: MS_MANDLOCK 64 ; ! Allow mandatory locks on an FS.
: S_WRITE 128 ; ! Write on file/directory/symlink.
: S_APPEND 256 ; ! Append-only file.
: S_IMMUTABLE 512 ; ! Immutable file.
: MS_NOATIME 1024 ; ! Do not update access times.
: MS_NODIRATIME 2048 ; ! Do not update directory access times.
: MS_BIND 4096 ; ! Bind directory at different place.
FUNCTION: int mount
( char* special_file, char* dir, char* fstype, ulong options, void* data ) ;
! FUNCTION: int umount2 ( char* file, int flags ) ;
FUNCTION: int umount ( char* file ) ;

View File

@ -0,0 +1,12 @@
USING: alien.syntax ;
IN: unix.linux.swap
: SWAP_FLAG_PREFER HEX: 8000 ; ! Set if swap priority is specified.
: SWAP_FLAG_PRIO_MASK HEX: 7fff ;
: SWAP_FLAG_PRIO_SHIFT 0 ;
FUNCTION: int swapon ( char* path, int flags ) ;
FUNCTION: int swapoff ( char* path ) ;

View File

@ -31,11 +31,23 @@ IN: unix.process
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This is kludgy. We need a better implementation. USING: kernel alien.c-types namespaces continuations threads assocs unix
combinators.cleave ;
USE: threads SYMBOL: pid-wait
: wait-for-pid ( pid -- ) ! KEY | VALUE
dup "int" <c-object> WNOHANG waitpid ! -----------
0 = [ 100 sleep wait-for-pid ] [ drop ] if ; ! pid | continuation
: init-pid-wait ( -- ) H{ } clone pid-wait set-global ;
: wait-for-pid ( pid -- status ) [ pid-wait get set-at stop ] curry callcc1 ;
: wait-loop ( -- )
-1 0 <int> tuck WNOHANG waitpid ! &status return
[ *int ] [ pid-wait get delete-at* drop ] bi* ! status ?
dup [ schedule-thread-with ] [ 2drop ] if
250 sleep wait-loop ;
: start-wait-loop ( -- ) init-pid-wait [ wait-loop ] in-thread ;

View File

@ -166,6 +166,10 @@ FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: int unlink ( char* path ) ; FUNCTION: int unlink ( char* path ) ;
FUNCTION: int utimes ( char* path, timeval[2] times ) ; FUNCTION: int utimes ( char* path, timeval[2] times ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! wait and waitpid
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Flags for waitpid ! Flags for waitpid
: WNOHANG 1 ; : WNOHANG 1 ;
@ -176,7 +180,27 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ;
: WCONTINUED 8 ; : WCONTINUED 8 ;
: WNOWAIT HEX: 1000000 ; : WNOWAIT HEX: 1000000 ;
! Examining status
: WTERMSIG ( status -- value ) HEX: 7f bitand ;
: WIFEXITED ( status -- ? ) WTERMSIG zero? ;
: WEXITSTATUS ( status -- value ) HEX: ff00 bitand -8 shift ;
: WIFSIGNALED ( status -- ? ) HEX: 7f bitand 1+ -1 shift 0 > ;
: WCOREFLAG ( -- value ) HEX: 80 ;
: WCOREDUMP ( status -- ? ) WCOREFLAG bitand zero? not ;
: WIFSTOPPED ( status -- ? ) HEX: ff bitand HEX: 7f = ;
: WSTOPSIG ( status -- value ) WEXITSTATUS ;
FUNCTION: pid_t wait ( int* status ) ; FUNCTION: pid_t wait ( int* status ) ;
FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;

View File

@ -166,6 +166,9 @@
(beginning-of-line) (beginning-of-line)
(insert "! ")) (insert "! "))
(defun factor-refresh-all ()
(interactive)
(comint-send-string "*factor*" "refresh-all\n"))
(define-key factor-mode-map "\C-c\C-f" 'factor-run-file) (define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
(define-key factor-mode-map "\C-c\C-r" 'factor-send-region) (define-key factor-mode-map "\C-c\C-r" 'factor-send-region)