void
init_wrapper (void)
{
Py_Initialize();
if (atexit(Py_Finalize)) {
fprintf(stderr,"cannot set Python finalization function\n"); // NOT COVERED BY TESTS
exit(1); // NOT COVERED BY TESTS
}
initpyscm();
init_pysmob_type();
init_g2p2g_smob_type();
// The following must happen after init_g2p2g_smob_type().
init_default_guiletopy_templates();
SCM s_default_g2p = scm_variable_ref(scm_c_lookup("guile2python"));
sargtemplate_default = scm_permanent_object(scm_list_2(scm_variable_ref(scm_c_lookup("g2p_list2Tuple")),s_default_g2p));
skwtemplate_default = SCM_UNDEFINED; // guileassoc2pythondict will choose the right default.
srestemplate_default = scm_permanent_object(scm_variable_ref(scm_c_lookup("python2guile")));
scm_c_define_gsubr ("python-eval",1,1,0,python_eval);
scm_c_define_gsubr ("python-apply",3,3,0,python_apply);
scm_c_define_gsubr ("python-import",1,0,0,python_import);
scm_c_define_gsubr ("pyguile-verbosity-set!",1,0,0,pyguile_verbosity_set);
scm_c_define_gsubr ("pyguile-version",0,0,0,pyguile_version);
}
/*! \brief Add a directory to the Guile load path.
* \par Function Description
* Prepends \a s_path to the Guile system '%load-path', after
* expanding environment variables.
*
* \param [in] s_path Path to be added.
* \return SCM_BOOL_T.
*/
SCM g_rc_scheme_directory(SCM s_path)
{
char *temp;
gchar *expanded;
SCM s_load_path_var;
SCM s_load_path;
SCM_ASSERT (scm_is_string (s_path), s_path,
SCM_ARG1, "scheme-directory");
/* take care of any shell variables */
temp = scm_to_utf8_string (s_path);
expanded = s_expand_env_variables (temp);
s_path = scm_from_utf8_string (expanded);
free (temp);
g_free (expanded);
s_load_path_var = scm_c_lookup ("%load-path");
s_load_path = scm_variable_ref (s_load_path_var);
scm_variable_set_x (s_load_path_var, scm_cons (s_path, s_load_path));
scm_remember_upto_here_2 (s_load_path_var, s_load_path);
scm_remember_upto_here_1 (s_path);
return SCM_BOOL_T;
}
/*! \brief Exports the keymap in scheme to a GLib GArray.
* \par Function Description
* This function converts the list of key sequence/action pairs
* returned by the scheme function \c dump-current-keymap into an
* array of C structures.
*
* The returned value must be freed by caller.
*
* \return A GArray with keymap data.
*/
GArray*
g_keys_dump_keymap (void)
{
SCM dump_proc = scm_c_lookup ("dump-current-keymap");
SCM scm_ret;
GArray *ret = NULL;
struct keyseq_action_t {
gchar *keyseq, *action;
};
dump_proc = scm_variable_ref (dump_proc);
g_return_val_if_fail (SCM_NFALSEP (scm_procedure_p (dump_proc)), NULL);
scm_ret = scm_call_0 (dump_proc);
g_return_val_if_fail (SCM_CONSP (scm_ret), NULL);
ret = g_array_sized_new (FALSE,
FALSE,
sizeof (struct keyseq_action_t),
(guint)scm_ilength (scm_ret));
for (; scm_ret != SCM_EOL; scm_ret = SCM_CDR (scm_ret)) {
SCM scm_keymap_entry = SCM_CAR (scm_ret);
struct keyseq_action_t keymap_entry;
g_return_val_if_fail (SCM_CONSP (scm_keymap_entry) &&
scm_is_symbol (SCM_CAR (scm_keymap_entry)) &&
scm_is_string (SCM_CDR (scm_keymap_entry)), ret);
keymap_entry.action = g_strdup (SCM_SYMBOL_CHARS (SCM_CAR (scm_keymap_entry)));
keymap_entry.keyseq = g_strdup (SCM_STRING_CHARS (SCM_CDR (scm_keymap_entry)));
ret = g_array_append_val (ret, keymap_entry);
}
return ret;
}
static int mod_load_servlet(lua_State *l)
{
const char *path = luaL_checkstring(l, -1);
SCM module = scm_c_define_module(path, NULL, NULL);
SCM prev_module = scm_set_current_module(module);
// TODO: don't define these functions every time for each servlet
scm_c_define_gsubr("get_arg", 2, 0, 0, &api_get_arg);
scm_c_define_gsubr("get_method", 1, 0, 0, &api_get_method);
scm_c_define_gsubr("get_header", 2, 0, 0, &api_get_header);
scm_c_define_gsubr("set_status", 2, 0, 0, &api_set_status);
scm_c_define_gsubr("set_header", 3, 0, 0, &api_set_header);
scm_c_define_gsubr("rwrite", 2, 0, 0, &api_rwrite);
scm_c_define_gsubr("rflush", 1, 0, 0, &api_rflush);
SCM foo = scm_c_primitive_load(path);
SCM run_symbol = scm_c_lookup("run");
SCM run_ref = scm_variable_ref(run_symbol);
scm_set_current_module(prev_module);
lua_newtable(l);
lua_pushlightuserdata(l, (void*)run_ref);
lua_pushcclosure(l, servlet_run, 1);
lua_setfield(l, -2, "run");
return 1;
}
SCM g_scm_c_get_uref (TOPLEVEL *toplevel, OBJECT *object)
{
SCM func = scm_variable_ref (scm_c_lookup ("get-uref"));
SCM object_smob = g_make_object_smob (toplevel, object);
SCM exp = scm_list_2 (func, object_smob);
return g_scm_eval_protected (exp, SCM_UNDEFINED);
}
SCM g_scm_c_get_uref (OBJECT *object)
{
SCM func = scm_variable_ref (scm_c_lookup ("get-uref"));
SCM object_smob = edascm_from_object (object);
SCM exp = scm_list_2 (func, object_smob);
return g_scm_eval_protected (exp, SCM_UNDEFINED);
}
int main( ){
SCM func;
scm_init_guile();
scm_c_primitive_load( "helloworld.scm" );
func = scm_variable_ref( scm_c_lookup( "hello_world" ) );
scm_call_0( func );
return 0;
}
// Does not include the template object in the string representation.
static PyObject *
pyscm_PySCM_str(pyscm_PySCMObject *self)
{
if (0 == self->ob_scm_index) {
return(PyString_FromString("<no SCM association>"));
}
SCM shandle = scm_hashv_get_handle(pyscm_registration_hash,scm_long2num(self->ob_scm_index));
if (SCM_BOOLP(shandle) && SCM_EQ_P(SCM_BOOL_F,shandle)) {
Py_FatalError("PySCM object lost its associated SCM object");
}
SCM sstr = scm_object_to_string(SCM_CADR(shandle),scm_variable_ref(scm_c_lookup("write")));
PyObject *pstr = PyString_FromStringAndSize(SCM_STRING_CHARS(sstr),SCM_STRING_LENGTH(sstr));
return(pstr); // possibly NULL.
}
void process_phrase(char *action, char *word, bool add_to_hist){
/* Add to history */
if(add_to_hist){
int errnum;
errnum = add_to_history(word, hist_fname);
}
/* Look up and call the function */
func_symbol = scm_c_lookup(action);
func = scm_variable_ref(func_symbol);
ret_val = scm_call_1(func, scm_from_locale_string(word));
/* TODO: process output based on the result of the Scheme function */
/* SCM is_list = scm_list_p (ret_val); */
/* Print the output */
print_scheme_list(ret_val);
}
/*! \brief Scheme API initialisation worker function.
* \par Function Description
* Called by edascm_init() with current thread in Guile mode.
*/
static void *
edascm_init_impl (void *data)
{
#include "scheme_init.x"
scm_setlocale(scm_variable_ref(scm_c_lookup("LC_ALL")), scm_from_locale_string(""));
edascm_init_smob ();
edascm_init_toplevel ();
edascm_init_object ();
edascm_init_complex ();
edascm_init_page ();
edascm_init_attrib ();
edascm_init_os ();
edascm_init_config ();
edascm_init_closure ();
edascm_init_deprecated ();
return NULL;
}
/**
* scm_return_rep:
*
* Retourne le dernier résultat,
* celui-ci étant sauvegardé dans "private-preced-var"
*/
SCM
scm_return_rep ()
{
return scm_c_lookup ("private-preced-var");
}
void
scm_init_deprecated_goops (void)
{
var_slot_ref_using_class = scm_c_lookup ("slot-ref-using-class");
var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!");
var_slot_bound_using_class_p = scm_c_lookup ("slot-bound-using-class?");
var_slot_exists_using_class_p = scm_c_lookup ("slot-exists-using-class?");
scm_no_applicable_method =
scm_variable_ref (scm_c_lookup ("no-applicable-method"));
var_get_keyword = scm_c_lookup ("get-keyword");
scm_class_class = scm_variable_ref (scm_c_lookup ("<class>"));
scm_class_top = scm_variable_ref (scm_c_lookup ("<top>"));
scm_class_object = scm_variable_ref (scm_c_lookup ("<object>"));
scm_class_foreign_slot = scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
scm_class_protected = scm_variable_ref (scm_c_lookup ("<protected-slot>"));
scm_class_hidden = scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
scm_class_opaque = scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
scm_class_read_only = scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
scm_class_self = scm_variable_ref (scm_c_lookup ("<self-slot>"));
scm_class_protected_opaque = scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>"));
scm_class_protected_hidden = scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>"));
scm_class_protected_read_only = scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>"));
scm_class_scm = scm_variable_ref (scm_c_lookup ("<scm-slot>"));
scm_class_int = scm_variable_ref (scm_c_lookup ("<int-slot>"));
scm_class_float = scm_variable_ref (scm_c_lookup ("<float-slot>"));
scm_class_double = scm_variable_ref (scm_c_lookup ("<double-slot>"));
/* scm_class_generic functions classes */
scm_class_procedure_class = scm_variable_ref (scm_c_lookup ("<procedure-class>"));
scm_class_applicable_struct_class = scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
scm_class_method = scm_variable_ref (scm_c_lookup ("<method>"));
scm_class_accessor_method = scm_variable_ref (scm_c_lookup ("<accessor-method>"));
scm_class_applicable = scm_variable_ref (scm_c_lookup ("<applicable>"));
scm_class_applicable_struct = scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
scm_class_applicable_struct_with_setter = scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
scm_class_generic = scm_variable_ref (scm_c_lookup ("<generic>"));
scm_class_extended_generic = scm_variable_ref (scm_c_lookup ("<extended-generic>"));
scm_class_generic_with_setter = scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
scm_class_accessor = scm_variable_ref (scm_c_lookup ("<accessor>"));
scm_class_extended_generic_with_setter = scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
scm_class_extended_accessor = scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
/* Primitive types classes */
scm_class_boolean = scm_variable_ref (scm_c_lookup ("<boolean>"));
scm_class_char = scm_variable_ref (scm_c_lookup ("<char>"));
scm_class_list = scm_variable_ref (scm_c_lookup ("<list>"));
scm_class_pair = scm_variable_ref (scm_c_lookup ("<pair>"));
scm_class_null = scm_variable_ref (scm_c_lookup ("<null>"));
scm_class_string = scm_variable_ref (scm_c_lookup ("<string>"));
scm_class_symbol = scm_variable_ref (scm_c_lookup ("<symbol>"));
scm_class_vector = scm_variable_ref (scm_c_lookup ("<vector>"));
scm_class_number = scm_variable_ref (scm_c_lookup ("<number>"));
scm_class_complex = scm_variable_ref (scm_c_lookup ("<complex>"));
scm_class_real = scm_variable_ref (scm_c_lookup ("<real>"));
scm_class_integer = scm_variable_ref (scm_c_lookup ("<integer>"));
scm_class_fraction = scm_variable_ref (scm_c_lookup ("<fraction>"));
scm_class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
scm_class_unknown = scm_variable_ref (scm_c_lookup ("<unknown>"));
scm_class_procedure = scm_variable_ref (scm_c_lookup ("<procedure>"));
scm_class_primitive_generic = scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
scm_class_port = scm_variable_ref (scm_c_lookup ("<port>"));
scm_class_input_port = scm_variable_ref (scm_c_lookup ("<input-port>"));
scm_class_output_port = scm_variable_ref (scm_c_lookup ("<output-port>"));
scm_class_input_output_port = scm_variable_ref (scm_c_lookup ("<input-output-port>"));
scm_port_class = scm_i_port_class;
scm_smob_class = scm_i_smob_class;
}
static PyObject *lookup_wrapper(const char *name)
{
return scm2py(scm_variable_ref(scm_c_lookup(name)));
}
/* get confinement from SCM
* in SCM, confinement is given by one of these:
* for spherical confinement,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "sphere"
* 10.0 ;; radius of the cavity at (0, 0, 0)
* ))
* for spherical confinement with a hole,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "sphere+hole"
* 10.0 ;; radius of the cavity at (0, 0, 0)
* 1.0 ;; radius of the hole at (0, 0, 1) direction
* ))
* for cylindrical confinement,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "cylinder" ;; the cylinder center goes through (0, 0, 0) and (x, y, z).
* 10.0 ;; radius of the cylinder
* 1.0 0.0 0.0 ;; direction vector (x, y, z) of the cylinder
* ))
* for dumbbell confinement,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "dumbbell" ;; the origin is at the center of the cylinder
* 10.0 ;; left cavity radius centered at (center1, 0, 0)
* 10.0 ;; right cavity radius centered at (center2, 0, 0)
* 2.0 ;; length of the cylinder
* 1.0 ;; cylinder radius
* ))
* for 2D hexagonal confinement with cylinder pipe,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "hex2d"
* 10.0 ;; cavity radius
* 1.0 ;; cylinder radius
* 12.0 ;; lattice spacing
* ))
* for porous media (outside of the 3D hexagonal particle array)
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "porous"
* 10.0 ;; particle radius
* 20.0 ;; lattice spacing in x (2R for touching case)
* ))
* INPUT
* var : name of the variable.
* in the above example, set "confinement".
* OUTPUT
* returned value : struct confinement
* if NULL is returned, it failed (not defined)
*/
struct confinement *
CF_guile_get (const char *var)
{
if (guile_check_symbol (var) == 0)
{
fprintf (stderr, "CF_guile_get: %s is not defined\n", var);
return (NULL);
}
SCM scm_symbol
= scm_c_lookup (var);
SCM scm_confinement
= scm_variable_ref (scm_symbol);
if (!SCM_NFALSEP (scm_list_p (scm_confinement)))
{
fprintf (stderr, "CF_guile_get: %s is not a list\n", var);
return (NULL);
}
struct confinement *cf = NULL;
unsigned long len
= scm_num2ulong (scm_length (scm_confinement),
0, "CF_guile_get");
if (len == 0)
{
// no confinement
return (cf);
}
else if (len < 4)
{
fprintf (stderr, "CF_guile_get: %s is too short\n", var);
return (NULL);
}
double epsilon
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (0)),
"CF_guile_get");
double r0
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (1)),
"CF_guile_get");
// get the string
char *str_cf = NULL;
SCM scm_conf = scm_list_ref (scm_confinement, scm_int2num (2));
#ifdef GUILE16
size_t str_len;
if (gh_string_p (scm_conf))
{
str_cf = gh_scm2newstr (scm_conf, &str_len);
}
#else // !GUILE16
if (scm_is_string (scm_conf))
{
str_cf = scm_to_locale_string (scm_conf);
}
#endif // GUILE16
if (strcmp (str_cf, "sphere") == 0)
{
if (len != 4)
{
fprintf (stderr, "CF_guile_get:"
" for sphere, number of parameter must be 1\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
cf = CF_init (0, // sphere
R,
0.0, // r
0.0, 0.0, 0.0, // x, y, z
0.0, // R2
0.0, // L
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "sphere+hole") == 0)
{
if (len != 5)
{
fprintf (stderr, "CF_guile_get:"
" for sphere+hole, number of parameter must be 2\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double r
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
cf = CF_init (1, // sphere+hole
R,
r,
0.0, 0.0, 0.0, // x, y, z
0.0, // R2
0.0, // L
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "cylinder") == 0)
{
if (len != 7)
{
fprintf (stderr, "CF_guile_get:"
" for cylinder, number of parameter must be 4\n");
}
else
{
double r
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double x
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
double y
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (5)),
"CF_guile_get");
double z
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (6)),
"CF_guile_get");
cf = CF_init (2, // cylinder
0.0, // R,
r,
x, y, z,
0.0, // R2
0.0, // L
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "dumbbell") == 0)
{
if (len != 7)
{
fprintf (stderr, "CF_guile_get:"
" for dumbbell, number of parameter must be 4\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double R2
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
double L
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (5)),
"CF_guile_get");
double r
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (6)),
"CF_guile_get");
cf = CF_init (3, // dumbbell
R,
r,
0.0, 0.0, 0.0, // x, y, z
R2,
L,
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "hex2d") == 0)
{
if (len != 6)
{
fprintf (stderr, "CF_guile_get:"
" for hex2d, number of parameter must be 3\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double r
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
double L
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (5)),
"CF_guile_get");
cf = CF_init (4, // hex2d
R,
r,
0.0, 0.0, 0.0, // x, y, z
0.0, // R2
L,
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "porous") == 0)
{
if (len != 5)
{
fprintf (stderr, "CF_guile_get:"
" for hex2d, number of parameter must be 2\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double L
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
cf = CF_init (5, // porous
R,
0.0,
0.0, 0.0, 0.0, // x, y, z
0.0, // R2
L,
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else
{
fprintf (stderr, "CF_guile_get: invalid confinement %s\n",
str_cf);
}
free (str_cf);
return (cf); // success
}
/* \brief Print a list of available backends.
* \par Function Description
* Prints a list of available gnetlist backends by searching for files
* in each of the directories in the current Guile %load-path. A file
* is considered to be a gnetlist backend if its basename begins with
* "gnet-" and ends with ".scm".
*
* \param pr_current Current #TOPLEVEL structure.
*/
void
gnetlist_backends (TOPLEVEL *pr_current)
{
SCM s_load_path;
GList *backend_names = NULL, *iter = NULL;
/* Look up the current Guile %load-path */
s_load_path = scm_variable_ref (scm_c_lookup ("%load-path"));
for ( ; s_load_path != SCM_EOL; s_load_path = scm_cdr (s_load_path)) {
SCM s_dir_name = scm_car (s_load_path);
char *dir_name;
DIR *dptr;
struct dirent *dentry;
/* Get directory name from Scheme */
g_assert (scm_is_true (scm_list_p (s_load_path))); /* Sanity check */
g_assert (scm_is_string (scm_car (s_load_path))); /* Sanity check */
dir_name = scm_to_utf8_string (s_dir_name);
/* Open directory */
dptr = opendir (dir_name);
if (dptr == NULL) {
g_warning ("Can't open directory %s: %s\n",
dir_name, strerror (errno));
continue;
}
free (dir_name);
while (1) {
char *name;
dentry = readdir (dptr);
if (dentry == NULL) break;
/* Check that filename has the right format to be a gnetlist
* backend */
if (!(g_str_has_prefix (dentry->d_name, "gnet-")
&& g_str_has_suffix (dentry->d_name, ".scm")))
continue;
/* Copy filename and remove prefix & suffix. Add to list of
* backend names. */
name = g_strdup (dentry->d_name + 5);
name[strlen(name)-4] = '\0';
backend_names = g_list_prepend (backend_names, name);
}
/* Close directory */
closedir (dptr);
}
/* Sort the list of backends */
backend_names = g_list_sort (backend_names, (GCompareFunc) strcmp);
printf ("List of available backends: \n\n");
for (iter = backend_names; iter != NULL; iter = g_list_next (iter)) {
printf ("%s\n", (char *) iter->data);
}
printf ("\n");
scm_remember_upto_here_1 (s_load_path);
}