Imported Upstream version 11.4

1 files changed, 55 insertions, 63 deletions

diff --git a/xen.c b/xen.c
index 7f73807..1b9bdc4 100644
--- a/xen.c
+++ b/xen.c
@@ -235,15 +235,17 @@ XEN xen_set_assoc(XEN key, XEN val, XEN alist)
 }
 
 
-XEN xen_assoc(XEN key, XEN alist)
-{
-  XEN val;
-  val = rb_ary_assoc(alist, key);
-  if (val != Qnil)
-    return(rb_ary_entry(val, 1));
-  return(Qfalse);
-}
-
+XEN xen_assoc(XEN key, XEN alist) 
+{ 
+  if (XEN_CONS_P(alist)) 
+    { 
+      XEN val; 
+      val = rb_ary_assoc(alist, key); 
+      if (val != Qnil) 
+	return(rb_ary_entry(val, 1)); 
+    } 
+  return(Qfalse); 
+} 
 
 
 static char *scheme_to_ruby(const char *name)
@@ -1388,7 +1390,7 @@ void xen_initialize(void)
 #include "s7.h"
 
 s7_scheme *s7;
-XEN xen_false, xen_true, xen_nil, xen_undefined;
+XEN xen_false, xen_true, xen_nil, xen_undefined, xen_zero;
 
 char *xen_version(void)
 {
@@ -1403,27 +1405,10 @@ char *xen_version(void)
 }
 
 
-double xen_to_c_double(XEN a) 
-{
-  if (s7_is_integer(a))
-    return((double)s7_integer(a));
-  if (s7_is_rational(a))
-    return((double)s7_numerator(a) / (double)s7_denominator(a));
-  return(s7_real(a));
-}
-
-
 int xen_to_c_int(XEN a) /* xen_to_c_int is expected to return an int (not an int64_t) */
 {
   s7_Int val;
-  if (s7_is_integer(a))
-    val = s7_integer(a);
-  else
-    {
-      if (s7_is_rational(a))
-	val = (int64_t)(s7_numerator(a) / s7_denominator(a));
-      else val = (int64_t)s7_real(a);
-    }
+  val = s7_number_to_integer(a);
   if (val > INT_MAX)
     return(INT_MAX);
   if (val < INT_MIN)
@@ -1435,13 +1420,7 @@ int xen_to_c_int(XEN a) /* xen_to_c_int is expected to return an int (not an int
 int64_t xen_to_c_int64_t(XEN a)
 {
   if (XEN_NUMBER_P(a))
-    {
-      if (s7_is_integer(a))
-	return(s7_integer(a));
-      if (s7_is_rational(a))
-	return((int64_t)(s7_numerator(a) / s7_denominator(a)));
-      return((int64_t)s7_real(a));
-    }
+    return(s7_number_to_integer(a));
   return(0); /* ?? in xm.c, XtSetValues of XmUserData with a pointer falls back on this -- probably can't work */
 }
 
@@ -1449,7 +1428,7 @@ int64_t xen_to_c_int64_t(XEN a)
 double xen_to_c_double_or_else(XEN a, double b) 
 {
   if (XEN_NUMBER_P(a))
-    return(xen_to_c_double(a));
+    return(s7_number_to_real(a));
   return(b);
 }
 
@@ -1511,14 +1490,6 @@ void xen_repl(int argc, char **argv)
 }
 
 
-bool xen_s7_type_p(XEN obj, XEN_OBJECT_TYPE type)
-{
-  return((s7_is_object(obj)) &&
-	 (s7_object_value(obj)) && /* i.e. not a null object */
-	 (s7_object_type(obj) == type));
-}
-
-
 void xen_s7_ignore(s7_function func) /* squelch compiler warnings */
 {
 }
