Merge commit 'dharmatech/master'

core/io/streams/lines/lines-tests.factor

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

core/io/streams/lines/lines.factor

@@ -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
+    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 )
-    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
+    dup delegate stream-read1 fix-read1 ;
-    over line-reader-cr [ over cr- fix-read1 ] [ nip ] if ;

extra/bake/bake.factor

@@ -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
 
@@ -22,6 +22,10 @@ C: <splice-quot> splice-quot
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: ,u ( seq -- seq ) unclip building get push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 SYMBOL: exemplar
 
 : reset-building ( -- ) 1024 <vector> building set ;
@@ -35,6 +39,7 @@ DEFER: bake
 : bake-item ( item -- )
   { { [ dup \ , = ]        [ drop , ] }
     { [ dup \ % = ] 	   [ drop % ] }
+    { [ dup \ ,u = ]	   [ drop ,u ] }
     { [ dup insert-quot? ] [ insert-quot-expr call , ] }
     { [ dup splice-quot? ] [ splice-quot-expr call % ] }
     { [ dup integer? ]     [ , ] }
@@ -48,4 +53,9 @@ DEFER: bake
 : bake-items ( seq -- ) [ bake-item ] each ;
 
 : 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
+

extra/raptor/config.factor

@@ -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
 
@@ -24,9 +26,20 @@ IN: raptor
   configure-route
 ] networking-hook set-global
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Filesystems
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+"/dev/hda1"     root-device     set-global
+
+{ "/dev/hda5" } swap-devices	set-global
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! boot-hook
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 [
+                                    start-wait-loop
 
   ! rcS.d
 
@@ -38,7 +51,12 @@ IN: raptor
   "mountdevsubfs" 		    start-service
   "module-init-tools" 		    start-service
   "procps.sh" 			    start-service
-  "checkroot.sh"		    start-service
+
+  !  "checkroot.sh"		    start-service
+
+     				    activate-swap
+				    mount-root
+
   "mtab"			    start-service
   "checkfs.sh" 			    start-service
   "mountall.sh"			    start-service
@@ -76,11 +94,17 @@ IN: raptor
   "rmnologin"			    start-service
 
   				    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
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! reboot-hook
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 [
@@ -108,6 +132,8 @@ IN: raptor
   "reboot" 			    stop-service
 ] reboot-hook set-global
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! shutdown-hook
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 [

extra/raptor/cron/cron.factor

@@ -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
 
@@ -46,3 +47,16 @@ C: <when> when
 
 : 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 ;
+

extra/raptor/cronjobs.factor

@@ -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
 
@@ -7,41 +8,33 @@ IN: raptor
 
 : 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 ;

extra/raptor/raptor.factor

@@ -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
 
@@ -10,29 +11,29 @@ SYMBOL: reboot-hook
 SYMBOL: shutdown-hook
 SYMBOL: networking-hook
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : reload-raptor-config ( -- )
   "/etc/raptor/config.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 ;
 : 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 ;
 
 : 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 ;
 
 MAIN: boot
+

extra/raptor/readme-0.1.1

@@ -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
 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 ***
 
+  # mkdir -v /etc/raptor
+
+  # cp -v /scratch/factor/extra/raptor/{config,cronjobs}.factor /etc/raptor
+
   ( scratchpad ) USE: raptor
+  ( scratchpad ) reload-raptor-config
   ( scratchpad ) save
 
   # mv -v /sbin/{init,init.orig}
@@ -19,10 +32,6 @@ another Linux distribution.
 
   # 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 ***
 
 If you use a static IP in your network then Factor can take care of

extra/tools/deploy/shaker/shaker.factor

@@ -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 ( hook -- )
-    strip-libc
+    >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
         ] [

extra/ui/gadgets/editors/editors-tests.factor

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

extra/ui/gadgets/gadgets.factor

@@ -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 dup [
-    dup gadget-model swap model-changed ;
+        2dup add-connection
+        swap model-changed
+    ] [
+        2drop
+    ] if ;
 
 : deactivate-control ( gadget -- )
     dup gadget-model dup [ 2dup remove-connection ] when 2drop ;

extra/ui/windows/windows.factor

@@ -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
+    over make-TRACKMOUSEEVENT
-    "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize
     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 ( -- )

extra/unix/linux/fs/fs.factor

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

extra/unix/linux/swap/swap.factor

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

extra/unix/process/process.factor

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

extra/unix/unix.factor

@@ -166,6 +166,10 @@ FUNCTION: time_t time ( time_t* t ) ;
 FUNCTION: int unlink ( char* path ) ;
 FUNCTION: int utimes ( char* path, timeval[2] times ) ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! wait and waitpid
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 ! Flags for waitpid
 
 : WNOHANG   1 ;
@@ -176,7 +180,27 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ;
 : WCONTINUED 8 ;
 : 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 waitpid ( pid_t wpid, int* status, int options ) ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;

misc/factor.el

@@ -166,6 +166,9 @@
   (beginning-of-line)
   (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-r" 'factor-send-region)