xref: /dports/science/libctl/libctl-4.5.0/src/ctl.c

/* libctl: flexible Guile-based control files for scientific software
 * Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the
 * Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 * Boston, MA  02111-1307, USA.
 *
 * Steven G. Johnson can be contacted at stevenj@alum.mit.edu.
 */

#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <math.h>

#include "ctl.h"

/**************************************************************************/

/* Functions missing from Guile 1.2: */

#if !defined(HAVE_GH_BOOL2SCM) && !defined(HAVE_NO_GH)
/* Guile 1.2 is missing gh_bool2scm for some reason; redefine: */
SCM ctl_gh_bool2scm(boolean b) { return (b ? SCM_BOOL_T : SCM_BOOL_F); }
#endif

#if defined(HAVE_NO_GH)
#define gh_length(x) scm_to_long(scm_length(x))
#elif !defined(HAVE_GH_LENGTH)
#define gh_length gh_list_length
#endif

#if defined(HAVE_NO_GH)
#define list_ref(l, index) scm_list_ref(l, scm_from_int(index))
#elif !defined(HAVE_GH_LIST_REF)
/* Guile 1.2 doesn't have the gh_list_ref function.  Sigh. */
/* Note: index must be in [0,list_length(l) - 1].  We don't check! */
static SCM list_ref(list l, int index) {
  SCM cur = SCM_UNSPECIFIED, rest = l;

  while (index >= 0) {
    cur = gh_car(rest);
    rest = gh_cdr(rest);
    --index;
  }
  return cur;
}
#else /* HAVE_GH_LIST_REF */
#define list_ref(l, index) gh_list_ref(l, gh_int2scm(index))
#endif

#if defined(HAVE_NO_GH)
#define vector_ref(v, i) scm_c_vector_ref(v, i)
#elif !defined(HAVE_GH_VECTOR_REF)
#define vector_ref(v, i) gh_vref(v, gh_int2scm(i))
#else
#define vector_ref(v, i) gh_vector_ref(v, gh_int2scm(i))
#endif

/**************************************************************************/

/* Scheme file loading (don't use gh_load directly because subsequent
   loads won't use the correct path name).  Uses our "include" function
   from include.scm, or defaults to gh_load if this function isn't
   defined. */

void ctl_include(const char *filename) {
  SCM include_proc = gh_lookup("include");
  if (include_proc == SCM_UNDEFINED)
    gh_load(filename);
  else
#ifdef HAVE_NO_GH
    scm_call_1(include_proc, ctl_convert_string_to_scm(filename));
#else
    gh_call1(include_proc, gh_str02scm(filename));
#endif
}

/* convert a pathname into one relative to the current include dir */
char *ctl_fix_path(const char *path) {
  char *newpath;
  if (path[0] != '/') {
    SCM include_dir = gh_lookup("include-dir");
    if (include_dir != SCM_UNDEFINED) {
      char *dir = ctl_convert_string_to_c(include_dir);
      newpath = (char *)malloc(sizeof(char) * (strlen(dir) + strlen(path) + 2));
      strcpy(newpath, dir);
      free(dir);
      if (newpath[0] && newpath[strlen(newpath) - 1] != '/') strcat(newpath, "/");
      strcat(newpath, path);
      return newpath;
    }
  }
  newpath = (char *)malloc(sizeof(char) * (strlen(path) + 1));
  strcpy(newpath, path);
  return newpath;
}

/**************************************************************************/

/* type conversion */

vector3 scm2vector3(SCM sv) {
  vector3 v;

  v.x = ctl_convert_number_to_c(vector_ref(sv, 0));
  v.y = ctl_convert_number_to_c(vector_ref(sv, 1));
  v.z = ctl_convert_number_to_c(vector_ref(sv, 2));
  return v;
}

matrix3x3 scm2matrix3x3(SCM sm) {
  matrix3x3 m;

  m.c0 = scm2vector3(vector_ref(sm, 0));
  m.c1 = scm2vector3(vector_ref(sm, 1));
  m.c2 = scm2vector3(vector_ref(sm, 2));
  return m;
}

static SCM make_vector3(SCM x, SCM y, SCM z) {
  SCM vscm;
  vscm = scm_c_make_vector(3, SCM_UNSPECIFIED);
#ifdef SCM_SIMPLE_VECTOR_SET
  SCM_SIMPLE_VECTOR_SET(vscm, 0, x);
  SCM_SIMPLE_VECTOR_SET(vscm, 1, y);
  SCM_SIMPLE_VECTOR_SET(vscm, 2, z);
#else
  {
    SCM *data;
    data = SCM_VELTS(vscm);
    data[0] = x;
    data[1] = y;
    data[2] = z;
  }
#endif
  return vscm;
}

