Restored mzscheme
git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk/SWIG@793 626c5289-ae23-0410-ae9c-e8d60b6d4f22
This commit is contained in:
Dave Beazley
parent
0d4871de7a
commit
3beee3ed17
3 changed files with 253 additions and 233 deletions
|
|
@ -13,8 +13,9 @@ AR = @AR@
|
|||
RANLIB = @RANLIB@
|
||||
|
||||
TARGET = libmodules11.a
|
||||
OBJS = swigmain.o tcl8.o python.o perl5.o guile.o ruby.o #java.o mzscheme.o
|
||||
SRCS = swigmain.cxx tcl8.cxx python.cxx perl5.cxx guile.cxx #java.cxx mzscheme.cxx ruby.cxx
|
||||
OBJS = swigmain.o tcl8.o python.o perl5.o guile.o ruby.o mzscheme.o #java.o
|
||||
SRCS = swigmain.cxx tcl8.cxx python.cxx perl5.cxx guile.cxx ruby.cxx mzscheme.cxx #java.cxx
|
||||
|
||||
INCLUDE = -I$(srcdir)/../Include \
|
||||
-I$(srcdir)/../SWIG1.1 \
|
||||
-I$(srcdir)/../DOH/Include \
|
||||
|
|
|
|||
|
|
@ -29,17 +29,16 @@ static char cvsroot[] = "$Header$";
|
|||
static char *mzscheme_usage = (char*)"\
|
||||
\n\
|
||||
Mzscheme Options (available with -mzscheme)\n\
|
||||
-help - Print this help\n\
|
||||
-module name - Set base name of module (not implemented) \n\
|
||||
-prefix name - Set a prefix to be appended to all name\n\
|
||||
-help - Print this help\n\
|
||||
-module name - Set base name of module (not implemented) \n\
|
||||
-prefix name - Set a prefix to be appended to all name\n\
|
||||
\n"
|
||||
;
|
||||
|
||||
static char *mzscheme_path = (char*)"mzscheme";
|
||||
static char *prefix = 0;
|
||||
static char *module = 0;
|
||||
|
||||
static DOHString *init_func_def = 0;
|
||||
static char *prefix=0;
|
||||
static char *module=0;
|
||||
static char *mzscheme_path=(char*)"mzscheme";
|
||||
static String *init_func_def = 0;
|
||||
|
||||
// ---------------------------------------------------------------------
|
||||
// MZSCHEME::parse_args(int argc, char *argv[])
|
||||
|
|
@ -59,7 +58,7 @@ MZSCHEME::parse_args (int argc, char *argv[])
|
|||
if (argv[i]) {
|
||||
if (strcmp (argv[i], "-help") == 0) {
|
||||
fputs (mzscheme_usage, stderr);
|
||||
SWIG_exit (EXIT_SUCCESS);
|
||||
SWIG_exit (0);
|
||||
}
|
||||
else if (strcmp (argv[i], "-prefix") == 0) {
|
||||
if (argv[i + 1]) {
|
||||
|
|
@ -74,7 +73,7 @@ MZSCHEME::parse_args (int argc, char *argv[])
|
|||
}
|
||||
else if (strcmp (argv[i], "-module") == 0) {
|
||||
if (argv[i + 1]) {
|
||||
set_module (argv[i + 1], 0);
|
||||
set_module (argv[i + 1]);
|
||||
Swig_mark_arg (i);
|
||||
Swig_mark_arg (i + 1);
|
||||
++i;
|
||||
|
|
@ -113,6 +112,7 @@ MZSCHEME::parse_args (int argc, char *argv[])
|
|||
void
|
||||
MZSCHEME::parse ()
|
||||
{
|
||||
init_func_def = NewString("");
|
||||
printf ("Generating wrappers for Mzscheme\n");
|
||||
|
||||
init_func_def = NewString("");
|
||||
|
|
@ -137,7 +137,7 @@ MZSCHEME::parse ()
|
|||
//----------------------------------------------------------------------
|
||||
|
||||
void
|
||||
MZSCHEME::set_module (char *mod_name, char **)
|
||||
MZSCHEME::set_module (char *mod_name)
|
||||
{
|
||||
if (module) {
|
||||
printf ("module already set (%s), returning\n", module);
|
||||
|
|
@ -160,7 +160,7 @@ void
|
|||
MZSCHEME::set_init (char *iname)
|
||||
{
|
||||
abort (); // for now -ttn
|
||||
set_module (iname, 0);
|
||||
set_module (iname);
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------
|
||||
|
|
@ -185,7 +185,7 @@ MZSCHEME::headers (void)
|
|||
if (Swig_insert_file ("mzscheme.swg", f_header) == -1) {
|
||||
Printf (stderr, "SWIG : Fatal error. ");
|
||||
Printf (stderr, "Unable to locate 'mzscheme.swg' in SWIG library.\n");
|
||||
SWIG_exit (EXIT_FAILURE);
|
||||
SWIG_exit (1);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -213,9 +213,8 @@ void
|
|||
MZSCHEME::close (void)
|
||||
{
|
||||
Printf (f_init, "}\n\n");
|
||||
|
||||
Printf(f_init, "Scheme_Object *scheme_reload(Scheme_Env *env) {\n");
|
||||
Printf(f_init, "%s\n", init_func_def);
|
||||
Printf(f_init, "%s\n", Char(init_func_def));
|
||||
Printf (f_init, "\treturn scheme_void;\n}\n");
|
||||
Printf(f_init, "Scheme_Object *scheme_initialize(Scheme_Env *env) {\n");
|
||||
Printf(f_init, "\treturn scheme_reload(env);\n");
|
||||
|
|
@ -223,7 +222,7 @@ MZSCHEME::close (void)
|
|||
}
|
||||
|
||||
// ----------------------------------------------------------------------
|
||||
// MZSCHEME::get_pointer(int parm, DataType *t)
|
||||
// MZSCHEME::get_pointer(int parm, SwigType *t, Wrapper *f)
|
||||
//
|
||||
// Emits code to get a pointer from a parameter and do type checking.
|
||||
// parm is the parameter number. This function is only used
|
||||
|
|
@ -231,154 +230,154 @@ MZSCHEME::close (void)
|
|||
// ----------------------------------------------------------------------
|
||||
|
||||
void
|
||||
MZSCHEME::get_pointer (DOHString_or_char *name, int parm, DataType *t,
|
||||
Wrapper *f)
|
||||
MZSCHEME::get_pointer (String *name, int parm, SwigType *t, Wrapper *f)
|
||||
{
|
||||
Printf(f->code," if (!swig_get_c_pointer(argv[%d],\"%s\", (void **) &_arg%d))\n", parm, DataType_manglestr(t), parm);
|
||||
Printf(f->code," scheme_wrong_type(\"%s\", \"%s\", %d, argc, argv);\n", name, DataType_manglestr(t), parm);
|
||||
char p[256];
|
||||
sprintf(p, "%d", parm);
|
||||
Printv(f->code, tab4, "if (!swig_get_c_pointer(argv[", p, "], \"", SwigType_manglestr(t),
|
||||
"\", (void **) &arg", p, "))\n",0);
|
||||
Printv(f->code, tab8, "scheme_wrong_type(\"", name,
|
||||
"\", \"", SwigType_manglestr(t), "\", ", p, ", argc, argv);\n",0);
|
||||
}
|
||||
|
||||
// ----------------------------------------------------------------------
|
||||
// MZSCHEME::create_function(char *name, char *iname, DataType *d,
|
||||
// MZSCHEME::create_function(char *name, char *iname, SwigType *d,
|
||||
// ParmList *l)
|
||||
//
|
||||
// Create a function declaration and register it with the interpreter.
|
||||
// ----------------------------------------------------------------------
|
||||
|
||||
static void
|
||||
mreplace (DOHString *s, DOHString_or_char *argnum, DOHString_or_char *arg, DOHString_or_char *proc_name)
|
||||
mreplace (String *s, String *argnum, String *arg, String *proc_name)
|
||||
{
|
||||
Replace(s,"$argnum", argnum, DOH_REPLACE_ANY);
|
||||
Replace(s,"$arg", arg, DOH_REPLACE_ANY);
|
||||
Replace(s,"$name", proc_name, DOH_REPLACE_ANY);
|
||||
Replace(s, "$argnum", argnum, DOH_REPLACE_ANY);
|
||||
Replace(s, "$arg", arg, DOH_REPLACE_ANY);
|
||||
Replace(s, "$name", proc_name, DOH_REPLACE_ANY);
|
||||
}
|
||||
|
||||
static void
|
||||
throw_unhandled_mzscheme_type_error (DataType *d)
|
||||
throw_unhandled_mzscheme_type_error (SwigType *d)
|
||||
{
|
||||
fflush (stdout);
|
||||
Printf (stderr, "ERROR: Unhandled MZSCHEME type error.\n");
|
||||
Printf (stderr, " type %d\n", DataType_Gettypecode(d));
|
||||
Printf (stderr, " name %s\n", DataType_Getname(d));
|
||||
Printf (stderr, " is_pointer %d\n", DataType_is_pointer(d));
|
||||
/* Printf (stderr, "implicit_ptr %d\n", d->implicit_ptr); */
|
||||
Printf (stderr, "is_reference %d\n", DataType_is_reference(d));
|
||||
/* Printf (stderr, " status %d\n", d->status); */
|
||||
/* Printf (stderr, " qualifier %s\n", (d->qualifier ? d->qualifier : ""));
|
||||
Printf (stderr, " arraystr %s\n", (d->arraystr ? d->arraystr : "")); */
|
||||
/* Printf (stderr, " id %d\n", d->id); */
|
||||
|
||||
fprintf (stderr, "ERROR: Unhandled MZSCHEME type error.\n");
|
||||
fprintf (stderr, "str: %s\n", Char(SwigType_str(d,0)));
|
||||
fprintf (stderr, "lstr: %s\n", Char(SwigType_lstr(d,0)));
|
||||
fprintf (stderr, "manglestr: %s\n", Char(SwigType_manglestr(d)));
|
||||
Printf (stderr, "\n\nBAILING...\n"); // for now -ttn
|
||||
abort(); // for now -ttn
|
||||
}
|
||||
|
||||
void
|
||||
MZSCHEME::create_function (char *name, char *iname, DataType *d, ParmList *l)
|
||||
MZSCHEME::create_function (char *name, char *iname, SwigType *d, ParmList *l)
|
||||
{
|
||||
|
||||
char source[256], target[256], argnum[256], arg[256];
|
||||
char *tm;
|
||||
Wrapper *f;
|
||||
DOHString *cleanup = 0;
|
||||
DOHString *proc_name = 0;
|
||||
Parm *p;
|
||||
|
||||
DOHString *outarg = 0;
|
||||
Wrapper *f = NewWrapper();
|
||||
String *proc_name = NewString("");
|
||||
String *source = NewString("");
|
||||
String *target = NewString("");
|
||||
String *argnum = NewString("");
|
||||
String *arg = NewString("");
|
||||
String *cleanup = NewString("");
|
||||
String *outarg = NewString("");
|
||||
String *build = NewString("");
|
||||
SwigType *t;
|
||||
char *tm;
|
||||
int need_len = 0;
|
||||
int need_tempc = 0;
|
||||
int have_build = 0;
|
||||
int argout_set = 0;
|
||||
|
||||
f = NewWrapper();
|
||||
outarg = NewString("");
|
||||
cleanup = NewString("");
|
||||
int i = 0;
|
||||
|
||||
// Make a wrapper name for this
|
||||
char * wname = Swig_name_wrapper (iname);
|
||||
char *wname = Char(Swig_name_wrapper(iname));
|
||||
|
||||
// Build the name for Scheme.
|
||||
proc_name = NewString(iname);
|
||||
Replace(proc_name,"_","-",DOH_REPLACE_ANY);
|
||||
Printv(proc_name, iname,0);
|
||||
Replace(proc_name, "_", "-", DOH_REPLACE_ANY);
|
||||
|
||||
// writing the function wrapper function
|
||||
Printv(f->def,
|
||||
"static Scheme_Object *", wname, " (",
|
||||
"int argc, Scheme_Object **argv",
|
||||
")\n{",
|
||||
0);
|
||||
Printv(f->def, "static Scheme_Object *", wname, " (", 0);
|
||||
Printv(f->def, "int argc, Scheme_Object **argv", 0);
|
||||
Printv(f->def, ")\n{", 0);
|
||||
|
||||
// Declare return variable and arguments
|
||||
// number of parameters
|
||||
// they are called _arg0, _arg1, ...
|
||||
// the return value is called _result
|
||||
// they are called arg0, arg1, ...
|
||||
// the return value is called result
|
||||
|
||||
int pcount = emit_args (d, l, f);
|
||||
int pcount = emit_args(d, l, f);
|
||||
int numargs = 0;
|
||||
int numopt = 0;
|
||||
|
||||
|
||||
// adds local variables : type name
|
||||
Wrapper_add_local (f,"_tempc","char *_tempc");
|
||||
Wrapper_add_local (f,"_len", "int _len");
|
||||
Wrapper_add_local (f,"swig_result", "Scheme_Object *swig_result");
|
||||
// adds local variables
|
||||
Wrapper_add_local(f, "_tempc", "char *_tempc");
|
||||
Wrapper_add_local(f, "_len", "int _len");
|
||||
Wrapper_add_local(f, "swig_result", "Scheme_Object *swig_result");
|
||||
|
||||
// Now write code to extract the parameters (this is super ugly)
|
||||
|
||||
int i = 0;
|
||||
p = l;
|
||||
for (i = 0; i < pcount; ++i, p = Getnext(p)) {
|
||||
DataType *pt = Gettype(p);
|
||||
char *pn = Getname(p);
|
||||
|
||||
for(p = l; p; p = Getnext(p)) {
|
||||
// Produce names of source and target
|
||||
|
||||
sprintf(source,"argv[%d]",i);
|
||||
sprintf(target,"%s", Getlname(p));
|
||||
sprintf(argnum,"%d",i);
|
||||
strcpy(arg,pn);
|
||||
Clear(source);
|
||||
Clear(target);
|
||||
Clear(argnum);
|
||||
Clear(arg);
|
||||
Printf(source, "argv[%d]", i);
|
||||
Printf(target, "arg%d", i);
|
||||
Printf(argnum, "%d", i);
|
||||
Printv(arg, Getname(p),0);
|
||||
|
||||
// Handle parameter types.
|
||||
|
||||
if (Getignore(p))
|
||||
Printv(f->code, "/* ", pn, " ignored... */\n", 0);
|
||||
Printv(f->code, "/* ", Char(Getname(p)), " ignored... */\n", 0);
|
||||
else {
|
||||
++numargs;
|
||||
if ((tm = typemap_lookup ((char*)"in", typemap_lang,
|
||||
pt, pn, source, target, f))) {
|
||||
if ((tm = Swig_typemap_lookup ((char*)"in",
|
||||
Gettype(p), Getname(p), source, target, f))) {
|
||||
Printv(f->code, tm, "\n", 0);
|
||||
mreplace (f->code, argnum, arg, proc_name);
|
||||
}
|
||||
// no typemap found
|
||||
// assume it's a Scheme_Object containing the C pointer
|
||||
else if (DataType_is_pointer(pt)) {
|
||||
get_pointer (proc_name, i, pt, f);
|
||||
// check if typedef and resolve
|
||||
else if (SwigType_istypedef(Gettype(p))) {
|
||||
t = SwigType_typedef_resolve(Gettype(p));
|
||||
|
||||
// if a pointer then get it
|
||||
if (SwigType_ispointer(t)) {
|
||||
get_pointer (proc_name, i, t, f);
|
||||
}
|
||||
// not a pointer
|
||||
else throw_unhandled_mzscheme_type_error (Gettype(p));
|
||||
}
|
||||
// no typemap found and not a pointer
|
||||
else throw_unhandled_mzscheme_type_error (pt);
|
||||
}
|
||||
|
||||
// Check if there are any constraints.
|
||||
|
||||
if ((tm = typemap_lookup ((char*)"check", typemap_lang,
|
||||
pt, pn, source, target, f))) {
|
||||
if ((tm = Swig_typemap_lookup ((char*)"check",
|
||||
Gettype(p), Getname(p), source, target, f))) {
|
||||
// Yep. Use it instead of the default
|
||||
Printv(f->code,tm,"\n", 0);
|
||||
Printv(f->code, tm, "\n", 0);
|
||||
mreplace (f->code, argnum, arg, proc_name);
|
||||
}
|
||||
|
||||
// Pass output arguments back to the caller.
|
||||
|
||||
if ((tm = typemap_lookup ((char*)"argout", typemap_lang,
|
||||
pt, pn, source, target, f))) {
|
||||
if ((tm = Swig_typemap_lookup ((char*)"argout",
|
||||
Gettype(p), Getname(p), source, target, f))) {
|
||||
// Yep. Use it instead of the default
|
||||
Printv(outarg, tm, "\n", 0);
|
||||
Printv(outarg, tm, "\n",0);
|
||||
mreplace (outarg, argnum, arg, proc_name);
|
||||
argout_set = 1;
|
||||
}
|
||||
|
||||
// Free up any memory allocated for the arguments.
|
||||
if ((tm = typemap_lookup ((char*)"freearg", typemap_lang,
|
||||
pt, pn, source, target, f))) {
|
||||
if ((tm = Swig_typemap_lookup ((char*)"freearg",
|
||||
Gettype(p), Getname(p), source, target, f))) {
|
||||
// Yep. Use it instead of the default
|
||||
Printv(cleanup, tm, "\n", 0);
|
||||
Printv(cleanup, tm, "\n",0);
|
||||
mreplace (cleanup, argnum, arg, proc_name);
|
||||
}
|
||||
i++;
|
||||
}
|
||||
|
||||
// Now write code to make the function call
|
||||
|
|
@ -387,97 +386,97 @@ MZSCHEME::create_function (char *name, char *iname, DataType *d, ParmList *l)
|
|||
|
||||
// Now have return value, figure out what to do with it.
|
||||
|
||||
if (DataType_type(d) == T_VOID) {
|
||||
if (SwigType_type(d) == T_VOID) {
|
||||
if(!argout_set)
|
||||
Printv(f->code, tab4, "swig_result = scheme_void;\n", 0);
|
||||
Printv(f->code, tab4, "swig_result = scheme_void;\n",0);
|
||||
}
|
||||
|
||||
else if ((tm = typemap_lookup ((char*)"out", typemap_lang,
|
||||
d, name, (char*)"result", (char*)"swig_result", f))) {
|
||||
Printv(f->code, tm, "\n", 0);
|
||||
else if ((tm = Swig_typemap_lookup ((char*)"out",
|
||||
d, name, (char*)"result", (char*)"swig_result", f))) {
|
||||
Printv(f->code, tm, "\n",0);
|
||||
mreplace (f->code, argnum, arg, proc_name);
|
||||
}
|
||||
// no typemap found and not void then create a Scheme_Object holding
|
||||
// the C pointer and return it
|
||||
else if (DataType_is_pointer(d)) {
|
||||
Printv(f->code,
|
||||
tab4,
|
||||
else if (SwigType_ispointer(d)) {
|
||||
Printv(f->code, tab4,
|
||||
"swig_result = swig_make_c_pointer(",
|
||||
"result, \"",
|
||||
DataType_manglestr(d),
|
||||
"\");\n",
|
||||
0);
|
||||
SwigType_manglestr(d),
|
||||
"\");\n", 0);
|
||||
}
|
||||
else {
|
||||
throw_unhandled_mzscheme_type_error (d);
|
||||
}
|
||||
|
||||
// Dump the argument output code
|
||||
Printv(f->code, outarg,0);
|
||||
Printv(f->code, Char(outarg),0);
|
||||
|
||||
// Dump the argument cleanup code
|
||||
Printv(f->code, cleanup, 0);
|
||||
Printv(f->code, Char(cleanup),0);
|
||||
|
||||
// Look for any remaining cleanup
|
||||
|
||||
if (NewObject) {
|
||||
if ((tm = typemap_lookup ((char*)"newfree", typemap_lang,
|
||||
d, iname, (char*)"result", (char*)"", f))) {
|
||||
Printv(f->code,tm,"\n",0);
|
||||
if ((tm = Swig_typemap_lookup ((char*)"newfree",
|
||||
d, iname, (char*)"result", (char*)"", f))) {
|
||||
Printv(f->code, tm, "\n",0);
|
||||
mreplace (f->code, argnum, arg, proc_name);
|
||||
}
|
||||
}
|
||||
|
||||
// Free any memory allocated by the function being wrapped..
|
||||
|
||||
if ((tm = typemap_lookup ((char*)"ret", typemap_lang,
|
||||
d, name, (char*)"result", (char*)"", f))) {
|
||||
if ((tm = Swig_typemap_lookup ((char*)"ret",
|
||||
d, name, (char*)"result", (char*)"", f))) {
|
||||
// Yep. Use it instead of the default
|
||||
Printv(f->code,tm,"\n",0);
|
||||
Printv(f->code, tm, "\n",0);
|
||||
mreplace (f->code, argnum, arg, proc_name);
|
||||
}
|
||||
|
||||
// returning multiple values
|
||||
if(argout_set) {
|
||||
if(DataType_type(d) == T_VOID) {
|
||||
Wrapper_add_local(f,"_lenv","int _lenv = 0");
|
||||
Wrapper_add_local(f,"_values", "Scheme_Object * _values[MAXVALUES]");
|
||||
Printv(f->code, tab4, "swig_result = scheme_values(_lenv, _values);\n", 0);
|
||||
if(SwigType_type(d) == T_VOID) {
|
||||
Wrapper_add_local(f, "_lenv", "int _lenv = 0");
|
||||
Wrapper_add_local(f, "values", "Scheme_Object *values[MAXVALUES]");
|
||||
Printv(f->code, tab4, "swig_result = scheme_values(_lenv, _values);\n",0);
|
||||
}
|
||||
else {
|
||||
Wrapper_add_local(f,"_lenv","int _lenv = 1");
|
||||
Wrapper_add_local(f,"_values", "Scheme_Object * _values[MAXVALUES]");
|
||||
Printv(f->code, tab4, "_values[0] = swig_result;\n", 0);
|
||||
Printv(f->code, tab4, "swig_result = scheme_values(_lenv, _values);\n", 0);
|
||||
Wrapper_add_local(f, "_lenv", "int _lenv = 1");
|
||||
Wrapper_add_local(f, "values", "Scheme_Object *values[MAXVALUES]");
|
||||
Printv(f->code, tab4, "_values[0] = swig_result;\n",0);
|
||||
Printv(f->code, tab4, "swig_result = scheme_values(_lenv, _values);\n",0);
|
||||
}
|
||||
}
|
||||
|
||||
// Wrap things up (in a manner of speaking)
|
||||
|
||||
Printv(f->code, tab4, "return swig_result;\n", "}\n", 0);
|
||||
Printv(f->code, tab4, "return swig_result;\n",0);
|
||||
Printv(f->code, "}\n",0);
|
||||
|
||||
Wrapper_print(f,f_wrappers);
|
||||
Wrapper_print(f, f_wrappers);
|
||||
|
||||
// Now register the function
|
||||
/* Printv(init_func_def,
|
||||
"scheme_add_global(\"", proc_name,
|
||||
char temp[256];
|
||||
sprintf(temp, "%d", numargs);
|
||||
Printv(init_func_def, "scheme_add_global(\"", proc_name,
|
||||
"\", scheme_make_prim_w_arity(", wname,
|
||||
", \"", proc_name, "\", ", numargs, ", ", numargs,
|
||||
"), env);\n",
|
||||
0);
|
||||
*/
|
||||
|
||||
Printf(init_func_def,"scheme_add_global(\"%s\", scheme_make_prim_w_arity(%s, \"%s\", %d, %d), env);\n",
|
||||
proc_name, wname, proc_name, numargs, numargs);
|
||||
", \"", proc_name, "\", ", temp, ", ", temp,
|
||||
"), env);\n",0);
|
||||
|
||||
Delete(proc_name);
|
||||
Delete(source);
|
||||
Delete(target);
|
||||
Delete(argnum);
|
||||
Delete(arg);
|
||||
Delete(outarg);
|
||||
Delete(cleanup);
|
||||
Delete(build);
|
||||
DelWrapper(f);
|
||||
}
|
||||
|
||||
// -----------------------------------------------------------------------
|
||||
// MZSCHEME::link_variable(char *name, char *iname, DataType *d)
|
||||
// MZSCHEME::link_variable(char *name, char *iname, SwigType *d)
|
||||
//
|
||||
// Create a link to a C variable.
|
||||
// This creates a single function _wrap_swig_var_varname().
|
||||
|
|
@ -488,27 +487,28 @@ MZSCHEME::create_function (char *name, char *iname, DataType *d, ParmList *l)
|
|||
// -----------------------------------------------------------------------
|
||||
|
||||
void
|
||||
MZSCHEME::link_variable (char *name, char *iname, DataType *t)
|
||||
MZSCHEME::link_variable (char *name, char *iname, SwigType *t)
|
||||
{
|
||||
DOHString *proc_name;
|
||||
String *proc_name = NewString("");
|
||||
char var_name[256];
|
||||
char *tm;
|
||||
char *argnum = "0";
|
||||
char *arg = "argv[0]";
|
||||
String *tm2 = NewString("");;
|
||||
String *argnum = NewString("0");
|
||||
String *arg = NewString("argv[0]");
|
||||
|
||||
// evaluation function names
|
||||
|
||||
sprintf (var_name, "_wrap_%svar_%s", prefix, iname);
|
||||
|
||||
// Build the name for scheme.
|
||||
proc_name = NewString(iname);
|
||||
Replace(proc_name,"_","-",DOH_REPLACE_ANY);
|
||||
Printv(proc_name, iname,0);
|
||||
Replace(proc_name, "_", "-", DOH_REPLACE_ANY);
|
||||
|
||||
if (DataType_type(t) != T_USER) {
|
||||
if ((SwigType_type(t) != T_USER) || (SwigType_ispointer(t))) {
|
||||
|
||||
Printf (f_wrappers, "static Scheme_Object *%s(int argc, Scheme_Object** argv) {\n", var_name);
|
||||
|
||||
if ((DataType_type(t) == T_CHAR) || (DataType_type(t) == T_POINTER) || (DataType_type(t) == T_ARRAY) || (DataType_type(t) == T_REFERENCE)) {
|
||||
if ((SwigType_type(t) == T_CHAR) || (SwigType_ispointer(t))){
|
||||
Printf (f_wrappers, "\t char *_temp, _ptemp[128];\n");
|
||||
Printf (f_wrappers, "\t int _len;\n");
|
||||
}
|
||||
|
|
@ -520,35 +520,34 @@ MZSCHEME::link_variable (char *name, char *iname, DataType *t)
|
|||
|
||||
// Yup. Extract the type from argv[0] and set variable value
|
||||
|
||||
// if (Status & STAT_READONLY) {
|
||||
// Printf (f_wrappers, "\t\t GSWIG_ASSERT(0,\"Unable to set %s. "
|
||||
// "Variable is read only.\", argv[0]);\n", iname);
|
||||
// }
|
||||
// if (Status & STAT_READONLY) {
|
||||
// Printf (f_wrappers, "\t\t GSWIG_ASSERT(0,\"Unable to set %s. "
|
||||
// "Variable is read only.\", argv[0]);\n", iname);
|
||||
// }
|
||||
if (Status & STAT_READONLY) {
|
||||
Printf (f_wrappers, "\t\t scheme_signal_error(\"Unable to set %s. "
|
||||
"Variable is read only.\");\n", iname);
|
||||
"Variable is read only.\");\n", iname);
|
||||
}
|
||||
else if ((tm = typemap_lookup ((char*)"varin", typemap_lang,
|
||||
t, name, (char*)"argv[0]", name))) {
|
||||
DOHString *tm2 = NewString(tm);
|
||||
else if ((tm = Swig_typemap_lookup ((char*)"varin",
|
||||
t, name, (char*)"argv[0]", name,0))) {
|
||||
Printv(tm2, tm,0);
|
||||
mreplace(tm2, argnum, arg, proc_name);
|
||||
Printf(f_wrappers, "%s\n", tm2);
|
||||
Delete(tm2);
|
||||
Printv(f_wrappers, tm2, "\n",0);
|
||||
}
|
||||
else if (DataType_is_pointer(t)) {
|
||||
if (DataType_type(t) == T_STRING) {
|
||||
Printf (f_wrappers, "\t\t _temp = SCHEME_STR_VAL(argv[0]);\n");
|
||||
Printf (f_wrappers, "\t\t _len = SCHEME_STRLEN_VAL(argv[0]);\n");
|
||||
Printf (f_wrappers, "\t\t if (%s) { free(%s);}\n", name, name);
|
||||
Printf (f_wrappers, "\t\t %s = (char *) "
|
||||
"malloc((_len+1)*sizeof(char));\n", name);
|
||||
Printf (f_wrappers, "\t\t strncpy(%s,_temp,_len);\n", name);
|
||||
else if (SwigType_ispointer(t)) {
|
||||
if ((SwigType_type(t) == T_CHAR) && (SwigType_ispointer(t) == 1)) {
|
||||
Printf (f_wrappers, "\t\t _temp = SCHEME_STR_VAL(argv[0]);\n");
|
||||
Printf (f_wrappers, "\t\t _len = SCHEME_STRLEN_VAL(argv[0]);\n");
|
||||
Printf (f_wrappers, "\t\t if (%s) { free(%s);}\n", name, name);
|
||||
Printf (f_wrappers, "\t\t %s = (char *) "
|
||||
"malloc((_len+1)*sizeof(char));\n", name);
|
||||
Printf (f_wrappers, "\t\t strncpy(%s,_temp,_len);\n", name);
|
||||
} else {
|
||||
// Set the value of a pointer
|
||||
Printf(f_wrappers, "\t\tif (!swig_get_c_pointer(argv[0], \"%s\", (void **) &_arg0))\n",
|
||||
DataType_manglestr(t));
|
||||
// Set the value of a pointer
|
||||
Printf(f_wrappers, "\t\tif (!swig_get_c_pointer(argv[0], \"%s\", (void **) &arg0))\n",
|
||||
SwigType_manglestr(t));
|
||||
Printf(f_wrappers, "\t\t\tscheme_wrong_type(\"%s\", %s, 0, argc, argv", \
|
||||
var_name, DataType_manglestr(t));
|
||||
var_name, SwigType_manglestr(t));
|
||||
}
|
||||
}
|
||||
else {
|
||||
|
|
@ -559,17 +558,17 @@ MZSCHEME::link_variable (char *name, char *iname, DataType *t)
|
|||
// Now return the value of the variable (regardless
|
||||
// of evaluating or setting)
|
||||
|
||||
if ((tm = typemap_lookup ((char*)"varout", typemap_lang,
|
||||
t, name, name, (char*)"swig_result"))) {
|
||||
if ((tm = Swig_typemap_lookup ((char*)"varout",
|
||||
t, name, name, (char*)"swig_result",0))) {
|
||||
Printf (f_wrappers, "%s\n", tm);
|
||||
}
|
||||
else if (DataType_is_pointer(t)) {
|
||||
if (DataType_type(t) == T_STRING) {
|
||||
Printf (f_wrappers, "\t swig_result = scheme_make_string(%s);\n", name);
|
||||
else if (SwigType_ispointer(t)) {
|
||||
if ((SwigType_type(t) == T_CHAR) && (SwigType_ispointer(t) == 1)) {
|
||||
Printf (f_wrappers, "\t swig_result = scheme_make_string(%s);\n", name);
|
||||
} else {
|
||||
// Is an ordinary pointer type.
|
||||
// Is an ordinary pointer type.
|
||||
Printf(f_wrappers, "\tswig_result = swig_make_c_pointer(%s, \"%s\");\n",
|
||||
name, DataType_manglestr(t));
|
||||
name, SwigType_manglestr(t));
|
||||
}
|
||||
}
|
||||
else {
|
||||
|
|
@ -581,33 +580,44 @@ MZSCHEME::link_variable (char *name, char *iname, DataType *t)
|
|||
// Now add symbol to the MzScheme interpreter
|
||||
|
||||
Printv(init_func_def,
|
||||
"scheme_add_global(\"", proc_name,
|
||||
"\", scheme_make_prim_w_arity(", var_name,
|
||||
", \"", proc_name, "\", 0, 1), env);\n",
|
||||
0);
|
||||
"scheme_add_global(\"",
|
||||
proc_name,
|
||||
"\", scheme_make_prim_w_arity(",
|
||||
var_name,
|
||||
", \"",
|
||||
proc_name,
|
||||
"\", ",
|
||||
"0",
|
||||
", ",
|
||||
"1",
|
||||
"), env);\n",0);
|
||||
|
||||
} else {
|
||||
Printf (stderr, "%s : Line %d. ** Warning. Unable to link with "
|
||||
" type %s (ignored).\n",
|
||||
input_file, line_number, DataType_str(t,0));
|
||||
" type %s (ignored).\n",
|
||||
input_file, line_number, SwigType_manglestr(t));
|
||||
}
|
||||
Delete(proc_name);
|
||||
Delete(argnum);
|
||||
Delete(arg);
|
||||
Delete(tm2);
|
||||
}
|
||||
|
||||
// -----------------------------------------------------------------------
|
||||
// MZSCHEME::declare_const(char *name, char *iname, DataType *type, char *value)
|
||||
// MZSCHEME::declare_const(char *name, char *iname, SwigType *type, char *value)
|
||||
//
|
||||
// Makes a constant. Not sure how this is really supposed to work.
|
||||
// I'm going to fake out SWIG and create a variable instead.
|
||||
// ------------------------------------------------------------------------
|
||||
|
||||
void
|
||||
MZSCHEME::declare_const (char *name, char *, DataType *type, char *value)
|
||||
MZSCHEME::declare_const (char *name, char *, SwigType *type, char *value)
|
||||
{
|
||||
int OldStatus = Status; // Save old status flags
|
||||
DOHString *proc_name;
|
||||
char var_name[256];
|
||||
DOHString *rvalue;
|
||||
String *proc_name = NewString("");
|
||||
String *rvalue = NewString("");
|
||||
String *temp = NewString("");
|
||||
char *tm;
|
||||
|
||||
Status = STAT_READONLY; // Enable readonly mode.
|
||||
|
|
@ -617,33 +627,38 @@ MZSCHEME::declare_const (char *name, char *, DataType *type, char *value)
|
|||
sprintf (var_name, "_wrap_const_%s", name);
|
||||
|
||||
// Build the name for scheme.
|
||||
proc_name = NewString(name);
|
||||
Replace(proc_name,"_","-",DOH_REPLACE_ANY);
|
||||
Printv(proc_name, name,0);
|
||||
Replace(proc_name, "_", "-", DOH_REPLACE_ANY);
|
||||
|
||||
if (DataType_type(type) == T_USER) {
|
||||
Printf (stderr, "%s : Line %d. Unsupported constant value.\n",
|
||||
input_file, line_number);
|
||||
if ((SwigType_type(type) == T_USER) && (!SwigType_ispointer(type))) {
|
||||
fprintf (stderr, "%s : Line %d. Unsupported constant value.\n",
|
||||
input_file, line_number);
|
||||
return;
|
||||
}
|
||||
|
||||
// See if there's a typemap
|
||||
rvalue = NewString(value);
|
||||
if (DataType_type(type) == T_STRING) {
|
||||
rvalue = NewStringf("\"%s\"", value);
|
||||
} else if (DataType_type(type) == T_CHAR) {
|
||||
rvalue = NewStringf("\'%s\'", value);
|
||||
} else {
|
||||
rvalue = NewString(value);
|
||||
|
||||
Printv(rvalue, value,0);
|
||||
if ((SwigType_type(type) == T_CHAR) && (SwigType_ispointer(type) == 1)) {
|
||||
temp = Copy(rvalue);
|
||||
Clear(rvalue);
|
||||
Printv(rvalue, "\"", temp, "\"",0);
|
||||
}
|
||||
if ((tm = typemap_lookup ((char*)"const", typemap_lang, type, name,
|
||||
Char(rvalue), name))) {
|
||||
if ((SwigType_type(type) == T_CHAR) && (SwigType_ispointer(type) == 0)) {
|
||||
Delete(temp);
|
||||
temp = Copy(rvalue);
|
||||
Clear(rvalue);
|
||||
Printv(rvalue, "'", temp, "'",0);
|
||||
}
|
||||
if ((tm = Swig_typemap_lookup ((char*)"const", type, name,
|
||||
rvalue, name,0))) {
|
||||
// Yep. Use it instead of the default
|
||||
Printf (f_init, "%s\n", tm);
|
||||
} else {
|
||||
// Create variable and assign it a value
|
||||
|
||||
Printf (f_header, "static %s %s = ", DataType_lstr(type,0), var_name);
|
||||
if ((DataType_type(type) == T_CHAR) || (DataType_type(type) == T_STRING)) {
|
||||
Printf (f_header, "static %s %s = ", SwigType_str(type,0), var_name);
|
||||
if ((SwigType_type(type) == T_CHAR) && (SwigType_ispointer(type) <= 1)) {
|
||||
Printf (f_header, "\"%s\";\n", value);
|
||||
} else {
|
||||
Printf (f_header, "%s;\n", value);
|
||||
|
|
@ -654,33 +669,37 @@ MZSCHEME::declare_const (char *name, char *, DataType *type, char *value)
|
|||
link_variable (var_name, name, type);
|
||||
Status = OldStatus;
|
||||
}
|
||||
Delete(proc_name);
|
||||
Delete(rvalue);
|
||||
Delete(temp);
|
||||
}
|
||||
|
||||
// ----------------------------------------------------------------------
|
||||
// MZSCHEME::usage_var(char *iname, DataType *t, String &usage)
|
||||
// MZSCHEME::usage_var(char *iname, SwigType *t, String &usage)
|
||||
//
|
||||
// Produces a usage string for a MzScheme variable.
|
||||
// ----------------------------------------------------------------------
|
||||
|
||||
void
|
||||
MZSCHEME::usage_var (char *iname, DataType *t, DOHString *usage)
|
||||
MZSCHEME::usage_var (char *iname, SwigType *t, String *usage)
|
||||
{
|
||||
Printv(usage, "(", iname, " [value])", 0);
|
||||
if (DataType_type(t) == T_USER) {
|
||||
Printf(usage," - unsupported");
|
||||
}
|
||||
// char temp[1024], *c;
|
||||
|
||||
// usage << "(" << iname << " [value])";
|
||||
// if (!((t->type != T_USER) || (t->is_pointer))) {
|
||||
// usage << " - unsupported";
|
||||
// }
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// MZSCHEME::usage_func(char *iname, DataType *t, ParmList *l, String &usage)
|
||||
// MZSCHEME::usage_func(char *iname, SwigType *t, ParmList *l, String &usage)
|
||||
//
|
||||
// Produces a usage string for a function in MzScheme
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
void
|
||||
MZSCHEME::usage_func (char *iname, DataType *d, ParmList *l, DOHString *usage)
|
||||
MZSCHEME::usage_func (char *iname, SwigType *d, ParmList *l, DOHString *usage)
|
||||
{
|
||||
|
||||
Parm *p;
|
||||
|
||||
// Print the function name.
|
||||
|
|
@ -690,44 +709,44 @@ MZSCHEME::usage_func (char *iname, DataType *d, ParmList *l, DOHString *usage)
|
|||
// Now go through and print parameters
|
||||
|
||||
for (p = l; p != 0; p = Getnext(p)) {
|
||||
DataType *pt = Gettype(p);
|
||||
char *pn = Getname(p);
|
||||
SwigType *pt = Gettype(p);
|
||||
String *pn = Getname(p);
|
||||
|
||||
if (Getignore(p))
|
||||
continue;
|
||||
|
||||
// Print the type. If the parameter has been named, use that as well.
|
||||
|
||||
if (DataType_type(pt) != T_VOID) {
|
||||
if (SwigType_type(pt) != T_VOID) {
|
||||
|
||||
// Print the type.
|
||||
Printv(usage," <", DataType_Getname(pt), 0);
|
||||
if (DataType_is_pointer(pt)) {
|
||||
/* for (int j = 0; j < (pt->is_pointer - pt->implicit_ptr); j++) { */
|
||||
for (int j = 0; j < DataType_is_pointer(pt); j++) {
|
||||
Printv(usage," <", Getname(pt), 0);
|
||||
if (SwigType_ispointer(pt)) {
|
||||
for (int j = 0; j < SwigType_ispointer(pt); j++) {
|
||||
Putc('*', usage);
|
||||
}
|
||||
}
|
||||
Putc('>',usage);
|
||||
|
||||
// Print the name if it exists.
|
||||
if (strlen (pn) > 0) {
|
||||
if (strlen (Char(pn)) > 0) {
|
||||
Printv(usage," ", pn, 0);
|
||||
}
|
||||
}
|
||||
Delete(pn);
|
||||
}
|
||||
Putc(')',usage);
|
||||
}
|
||||
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// MZSCHEME::usage_returns(char *iname, DataType *t, ParmList *l, String &usage)
|
||||
// MZSCHEME::usage_returns(char *iname, SwigType *t, ParmList *l, String &usage)
|
||||
//
|
||||
// Produces a usage string for a function in MzScheme
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
void
|
||||
MZSCHEME::usage_returns (char *iname, DataType *d, ParmList *l, DOHString *usage)
|
||||
MZSCHEME::usage_returns (char *iname, SwigType *d, ParmList *l, DOHString *usage)
|
||||
{
|
||||
Parm *p;
|
||||
DOHString *param;
|
||||
|
|
@ -741,37 +760,37 @@ MZSCHEME::usage_returns (char *iname, DataType *d, ParmList *l, DOHString *usage
|
|||
// go through and see if any are output.
|
||||
|
||||
for (p = l; p != 0; p = Getnext(p)) {
|
||||
DataType *pt = Gettype(p);
|
||||
char *pn = Getname(p);
|
||||
SwigType *pt = Gettype(p);
|
||||
String *pn = Getname(p);
|
||||
|
||||
if (strcmp (pn,"BOTH") && strcmp (pn,"OUTPUT"))
|
||||
if (strcmp (Char(pn),"BOTH") && strcmp (Char(pn),"OUTPUT"))
|
||||
continue;
|
||||
|
||||
// Print the type. If the parameter has been named, use that as well.
|
||||
|
||||
if (DataType_type(pt) != T_VOID) {
|
||||
if (SwigType_type(pt) != T_VOID) {
|
||||
++have_param;
|
||||
|
||||
// Print the type.
|
||||
Printv(param," $",DataType_Getname(pt), 0);
|
||||
if (DataType_is_pointer(pt)) {
|
||||
/* for (j = 0; j < (pt->is_pointer - pt->implicit_ptr - 1); j++) {*/
|
||||
for (j = 0; j < DataType_is_pointer(pt) - 1; j++) {
|
||||
Printv(param," $", Getname(pt), 0);
|
||||
if (SwigType_ispointer(pt)) {
|
||||
for (j = 0; j < SwigType_ispointer(pt) - 1; j++) {
|
||||
Putc('*',param);
|
||||
}
|
||||
}
|
||||
Printf(param,"# ");
|
||||
}
|
||||
Delete(pn);
|
||||
}
|
||||
|
||||
// See if we stick on the function return type.
|
||||
if (DataType_type(d) != T_VOID || have_param == 0) {
|
||||
if (SwigType_type(d) != T_VOID || have_param == 0) {
|
||||
++have_param;
|
||||
if (DataType_type(d) == T_VOID)
|
||||
if (SwigType_type(d) == T_VOID)
|
||||
Insert(param,0," unspecified");
|
||||
else {
|
||||
Insert(param,0,"# ");
|
||||
Insert(param,0,DataType_str(d,0));
|
||||
Insert(param,0,SwigType_str(d,0));
|
||||
Insert(param,0," $");
|
||||
}
|
||||
}
|
||||
|
|
@ -793,13 +812,13 @@ MZSCHEME::usage_returns (char *iname, DataType *d, ParmList *l, DOHString *usage
|
|||
|
||||
|
||||
// ----------------------------------------------------------------------
|
||||
// MZSCHEME::usage_const(char *iname, DataType *type, char *value, String &usage)
|
||||
// MZSCHEME::usage_const(char *iname, SwigType *type, char *value, String &usage)
|
||||
//
|
||||
// Produces a usage string for a MzScheme constant
|
||||
// ----------------------------------------------------------------------
|
||||
|
||||
void
|
||||
MZSCHEME::usage_const (char *iname, DataType *, char *value, DOHString *usage)
|
||||
MZSCHEME::usage_const (char *iname, SwigType *, char *value, DOHString *usage)
|
||||
{
|
||||
Printv(usage,"(", iname, " ", value, ")", 0);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -34,8 +34,8 @@ static char cvsroot[] = "$Header$";
|
|||
#include "guile.h"
|
||||
#ifdef OLD
|
||||
#include "java.h"
|
||||
#include "mzscheme.h"
|
||||
#endif
|
||||
#include "mzscheme.h"
|
||||
#include "ruby.h"
|
||||
|
||||
#include <ctype.h>
|
||||
|
|
@ -92,10 +92,10 @@ int main(int argc, char **argv) {
|
|||
} else if (strcmp(argv[i],"-java") == 0) {
|
||||
dl = new JAVA;
|
||||
Swig_mark_arg(i);
|
||||
#endif
|
||||
} else if (strcmp(argv[i],"-mzscheme") == 0) {
|
||||
dl = new MZSCHEME;
|
||||
Swig_mark_arg(i);
|
||||
#endif
|
||||
} else if (strcmp(argv[i],"-ruby") == 0) {
|
||||
dl = new RUBY;
|
||||
Swig_mark_arg(i);
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue