Commit 5ce18a3c authored by stephane's avatar stephane

put in common the common files and code of thread and mutex

str.c: fix a compile warning about LONG_MIN not fitting in int variable
strklos.h: made EXTERN_PRIMITIVE actually declare the primitive extern, and
 also declare its associated primitive_obj as extern.
vm.c: fix (??) REG_CALL_PRIM which was doing some real wrong stuff I have no
 idead why it worked, and if it did work, no idea why it still works after
 my fix...
all the rest: put the ';' at the end of EXTERN_PRIMITIVE(...) as it should 
 have been (or not?)
parent 3f081ccb
......@@ -38,7 +38,7 @@
(include "compiler.stk") ; VM Compiler
(include "object.stk") ; CLOS like object system
(include "date.stk") ; Dates
(include "threads.stk") ; Thread support
(include "thread.stk") ; Thread support
(include "pragma.stk") ; Pragma system for STklos compiler
(include "obsolete.stk") ; Obsolete functions. Candidates to disappear
......
......@@ -59,7 +59,7 @@
;; We had a timeout
(if timeout-val?
timeout-val
(raise (make-condition &thead-join-timeout))))
(raise (make-condition &thread-join-timeout))))
((%thread-end-exception thread)
;; We had an exceptionin thread. Raise it
(raise (%thread-end-exception thread)))
......
......@@ -21,10 +21,10 @@ THREADS = @THREADS@
# what thread support do we put in?
if LURC
THREAD_FILES = thread-lurc.c mutex-lurc.c
THREAD_FILES = thread-common.c thread-lurc.c mutex-common.c mutex-lurc.c
endif
if PTHREADS
THREAD_FILES = thread-pthreads.c mutex-pthreads.c
THREAD_FILES = thread-common.c thread-pthreads.c mutex-common.c mutex-pthreads.c
endif
if NO_THREAD
THREAD_FILES = thread-none.c mutex-none.c
......
......@@ -135,9 +135,9 @@ extrainc_DATA = stklos.h extraconf.h stklosconf.h socket.h fport.h
DOCDB = DOCDB
# what thread support do we put in?
@LURC_TRUE@THREAD_FILES = thread-lurc.c mutex-lurc.c
@LURC_TRUE@THREAD_FILES = thread-common.c thread-lurc.c mutex-common.c mutex-lurc.c
@NO_THREAD_TRUE@THREAD_FILES = thread-none.c mutex-none.c
@PTHREADS_TRUE@THREAD_FILES = thread-pthreads.c mutex-pthreads.c
@PTHREADS_TRUE@THREAD_FILES = thread-common.c thread-pthreads.c mutex-common.c mutex-pthreads.c
stklos_SOURCES = boolean.c boot.c char.c cond.c dynload.c env.c error.c \
extend.c fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c \
......@@ -188,10 +188,12 @@ CONFIG_CLEAN_FILES = extraconf.h
bin_PROGRAMS = stklos$(EXEEXT)
PROGRAMS = $(bin_PROGRAMS)
@LURC_TRUE@am__objects_1 = thread-lurc.$(OBJEXT) mutex-lurc.$(OBJEXT)
@LURC_TRUE@am__objects_1 = thread-common.$(OBJEXT) thread-lurc.$(OBJEXT) \
@LURC_TRUE@ mutex-common.$(OBJEXT) mutex-lurc.$(OBJEXT)
@NO_THREAD_TRUE@am__objects_1 = thread-none.$(OBJEXT) \
@NO_THREAD_TRUE@ mutex-none.$(OBJEXT)
@PTHREADS_TRUE@am__objects_1 = thread-pthreads.$(OBJEXT) \
@PTHREADS_TRUE@am__objects_1 = thread-common.$(OBJEXT) \
@PTHREADS_TRUE@ thread-pthreads.$(OBJEXT) mutex-common.$(OBJEXT) \
@PTHREADS_TRUE@ mutex-pthreads.$(OBJEXT)
am_stklos_OBJECTS = boolean.$(OBJEXT) boot.$(OBJEXT) char.$(OBJEXT) \
cond.$(OBJEXT) dynload.$(OBJEXT) env.$(OBJEXT) error.$(OBJEXT) \
......@@ -223,6 +225,7 @@ am__depfiles_maybe = depfiles
@AMDEP_TRUE@ ./$(DEPDIR)/gnu-glob.Po ./$(DEPDIR)/hash.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/keyword.Po ./$(DEPDIR)/lib.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/list.Po ./$(DEPDIR)/misc.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/mutex-common.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/mutex-lurc.Po ./$(DEPDIR)/mutex-none.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/mutex-pthreads.Po ./$(DEPDIR)/number.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/object.Po ./$(DEPDIR)/parameter.Po \
......@@ -234,7 +237,8 @@ am__depfiles_maybe = depfiles
@AMDEP_TRUE@ ./$(DEPDIR)/socket.Po ./$(DEPDIR)/sport.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/stklos.Po ./$(DEPDIR)/str.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/struct.Po ./$(DEPDIR)/symbol.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/system.Po ./$(DEPDIR)/thread-lurc.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/system.Po ./$(DEPDIR)/thread-common.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/thread-lurc.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/thread-none.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/thread-pthreads.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/uvector.Po ./$(DEPDIR)/vector.Po \
......@@ -328,6 +332,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/lib.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/list.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/misc.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mutex-common.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mutex-lurc.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mutex-none.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mutex-pthreads.Po@am__quote@
......@@ -351,6 +356,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/struct.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/symbol.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/system.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/thread-common.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/thread-lurc.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/thread-none.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/thread-pthreads.Po@am__quote@
......
This diff is collapsed.
This diff is collapsed.
......@@ -28,15 +28,7 @@
#include "stklos.h"
#include "hash.h"
#include "vm.h"
#ifdef THREADS_PTHREADS
# include "thread-pthreads.h"
#endif
#ifdef THREADS_LURC
# include "thread-lurc.h"
#endif
#ifdef THREADS_NONE
# include "thread-none.h"
#endif
#include "thread-common.h"
static void error_bad_module_name(SCM obj)
{
......
/*
* mutex-common.c -- Common Mutexes in Scheme
*
* Copyright © 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
* USA.
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 2-Feb-2006 21:58 (eg)
* Last file update: 17-Apr-2006 00:00 (eg)
*/
#include <unistd.h>
#include "stklos.h"
#include "vm.h"
#include "thread-common.h"
#include "mutex-common.h"
/* ====================================================================== *\
*
* M U T E X E S
*
\* ====================================================================== */
SCM STk_sym_not_owned, STk_sym_abandoned, STk_sym_not_abandoned;
void STk_error_bad_mutex(SCM obj)
{
STk_error("bad mutex ~S", obj);
}
void STk_error_deadlock(void)
{
STk_error("cannot lock mutex (deadlock will occur)");
}
void STk_error_bad_timeout(SCM tm)
{
STk_error("bad timeout ~S", tm);
}
/* ====================================================================== */
DEFINE_PRIMITIVE("make-mutex", make_mutex, subr01, (SCM name))
{
SCM z;
NEWCELL(z, mutex);
MUTEX_NAME(z) = (name ? name : STk_false);
MUTEX_SPECIFIC(z) = STk_void;
MUTEX_OWNER(z) = STk_false;
MUTEX_LOCKED(z) = FALSE;
STk_make_mutex_specific(z);
return z;
}
DEFINE_PRIMITIVE("mutex?", mutexp, subr1, (SCM obj))
{
return MAKE_BOOLEAN(MUTEXP(obj));
}
DEFINE_PRIMITIVE("mutex-name", mutex_name, subr1, (SCM mtx))
{
if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
return MUTEX_NAME(mtx);
}
DEFINE_PRIMITIVE("mutex-specific", mutex_specific, subr1, (SCM mtx))
{
if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
return MUTEX_SPECIFIC(mtx);
}
DEFINE_PRIMITIVE("mutex-specific-set!", mutex_specific_set, subr2, (SCM mtx, SCM v))
{
if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
MUTEX_SPECIFIC(mtx) = v;
return STk_void;
}
/* ====================================================================== *\
*
* C O N D V A R S
*
\* ====================================================================== */
void STk_error_bad_condv(SCM obj)
{
STk_error("bad confdition variable ~S", obj);
}
/* ====================================================================== */
DEFINE_PRIMITIVE("make-condition-variable", make_condv, subr01, (SCM name))
{
SCM z;
NEWCELL(z, condv);
CONDV_NAME(z) = (name ? name : STk_false);
CONDV_SPECIFIC(z) = STk_void;
STk_make_condv_specific(z);
return z;
}
DEFINE_PRIMITIVE("condition-variable?", condvp, subr1, (SCM obj))
{
return MAKE_BOOLEAN(CONDVP(obj));
}
DEFINE_PRIMITIVE("condition-variable-name", condv_name, subr1, (SCM cv))
{
if (! CONDVP(cv)) STk_error_bad_condv(cv);
return CONDV_NAME(cv);
}
DEFINE_PRIMITIVE("condition-variable-specific", condv_specific, subr1, (SCM cv))
{
if (! CONDVP(cv)) STk_error_bad_condv(cv);
return CONDV_SPECIFIC(cv);
}
DEFINE_PRIMITIVE("condition-variable-specific-set!", condv_specific_set, subr2,
(SCM cv, SCM v))
{
if (! CONDVP(cv)) STk_error_bad_condv(cv);
CONDV_SPECIFIC(cv) = v;
return STk_void;
}
/* ====================================================================== *\
* Initialization ...
\* ====================================================================== */
static void print_mutex(SCM mutex, SCM port, int mode)
{
STk_puts("#[mutex ", port);
STk_print(MUTEX_NAME(mutex), port, DSP_MODE);
STk_putc(']', port);
}
static void print_condv(SCM condv, SCM port, int mode)
{
STk_puts("#[condition-variable ", port);
STk_print(CONDV_NAME(condv), port, DSP_MODE);
STk_putc(']', port);
}
/* The stucture which describes the mutex type */
static struct extended_type_descr xtype_mutex = {
"mutex", /* name */
print_mutex /* print function */
};
/* The stucture which describes the condv type */
static struct extended_type_descr xtype_condv = {
"condv", /* name */
print_condv /* print function */
};
int STk_init_mutexes(void)
{
/* Define some symbols */
STk_sym_not_owned = STk_intern("not-owned");
STk_sym_abandoned = STk_intern("abandoned");
STk_sym_not_abandoned = STk_intern("not-abandoned");
/* Mutex and condv type declarations */
DEFINE_XTYPE(mutex, &xtype_mutex);
DEFINE_XTYPE(condv, &xtype_condv);
/* Mutexes primitives */
ADD_PRIMITIVE(make_mutex);
ADD_PRIMITIVE(mutexp);
ADD_PRIMITIVE(mutex_name);
ADD_PRIMITIVE(mutex_specific);
ADD_PRIMITIVE(mutex_specific_set);
ADD_PRIMITIVE(mutex_state);
ADD_PRIMITIVE(mutex_lock);
ADD_PRIMITIVE(mutex_unlock);
/* Condv primitives */
ADD_PRIMITIVE(make_condv);
ADD_PRIMITIVE(condvp);
ADD_PRIMITIVE(condv_name);
ADD_PRIMITIVE(condv_specific);
ADD_PRIMITIVE(condv_specific_set);
ADD_PRIMITIVE(condv_signal);
ADD_PRIMITIVE(condv_broadcast);
return TRUE;
}
/*
* mutex-common.h -- Mutex support for STklos
*
* Copyright © 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
* USA.
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 4-Feb-2006 11:03 (eg)
* Last file update: 4-Feb-2006 11:04 (eg)
*/
#ifndef _STK_MUTEX_H
#define _STK_MUTEX_H
#include "stklos.h"
#ifdef THREADS_LURC
# include "mutex-lurc.h"
#elif defined(THREADS_PTHREADS)
# include "mutex-pthreads.h"
#else
# include "mutex-none.h"
#endif
#ifndef THREADS_NONE
/* ====================================================================== *\
*
* M U T E X E S
*
\* ====================================================================== */
struct mutex_obj {
stk_header header;
SCM name;
SCM specific;
SCM owner;
int locked;
struct mutex_obj_specific sys_mutex;
};
#define MUTEXP(p) (BOXED_TYPE_EQ((p), tc_mutex))
#define MUTEX_NAME(p) (((struct mutex_obj *) (p))->name)
#define MUTEX_SPECIFIC(p) (((struct mutex_obj *) (p))->specific)
#define MUTEX_OWNER(p) (((struct mutex_obj *) (p))->owner)
#define MUTEX_LOCKED(p) (((struct mutex_obj *) (p))->locked)
/* ====================================================================== *\
*
* C O N D V A R S
*
\* ====================================================================== */
struct condv_obj {
stk_header header;
SCM name;
SCM specific;
struct condv_obj_specific sys_condv;
};
#define CONDVP(p) (BOXED_TYPE_EQ((p), tc_condv))
#define CONDV_NAME(p) (((struct condv_obj *) (p))->name)
#define CONDV_SPECIFIC(p) (((struct condv_obj *) (p))->specific)
/* ====================================================================== */
extern SCM STk_sym_not_owned, STk_sym_abandoned, STk_sym_not_abandoned;
extern void STk_error_bad_mutex(SCM obj);
extern void STk_error_deadlock(void);
extern void STk_error_bad_timeout(SCM tm);
extern void STk_error_bad_condv(SCM obj);
#endif /* ! THREADS_NONE */
#endif /* ! _STK_MUTEX_H */
......@@ -33,9 +33,8 @@
#include <unistd.h>
#include "stklos.h"
#include "vm.h"
#include "thread-lurc.h"
static SCM sym_not_owned, sym_abandoned, sym_not_abandoned;
#include "mutex-common.h"
#include "thread-common.h"
/* ====================================================================== *\
......@@ -44,123 +43,34 @@ static SCM sym_not_owned, sym_abandoned, sym_not_abandoned;
*
\* ====================================================================== */
struct mutex_obj {
stk_header header;
SCM name;
SCM specific;
SCM owner;
int locked;
lurc_mutex_t mymutex;
lurc_signal_t mysignal;
};
#define MUTEXP(p) (BOXED_TYPE_EQ((p), tc_mutex))
#define MUTEX_NAME(p) (((struct mutex_obj *) (p))->name)
#define MUTEX_SPECIFIC(p) (((struct mutex_obj *) (p))->specific)
#define MUTEX_OWNER(p) (((struct mutex_obj *) (p))->owner)
#define MUTEX_LOCKED(p) (((struct mutex_obj *) (p))->locked)
#define MUTEX_MYMUTEX(p) (((struct mutex_obj *) (p))->mymutex)
#define MUTEX_MYSIGNAL(p) (((struct mutex_obj *) (p))->mysignal)
typedef enum {CV_NONE, CV_ONE, CV_ALL} cv_target_t;
struct condv_obj {
stk_header header;
SCM name;
SCM specific;
lurc_signal_t mysignal;
cv_target_t target;
lurc_instant_t emitted;
};
#define CONDVP(p) (BOXED_TYPE_EQ((p), tc_mutex))
#define CONDV_NAME(p) (((struct condv_obj *) (p))->name)
#define CONDV_SPECIFIC(p) (((struct condv_obj *) (p))->specific)
#define CONDV_MYSIGNAL(p) (((struct condv_obj *) (p))->mysignal)
#define CONDV_TARGET(p) (((struct condv_obj *) (p))->target)
#define CONDV_EMITTED(p) (((struct condv_obj *) (p))->emitted)
void error_bad_mutex(SCM obj)
{
STk_error("bad mutex ~S", obj);
}
void error_deadlock(void)
{
STk_error("cannot lock mutex (deadlock will occur)");
}
void error_bad_timeout(SCM tm)
{
STk_error("bad timeout ~S", tm);
}
void mutex_finalizer(SCM mtx)
static void mutex_finalizer(SCM mtx)
{
lurc_mutex_destroy(&MUTEX_MYMUTEX(mtx));
lurc_signal_destroy(&MUTEX_MYSIGNAL(mtx));
}
/* ====================================================================== */
DEFINE_PRIMITIVE("make-mutex", make_mutex, subr01, (SCM name))
void STk_make_mutex_specific(SCM z)
{
SCM z;
NEWCELL(z, mutex);
MUTEX_NAME(z) = (name ? name : STk_false);
MUTEX_SPECIFIC(z) = STk_void;
MUTEX_OWNER(z) = STk_false;
MUTEX_LOCKED(z) = FALSE;
lurc_mutex_init(&MUTEX_MYMUTEX(z), NULL);
lurc_signal_init(&MUTEX_MYSIGNAL(z), NULL);
STk_register_finalizer(z, mutex_finalizer);
return z;
}
DEFINE_PRIMITIVE("mutex?", mutexp, subr1, (SCM obj))
{
return MAKE_BOOLEAN(MUTEXP(obj));
}
DEFINE_PRIMITIVE("mutex-name", mutex_name, subr1, (SCM mtx))
{
if (! MUTEXP(mtx)) error_bad_mutex(mtx);
return MUTEX_NAME(mtx);
}
DEFINE_PRIMITIVE("mutex-specific", mutex_specific, subr1, (SCM mtx))
{
if (! MUTEXP(mtx)) error_bad_mutex(mtx);
return MUTEX_SPECIFIC(mtx);
}
DEFINE_PRIMITIVE("mutex-specific-set!", mutex_specific_set, subr2, (SCM mtx, SCM v))
{
if (! MUTEXP(mtx)) error_bad_mutex(mtx);
MUTEX_SPECIFIC(mtx) = v;
return STk_void;
}
DEFINE_PRIMITIVE("mutex-state", mutex_state, subr1, (SCM mtx))
{
SCM res;
if (! MUTEXP(mtx)) error_bad_mutex(mtx);
if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
lurc_mutex_lock(&MUTEX_MYMUTEX(mtx));
if (MUTEX_LOCKED(mtx))
res = (MUTEX_OWNER(mtx) == STk_false) ? sym_not_owned : MUTEX_OWNER(mtx);
res = (MUTEX_OWNER(mtx) == STk_false) ? STk_sym_not_owned : MUTEX_OWNER(mtx);
else
res = (MUTEX_OWNER(mtx) == STk_false) ? sym_not_abandoned: sym_abandoned;
res = (MUTEX_OWNER(mtx) == STk_false) ? STk_sym_not_abandoned: STk_sym_abandoned;
lurc_mutex_unlock(&MUTEX_MYMUTEX(mtx));
......@@ -174,14 +84,14 @@ DEFINE_PRIMITIVE("%mutex-lock!", mutex_lock, subr3, (SCM mtx, SCM tm, SCM thread
SCM res = STk_true;
int did_loop = 0;
if (! MUTEXP(mtx)) error_bad_mutex(mtx);
if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
if (REALP(tm)){
// bah nothing
}else if (!BOOLEANP(tm))
error_bad_timeout(tm);
STk_error_bad_timeout(tm);
if (lurc_mutex_lock(&MUTEX_MYMUTEX(mtx)) != 0)
error_deadlock();
STk_error_deadlock();
while (MUTEX_LOCKED(mtx)) {
if ((MUTEX_OWNER(mtx) != STk_false) &&
......@@ -237,15 +147,15 @@ DEFINE_PRIMITIVE("%mutex-unlock!", mutex_unlock, subr3, (SCM mtx, SCM cv, SCM tm
SCM res = STk_true;
struct timeval rel_tv;
if (! MUTEXP(mtx)) error_bad_mutex(mtx);
if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
if (REALP(tm)) {
rel_tv = lthr_abs_time_to_rel_time(REAL_VAL(tm));
}
else if (!BOOLEANP(tm))
error_bad_timeout(tm);
STk_error_bad_timeout(tm);
if (lurc_mutex_lock(&MUTEX_MYMUTEX(mtx)) != 0)
error_deadlock();
STk_error_deadlock();
/* Go in the unlocked/abandonned state */
MUTEX_LOCKED(mtx) = FALSE;
......@@ -293,65 +203,24 @@ DEFINE_PRIMITIVE("%mutex-unlock!", mutex_unlock, subr3, (SCM mtx, SCM cv, SCM tm
*
\* ====================================================================== */
void error_bad_condv(SCM obj)
{
STk_error("bad confdition variable ~S", obj);
}
void condv_finalizer(SCM cv)
static void condv_finalizer(SCM cv)
{
lurc_signal_destroy(&CONDV_MYSIGNAL(cv));
}
/* ====================================================================== */
DEFINE_PRIMITIVE("make-condition-variable", make_condv, subr01, (SCM name))
void STk_make_condv_specific(SCM z)
{
SCM z;
NEWCELL(z, condv);
CONDV_NAME(z) = (name ? name : STk_false);
CONDV_SPECIFIC(z) = STk_void;
CONDV_TARGET(z) = -1;
CONDV_EMITTED(z) = CV_NONE;
CONDV_TARGET(z) = CV_NONE;
CONDV_EMITTED(z) = -1;
lurc_signal_init(&CONDV_MYSIGNAL(z), NULL);
STk_register_finalizer(z, condv_finalizer);
return z;
}
DEFINE_PRIMITIVE("condition-variable?", condvp, subr1, (SCM obj))
{
return MAKE_BOOLEAN(CONDVP(obj));
}
DEFINE_PRIMITIVE("condition-variable-name", condv_name, subr1, (SCM cv))
{
if (! CONDVP(cv)) error_bad_condv(cv);
return CONDV_NAME(cv);
}
DEFINE_PRIMITIVE("condition-variable-specific", condv_specific, subr1, (SCM cv))
{
if (! CONDVP(cv)) error_bad_condv(cv);
return CONDV_SPECIFIC(cv);
}
DEFINE_PRIMITIVE("condition-variable-specific-set!", condv_specific_set, subr2,
(SCM cv, SCM v))
{
if (! CONDVP(cv)) error_bad_condv(cv);
CONDV_SPECIFIC(cv) = v;
return STk_void;
}
DEFINE_PRIMITIVE("condition-variable-signal!", condv_signal, subr1, (SCM cv))
{
if (! CONDVP(cv)) error_bad_condv(cv);
if (! CONDVP(cv)) STk_error_bad_condv(cv);
// find a free instant to emit
while(lurc_instant() == CONDV_EMITTED(cv))
lurc_pause();
......@@ -366,7 +235,7 @@ DEFINE_PRIMITIVE("condition-variable-signal!", condv_signal, subr1, (SCM cv))
DEFINE_PRIMITIVE("condition-variable-brodcast!", condv_broadcast, subr1, (SCM cv))
{
if (! CONDVP(cv)) error_bad_condv(cv);
if (! CONDVP(cv)) STk_error_bad_condv(cv);
// find a free instant to emit
while(lurc_instant() == CONDV_EMITTED(cv))
lurc_pause();
......@@ -378,68 +247,3 @@ DEFINE_PRIMITIVE("condition-variable-brodcast!", condv_broadcast, subr1, (SCM cv
return STk_void;
}
/* ====================================================================== *\
* Initialization ...
\* ====================================================================== */
static void print_mutex(SCM mutex, SCM port, int mode)
{
STk_puts("#[mutex ", port);
STk_print(MUTEX_NAME(mutex), port, DSP_MODE);
STk_putc(']', port);
}
static void print_condv(SCM condv, SCM port, int mode)
{
STk_puts("#[condition-variable ", port);
STk_print(CONDV_NAME(condv), port, DSP_MODE);
STk_putc(']', port);
}
/* The stucture which describes the mutex type */
static struct extended_type_descr xtype_mutex = {
"mutex", /* name */
print_mutex /* print function */
};
/* The stucture which describes the condv type */
static struct extended_type_descr xtype_condv = {
"condv", /* name */
print_condv /* print function */
};
int STk_init_mutexes(void)
{
/* Define some symbols */
sym_not_owned = STk_intern("not-owned");
sym_abandoned = STk_intern("abandoned");
sym_not_abandoned = STk_intern("not-abandoned");
/* Mutex and condv type declarations */
DEFINE_XTYPE(mutex, &xtype_mutex);
DEFINE_XTYPE(condv, &xtype_condv);
/* Mutexes primitives */
ADD_PRIMITIVE(make_mutex);
ADD_PRIMITIVE(mutexp);
ADD_PRIMITIVE(mutex_name);
ADD_PRIMITIVE(mutex_specific);
ADD_PRIMITIVE(mutex_specific_set);
ADD_PRIMITIVE(mutex_state);
ADD_PRIMITIVE(mutex_lock);
ADD_PRIMITIVE(mutex_unlock);
/* Condv primitives */
ADD_PRIMITIVE(make_condv);
ADD_PRIMITIVE(condvp);
ADD_PRIMITIVE(condv_name);
ADD_PRIMITIVE(condv_specific);
ADD_PRIMITIVE(condv_specific_set);
ADD_PRIMITIVE(condv_signal);
ADD_PRIMITIVE(condv_broadcast);
return TRUE;
}
/*
* mutex-lurc.h -- Mutex support for STklos
*
* Copyright © 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
*
* This program is free software; you can redistribute it and/or modify