mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-14 13:21:54 -08:00
Code Issues Projects Releases Packages Wiki Activity

Unify the sources for windows and posix threads

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2008-10-11 11:38:15 +02:00
parent 8a3350f180
commit cbe49afc5b
12 changed files with 387 additions and 687 deletions
Download patch file Download diff file Expand all files Collapse all files

2
msvc/c/Makefile
View file

@ -5,7 +5,7 @@ top_srcdir = ..\..\src
srcdir = ..\..\src\c
!if "$(ECL_THREADS)" != ""
THREADS_OBJ= threads_win32.obj
THREADS_OBJ= threads.obj
THREADS_FLAGS= -DECL_THREADS
!else
THREADS_OBJ=

15
src/c/alloc_2.d
View file

@ -522,26 +522,15 @@ ecl_mark_env(struct cl_env_struct *env)
GC_set_mark_bit((void *)env->bds_org);
}
#endif
#if 0
GC_push_all(&(env->lex_env), &(env->lex_env)+1);
GC_push_all(&(env->string_pool), &(env->print_base));
#if !defined(ECL_CMU_FORMAT)
GC_push_all(&(env->queue), &(env->qh));
#endif
GC_push_all(env->big_register, env->big_register + 3);
if (env->nvalues)
GC_push_all(env->values, env->values + env->nvalues + 1);
#else
/*memset(env->values[env->nvalues], 0, (64-env->nvalues)*sizeof(cl_object));*/
#ifdef ECL_THREADS
#if defined(ECL_THREADS) && !defined(ECL_USE_MPROTECT)
/* When using threads, "env" is a pointer to memory allocated by ECL. */
GC_push_conditional((void *)env, (void *)(env + 1), 1);
GC_set_mark_bit((void *)env);
#else
/* When not using threads, "env" is a statically allocated structure. */
/* When not using threads, "env" is mmaped or statically allocated. */
GC_push_all((void *)env, (void *)(env + 1));
#endif
#endif
}
static void

10
src/c/big.d
View file

@ -281,18 +281,18 @@ mp_free(void *ptr, size_t size)
cl_dealloc(x);
}
void init_big_registers(void)
void init_big_registers(cl_env_ptr env)
{
int i;
for (i = 0; i < 3; i++) {
cl_env.big_register[i] = ecl_alloc_object(t_bignum);
big_register_free(cl_env.big_register[i]);
env->big_register[i] = ecl_alloc_object(t_bignum);
big_register_free(env->big_register[i]);
}
}
void
init_big(void)
init_big(cl_env_ptr env)
{
init_big_registers();
init_big_registers(env);
mp_set_memory_functions(mp_alloc, mp_realloc, mp_free);
}

9
src/c/main.d
View file

@ -204,13 +204,14 @@ _ecl_alloc_env()
{
cl_env_ptr output;
#if defined(ECL_USE_MPROTECT)
output = mmap(0, sizeof(*cl_env_p), PROT_READ | PROT_WRITE,
output = mmap(0, sizeof(*output), PROT_READ | PROT_WRITE,
MAP_ANON | MAP_PRIVATE, 0, 0);
if (output < 0)
ecl_internal_error("Unable to allocate environment structure.");
#else
output = ecl_alloc(sizeof(*cl_env_p));
output = ecl_alloc(sizeof(*output));
#endif
output->disable_interrupts = 1;
return output;
}
@ -273,10 +274,6 @@ cl_boot(int argc, char **argv)
init_threads(cl_env_p);
#endif
#if !defined(MSDOS) && !defined(cygwin)
ecl_self = ecl_expand_pathname(ecl_self);
#endif
/*
* 1) Initialize symbols and packages
*/

2
src/c/number.d
View file

@ -612,7 +612,7 @@ init_number(void)
ECL_SET(@'pi', ecl_make_doublefloat((double)ECL_PI_D));
#endif
init_big();
init_big(&cl_env);
ECL_SET(@'*random-state*', ecl_make_random_state(Ct));
}

1
src/c/symbols_list.h
View file

