Merge branch 'master' of git://factorcode.org/git/factor
commit
5a23bede54
|
@ -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
|
||||
|
||||
[ ] [
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
: <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 ;
|
||||
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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);
|
||||
|
|
Loading…
Reference in New Issue