Initial version of semaphores both for POSIX and Windows. Includes test that detects failure of unnamed semaphores under Darwin. The whole code is still inactive.

src/aclocal.m4

@@ -841,3 +841,28 @@ case "${host_cpu}" in
 esac
 AC_SUBST(ECL_FPE_CODE)
 ])
+
+dnl ----------------------------------------------------------------------
+dnl Check whether we have unnamed POSIX semaphores available
+AC_DEFUN([ECL_POSIX_SEMAPHORES],
+[AC_MSG_CHECKING(working sem_init())
+AC_RUN_IFELSE([AC_LANG_SOURCE([[
+#ifdef HAVE_SEMAPHORE_H
+#include <semaphore.h>
+int main() {
+  sem_t aux;
+  if (sem_init(&aux, 0, 0))
+    exit(1);
+  exit(0);
+#else
+int main() {
+  exit(1);
+}
+#endif
+}]])],[working_sem_init=yes],[working_sem_init=no],[])
+AC_MSG_RESULT([$working_sem_init])
+if test $working_sem_init = yes ; then
+  AC_DEFINE(ECL_SEMAPHORES)
+  AC_DEFINE(HAVE_SEM_INIT)
+fi
+])

src/c/alloc.d

@@ -405,6 +405,11 @@ ONCE_MORE:
 	  obj->condition_variable.cv = OBJNULL;
 	  break;
 #endif
+#ifdef ECL_SEMAPHORES
+	case t_semaphore:
+          obj->semaphore.handle = NULL;
+	  break;
+#endif
 #ifdef CLOS
 	case t_instance:
 	  obj->instance.length = 0;
@@ -758,6 +763,10 @@ init_alloc(void)
 	init_tm(t_condition_variable, "tCONDITION-VARIABLE",
                 sizeof(struct ecl_condition_variable), 2);
 #endif /* THREADS */
+#ifdef ECL_SEMAPHORES
+	init_tm(t_semaphore, "tSEMAPHORE",
+                sizeof(struct ecl_semaphore), 2);
+#endif
 #ifdef ECL_LONG_FLOAT
 	init_tm(t_longfloat, "tLONGFLOAT", sizeof(struct ecl_long_float), 2);
 #endif

src/c/alloc_2.d

@@ -188,6 +188,9 @@ ecl_alloc_object(cl_type t)
 	case t_process:
         case t_lock:
         case t_condition_variable:
+#endif
+#ifdef ECL_SEMAPHORES:
+        case t_semaphores:
 #endif
 	case t_foreign:
 	case t_codeblock: {
@@ -422,6 +425,9 @@ init_alloc(void)
 	init_tm(t_condition_variable, "CONDITION-VARIABLE",
                 sizeof(struct ecl_condition_variable));
 #endif
+#ifdef ECL_SEMAPHORES
+	init_tm(t_semaphores, "SEMAPHORES", sizeof(struct ecl_semaphores));
+#endif
 #ifdef ECL_LONG_FLOAT
 	init_tm(t_longfloat, "LONG-FLOAT", sizeof(struct ecl_long_float));
 #endif
@@ -477,6 +483,12 @@ standard_finalizer(cl_object o)
 		ecl_enable_interrupts_env(the_env);
 		break;
 	}
+#endif
+#ifdef ECL_SEMAPHORES
+	case t_semaphore: {
+                mp_semaphore_close(o);
+		break;
+	}
 #endif
 	default:;
 	}

src/c/gbc.d

@@ -391,6 +391,10 @@ BEGIN:
 	case t_condition_variable:
                 break;
 #endif /* THREADS */
+#ifdef ECL_SEMAPHORES
+	case t_semaphore:
+                break;
+#endif
 #ifdef CLOS
 	case t_instance:
 		mark_object(x->instance.clas);
@@ -670,6 +674,11 @@ sweep_phase(void)
 				pthread_cond_destroy(&x->condition_variable.cv);
 #endif
 				break;
+#endif
+#ifdef ECL_SEMAPHORES
+			case t_semaphore:
+#error "Unfinished"
+				break;
 #endif
 			default:;
 			}

src/c/instance.d

@@ -262,6 +262,9 @@ enum ecl_built_in_classes {
 	ECL_BUILTIN_LOCK,
 	ECL_BUILTIN_CONDITION_VARIABLE
 #endif
+#ifdef ECL_SEMAPHORES
+        , ECL_BUILTIN_SEMAPHORE
+#endif
 };
 
 cl_object