@ -1489,7 +1489,6 @@ cl_symbols[] = {
{MP_ "+LOAD-COMPILE-LOCK+", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "WITH-LOCK", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "WITHOUT-INTERRUPTS", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "CHECK-PENDING-INTERRUPTS", SI_ORDINARY, si_check_pending_interrupts, 0, OBJNULL},
#endif
{SYS_ "WHILE", SI_ORDINARY, NULL, -1, OBJNULL},

1
src/c/symbols_list2.h
View file

@ -1489,7 +1489,6 @@ cl_symbols[] = {
{MP_ "+LOAD-COMPILE-LOCK+",NULL},
{MP_ "WITH-LOCK",NULL},
{MP_ "WITHOUT-INTERRUPTS",NULL},
{MP_ "CHECK-PENDING-INTERRUPTS","si_check_pending_interrupts"},
#endif
{SYS_ "WHILE",NULL},

198
src/c/threads.d
View file

@ -31,11 +31,29 @@
# include <sched.h>
#endif
#if defined(_MSVC) || defined(mingw32)
#define ECL_WINDOWS_THREADS
/*
* We have to put this explicit definition here because Boehm GC
* is designed to produce a DLL and we rather want a static
* reference
*/
#include <windows.h>
#include <gc.h>
extern HANDLE WINAPI GC_CreateThread(
LPSECURITY_ATTRIBUTES lpThreadAttributes,
DWORD dwStackSize, LPTHREAD_START_ROUTINE lpStartAddress,
LPVOID lpParameter, DWORD dwCreationFlags, LPDWORD lpThreadId );
#ifndef WITH___THREAD
DWORD cl_env_key;
#endif
static DWORD main_thread;
#else
#ifndef WITH___THREAD
static pthread_key_t cl_env_key;
#endif
static pthread_t main_thread;
#endif
extern void ecl_init_env(struct cl_env_struct *env);
@ -43,11 +61,15 @@ extern void ecl_init_env(struct cl_env_struct *env);
struct cl_env_struct *
ecl_process_env(void)
{
#ifdef ECL_WINDOWS_THREADS
return TlsGetValue(cl_env_key);
#else
struct cl_env_struct *rv = pthread_getspecific(cl_env_key);
if (rv)
return rv;
FElibc_error("pthread_getspecific() failed.", 0);
return NULL;
#endif
}
#endif
@ -90,16 +112,22 @@ thread_cleanup(void *env)
static void *
thread_entry_point(cl_object process)
{
cl_env_ptr env = process->process.env;
/* 1) Setup the environment for the execution of the thread */
pthread_cleanup_push(thread_cleanup, (void *)process->process.env);
pthread_cleanup_push(thread_cleanup, (void *)env);
ecl_init_env(env);
init_big_registers(env);
#ifdef WITH___THREAD
cl_env_p = process->process.env;
cl_env_p = env;
#else
if (pthread_setspecific(cl_env_key, process->process.env))
# ifdef ECL_WINDOWS_THREADS
TlsSetValue(cl_env_key, env);
# else
if (pthread_setspecific(cl_env_key, env))
FElibc_error("pthread_setcspecific() failed.", 0);
# endif
#endif
ecl_init_env(process->process.env);
init_big_registers();
/* 2) Execute the code. The CATCH_ALL point is the destination
* provides us with an elegant way to exit the thread: we just
@ -116,8 +144,13 @@ thread_entry_point(cl_object process)
/* 3) If everything went right, we should be exiting the thread
* through this point. thread_cleanup is automatically invoked.
*/
#ifdef ECL_WINDOWS_THREADS
thread_cleanup(env);
return 1;
#else
pthread_cleanup_pop(1);
return NULL;
#endif
}
static cl_object
@ -155,15 +188,21 @@ void
ecl_import_current_thread(cl_object name, cl_object bindings)
{
cl_object process = alloc_process(name);
#ifdef WITH___THREAD
cl_env_p = process->process.env;
#else
if (pthread_setspecific(cl_env_key, process->process.env))
FElibc_error("pthread_setcspecific() failed.", 0);
#endif
cl_env_ptr env = process->process.env;
initialize_process_bindings(process, bindings);
ecl_init_env(&cl_env);
init_big_registers();
ecl_init_env(env);
init_big_registers(env);
ecl_enable_interrupts_env(env);
#ifdef WITH___THREAD
cl_env_p = env;
#else
# ifdef ECL_WINDOWS_THREADS
TlsSetValue(cl_env_key, env);
# else
if (pthread_setspecific(cl_env_key, env))
FElibc_error("pthread_setcspecific() failed.", 0);
# endif
#endif
}
void
@ -198,17 +237,34 @@ mp_interrupt_process(cl_object process, cl_object function)
{
if (mp_process_active_p(process) == Cnil)
FEerror("Cannot interrupt the inactive process ~A", 1, process);
#ifdef ECL_WINDOWS_THREADS
{
CONTEXT context;
HANDLE thread = process->process.thread;
if (SuspendThread(thread) == (DWORD)-1)
FEwin32_error("Cannot suspend process ~A", 1, process);
context.ContextFlags = CONTEXT_CONTROL | CONTEXT_INTEGER;
if (!GetThreadContext(thread, &context))
FEwin32_error("Cannot get context for process ~A", 1, process);
context.Eip = process_interrupt_handler;
if (!SetThreadContext(thread, &context))
FEwin32_error("Cannot set context for process ~A", 1, process);
process->process.interrupt = function;
if (ResumeThread(thread) == (DWORD)-1)
FEwin32_error("Cannot resume process ~A", 1, process);
}
#else
process->process.interrupt = function;
if ( pthread_kill(process->process.thread, SIGUSR1) )
FElibc_error("pthread_kill() failed.", 0);
#endif
@(return Ct)
}
cl_object
mp_process_kill(cl_object process)
{
mp_interrupt_process(process, @'mp::exit-process');
@(return Ct)
return mp_interrupt_process(process, @'mp::exit-process');
}
cl_object
@ -217,7 +273,11 @@ mp_process_yield(void)
#ifdef HAVE_SCHED_YIELD
sched_yield();
#else
# if defined(_MSVC) || defined(mingw32)
Sleep(0);
# else
sleep(0); /* Use sleep(0) to yield to a >= priority thread */
# endif
#endif
@(return)
}
@ -225,6 +285,25 @@ mp_process_yield(void)
cl_object
mp_process_enable(cl_object process)
{
cl_object output;
#ifdef ECL_WINDOWS_THREADS
HANDLE code;
DWORD threadId;
if (mp_process_active_p(process) != Cnil)
FEerror("Cannot enable the running process ~A.", 1, process);
THREAD_OP_LOCK();
code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId);
if (code) {
/* If everything went ok, add the thread to the list. */
cl_core.processes = CONS(process, cl_core.processes);
output = process;
} else {
output = Cnil;
}
process->process.thread = code;
THREAD_OP_UNLOCK();
#else
pthread_t *posix_thread;
int code;
@ -232,18 +311,27 @@ mp_process_enable(cl_object process)
FEerror("Cannot enable the running process ~A.", 1, process);
THREAD_OP_LOCK();
code = pthread_create(&process->process.thread, NULL, thread_entry_point, process);
if (!code) {
if (code) {
output = Cnil;
} else {
/* If everything went ok, add the thread to the list. */
cl_core.processes = CONS(process, cl_core.processes);
output = process;
} /* FIXME: how to do FElibc_error() without leaving a lock? */
THREAD_OP_UNLOCK();
@(return (code? Cnil : process))
#endif
@(return output)
}
cl_object
mp_exit_process(void)
{
if (pthread_equal(pthread_self(), main_thread)) {
#ifdef ECL_WINDOWS_THREADS
int same = GetCurrentThreadId() == main_thread;
#else
int same = pthread_equal(pthread_self(), main_thread);
#endif
if (same) {
/* This is the main thread. Quitting it means exiting the
program. */
si_quit(0);
@ -259,7 +347,7 @@ mp_exit_process(void)
cl_object
mp_all_processes(void)
{
/* Isn't it a race condition? */
/* Isn't it a race condition? */
@(return cl_copy_list(cl_core.processes))
}
@ -310,8 +398,15 @@ mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...)
pthread_mutexattr_t attr;
cl_object output;
@
pthread_mutexattr_init(&attr);
output = ecl_alloc_object(t_lock);
#ifdef ECL_WINDOWS_THREADS
output->lock.name = name;
output->lock.mutex = CreateMutex(NULL, FALSE, NULL);
output->lock.holder = Cnil;
output->lock.counter = 0;
output->lock.recursive = (recursive != Cnil);
#else
pthread_mutexattr_init(&attr);
output->lock.name = name;
output->lock.holder = Cnil;
output->lock.counter = 0;
@ -324,6 +419,7 @@ mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...)
}
pthread_mutex_init(&output->lock.mutex, &attr);
pthread_mutexattr_destroy(&attr);
#endif
si_set_finalizer(output, Ct);
@(return output)
@)
@ -365,7 +461,12 @@ mp_giveup_lock(cl_object lock)
if (--lock->lock.counter == 0) {
lock->lock.holder = Cnil;
}
#ifdef ECL_WINDOWS_THREADS
if (ReleaseMutex(lock->lock.mutex) == 0)
FEwin32_error("Unable to release Win32 Mutex", 0);
#else
pthread_mutex_unlock(&lock->lock.mutex);
#endif
@(return Ct)
}
@ -375,10 +476,29 @@ mp_giveup_lock(cl_object lock)
@
if (type_of(lock) != t_lock)
FEwrong_type_argument(@'mp::lock', lock);
/* In Windows, all locks are recursive. We simulate the other case. */
/* We will complain always if recursive=0 and try to lock recursively. */
if (!lock->lock.recursive && (lock->lock.holder == cl_env.own_process)) {
FEerror("A recursive attempt was made to hold lock ~S", 1, lock);
}
#ifdef ECL_WINDOWS_THREADS
switch (WaitForSingleObject(lock->lock.mutex, (wait==Ct?INFINITE:0))) {
case WAIT_OBJECT_0:
lock->lock.holder = cl_env.own_process;
lock->lock.counter++;
output = Ct;
break;
case WAIT_TIMEOUT:
output = Cnil;
break;
case WAIT_ABANDONED:
ecl_internal_error("");
break;
case WAIT_FAILED:
FEwin32_error("Unable to lock Win32 Mutex", 0);
break;
}
#else
if (wait == Ct) {
rc = pthread_mutex_lock(&lock->lock.mutex);
} else {
@ -391,6 +511,7 @@ mp_giveup_lock(cl_object lock)
} else {
output = Cnil;
}
#endif
@(return output)
@)
@ -401,6 +522,10 @@ mp_giveup_lock(cl_object lock)
cl_object
mp_make_condition_variable(void)
{
#ifdef ECL_WINDOWS_THREADS
FEerror("Condition variables are not supported under Windows.", 0);
@(return Cnil)
#else
pthread_condattr_t attr;
cl_object output;
@ -410,11 +535,15 @@ mp_make_condition_variable(void)
pthread_condattr_destroy(&attr);
si_set_finalizer(output, Ct);
@(return output)
#endif
}
cl_object
mp_condition_variable_wait(cl_object cv, cl_object lock)
{
#ifdef ECL_WINDOWS_THREADS
FEerror("Condition variables are not supported under Windows.", 0);
#else
if (type_of(cv) != t_condition_variable)
FEwrong_type_argument(@'mp::condition-variable', cv);
if (type_of(lock) != t_lock)
@ -422,12 +551,16 @@ mp_condition_variable_wait(cl_object cv, cl_object lock)
if (pthread_cond_wait(&cv->condition_variable.cv,
&lock->lock.mutex) == 0)
lock->lock.holder = cl_env.own_process;
#endif
@(return Ct)
}
cl_object
mp_condition_variable_timedwait(cl_object cv, cl_object lock, cl_object seconds)
{
#ifdef ECL_WINDOWS_THREADS
FEerror("Condition variables are not supported under Windows.", 0);
#else
int rc;
double r;
struct timespec ts;
@ -443,7 +576,6 @@ mp_condition_variable_timedwait(cl_object cv, cl_object lock, cl_object seconds)
make_constant_base_string("Not a non-negative number ~S"),
@':format-arguments', cl_list(1, seconds),
@':expected-type', @'real', @':datum', seconds);
gettimeofday(&tp, NULL);
/* Convert from timeval to timespec */
ts.tv_sec = tp.tv_sec;
@ -464,23 +596,32 @@ mp_condition_variable_timedwait(cl_object cv, cl_object lock, cl_object seconds)
} else {
@(return Cnil)
}
#endif
}
cl_object
mp_condition_variable_signal(cl_object cv)
{
#ifdef ECL_WINDOWS_THREADS
FEerror("Condition variables are not supported under Windows.", 0);
#else
if (type_of(cv) != t_condition_variable)
FEwrong_type_argument(@'mp::condition-variable', cv);
pthread_cond_signal(&cv->condition_variable.cv);
#endif
@(return Ct)
}
cl_object
mp_condition_variable_broadcast(cl_object cv)
{
#ifdef ECL_WINDOWS_THREADS
FEerror("Condition variables are not supported under Windows.", 0);
#else
if (type_of(cv) != t_condition_variable)
FEwrong_type_argument(@'mp::condition-variable', cv);
pthread_cond_broadcast(&cv->condition_variable.cv);
#endif
@(return Ct)
}
@ -495,10 +636,14 @@ init_threads(cl_env_ptr env)
pthread_mutexattr_t attr;
cl_core.processes = OBJNULL;
#ifdef ECL_WINDOWS_THREADS
cl_core.global_lock = CreateMutex(NULL, FALSE, NULL);
#else
pthread_mutexattr_init(&attr);
pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_ERRORCHECK_NP);
pthread_mutex_init(&cl_core.global_lock, &attr);
pthread_mutexattr_destroy(&attr);
#endif
process = ecl_alloc_object(t_process);
process->process.active = 1;
@ -511,12 +656,21 @@ init_threads(cl_env_ptr env)
#ifdef WITH___THREAD
cl_env_p = env;
#else
# ifdef ECL_WINDOWS_THREADS
cl_env_key = TlsAlloc();
TlsSetValue(cl_env_key, env);
# else
pthread_key_create(&cl_env_key, NULL);
pthread_setspecific(cl_env_key, env);
# endif
#endif
env->own_process = process;
cl_core.processes = ecl_list1(process);
#ifdef ECL_WINDOWS_THREADS
main_thread = GetCurrentThreadId();
#else
main_thread = pthread_self();
#endif
}

