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

core/definitions/definitions-tests.factor

@@ -11,7 +11,7 @@ SYMBOL: generic-1
 [
     generic-1 T{ combination-1 } define-generic
 
-    [ ] <method> object \ generic-1 define-method
+    [ ] object \ generic-1 define-method
 ] with-compilation-unit
 
 [ ] [

core/generic/generic-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax generic.math generic.standard
 words classes definitions kernel alien combinators sequences 
-math ;
+math quotations ;
 IN: generic
 
 ARTICLE: "method-order" "Method precedence"
@@ -154,7 +154,7 @@ HELP: with-methods
 $low-level-note ;
 
 HELP: define-method
-{ $values { "method" "an instance of " { $link method } } { "class" class } { "generic" generic } }
+{ $values { "method" quotation } { "class" class } { "generic" generic } }
 { $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
 
 HELP: implementors

core/generic/generic.factor

@@ -39,11 +39,6 @@ TUPLE: method loc def ;
 : <method> ( def -- method )
     { set-method-def } \ method construct ;
 
-M: f method-def ;
-M: f method-loc ;
-M: quotation method-def ;
-M: quotation method-loc drop f ;
-
 : method ( class generic -- method/f )
     "methods" word-prop at ;
 
@@ -55,7 +50,7 @@ PREDICATE: pair method-spec
 
 : sort-methods ( assoc -- newassoc )
     [ keys sort-classes ] keep
-    [ dupd at method-def 2array ] curry map ;
+    [ dupd at method-def ] curry { } map>assoc ;
 
 : methods ( word -- assoc )
     "methods" word-prop sort-methods ;
@@ -72,18 +67,19 @@ TUPLE: check-method class generic ;
     inline
 
 : define-method ( method class generic -- )
-    >r bootstrap-word r> check-method
+    >r >r <method> r> bootstrap-word r> check-method
     [ set-at ] with-methods ;
 
 ! Definition protocol
 M: method-spec where
-    dup first2 method method-loc [ ] [ second where ] ?if ;
+    dup first2 method [ method-loc ] [ second where ] ?if ;
 
 M: method-spec set-where first2 method set-method-loc ;
 
 M: method-spec definer drop \ M: \ ; ;
 
-M: method-spec definition first2 method method-def ;
+M: method-spec definition
+    first2 method dup [ method-def ] when ;
 
 : forget-method ( class generic -- )
     check-method [ delete-at ] with-methods ;

core/generic/math/math.factor

@@ -39,8 +39,8 @@ TUPLE: no-math-method left right generic ;
     \ no-math-method construct-boa throw ;
 
 : applicable-method ( generic class -- quot )
-    over method method-def
+    over method
-    [ ] [ [ no-math-method ] curry [ ] like ] ?if ;
+    [ method-def ] [ [ no-math-method ] curry [ ] like ] ?if ;
 
 : object-method ( generic -- quot )
     object bootstrap-word applicable-method ;

core/slots/slots.factor

@@ -10,7 +10,7 @@ TUPLE: slot-spec type name offset reader writer ;
 C: <slot-spec> slot-spec
 
 : define-typecheck ( class generic quot -- )
-    <method> over define-simple-generic -rot define-method ;
+    over define-simple-generic -rot define-method ;
 
 : define-slot-word ( class slot word quot -- )
     rot >fixnum add* define-typecheck ;

core/syntax/syntax.factor

@@ -126,7 +126,7 @@ IN: bootstrap.syntax
         f set-word
         location >r
         scan-word bootstrap-word scan-word
-        [ parse-definition <method> -rot define-method ] 2keep
+        [ parse-definition -rot define-method ] 2keep
         2array r> remember-definition
     ] define-syntax
 

extra/io/launcher/launcher-docs.factor

@@ -116,6 +116,15 @@ HELP: run-detached
     "The output value can be passed to " { $link wait-for-process } " to get an exit code."
 } ;
 
