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

db4
Slava Pestov 2008-02-03 14:52:37 -06:00
commit 5a23bede54
16 changed files with 81 additions and 39 deletions

View File

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

View File

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

View File

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

4
core/generic/math/math.factor Normal file → Executable file
View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

3
vm/os-genunix.c Normal file → Executable file
View File

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

7
vm/utilities.c Normal file → Executable file
View File

@ -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
vm/utilities.h Normal file → Executable file
View File

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