488
src/c/threads_win32.d
View file

@ -1,488 +0,0 @@
/* -*- mode: c; c-basic-offset: 8 -*- */
/*
threads.d -- Posix threads with support from GCC.
*/
/*
Copyright (c) 2003, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
/*
* IMPORTANT!!!! IF YOU EDIT THIS FILE, CHANGE ALSO threads.d
*/
#include <signal.h>
#include <ecl/ecl.h>
#include <ecl/internal.h>
#ifdef HAVE_SCHED_YIELD
# include <sched.h>
#endif
/*
* We have to put this explicit definition here because Boehm GC
* is designed to produce a DLL and we rather want a static
* reference
*/
#include <windows.h>
#include <gc.h>
extern HANDLE WINAPI GC_CreateThread(
LPSECURITY_ATTRIBUTES lpThreadAttributes,
DWORD dwStackSize, LPTHREAD_START_ROUTINE lpStartAddress,
LPVOID lpParameter, DWORD dwCreationFlags, LPDWORD lpThreadId );
#ifndef WITH___THREAD
DWORD cl_env_key;
#endif
static DWORD main_thread;
extern void ecl_init_env(struct cl_env_struct *env);
#ifndef WITH___THREAD
struct cl_env_struct *
ecl_process_env(void)
{
return TlsGetValue(cl_env_key);
}
#endif
cl_object
mp_current_process(void)
{
return cl_env.own_process;
}
/*----------------------------------------------------------------------
* THREAD OBJECT
*/
static void
assert_type_process(cl_object o)
{
if (type_of(o) != t_process)
FEwrong_type_argument(@'mp::process', o);
}
static void
thread_cleanup(void *env)
{
/* This routine performs some cleanup before a thread is completely
* killed. For instance, it has to remove the associated process
* object from the list, an it has to dealloc some memory.
*
* NOTE: thread_cleanup() does not provide enough "protection". In
* order to ensure that all UNWIND-PROTECT forms are properly
* executed, never use pthread_cancel() to kill a process, but
* rather use the lisp functions mp_interrupt_process() and
* mp_process_kill().
*/
THREAD_OP_LOCK();
cl_core.processes = ecl_remove_eq(cl_env.own_process,
cl_core.processes);
THREAD_OP_UNLOCK();
}
static DWORD WINAPI
thread_entry_point(cl_object process)
{
/* 1) Setup the environment for the execution of the thread */
#ifdef WITH___THREAD
cl_env_p = process->process.env
#else
TlsSetValue(cl_env_key, (void *)process->process.env);
#endif
ecl_init_env(process->process.env);
init_big_registers();
/* 2) Execute the code. The CATCH_ALL point is the destination
* provides us with an elegant way to exit the thread: we just
* do an unwind up to frs_top.
*/
process->process.active = 1;
CL_CATCH_ALL_BEGIN {
bds_bind(@'mp::*current-process*', process);
cl_apply(2, process->process.function, process->process.args);
bds_unwind1();
} CL_CATCH_ALL_END;
process->process.active = 0;
/* 3) If everything went right, we should be exiting the thread
* through this point.
*/
thread_cleanup(&cl_env);
return 1;
}
static cl_object
alloc_process(cl_object name)
{
cl_object process = ecl_alloc_object(t_process);
process->process.active = 0;
process->process.name = name;
process->process.function = Cnil;
process->process.args = Cnil;
process->process.interrupt = Cnil;
process->process.env = ecl_alloc(sizeof(*process->process.env));
process->process.env->own_process = process;
return process;
}
static void
initialize_process_bindings(cl_object process, cl_object initial_bindings)
{
cl_object hash;
/* FIXME! Here we should either use INITIAL-BINDINGS or copy lexical
* bindings */
if (initial_bindings != OBJNULL) {
hash = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024),
ecl_make_singlefloat(1.5),
ecl_make_singlefloat(0.7),
Cnil); /* no need for locking */
} else {
hash = si_copy_hash_table(cl_env.bindings_hash);
}
process->process.env->bindings_hash = hash;
}
void
ecl_import_current_thread(cl_object name, cl_object bindings)
{
cl_object process = alloc_process(name);
#ifdef WITH___THREAD
cl_env_p = process->process.env;
#else
TlsSetValue(cl_env_key, (void *)process->process.env);
#endif
initialize_process_bindings(process, bindings);
ecl_init_env(&cl_env);
init_big_registers();
}
void
ecl_release_current_thread(void)
{
thread_cleanup(&cl_env);
}
@(defun mp::make-process (&key name ((:initial-bindings initial_bindings) Ct))
cl_object process;
@
process = alloc_process(name);
initialize_process_bindings(process, initial_bindings);
@(return process)
@)
cl_object
mp_process_preset(cl_narg narg, cl_object process, cl_object function, ...)
{
cl_va_list args;
cl_va_start(args, function, narg, 2);
if (narg < 2)
FEwrong_num_arguments(@'mp::process-preset');
assert_type_process(process);
process->process.function = function;
process->process.args = cl_grab_rest_args(args);
@(return process)
}
static void
process_interrupt_handler(void)
{
funcall(1, ecl_process_env()->own_process->process.interrupt);
}
cl_object
mp_interrupt_process(cl_object process, cl_object function)
{
CONTEXT context;
HANDLE thread = process->process.thread;
if (mp_process_active_p(process) == Cnil)
FEerror("Cannot interrupt the inactive process ~A", 1, process);
if (SuspendThread(thread) == (DWORD)-1)
FEwin32_error("Cannot suspend process ~A", 1, process);
context.ContextFlags = CONTEXT_CONTROL | CONTEXT_INTEGER;
if (!GetThreadContext(thread, &context))
FEwin32_error("Cannot get context for process ~A", 1, process);
context.Eip = process_interrupt_handler;
if (!SetThreadContext(thread, &context))
FEwin32_error("Cannot set context for process ~A", 1, process);
process->process.interrupt = function;
if (ResumeThread(thread) == (DWORD)-1)
FEwin32_error("Cannot resume process ~A", 1, process);
@(return Ct)
}
cl_object
mp_process_kill(cl_object process)
{
return mp_interrupt_process(process, @'mp::exit-process');
}
cl_object
mp_process_yield(void)
{
#ifdef HAVE_SCHED_YIELD
sched_yield();
#else
Sleep(0); /* Use sleep(0) to yield to a >= priority thread */
#endif
@(return)
}
cl_object
mp_process_enable(cl_object process)
{
HANDLE code;
DWORD threadId;
if (mp_process_active_p(process) != Cnil)
FEerror("Cannot enable the running process ~A.", 1, process);
THREAD_OP_LOCK();
code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId);
if (code) {
/* If everything went ok, add the thread to the list. */
cl_core.processes = CONS(process, cl_core.processes);
}
process->process.thread = code;
THREAD_OP_UNLOCK();
@(return (code==NULL ? Cnil : process))
}
cl_object
mp_exit_process(void)
{
if (GetCurrentThreadId() == main_thread) {
/* This is the main thread. Quitting it means exiting the
program. */
si_quit(0);
} else {
/* We simply undo the whole of the frame stack. This brings up
back to the thread entry point, going through all possible
UNWIND-PROTECT.
*/
ecl_unwind(cl_env.frs_org);
}
}
cl_object
mp_all_processes(void)
{
@(return cl_copy_list(cl_core.processes))
}
cl_object
mp_process_name(cl_object process)
{
assert_type_process(process);
@(return process->process.name)
}
cl_object
mp_process_active_p(cl_object process)
{
assert_type_process(process);
@(return (process->process.active? Ct : Cnil))
}
cl_object
mp_process_whostate(cl_object process)
{
assert_type_process(process);
@(return (cl_core.null_string))
}
cl_object
mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...)
{
cl_object process;
cl_va_list args;
cl_va_start(args, function, narg, 2);
if (narg < 2)
FEwrong_num_arguments(@'mp::process-run-function');
if (CONSP(name)) {
process = cl_apply(2, @'mp::make-process', name);
} else {
process = mp_make_process(2, @':name', name);
}
cl_apply(4, @'mp::process-preset', process, function,
cl_grab_rest_args(args));
return mp_process_enable(process);
}
/*----------------------------------------------------------------------
* LOCKS or MUTEX
*/
@(defun mp::make-lock (&key name ((:recursive recursive) Ct))
cl_object output;
@
output = ecl_alloc_object(t_lock);
output->lock.name = name;
output->lock.mutex = CreateMutex(NULL, FALSE, NULL);
output->lock.holder = Cnil;
output->lock.counter = 0;
output->lock.recursive = (recursive != Cnil);
si_set_finalizer(output, Ct);
@(return output)
@)
cl_object
mp_recursive_lock_p(cl_object lock)
{
if (type_of(lock) != t_lock)
FEwrong_type_argument(@'mp::lock', lock);
@(return (lock->lock.recursive? Ct : Cnil))
}
cl_object
mp_lock_name(cl_object lock)
{
if (type_of(lock) != t_lock)
FEwrong_type_argument(@'mp::lock', lock);
@(return lock->lock.name)
}
cl_object
mp_lock_holder(cl_object lock)
{
if (type_of(lock) != t_lock)
FEwrong_type_argument(@'mp::lock', lock);
@(return lock->lock.holder)
}
cl_object
mp_giveup_lock(cl_object lock)
{
if (type_of(lock) != t_lock)
FEwrong_type_argument(@'mp::lock', lock);
if (lock->lock.holder != cl_env.own_process) {
FEerror("Attempt to give up a lock ~S that is not owned by ~S.", 2,
lock, cl_env.own_process);
}
if (--lock->lock.counter == 0) {
lock->lock.holder = Cnil;
}
if (ReleaseMutex(lock->lock.mutex) == 0)
FEwin32_error("Unable to release Win32 Mutex", 0);
@(return Ct)
}
@(defun mp::get-lock (lock &optional (wait Ct))
cl_object output;
@
if (type_of(lock) != t_lock)
FEwrong_type_argument(@'mp::lock', lock);
/* In Windows, all locks are recursive. We simulate the other case. */
if (!lock->lock.recursive && (lock->lock.holder == cl_env.own_process)) {
FEerror("A recursive attempt was made to hold lock ~S", 1, lock);
}
switch (WaitForSingleObject(lock->lock.mutex, (wait==Ct?INFINITE:0))) {
case WAIT_OBJECT_0:
lock->lock.holder = cl_env.own_process;
lock->lock.counter++;
output = Ct;
break;
case WAIT_TIMEOUT:
output = Cnil;
break;
case WAIT_ABANDONED:
ecl_internal_error("");
break;
case WAIT_FAILED:
FEwin32_error("Unable to lock Win32 Mutex", 0);
break;
}
@(return output)
@)
/*----------------------------------------------------------------------
* CONDITION VARIABLES
*/
cl_object
mp_make_condition_variable(void)
{
FEerror("Condition variables are not supported under Windows.", 0);
@(return Cnil)
}
cl_object
mp_condition_variable_wait(cl_object cv, cl_object lock)
{
if (type_of(cv) != t_condition_variable)
FEwrong_type_argument(@'mp::condition-variable', cv);
if (type_of(lock) != t_lock)
FEwrong_type_argument(@'mp::lock', lock);
FEerror("Condition variables are not supported under Windows.", 0);
@(return Ct)
}
cl_object
mp_condition_variable_timedwait(cl_object cv, cl_object lock, cl_object seconds)
{
if (type_of(cv) != t_condition_variable)
FEwrong_type_argument(@'mp::condition-variable', cv);
if (type_of(lock) != t_lock)
FEwrong_type_argument(@'mp::lock', lock);
FEerror("Condition variables are not supported under Windows.", 0);
@(return Cnil)
}
cl_object
mp_condition_variable_signal(cl_object cv)
{
if (type_of(cv) != t_condition_variable)
FEwrong_type_argument(@'mp::condition-variable', cv);
FEerror("Condition variables are not supported under Windows.", 0);
@(return Ct)
}
cl_object
mp_condition_variable_broadcast(cl_object cv)
{
if (type_of(cv) != t_condition_variable)
FEwrong_type_argument(@'mp::condition-variable', cv);
FEerror("Condition variables are not supported under Windows.", 0);
@(return Ct)
}
/*----------------------------------------------------------------------
* INITIALIZATION
*/
void
init_threads()
{
cl_object process;
struct cl_env_struct *env;
GC_INIT();
cl_core.processes = OBJNULL;
cl_core.global_lock = CreateMutex(NULL, FALSE, NULL);
process = ecl_alloc_object(t_process);
process->process.active = 1;
process->process.name = @'si::top-level';
process->process.function = Cnil;
process->process.args = Cnil;
process->process.thread = GetCurrentThread();
process->process.env = env = (struct cl_env_struct*)ecl_alloc(sizeof(*env));
#ifdef WITH___THREAD
cl_env_p = env
#else
cl_env_key = TlsAlloc();
TlsSetValue(cl_env_key, env);
#endif
env->own_process = process;
cl_core.processes = CONS(process, Cnil);
main_thread = GetCurrentThreadId();
}

