TAC allows to define new C types for binding. Since the VLisp interpreter has the facility to dynamically add new types to the interpreter, TAC is able to register new VLisp types. As an example the binding of the C type Widget from the ViennaWidgetSet defined in the X11 toolkit is shown. The new type must be registered by using the key newtypes from the Define-TAC-Interface as shown in Figure 6.14.
Abbildung 6.14: TAC definition in vmfile.mk for new LISP type WIDGET
In this case the binding depends on the TAC information extracted from
the VBS. The listing of the TAC definition file is shown in
Listing 6.3.
In this case two additional TAC classes are required. The tac::WidgetParam is subclassed from tac::PointerParam and handled similar to a pointer. The tac::WidgetArrayParam is used for a widget array as parameter between VLisp and C. With the defconversion (see defconversion these classes are associated to the C type Widget. In addition to the TAC definition file additional files are required to implement the full binding functionality for the new types in TAC. These are
TAC source file for C type Widget
/* the new type */
xltype vlwidget; /* the XToolkit Widget */
static LVAL xvwnull; /* NULL widget */
/* all (static) functions for type processing */
static LVAL _cvwidget(Widget w)
{
if (w == xvwNULLWIDGET)
return(xvwnull); /* one time global */
else {
LVAL node = newnode(WIDGET);
setwidget(node, w);
setwidgetclass(node, XvwClass(w));
return(node);
}
}
static vVoid _prwidget(LVAL fptr, LVAL obj, vBoolean flag)
{
Widget w = (Widget)getwidget(obj);
if (w == xvwNULLWIDGET) {
if (flag)
xlputstr(fptr, "#<Widget: ");
xlputstr(fptr, "null");
if (flag)
xlputc(fptr, '>');
} else if ((((Object)w)->object.self == w) &&
(((Object)w)->object.widget_class == getwidgetclass(obj))) {
vChar buf[STRMAX+1];
if (flag) {
if (XtIsWidget(w))
xlputstr(fptr, "#<Widget: ");
else
xlputstr(fptr, "#<Gadget: ");
}
xlputstr(fptr, XvwName(w)); /* print name */
if (flag) {
xlputc(fptr, '(');
xlputstr(fptr, XvwClassName(w)); /* print class */
xlputc(fptr, ')');
xlputc(fptr, ',');
sprintf(buf,vPOINTER_FORMAT,w); /* print pointer */
xlputstr(fptr,buf);
xlputc(fptr, '>');
}
} else
xlputstr(fptr, "#<Widget: invalid>");
}
static vBoolean _equalwidget(LVAL w1, LVAL w2)
{
return(getwidget(w1) == getwidget(w2));
}
static LVAL _pdwidget()
{
LVAL val = xlgetarg();
xllastarg();
return(widgetp(val) ? s_true : NIL);
}
static LVAL _widgetname()
{
Widget w;
LVAL val = xlgawidget();
xllastarg();
w = getwidget(val);
if (w == xvwNULLWIDGET)
return(NIL); /* has no name */
else
return(cvstring(XvwName(w))); /* get name of widgetclass */
}
static LVAL _widgetcls()
{
Widget w;
LVAL val = xlgawidget();
xllastarg();
w = getwidget(val);
if (w == xvwNULLWIDGET)
return(NIL); /* has no class */
else
return(cvstring(XvwClassName(w))); /* get name of widgetclass */
}
LVAL xltacGetWidgetArray(
LVAL input, /* [I] input list */
vLong *len) /* [O] returned length of list */
{
LVAL node;
Widget *ptr;
vLong length, i;
if (null(input)) {
*len = 0;
return(cvmemory(vNULL));
}
length = listlen(input);
node = xltacMalloc(sizeof(Widget) * length);
ptr = (Widget *)getmemory(node);
if (consp(input)) {
for (i = 0; i < length; i++) {
LVAL val = car(input);
if (!widgetp(val))
xlbadtype(input);
ptr[i] = getwidget(val);
input = cdr(input);
}
} else if (vectorp(input)) {
for (i = 0; i < length; i++) {
LVAL val = getelement(input, i);
if (!widgetp(val))
xlbadtype(input);
ptr[i] = getwidget(val);
}
} else if (widgetp(input))
*ptr = getwidget(input);
else
xlbadtype(input);
*len = length;
return(node);
}
LVAL xltacConvertWidgetArray(
Widget *input, /* [I] input array */
vLong len, /* [I] length of array */
vBoolean allocated) /* [I] array was allocated */
{
LVAL node;
xlsave1(node);
for (len--; len >= 0; len--)
node = cons(cvwidget(input[len]), node);
xlpop();
if (allocated && (input != vNULL))
vFree(input);
return(node);
}
/* global initialization function */
vVoid vlInitializeBindingXVW()
{
/* initialize new type */
vlwidget = xltacNewType("widget", /* name of new node type */
_cvwidget, /* create node */
vNULLFUNC, /* mark node during GC */
vNULLFUNC, /* free node (unreachable) */
_equalwidget, /* test for equal */
_prwidget, /* print node */
vFALSE); /* has no children */
/* predicate function */
xltacSubr("widgetp", _pdwidget);
xltacSubr("xvw::widget-name", _widgetname);
xltacSubr("xvw::widget-class", _widgetcls);
/* preallocate xvwNULLWIDGET */
xvwnull = newcnode(WIDGET);
setwidget(xvwnull, xvwNULLWIDGET);
setwidgetclass(xvwnull, vNULL);
}
In addition of registering the new type to the VLisp interpreter, a predicate function and two utility functions are registered for the new type. For the special value of xvwNULLWIDGET a constant VLisp symbol is created and initialized. This value is used by many routines of the ViennaWidgetSet as special parameter.
TAC extension file for C type Widget
%\begin{lispprog}
;;- define the methods
(defmethod tac::WidgetParam :bindvars (desc)
(format desc " LVAL _vl~A_;\n" name)
(format desc " ~A ~A;\n" (send self :ctype) name)
0)
(defmethod tac::WidgetParam :getvalue (desc haskeys)
(format desc " _vl~A_ = xlgawidget();\n" name)
(format desc " ~A = (~A)getwidget(_vl~A_);\n"
name (send self :ctype) name)
0)
(defmethod tac::WidgetParam :cvlisp ()
(strcat "cvwidget((Widget)" name ")"))
(defmethod tac::WidgetParam :cbfunc () "tacWidgetCB")
(defmethod tac::WidgetArrayParam :bindvars (desc)
(format desc " LVAL _vl~A_;\n" name)
(cond (maxsize
(format desc " ~A ~A[~A];\n" (car type) maxsize))
(check
(format desc " ~A *~A;\n" (car type) name)
(format desc " vLong _~Alen_;\n" name))
(t
(format desc " ~A ~A;\n" (send self :ctype) name)
(format desc " vLong ~A;\n" (send length :get 'name))))
(if input 1 0))
(defmethod tac::WidgetArrayParam :getvalue (desc haskeys)
(format desc " _vl~A_ = xlgetarg();\n" name)
(format desc " xlprotect(_vl~A_);\n" name)
(if check
(format desc " _vl~A_ = xltacGetWidgetArray(_vl~A_, &_~Alen_);\n"
name name name min max)
(format desc " _vl~A_ = xltacGetWidgetArray(_vl~A_, &~A);\n"
name name (send length :get 'name)))
(format desc " ~A = (~A)getmemory(_vl~A_);\n"
name (send self :ctype) name)
(unless null
(format desc " if (~A == vNULL)\n" name)
(format desc " xlbadvalue(_vl~A_);\n" name))
;;- check minimum/maximum length of array
(when length
(when (send length :get 'min)
(format desc " if (~A < ~A)\n"
(send length :get 'name) (send length :get 'min))
(format desc " xlbadvalue(_vl~A_);\n" name))
(when (send length :get 'max)
(format desc " if (~A > ~A)\n"
(send length :get 'name) (send length :get 'max))
(format desc " xlbadvalue(_vl~A_);\n" name)))
1)
(defmethod tac::WidgetArrayParam :cvlisp ()
(strcat "xltacConvertWidgetArray((Widget *)" name ",(vLong)"
(send length :get 'name) ","
(if allocated "vTRUE" "vFALSE") ")"))