From 1dbd54293c7775ebf866c9d415603b8d15a17eaf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Feb 2008 14:19:07 -0600 Subject: [PATCH 1/4] Clean up generic words a little bit --- core/definitions/definitions-tests.factor | 2 +- core/generic/generic-docs.factor | 4 ++-- core/generic/generic.factor | 14 +++++--------- core/generic/math/math.factor | 4 ++-- core/slots/slots.factor | 2 +- core/syntax/syntax.factor | 2 +- 6 files changed, 12 insertions(+), 16 deletions(-) mode change 100644 => 100755 core/generic/math/math.factor diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index 13172c0ada..a4cb4de902 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -11,7 +11,7 @@ SYMBOL: generic-1 [ generic-1 T{ combination-1 } define-generic - [ ] object \ generic-1 define-method + [ ] object \ generic-1 define-method ] with-compilation-unit [ ] [ diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 9dfc40a869..f1cdae1c91 100755 --- a/core/generic/generic-docs.factor +++ b/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 diff --git a/core/generic/generic.factor b/core/generic/generic.factor index bde5fd31af..c75dd41d74 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -39,11 +39,6 @@ TUPLE: method loc def ; : ( 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 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 ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor old mode 100644 new mode 100755 index 912ece3a30..d5079c5dfb --- a/core/generic/math/math.factor +++ b/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 - [ ] [ [ no-math-method ] curry [ ] like ] ?if ; + over method + [ method-def ] [ [ no-math-method ] curry [ ] like ] ?if ; : object-method ( generic -- quot ) object bootstrap-word applicable-method ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index cd523b05c1..40f0dd3da1 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -10,7 +10,7 @@ TUPLE: slot-spec type name offset reader writer ; C: slot-spec : define-typecheck ( class generic quot -- ) - 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 ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 006f1a225f..67799b92ea 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -126,7 +126,7 @@ IN: bootstrap.syntax f set-word location >r scan-word bootstrap-word scan-word - [ parse-definition -rot define-method ] 2keep + [ parse-definition -rot define-method ] 2keep 2array r> remember-definition ] define-syntax From d92361286da46186e4dd961dd03dde288e0b38c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Feb 2008 14:23:14 -0600 Subject: [PATCH 2/4] Add kill-process and flesh out inotify --- extra/io/launcher/launcher-docs.factor | 11 +++++++++++ extra/io/launcher/launcher.factor | 5 +++++ extra/io/unix/launcher/launcher.factor | 6 +++++- extra/io/unix/linux/linux.factor | 15 ++++++++++----- extra/io/windows/launcher/launcher.factor | 8 ++++++-- extra/unix/unix.factor | 7 ++++--- extra/windows/kernel32/kernel32.factor | 2 +- 7 files changed, 42 insertions(+), 12 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 072cfcf959..c30516a83f 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/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 } { $subsection with-process-stream } diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 9fb24fb51a..09a77fe985 100755 --- a/extra/io/launcher/launcher.factor +++ b/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 ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 0135b55a7e..030583dbe8 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/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 ] with-descriptor ; +M: unix-io kill-process* ( pid -- ) + SIGTERM kill io-error ; + : open-pipe ( -- pair ) 2 "int" dup pipe zero? [ 2 c-int-array> ] [ drop f ] if ; diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 01d6159e45..9751cefe91 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -21,8 +21,11 @@ TUPLE: linux-monitor path wd callback ; TUPLE: inotify watches ; -: wd>path ( wd -- path ) - inotify get-global inotify-watches at linux-monitor-path ; +: watches ( -- assoc ) inotify get-global inotify-watches ; + +: wd>monitor ( wd -- monitor ) watches at ; + +: wd>path ( wd -- path ) wd>monitor linux-monitor-path ; : ( -- 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 ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index ec53d9152c..ad84be0825 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/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 [ @@ -162,6 +162,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." diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index f5c484568e..bcfbb3a214 100755 --- a/extra/unix/unix.factor +++ b/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 ) ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! wait and waitpid -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: SIGKILL 9 ; inline +: SIGTERM 15 ; inline + +FUNCTION: int kill ( pid_t pid, int sig ) ; ! Flags for waitpid diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 77c7666bfd..b0c2d85598 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -1453,7 +1453,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 From 9d0d371efc1159aa26f5350a305108968aad4a87 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Feb 2008 14:47:44 -0600 Subject: [PATCH 3/4] Minor fix for Windows +stderr+ = +stdout+ --- extra/io/windows/launcher/launcher.factor | 13 ++++++++++++- extra/windows/kernel32/kernel32.factor | 14 +++++++++++++- 2 files changed, 25 insertions(+), 2 deletions(-) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index ad84be0825..3d0c2feac1 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -118,11 +118,22 @@ TUPLE: CreateProcess-args : inherited-stderr ( args -- handle ) drop STD_ERROR_HANDLE GetStdHandle ; +: duplicate-handle ( handle -- handle ) + GetCurrentProcess + swap + GetCurrentProcess + f [ + 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 diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index b0c2d85598..45bd6bfae9 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/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 From 62bbb0597ee1f9fd621f5eb6b34aa7af4f60e67c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Feb 2008 14:51:35 -0600 Subject: [PATCH 4/4] Fix dodgy memory management --- vm/os-genunix.c | 3 ++- vm/utilities.c | 7 ------- vm/utilities.h | 1 - 3 files changed, 2 insertions(+), 9 deletions(-) mode change 100644 => 100755 vm/os-genunix.c mode change 100644 => 100755 vm/utilities.c mode change 100644 => 100755 vm/utilities.h diff --git a/vm/os-genunix.c b/vm/os-genunix.c old mode 100644 new mode 100755 index 92598eec41..a0bd3e05ae --- a/vm/os-genunix.c +++ b/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; } diff --git a/vm/utilities.c b/vm/utilities.c old mode 100644 new mode 100755 index 60a4ecb268..ebc8e87977 --- a/vm/utilities.c +++ b/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); diff --git a/vm/utilities.h b/vm/utilities.h old mode 100644 new mode 100755 index 483e395345..89a8ba57a3 --- a/vm/utilities.h +++ b/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);