@@ -1790,8 +1761,12 @@ static XEN g_run_hook(XEN all_args)
 
   if (ghook_arity(obj) != arglen)
     XEN_ERROR(XEN_ERROR_TYPE("wrong-number-of-args"),
-	      XEN_LIST_2(C_TO_XEN_STRING("run-hook"),
+	      XEN_LIST_5(C_TO_XEN_STRING("run hook (~A) got ~A args, but wants ~A (args: ~A)"),
+			 hook,
+			 C_TO_XEN_INT(arglen),
+			 C_TO_XEN_INT(ghook_arity(obj)),
 			 args));
+			 
 
   functions = ghook_functions(obj);
   while (XEN_NOT_NULL_P(functions))
@@ -1895,13 +1870,6 @@ static bool file_probe(const char *arg)
 }
 
 
-#if USE_SND
-
-char *snd_tempnam(void);
-bool directory_p(const char *filename);
-
-#else
-
 static bool directory_p(const char *filename)
 {
 #if HAVE_WINDOZE
@@ -1923,8 +1891,6 @@ static bool directory_p(const char *filename)
 #endif
 }
 
-#endif
-
 
 static XEN g_file_exists_p(XEN name)
 {
@@ -2031,16 +1997,41 @@ static XEN g_current_time(void)
 
 static XEN g_tmpnam(void)
 {
-  XEN str;
-  char *result;
-#if USE_SND
-  result = snd_tempnam();
+  #define H_tmpnam "(tmpnam) returns a new (hopefully unused) tempporary file name"
+  #define BUFFER_SIZE 512
+  static int file_ctr = 0;
+  char *str, *tmpdir = NULL;
+  int len;
+  XEN result;
+
+  str = (char *)calloc(BUFFER_SIZE, sizeof(char));
+  tmpdir = xen_strdup(getenv("TMPDIR"));
+
+#ifdef P_tmpdir
+  if (tmpdir == NULL) 
+    tmpdir = xen_strdup(P_tmpdir); /* /usr/include/stdio.h */
+  if (tmpdir)
+    {
+      len = strlen(tmpdir);
+      if (len > 0)
+	{
+	  if (tmpdir[len - 1] == '/') tmpdir[len - 1] = 0;
+	}
+      else
+	{
+	  free(tmpdir);
+	  tmpdir = xen_strdup(".");
+	}
+    }
 #else
-  result = tempnam(NULL, "xen_");
+  if (tmpdir == NULL) tmpdir = xen_strdup("/tmp");
 #endif
-  str = C_TO_XEN_STRING(result);
-  free(result);
-  return(str);
+
+  snprintf(str, BUFFER_SIZE, "%s/xen_%d_%d", tmpdir, (int)getpid(), file_ctr++);
+  if (tmpdir) free(tmpdir);
+  result = C_TO_XEN_STRING(str);
+  free(str);
+  return(result);
 }
 
 
@@ -2111,6 +2102,7 @@ s7_scheme *s7_xen_initialize(s7_scheme *sc)
   xen_true = s7_t(s7);
   xen_nil = s7_nil(s7);
   xen_undefined = s7_undefined(s7);
+  xen_zero = s7_make_integer(s7, 0);
 
   ghook_tag = XEN_MAKE_OBJECT_TYPE("<hook>", print_hook, free_hook, equalp_hook, mark_hook, NULL, NULL, NULL, NULL, NULL);
 
@@ -2131,7 +2123,7 @@ s7_scheme *s7_xen_initialize(s7_scheme *sc)
   XEN_DEFINE_PROCEDURE("delete-file",         g_delete_file_w,        1, 0, 0, H_delete_file);
   XEN_DEFINE_PROCEDURE("getcwd",              g_getcwd_w,             0, 0, 0, H_getcwd);
   XEN_DEFINE_PROCEDURE("strftime",            g_strftime_w,           2, 0, 0, H_strftime);
-  XEN_DEFINE_PROCEDURE("tmpnam",              g_tmpnam_w,             0, 0, 0, H_localtime);
+  XEN_DEFINE_PROCEDURE("tmpnam",              g_tmpnam_w,             0, 0, 0, H_tmpnam);
   XEN_DEFINE_PROCEDURE("localtime",           g_localtime_w,          1, 0, 0, H_localtime);
   XEN_DEFINE_PROCEDURE("current-time",        g_current_time_w,       0, 0, 0, H_current_time);
   XEN_DEFINE_PROCEDURE("ftell",               g_ftell_w,              1, 0, 0, "(ftell fd): lseek");