| --
-- Copyright 1990 by Jim West
--
-- Digital Equipment Corporation
-- Maynard, Massachusetts.
--
-- 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 name of Digital Equipment
-- Corporation not be used in advertising or publicity pertaining to
-- distribution of the software without specific, written prior permission.
--
--
-- DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
-- ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
-- DIGITAL 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.
--
-- ++
--
-- TITLE:
--
-- {tbs}
--
-- ABSTRACT:
--
-- {tbs}
--
-- AUTHORS:
--
-- {tbs}
--
-- CREATION DATE:
--
-- {tbs}
--
-- MODIFICATION HISTORY:
--
-- {tbs}
--
-- --
with
x,
dwt,
system,
starlet,
set_integer,
text_io;
use
starlet,
system;
procedure POPUP_EXAMPLE is
status : dwt.cardinal_type;
top_level : dwt.widget_type;
popup : dwt.widget_type;
main_window : dwt.widget_type;
db : dwt.widget_type;
the_window : dwt.window_type;
display : dwt.display_type;
event_mask : x.event_masks_type := x.event_masks_type_init;
urlist : unsigned_longword_array (0 .. 0);
app_shell_name : constant string := "Popup Example";
class_name : constant string := "popupExample";
argc : dwt.cardinal_type := 0;
drm_id : dwt.drm_hierarchy_type;
drm_file_name : constant string := "popup_example.uid";
drm_file_descr : descriptor_type := (
length => drm_file_name'length,
pointer => drm_file_name'address,
class => starlet.dsc_k_class_s,
dtype => starlet.dsc_k_dtype_t);
drm_file_list : dwt.address_array (0 .. 0) :=
(0 => drm_file_descr'address);
fetch_status : dwt.cardinal_type;
fetch_class : dwt.drm_type_type;
event : dwt.event_type;
begin --POPUP_EXAMPLE
dwt.initialize_drm;
dwt.xt_initialize (
widget => top_level,
name => app_shell_name,
class_name => class_name,
urlist => urlist,
num_urlist => 0,
argcount => argc);
set_integer (top_level, dwt.c_nx, 100);
set_integer (top_level, dwt.c_ny, 100);
dwt.open_hierarchy (
status => status,
num_files => drm_file_list'length,
file_names_list => drm_file_list,
hierarchy_id_return => drm_id);
dwt.fetch_widget (
status => fetch_status,
hierarchy_id => drm_id,
index => "MAIN_WINDOW",
parent => top_level,
w_return => main_window,
class_return => fetch_class);
dwt.xt_manage_child (widget => main_window);
dwt.fetch_widget (
status => fetch_status,
hierarchy_id => drm_id,
index => "work_area",
parent => main_window,
w_return => db,
class_return => fetch_class);
dwt.xt_manage_child (widget => db);
dwt.fetch_widget (
status => fetch_status,
hierarchy_id => drm_id,
index => "POPUP_MENU",
parent => top_level,
w_return => popup,
class_return => fetch_class);
dwt.xt_realize_widget (widget => top_level);
dwt.xt_window (
result => the_window,
widget => db);
dwt.xt_display (
result => display,
widget => top_level);
if the_window = 0 then
text_io.put_line ("No window ID found for top_level shell.");
else
event_mask.button_press := true;
event_mask.button_release := true;
event_mask.owner_grab_button := true;
x.select_input (
display => display,
window_id => the_window,
event_mask => event_mask);
end if;
loop
dwt.xt_next_event (event => event);
if event.evnt_type = x.c_button_press and then
event.btev_button = x.c_button2 then
dwt.menu_position (
menu => popup,
event => event);
text_io.put_line ("Managing popup menu...");
dwt.xt_manage_child (widget => popup);
end if;
dwt.xt_dispatch_event (event => event);
end loop;
end POPUP_EXAMPLE;
|
| Hi,
I think that everybody here is working on the same problem...
The same problem is cross posted in DECWINDOS_PROGRAMMING conference,
note #1106.*. I'll include here the problematic UIL and ADA files.
I'll appreciate if you can take a look at them. I couldn't find the
problem and some others in my dept. couldn't also.
Thanks for the help,
Itamar.
*****************************
Itest.ada
*****************************
package DD_Itest is
type Widget_Names_Type is (
wn_adam_main ,
wn_db ,
wn_popup ,
wn_1 ,
wn_2 ,
wn_3 );
for Widget_Names_Type use (
wn_adam_main => 2,
wn_db => 3,
wn_popup => 4,
wn_1 => 5,
wn_2 => 6,
wn_3 => 7) ;
end Dd_Itest ;
--------------------------------------------------------------------------
-- Widget package
--------------------------------------------------------------------------
with Dd_Itest ; use Dd_Itest ;
with Dwt ;
with X ;
with Starlet;
with System ;
package wdgt is
Toplevel_Widget : Dwt.Widget_Type := System.Address_Zero;
procedure Register_Widget_ID (
Widget: in Dwt.Widget_Type;
Tag : in Widget_Names_Type) ;
procedure Initialize(
Uil_File_Name : in string;
Application_name : in string) ;
procedure Manage_Widget (
Widget_Name_In_Uil_File : in String ;
Widget_Name_In_Array : in Widget_Names_Type ) ;
procedure Register_Callback
(Routine_Uil_Name : in string;
Routine_address : in System.Address) ;
procedure Register_Action
(Routine_Uil_Name : in string;
Routine_address : in System.Address) ;
function Widget
(Widget_Name_In_Array : in Widget_Names_Type )
return Dwt.Widget_Type ;
end wdgt ;
------------------------------------
------------------------------------
with text_io ; use text_io ;
with system ; use system ;
package body wdgt is
package widget_io is new Enumeration_Io(widget_names_Type) ; use widget_io ;
Drm_Hierarchy : Dwt.Drm_Hierarchy_Type;
Widget_Array: array (Widget_Names_Type)
of Dwt.Widget_Type := -- Place to keep all
(Others => System.Address_Zero); -- widget IDs
-------------------------------------------------------------------------------
procedure Open_Uil_Hierarchy_Files
(Uil_File_Name : in string) is
Hierarchy_File_Descr : Dwt.Descriptor_Type := (
CLASS => Starlet.Dsc_K_Class_S,
DTYPE => Starlet.Dsc_K_Dtype_T,
LENGTH => Uil_File_Name'LENGTH,
POINTER => Uil_File_Name'ADDRESS);
Hierarchy_Name_List : Dwt.Address_Array (0..0) :=
(0=> Hierarchy_File_Descr'ADDRESS);
Hierarchy_Status : Dwt.Cardinal_Type;
begin
Dwt.Open_Hierarchy (
STATUS => Hierarchy_Status,
NUM_FILES => Hierarchy_Name_List'LENGTH,
FILE_NAMES_LIST => Hierarchy_Name_List,
HIERARCHY_ID_RETURN => Drm_Hierarchy);
if Hierarchy_Status /= Dwt.C_Drm_Success
then
Text_Io.Put_Line ("%Widgets.Open_Uil_Hierarchy_Files-F-Can't open UIL hierarchy");
end if;
end Open_Uil_Hierarchy_Files ;
-------------------------------------------------------------------------------
procedure Initialize_Toplevel
(Application_name : string) is
Urlist : Unsigned_Longword_Array(0..0) := (0=> 0);
Argv : Dwt.Address_Array(0..0) := (0=> ADDRESS_ZERO);
Argc : Unsigned_Longword := 0;
begin
Dwt.Xt_Initialize (
WIDGET => Toplevel_Widget,
NAME => Application_name,
CLASS_NAME => Application_name,
URLIST => Urlist,
NUM_URLIST => 0,
ARGCOUNT => Argc,
ARGVALUE => Argv);
end Initialize_Toplevel;
-------------------------------------------------------------------------------
-- This is the callback routine that registers all widgets on create callback
--
procedure Register_Widget_ID (
Widget: in Dwt.Widget_Type;
Tag : in Widget_Names_Type) is
begin
Widget_Array(Tag) := Widget ;
end Register_Widget_ID;
--------------------------------------------------------------------------
procedure Initialize(
Uil_File_Name : in string; -- the .UID file
Application_name : in string) is
begin
DWT.Initialize_Drm;
Open_Uil_Hierarchy_Files (Uil_File_Name);
Initialize_Toplevel (Application_name);
end Initialize;
--------------------------------------------------------------------------
procedure Fetch_Widget
(Widget_Name_In_Uil_File : in string;
Widget_Name_In_Array : in Widget_Names_Type) is
Class : Dwt.Drm_Type_Type;
Fetch_Status : Dwt.Cardinal_Type;
begin
Dwt.Fetch_Widget (
STATUS => Fetch_Status,
HIERARCHY_ID => Drm_Hierarchy,
INDEX => Widget_Name_In_Uil_File,
PARENT => Toplevel_Widget,
W_RETURN => Widget_Array(Widget_Name_In_Array),
CLASS_RETURN => Class);
if (Fetch_Status /= Dwt.C_Drm_Success) then
Text_Io.Put_Line ("%Widgets.Fetch_Widget-E-Can't fetch the widget " & Widget_Name_In_Uil_File);
end if;
end Fetch_Widget;
-------------------------------------------------------------------------------
procedure Manage_Widget ( Widget_Name_In_Uil_File : in String ;
Widget_Name_In_Array : in Widget_Names_Type ) is
Is_Managed : Boolean;
Display : X.Display_Type;
begin
if Widget_Array(Widget_Name_In_Array) = System.Address_Zero then
Fetch_Widget(Widget_Name_In_Uil_File,Widget_Name_In_Array);
end if;
Dwt.Xt_Manage_Child (Widget_Array(Widget_Name_In_Array));
end Manage_Widget;
--------------------------------------------------------------------------
procedure Register_Callback -- registers a single callback
(Routine_Uil_Name : in string;
Routine_address : in System.Address) is
Routine_Name : string(1..100);
Register_Status : Dwt.Cardinal_Type;
len : integer := Routine_Uil_Name'Last;
begin
Routine_Name(1..len+1) := Routine_Uil_Name & Ascii.Nul;
Dwt.Register_Drm_Names (
Status => Register_Status,
Register_List => (0 => (Drmr_Name => Routine_Name'Address,
Drmr_Value => Routine_address) ),
Register_Count => 1);
if Register_Status /= Dwt.C_Drm_Success
then
Text_Io.Put_Line ("Can't register callback");
end if;
end Register_Callback;
-------------------------------------------------------------------------------
procedure Register_Action -- registers a single action
(Routine_Uil_Name : in string;
Routine_address : in System.Address) is
type event_table_entry_type is record
Name_Address : system.address;
Routine_address : system.address;
end record;
Routine_Name : string(1..100);
Register_Status : Dwt.Cardinal_Type;
len : integer := Routine_Uil_Name'Last;
event_table : array(0..0) of event_table_entry_type :=
(0=> (Routine_Name'Address, Routine_address));
begin
Routine_Name(1..len+1) := Routine_Uil_Name & Ascii.Nul;
Dwt.XT_ADD_ACTIONS (
ACTION => event_table'ADDRESS,
NUM_ACTIONS => Dwt.CARDINAL_TYPE( event_table'length) );
end Register_Action;
-------------------------------------------------------------------------------
function Widget
(Widget_Name_In_Array : in Widget_Names_Type )
return Dwt.Widget_Type is
begin
return (Widget_Array (Widget_Name_In_Array));
end;
------------------------------------------------------------------------------
end wdgt;
--------------------------------------------------------------------------
-- Events package
--------------------------------------------------------------------------
with Dd_Itest ; use Dd_Itest ;
with Dwt ;
with X ;
package events is
procedure Register_Widget_ID (
Widget: in Dwt.Widget_Type;
Tag : in Dd_Itest.Widget_Names_Type;
Reason: in Integer);
pragma EXPORT_PROCEDURE (register_widget_id);
procedure Popup_Action(
Widget : in Dwt.Widget_Type;
Xevent : in Dwt.Event_Type) ;
pragma EXPORT_PROCEDURE (Popup_Action);
procedure Add ;
pragma EXPORT_PROCEDURE (add);
end events;
------------------------------------
with text_io ; use text_io ;
with wdgt;
package body events is
--------------------------------------------------------------------------
procedure Register_Widget_ID (
Widget: in Dwt.Widget_Type;
Tag : in Dd_Itest.Widget_Names_Type;
Reason: in Integer) is
begin
Wdgt.Register_Widget_ID (Widget, Tag);
end;
--------------------------------------------------------------------------
procedure Popup_Action(
Widget : in Dwt.Widget_Type;
Xevent : in Dwt.Event_Type) is
begin
put_line ("popup_action");
Dwt.Menu_Position ( menu => wdgt.Widget (wn_popup) ,
event => Xevent ) ;
wdgt.Manage_widget ("popup_options",wn_popup);
end;
--------------------------------------------------------------------------
procedure Add is
begin
put_line ("Add");
end;
end events;
------------------------------------------------------------------------------
-- Main Procedure
---------------------------------------------------------------------
with system ;
with text_io ; use text_io ;
with starlet;
with wdgt;
with Dd_Itest; use Dd_Itest ;
with events;
with Dwt;
--with X;
procedure itest is
procedure RC(A:string; B:system.Address) renames Wdgt.Register_callback;
procedure RA(A:string; B:system.Address) renames Wdgt.Register_action;
begin
wdgt.Initialize("adam.uid","POPUP TEST");
RC ("register_widget_id", Events.Register_Widget_ID'address);
RC ("add" , Events.Add'address);
RA ("popup_action" , Events.Popup_Action'address);
wdgt.Manage_Widget ("adam_main",wn_adam_main) ;
Dwt.Xt_Realize_Widget ( Widget => Wdgt.Toplevel_Widget ) ;
loop
begin
Dwt.Xt_main_loop; -- handle events until quit
exception
when others => put_line(" test - unhandled exception ");
end ;
end loop ;
end;
**************************
ADAM.UIL
****************************
module adam
version = 'v1.0'
names = case_sensitive
include file 'decw$include:dwtappl.uil' ;
value
aqua_clr : color ('aquamarine', foreground);
white_clr : color ('white',foreground);
value
wn_main : 2 ;
wn_db : 3 ;
wn_popup : 4 ;
wn_1 : 5 ;
wn_2 : 6 ;
wn_3 : 7 ;
procedure
register_widget_id (integer);
popup_action();
add();
list freez_mode_translations:
arguments
{ translations = translation_table ('<Btn2Down> : popup_action() ');};
/********************************************************/
object
adam_main : dialog_box {
arguments{
units=DwtPixelUnits;
x=10;
y=10;
width =700;
height=800;
};
controls {
dialog_box adam_db ;
};
callbacks {
create=procedure register_widget_id (wn_main);
};
};
object
adam_db : dialog_box {
arguments {
arguments freez_mode_translations;
units=DwtPixelUnits;
x = 0;
y =100;
width =300;
height=326;
border_width =3;
background_color=aqua_clr;
};
callbacks {
create=procedure register_widget_id(wn_db);
};
};
object
popup_options : popup_menu {
controls {
push_button {
arguments {
label_label = ' 1 ' ;
} ;
callbacks {
create=procedure register_widget_id(wn_1);
activate=procedure add();
};
};
push_button {
arguments {
label_label = ' 2 ' ;
} ;
callbacks {
create=procedure register_widget_id(wn_2);
activate=procedure add();
};
};
push_button {
arguments {
label_label = ' 3 ' ;
} ;
callbacks {
create=procedure register_widget_id(wn_3);
activate=procedure add();
};
};
} ;
callbacks {
create=procedure register_widget_id(wn_popup);
};
};
end module;
|