X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/e4b265d817c6758441bbfc66730cae98eabde9b5..9bc6fb0a7d91ae9a6c57cedb76022043db413ba5:/libguile/gh_data.c

diff --git a/libguile/gh_data.c b/libguile/gh_data.c
index e431208b3..31c9ea730 100644
--- a/libguile/gh_data.c
+++ b/libguile/gh_data.c
@@ -48,16 +48,6 @@
 
 /* data conversion C->scheme */
 
-#if (SCM_DEBUG_DEPRECATED == 0)
-
-SCM 
-gh_int2scmb (int x)		/* this is being phased out */
-{
-  return SCM_BOOL(x);
-}
-
-#endif  /* SCM_DEBUG_DEPRECATED == 0 */
-
 SCM 
 gh_bool2scm (int x)
 {
@@ -89,9 +79,9 @@ gh_char2scm (char c)
  return SCM_MAKE_CHAR (c);
 }
 SCM 
-gh_str2scm (const char *s, int len)
+gh_str2scm (const char *s, size_t len)
 {
-  return scm_makfromstr (s, len, 0);
+  return scm_mem2string (s, len);
 }
 SCM 
 gh_str02scm (const char *s)
@@ -105,21 +95,18 @@ gh_str02scm (const char *s)
    If START + LEN is off the end of DST, signal an out-of-range
    error.  */
 void 
-gh_set_substr (char *src, SCM dst, int start, int len)
+gh_set_substr (char *src, SCM dst, long start, size_t len)
 {
   char *dst_ptr;
-  unsigned long dst_len;
-  unsigned long effective_length;
+  size_t dst_len;
 
   SCM_ASSERT (SCM_STRINGP (dst), dst, SCM_ARG3, "gh_set_substr");
 
   dst_ptr = SCM_STRING_CHARS (dst);
   dst_len = SCM_STRING_LENGTH (dst);
-  SCM_ASSERT (len >= 0 && (unsigned) len <= dst_len,
-	      dst, SCM_ARG4, "gh_set_substr");
+  SCM_ASSERT (start + len <= dst_len, dst, SCM_ARG4, "gh_set_substr");
   
-  effective_length = ((unsigned) len < dst_len) ? len : dst_len;
-  memmove (dst_ptr + start, src, effective_length);
+  memmove (dst_ptr + start, src, len);
   scm_remember_upto_here_1 (dst);
 }
 
@@ -131,22 +118,22 @@ gh_symbol2scm (const char *symbol_str)
 }
 
 SCM
-gh_ints2scm (const int *d, int n)
+gh_ints2scm (const int *d, long n)
 {
-  int i;
+  long i;
   SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
   SCM *velts = SCM_VELTS(v);
 
   for (i = 0; i < n; ++i)
-    velts[i] = (SCM_FIXABLE (d[i]) ? SCM_MAKINUM (d[i]) : scm_long2big (d[i]));
+    velts[i] = (SCM_FIXABLE (d[i]) ? SCM_MAKINUM (d[i]) : scm_i_long2big (d[i]));
 
   return v;
 }
 
 SCM
