Imported Upstream version 11.2

1 files changed, 5 insertions, 450 deletions

diff --git a/xen.c b/xen.c
index 4297bf9..eeea060 100644
--- a/xen.c
+++ b/xen.c
@@ -20,12 +20,6 @@
 #define S_gc_on  "gc-on"
 
 
-XEN xen_return_first(XEN a, ...)
-{
-  return(a);
-}
-
-
 char *xen_strdup(const char *str)
 {
   char *newstr = NULL;
@@ -37,436 +31,6 @@ char *xen_strdup(const char *str)
 
 
 
-/* ------------------------------ GUILE ------------------------------ */
-
-#if HAVE_GUILE
-
-off_t xen_to_c_off_t_or_else(XEN obj, off_t fallback)
-{
-  if ((XEN_NOT_FALSE_P(scm_integer_p(obj))) && XEN_EXACT_P(obj))
-#if (defined(SIZEOF_OFF_T) && (SIZEOF_OFF_T > 4)) || (defined(_FILE_OFFSET_BITS) && (_FILE_OFFSET_BITS == 64))
-    return(XEN_TO_C_LONG_LONG(obj));
-#else
-    return(XEN_TO_C_INT(obj));
-#endif
-  else
-    if (XEN_NUMBER_P(obj))
-      return((off_t)XEN_TO_C_DOUBLE(obj));
-  return(fallback);
-}
-
-
-off_t xen_to_c_off_t(XEN obj)
-{
-  if (XEN_EXACT_P(obj))
-#if (defined(SIZEOF_OFF_T) && (SIZEOF_OFF_T > 4)) || (defined(_FILE_OFFSET_BITS) && (_FILE_OFFSET_BITS == 64))
-    return(XEN_TO_C_LONG_LONG(obj));
-#else
-    return(XEN_TO_C_INT(obj));
-#endif
-  return((off_t)XEN_TO_C_DOUBLE(obj)); /* inexact integer squeezed through somewhere */
-}
-
-
-XEN c_to_xen_off_t(off_t val)
-{
-#if (defined(SIZEOF_OFF_T) && (SIZEOF_OFF_T > 4)) || (defined(_FILE_OFFSET_BITS) && (_FILE_OFFSET_BITS == 64))
-    return(C_TO_XEN_LONG_LONG(val));
-#else
-    return(C_TO_XEN_INT(val));
-#endif
-}
-
-
-int64_t xen_to_c_int64_t_or_else(XEN obj, int64_t fallback)
-{
-  if ((XEN_NOT_FALSE_P(scm_integer_p(obj))) && XEN_EXACT_P(obj))
-    return(XEN_TO_C_LONG_LONG(obj));
-  else
-    if (XEN_NUMBER_P(obj))
-      return((int64_t)XEN_TO_C_DOUBLE(obj));
-  return(fallback);
-}
-
-
-int64_t xen_to_c_int64_t(XEN obj)
-{
-  if (XEN_EXACT_P(obj))
-    return(XEN_TO_C_LONG_LONG(obj));
-  return((int64_t)XEN_TO_C_DOUBLE(obj)); /* inexact integer squeezed through somewhere */
-}
-
-
-
-char *xen_version(void)
-{
-  char *buf;
-  buf = (char *)calloc(64, sizeof(char));
-#if HAVE_SNPRINTF
-  snprintf(buf, 64, "Guile: %s, Xen: %s", XEN_TO_C_STRING(scm_version()), XEN_VERSION);
-#else
-  sprintf(buf, "Guile: %s, Xen: %s", XEN_TO_C_STRING(scm_version()), XEN_VERSION);
-#endif
-  return(buf);
-}
-
-
-void xen_repl(int argc, char **argv)
-{
-  scm_shell(argc, argv); 
-}
-
-
-void xen_gc_mark(XEN val)
-{
-  scm_gc_mark(val);
-}
-
-
-double xen_to_c_double(XEN a) 
-{
-  double num = 0.0;
-#if HAVE_SCM_TO_SIGNED_INTEGER
-  num = scm_to_double(a);
-#else
-  num = scm_num2dbl(a, c__FUNCTION__);
-#endif
-#if HAVE_DECL_ISNAN
-  if (isnan(num)) return(0.0);
-#endif
-#if HAVE_DECL_ISINF
-  if (isinf(num)) return(0.0);
-#endif
-  return(num);
-}
-
-
-double xen_to_c_double_or_else(XEN a, double b) 
-{
-  if (XEN_NUMBER_P(a))
-    return(xen_to_c_double(a));
-  return(b);
-}
-
-
-bool xen_integer_p(XEN a) 
-{
-#if (!defined(SCM_PACK)) || HAVE_SCM_TO_SIGNED_INTEGER
-  return(XEN_NOT_FALSE_P(scm_integer_p(a)));
-#else
-  if (SCM_INUMP(a)) return(true);
-  if (SCM_REALP(a))
-    {
-      double r;
-#ifdef SCM_REAL_VALUE
-      r = SCM_REAL_VALUE(a);
-#else
-      r = SCM_REALPART(a);
-#endif
-      if (r == floor(r))
-	return(true);
-    }
-  return(false);
-#endif
-}
-
-
-int xen_to_c_int(XEN a)
-{
-  /* Scheme integer (possibly inexact) to C int without errors */
-#if HAVE_SCM_TO_SIGNED_INTEGER
-    if ((SCM_INEXACTP(a)) || (SCM_FRACTIONP(a))) /* avoid error if inexact integer! SCM_INUMP deprecated in 1.7 */
-      {
-	if ((scm_is_true(scm_inf_p(a))) || 
-	    (scm_is_true(scm_nan_p(a)))) 
-	  return(0);
-	if (SCM_REALP(a)) 
-	  return((int)(SCM_REAL_VALUE(a)));
-	return((int)scm_to_double(a)); 
-      }
-    return(scm_to_int32(a)); 
-#else
-  #if HAVE_SCM_NUM2INT
-    if (SCM_INUMP(a)) return(SCM_INUM(a));
-    if (SCM_REALP(a)) return((int)(SCM_REAL_VALUE(a)));
-    return((int)scm_num2dbl(a, c__FUNCTION__));
-  #else
-    return((int)gh_scm2int(a));  /* ah for the good old days... */
-  #endif
-#endif
-}
-
-
-int xen_to_c_int_or_else(XEN obj, int fallback)
-{
-  /* don't want errors about floats with non-zero fractions etc */
-  if (XEN_NUMBER_P(obj))
-    return(xen_to_c_int(obj));
-  return(fallback);
-}
-
-
-void xen_guile_define_procedure_with_setter(const char *get_name, XEN (*get_func)(), 
-					    const char *get_help, XEN (*set_func)(), XEN local_doc,
-					    int get_req, int get_opt, int set_req, int set_opt)
-{
-#if HAVE_SCM_C_DEFINE
-  XEN str = XEN_FALSE;
-#if XEN_DEBUGGING
-  if (XEN_DEFINED_P(get_name)) fprintf(stderr, "%s is defined\n", get_name);
-  /* if (!(snd_url(get_name))) fprintf(stderr, "%s not documented\n", get_name); */
-#endif
-
-  if (get_help) str = C_TO_XEN_STRING(get_help);
-  XEN_PROTECT_FROM_GC(
-    XEN_DEFINE(get_name,
-      scm_make_procedure_with_setter(
-        XEN_NEW_PROCEDURE(get_name, XEN_PROCEDURE_CAST get_func, get_req, get_opt, 0),
-	XEN_NEW_PROCEDURE(get_name, XEN_PROCEDURE_CAST set_func, set_req, set_opt, 0))));
-  if (get_help)
-    {
-      scm_set_object_property_x(C_STRING_TO_XEN_SYMBOL(get_name), local_doc, str);
-      scm_set_procedure_property_x(XEN_NAME_AS_C_STRING_TO_VALUE(get_name), local_doc, str);
-    }
-#else
-  scm_set_object_property_x(
-    XEN_CDR(
-      XEN_DEFINE(get_name,
-	scm_make_procedure_with_setter(
-          XEN_NEW_PROCEDURE(get_name, XEN_PROCEDURE_CAST get_func, get_req, get_opt, 0),
-	  XEN_NEW_PROCEDURE(get_name, XEN_PROCEDURE_CAST set_func, set_req, set_opt, 0)
-	  ))),
-    local_doc,
-    C_TO_XEN_STRING(get_help));
-#endif
-}
-
-
-void xen_guile_define_procedure_with_reversed_setter(const char *get_name, XEN (*get_func)(), 
-						     const char *get_help, XEN (*set_func)(), XEN (*reversed_set_func)(), 
-						     XEN local_doc, int get_req, int get_opt, int set_req, int set_opt)
-{
-#if HAVE_SCM_C_DEFINE
-  XEN str = XEN_FALSE;
-#if XEN_DEBUGGING
-  if (XEN_DEFINED_P(get_name)) fprintf(stderr, "%s is defined\n", get_name);
-  /* if (!(snd_url(get_name))) fprintf(stderr, "%s not documented\n", get_name); */
-#endif
-  if (get_help) str = C_TO_XEN_STRING(get_help);
-  XEN_PROTECT_FROM_GC(
-    XEN_DEFINE(get_name,
-      scm_make_procedure_with_setter(
-        XEN_NEW_PROCEDURE(get_name, XEN_PROCEDURE_CAST get_func, get_req, get_opt, 0),
-	XEN_NEW_PROCEDURE(get_name, XEN_PROCEDURE_CAST reversed_set_func, set_req, set_opt, 0))));
-  if (get_help)
-    {
-      scm_set_object_property_x(C_STRING_TO_XEN_SYMBOL(get_name), local_doc, str);
-      scm_set_procedure_property_x(XEN_NAME_AS_C_STRING_TO_VALUE(get_name), local_doc, str);
-    }
-#else
-  scm_set_object_property_x(
-    XEN_CDR(
-      XEN_DEFINE(get_name,
-	scm_make_procedure_with_setter(
-          XEN_NEW_PROCEDURE(get_name, XEN_PROCEDURE_CAST get_func, get_req, get_opt, 0),
-	  XEN_NEW_PROCEDURE(get_name, XEN_PROCEDURE_CAST reversed_set_func, set_req, set_opt, 0)
-	  ))),
-    local_doc,
-    C_TO_XEN_STRING(get_help));
-#endif
-}
-
-
-XEN xen_guile_create_hook(const char *name, int args, const char *help, XEN local_doc)
-{
-  /* make-hook + documentation */
-  XEN hook;
-  hook = XEN_DEFINE_SIMPLE_HOOK(args);
-  if ((name) && (help))
-    scm_set_object_property_x(XEN_PROTECT_FROM_GC(hook), local_doc, C_TO_XEN_STRING(help));
-  XEN_DEFINE(name, hook);
-  return(hook);
-}
-
-
-#if XEN_DEBUGGING && HAVE_SCM_C_DEFINE_GSUBR
-XEN xen_guile_dbg_new_procedure(const char *name, XEN (*func)(), int req, int opt, int rst)
-{
-  /* look for name collisions */
-  if ((name) && (strlen(name) > 0) && XEN_DEFINED_P(name)) fprintf(stderr, "%s is defined\n", name);
-  /* if ((name) && (strlen(name) > 0) && (!(snd_url(name)))) fprintf(stderr, "%s not documented\n", name); */
-  return(scm_c_define_gsubr(name, req, opt, rst, func));
-}
-#endif
-
-
-XEN xen_guile_add_to_load_path(char *path)
-{
-  char *buf = NULL;
-  int len;
-  XEN result = XEN_FALSE;
-  if (path)
-    {
-      len = (strlen(path) * 2) + 256;
-      buf = (char *)calloc(len, sizeof(char));
-#if HAVE_SNPRINTF
-      snprintf(buf, len, "(if (not (member \"%s\" %%load-path)) (set! %%load-path (cons \"%s\" %%load-path)))", path, path);
-#else
-      sprintf(buf, "(if (not (member \"%s\" %%load-path)) (set! %%load-path (cons \"%s\" %%load-path)))", path, path);
-#endif 
-      result = XEN_EVAL_C_STRING(buf);
-      free(buf);
-    }
-  return(result);
-}
-
-
-#if HAVE_SCM_C_MAKE_RECTANGULAR
-static char **xen_temp_strings = NULL;
-static int xen_temp_strings_ctr = 0;
-#define XEN_TEMP_STRINGS_SIZE 512
-
-#if HAVE_PTHREADS
-static pthread_mutex_t xen_string_lock = PTHREAD_MUTEX_INITIALIZER;
-#endif
-
-
-char *xen_guile_to_c_string_with_eventual_free(XEN str)
-{
-  char *result;
-  if (XEN_FALSE_P(str)) return(NULL);
-#if XEN_DEBUGGING
-  XEN_ASSERT_TYPE(XEN_STRING_P(str), str, 0, "xen->c-string", "a string");
-#endif
-    
-  if (!xen_temp_strings)
-    xen_temp_strings = (char **)calloc(XEN_TEMP_STRINGS_SIZE, sizeof(char *));
-
-  result = scm_to_locale_string(str); /* not XEN_TO_C_STRING here -- infinite recursion */
-
-#if HAVE_PTHREADS
-  pthread_mutex_lock(&xen_string_lock); 
-#endif
-
-  if (xen_temp_strings[xen_temp_strings_ctr]) 
-    free(xen_temp_strings[xen_temp_strings_ctr]);
-
-  xen_temp_strings[xen_temp_strings_ctr++] = result;
-  if (xen_temp_strings_ctr >= XEN_TEMP_STRINGS_SIZE) xen_temp_strings_ctr = 0;
-
-#if HAVE_PTHREADS
-  pthread_mutex_unlock(&xen_string_lock); 
-#endif
-
-  return(result);
-}
-#endif
-
-#if !(defined(__GNUC__) && (!(defined(__cplusplus))))
-  XEN xen_guile_c_to_xen_string(const char *a) {return((a) ? scm_from_locale_string(a) : XEN_FALSE);}
-#endif
-
-
-#if (!HAVE_SCM_CONTINUATION_P)
-static XEN g_continuation_p(XEN obj)
-{
-#ifdef SCM_CONTINUATIONP
-  return(C_TO_XEN_BOOLEAN(SCM_NIMP(obj) && SCM_CONTINUATIONP(obj)));
-#else
-  return(C_TO_XEN_BOOLEAN(XEN_PROCEDURE_P(obj)));
-#endif
-}
-#endif
-
-
-/* -------- block comments -------- */
-/* libguile/read.c */
-
-/* this doesn't always work correctly -- the # reader is called at a different place in
- *    libguile/read.c than the built-in #! !# reader, and insists on returning a value.
- *    That value (#f here) screws up code such as:
- *
- *      (define (gad a)
- *        (let ((b a))
- *          b
- *      #|
- *          a comment
- *      |#
- *          ))
- * 
- *   which returns #f, not b.  I can't see how to fix this.
- */
-
-#if USE_SND
-  void snd_warning(const char *format, ...);
-#endif
-
-static XEN g_skip_block_comment(XEN ch, XEN port)
-{
-  int bang_seen = 0;
-  while (true)
-    {
-      int c;
-      c = scm_getc(port);
-      if (c == EOF)
-	{
-#if USE_SND
-	  snd_warning("unterminated `#| ... |#' comment");
-#else
-	  fprintf(stderr, "unterminated `#| ... |#' comment");
-#endif
-	  return(XEN_FALSE);
-	}
-      if (c == '|')
-	bang_seen = 1;
-      else 
-	{
-	  if ((c == '#') && (bang_seen))
-	    return(XEN_FALSE);
-	  else bang_seen = 0;
-	}
-    }
-  return(XEN_FALSE);
-}
-
-
-static XEN g_gc_off(void) {return(XEN_FALSE);}
-static XEN g_gc_on(void)  {return(XEN_FALSE);}
-
-
-void xen_initialize(void)
-{
-#if (!HAVE_SCM_CONTINUATION_P)
-  XEN_DEFINE_PROCEDURE("continuation?", g_continuation_p, 1, 0, 0, "#t if arg is a continuation");
-#endif
-
-#if (!defined(M_PI))
-  #define M_PI 3.14159265358979323846264338327
-#endif
-  XEN_DEFINE("pi", C_TO_XEN_DOUBLE(M_PI)); /* not XEN_DEFINE_CONSTANT which assumes int */
-
-  {
-    /* CL uses '#| |#' for block comments, so implement them in Guile */
-    /*   this is in R6RS, so presumably Guile will eventually implement them itself */
-    XEN proc;
-    proc = XEN_NEW_PROCEDURE("%skip-comment%", g_skip_block_comment, 2, 0, 0);
-    scm_read_hash_extend(C_TO_XEN_CHAR('|'), proc);
-  }
-
-  XEN_DEFINE_PROCEDURE(S_gc_off, g_gc_off, 0, 0, 0, "(" S_gc_off ") is a no-op");
-  XEN_DEFINE_PROCEDURE(S_gc_on,  g_gc_on,  0, 0, 0, "(" S_gc_on ") is a no-op");
-
-  XEN_EVAL_C_STRING("(define (bignum x) x)");          /* consistency with s7 */
-  XEN_EVAL_C_STRING("(define bignum-precision (make-procedure-with-setter (lambda () 0) (lambda (x) x)))");
-
-  XEN_EVAL_C_STRING("(define call-with-exit call-with-current-continuation)"); /* call/cc here doesn't work in Guile 1.6.n */
- }
-
-#endif
-
-
-
-
 /* ------------------------------ RUBY ------------------------------ */
 
 #if HAVE_RUBY
@@ -1793,9 +1357,9 @@ char *xen_version(void)
   char *buf;
   buf = (char *)calloc(64, sizeof(char));
 #if HAVE_SNPRINTF
-  snprintf(buf, 64, "S7: %s (%s), Xen: %s", S7_VERSION, S7_DATE, XEN_VERSION);
+  snprintf(buf, 64, "s7: %s (%s), Xen: %s", S7_VERSION, S7_DATE, XEN_VERSION);
 #else
-  sprintf(buf, "S7: %s (%s), Xen: %s", S7_VERSION, S7_DATE, XEN_VERSION);
+  sprintf(buf, "s7: %s (%s), Xen: %s", S7_VERSION, S7_DATE, XEN_VERSION);
 #endif
   return(buf);
 }
