1 ;; row-column.d 2 ;; 3 ;; $Id$ 4 ;; 5 ;; Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin 6 ;; Copyright 2002, 2003 Sam Hocevar <sam@hocevar.net>, Paris 7 ;; 8 ;; This software was derived from Elk 1.2, which was Copyright 1987, 1988, 9 ;; 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written 10 ;; by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project 11 ;; between TELES and Nixdorf Microprocessor Engineering, Berlin). 12 ;; 13 ;; Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co- 14 ;; owners or individual owners of copyright in this software, grant to any 15 ;; person or company a worldwide, royalty free, license to 16 ;; 17 ;; i) copy this software, 18 ;; ii) prepare derivative works based on this software, 19 ;; iii) distribute copies of this software or derivative works, 20 ;; iv) perform this software, or 21 ;; v) display this software, 22 ;; 23 ;; provided that this notice is not removed and that neither Oliver Laumann 24 ;; nor Teles nor Nixdorf are deemed to have made any representations as to 25 ;; the suitability of this software for any purpose nor are held responsible 26 ;; for any defects of this software. 27 ;; 28 ;; THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE. 29 30 (define-widget-type 'rowcolumn "RowColumn.h") 31 32 (prolog 33 34 "static SYMDESCR Type_Syms[] = { 35 { \"work-area\", XmWORK_AREA }, 36 { \"menu-bar\", XmMENU_BAR }, 37 { \"menu-pulldown\", XmMENU_PULLDOWN }, 38 { \"menu-popup\", XmMENU_POPUP }, 39 { \"menu-option\", XmMENU_OPTION }, 40 { 0, 0} 41 };") 42 43 (define-widget-class 'row-column 'xmRowColumnWidgetClass) 44 45 (prolog 46 47 "static void Post_Handler (Widget w, XtPointer client_data, XEvent *event, 48 Boolean *unused) { 49 unsigned int b; 50 Arg a; 51 XButtonPressedEvent *ep = (XButtonPressedEvent *)event; 52 Widget popup = (Widget)client_data; 53 54 XtSetArg (a, XmNwhichButton, &b); 55 XtGetValues (popup, &a, 1); 56 if (ep->button != b) 57 return; 58 XmMenuPosition (popup, ep); 59 XtManageChild (popup); 60 }") 61 62 (prolog 63 64 "static Object Get_Row_Column_CB (XmRowColumnCallbackStruct *p) { 65 Object ret, s; 66 GC_Node2; 67 68 ret = s = Make_Widget_Foreign (p->widget); 69 GC_Link2 (ret, s); 70 ret = Cons (ret, Null); 71 s = Get_Any_CB ((XmAnyCallbackStruct *)p); 72 ret = Cons (Cdr (s), ret); 73 ret = Cons (Car (s), ret); 74 GC_Unlink; 75 return ret; 76 }") 77 78 (define-primitive 'popup-menu-attach-to! '(m w) 79 " XtPointer client_data; 80 Arg a; 81 Check_Widget_Class (m, xmRowColumnWidgetClass); 82 Check_Widget (w); 83 XtSetArg (a, XmNuserData, &client_data); 84 XtGetValues (WIDGET(w)->widget, &a, 1); 85 if (client_data) 86 XtRemoveEventHandler (WIDGET(w)->widget, ButtonPressMask, 0, 87 Post_Handler, client_data); 88 client_data = (XtPointer)WIDGET(m)->widget; 89 XtAddEventHandler (WIDGET(w)->widget, ButtonPressMask, 0, 90 Post_Handler, client_data); 91 client_data = (XtPointer)WIDGET(m)->widget; 92 XtSetValues (WIDGET(w)->widget, &a, 1); 93 return Void;") 94 95 (define-callback 'row-column 'entryCallback #t) 96 97 (define row-column-callback->scheme 98 " return Get_Row_Column_CB ((XmRowColumnCallbackStruct *)x);") 99 100 (c->scheme 'callback:row-column-entryCallback row-column-callback->scheme) 101 102 (define scheme->row-column-type 103 " return (XtArgVal)Symbols_To_Bits (x, 0, Type_Syms);") 104 105 ;;; whichButton resource is declared with a type of XtRWhichButton 106 ;;; instead of XtRUnsignedInt. Argh! 107 108 (define scheme->which-button 109 " return (XtArgVal)Get_Integer (x);") 110 111 (define which-button->scheme 112 " return Make_Integer (x);") 113 114 ;;; entryClass is declared as int! Bletch! 115 116 (define scheme->entry-class 117 " Check_Type (x, T_Class); return (XtArgVal)CLASS(x)->wclass;") 118 119 (define entry-class->scheme 120 " return Make_Widget_Class ((WidgetClass)x);") 121 122 (scheme->c 'row-column-rowColumnType scheme->row-column-type) 123 124 (scheme->c 'row-column-whichButton scheme->which-button) 125 (c->scheme 'row-column-whichButton which-button->scheme) 126 127 (scheme->c 'row-column-entryClass scheme->entry-class) 128 (c->scheme 'row-column-entryClass entry-class->scheme) 129