+HELP: kill-process
+{ $values { "process" process } }
+{ $description "Kills a running process. Does nothing if the process has already exited." } ;
+
+HELP: kill-process*
+{ $values { "handle" "a process handle" } }
+{ $contract "Kills a running process." }
+{ $notes "User code should call " { $link kill-process } " intead." } ;
+
 HELP: process
 { $class-description "A class representing an active or finished process."
 $nl
@@ -166,6 +175,8 @@ $nl
 "The following words are used to launch processes:"
 { $subsection run-process }
 { $subsection run-detached }
+"Stopping processes:"
+{ $subsection kill-process }
 "Redirecting standard input and output to a pipe:"
 { $subsection <process-stream> }
 { $subsection with-process-stream }

extra/io/launcher/launcher.factor

@@ -84,6 +84,11 @@ HOOK: run-process* io-backend ( desc -- handle )
 : run-detached ( desc -- process )
     >descriptor H{ { +detached+ t } } union run-process ;
 
+HOOK: kill-process* io-backend ( handle -- )
+
+: kill-process ( process -- )
+    process-handle [ kill-process* ] when* ;
+
 HOOK: process-stream* io-backend ( desc -- stream process )
 
 TUPLE: process-stream process ;

extra/io/unix/launcher/launcher.factor

@@ -57,7 +57,8 @@ MEMO: 'arguments' ( -- parser )
 : setup-redirection ( -- )
     +stdin+ get read-flags 0 redirect
     +stdout+ get write-flags 1 redirect
-    +stderr+ get write-flags 2 redirect ;
+    +stderr+ get dup +stdout+ get eq?
+    [ 1 2 dup2 ] [ write-flags 2 redirect ] if ;
 
 : spawn-process ( -- )
     [
@@ -74,6 +75,9 @@ M: unix-io run-process* ( desc -- pid )
         [ spawn-process ] [ ] with-fork <process>
     ] with-descriptor ;
 
+M: unix-io kill-process* ( pid -- )
+    SIGTERM kill io-error ;
+
 : open-pipe ( -- pair )
     2 "int" <c-array> dup pipe zero?
     [ 2 c-int-array> ] [ drop f ] if ;

extra/io/unix/linux/linux.factor

@@ -21,8 +21,11 @@ TUPLE: linux-monitor path wd callback ;
 
 TUPLE: inotify watches ;
 
-: wd>path ( wd -- path )
+: watches ( -- assoc ) inotify get-global inotify-watches ;
-    inotify get-global inotify-watches at linux-monitor-path ;
+
+: wd>monitor ( wd -- monitor ) watches at ;
+
+: wd>path ( wd -- path ) wd>monitor linux-monitor-path ;
 
 : <inotify> ( -- port )
     H{ } clone
@@ -31,8 +34,6 @@ TUPLE: inotify watches ;
 
 : inotify-fd inotify get-global port-handle ;
 
-: watches inotify get-global inotify-watches ;
-
 : (add-watch) ( path mask -- wd )
     inotify-fd -rot inotify_add_watch dup io-error ;
 
@@ -105,9 +106,13 @@ M: linux-monitor dispose ( monitor -- )
     inotify-event-len "inotify-event" heap-size +
     swap >r + r> ;
 
+: wd>queue ( wd -- queue )
+    inotify-event-wd wd>monitor monitor-queue ;
+
 : parse-file-notifications ( i buffer -- )
     2dup events-exhausted? [ 2drop ] [
-        2dup inotify-event@ parse-file-notify changed-file
+        2dup inotify-event@ dup inotify-event-wd wd>queue
+        [ parse-file-notify changed-file ] bind
         next-event parse-file-notifications
     ] if ;
 

extra/io/windows/launcher/launcher.factor

@@ -48,10 +48,10 @@ TUPLE: CreateProcess-args
     } get-slots CreateProcess win32-error=0/f ;
 
 : escape-argument ( str -- newstr )