SCM vector32scm(vector3 v) {
  return make_vector3(ctl_convert_number_to_scm(v.x), ctl_convert_number_to_scm(v.y),
                      ctl_convert_number_to_scm(v.z));
}

SCM matrix3x32scm(matrix3x3 m) {
  return make_vector3(vector32scm(m.c0), vector32scm(m.c1), vector32scm(m.c2));
}

cnumber scm2cnumber(SCM sx) {
#ifdef HAVE_SCM_COMPLEXP
  if (scm_real_p(sx) && !(SCM_COMPLEXP(sx)))
    return make_cnumber(ctl_convert_number_to_c(sx), 0.0);
  else
    return make_cnumber(SCM_COMPLEX_REAL(sx), SCM_COMPLEX_IMAG(sx));
#else
  if (scm_real_p(sx) && !(SCM_NIMP(sx) && SCM_INEXP(sx) && SCM_CPLXP(sx)))
    return make_cnumber(ctl_convert_number_to_c(sx), 0.0);
  else
    return make_cnumber(SCM_REALPART(sx), SCM_IMAG(sx));
#endif
}

SCM cnumber2scm(cnumber x) {
#if defined(HAVE_SCM_C_MAKE_RECTANGULAR)     /* Guile 1.6.5 */
  return scm_c_make_rectangular(x.re, x.im); /* Guile 1.5 */
#elif defined(HAVE_SCM_MAKE_COMPLEX)
  return scm_make_complex(x.re, x.im); /* Guile 1.5 */
#else
  if (x.im == 0.0)
    return ctl_convert_number_to_scm(x.re);
  else
    return scm_makdbl(x.re, x.im);
#endif
}

cvector3 scm2cvector3(SCM sv) {
  cvector3 v;

  v.x = scm2cnumber(vector_ref(sv, 0));
  v.y = scm2cnumber(vector_ref(sv, 1));
  v.z = scm2cnumber(vector_ref(sv, 2));
  return v;
}

cmatrix3x3 scm2cmatrix3x3(SCM sm) {
  cmatrix3x3 m;

  m.c0 = scm2cvector3(vector_ref(sm, 0));
  m.c1 = scm2cvector3(vector_ref(sm, 1));
  m.c2 = scm2cvector3(vector_ref(sm, 2));
  return m;
}

SCM cvector32scm(cvector3 v) {
  return make_vector3(cnumber2scm(v.x), cnumber2scm(v.y), cnumber2scm(v.z));
}

SCM cmatrix3x32scm(cmatrix3x3 m) {
  return make_vector3(cvector32scm(m.c0), cvector32scm(m.c1), cvector32scm(m.c2));
}

/**************************************************************************/

/* variable get/set functions */

/**** Getters ****/

integer ctl_get_integer(const char *identifier) {
  return (ctl_convert_integer_to_c(gh_lookup(identifier)));
}

number ctl_get_number(const char *identifier) {
  return (ctl_convert_number_to_c(gh_lookup(identifier)));
}

cnumber ctl_get_cnumber(const char *identifier) { return (scm2cnumber(gh_lookup(identifier))); }

boolean ctl_get_boolean(const char *identifier) {
  return (ctl_convert_boolean_to_c(gh_lookup(identifier)));
}

char *ctl_get_string(const char *identifier) {
  return (ctl_convert_string_to_c(gh_lookup(identifier)));
}

vector3 ctl_get_vector3(const char *identifier) { return (scm2vector3(gh_lookup(identifier))); }

matrix3x3 ctl_get_matrix3x3(const char *identifier) {
  return (scm2matrix3x3(gh_lookup(identifier)));
}

cvector3 ctl_get_cvector3(const char *identifier) { return (scm2cvector3(gh_lookup(identifier))); }

cmatrix3x3 ctl_get_cmatrix3x3(const char *identifier) {
  return (scm2cmatrix3x3(gh_lookup(identifier)));
}

list ctl_get_list(const char *identifier) { return (gh_lookup(identifier)); }

object ctl_get_object(const char *identifier) { return (gh_lookup(identifier)); }

function ctl_get_function(const char *identifier) { return (gh_lookup(identifier)); }

SCM ctl_get_SCM(const char *identifier) { return (gh_lookup(identifier)); }

/**** Setters ****/

