i know this is a bit late, but i use the following quite
effectively. maybe someone can clean it up a little bit
and include it in stk.
to use this code, #include <gh_extra.h> into your code,
and link in gh_extra.o. then one can code with the gh_
api in stk. mostly, anyway.
one important difference: i use a new c function called
gh_new_procedure_simple rather than gh_new_procedure. it
is a direct simplification of the gh_new_procedure, and
is trivially implemented if one is programming in guile
itself.
i've also added a couple of goodies that would need to
be added to gh_ in guile itself. gh_assert comes to mind,
there may be others.
certainly, things are missing. i've added things as i've
needed them. use as you please, if you do please include
my name.
-russ
gh_extra.h:
#ifndef GH_EXTRA_H
#define GH_EXTRA_H
#if defined(__cplusplus)
extern "C" {
#endif
#include <stdio.h>
#include <stk.h>
#define gh_eq_p(obj1, obj2) STk_eq(obj1, obj2)
#define gh_gc_mark(obj) STk_gc_mark(obj)
#define gh_gc_link(obj) (void)0;
#define gh_gc_unlink(obj) (void)0;
#define gh_string_p(obj) STRINGP(obj)
#define gh_exact_p(obj) INTEGERP(obj)
#define gh_number_p(obj) NUMBERP(obj)
#define gh_procedure_p(obj) CLOSUREP(obj)
#define gh_car(obj) CAR(obj)
#define gh_cdr(obj) CDR(obj)
#define gh_str2scm(s,len) (s?STk_makestrg(len,s):STk_makestrg(1,"\0"))
#define gh_str02scm(s) (s?STk_makestrg(strlen(s),s):STk_makestrg(1,"\0"))
#define gh_vector(n, init) STk_make_vector(n, init)
#define gh_int2scm(n) STk_makeinteger((double)n)
#define gh_scm2int(obj) INTEGER(obj)
#define gh_scm2long(obj) ((long)INTEGER(obj))
#define gh_scm2double(obj) FLONM(obj)
#define gh_double2scm(n) STk_makenumber(n)
#define gh_vset(v, i, obj) STk_vector_set(v, i, obj)
#define SCM_EOL STk_nil
#define gh_list_length(obj) ((unsigned long)STk_llength(obj))
#define gh_apply(proc, ls) STk_apply(proc, ls)
#define gh_cons(obj1, obj2) STk_cons(obj1, obj2)
#define SCM_BOOL_F STk_ntruth
#define SCM_BOOL_T STk_truth
#define gh_defer_ints() (void)1
#define gh_allow_ints() (void)1
#define gh_new_cell(obj, tag) NEWCELL((obj), (tag))
#define gh_type_p(obj, tag) TYPEP(obj, tag)
#define gh_set_ext_data(obj, x) EXTDATA(obj) = (void*)(x);
#define gh_get_ext_data(obj) (void*)EXTDATA(obj)
#define gh_intern(str) STk_intern(str)
#define gh_defer_ints() (void)1
#define gh_allow_ints() (void)1
/* prototypes for functions defined in gh_extra.c */
#define GH_ARGLIST -1
void gh_new_procedure_simple(char *name, SCM (*fn)(), int n_args);
void gh_assert(int cond, const char *proc, const char *msg, SCM obj);
char *gh_must_malloc(long size);
void gh_scm2str(SCM obj, char **return_str, int *len);
void gh_scm2str0(SCM obj, char *return_str0, int max_len);
#if defined(__cplusplus)
};
#endif
gh_extra.c:
void gh_new_procedure_simple(char *name, SCM (*fn)(), int n_args)
{
int type;
switch (n_args) {
case 0:
type = tc_subr_0;
break;
case 1:
type = tc_subr_1;
break;
case 2:
type = tc_subr_2;
break;
case 3:
type = tc_subr_3;
break;
case GH_ARGLIST:
type = tc_lsubr;
break;
default:
assert(0);
break;
}
STk_add_new_primitive(name, type, fn);
return;
}
void gh_assert(int cond, const char *proc, const char *msg, SCM obj)
{
if (!cond) {
char buf[256];
sprintf(buf, "%s:%s", proc, msg);
STk_err(buf, obj);
}
}
void gh_scm2str0(SCM obj, char *return_str0, int max_len)
{
char *ret_str = CHARS(obj);
int i, len = STRSIZE(obj);
for (i = 0; (i < len) && (i < (max_len-1)); ++i) {
return_str0[i] = ret_str[i];
}
/* now make sure we null-terminate it */
return_str0[i] = '\0';
}
void gh_scm2str(SCM obj, char **return_str, int *len)
{
*return_str = CHARS(obj);
*len = STRSIZE(obj);
return;
}
char *gh_must_malloc(long size)
{
return must_malloc(size);
}
--
Russell D. McManus phone: 212-357-4901
Goldman, Sachs & Co. beep: 917-556-0708
Intl. Equities Technology
Received on Tue Apr 29 1997 - 15:24:25 CEST