-gh_doubles2scm (const double *d, int n)
+gh_doubles2scm (const double *d, long n)
 {
-  int i;
+  long i;
   SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
   SCM *velts = SCM_VELTS(v);
 
@@ -160,61 +147,55 @@ gh_doubles2scm (const double *d, int n)
    you arrange for the elements to be protected from GC while you
    initialize the vector.  */
 static SCM
-makvect (char* m, int len, int type)
+makvect (char *m, size_t len, int type)
 {
-  SCM ans;
-  SCM_NEWCELL (ans);
-  SCM_DEFER_INTS;
-  SCM_SET_UVECTOR_BASE (ans, m);
-  SCM_SET_UVECTOR_LENGTH (ans, len, type);
-  SCM_ALLOW_INTS;
-  return ans;
+  return scm_cell (SCM_MAKE_UVECTOR_TAG (len, type), (scm_t_bits) m);
 }
 
 SCM
-gh_chars2byvect (const char *d, int n)
+gh_chars2byvect (const char *d, long n)
 {
-  char *m = scm_must_malloc (n * sizeof (char), "vector");
+  char *m = scm_gc_malloc (n * sizeof (char), "vector");
   memcpy (m, d, n * sizeof (char));
   return makvect (m, n, scm_tc7_byvect);
 }
 
 SCM
-gh_shorts2svect (const short *d, int n)
+gh_shorts2svect (const short *d, long n)
 {
-  char *m = scm_must_malloc (n * sizeof (short), "vector");
+  char *m = scm_gc_malloc (n * sizeof (short), "vector");
   memcpy (m, d, n * sizeof (short));
   return makvect (m, n, scm_tc7_svect);
 }
 
 SCM
-gh_longs2ivect (const long *d, int n)
+gh_longs2ivect (const long *d, long n)
 {
-  char *m = scm_must_malloc (n * sizeof (long), "vector");
+  char *m = scm_gc_malloc (n * sizeof (long), "vector");
   memcpy (m, d, n * sizeof (long));
   return makvect (m, n, scm_tc7_ivect);
 }
 
 SCM
-gh_ulongs2uvect (const unsigned long *d, int n)
+gh_ulongs2uvect (const unsigned long *d, long n)
 {
-  char *m = scm_must_malloc (n * sizeof (unsigned long), "vector");
+  char *m = scm_gc_malloc (n * sizeof (unsigned long), "vector");
   memcpy (m, d, n * sizeof (unsigned long));
   return makvect (m, n, scm_tc7_uvect);
 }
 
 SCM
-gh_floats2fvect (const float *d, int n)
+gh_floats2fvect (const float *d, long n)
 {
-  char *m = scm_must_malloc (n * sizeof (float), "vector");
+  char *m = scm_gc_malloc (n * sizeof (float), "vector");
   memcpy (m, d, n * sizeof (float));
   return makvect (m, n, scm_tc7_fvect);
 }
 
 SCM
-gh_doubles2dvect (const double *d, int n)
+gh_doubles2dvect (const double *d, long n)
 {
-  char *m = scm_must_malloc (n * sizeof (double), "vector");
+  char *m = scm_gc_malloc (n * sizeof (double), "vector");
   memcpy (m, d, n * sizeof (double));
   return makvect (m, n, scm_tc7_dvect);
 }
@@ -239,8 +220,7 @@ gh_scm2long (SCM obj)
 int 
 gh_scm2int (SCM obj)
 {
-  /* NOTE: possible loss of precision here */
-  return (int) scm_num2long (obj, SCM_ARG1, "gh_scm2int");
+  return (int) scm_num2int (obj, SCM_ARG1, "gh_scm2int");
 }
 double 
 gh_scm2double (SCM obj)
@@ -262,7 +242,7 @@ gh_scm2char (SCM obj)
 char *
 gh_scm2chars (SCM obj, char *m)
 {
-  int i, n;
+  long i, n;
   long v;
   SCM val;
   if (SCM_IMP (obj))
@@ -302,7 +282,6 @@ gh_scm2chars (SCM obj, char *m)
       break;
 #endif
     case scm_tc7_string:
-    case scm_tc7_substring:
       n = SCM_STRING_LENGTH (obj);
       if (m == 0)
 	m = (char *) malloc (n * sizeof (char));
@@ -322,7 +301,7 @@ gh_scm2chars (SCM obj, char *m)
 short *
 gh_scm2shorts (SCM obj, short *m)
 {
-  int i, n;
+  long i, n;
   long v;
   SCM val;
   if (SCM_IMP (obj))
@@ -373,7 +352,7 @@ gh_scm2shorts (SCM obj, short *m)
 long *
 gh_scm2longs (SCM obj, long *m)
 {
-  int i, n;
+  long i, n;
   SCM val;
   if (SCM_IMP (obj))
     scm_wrong_type_arg (0, 0, obj);
@@ -423,7 +402,7 @@ gh_scm2longs (SCM obj, long *m)
 float *
 gh_scm2floats (SCM obj, float *m)
 {
-  int i, n;
+  long i, n;
   SCM val;
   if (SCM_IMP (obj))
     scm_wrong_type_arg (0, 0, obj);
@@ -486,7 +465,7 @@ gh_scm2floats (SCM obj, float *m)
 double *
 gh_scm2doubles (SCM obj, double *m)
 {
-  int i, n;
+  long i, n;
   SCM val;
   if (SCM_IMP (obj))
     scm_wrong_type_arg (0, 0, obj);
@@ -559,10 +538,10 @@ gh_scm2doubles (SCM obj, double *m)
    function always copies the complete contents of STR, and sets
    *LEN_P to the true length of the string (when LEN_P is non-null).  */
 char *
-gh_scm2newstr (SCM str, int *lenp)
+gh_scm2newstr (SCM str, size_t *lenp)
 {
   char *ret_str;
-  int len;
+  size_t len;
 
   SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG3, "gh_scm2newstr");
 
@@ -594,9 +573,9 @@ gh_scm2newstr (SCM str, int *lenp)
    region to fit the string.  If truncation occurs, the corresponding
    area of DST is left unchanged.  */
 void 
-gh_get_substr (SCM src, char *dst, int start, int len)
+gh_get_substr (SCM src, char *dst, long start, size_t len)
 {
-  int src_len, effective_length;
+  size_t src_len, effective_length;
   SCM_ASSERT (SCM_STRINGP (src), src, SCM_ARG3, "gh_get_substr");
 
   src_len = SCM_STRING_LENGTH (src);
@@ -616,10 +595,10 @@ gh_get_substr (SCM src, char *dst, int start, int len)
    caller is responsible for freeing it.  If out of memory, NULL is
    returned.*/
 char *
-gh_symbol2newstr (SCM sym, int *lenp)
+gh_symbol2newstr (SCM sym, size_t *lenp)
 {
   char *ret_str;
-  int len;
+  size_t len;
 
   SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG3, "gh_scm2newsymbol");
 
@@ -669,7 +648,7 @@ gh_vector_ref (SCM vec, SCM pos)
 unsigned long 
 gh_vector_length (SCM v)
 {
-  return gh_scm2ulong (scm_vector_length (v));
+  return (unsigned long) SCM_VECTOR_LENGTH (v);
 }
 
 #ifdef HAVE_ARRAYS
@@ -679,7 +658,7 @@ gh_vector_length (SCM v)
 unsigned long
 gh_uniform_vector_length (SCM v)
 {
-  return gh_scm2ulong (scm_uniform_vector_length (v));
+  return (unsigned long) SCM_UVECTOR_LENGTH (v);
 }
 
 /* gets the given element from a uniform vector; ilist is a list (or
@@ -704,26 +683,32 @@ gh_uniform_vector_ref (SCM v, SCM ilist)
    `vec' argument.
 
    The return value is the Scheme object to which SNAME is bound, or
-   SCM_UNDEFINED if SNAME is not bound in the given context. [FIXME:
-   should this be SCM_UNSPECIFIED?  Can a symbol ever legitimately be
-   bound to SCM_UNDEFINED or SCM_UNSPECIFIED?  What is the difference?
-   -twp] */
+   SCM_UNDEFINED if SNAME is not bound in the given context.
+ */
 
 SCM
 gh_lookup (const char *sname)
 {
-  return gh_module_lookup (SCM_BOOL_F, sname);
+  return gh_module_lookup (scm_current_module (), sname);
 }
 
+
 SCM
-gh_module_lookup (SCM vec, const char *sname)
+gh_module_lookup (SCM module, const char *sname)
+#define FUNC_NAME "gh_module_lookup"
 {
-  SCM sym = gh_symbol2scm (sname);
-  if (SCM_EQ_P (scm_symbol_bound_p (vec, sym), SCM_BOOL_T))
-    return scm_symbol_binding (vec, sym);
+  SCM sym, var;
+
+  SCM_VALIDATE_MODULE (SCM_ARG1, module);
+
+  sym = scm_str2symbol (sname);
+  var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
+  if (var != SCM_BOOL_F)
+    return SCM_VARIABLE_REF (var);
   else
     return SCM_UNDEFINED;
 }
+#undef FUNC_NAME
 
 /*
   Local Variables: