287 lines
9.8 KiB
D
287 lines
9.8 KiB
D
;; arrow-button.d: Used as container for random stuff
|
|
;;
|
|
;; $Id$
|
|
;;
|
|
;; Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
|
|
;; Copyright 2002, 2003 Sam Hocevar <sam@zoy.org>, Paris
|
|
;;
|
|
;; This software was derived from Elk 1.2, which was Copyright 1987, 1988,
|
|
;; 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
|
|
;; by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
|
|
;; between TELES and Nixdorf Microprocessor Engineering, Berlin).
|
|
;;
|
|
;; Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
|
|
;; owners or individual owners of copyright in this software, grant to any
|
|
;; person or company a worldwide, royalty free, license to
|
|
;;
|
|
;; i) copy this software,
|
|
;; ii) prepare derivative works based on this software,
|
|
;; iii) distribute copies of this software or derivative works,
|
|
;; iv) perform this software, or
|
|
;; v) display this software,
|
|
;;
|
|
;; provided that this notice is not removed and that neither Oliver Laumann
|
|
;; nor Teles nor Nixdorf are deemed to have made any representations as to
|
|
;; the suitability of this software for any purpose nor are held responsible
|
|
;; for any defects of this software.
|
|
;;
|
|
;; THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
|
|
|
|
(define-widget-type 'support "") ; No include file
|
|
|
|
(prolog
|
|
|
|
"SYMDESCR Reason_Syms[] = {
|
|
{ \"none\", XmCR_NONE },
|
|
{ \"help\", XmCR_HELP },
|
|
{ \"value-changed\", XmCR_VALUE_CHANGED },
|
|
{ \"increment\", XmCR_INCREMENT },
|
|
{ \"decrement\", XmCR_DECREMENT },
|
|
{ \"page-increment\", XmCR_PAGE_INCREMENT },
|
|
{ \"page-decrement\", XmCR_PAGE_DECREMENT },
|
|
{ \"to-top\", XmCR_TO_TOP },
|
|
{ \"to-bottom\", XmCR_TO_BOTTOM },
|
|
{ \"drag\", XmCR_DRAG },
|
|
{ \"activate\", XmCR_ACTIVATE },
|
|
{ \"arm\", XmCR_ARM },
|
|
{ \"disarm\", XmCR_DISARM },
|
|
{ \"map\", XmCR_MAP },
|
|
{ \"unmap\", XmCR_UNMAP },
|
|
{ \"focus\", XmCR_FOCUS },
|
|
{ \"losing-focus\", XmCR_LOSING_FOCUS },
|
|
{ \"modifying-text-value\", XmCR_MODIFYING_TEXT_VALUE },")
|
|
|
|
(prolog
|
|
" { \"moving-insert-cursor\", XmCR_MOVING_INSERT_CURSOR },
|
|
{ \"execute\", XmCR_EXECUTE },
|
|
{ \"single-select\", XmCR_SINGLE_SELECT },
|
|
{ \"multiple-select\", XmCR_MULTIPLE_SELECT },
|
|
{ \"extended-select\", XmCR_EXTENDED_SELECT },
|
|
{ \"browse-select\", XmCR_BROWSE_SELECT },
|
|
{ \"default-action\", XmCR_DEFAULT_ACTION },
|
|
{ \"clipboard-data-request\", XmCR_CLIPBOARD_DATA_REQUEST },
|
|
{ \"clipboard-data-delete\", XmCR_CLIPBOARD_DATA_DELETE },
|
|
{ \"cascading\", XmCR_CASCADING },
|
|
{ \"ok\", XmCR_OK },
|
|
{ \"cancel\", XmCR_CANCEL },
|
|
{ \"apply\", XmCR_APPLY },
|
|
{ \"no-match\", XmCR_NO_MATCH },
|
|
{ \"command-entered\", XmCR_COMMAND_ENTERED },
|
|
{ \"command-changed\", XmCR_COMMAND_CHANGED },
|
|
{ \"expose\", XmCR_EXPOSE },
|
|
{ \"resize\", XmCR_RESIZE },
|
|
{ \"input\", XmCR_INPUT },
|
|
{ 0, 0 }
|
|
};")
|
|
|
|
(prolog
|
|
|
|
"Object Get_Any_CB (XmAnyCallbackStruct *p) {
|
|
Object args, ret;
|
|
GC_Node2;
|
|
|
|
args = ret = Null;
|
|
GC_Link2 (ret, args);
|
|
if (p->event) {
|
|
args = Get_Event_Args (p->event);
|
|
ret = Copy_List (args);
|
|
Destroy_Event_Args (args);
|
|
}
|
|
ret = Cons (Bits_To_Symbols ((unsigned long)p->reason, 0, Reason_Syms),
|
|
ret);
|
|
GC_Unlink;
|
|
return ret;
|
|
}")
|
|
|
|
(prolog
|
|
|
|
"Object Get_Selection_CB (XmSelectionBoxCallbackStruct *p) {
|
|
Object ret, s;
|
|
char *text;
|
|
GC_Node2;
|
|
|
|
if (!XmStringGetLtoR (p->value, XmSTRING_DEFAULT_CHARSET, &text))
|
|
text = \"\";
|
|
ret = s = Make_String (text, strlen (text));
|
|
GC_Link2 (ret, s);
|
|
ret = Cons (ret, Null);
|
|
s = Get_Any_CB ((XmAnyCallbackStruct *)p);
|
|
ret = Cons (Cdr (s), ret);
|
|
ret = Cons (Car (s), ret);
|
|
GC_Unlink;
|
|
return ret;
|
|
}")
|
|
|
|
(prolog
|
|
|
|
"static XtArgVal Scheme_To_String_Table (Object x) {
|
|
Object t;
|
|
char *s;
|
|
XmString *tab;
|
|
int i = 0;
|
|
Alloca_Begin;
|
|
|
|
tab = (XmString *)XtMalloc (Get_Integer (P_Length (x))
|
|
* sizeof (XmString));
|
|
/* tab is never freed since the converter must return a new address
|
|
* each time it is called.
|
|
*/
|
|
for (t = x; TYPE(t) == T_Pair; t = Cdr (t)) {
|
|
Get_Strsym_Stack (Car (t), s);
|
|
tab[i++] = XmStringCreate (s, XmSTRING_DEFAULT_CHARSET);
|
|
}
|
|
Alloca_End;
|
|
return (XtArgVal)tab;
|
|
}")
|
|
|
|
|
|
(define-primitive 'update-display '(w)
|
|
" Check_Widget (w);
|
|
XmUpdateDisplay (WIDGET(w)->widget);
|
|
return Void;")
|
|
|
|
|
|
;;; Converters
|
|
|
|
(define keysym->scheme
|
|
" return Make_Char ((int)x);")
|
|
|
|
(define scheme->keysym
|
|
" Check_Type (x, T_Character); return (XtArgVal)CHAR(x);")
|
|
|
|
(define position->scheme
|
|
" return Make_Integer (*(Position *)(void *)&x);")
|
|
|
|
(define scheme->position
|
|
" return (XtArgVal)Get_Integer (x);")
|
|
|
|
(define dimension->scheme
|
|
" return Make_Integer (*(Dimension *)(void *)&x);")
|
|
|
|
(define scheme->dimension
|
|
" return (XtArgVal)Get_Unsigned (x);")
|
|
|
|
(define int->scheme
|
|
" return Make_Integer (*(int *)(void *)&x);")
|
|
|
|
(define scheme->int
|
|
" return (XtArgVal)Get_Integer (x);")
|
|
|
|
(define window->scheme
|
|
" return Make_Widget_Foreign ((Widget)x);")
|
|
|
|
(define scheme->window
|
|
" Check_Widget (x); return (XtArgVal)WIDGET(x)->widget;")
|
|
|
|
(define scheme->scrollbar
|
|
" extern WidgetClass xmScrollBarWidgetClass;
|
|
Check_Widget_Class (x, xmScrollBarWidgetClass);
|
|
return (XtArgVal)WIDGET(x)->widget;")
|
|
|
|
(define selection-callback->scheme
|
|
" return Get_Selection_CB ((XmSelectionBoxCallbackStruct *)x);")
|
|
|
|
(define help-callback->scheme
|
|
" return Get_Any_CB ((XmAnyCallbackStruct *)x);")
|
|
|
|
(define button-callback->scheme
|
|
" return Get_Any_CB ((XmAnyCallbackStruct *)x);")
|
|
|
|
(define event-callback->scheme
|
|
" return Get_Any_CB ((XmAnyCallbackStruct *)x);")
|
|
|
|
(define xm-string->scheme
|
|
" char *text;
|
|
if (!XmStringGetLtoR ((XmString)x, XmSTRING_DEFAULT_CHARSET, &text))
|
|
text = \"\";
|
|
return Make_String (text, strlen (text));")
|
|
|
|
(define scheme->xm-string
|
|
" char *s;
|
|
XtArgVal ret;
|
|
Alloca_Begin;
|
|
Get_Strsym_Stack (x, s);
|
|
ret = (XtArgVal)XmStringCreateLtoR (s, XmSTRING_DEFAULT_CHARSET);
|
|
Alloca_End;
|
|
return ret;")
|
|
|
|
(define scheme->xm-string-table
|
|
" return Scheme_To_String_Table (x);")
|
|
|
|
(c->scheme 'KeySym keysym->scheme)
|
|
(scheme->c 'KeySym scheme->keysym)
|
|
|
|
(c->scheme 'HorizontalPosition position->scheme)
|
|
(c->scheme 'VerticalPosition position->scheme)
|
|
(c->scheme 'HorizontalDimension dimension->scheme)
|
|
(c->scheme 'VerticalDimension dimension->scheme)
|
|
(c->scheme 'HorizontalInt int->scheme) ; Sigh. Why don't they just
|
|
(c->scheme 'VerticalInt int->scheme) ; use plain old Int??
|
|
(scheme->c 'HorizontalPosition scheme->position)
|
|
(scheme->c 'VerticalPosition scheme->position)
|
|
(scheme->c 'HorizontalDimension scheme->dimension)
|
|
(scheme->c 'VerticalDimension scheme->dimension)
|
|
(scheme->c 'HorizontalInt scheme->int)
|
|
(scheme->c 'VerticalInt scheme->int)
|
|
|
|
(c->scheme 'ShellHorizPos position->scheme)
|
|
(c->scheme 'ShellVertPos position->scheme)
|
|
(c->scheme 'ShellHorizDim dimension->scheme)
|
|
(c->scheme 'ShellVertDim dimension->scheme)
|
|
(scheme->c 'ShellHorizPos scheme->position)
|
|
(scheme->c 'ShellVertPos scheme->position)
|
|
(scheme->c 'ShellHorizDim scheme->dimension)
|
|
(scheme->c 'ShellVertDim scheme->dimension)
|
|
|
|
(c->scheme 'horizontalScrollBar window->scheme) ; Some classes have resources
|
|
(c->scheme 'verticalScrollBar window->scheme) ; of type window instead of
|
|
(c->scheme 'workWindow window->scheme) ; widget. What a crock!
|
|
(c->scheme 'commandWindow window->scheme)
|
|
(c->scheme 'menuBar window->scheme)
|
|
(c->scheme 'subMenuId window->scheme)
|
|
(c->scheme 'menuHistory window->scheme)
|
|
(c->scheme 'menuHelpWidget window->scheme)
|
|
(c->scheme 'bottomWidget window->scheme)
|
|
(c->scheme 'leftWidget window->scheme)
|
|
(c->scheme 'rightWidget window->scheme)
|
|
(c->scheme 'topWidget window->scheme)
|
|
|
|
(scheme->c 'horizontalScrollBar scheme->scrollbar)
|
|
(scheme->c 'verticalScrollBar scheme->scrollbar)
|
|
(scheme->c 'workWindow scheme->window)
|
|
(scheme->c 'commandWindow scheme->window)
|
|
(scheme->c 'menuBar scheme->window)
|
|
(scheme->c 'subMenuId scheme->window)
|
|
(scheme->c 'menuHistory scheme->window)
|
|
(scheme->c 'menuHelpWidget scheme->window)
|
|
(scheme->c 'bottomWidget scheme->window)
|
|
(scheme->c 'leftWidget scheme->window)
|
|
(scheme->c 'rightWidget scheme->window)
|
|
(scheme->c 'topWidget scheme->window)
|
|
|
|
(c->scheme 'callback:applyCallback selection-callback->scheme)
|
|
(c->scheme 'callback:cancelCallback selection-callback->scheme)
|
|
(c->scheme 'callback:noMatchCallback selection-callback->scheme)
|
|
(c->scheme 'callback:okCallback selection-callback->scheme)
|
|
|
|
(c->scheme 'callback:helpCallback help-callback->scheme)
|
|
|
|
(c->scheme 'callback:activateCallback button-callback->scheme)
|
|
(c->scheme 'callback:armCallback button-callback->scheme)
|
|
(c->scheme 'callback:disarmCallback button-callback->scheme)
|
|
(c->scheme 'callback:cascadingCallback button-callback->scheme)
|
|
|
|
(c->scheme 'callback:exposeCallback event-callback->scheme)
|
|
(c->scheme 'callback:inputCallback event-callback->scheme)
|
|
(c->scheme 'callback:resizeCallback event-callback->scheme)
|
|
|
|
(c->scheme 'XmString xm-string->scheme)
|
|
(scheme->c 'XmString scheme->xm-string)
|
|
(scheme->c 'XmStringTable scheme->xm-string-table)
|
|
|
|
;;; Classes for which no .d-file exists:
|
|
|
|
(define-widget-class 'primitive 'xmPrimitiveWidgetClass)
|
|
|
|
(define-widget-class 'manager 'xmManagerWidgetClass)
|