mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 22:10:21 +02:00
Code Activity

* gh.h, gh_data.c (gh_doubles2scm, gh_doubles2dvect,

Browse source 
gh_doubles2scm): New functions.
This commit is contained in:
Mikael Djurfeldt 1998-01-20 17:57:01 +00:00
parent e1b6c71093
commit f3a2c4cfe6
3 changed files with 93 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

5
libguile/ChangeLog
View file

@ -1,3 +1,8 @@
1998-01-20 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
* gh.h, gh_data.c (gh_doubles2scm, gh_doubles2dvect,
gh_doubles2scm): New functions.
1998-01-15 Mark Galassi <rosalia@nis.lanl.gov>
* gh_eval.c (gh_eval_str): cleanup -- threw out the old

5
libguile/gh.h
View file

@ -113,6 +113,10 @@ SCM gh_str2scm(char *s, int len);
SCM gh_str02scm(char *s);
void gh_set_substr(char *src, SCM dst, int start, int len);
SCM gh_symbol2scm(char *symbol_str);
SCM gh_doubles2scm(double *d, int n);
#ifdef SCM_FLOATS
SCM gh_doubles2dvect(double *d, int n);
#endif
/* Scheme to C conversion */
@ -125,6 +129,7 @@ double gh_scm2double(SCM obj);
char *gh_scm2newstr(SCM str, int *lenp);
void gh_get_substr(SCM src, char *dst, int start, int len);
char *gh_symbol2newstr(SCM sym, int *lenp);
double *gh_scm2doubles(SCM vector);
/* type predicates: tell you if an SCM object has a given type */
int gh_boolean_p(SCM val);

83
libguile/gh_data.c
View file

@ -122,6 +122,37 @@ gh_symbol2scm (char *symbol_str)
return SCM_CAR (scm_intern (symbol_str, strlen (symbol_str)));
}
SCM
gh_doubles2scm (double *d, int n)
{
SCM ans;
SCM *m = (SCM*) scm_must_malloc (n * sizeof (SCM), "vector");
int i;
for (i = 0; i < n; ++i)
m[i] = scm_makdbl (d[i], 0.0);
SCM_NEWCELL (ans);
SCM_DEFER_INTS;
SCM_SETCHARS (ans, m);
SCM_SETLENGTH (ans, n, scm_tc7_vector);
SCM_ALLOW_INTS;
return ans;
}
#ifdef SCM_FLOATS
SCM
gh_doubles2dvect (double *d, int n)
{
SCM ans;
char *m = scm_must_malloc (n * sizeof (double), "vector");
memcpy (m, d, n * sizeof (double));
SCM_NEWCELL (ans);
SCM_DEFER_INTS;
SCM_SETCHARS (ans, m);
SCM_SETLENGTH (ans, n, scm_tc7_dvect);
SCM_ALLOW_INTS;
return ans;
}
#endif
/* data conversion scheme->C */
int
@ -156,6 +187,58 @@ gh_scm2char (SCM obj)
return SCM_ICHR (obj);
}
/* Convert a vector, weak vector or uniform vector into a malloced
array of doubles. */
double*
gh_scm2doubles (SCM obj)
{
int i, n;
double *m;
SCM val;
if (!SCM_NIMP (obj))
scm_wrong_type_arg (0, 0, obj);
switch (SCM_TYP7 (obj))
{
case scm_tc7_vector:
case scm_tc7_wvect:
n = SCM_LENGTH (obj);
m = (double*) malloc (n * sizeof (double));
for (i = 0; i < n; ++i)
{
val = SCM_VELTS (obj)[i];
if (SCM_INUMP (val))
m[i] = SCM_INUM (val);
else if (SCM_NIMP (val) && SCM_REALP (val))
m[i] = SCM_REALPART (val);
else
{
free (m);
scm_wrong_type_arg (0, 0, val);
}
}
break;
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
n = SCM_LENGTH (obj);
m = (double*) malloc (n * sizeof (double));
for (i = 0; i < n; ++i)
m[i] = ((float*) SCM_VELTS (obj))[i];
break;
#endif
case scm_tc7_dvect:
n = SCM_LENGTH (obj);
m = (double*) malloc (n * sizeof (double));
for (i = 0; i < n; ++i)
m[i] = ((double*) SCM_VELTS (obj))[i];
break;
#endif
default:
scm_wrong_type_arg (0, 0, obj);
}
return m;
}
/* string conversions between C and Scheme */
/* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a