@@ -2272,7 +1836,7 @@ bool directory_p(const char *filename);
 
 static bool directory_p(const char *filename)
 {
-#if MUS_WINDOZE
+#if HAVE_WINDOZE
   return(false);
 
 #else
@@ -2469,7 +2033,7 @@ s7_scheme *s7_xen_initialize(s7_scheme *sc)
       s7 = s7_init();
       if (!s7) 
 	{
-	  fprintf(stderr, "Can't initialize S7!\n");
+	  fprintf(stderr, "Can't initialize s7!\n");
 	  return(NULL);
 	}
     }
@@ -2506,21 +2070,12 @@ s7_scheme *s7_xen_initialize(s7_scheme *sc)
   XEN_DEFINE_PROCEDURE(S_gc_off,              g_gc_off_w,             0, 0, 0, H_gc_off);
   XEN_DEFINE_PROCEDURE(S_gc_on,               g_gc_on_w,              0, 0, 0, H_gc_on);
 
-
-  /* these are for compatibility with Guile */
-  XEN_EVAL_C_STRING("(defmacro use-modules (arg . args) #f)");
-  XEN_EVAL_C_STRING("(define (debug-enable . args) \"guile compatibility, a no-op in s7\" #f)");
-  XEN_EVAL_C_STRING("(define (read-enable . args) \"guile compatibility, a no-op in s7\" #f)");
-  XEN_EVAL_C_STRING("(define-macro (debug-set! . args) #f)"); /* needs to be a macro so that its arguments are not evaluated */
-  XEN_EVAL_C_STRING("(define (make-soft-port . args) \"guile compatibility, a no-op in s7\" #f)");
-  XEN_EVAL_C_STRING("(define (current-module) \"synonym for current-environment\" (current-environment))");
   XEN_EVAL_C_STRING("(define load-from-path load)");
-  XEN_EVAL_C_STRING("(define shell system)"); /* backwards compatibility (no longer in examp.scm) */
   XEN_EVAL_C_STRING("(define (1+ x) \"add 1 to arg\" (+ x 1))");
   XEN_EVAL_C_STRING("(define (1- x) \"subtract 1 from arg\" (- x 1))");
   XEN_EVAL_C_STRING("(defmacro while (cond . body) `(do () ((not ,cond)) ,@body))");
   XEN_EVAL_C_STRING("(define (identity x) \"return arg\" x)");                    /* popup.scm uses this */
-  XEN_EVAL_C_STRING("(define (throw . args) (apply error args))"); /* selection.scm uses this */
+  XEN_EVAL_C_STRING("(define (throw . args) (apply error args))"); /* selection.scm uses this (also the break macro in snd-xen.c) */
 
   return(s7);
 }