Initial revision

1 files changed, 2177 insertions, 0 deletions

diff --git a/Modules/flmodule.c b/Modules/flmodule.c
new file mode 100644
index 0000000..4411d87
--- /dev/null
+++ b/Modules/flmodule.c
@@ -0,0 +1,2177 @@
+/**********************************************************
+Copyright 1991 by Stichting Mathematisch Centrum, Amsterdam, The
+Netherlands.
+
+                        All Rights Reserved
+
+Permission to use, copy, modify, and distribute this software and its 
+documentation for any purpose and without fee is hereby granted, 
+provided that the above copyright notice appear in all copies and that
+both that copyright notice and this permission notice appear in 
+supporting documentation, and that the names of Stichting Mathematisch
+Centrum or CWI not be used in advertising or publicity pertaining to
+distribution of the software without specific, written prior permission.
+
+STICHTING MATHEMATISCH CENTRUM DISCLAIMS ALL WARRANTIES WITH REGARD TO
+THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS, IN NO EVENT SHALL STICHTING MATHEMATISCH CENTRUM BE LIABLE
+FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
+OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
+******************************************************************/
+
+/* FL module -- interface to Mark Overmars' FORMS Library. */
+
+#include "forms.h"
+
+#include "allobjects.h"
+#include "import.h"
+#include "modsupport.h"
+#include "structmember.h"
+
+/* #include "ceval.h" */
+extern object *call_object(object *, object *);
+
+/* Generic Forms Objects */
+
+typedef struct {
+	OB_HEAD
+	FL_OBJECT *ob_generic;
+	struct methodlist *ob_methods;
+	object *ob_callback;
+	object *ob_callback_arg;
+} genericobject;
+
+/* List of all objects (later this should be a hash table on address...) */
+
+static object *allgenerics = NULL;
+
+static void
+knowgeneric(g)
+	genericobject *g;
+{
+	if (allgenerics == NULL) {
+		allgenerics = newlistobject(0);
+		if (allgenerics == NULL) {
+			err_clear();
+			return; /* Botte pech */
+		}
+	}
+	addlistitem(allgenerics, (object *)g);
+}
+
+static genericobject *
+findgeneric(generic)
+	FL_OBJECT *generic;
+{
+	int i, n;
+	genericobject *g;
+	
+	if (allgenerics == NULL)
+		return NULL; /* Botte pech */
+	n = getlistsize(allgenerics);
+	for (i = 0; i < n; i++) {
+		g = (genericobject *)getlistitem(allgenerics, i);
+		if (g->ob_generic == generic)
+			return g;
+	}
+	return NULL; /* Unknown object */
+}
+
+
+/* Methods of generic objects */
+
+static object *
+generic_set_call_back(g, args)
+	genericobject *g;
+	object *args;
+{
+	if (args == NULL) {
+		XDECREF(g->ob_callback);
+		XDECREF(g->ob_callback_arg);
+		g->ob_callback = NULL;
+		g->ob_callback_arg = NULL;
+	}
+	else {
+		if (!is_tupleobject(args) || gettuplesize(args) != 2) {
+			err_badarg();
+			return NULL;
+		}
+		XDECREF(g->ob_callback);
+		XDECREF(g->ob_callback_arg);
+		g->ob_callback = gettupleitem(args, 0);
+		INCREF(g->ob_callback);
+		g->ob_callback_arg = gettupleitem(args, 1);
+		INCREF(g->ob_callback_arg);
+	}
+	INCREF(None);
+	return None;
+}
+
+static object *
+generic_call(g, args, func)
+	genericobject *g;
+	object *args;
+	void (*func)(FL_OBJECT *);
+{
+	if (!getnoarg(args))
+		return NULL;
+	(*func)(g->ob_generic);
+	INCREF(None);
+	return None;
+}
+
+static object *
+generic_show_object(g, args)
+	genericobject *g;
+	object *args;
+{
+	return generic_call(g, args, fl_show_object);
+}
+
+static object *
+generic_hide_object(g, args)
+	genericobject *g;
+	object *args;
+{
+	return generic_call(g, args, fl_hide_object);
+}
+
+static object *
+generic_redraw_object(g, args)
+	genericobject *g;
+	object *args;
+{
+	return generic_call(g, args, fl_redraw_object);
+}
+
+static object *
+generic_freeze_object(g, args)
+	genericobject *g;
+	object *args;
+{
+	return generic_call(g, args, fl_freeze_object);
+}
+
+static object *
+generic_unfreeze_object(g, args)
+	genericobject *g;
+	object *args;
+{
+	return generic_call(g, args, fl_unfreeze_object);
+}
+
+static struct methodlist generic_methods[] = {
+	{"set_call_back",	generic_set_call_back},
+	{"show_object",		generic_show_object},
+	{"hide_object",		generic_hide_object},
+	{"redraw_object",	generic_redraw_object},
+	{"freeze_object",	generic_freeze_object},
+	{"unfreeze_object",	generic_unfreeze_object},
+#if 0
+	{"handle_object",	generic_handle_object},
+	{"handle_object_direct",generic_handle_object_direct},
+#endif
+  {NULL,			NULL}		/* sentinel */
+};
+
+static void
+generic_dealloc(g)
+	genericobject *g;
+{
+	/* XXX can't destroy forms objects !!! */
+	DEL(g);
+}
+
+#define OFF(x) offsetof(FL_OBJECT, x)
+
+static struct memberlist generic_memberlist[] = {
+	{"objclass",	T_INT,		OFF(objclass),	RO},
+	{"type",	T_INT,		OFF(type),	RO},
+	{"boxtype",	T_INT,		OFF(boxtype)},
+	{"x",		T_FLOAT,	OFF(x)},
+	{"y",		T_FLOAT,	OFF(y)},
+	{"w",		T_FLOAT,	OFF(w)},
+	{"h",		T_FLOAT,	OFF(h)},
+	{"col1",	T_INT,		OFF(col1)},
+	{"col2",	T_INT,		OFF(col2)},
+	{"align",	T_INT,		OFF(align)},
+	{"lcol",	T_INT,		OFF(lcol)},
+	{"lsize",	T_FLOAT,	OFF(lsize)},
+	/* "label" is treated specially! */
+	{"lstyle",	T_INT,		OFF(lstyle)},
+	{"pushed",	T_INT,		OFF(pushed),	RO},
+	{"focus",	T_INT,		OFF(focus),	RO},
+	{"belowmouse",	T_INT,		OFF(belowmouse),RO},
+	{"frozen",	T_INT,		OFF(frozen),	RO},
+	{"active",	T_INT,		OFF(active),	RO},
+	{"input",	T_INT,		OFF(input),	RO},
+	{"visible",	T_INT,		OFF(visible),	RO},
+	{"radio",	T_INT,		OFF(radio),	RO},
+	{"automatic",	T_INT,		OFF(automatic),	RO},
+	{NULL}	/* Sentinel */
+};
+
+static object *
+generic_getattr(g, name)
+	genericobject *g;
+	char *name;
+{
+	object *meth;
+	
+	if (g-> ob_methods) {
+	  meth = findmethod(g->ob_methods, (object *)g, name);
+	  if (meth != NULL) return meth;
+	  err_clear();
+        }
+
+	meth = findmethod(generic_methods, (object *)g, name);
+	if (meth != NULL)
+		return meth;
+	err_clear();
+
+	/* "label" is an exception, getmember only works for char pointers,
+	   not for char arrays */
+	if (strcmp(name, "label") == 0)
+		return newstringobject(g->ob_generic->label);
+
+	return getmember((char *)g->ob_generic, generic_memberlist, name);
+}
+
+static int
+generic_setattr(g, name, v)
+	genericobject *g;
+	char *name;
+	object *v;
+{
+	int ret;
+
+	if (v == NULL) {
+		err_setstr(TypeError, "can't delete forms object attributes");
+		return NULL;
+	}
+
+	/* "label" is an exception: setmember doesn't set strings;
+	   and FORMS wants you to call a function to set the label */
+	if (strcmp(name, "label") == 0) {
+		if (!is_stringobject(v)) {
+			err_setstr(TypeError, "label attr must be string");
+			return NULL;
+		}
+		fl_set_object_label(g->ob_generic, getstringvalue(v));
+		return 0;
+	}
+
+	ret = setmember((char *)g->ob_generic, generic_memberlist, name, v);
+
+	/* Rather than calling all the various set_object_* functions,
+	   we call fl_redraw_object here.  This is sometimes redundant
+	   but I doubt that's a big problem */
+	if (ret == 0)
+		fl_redraw_object(g->ob_generic);
+
+	return ret;
+}
+
+typeobject GenericObjecttype = {
+	OB_HEAD_INIT(&Typetype)
+	0,			/*ob_size*/
+	"generic FORMS object",	/*tp_name*/
+	sizeof(genericobject),	/*tp_size*/
+	0,			/*tp_itemsize*/
+	/* methods */
+	generic_dealloc,	/*tp_dealloc*/
+	0,			/*tp_print*/
+	generic_getattr,	/*tp_getattr*/
+	generic_setattr,	/*tp_setattr*/
+	0,			/*tp_compare*/
+	0,			/*tp_repr*/
+};
+
+static object *
+newgenericobject(generic, methods)
+	FL_OBJECT *generic;
+	struct methodlist *methods;
+{
+	genericobject *g;
+	g = NEWOBJ(genericobject, &GenericObjecttype);
+	if (g == NULL)
+		return NULL;
+	g-> ob_generic = generic;
+	g->ob_methods = methods;
+	g->ob_callback = NULL;
+	g->ob_callback_arg = NULL;
+	knowgeneric(g);
+	return (object *)g;
+}
+
+/**********************************************************************/
+/* Some common calling sequences */
+
+/* void func (object, float) */
+static object *
+call_forms_INf (func, obj, args)
+     void *(*func)(FL_OBJECT *, float);
+     FL_OBJECT *obj;
+     object *args;
+{
+     float parameter;
+
+     if (!getfloatarg (args, &parameter)) return NULL;
+
+     (*func) (obj, parameter);
+
+     INCREF(None);
+     return None;
+}
+
+/* void func (object, float) */
+static object *
+call_forms_INfINf (func, obj, args)
+     void *(*func)(FL_OBJECT *, float, float);
+     FL_OBJECT *obj;
+     object *args;
+{
+     float par1, par2;
+
+     if (!getfloatfloatarg (args, &par1, &par2)) return NULL;
+
+     (*func) (obj, par1, par2);
+
+     INCREF(None);
+     return None;
+}
+
+/* void func (object, int) */
+static object *
+call_forms_INi (func, obj, args)
+     void *(*func)(FL_OBJECT *, int);
+     FL_OBJECT *obj;
+     object *args;
+{
+     int parameter;
+
+     if (!getintarg (args, &parameter)) return NULL;
+
+     (*func) (obj, parameter);
+
+     INCREF(None);
+     return None;
+}
+
+/* void func (object, string) */
+static object *
+call_forms_INstr (func, obj, args)
+     void *(*func)(FL_OBJECT *, char *);
+     FL_OBJECT *obj;
+     object *args;
+{  
+     object *a;
+     
+     if (!getstrarg (args, &a)) return NULL;
+
+     (*func) (obj, getstringvalue (a));
+
+     INCREF(None);
+     return None;
+}
+
+
+/* voide func (object, int, string) */
+static object *
+call_forms_INiINstr (func, obj, args)
+     void *(*func)(FL_OBJECT *, int, char *);
+     FL_OBJECT *obj;
+     object *args;
+
+{
+     object *a;
+     int b;
+     
+     if (!getintstrarg (args, &b, &a)) return NULL;
+
+     (*func) (obj, b, getstringvalue (a));
+
+     INCREF(None);
+     return None;
+}
+
+/* void func (object, float) */
+static object *
+call_forms_INiINi (func, obj, args)
+     void *(*func)(FL_OBJECT *, float, float);
+     FL_OBJECT *obj;
+     object *args;
+{
+     int par1, par2;
+
+     if (!getintintarg (args, &par1, &par2)) return NULL;
+
+     (*func) (obj, par1, par2);
+
+     INCREF(None);
+     return None;
+}
+
+/* int func (object) */
+static object *
+call_forms_Ri (func, obj, args)
+     int (*func)(FL_OBJECT *);
+     FL_OBJECT *obj;
+     object *args;
+{
+     int retval;
+
+     if (!getnoarg(args)) return NULL;
+
+     retval = (*func) (obj);
+
+     return newintobject ((long) retval);
+}
+
+/* char * func (object) */
+static object *
+call_forms_Rstr (func, obj, args)
+     char * (*func)(FL_OBJECT *);
+     FL_OBJECT *obj;
+     object *args;
+{  
+     char *str;
+     
+     if (!getnoarg (args)) return NULL;
+
+     str = (*func) (obj);
+
+     return newstringobject (str);
+}
+
+/* int func (object) */
+static object *
+call_forms_Rf (func, obj, args)
+     float (*func)(FL_OBJECT *);
+     FL_OBJECT *obj;
+     object *args;
+{
+     float retval;
+
+     if (!getnoarg(args)) return NULL;
+
+     retval = (*func) (obj);
+
+     return newfloatobject (retval);
+}
+
+static object *
+call_forms_OUTfOUTf (func, obj, args)
+        void *(*func)(FL_OBJECT *, float *, float *);
+	FL_OBJECT *obj;
+	object *args;
+{
+        float f1, f2;
+	object *arg;
+
+        if (!getnoarg(args)) return NULL;
+
+	(*func) (obj, &f1, &f2);
+	
+	arg = newtupleobject (2);
+	if (arg == NULL) return NULL;
+
+	settupleitem (arg, 0, newfloatobject (f1));
+	settupleitem (arg, 1, newfloatobject (f2));
+	return arg;
+}
+
+static object *
+call_forms_OUTf (func, obj, args)
+        void *(*func)(FL_OBJECT *, float *);
+	FL_OBJECT *obj;
+	object *args;
+{
+        float f;
+	object *arg;
+
+        if (!getnoarg(args)) return NULL;
+
+	(*func) (obj, &f);
+
+	return newfloatobject (f);
+}
+
+/**********************************************************************/
+/* Class : browser */
+
+static object *
+set_browser_topline(g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INi (fl_set_browser_topline, g-> ob_generic, args);
+}
+
+static object *
+clear_browser(g, args)
+	genericobject *g;
+	object *args;
+{
+  return generic_call (g, args, fl_clear_browser);
+}
+
+static object *
+add_browser_line (g, args)
+     genericobject *g;
+     object *args;
+{
+  return call_forms_INstr (fl_add_browser_line, g-> ob_generic, args);
+}
+
+static object *
+addto_browser (g, args)
+     genericobject *g;
+     object *args;
+{
+  return call_forms_INstr (fl_addto_browser, g-> ob_generic, args);
+}
+
+static object *
+insert_browser_line (g, args)
+     genericobject *g;
+     object *args;
+{
+  return call_forms_INiINstr (fl_insert_browser_line, g-> ob_generic, args);
+}
+
+static object *
+delete_browser_line (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INi (fl_delete_browser_line, g-> ob_generic, args);
+}
+
+static object *
+replace_browser_line (g, args)
+     genericobject *g;
+     object *args;
+{
+  return call_forms_INiINstr (fl_replace_browser_line, g-> ob_generic, args);
+}
+
+static object *
+get_browser_line(g, args)
+	genericobject *g;
+	object *args;
+{
+	int i;
+	char *str;
+
+	if (!getintarg(args, &i))
+		return NULL;
+
+	str = fl_get_browser_line (g->ob_generic, i);
+
+	return newstringobject (str);
+}
+
+static object *
+load_browser (g, args)
+     genericobject *g;
+     object *args;
+{
+  return call_forms_INstr (fl_load_browser, g-> ob_generic, args);
+}
+
+static object *
+get_browser_maxline(g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_Ri (fl_get_browser_maxline, g-> ob_generic, args);
+}
+
+static object *
+select_browser_line (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INi (fl_select_browser_line, g-> ob_generic, args);
+}
+
+static object *
+deselect_browser_line (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INi (fl_deselect_browser_line, g-> ob_generic, args);
+}
+
+static object *
+deselect_browser (g, args)
+	genericobject *g;
+	object *args;
+{
+  return generic_call (g, args, fl_deselect_browser);
+}
+
+static object *
+isselected_browser_line (g, args)
+     genericobject *g;
+     object *args;
+{
+	int i, j;
+	object *arg;
+
+	if (!getintarg(args, &i))
+		return NULL;
+
+	j = fl_isselected_browser_line (g->ob_generic, i);
+
+	return newintobject (j);
+}
+
+static object *
+get_browser (g, args)
+     genericobject *g;
+     object *args;
+{
+  return call_forms_Ri (fl_get_browser, g-> ob_generic, args);
+}
+
+static object *
+set_browser_fontsize (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INf (fl_set_browser_fontsize, g-> ob_generic, args);
+}
+
+static object *
+set_browser_fontstyle (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INi (fl_set_browser_fontstyle, g-> ob_generic, args);
+}
+
+static struct methodlist browser_methods[] = {
+	{"set_browser_topline",	set_browser_topline},
+	{"clear_browser",       clear_browser},
+	{"add_browser_line",    add_browser_line},
+	{"addto_browser",       addto_browser},
+	{"insert_browser_line", insert_browser_line},
+	{"delete_browser_line", delete_browser_line},
+	{"replace_browser_line",replace_browser_line},
+	{"get_browser_line",    get_browser_line},
+	{"load_browser",        load_browser},
+	{"get_browser_maxline", get_browser_maxline},
+	{"select_browser_line", select_browser_line},
+	{"deselect_browser_line",   deselect_browser_line},
+	{"deselect_browser",    deselect_browser},
+	{"isselected_browser_line", isselected_browser_line},
+	{"get_browser",         get_browser},
+	{"set_browser_fontsize",set_browser_fontsize},
+	{"set_browser_fontstyle",    set_browser_fontstyle},
+	{NULL,			NULL}		/* sentinel */
+};
+
+/* Class: button */
+
+static object *
+set_button(g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INi (fl_set_button, g-> ob_generic, args);
+}
+
+static object *
+get_button(g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_Ri (fl_get_button, g-> ob_generic, args);
+}
+
+static struct methodlist button_methods[] = {
+	{"set_button",		set_button},
+	{"get_button",		get_button},
+	{NULL,			NULL}		/* sentinel */
+};
+
+/* Class: choice */
+
+static object *
+set_choice(g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INi (fl_set_choice, g-> ob_generic, args);
+}
+
+static object *
+get_choice(g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_Ri (fl_get_choice, g-> ob_generic, args);
+}
+
+static object *
+clear_choice (g, args)
+     genericobject *g;
+     object *args;
+{
+     generic_call (g, args, fl_clear_choice);
+}
+
+static object *
+addto_choice (g, args)
+     genericobject *g;
+     object *args;
+{  
+   return call_forms_INstr (fl_addto_choice, g-> ob_generic, args);
+}
+
+static object *
+replace_choice (g, args)
+     genericobject *g;
+     object *args;
+{  
+  return call_forms_INiINstr (fl_replace_choice, g-> ob_generic, args);
+}
+
+static object *
+delete_choice (g, args)
+     genericobject *g;
+     object *args;
+{
+  return call_forms_INi (fl_delete_choice, g-> ob_generic, args);
+}
+
+static object *
+get_choice_text (g, args)
+     genericobject *g;
+     object *args;
+{  
+  return call_forms_Rstr (fl_get_choice_text, g-> ob_generic, args);
+}
+
+static object *
+set_choice_fontsize (g, args)
+     genericobject *g;
+     object *args;
+{
+  return call_forms_INf (fl_set_choice_fontsize, g-> ob_generic, args);
+}
+
+static object *
+set_choice_fontstyle (g, args)
+     genericobject *g;
+     object *args;
+{
+  return call_forms_INi (fl_set_choice_fontstyle, g-> ob_generic, args);
+}
+
+static struct methodlist choice_methods[] = {
+	{"set_choice",		set_choice},
+	{"get_choice",		get_choice},
+	{"clear_choice",	clear_choice},
+	{"addto_choice",        addto_choice},
+	{"replace_choice",      replace_choice},
+	{"delete_choice",       delete_choice},
+	{"get_choice_text",     get_choice_text},
+	{"set_choice_fontsize", set_choice_fontsize},
+	{"set_choice_fontstyle",set_choice_fontstyle},
+	{NULL,			NULL}		/* sentinel */
+};
+
+/* Class : Clock */
+
+static object *
+get_clock(g, args)
+	genericobject *g;
+	object *args;
+{
+	int i0, i1, i2;
+	object *arg;
+
+	if (!getnoarg(args))
+		return NULL;
+
+	fl_get_clock (g->ob_generic, &i0, &i1, &i2);
+
+	arg = newtupleobject (3);
+	if (arg == NULL) return NULL;
+
+	settupleitem (arg, 0, newintobject (i0));
+	settupleitem (arg, 1, newintobject (i1));
+	settupleitem (arg, 2, newintobject (i2));
+	return arg;
+}
+
+static struct methodlist clock_methods[] = {
+	{"get_clock",		get_clock},
+	{NULL,			NULL}		/* sentinel */
+};
+
+/* CLass : Counters */
+
+static object *
+get_counter_value(g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_Rf (fl_get_counter_value, g-> ob_generic, args);
+}
+
+static object *
+set_counter_value (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INf (fl_set_counter_value, g-> ob_generic, args);
+}
+
+static object *
+set_counter_precision (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INi (fl_set_counter_precision, g-> ob_generic, args);
+}
+
+static object *
+set_counter_bounds (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INfINf (fl_set_counter_bounds, g-> ob_generic, args);
+}
+
+static object *
+set_counter_step (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INfINf (fl_set_counter_step, g-> ob_generic, args);
+}
+
+static object *
+set_counter_return (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INi (fl_set_counter_return, g-> ob_generic, args);
+}
+
+static struct methodlist counter_methods[] = {
+	{"set_counter_value",          set_counter_value},
+	{"get_counter_value",	      get_counter_value},
+	{"set_counter_bounds",   set_counter_bounds},
+	{"set_counter_step",   set_counter_step},
+	{"set_counter_precision",   set_counter_precision},
+	{"set_counter_return",   set_counter_return},
+	{NULL,			NULL}		/* sentinel */
+};
+
+/* Class : Defaults */
+
+static object *
+get_default(g, args)
+	genericobject *g;
+	object *args;
+{
+  char c;
+
+  if (!getnoarg(args)) return NULL;
+
+  c = fl_get_default (g->ob_generic);
+
+  return ((object *) mknewcharobject (c));     /* in cgensupport.c */
+}
+
+static struct methodlist default_methods[] = {
+	{"get_default",	      get_default},
+	{NULL,			NULL}		/* sentinel */
+};
+
+
+/* Class: Dials */
+
+static object *
+set_dial (g, args)
+	genericobject *g;
+	object *args;
+{
+	float f1, f2, f3;
+
+	if (!getfloatfloatfloatarg(args, &f1, &f2, &f3))
+		return NULL;
+	fl_set_dial (g->ob_generic, f1, f2, f3);
+	INCREF(None);
+	return None;
+}
+
+static object *
+get_dial(g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_Rf (fl_get_dial, g-> ob_generic, args);
+}
+
+static object *
+set_dial_value (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INf (fl_set_dial_value, g-> ob_generic, args);
+}
+
+static object *
+set_dial_bounds (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INfINf (fl_set_dial_bounds, g-> ob_generic, args);
+}
+
+static object *
+get_dial_bounds (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_OUTfOUTf (fl_get_dial_bounds, g-> ob_generic, args);
+}
+
+static struct methodlist dial_methods[] = {
+	{"set_dial",          set_dial},
+	{"get_dial",	      get_dial},
+	{"set_dial_value",    set_dial_value},
+	{"get_dial_value",    get_dial},
+	{"set_dial_bounds",   set_dial_bounds},
+	{"get_dial_bounds",   get_dial_bounds},
+	{NULL,			NULL}		/* sentinel */
+};
+
+/* Class : Input */
+
+static object *
+set_input (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INstr (fl_set_input, g-> ob_generic, args);
+}
+
+static object *
+get_input (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_Rstr (fl_get_input, g-> ob_generic, args);
+}
+
+static object *
+set_input_color (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INfINf (fl_set_input_color, g-> ob_generic, args);
+}
+
+static struct methodlist input_methods[] = {
+	{"set_input",         set_input},
+	{"get_input",	      get_input},
+	{"set_input_color",   set_input_color},
+	{NULL,			NULL}		/* sentinel */
+};
+
+
+/* Class : Menu */
+
+static object *
+set_menu (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INstr (fl_set_menu, g-> ob_generic, args);
+}
+
+static object *
+get_menu (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_Ri (fl_get_menu, g-> ob_generic, args);
+}
+
+static object *
+addto_menu (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INstr (fl_addto_menu, g-> ob_generic, args);
+}
+
+static struct methodlist menu_methods[] = {
+	{"set_menu",         set_menu},
+	{"get_menu",	     get_menu},
+	{"addto_menu",       addto_menu},
+	{NULL,			NULL}		/* sentinel */
+};
+
+
+/* Class: Sliders */
+
+static object *
+set_slider (g, args)
+	genericobject *g;
+	object *args;
+{
+	float f1, f2, f3;
+
+	if (!getfloatfloatfloatarg(args, &f1, &f2, &f3))
+		return NULL;
+	fl_set_slider (g->ob_generic, f1, f2, f3);
+	INCREF(None);
+	return None;
+}
+
+static object *
+get_slider(g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_Rf (fl_get_slider, g-> ob_generic, args);
+}
+
+static object *
+set_slider_value (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INf (fl_set_slider_value, g-> ob_generic, args);
+}
+
+static object *
+set_slider_bounds (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INfINf (fl_set_slider_bounds, g-> ob_generic, args);
+}
+
+static object *
+get_slider_bounds (g, args)
+	genericobject *g;
+	object *args;
+{
+	return call_forms_OUTfOUTf(fl_get_slider_bounds, g-> ob_generic, args);
+}
+
+static object *
+set_slider_return (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INf (fl_set_slider_return, g-> ob_generic, args);
+}
+
+static object *
+set_slider_size (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INf (fl_set_slider_size, g-> ob_generic, args);
+}
+
+static object *
+set_slider_precision (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INi (fl_set_slider_precision, g-> ob_generic, args);
+}
+
+static struct methodlist slider_methods[] = {
+	{"set_slider",		set_slider},
+	{"get_slider",		get_slider},
+	{"set_slider_value",    set_slider_value},
+	{"get_slider_value",    get_slider},
+	{"set_slider_bounds",   set_slider_bounds},
+	{"get_slider_bounds",   get_slider_bounds},
+	{"set_slider_return",   set_slider_return},
+	{"set_slider_size",     set_slider_size},
+	{"set_slider_precision",set_slider_precision},
+	{NULL,			NULL}		/* sentinel */
+};
+
+static object *
+set_positioner_xvalue (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INf (fl_set_positioner_xvalue, g-> ob_generic, args);
+}
+
+static object *
+set_positioner_xbounds (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INfINf (fl_set_positioner_xbounds, g-> ob_generic, args);
+}
+
+static object *
+set_positioner_yvalue (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INf (fl_set_positioner_yvalue, g-> ob_generic, args);
+}
+
+static object *
+set_positioner_ybounds (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INfINf (fl_set_positioner_ybounds, g-> ob_generic, args);
+}
+
+static object *
+get_positioner_xvalue (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_Rf (fl_get_positioner_xvalue, g-> ob_generic, args);
+}
+
+static object *
+get_positioner_xbounds (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_OUTfOUTf (fl_get_positioner_xbounds, g-> ob_generic, args);
+}
+
+static object *
+get_positioner_yvalue (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_Rf (fl_get_positioner_yvalue, g-> ob_generic, args);
+}
+
+static object *
+get_positioner_ybounds (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_OUTfOUTf (fl_get_positioner_ybounds, g-> ob_generic, args);
+}
+
+static struct methodlist positioner_methods[] = {
+	{"set_positioner_xvalue",		set_positioner_xvalue},
+	{"set_positioner_yvalue",		set_positioner_yvalue},
+	{"set_positioner_xbounds",	 	set_positioner_xbounds},
+	{"set_positioner_ybounds",	 	set_positioner_ybounds},
+	{"get_positioner_xvalue",		get_positioner_xvalue},
+	{"get_positioner_yvalue",		get_positioner_yvalue},
+	{"get_positioner_xbounds",	 	get_positioner_xbounds},
+	{"get_positioner_ybounds",	 	set_positioner_ybounds},
+	{NULL,			NULL}		/* sentinel */
+};
+
+/* Class timer */
+
+static object *
+set_timer (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_INf (fl_set_timer, g-> ob_generic, args);
+}
+
+static object *
+get_timer (g, args)
+	genericobject *g;
+	object *args;
+{
+  return call_forms_Rf (fl_get_timer, g-> ob_generic, args);
+}
+
+static struct methodlist timer_methods[] = {
+	{"set_timer",		set_timer},
+	{"get_timer",		get_timer},
+	{NULL,			NULL}		/* sentinel */
+};
+
+/* Form objects */
+
+typedef struct {
+	OB_HEAD
+	FL_FORM *ob_form;
+} formobject;
+
+extern typeobject Formtype; /* Forward */
+
+#define is_formobject(v) ((v)->ob_type == &Formtype)
+
+static object *
+form_show_form(f, args)
+	formobject *f;
+	object *args;
+{
+	int place, border;
+	object *name;
+	if (!getintintstrarg(args, &place, &border, &name))
+		return NULL;
+	fl_show_form(f->ob_form, place, border, getstringvalue(name));
+	INCREF(None);
+	return None;
+}
+
+static object *
+form_call(func, f, args)
+	FL_FORM *f;
+	object *args;
+	void (*func)(FL_FORM *);
+{
+	if (!getnoarg(args)) return NULL;
+
+	(*func)(f);
+
+	INCREF(None);
+	return None;
+}
+
+static object *
+form_call_INiINi (func, f, args)
+	FL_FORM *f;
+	object *args;
+	void (*func)(FL_FORM *, int, int);
+{
+        int a, b;
+
+        if (!getintintarg(args, &a, &b)) return NULL;
+
+	(*func)(f, a, b);
+
+	INCREF(None);
+	return None;
+}
+
+static object *
+form_hide_form(f, args)
+	formobject *f;
+	object *args;
+{
+	return form_call (fl_hide_form, f-> ob_form, args);
+}
+
+static object *
+form_redraw_form(f, args)
+	formobject *f;
+	object *args;
+{ 
+	return form_call (fl_redraw_form, f-> ob_form, args);
+}
+
+static object *
+form_set_form_position (f, args)
+	formobject *f;
+	object *args;
+{
+  return form_call_INiINi (fl_set_form_position, f-> ob_form, args);
+}
+
+static object *
+generic_add_object (f, args, func, internal_methods)
+	formobject *f;
+	object *args;
+	FL_OBJECT *(*func)(int, float, float, float, float, char*);
+        struct methodlist *internal_methods;
+{
+  int type;
+  float x, y, w, h;
+  object *name;
+  FL_OBJECT *genobj;
+
+  if (!getintfloatfloatfloatfloatstr (args,&type,&x,&y,&w,&h,&name))
+    return NULL;
+  
+  fl_addto_form (f-> ob_form);
+  
+  genobj = (*func) (type, x, y, w, h, getstringvalue (name));
+
+  fl_end_form ();
+
+  if (genobj == NULL) { err_nomem(); return NULL; }
+
+  return newgenericobject (genobj, internal_methods);
+}
+
+static object *
+form_add_button(f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_button, button_methods);
+}
+
+static object *
+form_add_lightbutton(f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_lightbutton, button_methods);
+}
+
+static object *
+form_add_roundbutton(f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_roundbutton, button_methods);
+}
+
+static object *
+form_add_menu (f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_menu, menu_methods);
+}
+
+static object *
+form_add_slider(f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_slider, slider_methods);
+}
+
+static object *
+form_add_valslider(f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_valslider, slider_methods);
+}
+
+static object *
+form_add_dial (f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_dial, dial_methods);
+}
+
+static object *
+form_add_counter (f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_counter, counter_methods);
+}
+
+static object *
+form_add_default (f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_default, default_methods);
+}
+
+static object *
+form_add_clock (f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_clock, clock_methods);
+}
+
+static object *
+form_add_box (f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_box, NULL);
+}
+
+static object *
+form_add_choice (f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_choice, choice_methods);
+}
+
+static object *
+form_add_browser (f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_browser, browser_methods);
+}
+
+static object *
+form_add_positioner (f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_positioner, positioner_methods);
+}
+
+static object *
+form_add_input (f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_input, input_methods);
+}
+
+static object *
+form_add_text (f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_text, NULL);
+}
+
+static object *
+form_add_timer (f, args)
+     formobject *f;
+     object *args;
+{
+	return generic_add_object(f, args, fl_add_timer, timer_methods);
+}
+
+static object *
+form_show_message (f, args)
+     formobject *f;
+     object *args;
+{
+	object *a, *b, *c;
+
+        if (!getstrstrstrarg(args, &a, &b, &c)) return NULL;
+
+	fl_show_message (
+		   getstringvalue(a), getstringvalue(b), getstringvalue(c));
+
+	INCREF (None);
+	return None;
+}
+
+static object *
+form_show_question (f, args)
+     formobject *f;
+     object *args;
+{
+        int ret;
+	object *a, *b, *c;
+
+        if (!getstrstrstrarg(args, &a, &b, &c)) return NULL;
+
+	ret = fl_show_question (
+		   getstringvalue(a), getstringvalue(b), getstringvalue(c));
+   
+        return newintobject ((long) ret);
+}
+
+static object *
+form_show_input (f, args)
+     formobject *f;
+     object *args;
+{
+        char *str;
+	object *a, *b;
+
+        if (!getstrstrarg(args, &a, &b)) return NULL;
+
+	str = fl_show_input (getstringvalue(a), getstringvalue(b));
+   
+        return newstringobject (str);
+}
+
+static object *
+form_file_selector (f, args)
+     formobject *f;
+     object *args;
+{
+        char *str;
+	object *a, *b, *c, *d;
+
+        if (!getstrstrstrstrarg(args, &a, &b, &c, &d)) return NULL;
+
+	str = fl_show_file_selector (getstringvalue(a), getstringvalue(b),
+				     getstringvalue (c), getstringvalue (d));
+   
+        return newstringobject (str);
+}
+
+
+static object *
+form_file_selector_func (f, args, func)
+     formobject *f;
+     object *args;
+     char *(*func)();
+{
+  char *str;
+  
+  str = (*func) ();
+
+  return newstringobject (str);
+}
+
+static object *
+form_get_directory (f, args)
+     formobject *f;
+     object *args;
+{
+  return form_file_selector_func (f, args, fl_get_directory);
+}
+
+static object *
+form_get_pattern (f, args)
+     formobject *f;
+     object *args;
+{
+  return form_file_selector_func (f, args, fl_get_pattern);
+}
+
+static object *
+form_get_filename (f, args)
+     formobject *f;
+     object *args;
+{
+  return form_file_selector_func (f, args, fl_get_filename);
+
+}
+
+static object *
+form_freeze_form(f, args)
+	formobject *f;
+	object *args;
+{
+	return form_call (fl_freeze_form, f-> ob_form, args);  
+}
+
+static object *
+form_unfreeze_form(f, args)
+	formobject *f;
+	object *args;
+{
+	return form_call (fl_unfreeze_form, f-> ob_form, args);
+}
+
+static object *
+form_display_form(f, args)
+	formobject *f;
+	object *args;
+{
+	int place, border;
+	object *name;
+	if (!getintintstrarg(args, &place, &border, &name))
+		return NULL;
+	fl_show_form(f->ob_form, place, border, getstringvalue(name));
+	INCREF(None);
+	return None;
+}
+
+static object *
+form_remove_form(f, args)
+	formobject *f;
+	object *args;
+{
+	return form_call (fl_remove_form, f-> ob_form, args);
+}
+
+static object *
+form_activate_form(f, args)
+	formobject *f;
+	object *args;
+{
+	return form_call (fl_activate_form, f-> ob_form, args);
+}
+
+static object *
+form_deactivate_form(f, args)
+	formobject *f;
+	object *args;
+{
+	return form_call (fl_deactivate_form, f-> ob_form, args);
+}
+
+static struct methodlist form_methods[] = {
+/* adm */
+	{"show_form",		form_show_form},
+	{"hide_form",		form_hide_form},
+	{"redraw_form",         form_redraw_form},
+	{"set_form_position",   form_set_form_position},
+	{"freeze_form",		form_freeze_form},
+	{"unfreeze_form",	form_unfreeze_form},
+	{"display_form",	form_display_form},
+	{"remove_form",		form_remove_form},
+	{"activate_form",	form_activate_form},
+	{"deactivate_form",	form_deactivate_form},
+
+/* basic objects */
+	{"add_button",          form_add_button},
+/*	{"add_bitmap",          form_add_bitmap}, */
+	{"add_lightbutton",	form_add_lightbutton},
+	{"add_roundbutton",     form_add_roundbutton},
+	{"add_menu",            form_add_menu},
+	{"add_slider",          form_add_slider},
+	{"add_positioner",      form_add_positioner},
+	{"add_valslider",       form_add_valslider},
+	{"add_dial",            form_add_dial},
+	{"add_counter",         form_add_counter},
+	{"add_default",         form_add_default},
+	{"add_box",             form_add_box},
+	{"add_clock",           form_add_clock},
+	{"add_choice",          form_add_choice},
+	{"add_browser",         form_add_browser},
+	{"add_input",           form_add_input},
+	{"add_timer",           form_add_timer},
+	{"add_text",            form_add_text},
+	{NULL,			NULL}		/* sentinel */
+};
+
+static void
+form_dealloc(f)
+	formobject *f;
+{
+	/* XXX can't destroy form objects !!! */
+	DEL(f);
+}
+
+static object *
+form_getattr(f, name)
+	formobject *f;
+	char *name;
+{
+	/* XXX check for data attr's: x, y etc. */
+	return findmethod(form_methods, (object *)f, name);
+}
+
+typeobject Formtype = {
+	OB_HEAD_INIT(&Typetype)
+	0,			/*ob_size*/
+	"form",			/*tp_name*/
+	sizeof(formobject),	/*tp_size*/
+	0,			/*tp_itemsize*/
+	/* methods */
+	form_dealloc,		/*tp_dealloc*/
+	0,			/*tp_print*/
+	form_getattr,		/*tp_getattr*/
+	0,			/*tp_setattr*/
+	0,			/*tp_compare*/
+	0,			/*tp_repr*/
+};
+
+static object *
+newformobject(form)
+	FL_FORM *form;
+{
+	formobject *f;
+	f = NEWOBJ(formobject, &Formtype);
+	if (f == NULL)
+		return NULL;
+	f->ob_form = form;
+	return (object *)f;
+}
+
+/* The "fl" module */
+static object *
+forms_make_form(dummy, args)
+	object *dummy;
+	object *args;
+{
+	int type;
+	float w, h;
+	FL_FORM *form;
+	if (!getintfloatfloatarg(args, &type, &w, &h))
+		return NULL;
+	form = fl_bgn_form(type, w, h);
+	if (form == NULL) {
+		/* XXX Actually, cannot happen! */
+		err_nomem();
+		return NULL;
+	}
+	fl_end_form();
+	return newformobject(form);
+}
+
+static object *my_event_callback = NULL;
+
+static object *
+forms_set_event_call_back(dummy, args)
+	object *dummy;
+	object *args;
+{
+	my_event_callback = args;
+	XINCREF(args);
+	INCREF(None);
+	return None;
+}
+
+static object *
+forms_do_or_check_forms(dummy, args, func)
+	object *dummy;
+	object *args;
+	FL_OBJECT *(*func)();
+{
+	FL_OBJECT *generic;
+	genericobject *g;
+	object *arg, *res;
+	
+	if (!getnoarg(args))
+		return NULL;
+
+	for (;;) {
+		generic = (*func)();
+		if (generic == NULL) {
+			INCREF(None);
+			return None;
+		}
+		if (generic == FL_EVENT) {
+			int dev;
+			short val;
+			if (my_event_callback == NULL)
+				return newintobject(-1);
+			dev = fl_qread(&val);
+			arg = newtupleobject(2);
+			if (arg == NULL)
+				return NULL;
+			settupleitem(arg, 0, newintobject((long)dev));
+			settupleitem(arg, 1, newintobject((long)val));
+			res = call_object(my_event_callback, arg);
+			XDECREF(res);
+			DECREF(arg);
+			if (res == NULL)
+				return NULL; /* Callback raised exception */
+			continue;
+		}
+		g = findgeneric(generic);
+		if (g == NULL) {
+			err_setstr(RuntimeError,
+				   "do_forms returns unknown object");
+			return NULL;
+		}
+		if (g->ob_callback == NULL) {
+			INCREF(g);
+			return ((object *) g);
+		}
+		arg = newtupleobject(2);
+		INCREF(g);
+		settupleitem(arg, 0, g);
+		INCREF(g->ob_callback_arg);
+		settupleitem(arg, 1, g->ob_callback_arg);
+		res = call_object(g->ob_callback, arg);
+		XDECREF(res);
+		DECREF(arg);
+		if (res == NULL)
+			return NULL; /* Callback raised exception */
+	}
+}
+
+static object *
+forms_do_forms (dummy, args)
+	object *dummy;
+	object *args;
+{
+  return forms_do_or_check_forms (dummy, args, fl_do_forms);
+}
+
+static object *
+forms_check_forms (dummy, args)
+	object *dummy;
+	object *args;
+{
+  return forms_do_or_check_forms (dummy, args, fl_check_forms);
+}
+
+static object *
+fl_call(func, args)
+	object *args;
+	void (*func)();
+{
+	if (!getnoarg(args))
+		return NULL;
+	(*func)();
+	INCREF(None);
+	return None;
+}
+
+static object *
+forms_bgn_group (dummy, args)
+	object *dummy;
+	object *args;
+{
+	return fl_call (fl_bgn_group, dummy, args);
+}
+
+static object *
+forms_end_group (dummy, args)
+	object *dummy;
+	object *args;
+{
+	return fl_call (fl_end_group, args);
+}
+
+static object *
+forms_qdevice(self, args)
+	object *self;
+	object *args;
+{
+	short arg1 ;
+	if (!getishortarg(args, 1, 0, &arg1))
+		return NULL;
+	fl_qdevice( arg1 );
+	INCREF(None);
+	return None;
+}
+
+static object *
+forms_unqdevice(self, args)
+	object *self;
+	object *args;
+{
+	short arg1 ;
+	if (!getishortarg(args, 1, 0, &arg1))
+		return NULL;
+	fl_unqdevice( arg1 );
+	INCREF(None);
+	return None;
+}
+
+static object *
+forms_isqueued(self, args)
+	object *self;
+	object *args;
+{
+	int retval;
+	short arg1 ;
+	if (!getishortarg(args, 1, 0, &arg1))
+		return NULL;
+	retval = fl_isqueued( arg1 );
+
+	return newintobject((int) retval);
+}
+
+static object *
+forms_qtest(self, args)
+	object *self;
+	object *args;
+{
+	long retval;
+	retval = fl_qtest( );
+	return newintobject((int) retval);
+}
+
+
+static object *
+forms_qread(self, args)
+	object *self;
+	object *args;
+{
+	long retval;
+	short arg1 ;
+	retval = fl_qread( & arg1 );
+	{ object *v = newtupleobject( 2 );
+	  if (v == NULL) return NULL;
+	  settupleitem(v, 0, newintobject(retval));
+	  settupleitem(v, 1, newintobject((long)arg1));
+	  return v;
+	}
+}
+
+static object *
+forms_qreset(self, args)
+	object *self;
+	object *args;
+{
+	if (!getnoarg(args)) return NULL;
+
+	forms_qreset();
+	INCREF(None);
+	return None;
+}
+
+static object *
+forms_qenter(self, args)
+	object *self;
+	object *args;
+{
+	short arg1 ;
+	short arg2 ;
+	if (!getishortarg(args, 2, 0, &arg1))
+		return NULL;
+	if (!getishortarg(args, 2, 1, &arg2))
+		return NULL;
+	fl_qenter( arg1 , arg2 );
+	INCREF(None);
+	return None;
+}
+
+static object *
+forms_color (self, args)
+	object *self;
+	object *args;
+{
+	int arg;
+
+	if (!getintarg(args, &arg)) return NULL;
+
+	fl_color((short) arg);
+
+	INCREF(None);
+	return None;
+}
+
+static object *
+forms_mapcolor (self, args)
+	object *self;
+	object *args;
+{
+	int arg0, arg1, arg2, arg3;
+
+	if (!getintintintintarg(args, &arg0, &arg1, &arg2, &arg3))
+	      return NULL;
+
+	fl_mapcolor(arg0, (short) arg1, (short) arg2, (short) arg3);
+
+	INCREF(None);
+	return None;
+}
+
+static object *
+forms_getmcolor (self, args)
+	object *self;
+	object *args;
+{
+	int arg, r, g, b;
+	object *v;
+
+	if (!getintarg(args, &arg)) return NULL;
+
+	fl_getmcolor (arg, (short) r, (short)g, (short)b);
+
+	v = newtupleobject(3);
+
+	if (v == NULL) return NULL;
+
+	settupleitem(v, 0, newintobject(r));
+	settupleitem(v, 1, newintobject(g));
+	settupleitem(v, 2, newintobject(b));
+
+	return v;
+}
+
+static object *
+forms_tie(self, args)
+	object *self;
+	object *args;
+{
+	short arg1 ;
+	short arg2 ;
+	short arg3 ;
+	if (!getishortarg(args, 3, 0, &arg1))
+		return NULL;
+	if (!getishortarg(args, 3, 1, &arg2))
+		return NULL;
+	if (!getishortarg(args, 3, 2, &arg3))
+		return NULL;
+	fl_tie( arg1 , arg2 , arg3 );
+	INCREF(None);
+	return None;
+}
+
+static struct methodlist forms_methods[] = {
+/* adm */
+	{"make_form",		forms_make_form},
+	{"bgn_group",		forms_bgn_group},
+	{"end_group",		forms_end_group},
+/* gl support wrappers */
+	{"qdevice",		forms_qdevice},
+	{"unqdevice",		forms_unqdevice},
+	{"isqueued",		forms_isqueued},
+	{"qtest",		forms_qtest},
+	{"qread",		forms_qread},
+/*	{"blkqread",		forms_blkqread},  */
+	{"qreset",		forms_qreset},
+	{"qenter",		forms_qenter},
+	{"tie",		forms_tie},
+/*	{"new_events",		forms_new_events}, */
+	{"color",               forms_color},
+	{"mapcolor",		forms_mapcolor},
+	{"getmcolor",		forms_getmcolor},
+/* interaction */
+	{"do_forms",		forms_do_forms},
+	{"check_forms",		forms_check_forms},
+	{"set_event_call_back",	forms_set_event_call_back},
+/* goodies */
+	{"show_message",        form_show_message},
+	{"show_question",       form_show_question},
+	{"file_selector",       form_file_selector},
+	{"get_directory",       form_get_directory},
+	{"get_pattern",         form_get_pattern},
+	{"get_filename",        form_get_filename},
+/*
+	{"show_choice",         form_show_choice},
+	XXX - draw.c
+*/
+	{"show_input",          form_show_input},
+	{NULL,			NULL}		/* sentinel */
+};
+
+void
+initfl()
+{
+	initmodule("fl", forms_methods);
+	foreground ();
+}
+
+
+/* Support routines */
+
+int
+getintintstrarg(args, a, b, c)
+	object *args;
+	int *a, *b;
+	object **c;
+{
+	if (args == NULL || !is_tupleobject(args) || gettuplesize(args) != 3) {
+		err_badarg();
+		return NULL;
+	}
+	return getintarg(gettupleitem(args, 0), a) &&
+		getintarg(gettupleitem(args, 1), b) &&
+		getstrarg(gettupleitem(args, 2), c);
+}
+
+int
+getintfloatfloatarg(args, a, b, c)
+	object *args;
+	int *a;
+	float *b, *c;
+{
+	if (args == NULL || !is_tupleobject(args) || gettuplesize(args) != 3) {
+		err_badarg();
+		return NULL;
+	}
+	return getintarg(gettupleitem(args, 0), a) &&
+		getfloatarg(gettupleitem(args, 1), b) &&
+		getfloatarg(gettupleitem(args, 2), c);
+}
+
+int
+getintintintintarg(args, a, b, c, d)
+	object *args;
+	int *a, *b, *c, *d;
+{
+	if (args == NULL || !is_tupleobject(args) || gettuplesize(args) != 4) {
+		err_badarg();
+		return NULL;
+	}
+	return getintarg(gettupleitem(args, 0), a) &&
+		getintarg(gettupleitem(args, 1), b) &&
+		getintarg(gettupleitem(args, 2), c) &&
+		getintarg(gettupleitem(args, 3), d);
+}
+
+int
+getfloatarg(args, a)
+	object *args;
+	float *a;
+{
+	double x;
+	if (!getdoublearg(args, &x))
+		return 0;
+	*a = x;
+	return 1;
+}
+
+int
+getintfloatfloatfloatfloatstr (args, type, x, y, w, h, name)
+     object *args;
+     int *type;
+     float *x, *y, *w, *h;
+     object **name;
+{
+	if (args == NULL || !is_tupleobject(args) || gettuplesize(args) != 6) {
+		err_badarg();
+		return NULL;
+	}
+	return  getintarg(gettupleitem(args, 0), type) &&
+		getfloatarg(gettupleitem(args, 1), x) &&
+		getfloatarg(gettupleitem(args, 2), y) &&
+		getfloatarg(gettupleitem(args, 3), w) &&
+		getfloatarg(gettupleitem(args, 4), h) &&
+		getstrarg(gettupleitem(args, 5), name);
+}
+
+int
+getfloatfloatfloatarg(args, f1, f2, f3)
+     object *args;
+     float *f1, *f2, *f3;
+{
+        if (args == NULL || !is_tupleobject(args) || gettuplesize(args) != 3) {
+		err_badarg();
+		return NULL;
+	}
+	return  getfloatarg(gettupleitem(args, 0), f1) &&
+		getfloatarg(gettupleitem(args, 1), f2) &&
+		getfloatarg(gettupleitem(args, 2), f3);
+}
+
+int
+getfloatfloatarg(args, f1, f2)
+     object *args;
+     float *f1, *f2;
+{
+        if (args == NULL || !is_tupleobject(args) || gettuplesize(args) != 2) {
+		err_badarg();
+		return NULL;
+	}
+	return  getfloatarg(gettupleitem(args, 0), f1) &&
+		getfloatarg(gettupleitem(args, 1), f2);
+}
+
+int
+getstrstrstrarg(v, a, b, c)
+	object *v;
+	object **a;
+	object **b;
+        object **c;
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 3) {
+		return err_badarg();
+	}
+	return getstrarg(gettupleitem(v, 0), a) &&
+		getstrarg(gettupleitem(v, 1), b)&&
+		getstrarg(gettupleitem(v, 2), c);
+}
+
+
+int
+getstrstrstrstrarg(v, a, b, c, d)
+	object *v;
+	object **a;
+	object **b;
+        object **c;
+        object **d;
+{
+	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 4) {
+		return err_badarg();
+	}
+	return getstrarg(gettupleitem(v, 0), a) &&
+		getstrarg(gettupleitem(v, 1), b)&&
+		getstrarg(gettupleitem(v, 2), c) &&
+		getstrarg(gettupleitem(v, 3),d);
+		  
+}