/* UGLY hack alert!  There doesn't seem to be any clean way of setting
   Scheme variables from C in Guile (e.g. no gh_* interface).

   One option is to use scm_symbol_set_x (symbol-set! in Scheme), but
   I'm not sure how to get this to work in Guile 1.3 because of the
   %&*@^-ing module system (I need to pass some module for the first
   parameter, but I don't know what to pass).

   Instead, I hacked together the following my_symbol_set_x routine,
   using the functions scm_symbol_value0 and scm_symbol_set_x from the
   Guile 1.3 sources. (scm_symbol_value0 has the virtue of looking in
   the correct module somehow; I also used this function to replace
   gh_lookup, which broke in Guile 1.3 as well...sigh.)

   Note that I can't call "set!" because it is really a macro.

   All the ugliness is confined to the set_value() routine, though.

   Update: in Guile 1.5, we can call scm_variable_set_x (equivalent
   to variable-set!) to set values of variables, which are looked up
   via scm_c_lookup (which doesn't exist in Guile 1.3.x). */

#if !(defined(HAVE_SCM_VARIABLE_SET_X) && defined(HAVE_SCM_C_LOOKUP))
#define USE_MY_SYMBOL_SET_X 1 /* use the hack */
#endif

#ifdef USE_MY_SYMBOL_SET_X
static SCM my_symbol_set_x(const char *name, SCM v) {
  /* code swiped from scm_symbol_value0 and scm_symbol_set_x */
  SCM symbol = scm_intern_obarray_soft(name, strlen(name), scm_symhash, 0);
  SCM vcell = scm_sym2vcell(SCM_CAR(symbol), SCM_CDR(scm_top_level_lookup_closure_var), SCM_BOOL_F);
  if (SCM_FALSEP(vcell)) return SCM_UNDEFINED;
  SCM_SETCDR(vcell, v);
  return SCM_UNSPECIFIED;
}
#endif

static void set_value(const char *identifier, SCM value) {
#if defined(USE_SCM_SYMBOL_SET_X) /* worked in Guile 1.1, 1.2 */
  scm_symbol_set_x(SCM_BOOL_F, gh_symbol2scm(identifier), value);
#elif defined(HAVE_SCM_VARIABLE_SET_X) && defined(HAVE_SCM_C_LOOKUP)
  scm_variable_set_x(scm_c_lookup(identifier), value);
#elif defined(USE_MY_SYMBOL_SET_X)
  my_symbol_set_x(identifier, value);
#endif
}

void ctl_set_integer(const char *identifier, integer value) {
  set_value(identifier, ctl_convert_integer_to_scm(value));
}

void ctl_set_number(const char *identifier, number value) {
  set_value(identifier, ctl_convert_number_to_scm(value));
}

void ctl_set_cnumber(const char *identifier, cnumber value) {
  set_value(identifier, cnumber2scm(value));
}

void ctl_set_boolean(const char *identifier, boolean value) {
  set_value(identifier, ctl_convert_boolean_to_scm(value));
}

void ctl_set_string(const char *identifier, const char *value) {
  set_value(identifier, ctl_convert_string_to_scm(value));
}

void ctl_set_vector3(const char *identifier, vector3 value) {
  set_value(identifier, vector32scm(value));
}

void ctl_set_matrix3x3(const char *identifier, matrix3x3 value) {
  set_value(identifier, matrix3x32scm(value));
}

void ctl_set_cvector3(const char *identifier, cvector3 value) {
  set_value(identifier, cvector32scm(value));
}

void ctl_set_cmatrix3x3(const char *identifier, cmatrix3x3 value) {
  set_value(identifier, cmatrix3x32scm(value));
}

void ctl_set_list(const char *identifier, list value) { set_value(identifier, value); }

void ctl_set_object(const char *identifier, object value) { set_value(identifier, value); }

void ctl_set_function(const char *identifier, function value) { set_value(identifier, value); }

void ctl_set_SCM(const char *identifier, SCM value) { set_value(identifier, value); }

/**************************************************************************/

/* list traversal */

int list_length(list l) { return (gh_length(l)); }

integer integer_list_ref(list l, int index) {
  return (ctl_convert_integer_to_c(list_ref(l, index)));
}

number number_list_ref(list l, int index) { return (ctl_convert_number_to_c(list_ref(l, index))); }

cnumber cnumber_list_ref(list l, int index) { return (scm2cnumber(list_ref(l, index))); }

boolean boolean_list_ref(list l, int index) { return (SCM_BOOL_F != list_ref(l, index)); }

char *string_list_ref(list l, int index) { return (ctl_convert_string_to_c(list_ref(l, index))); }

vector3 vector3_list_ref(list l, int index) { return (scm2vector3(list_ref(l, index))); }

matrix3x3 matrix3x3_list_ref(list l, int index) { return (scm2matrix3x3(list_ref(l, index))); }

cvector3 cvector3_list_ref(list l, int index) { return (scm2cvector3(list_ref(l, index))); }