343
src/c/unixfsys.d
View file

@ -50,6 +50,38 @@
#endif
#include <errno.h>
static int
safe_chdir(const char *path)
{
int output;
ecl_disable_interrupts();
output = chdir(path);
ecl_enable_interrupts();
return output;
}
static int
safe_stat(const char *path, struct stat *sb)
{
int output;
ecl_disable_interrupts();
output = stat(path, sb);
ecl_enable_interrupts();
return output;
}
#ifdef HAVE_LSTAT
static int
safe_lstat(const char *path, struct stat *sb)
{
int output;
ecl_disable_interrupts();
output = lstat(path, sb);
ecl_enable_interrupts();
return output;
}
#endif
#if defined(_MSC_VER) || defined(mingw32)
static void
change_drive(cl_object pathname)
@ -57,7 +89,7 @@ change_drive(cl_object pathname)
if (pathname->pathname.device != Cnil) {
char device[3] = {'\0', ':', '\0'};
device[0] = pathname->pathname.device->base_string.self[0];
if (chdir(device) < 0) {
if (safe_chdir(device) < 0) {
FElibc_error("Can't change the current drive to ~S",
1, pathname->pathname.device);
}
@ -91,16 +123,18 @@ current_dir(void) {
cl_index size = 128;
do {
output = cl_alloc_adjustable_base_string(size);
ok = getcwd(output->base_string.self, size);
size += 256;
output = cl_alloc_adjustable_base_string(size);
ecl_disable_interrupts();
ok = getcwd(output->base_string.self, size);
ecl_enable_interrupts();
size += 256;
} while(ok == NULL);
size = strlen(output->base_string.self);
if ((size + 1 /* / */ + 1 /* 0 */) >= output->base_string.dim) {
/* Too large to host the trailing '/' */
cl_object other = cl_alloc_adjustable_base_string(size+2);
strcpy(other->base_string.self, output->base_string.self);
output = other;
/* Too large to host the trailing '/' */
cl_object other = cl_alloc_adjustable_base_string(size+2);
strcpy(other->base_string.self, output->base_string.self);
output = other;
}
#ifdef _MSC_VER
for (c=output->base_string.self; *c; c++)
@ -121,32 +155,38 @@ current_dir(void) {
static cl_object
file_kind(char *filename, bool follow_links) {
cl_object output;
#if defined(_MSC_VER) || defined(mingw32)
DWORD dw = GetFileAttributes( filename );
DWORD dw;
ecl_disable_interrupts();
dw = GetFileAttributes( filename );
if (dw == -1)
return Cnil;
output = Cnil;
else if ( dw & FILE_ATTRIBUTE_DIRECTORY )
return @':directory';
output = @':directory';
else
return @':file';
output = @':file';
ecl_enable_interrupts();
#else
struct stat buf;
#ifdef HAVE_LSTAT
if ((follow_links? stat : lstat)(filename, &buf) < 0)
#else
if (stat(filename, &buf) < 0)
#endif
return Cnil;
#ifdef HAVE_LSTAT
if (S_ISLNK(buf.st_mode))
return @':link';
#endif
if (S_ISDIR(buf.st_mode))
return @':directory';
if (S_ISREG(buf.st_mode))
return @':file';
return @':special';
# ifdef HAVE_LSTAT
if ((follow_links? safe_stat : safe_lstat)(filename, &buf) < 0)
# else
if (safe_stat(filename, &buf) < 0)
# endif
output = Cnil;
# ifdef HAVE_LSTAT
else if (S_ISLNK(buf.st_mode))
output = @':link';
# endif
else if (S_ISDIR(buf.st_mode))
output = @':directory';
else if (S_ISREG(buf.st_mode))
output = @':file';
else
output = @':special';
#endif
return output;
}
cl_object
@ -164,7 +204,10 @@ si_readlink(cl_object filename) {
cl_object output, kind;
do {
output = cl_alloc_adjustable_base_string(size);
written = readlink(filename->base_string.self, output->base_string.self, size);
ecl_disable_interrupts();
written = readlink(filename->base_string.self,
output->base_string.self, size);
ecl_enable_interrupts();
size += 256;
} while(written == size);
output->base_string.self[written] = '\0';
@ -227,17 +270,17 @@ cl_truename(cl_object orig_pathname)
{
cl_object part = CAR(dir);
if (type_of(part) == t_base_string) {
if (chdir(part->base_string.self) < 0) {
if (safe_chdir(part->base_string.self) < 0) {
ERROR: FElibc_error("Can't change the current directory to ~S",
1, pathname);
}
} else if (part == @':absolute') {
if (chdir("/") < 0)
if (safe_chdir("/") < 0)
goto ERROR;
} else if (part == @':relative') {
/* Nothing to do */
} else if (part == @':up') {
if (chdir("..") < 0)
if (safe_chdir("..") < 0)
goto ERROR;
} else {
FEerror("~S is not allowed in TRUENAME", 1, part);
@ -253,7 +296,7 @@ ERROR: FElibc_error("Can't change the current directory to ~S",
#endif
pathname = ecl_merge_pathnames(si_getcwd(0), pathname, @':newest');
} CL_UNWIND_PROTECT_EXIT {
chdir(previous->base_string.self);
safe_chdir(previous->base_string.self);
} CL_UNWIND_PROTECT_END;
@(return pathname)
@ -268,14 +311,20 @@ ecl_backup_fopen(const char *filename, const char *option)
}
strcat(strcpy(backupfilename, filename), ".BAK");
ecl_disable_interrupts();
#ifdef _MSC_VER
/* MSVC rename doesn't remove an existing file */
if (access(backupfilename, F_OK) == 0 && unlink(backupfilename))
if (access(backupfilename, F_OK) == 0 && unlink(backupfilename)) {
ecl_enable_interrupts();
FElibc_error("Cannot remove the file ~S", 1, make_simple_base_string(backupfilename));
}
#endif
if (rename(filename, backupfilename))
if (rename(filename, backupfilename)) {
ecl_enable_interrupts();
FElibc_error("Cannot rename the file ~S to ~S.", 2,
make_constant_base_string(filename), make_simple_base_string(backupfilename));
}
ecl_enable_interrupts();
cl_dealloc(backupfilename);
return fopen(filename, option);
}
@ -284,8 +333,9 @@ cl_object
ecl_file_len(void *fp)
{
struct stat filestatus;
ecl_disable_interrupts();
fstat(fileno((FILE*)fp), &filestatus);
ecl_enable_interrupts();
return ecl_make_integer(filestatus.st_size);
}
@ -305,6 +355,7 @@ ecl_file_len(void *fp)
newn = ecl_merge_pathnames(newn, oldn, @':newest');
new_filename = si_coerce_to_filename(newn);
ecl_disable_interrupts();
while (if_exists == @':error' || if_exists == Cnil) {
#if defined(_MSC_VER) || defined(mingw32)
error = SetErrorMode(0);
@ -331,14 +382,17 @@ ecl_file_len(void *fp)
#endif
/* if the file already exists */
if (if_exists != Cnil) {
ecl_enable_interrupts();
if_exists = CEerror(@':supersede',
"When trying to rename ~S, ~S already exists", 2,
oldn, new_filename);
ecl_disable_interrupts();
if (if_exists == Ct) if_exists= @':error';
}
if (if_exists == Cnil) {
@(return Cnil)
ecl_enable_interrupts();
@(return Cnil Cnil Cnil)
}
}
@ -384,22 +438,30 @@ ecl_file_len(void *fp)
#endif
} else {
/* invalid key */
ecl_enable_interrupts();
FEerror("~S is an illegal IF-EXISTS option for RENAME-FILE.", 1, if_exists);
}
FAILURE_CLOBBER:
ecl_enable_interrupts();
FElibc_error("Cannot rename the file ~S to ~S.", 2, oldn, newn);
SUCCESS:new_truename = cl_truename(newn);
SUCCESS:
ecl_enable_interrupts();
new_truename = cl_truename(newn);
@(return newn old_truename new_truename)
@)
cl_object
cl_delete_file(cl_object file)
{
cl_object filename;
cl_object filename = si_coerce_to_filename(file);
int ok;
filename = si_coerce_to_filename(file);
if (unlink(filename->base_string.self) < 0)
ecl_disable_interrupts();
ok = unlink(filename->base_string.self);
ecl_enable_interrupts();
if (ok < 0)
FElibc_error("Cannot delete the file ~S.", 1, file);
@(return Ct)
}
@ -414,11 +476,9 @@ cl_probe_file(cl_object file)
cl_object
cl_file_write_date(cl_object file)
{
cl_object filename, time;
cl_object time, filename = si_coerce_to_filename(file);
struct stat filestatus;
filename = si_coerce_to_filename(file);
if (stat(filename->base_string.self, &filestatus) < 0)
if (safe_stat(filename->base_string.self, &filestatus) < 0)
time = Cnil;
else
time = UTC_time_to_universal_time(filestatus.st_mtime);
@ -428,54 +488,22 @@ cl_file_write_date(cl_object file)
cl_object
cl_file_author(cl_object file)
{
cl_object filename = si_coerce_to_filename(file);
cl_object output, filename = si_coerce_to_filename(file);
struct stat filestatus;
if (safe_stat(filename->base_string.self, &filestatus) < 0)
FElibc_error("Cannot get the file status of ~S.", 1, file);
#ifdef HAVE_PWD_H
struct stat filestatus;
struct passwd *pwent;
if (stat(filename->base_string.self, &filestatus) < 0)
FElibc_error("Cannot get the file status of ~S.", 1, file);
pwent = getpwuid(filestatus.st_uid);
@(return make_base_string_copy(pwent->pw_name))
{
struct passwd *pwent;
ecl_disable_interrupts();
pwent = getpwuid(filestatus.st_uid);
ecl_enable_interrupts();
output = make_base_string_copy(pwent->pw_name);
}
#else
struct stat filestatus;
if (stat(filename->base_string.self, &filestatus) < 0)
FElibc_error("Cannot get the file status of ~S.", 1, file);
@(return make_constant_base_string("UNKNOWN"))
output = make_constant_base_string("UNKNOWN");
#endif
}
const char *
ecl_expand_pathname(const char *name)
{
const char *path, *p;
static char pathname[255], *pn;
if (IS_DIR_SEPARATOR(name[0])) return(name);
if ((path = getenv("PATH")) == NULL) ecl_internal_error("No PATH in environment");
p = path;
pn = pathname;
do {
if ((*p == '\0') || (*p == PATH_SEPARATOR)) {
if (pn != pathname) *pn++ = DIR_SEPARATOR; /* on SYSV . is empty */
LAST: strcpy(pn, name);
#ifdef _MSC_VER
if (GetFileAttributes(pathname) & FILE_ATTRIBUTE_DIRECTORY)
return ( pathname );
#else
if (access(pathname, X_OK) == 0)
return (pathname);
#endif
pn = pathname;
if (p[0] == PATH_SEPARATOR && p[1] == '\0') { /* last entry is empty */
p++;
goto LAST;
}
}
else
*pn++ = *p;
} while (*p++ != '\0');
return(name); /* should never occur */
@(return output)
}
cl_object
@ -596,14 +624,16 @@ list_current_directory(const char *mask, bool only_dir)
{
cl_object out = Cnil;
char *text;
#if defined(HAVE_DIRENT_H)
DIR *dir;
struct dirent *entry;
ecl_disable_interrupts();
dir = opendir("./");
if (dir == NULL)
return Cnil;
if (dir == NULL) {
out = Cnil;
goto OUTPUT;
}
while ((entry = readdir(dir))) {
text = entry->d_name;
@ -613,30 +643,32 @@ list_current_directory(const char *mask, bool only_dir)
HANDLE hFind = NULL;
BOOL found = FALSE;
ecl_disable_interrupts();
for (;;) {
if (hFind == NULL)
{
if (hFind == NULL) {
hFind = FindFirstFile(".\\*", &fd);
if (hFind == INVALID_HANDLE_VALUE)
return Cnil;
if (hFind == INVALID_HANDLE_VALUE) {
out = Cnil;
goto OUTPUT;
}
found = TRUE;
}
else
} else {
found = FindNextFile(hFind, &fd);
}
if (!found)
break;
text = fd.cFileName;
# else /* sys/dir.h as in SYSV */
FILE *fp;
char iobuffer[BUFSIZ];
DIRECTORY dir;
ecl_disable_interrupts();
fp = fopen("./", OPEN_R);
if (fp == NULL)
return Cnil;
if (fp == NULL) {
out = Cnil;
goto OUTPUT;
}
setbuf(fp, iobuffer);
for (;;) {
if (fread(&dir, sizeof(DIRECTORY), 1, fp) <= 0)
@ -665,6 +697,8 @@ list_current_directory(const char *mask, bool only_dir)
fclose(fp);
# endif /* !_MSC_VER */
#endif /* !HAVE_DIRENT_H */
ecl_enable_interrupts();
OUTPUT:
return cl_nreverse(out);
}
@ -757,21 +791,21 @@ dir_recursive(cl_object pathname, cl_object directory)
loop_for_in(next_dir) {
char *text = CAR(next_dir)->base_string.self;
/* We are unable to move into this directory! */
if (chdir(text) < 0)
if (safe_chdir(text) < 0)
continue;
item = dir_recursive(pathname, CDR(directory));
output = ecl_nconc(item, output);
chdir(prev_dir->base_string.self);
safe_chdir(prev_dir->base_string.self);
} end_loop_for_in;
} else if (item == @':absolute') {
/*
* 2.2) If CAR(DIRECTORY) is :ABSOLUTE, we have to scan the
* root directory.
*/
if (chdir("/") < 0)
if (safe_chdir("/") < 0)
return Cnil;
output = dir_recursive(pathname, CDR(directory));
chdir(prev_dir->base_string.self);
safe_chdir(prev_dir->base_string.self);
} else if (item == @':relative') {
/*
* 2.3) If CAR(DIRECTORY) is :RELATIVE, we have to scan the
@ -783,10 +817,10 @@ dir_recursive(cl_object pathname, cl_object directory)
* 2.4) If CAR(DIRECTORY) is :UP, we have to scan the directory
* which contains this one.
*/
if (chdir("..") < 0)
if (safe_chdir("..") < 0)
return Cnil;
output = dir_recursive(pathname, CDR(directory));
chdir(prev_dir->base_string.self);
safe_chdir(prev_dir->base_string.self);
} else if (item == @':wild-inferiors') {
/*
* 2.5) If CAR(DIRECTORY) is :WILD-INFERIORS, we have to do
@ -796,11 +830,11 @@ dir_recursive(cl_object pathname, cl_object directory)
next_dir = list_current_directory("*", TRUE);
loop_for_in(next_dir) {
char *text = CAR(next_dir)->base_string.self;
if (chdir(text) < 0)
if (safe_chdir(text) < 0)
continue;
item = dir_recursive(pathname, directory);
output = ecl_nconc(item, output);
chdir(prev_dir->base_string.self);
safe_chdir(prev_dir->base_string.self);
} end_loop_for_in;
output = ecl_nconc(output, dir_recursive(pathname, CDR(directory)));
}
@ -818,7 +852,7 @@ dir_recursive(cl_object pathname, cl_object directory)
output = dir_recursive(mask, mask->pathname.directory);
} CL_UNWIND_PROTECT_EXIT {
if (prev_dir != Cnil)
chdir(prev_dir->base_string.self);
safe_chdir(prev_dir->base_string.self);
} CL_UNWIND_PROTECT_END;
@(return output)
@)
@ -838,10 +872,16 @@ si_get_library_pathname(void)
{
cl_object s = cl_alloc_adjustable_base_string(cl_core.path_max);
char *buffer = (char*)s->base_string.self;
HMODULE hnd = GetModuleHandle( "ecl.dll" );
HMODULE hnd;
cl_index len, ep;
if ((len = GetModuleFileName(hnd, buffer, cl_core.path_max-1)) == 0)
FEerror("GetModuleFileName failed (last error = ~S)", 1, MAKE_FIXNUM(GetLastError()));
ecl_disable_interrupts();
hnd = GetModuleHandle("ecl.dll");
len = GetModuleFileName(hnd, buffer, cl_core.path_max-1);
ecl_enable_interrupts();
if (len == 0) {
FEerror("GetModuleFileName failed (last error = ~S)",
1, MAKE_FIXNUM(GetLastError()));
}
s->base_string.fillp = len;
return ecl_parse_namestring(s, 0, len, &ep, Cnil);
}
@ -857,7 +897,7 @@ si_get_library_pathname(void)
directory->pathname.type != Cnil)
FEerror("~A is not a directory pathname.", 1, directory);
namestring = cl_namestring(directory);
if (chdir(namestring->base_string.self) <0)
if (safe_chdir(namestring->base_string.self) <0)
FElibc_error("Can't change the current directory to ~A",
1, namestring);
if (change_d_p_d != Cnil)
@ -868,18 +908,22 @@ si_get_library_pathname(void)
cl_object
si_mkdir(cl_object directory, cl_object mode)
{
cl_object filename;
cl_index modeint;
cl_object filename = si_coerce_to_filename(directory);
cl_index modeint = ecl_fixnum_in_range(@'si::mkdir',"mode",mode,0,0777);
int ok;
filename = si_coerce_to_filename(directory);
modeint = ecl_fixnum_in_range(@'si::mkdir',"mode",mode,0,0777);
if (filename->base_string.fillp)
filename->base_string.self[--filename->base_string.fillp] = 0;
ecl_disable_interrupts();
#ifdef mingw32
if (mkdir(filename->base_string.self) < 0)
ok = mkdir(filename->base_string.self);
#else
if (mkdir(filename->base_string.self, modeint) < 0)
ok = mkdir(filename->base_string.self, modeint);
#endif
ecl_enable_interrupts();
if (ok < 0)
FElibc_error("Could not create directory ~S", 1, filename);
@(return filename)
}
@ -892,67 +936,74 @@ si_mkstemp(cl_object template)
int fd;
#if defined(mingw32) || defined(_MSC_VER)
cl_object phys, dir, file;
char strTempDir[MAX_PATH];
char strTempFileName[MAX_PATH];
char * s;
char *s;
int ok;
phys = cl_translate_logical_pathname(1, template);
dir = cl_make_pathname(8,
@':type', Cnil,
@':name', Cnil,
@':version', Cnil,
@':defaults', phys);
dir = cl_namestring(dir);
file = cl_file_namestring(phys);
l = dir->base_string.fillp;
memcpy(strTempDir, dir->base_string.self, l);
strTempDir[l] = 0;
for (s = strTempDir; *s; s++)
if (*s == '/')
*s = '\\';
if (!GetTempFileName(strTempDir, file->base_string.self, 0, strTempFileName))
{
@(return Cnil)
ecl_disable_interrupts();
ok = GetTempFileName(strTempDir, file->base_string.self, 0, strTempFileName);
ecl_enable_interrupts();
if (!ok) {
output = Cnil;
} else {
l = strlen(strTempFileName);
output = cl_alloc_simple_base_string(l);
memcpy(output->base_string.self, strTempFileName, l);
}
l = strlen(strTempFileName);
output = cl_alloc_simple_base_string(l);
memcpy(output->base_string.self, strTempFileName, l);
#else
template = si_coerce_to_filename(template);
l = template->base_string.fillp;
output = cl_alloc_simple_base_string(l + 6);
memcpy(output->base_string.self, template->base_string.self, l);
memcpy(output->base_string.self + l, "XXXXXX", 6);
#ifdef HAVE_MKSTEMP
ecl_disable_interrupts();
# ifdef HAVE_MKSTEMP
fd = mkstemp(output->base_string.self);
#else
# else
fd = mktemp(output->base_string.self);
fd = open(fd, O_CREAT|O_TRUNC, 0666);
#endif
if (fd < 0)
@(return Cnil)
close(fd);
# endif
ecl_enable_interrupts();
if (fd < 0) {
output = Cnil;
} else {
close(fd);
}
#endif
@(return cl_truename(output))
@(return (Null(output)? output : cl_truename(output)))
}
cl_object
si_rmdir(cl_object directory)
{
int code;
directory = si_coerce_to_filename(directory);
if ( rmdir(directory->base_string.self) != 0 )
ecl_disable_interrupts();
code = rmdir(directory->base_string.self);
ecl_enable_interrupts();
if (code != 0)
FElibc_error("Can't remove directory ~A.", 1, directory);
@(return Cnil)
}

1
src/h/external.h
View file

@ -1541,7 +1541,6 @@ extern ECL_API cl_object cl_user_homedir_pathname _ARGS((cl_narg narg, ...));
extern ECL_API cl_object si_mkstemp(cl_object templ);
extern ECL_API cl_object si_rmdir(cl_object directory);
extern ECL_API const char *ecl_expand_pathname(const char *name);
extern ECL_API cl_object ecl_cstring_to_pathname(char *s);
extern ECL_API void *ecl_backup_fopen(const char *filename, const char *option);
extern ECL_API cl_object ecl_file_len(void *fp);

4
src/h/internal.h
View file

@ -25,8 +25,8 @@ extern "C" {
extern void init_all_symbols(void);
extern void init_alloc(void);
extern void init_backq(void);
extern void init_big(void);
extern void init_big_registers(void);
extern void init_big(cl_env_ptr);
extern void init_big_registers(cl_env_ptr);
#ifdef CLOS
extern void init_clos(void);
#endif