-    [ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ;
+    CHAR: \s over member? [ "\"" swap "\"" 3append ] when ;
 
 : join-arguments ( args -- cmd-line )
-    " " join ;
+    [ escape-argument ] map " " join ;
 
 : app-name/cmd-line ( -- app-name cmd-line )
     +command+ get [
@@ -118,11 +118,22 @@ TUPLE: CreateProcess-args
 : inherited-stderr ( args -- handle )
     drop STD_ERROR_HANDLE GetStdHandle ;
 
+: duplicate-handle ( handle -- handle )
+    GetCurrentProcess
+    swap
+    GetCurrentProcess
+    f <void*> [
+        0
+        TRUE
+        DUPLICATE_SAME_ACCESS
+        DuplicateHandle win32-error=0/f
+    ] keep *void* ;
+
 : redirect-stderr ( args -- handle )
     +stderr+ get
     dup +stdout+ eq? [
         drop
-        CreateProcess-args-lpStartupInfo
+        CreateProcess-args-lpStartupInfo duplicate-handle
         STARTUPINFO-hStdOutput
     ] [
         GENERIC_WRITE CREATE_ALWAYS redirect
@@ -162,6 +173,10 @@ M: windows-io run-process* ( desc -- handle )
         ] with-descriptor
     ] with-destructors ;
 
+M: windows-io kill-process* ( handle -- )
+    PROCESS_INFORMATION-hProcess
+    255 TerminateProcess win32-error=0/f ;
+
 : dispose-process ( process-information -- )
     #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
     #! with CloseHandle when they are no longer needed."

extra/unix/unix.factor

@@ -168,9 +168,10 @@ FUNCTION: time_t time ( time_t* t ) ;
 FUNCTION: int unlink ( char* path ) ;
 FUNCTION: int utimes ( char* path, timeval[2] times ) ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: SIGKILL 9 ; inline
-! wait and waitpid
+: SIGTERM 15 ; inline
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+FUNCTION: int kill ( pid_t pid, int sig ) ;
 
 ! Flags for waitpid
 

extra/windows/kernel32/kernel32.factor

@@ -707,7 +707,19 @@ FUNCTION: BOOL DeleteFileW ( LPCTSTR lpFileName ) ;
 ! FUNCTION: DosPathToSessionPathA
 ! FUNCTION: DosPathToSessionPathW
 ! FUNCTION: DuplicateConsoleHandle
-! FUNCTION: DuplicateHandle
+
+FUNCTION: BOOL DuplicateHandle (
+    HANDLE hSourceProcessHandle,
+    HANDLE hSourceHandle,
+    HANDLE hTargetProcessHandle,
+    LPHANDLE lpTargetHandle,
+    DWORD dwDesiredAccess,
+    BOOL bInheritHandle,
+    DWORD dwOptions ) ;
+
+: DUPLICATE_CLOSE_SOURCE 1 ;
+: DUPLICATE_SAME_ACCESS 2 ;
+
 ! FUNCTION: EncodePointer
 ! FUNCTION: EncodeSystemPointer
 ! FUNCTION: EndUpdateResourceA
@@ -1453,7 +1465,7 @@ FUNCTION: DWORD SleepEx ( DWORD dwMilliSeconds, BOOL bAlertable ) ;
 FUNCTION: BOOL SystemTimeToFileTime ( SYSTEMTIME* lpSystemTime, LPFILETIME lpFileTime ) ;
 ! FUNCTION: SystemTimeToTzSpecificLocalTime
 ! FUNCTION: TerminateJobObject
-! FUNCTION: TerminateProcess
+FUNCTION: BOOL TerminateProcess ( HANDLE hProcess, DWORD uExit ) ;
 ! FUNCTION: TerminateThread
 ! FUNCTION: TermsrvAppInstallMode
 ! FUNCTION: Thread32First

vm/os-genunix.c

@@ -21,7 +21,8 @@ const char *default_image_path(void)
 	if(!path)
 		return "factor.image";
 
-	char *new_path = safe_realloc(path,PATH_MAX + strlen(SUFFIX) + 1);
+	char *new_path = safe_malloc(PATH_MAX + strlen(SUFFIX) + 1);
+	memcpy(new_path,path,strlen(path) + 1);
 	strcat(new_path,SUFFIX); 
 	return new_path;
 }

vm/utilities.c

@@ -8,13 +8,6 @@ void *safe_malloc(size_t size)
 	return ptr;
 }
 
-void *safe_realloc(const void *ptr, size_t size)
-{
-	void *new_ptr = realloc((void *)ptr,size);
-	if(!new_ptr) fatal_error("Out of memory in safe_realloc", 0);
-	return new_ptr;
-}
-
 F_CHAR *safe_strdup(const F_CHAR *str)
 {
 	F_CHAR *ptr = STRDUP(str);

vm/utilities.h

@@ -1,3 +1,2 @@
 void *safe_malloc(size_t size);
-void *safe_realloc(const void *ptr, size_t size);
 F_CHAR *safe_strdup(const F_CHAR *str);