cmatrix3x3 cmatrix3x3_list_ref(list l, int index) { return (scm2cmatrix3x3(list_ref(l, index))); }

list list_list_ref(list l, int index) { return (list_ref(l, index)); }

object object_list_ref(list l, int index) { return (list_ref(l, index)); }

function function_list_ref(list l, int index) { return (list_ref(l, index)); }

SCM SCM_list_ref(list l, int index) { return (list_ref(l, index)); }

/**************************************************************************/

/* list creation */

#define MAKE_LIST(conv)                                                                            \
  {                                                                                                \
    int i;                                                                                         \
    list cur_list = SCM_EOL;                                                                       \
    for (i = num_items - 1; i >= 0; --i)                                                           \
      cur_list = gh_cons(conv(items[i]), cur_list);                                                \
    return (cur_list);                                                                             \
  }

#ifdef HAVE_NO_GH

list make_integer_list(int num_items, const integer *items) MAKE_LIST(scm_from_int)

    list make_boolean_list(int num_items, const boolean *items) MAKE_LIST(scm_from_bool)

        list make_string_list(int num_items, const char **items) MAKE_LIST(scm_from_locale_string)

            list make_number_list(int num_items, const number *items) MAKE_LIST(scm_from_double)

#else /* ! HAVE_NO_GH */

list make_integer_list(int num_items, const integer *items) MAKE_LIST(gh_int2scm)

    list make_boolean_list(int num_items, const boolean *items) MAKE_LIST(gh_bool2scm)

        list make_string_list(int num_items, const char **items) MAKE_LIST(gh_str02scm)

            list make_number_list(int num_items, const number *items) MAKE_LIST(gh_double2scm)

#endif /* ! HAVE_NO_GH */

                list make_cnumber_list(int num_items, const cnumber *items) MAKE_LIST(cnumber2scm)

                    list
    make_vector3_list(int num_items, const vector3 *items) MAKE_LIST(vector32scm)

        list make_matrix3x3_list(int num_items, const matrix3x3 *items) MAKE_LIST(matrix3x32scm)

            list make_cvector3_list(int num_items, const cvector3 *items) MAKE_LIST(cvector32scm)

                list
    make_cmatrix3x3_list(int num_items, const cmatrix3x3 *items) MAKE_LIST(cmatrix3x32scm)

#define NO_CONVERSION

        list make_list_list(int num_items, const list *items) MAKE_LIST(NO_CONVERSION)

            list make_object_list(int num_items, const object *items) MAKE_LIST(NO_CONVERSION)

                list make_function_list(int num_items, const object *items) MAKE_LIST(NO_CONVERSION)

                    list make_SCM_list(int num_items, const object *items) MAKE_LIST(NO_CONVERSION)

    /**************************************************************************/

    /* object properties */

    boolean object_is_member(const char *type_name, object o) {
  return (SCM_BOOL_F != gh_call2(gh_lookup("object-member?"), gh_symbol2scm(type_name), o));
}

static SCM object_property_value(object o, const char *property_name) {
  return (gh_call2(gh_lookup("object-property-value"), o, gh_symbol2scm(property_name)));
}

integer integer_object_property(object o, const char *property_name) {
  return (ctl_convert_integer_to_c(object_property_value(o, property_name)));
}

number number_object_property(object o, const char *property_name) {
  return (ctl_convert_number_to_c(object_property_value(o, property_name)));
}

cnumber cnumber_object_property(object o, const char *property_name) {
  return (scm2cnumber(object_property_value(o, property_name)));
}

boolean boolean_object_property(object o, const char *property_name) {
  return (SCM_BOOL_F != object_property_value(o, property_name));
}

char *string_object_property(object o, const char *property_name) {
  return (ctl_convert_string_to_c(object_property_value(o, property_name)));
}

vector3 vector3_object_property(object o, const char *property_name) {
  return (scm2vector3(object_property_value(o, property_name)));
}

matrix3x3 matrix3x3_object_property(object o, const char *property_name) {
  return (scm2matrix3x3(object_property_value(o, property_name)));
}

cvector3 cvector3_object_property(object o, const char *property_name) {
  return (scm2cvector3(object_property_value(o, property_name)));
}

cmatrix3x3 cmatrix3x3_object_property(object o, const char *property_name) {
  return (scm2cmatrix3x3(object_property_value(o, property_name)));
}

list list_object_property(object o, const char *property_name) {
  return (object_property_value(o, property_name));
}

object object_object_property(object o, const char *property_name) {
  return (object_property_value(o, property_name));
}

function function_object_property(object o, const char *property_name) {
  return (object_property_value(o, property_name));
}

SCM SCM_object_property(object o, const char *property_name) {
  return (object_property_value(o, property_name));
}