@@ -350,6 +353,10 @@ cl_class_of(cl_object x)
 		index = ECL_BUILTIN_LOCK; break;
 	case t_condition_variable:
 		index = ECL_BUILTIN_CONDITION_VARIABLE; break;
+#endif
+#ifdef ECL_SEMAPHORES
+	case t_semaphores:
+		index = ECL_BUILTIN_SEMAPHORE; break;
 #endif
 	case t_codeblock:
 		index = ECL_BUILTIN_CODE_BLOCK; break;

src/c/main.d

@@ -107,6 +107,9 @@ static const char *feature_names[] = {
 #ifdef ECL_THREADS
 	"THREADS",
 #endif
+#ifdef ECL_SEMAPHORES
+	"SEMAPHORES",
+#endif
 #ifdef CLOS
 	"CLOS",
 #endif

src/c/print.d

@@ -1612,6 +1612,14 @@ si_write_ugly_object(cl_object x, cl_object stream)
 		write_ch('>', stream);
 		break;
 #endif /* ECL_THREADS */
+#ifdef ECL_SEMAPHORES
+	case t_semaphore:
+		if (ecl_print_readably()) FEprint_not_readable(x);
+		write_str("#<semaphore ", stream);
+		write_addr(x, stream);
+		write_ch('>', stream);
+		break;
+#endif
 	default:
 		if (ecl_print_readably()) FEprint_not_readable(x);
 		write_str("#<illegal pointer ", stream);

src/c/symbols_list.h

@@ -1517,6 +1517,14 @@ cl_symbols[] = {
 {MP_ "PROCESS-RESUME", MP_ORDINARY, mp_process_resume, 1, OBJNULL},
 {MP_ "SUSPEND-LOOP", MP_ORDINARY, mp_suspend_loop, 0, OBJNULL},
 {MP_ "BREAK-SUSPEND-LOOP", MP_ORDINARY, mp_break_suspend_loop, 0, OBJNULL},
+# ifdef ECL_SEMAPHORES
+{MP_ "SEMAPHORE", MP_ORDINARY, NULL, -1, OBJNULL},
+{MP_ "MAKE-SEMAPHORE", MP_ORDINARY, mp_make_semaphore, -1, OBJNULL},
+{MP_ "SEMAPHORE-WAIT", MP_ORDINARY, mp_semaphore_wait, 1, OBJNULL},
+{MP_ "SEMAPHORE-TRYWAIT", MP_ORDINARY, mp_semaphore_trywait, 1, OBJNULL},
+{MP_ "SEMAPHORE-SIGNAL", MP_ORDINARY, mp_semaphore_signal, 1, OBJNULL},
+{MP_ "SEMAPHORE-CLOSE", MP_ORDINARY, mp_semaphore_close, 1, OBJNULL},
+# endif
 #endif
 
 {SYS_ "WHILE", SI_ORDINARY, NULL, -1, OBJNULL},

src/c/symbols_list2.h

@@ -1517,6 +1517,14 @@ cl_symbols[] = {
 {MP_ "PROCESS-RESUME","mp_process_resume"},
 {MP_ "SUSPEND-LOOP","mp_suspend_loop"},
 {MP_ "BREAK-SUSPEND-LOOP","mp_break_suspend_loop"},
+# ifdef ECL_SEMAPHORES
+{MP_ "SEMAPHORE",NULL},
+{MP_ "MAKE-SEMAPHORE","mp_make_semaphore"},
+{MP_ "SEMAPHORE-WAIT","mp_semaphore_wait"},
+{MP_ "SEMAPHORE-TRYWAIT","mp_semaphore_trywait"},
+{MP_ "SEMAPHORE-SIGNAL","mp_semaphore_signal"},
+{MP_ "SEMAPHORE-CLOSE","mp_semaphore_close"},
+# endif
 #endif
 
 {SYS_ "WHILE",NULL},

src/c/threads.d

@@ -1,6 +1,6 @@
 /* -*- mode: c; c-basic-offset: 8 -*- */
 /*
-    threads.d -- Posix threads with support from GCC.
+    threads.d -- Native threads.
 */
 /*
     Copyright (c) 2003, Juan Jose Garcia Ripoll.
@@ -37,6 +37,9 @@
 #ifdef HAVE_SCHED_YIELD
 # include <sched.h>
 #endif
+#ifdef HAVE_SEMAPHORE_H
+# include <semaphore.h>
+#endif
 
 #if defined(_MSC_VER) || defined(mingw32)
 # define ECL_WINDOWS_THREADS
@@ -832,6 +835,188 @@ mp_condition_variable_broadcast(cl_object cv)
 	@(return Ct)
 }
 
+/*----------------------------------------------------------------------
+ * SEMAPHORES
+ */
+
+#ifdef ECL_SEMAPHORES
+
+# ifdef ECL_MACH_SEMAPHORES
+struct ecl_semaphore_inner {
+        task_t owner;
+        semaphore_t counter[1];
+};
+# endif
+
+@(defun mp::make-semaphore (max &key name ((:count count) MAKE_FIXNUM(0)))
+	cl_object output;
+	cl_index initial_count, max_count;
+@
+{
+        output = ecl_alloc_object(t_semaphore);
+        ecl_disable_interrupts_env(the_env);
+        output->semaphore.name = name;
+        output->semaphore.handle = NULL;
+        ecl_set_finalizer_unprotected(output, Ct);
+        max_count = ecl_fixnum_in_range(@'mp:make-semaphore', "maximum count",
+                                        max, 0, 0xFFFF);
+        initial_count = ecl_fixnum_in_range(@'mp:make-semaphore', "initial count",
+                                            count, 0, max_count);
+#ifdef ECL_WINDOWS_THREADS
+        {
+                HANDLE h = CreateSemaphore(NULL,
+                                           initial_count,
+                                           0xFFFF,
+                                           NULL);
+                output->semaphore.handle = h;
+                ecl_enable_interrupts_env(the_env);
+                if (h == NULL)
+                        FEwin32_error("Unable to create semaphore object.", 0);
+        }
+#else
+# ifdef HAVE_SEM_INIT
+        {
+                sem_t *h = ecl_alloc_atomic(sizeof(sem_t));
+                int rc = sem_init(h, 0, initial_count);
+                if (!rc)
+                        output->semaphore.handle = h;
+                ecl_enable_interrupts();
+                if (rc)
+                        FEerror("Unable to create semaphore object.", 0);
+        }
+# endif /* HAVE_SEM_INIT */
+#endif /* ECL_WINDOWS_THREADS */
+        @(return output)
+}
+@)
+
+cl_object
+mp_semaphore_trywait(cl_object sem)
+{
+        cl_object output;
+        if (typeof(sem) != t_semaphore)
+                FEwrong_type_argument(@'mp::semaphore', cv);
+ AGAIN:
+#ifdef ECL_WINDOWS_THREADS
+        {
+                HANDLE h = (HANDLE)(sem->semaphore.handle);
+                switch (WaitForSingleObject(h, 0)) {
+		case WAIT_OBJECT_0:
+                        output = Ct;
+			break;
+                case WAIT_TIMEOUT:
+                        output = Cnil;
+                        break;
+		default:
+			FEwin32_error("Unable to wait on semaphore", 0);
+                        output = Cnil;
+                }
+        }
+#else
+# ifdef HAVE_SEM_INIT
+        {
+                sem_t *h = (sem_t *)(sem->semaphore.handle);
+                int rc = sem_trywait(h);
+                if (sem_trywait(h)) {
+                        if (errno != EAGAIN) {
+                                FElibc_error("Unable to wait on semaphore", 0);
+                        }
+                        output = Cnil;
+                } else {
+                        output = Ct;
+                }
+        }
+# endif /* HAVE_SEM_INIT */
+#endif /* ECL_WINDOWS_THREADS */
+        @(return output)
+}
+
+
+cl_object
+mp_semaphore_wait(cl_object sem)
+{
+        cl_object output;
+        if (typeof(sem) != t_semaphore)
+                FEwrong_type_argument(@'mp::semaphore', cv);
+ AGAIN:
+#ifdef ECL_WINDOWS_THREADS
+        {
+                HANDLE h = (HANDLE)(sem->semaphore.handle);
+                if (WaitForSingleObject(h, INFINITE) != WAIT_OBJECT_0) {
+			FEwin32_error("Unable to wait on semaphore", 0);
+                }
+        }
+#else
+# ifdef HAVE_SEM_INIT
+        {
+                sem_t *h = (sem_t *)(sem->semaphore.handle);
+                int rc = sem_wait(h);
+                if (sem_wait(h)) {
+                        if (errno == EINTR) {
+                                ecl_check_pending_interrupts();
+                                goto AGAIN;
+                        }
+                        FElibc_error("Unable to wait on semaphore", 0);
+                }
+        }
+# endif /* HAVE_SEM_INIT */
+#endif /* ECL_WINDOWS_THREADS */
+        @(return Ct)
+}
+
+cl_object
+mp_semaphore_signal(cl_object sem)
+{
+        if (typeof(sem) != t_semaphore)
+                FEwrong_type_argument(@'mp::semaphore', cv);
+ AGAIN:
+#ifdef ECL_WINDOWS_THREADS
+        {
+                HANDLE h = (HANDLE)(sem->semaphore.handle);
+                if (!ReleaseSemaphore(h, 1, NULL)) {
+                        FEwin32_error("Unable to post on semaphore ~A" 1, sem);
+                }
+        }
+#else
+# ifdef HAVE_SEM_INIT
+        {
+                sem_t *h = (sem_t *)(sem->semaphore.handle);
+                int rc = sem_wait(h);
+                if (sem_wait(h)) {
+                        if (errno == EINTR) {
+                                ecl_check_pending_interrupts();
+                                goto AGAIN;
+                        }
+                        FElibc_error("Unable to post on semaphore ~A", 1, sem);
+                }
+        }
+# endif /* HAVE_SEM_INIT */
+#endif /* ECL_WINDOWS_THREADS */
+        @(return Ct)
+}
+
+cl_object
+mp_semaphore_close(cl_object sem)
+{
+        if (typeof(sem) != t_semaphore)
+                FEwrong_type_argument(@'mp::semaphore', cv);
+#ifdef ECL_WINDOWS_THREADS
+        {
+                HANDLE h = (HANDLE)(sem->semaphore.handle);
+                if (h) CloseHandle(h);
+        }
+#else
+# ifdef HAVE_SEM_INIT
+        /*
+         * No need for closing.
+         */
+# endif /* HAVE_SEM_INIT */
+#endif /* ECL_WINDOWS_THREADS */
+        @(return Ct)
+}
+
+#endif /* ECL_SEMAPHORES */
+
 /*----------------------------------------------------------------------
  * INITIALIZATION
  */

src/c/typespec.d

@@ -205,6 +205,10 @@ ecl_type_to_symbol(cl_type t)
 		return @'mp::lock';
 	case t_condition_variable:
 		return @'mp::condition-variable';
+#endif
+#ifdef ECL_SEMAPHORES
+	case t_semaphore:
+		return @'mp::semaphore';
 #endif
 	case t_codeblock:
 		return @'si::code-block';

src/clos/builtin.lsp

@@ -85,7 +85,8 @@
 	    (si::weak-pointer)
 	    #+threads (mp::process)
 	    #+threads (mp::lock)
-	    #+threads (mp::condition-variable))))
+	    #+threads (mp::condition-variable)
+	    #+semaphores (mp::semaphore))))
 
 (loop for (name . rest) in '#.+builtin-classes+
    with index = 1

src/configure

@@ -5972,6 +5972,87 @@ $as_echo "yes" >&6; }
       { $as_echo "$as_me:$LINENO: result: no" >&5
 $as_echo "no" >&6; }
     fi
+    { $as_echo "$as_me:$LINENO: checking working sem_init()" >&5
+$as_echo_n "checking working sem_init()... " >&6; }
+if test "$cross_compiling" = yes; then
+  { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+{ { $as_echo "$as_me:$LINENO: error: cannot run test program while cross compiling
+See \`config.log' for more details." >&5
+$as_echo "$as_me: error: cannot run test program while cross compiling
+See \`config.log' for more details." >&2;}
+   { (exit 1); exit 1; }; }; }
+else
+  cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
+
+#ifdef HAVE_SEMAPHORE_H
+#include <semaphore.h>
+int main() {
+  sem_t aux;
+  if (sem_init(&aux, 0, 0))
+    exit(1);
+  exit(0);
+#else
+int main() {
+  exit(1);
+}
+#endif
+}
+_ACEOF
+rm -f conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+  *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\""
+$as_echo "$ac_try_echo") >&5
+  (eval "$ac_link") 2>&5
+  ac_status=$?
+  $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
+  { (case "(($ac_try" in
+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+  *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\""
+$as_echo "$ac_try_echo") >&5
+  (eval "$ac_try") 2>&5
+  ac_status=$?
+  $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  working_sem_init=yes
+else
+  $as_echo "$as_me: program exited with status $ac_status" >&5
+$as_echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+( exit $ac_status )
+working_sem_init=no
+fi
+rm -rf conftest.dSYM
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
+fi
+
+
+{ $as_echo "$as_me:$LINENO: result: $working_sem_init" >&5
+$as_echo "$working_sem_init" >&6; }
+if test $working_sem_init = yes ; then
+  cat >>confdefs.h <<\_ACEOF
+#define ECL_SEMAPHORES 1
+_ACEOF
+
+  cat >>confdefs.h <<\_ACEOF
+#define HAVE_SEM_INIT 1
+_ACEOF
+
+fi
+
   fi
 else
   boehm_configure_flags="${boehm_configure_flags} --disable-threads"
@@ -7366,9 +7447,10 @@ done
 
 
 
+
 for ac_header in sys/resource.h sys/utsname.h float.h pwd.h dlfcn.h link.h \
                   mach-o/dyld.h ulimit.h dirent.h sys/ioctl.h sys/select.h \
-                  sys/wait.h
+                  sys/wait.h semaphore.h
 do
 as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh`
 if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then

src/configure.in

@@ -454,6 +454,7 @@ if test "${enable_threads}" = "yes" ; then
     else
       AC_MSG_RESULT([no])
     fi
+    ECL_POSIX_SEMAPHORES
   fi
 else
   boehm_configure_flags="${boehm_configure_flags} --disable-threads"
@@ -564,7 +565,7 @@ dnl !!! end autoscan
 
 AC_CHECK_HEADERS( [sys/resource.h sys/utsname.h float.h pwd.h dlfcn.h link.h] \
                   [mach-o/dyld.h ulimit.h dirent.h sys/ioctl.h sys/select.h] \
-                  [sys/wait.h] )
+                  [sys/wait.h semaphore.h] )
 
 dnl =====================================================================
 dnl Checks for typedefs, structures, and compiler characteristics.

src/h/config.h.in

@@ -67,6 +67,7 @@
 #undef ECL_THREADS
 #ifdef ECL_THREADS
 # define GC_THREADS
+/* # udef ECL_SEMAPHORES */
 #endif
 
 /* __thread thread-local variables?                                     */
@@ -337,6 +338,10 @@ typedef unsigned @CL_FIXNUM_TYPE@ cl_hashkey;
 #undef HAVE_COPYSIGNL
 /* whether we have sched_yield() that gives priority to other threads	*/
 #undef HAVE_SCHED_YIELD
+/* whether we semaphore.h                                               */
+#undef HAVE_SEMAPHORE_H
+/* whether we have a working sem_init()                                 */
+#undef HAVE_SEM_INIT
 /* uname() for system identification					*/
 #undef HAVE_UNAME
 #undef HAVE_UNISTD_H

src/h/external.h

@@ -1626,6 +1626,13 @@ extern ECL_API cl_object mp_restore_signals(cl_object sigmask);
 
 extern ECL_API bool ecl_import_current_thread(cl_object process_name, cl_object process_binding);
 extern ECL_API void ecl_release_current_thread(void);
+# ifdef ECL_SEMAPHORES
+extern ECL_API void mp_make_semaphore _ARGS((cl_narg, cl_object, ...));
+extern ECL_API void mp_semaphore_trywait(cl_object);
+extern ECL_API void mp_semaphore_wait(cl_object);
+extern ECL_API void mp_semaphore_signal(cl_object);
+extern ECL_API void mp_semaphore_close(cl_object);
+# endif
 #endif
 
 

src/h/object.h

@@ -84,6 +84,9 @@ typedef enum {
 	t_process,
 	t_lock,
 	t_condition_variable,
+# ifdef ECL_SEMAPHORES
+        t_semaphore,
+# endif
 #endif
 	t_codeblock,
 	t_foreign,
@@ -851,7 +854,11 @@ struct ecl_condition_variable {
         pthread_cond_t cv;
 };
 
-#endif
+struct ecl_semaphore {
+        HEADER;
+        void *handle;
+};
+#endif /* ECL_THREADS */
 
 #ifdef CLOS
 #define CLASS_OF(x)		(x)->instance.clas
@@ -919,6 +926,9 @@ union cl_lispunion {
 	struct ecl_process	process; 	/*  process  */
 	struct ecl_lock		lock; 		/*  lock  */
         struct ecl_condition_variable condition_variable; /*  condition-variable */
+#endif
+#ifdef ECL_SEMAPHORES
+        struct ecl_semaphore	semaphore;	/*  semaphore  */
 #endif
 	struct ecl_codeblock	cblock;		/*  codeblock  */
 	struct ecl_foreign	foreign; 	/*  user defined data type */