libguile/gh_data.c

   1 /*      Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   2
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41 \f
  42
  43 /* data initialization and C<->Scheme data conversion */
  44
  45 #include <stdio.h>
  46
  47 #include <gh.h>
  48
  49 /* data conversion C->scheme */
  50 SCM
  51 gh_int2scmb (int x)             /* this is being phased out */
  52 {
  53   return (x ? SCM_BOOL_T : SCM_BOOL_F);
  54 }
  55 SCM
  56 gh_bool2scm (int x)
  57 {
  58   return (x ? SCM_BOOL_T : SCM_BOOL_F);
  59 }
  60 SCM
  61 gh_int2scm (int x)
  62 {
  63   return scm_long2num ((long) x);
  64 }
  65 SCM
  66 gh_ulong2scm (unsigned long x)
  67 {
  68   return scm_ulong2num (x);
  69 }
  70 SCM
  71 gh_long2scm (long x)
  72 {
  73   return scm_long2num (x);
  74 }
  75 SCM
  76 gh_double2scm (double x)
  77 {
  78   return scm_makdbl (x, 0.0);
  79 }
  80 SCM
  81 gh_char2scm (char c)
  82 {
  83  return SCM_MAKICHR (c);
  84 }
  85 SCM
  86 gh_str2scm (char *s, int len)
  87 {
  88   return scm_makfromstr (s, len, 0);
  89 }
  90 SCM
  91 gh_str02scm (char *s)
  92 {
  93   return scm_makfrom0str (s);
  94 }
  95 /* Copy LEN characters at SRC into the *existing* Scheme string DST,
  96    starting at START.  START is an index into DST; zero means the
  97    beginning of the string.
  98
  99    If START + LEN is off the end of DST, signal an out-of-range
 100    error.  */
 101 void
 102 gh_set_substr (char *src, SCM dst, int start, int len)
 103 {
 104   char *dst_ptr;
 105   unsigned long dst_len;
 106   unsigned long effective_length;
 107
 108   SCM_ASSERT (SCM_NIMP (dst) && SCM_STRINGP (dst), dst, SCM_ARG3,
 109               "gh_set_substr");
 110
 111   dst_ptr = SCM_CHARS (dst);
 112   dst_len = SCM_LENGTH (dst);
 113   SCM_ASSERT (len >= 0 && (unsigned) len <= dst_len,
 114               dst, SCM_ARG4, "gh_set_substr");
 115
 116   scm_protect_object (dst);
 117   effective_length = ((unsigned) len < dst_len) ? len : dst_len;
 118   memmove (dst_ptr + start, src, effective_length);
 119   scm_unprotect_object (dst);
 120 }
 121
 122 /* Return the symbol named SYMBOL_STR.  */
 123 SCM
 124 gh_symbol2scm (char *symbol_str)
 125 {
 126   return SCM_CAR (scm_intern (symbol_str, strlen (symbol_str)));
 127 }
 128
 129 static SCM
 130 makvect (char* m, int len, int type)
 131 {
 132   SCM ans;
 133   SCM_NEWCELL (ans);
 134   SCM_DEFER_INTS;
 135   SCM_SETCHARS (ans, m);
 136   SCM_SETLENGTH (ans, len, type);
 137   SCM_ALLOW_INTS;
 138   return ans;
 139 }
 140
 141 SCM
 142 gh_ints2scm (int *d, int n)
 143 {
 144   SCM *m;
 145   int i;
 146   for (i = 0; i < n; ++i)
 147     SCM_ASSERT (d[i] >= SCM_INUM (LONG_MIN) && d[i] <= SCM_INUM (LONG_MAX),
 148                 SCM_MAKINUM (d[i]),
 149                 SCM_OUTOFRANGE,
 150                 "gh_ints2scm");
 151   m = (SCM*) scm_must_malloc (n * sizeof (SCM), "vector");
 152   for (i = 0; i < n; ++i)
 153     m[i] = SCM_MAKINUM (d[i]);
 154   return makvect ((char *) m, n, scm_tc7_vector);
 155 }
 156
 157 SCM
 158 gh_longs2ivect (long *d, int n)
 159 {
 160   char *m = scm_must_malloc (n * sizeof (long), "vector");
 161   memcpy (m, d, n * sizeof (long));
 162   return makvect (m, n, scm_tc7_ivect);
 163 }
 164
 165 SCM
 166 gh_ulongs2uvect (unsigned long *d, int n)
 167 {
 168   char *m = scm_must_malloc (n * sizeof (unsigned long), "vector");
 169   memcpy (m, d, n * sizeof (unsigned long));
 170   return makvect (m, n, scm_tc7_uvect);
 171 }
 172
 173 SCM
 174 gh_doubles2scm (double *d, int n)
 175 {
 176   SCM *m = (SCM*) scm_must_malloc (n * sizeof (SCM), "vector");
 177   int i;
 178   for (i = 0; i < n; ++i)
 179     m[i] = scm_makdbl (d[i], 0.0);
 180   return makvect ((char *) m, n, scm_tc7_vector);
 181 }
 182
 183 #ifdef SCM_FLOATS
 184 SCM
 185 gh_doubles2dvect (double *d, int n)
 186 {
 187   char *m = scm_must_malloc (n * sizeof (double), "vector");
 188   memcpy (m, d, n * sizeof (double));
 189   return makvect (m, n, scm_tc7_dvect);
 190 }
 191 #endif
 192
 193 /* data conversion scheme->C */
 194 int
 195 gh_scm2bool (SCM obj)
 196 {
 197   return ((obj) == SCM_BOOL_F) ? 0 : 1;
 198 }
 199 unsigned long
 200 gh_scm2ulong (SCM obj)
 201 {
 202   return scm_num2ulong (obj, (char *) SCM_ARG1, "gh_scm2ulong");
 203 }
 204 long
 205 gh_scm2long (SCM obj)
 206 {
 207   return scm_num2long (obj, (char *) SCM_ARG1, "gh_scm2long");
 208 }
 209 int
 210 gh_scm2int (SCM obj)
 211 {
 212   /* NOTE: possible loss of precision here */
 213   return (int) scm_num2long (obj, (char *) SCM_ARG1, "gh_scm2int");
 214 }
 215 double
 216 gh_scm2double (SCM obj)
 217 {
 218   return scm_num2dbl (obj, "gh_scm2double");
 219 }
 220 char
 221 gh_scm2char (SCM obj)
 222 {
 223   return SCM_ICHR (obj);
 224 }
 225
 226 /* Convert a vector, weak vector or uniform vector into a malloced
 227    array of doubles. */
 228 double*
 229 gh_scm2doubles (SCM obj)
 230 {
 231   int i, n;
 232   double *m = 0;
 233   SCM val;
 234   if (!SCM_NIMP (obj))
 235     scm_wrong_type_arg (0, 0, obj);
 236   switch (SCM_TYP7 (obj))
 237     {
 238     case scm_tc7_vector:
 239     case scm_tc7_wvect:
 240       n = SCM_LENGTH (obj);
 241       m = (double*) malloc (n * sizeof (double));
 242       for (i = 0; i < n; ++i)
 243         {
 244           val = SCM_VELTS (obj)[i];
 245           if (SCM_INUMP (val))
 246             m[i] = SCM_INUM (val);
 247           else if (SCM_NIMP (val) && SCM_REALP (val))
 248             m[i] = SCM_REALPART (val);
 249           else
 250             {
 251               free (m);
 252               scm_wrong_type_arg (0, 0, val);
 253             }
 254         }
 255       break;
 256 #ifdef SCM_FLOATS
 257 #ifdef SCM_SINGLES
 258     case scm_tc7_fvect:
 259       n = SCM_LENGTH (obj);
 260       m = (double*) malloc (n * sizeof (double));
 261       for (i = 0; i < n; ++i)
 262         m[i] = ((float*) SCM_VELTS (obj))[i];
 263       break;
 264 #endif
 265     case scm_tc7_dvect:
 266       n = SCM_LENGTH (obj);
 267       m = (double*) malloc (n * sizeof (double));
 268       for (i = 0; i < n; ++i)
 269         m[i] = ((double*) SCM_VELTS (obj))[i];
 270       break;
 271 #endif
 272     default:
 273       scm_wrong_type_arg (0, 0, obj);
 274     }
 275   return m;
 276 }
 277
 278 /* string conversions between C and Scheme */
 279
 280 /* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a
 281    new copy of its contents, followed by a null byte.  If lenp is
 282    non-null, set *lenp to the string's length.
 283
 284    This function uses malloc to obtain storage for the copy; the
 285    caller is responsible for freeing it.
 286
 287    Note that Scheme strings may contain arbitrary data, including null
 288    characters.  This means that null termination is not a reliable way
 289    to determine the length of the returned value.  However, the
 290    function always copies the complete contents of STR, and sets
 291    *LEN_P to the true length of the string (when LEN_P is non-null).  */
 292 char *
 293 gh_scm2newstr (SCM str, int *lenp)
 294 {
 295   char *ret_str;
 296   int len;
 297
 298   SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG3,
 299               "gh_scm2newstr");
 300
 301   /* protect str from GC while we copy off its data */
 302   scm_protect_object (str);
 303
 304   len = SCM_LENGTH (str);
 305
 306   ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char),
 307                                       "gh_scm2newstr");
 308   /* so we copy tmp_str to ret_str, which is what we will allocate */
 309   memcpy (ret_str, SCM_ROCHARS (str), len);     /* test ROCHARS here -twp */
 310   /* now make sure we null-terminate it */
 311   ret_str[len] = '\0';
 312
 313   scm_unprotect_object (str);
 314
 315   if (lenp != NULL)
 316     {
 317       *lenp = len;
 318     }
 319
 320   return ret_str;
 321 }
 322
 323
 324 /* Copy LEN characters at START from the Scheme string SRC to memory
 325    at DST.  START is an index into SRC; zero means the beginning of
 326    the string.  DST has already been allocated by the caller.
 327
 328    If START + LEN is off the end of SRC, silently truncate the source
 329    region to fit the string.  If truncation occurs, the corresponding
 330    area of DST is left unchanged.  */
 331 void
 332 gh_get_substr (SCM src, char *dst, int start, int len)
 333 {
 334   int src_len, effective_length;
 335   SCM_ASSERT (SCM_NIMP (src) && SCM_ROSTRINGP (src), src, SCM_ARG3,
 336               "gh_get_substr");
 337
 338   scm_protect_object (src);
 339   src_len = SCM_LENGTH (src);
 340   effective_length = (len < src_len) ? len : src_len;
 341   memcpy (dst + start, SCM_ROCHARS (src), effective_length * sizeof (char));
 342   /* FIXME: must signal an error if len > src_len */
 343   scm_unprotect_object (src);
 344 }
 345
 346
 347 /* gh_scm2newsymbol() -- Given a Scheme symbol 'identifier, return a
 348    pointer to a string with the symbol characters "identifier",
 349    followed by a null byte.  If lenp is non-null, set *lenp to the
 350    string's length.
 351
 352    This function uses malloc to obtain storage for the copy; the
 353    caller is responsible for freeing it. */
 354 char *
 355 gh_symbol2newstr (SCM sym, int *lenp)
 356 {
 357   char *ret_str;
 358   int len;
 359
 360   SCM_ASSERT (SCM_NIMP (sym) && SCM_SYMBOLP (sym), sym, SCM_ARG3,
 361               "gh_scm2newsymbol");
 362
 363   /* protect str from GC while we copy off its data */
 364   scm_protect_object (sym);
 365
 366   len = SCM_LENGTH (sym);
 367
 368   ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char),
 369                                       "gh_symbol2newstr");
 370   /* so we copy tmp_str to ret_str, which is what we will allocate */
 371   memcpy (ret_str, SCM_CHARS (sym), len);
 372   /* now make sure we null-terminate it */
 373   ret_str[len] = '\0';
 374
 375   scm_unprotect_object (sym);
 376
 377   if (lenp != NULL)
 378     {
 379       *lenp = len;
 380     }
 381
 382   return ret_str;
 383 }
 384
 385
 386 /* create a new vector of the given length, all initialized to the
 387    given value */
 388 SCM
 389 gh_make_vector (SCM len, SCM fill)
 390 {
 391   return scm_make_vector (len, fill);
 392 }
 393
 394 /* set the given element of the given vector to the given value */
 395 SCM
 396 gh_vector_set_x (SCM vec, SCM pos, SCM val)
 397 {
 398   return scm_vector_set_x (vec, pos, val);
 399 }
 400
 401 /* retrieve the given element of the given vector */
 402 SCM
 403 gh_vector_ref (SCM vec, SCM pos)
 404 {
 405   return scm_vector_ref (vec, pos);
 406 }
 407
 408 /* returns the length of the given vector */
 409 unsigned long
 410 gh_vector_length (SCM v)
 411 {
 412   return gh_scm2ulong (scm_vector_length (v));
 413 }
 414
 415
 416 /* uniform vector support */
 417
 418 /* returns the length as a C unsigned long integer */
 419 unsigned long
 420 gh_uniform_vector_length (SCM v)
 421 {
 422   return gh_scm2ulong (scm_uniform_vector_length (v));
 423 }
 424
 425 /* gets the given element from a uniform vector; ilist is a list (or
 426    possibly a single integer) of indices, and its length is the
 427    dimension of the uniform vector */
 428 SCM
 429 gh_uniform_vector_ref (SCM v, SCM ilist)
 430 {
 431   return scm_uniform_vector_ref (v, ilist);
 432 }
 433
 434 /* sets an individual element in a uniform vector */
 435 /* SCM */
 436 /* gh_list_to_uniform_array ( */
 437
 438
 439 /* Data lookups between C and Scheme
 440
 441    Look up a symbol with a given name, and return the object to which
 442    it is bound.  gh_lookup examines the Guile top level, and
 443    gh_module_lookup checks the module namespace specified by the
 444    `vec' argument.
 445
 446    The return value is the Scheme object to which SNAME is bound, or
 447    SCM_UNDEFINED if SNAME is not bound in the given context. [FIXME:
 448    should this be SCM_UNSPECIFIED?  Can a symbol ever legitimately be
 449    bound to SCM_UNDEFINED or SCM_UNSPECIFIED?  What is the difference?
 450    -twp] */
 451
 452 SCM
 453 gh_lookup (char *sname)
 454 {
 455   return gh_module_lookup (SCM_BOOL_F, sname);
 456 }
 457
 458 SCM
 459 gh_module_lookup (SCM vec, char *sname)
 460 {
 461   SCM sym = gh_symbol2scm (sname);
 462   if ((scm_symbol_bound_p (vec, sym)) == SCM_BOOL_T)
 463     return scm_symbol_binding (vec, sym);
 464   else
 465     return SCM_UNDEFINED;
 466 }