-------------------------------------------------------------------------------------- -- Ada language interface to OSF/Motif toolkit -- -- Version: 1.0 -- -- Release date: 3/19/91 -- -- Compiled under: -- VADS 5.5+ on Apollo Domain / DEC Ultrix / SCO Unix -- -- This is an Ada binding to the OSF Motif toolkit. -- Requires: -- OSF/Motif toolkit -- Verdix (or Verdix-derived) Ada libraries -- -- Author: -- Boeing Commercial Airplanes Avionics Flight Systems Organization -- -- -- Mailing Address: -- P.O. Box 3999, M/S 65-07 -- Seattle, WA 98124 -- Attn: E. J. Jones -- -- -- Approved for public release; distribution is unlimited. Per DoD Directive -- 5230.24. -- -- Copyright (c) 1991, The Boeing Company, Seattle, Washington. This software, -- the BCA Ada language interface to the OSF/Motif toolkit, produced by the -- Boeing Commercial Airplane Company and made available under STARS (Software -- Technology for Adaptable, Reliable Systems) is approved for release under -- Distribution "A" of the Scientific and Technical Information Program -- Classification Scheme (DoD Directive 5230.24) unless otherwise indicated. -- Sponsored by the U.S. Defense Advanced Research Project Agency (DARPA) under -- contract F19628-88-D-0028, the STARS program is supported by the military -- services, SEI, and MITRE, with the U.S. Air Force as the executive -- contracting agent. The code identified herein is subject to change. -- -- Permission to use, modify, copy, and comment on this software for purposes -- stated under Distribution "A" and without fee is hereby granted. This -- software retains Contractor indemnification to the Government regarding -- copyrights pursuant to the above referenced STARS contract. The Government -- disclaims all responsibility against liability, including costs and expenses -- for violation of proprietary rights, or copyrights arising out of the -- creation or use of this software. -- -- In addition, the Government and The Boeing Company disclaim all warranties -- with regard to this software, including all implied warranties of -- merchantability and fitness. In no event shall the Government or The Boeing -- Company be liable for any special, indirect or consequential damages or any -- damages whatsoever resulting from the loss of use, data or profits, whether -- in action of contract, negligence or other tortuous action, arising in -- connection with the use or performance of this software. The Boeing Company -- does not agree to support or maintain this software or to produce any -- future versions. -------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------- -- PROLOGUE -- -- NAME: Package Body for X_TOOLKIT_INTRINSICS_OSF -- -- FUNCTION: This is the Ada binding for the X toolkit (OSF version which is -- included with the OSF MOTIF Widget Set. ---------------------------------------------------------------------- -- Package body XT INTRINSICS ---------------------------------------------------------------------- -- CHANGE HISTORY -- Ver. Developer Date Description -- ---- -------- ----- --------------------------------- -- 1.0 E.J.Jones(206)477-3566 12/91 Original version for Ada Motif Bindings -- -- -- -------------------------------------------------------------------------------------- with SYSTEM, --SET_UP, UNCHECKED_CONVERSION, UNCHECKED_DEALLOCATION; package body X_TOOLKIT_INTRINSICS_OSF is -------------------------------------------------------------------------------------- -- -- ROADMAP for package body: -- -- -- DECLARATIONS OF HIDDEN TYPES -- Command Line Option Lists -- Argument List -- Callback List -- Widget Lists -- Predefined Callback Procedures -- Predefined Widget Classes -- -- COMMAND LINE OPTIONS -- Option List Management -- -- TOOLKIT INITIALIZATION -- XT_INITIALIZE -- -- CALLBACKS -- Callback List Management -- Callbacks for Widgets -- -- ARGUMENT LISTS -- Argument List Management -- -- WIDGET MANIPULATION -- Widget List Management -- Widget Creation -- Widget Childcare -- Realize/map Widgets -- Destroy Widgets -- Getting/setting Widget State -- Widget Misc -- -- SHELLS -- Popup Shells -- -- QUERIES -- XT_CLASS, XT_SUPERCLASS, XT_IS_SUBCLASS, XT_IS_COMPOSITE etc. -- XT_TRANSLATE_COORDS -- -- EVENTS -- Timeouts -- Event Handling -- -- MISCELLANEOUS JUNK -- -- This is all stuff we aren't sure we'll need or what to do with it. -- None of it should be useful in its current form. -------------------------------------------------------------------------------------- -- -- DECLARATIONS OF HIDDEN TYPES -- subtype XEVENT is SYSTEM.ADDRESS; type WIDGET_GROUP is array (AFS_MEDIUM_POSITIVE range <>) of WIDGET; type WIDGET_LIST_REC (COUNT : AFS_MEDIUM_NATURAL) is record LIST : WIDGET_GROUP (1..COUNT) := (others => NULL_WIDGET); INDEX : AFS_MEDIUM_NATURAL := 0; end record; type ARG_NUMBER is new AFS_BASIC_TYPES.AFS_LARGE_INTEGER range 0..63; type STR_PTR is access STRING; type STR_PTR_ARRAY is array (ARG_NUMBER) of SYSTEM.ADDRESS ; function XT_IS_MANAGED( W : in WIDGET ) return BOOLEAN is function XT_IS_MANAGED_FAKE( W : in SYSTEM.ADDRESS ) return BOOLEAN; pragma INTERFACE( C, XT_IS_MANAGED_FAKE ); pragma INTERFACE_NAME( XT_IS_MANAGED_FAKE, "XtIsManagedFake" ); begin return XT_IS_MANAGED_FAKE( WIDGET_TO_ADDR(W) ); end XT_IS_MANAGED; procedure XT_SET_KEYBOARD_FOCUS( SUBTREE : WIDGET; DESCENDENT : WIDGET ) is procedure XT_SET_KEYBRD_FOCUS( SUBTREE : SYSTEM.ADDRESS; DESCENDENT : SYSTEM.ADDRESS ); pragma INTERFACE( C, XT_SET_KEYBRD_FOCUS ); pragma INTERFACE_NAME( XT_SET_KEYBRD_FOCUS, "XtSetKeyboardFocus" ); begin XT_SET_KEYBRD_FOCUS( SUBTREE => WIDGET_TO_ADDR(SUBTREE), DESCENDENT => WIDGET_TO_ADDR(DESCENDENT) ); end XT_SET_KEYBOARD_FOCUS; -------------------------------------------------------------------------------------- -- -- PREDEFINED CALLBACK PROCEDURES -- procedure CALLBACKNONE (POPUP_SHELL : SYSTEM.ADDRESS; CLIENT_DATA : SYSTEM.ADDRESS; CALL_DATA : SYSTEM.ADDRESS); procedure CALLBACKNONEXCLUSIVE (POPUP_SHELL : SYSTEM.ADDRESS; CLIENT_DATA : SYSTEM.ADDRESS; CALL_DATA : SYSTEM.ADDRESS); procedure CALLBACKEXCLUSIVE (POPUP_SHELL : SYSTEM.ADDRESS; CLIENT_DATA : SYSTEM.ADDRESS; CALL_DATA : SYSTEM.ADDRESS); procedure CALLBACKPOPDOWN (POPUP_SHELL : SYSTEM.ADDRESS; CLIENT_DATA : SYSTEM.ADDRESS; CALL_DATA : SYSTEM.ADDRESS); pragma INTERFACE (C, CALLBACKNONE); pragma INTERFACE_NAME (CALLBACKNONE, "XtCallbackNone"); pragma INTERFACE (C, CALLBACKNONEXCLUSIVE); pragma INTERFACE_NAME (CALLBACKNONEXCLUSIVE, "XtCallbackNonexclusive"); pragma INTERFACE (C, CALLBACKEXCLUSIVE); pragma INTERFACE_NAME (CALLBACKEXCLUSIVE, "XtCallbackExclusive"); pragma INTERFACE (C, CALLBACKPOPDOWN); pragma INTERFACE_NAME (CALLBACKPOPDOWN, "XtCallbackPopdown"); -------------------------------------------------------------------------------------- -- -- PREDEFINED WIDGET CLASSES -- function CORE_WIDGET_CLASS return WIDGET_CLASS is function CORE_CLASS return SYSTEM.ADDRESS; pragma INTERFACE (C, CORE_CLASS); pragma INTERFACE_NAME (CORE_CLASS, "coreFakeClass"); begin return WIDGET_CLASS(CORE_CLASS); end CORE_WIDGET_CLASS; function COMPOSITE_WIDGET_CLASS return WIDGET_CLASS is function COMPOSITE_CLASS return SYSTEM.ADDRESS; pragma INTERFACE (C, COMPOSITE_CLASS); pragma INTERFACE_NAME (COMPOSITE_CLASS, "compositeFakeClass"); begin return WIDGET_CLASS(COMPOSITE_CLASS); end COMPOSITE_WIDGET_CLASS; function CONSTRAINT_WIDGET_CLASS return WIDGET_CLASS is function CONSTRAINT_CLASS return SYSTEM.ADDRESS; pragma INTERFACE (C, CONSTRAINT_CLASS); pragma INTERFACE_NAME (CONSTRAINT_CLASS, "constraintFakeClass"); begin return WIDGET_CLASS(CONSTRAINT_CLASS); end CONSTRAINT_WIDGET_CLASS; function TOP_LEVEL_SHELL_WIDGET_CLASS return WIDGET_CLASS is function TOP_LEVEL_SHELL_CLASS return SYSTEM.ADDRESS; pragma INTERFACE (C, TOP_LEVEL_SHELL_CLASS); pragma INTERFACE_NAME (TOP_LEVEL_SHELL_CLASS, "topLevelShellFakeClass"); begin return WIDGET_CLASS(TOP_LEVEL_SHELL_CLASS); end TOP_LEVEL_SHELL_WIDGET_CLASS; function TRANSIENT_SHELL_WIDGET_CLASS return WIDGET_CLASS is function TRANSIENT_SHELL_CLASS return SYSTEM.ADDRESS; pragma INTERFACE (C, TRANSIENT_SHELL_CLASS); pragma INTERFACE_NAME (TRANSIENT_SHELL_CLASS, "transientShellFakeClass"); begin return WIDGET_CLASS (TRANSIENT_SHELL_CLASS); end TRANSIENT_SHELL_WIDGET_CLASS; function OVERRIDE_SHELL_WIDGET_CLASS return WIDGET_CLASS is function OVERRIDE_SHELL_CLASS return SYSTEM.ADDRESS; pragma INTERFACE (C, OVERRIDE_SHELL_CLASS); pragma INTERFACE_NAME (OVERRIDE_SHELL_CLASS, "overrideShellFakeClass"); begin return WIDGET_CLASS (OVERRIDE_SHELL_CLASS); end OVERRIDE_SHELL_WIDGET_CLASS; function WM_SHELL_WIDGET_CLASS return WIDGET_CLASS is function WM_SHELL_CLASS return SYSTEM.ADDRESS; pragma INTERFACE (C, WM_SHELL_CLASS); pragma INTERFACE_NAME (WM_SHELL_CLASS, "wmShellFakeClass"); begin return WIDGET_CLASS (WM_SHELL_CLASS); end WM_SHELL_WIDGET_CLASS; function VENDOR_SHELL_WIDGET_CLASS return WIDGET_CLASS is function VENDOR_SHELL_CLASS return SYSTEM.ADDRESS; pragma INTERFACE (C, VENDOR_SHELL_CLASS); pragma INTERFACE_NAME (VENDOR_SHELL_CLASS, "vendorShellFakeClass"); begin return WIDGET_CLASS (VENDOR_SHELL_CLASS); end VENDOR_SHELL_WIDGET_CLASS; -------------------------------------------------------------------------------------- -- -- TYPE CONVERSION FUNCTIONS -- function TO_ADDRESS is new UNCHECKED_CONVERSION (AFS_LARGE_INTEGER, SYSTEM.ADDRESS); function TO_INTEGER is new UNCHECKED_CONVERSION (SYSTEM.ADDRESS, AFS_LARGE_INTEGER); function FLOAT_TO_INTEGER is new UNCHECKED_CONVERSION (AFS_MEDIUM_FLOAT, AFS_LARGE_INTEGER); -------------------------------------------------------------------------------------- -- -- COMMAND LINE OPTIONS -- procedure XT_MAKE_OPTION_LIST (SIZE : in AFS_MEDIUM_NATURAL; OPTION_LIST : in out XRM_OPTION_DESC_LIST) is begin if OPTION_LIST = NULL_OPTION_LIST then OPTION_LIST := new OPTION_LIST_REC (SIZE); else raise OPTION_LIST_NOT_EMPTY; end if; end XT_MAKE_OPTION_LIST; procedure XT_SET_OPTION (OPTION_LIST : in XRM_OPTION_DESC_LIST; OPTION_KIND : in XRM_OPTION_KIND; OPTION_NAME : in SYSTEM.ADDRESS; OPTION_SPEC : in SYSTEM.ADDRESS; OPTION_VALUE : in SYSTEM.ADDRESS := NULL_ADDRESS) is begin if OPTION_LIST.INDEX < OPTION_LIST.LIST'last then OPTION_LIST.INDEX := OPTION_LIST.INDEX +1; OPTION_LIST.LIST(OPTION_LIST.INDEX).OPTION_KIND := AFS_MEDIUM_NATURAL(XRM_OPTION_KIND'pos(OPTION_KIND)); OPTION_LIST.LIST(OPTION_LIST.INDEX).OPTION_NAME := OPTION_NAME; OPTION_LIST.LIST(OPTION_LIST.INDEX).SPECIFIER := OPTION_SPEC; OPTION_LIST.LIST(OPTION_LIST.INDEX).OPTION_VALUE:= OPTION_VALUE; else raise OPTION_LIST_FULL; end if; end XT_SET_OPTION; function XT_NUMBER (OPTION_LIST : in XRM_OPTION_DESC_LIST) return AFS_MEDIUM_NATURAL is begin if OPTION_LIST /= NULL_OPTION_LIST then return OPTION_LIST.INDEX; else return 0; end if; end XT_NUMBER; procedure XT_CLEAR_OPTION_LIST (OPTION_LIST : in out XRM_OPTION_DESC_LIST) is procedure FREE is new UNCHECKED_DEALLOCATION (OPTION_LIST_REC, XRM_OPTION_DESC_LIST); begin if OPTION_LIST /= null then FREE (OPTION_LIST); OPTION_LIST := null; end if; end XT_CLEAR_OPTION_LIST; -------------------------------------------------------------------------------------- -- -- TOOLKIT INITIALIZATION -- -- common function to be used by overloaded functions below function INITIALIZE (SHELL_NAME : in SYSTEM.ADDRESS; APPLICATION_CLASS : in SYSTEM.ADDRESS; OPTIONS : in SYSTEM.ADDRESS; OPTION_COUNT : in CARDINAL; ARG_COUNT : in SYSTEM.ADDRESS; ARG_VECTOR : in SYSTEM.ADDRESS) return SYSTEM.ADDRESS; pragma INTERFACE (C, INITIALIZE); pragma INTERFACE_NAME (INITIALIZE, "XtInitialize"); function XT_INITIALIZE (SHELL_NAME : in STRING; APPLICATION_CLASS : in STRING; OPTIONS : in XRM_OPTION_DESC_LIST := NULL_OPTION_LIST; ARG_COUNT : in SYSTEM.ADDRESS; ARG_VECTOR : in SYSTEM.ADDRESS) return WIDGET is TEMP_SHELL : constant STRING := SHELL_NAME & ASCII.NUL; TEMP_CLASS : constant STRING := APPLICATION_CLASS & ASCII.NUL; TEMP_WIDGET : WIDGET; begin if OPTIONS /= NULL_OPTION_LIST then TEMP_WIDGET := WIDGET (INITIALIZE (TEMP_SHELL'address, TEMP_CLASS'address, OPTIONS.LIST'address, OPTIONS.LIST'length, ARG_COUNT, ARG_VECTOR)); else TEMP_WIDGET := WIDGET (INITIALIZE (TEMP_SHELL'address, TEMP_CLASS'address, NULL_ADDRESS, 0, ARG_COUNT, ARG_VECTOR)); end if; return TEMP_WIDGET; end XT_INITIALIZE; -- function to change command line arguments to C types procedure CHANGE_CMD_LINE_ARGS_TO_C_ADDR( A_ARGC : in INTEGER; A_ARGV : in COMMAND_LINE.ARGV_PTR; C_ARGC : in out ARG_NUMBER; C_ARGV : out STR_PTR_ARRAY ) is -- local variables ARG : STR_PTR; COUNT : NATURAL := 0; begin C_ARGC := ARG_NUMBER( A_ARGC ); COUNT := 0; -- first arg while COUNT < A_ARGC loop -- put the ith command line argument in ARG ARG := new STRING (1 .. (A_ARGV(COUNT).LEN +1)); -- add one for null character ARG(1 .. (A_ARGV(COUNT).LEN +1)) := A_ARGV(COUNT).S & ASCII.NUL ; -- assign to return variable C_ARGV( ARG_NUMBER(COUNT) ) := ARG.all(1)'ADDRESS ; -- points to first character in string COUNT := COUNT +1; end loop; end CHANGE_CMD_LINE_ARGS_TO_C_ADDR; -- call this way XT_INITIALIZE ( ... ARG_COUNT => COMMAND_LINE.ARGC, -- ARG_VECTOR => COMMAND_LINE.ARGV ); function XT_INITIALIZE (SHELL_NAME : in STRING; APPLICATION_CLASS : in STRING; OPTIONS : in XRM_OPTION_DESC_LIST := NULL_OPTION_LIST; ARG_COUNT : in INTEGER; ARG_VECTOR : in COMMAND_LINE.ARGV_PTR) return WIDGET is --local variables NEW_ARGC : ARG_NUMBER; NEW_ARGV : STR_PTR_ARRAY; TEMP_SHELL : constant STRING := SHELL_NAME & ASCII.NUL; TEMP_CLASS : constant STRING := APPLICATION_CLASS & ASCII.NUL; TEMP_WIDGET : WIDGET; begin CHANGE_CMD_LINE_ARGS_TO_C_ADDR( ARG_COUNT, ARG_VECTOR, NEW_ARGC, NEW_ARGV ); if OPTIONS /= NULL_OPTION_LIST then TEMP_WIDGET := WIDGET (INITIALIZE (TEMP_SHELL'address, TEMP_CLASS'address, OPTIONS.LIST'address, OPTIONS.LIST'length, NEW_ARGC'address, NEW_ARGV'address )); else TEMP_WIDGET := WIDGET (INITIALIZE (TEMP_SHELL'address, TEMP_CLASS'address, NULL_ADDRESS, 0, NEW_ARGC'address, NEW_ARGV'address )); end if; return TEMP_WIDGET; end XT_INITIALIZE; -- end of addition -------------------------------------------------------------------------------------- -- -- CALLBACK LIST MANAGEMENT -- procedure XT_MAKE_CALLBACK_LIST (SIZE : in AFS_MEDIUM_NATURAL; CALLBACK_LIST : in out XT_CALLBACK_LIST) is begin if CALLBACK_LIST = NULL_CALLBACK_LIST then CALLBACK_LIST := new CALLBACK_LIST_REC (SIZE+1); -- add 1 for terminator else raise CALLBACK_LIST_NOT_EMPTY; end if; end XT_MAKE_CALLBACK_LIST; procedure XT_SET_CALLBACK (CALLBACK_LIST : in XT_CALLBACK_LIST; CALLBACK_PROC : in SYSTEM.ADDRESS; CLIENT_DATA : in SYSTEM.ADDRESS := NULL_ADDRESS) is begin if CALLBACK_LIST /= NULL_CALLBACK_LIST then if CALLBACK_LIST.INDEX < (CALLBACK_LIST.LIST'length -1) then CALLBACK_LIST.INDEX := CALLBACK_LIST.INDEX +1; CALLBACK_LIST.LIST(CALLBACK_LIST.INDEX).CALLBACK := CALLBACK_PROC; CALLBACK_LIST.LIST(CALLBACK_LIST.INDEX).CLIENT_DATA := CLIENT_DATA; else raise CALLBACK_LIST_FULL; end if; end if; end XT_SET_CALLBACK; procedure XT_SET_CALLBACK (CALLBACK_LIST : in XT_CALLBACK_LIST; CALLBACK_PROC : in SYSTEM.ADDRESS; CLIENT_DATA : in WIDGET) is begin XT_SET_CALLBACK (CALLBACK_LIST, CALLBACK_PROC, SYSTEM.ADDRESS(CLIENT_DATA)); end XT_SET_CALLBACK; procedure XT_SET_CALLBACK (CALLBACK_LIST : in XT_CALLBACK_LIST; PREDEFINED_PROC : in XT_PREDEFINED_CALLBACK; CLIENT_DATA : in SYSTEM.ADDRESS := NULL_ADDRESS) is ADDR : SYSTEM.ADDRESS := NULL_ADDRESS; begin case PREDEFINED_PROC is when XT_CALLBACK_NONE => ADDR := CALLBACKNONE'address; when XT_CALLBACK_NONEXCLUSIVE => ADDR := CALLBACKNONEXCLUSIVE'address; when XT_CALLBACK_EXCLUSIVE => ADDR := CALLBACKEXCLUSIVE'address; when XT_CALLBACK_POPDOWN => ADDR := CALLBACKPOPDOWN'address; end case; XT_SET_CALLBACK (CALLBACK_LIST, ADDR, CLIENT_DATA); end XT_SET_CALLBACK; procedure XT_SET_CALLBACK (CALLBACK_LIST : in XT_CALLBACK_LIST; PREDEFINED_PROC : in XT_PREDEFINED_CALLBACK; CLIENT_DATA : in WIDGET) is ADDR : SYSTEM.ADDRESS := NULL_ADDRESS; begin case PREDEFINED_PROC is when XT_CALLBACK_NONE => ADDR := CALLBACKNONE'address; when XT_CALLBACK_NONEXCLUSIVE => ADDR := CALLBACKNONEXCLUSIVE'address; when XT_CALLBACK_EXCLUSIVE => ADDR := CALLBACKEXCLUSIVE'address; when XT_CALLBACK_POPDOWN => ADDR := CALLBACKPOPDOWN'address; end case; XT_SET_CALLBACK (CALLBACK_LIST, ADDR, SYSTEM.ADDRESS(CLIENT_DATA)); end XT_SET_CALLBACK; function XT_NUMBER (CALLBACK_LIST : in XT_CALLBACK_LIST) return AFS_MEDIUM_NATURAL is begin if CALLBACK_LIST /= NULL_CALLBACK_LIST then return CALLBACK_LIST.INDEX; else return 0; end if; end XT_NUMBER; procedure XT_CLEAR_CALLBACK_LIST (CALLBACK_LIST : in out XT_CALLBACK_LIST) is procedure FREE is new UNCHECKED_DEALLOCATION (CALLBACK_LIST_REC, XT_CALLBACK_LIST); begin if CALLBACK_LIST /= NULL_CALLBACK_LIST then FREE (CALLBACK_LIST); CALLBACK_LIST := null; end if; end XT_CLEAR_CALLBACK_LIST; -------------------------------------------------------------------------------------- -- -- CALLBACKS FOR WIDGETS -- procedure ADDCALLBACK (W : in SYSTEM.ADDRESS; KIND : in XTN_RESOURCE_STRING; PROC : in SYSTEM.ADDRESS; DATA : in SYSTEM.ADDRESS); pragma INTERFACE (C, ADDCALLBACK); pragma INTERFACE_NAME (ADDCALLBACK, "XtAddCallback"); procedure XT_ADD_CALLBACK (TO : in WIDGET; KIND : in XTN_RESOURCE_STRING; CALLBACK : in SYSTEM.ADDRESS; CLIENT_DATA : in SYSTEM.ADDRESS := NULL_ADDRESS) is begin ADDCALLBACK (W => SYSTEM.ADDRESS(TO), KIND => KIND, PROC => CALLBACK, DATA => CLIENT_DATA); end XT_ADD_CALLBACK; procedure XT_ADD_CALLBACK (TO : in WIDGET; KIND : in XTN_RESOURCE_STRING; CALLBACK : in SYSTEM.ADDRESS; CLIENT_DATA : in WIDGET) is begin ADDCALLBACK (W => SYSTEM.ADDRESS(TO), KIND => KIND, PROC => CALLBACK, DATA => SYSTEM.ADDRESS(CLIENT_DATA)); end XT_ADD_CALLBACK; procedure XT_ADD_CALLBACK (TO : in WIDGET; KIND : in XTN_RESOURCE_STRING; CALLBACK : in SYSTEM.ADDRESS; CLIENT_DATA : in AFS_LARGE_INTEGER) is begin ADDCALLBACK (W => SYSTEM.ADDRESS(TO), KIND => KIND, PROC => CALLBACK, DATA => TO_ADDRESS (CLIENT_DATA)); end XT_ADD_CALLBACK; procedure XT_ADD_CALLBACK (TO : in WIDGET; KIND : in XTN_RESOURCE_STRING; PREDEFINED_PROC : in XT_PREDEFINED_CALLBACK; CLIENT_DATA : in SYSTEM.ADDRESS := NULL_ADDRESS) is ADDR : SYSTEM.ADDRESS := NULL_ADDRESS; begin case PREDEFINED_PROC is when XT_CALLBACK_NONE => ADDR := CALLBACKNONE'address; when XT_CALLBACK_NONEXCLUSIVE => ADDR := CALLBACKNONEXCLUSIVE'address; when XT_CALLBACK_EXCLUSIVE => ADDR := CALLBACKEXCLUSIVE'address; when XT_CALLBACK_POPDOWN => ADDR := CALLBACKPOPDOWN'address; end case; ADDCALLBACK (W => SYSTEM.ADDRESS(TO), KIND => KIND, PROC => ADDR, DATA => CLIENT_DATA); end XT_ADD_CALLBACK; procedure XT_ADD_CALLBACK (TO : in WIDGET; KIND : in XTN_RESOURCE_STRING; PREDEFINED_PROC : in XT_PREDEFINED_CALLBACK; CLIENT_DATA : in WIDGET) is ADDR : SYSTEM.ADDRESS := NULL_ADDRESS; begin case PREDEFINED_PROC is when XT_CALLBACK_NONE => ADDR := CALLBACKNONE'address; when XT_CALLBACK_NONEXCLUSIVE => ADDR := CALLBACKNONEXCLUSIVE'address; when XT_CALLBACK_EXCLUSIVE => ADDR := CALLBACKEXCLUSIVE'address; when XT_CALLBACK_POPDOWN => ADDR := CALLBACKPOPDOWN'address; end case; ADDCALLBACK (W => SYSTEM.ADDRESS(TO), KIND => KIND, PROC => ADDR, DATA => SYSTEM.ADDRESS(CLIENT_DATA)); end XT_ADD_CALLBACK; procedure XT_ADD_CALLBACKS (TO : in WIDGET; KIND : in XTN_RESOURCE_STRING; CALLBACKS : in XT_CALLBACK_LIST) is procedure XTADDCALLBACKS (TO : in SYSTEM.ADDRESS; KIND : in XTN_RESOURCE_STRING; CALLBACKS : in SYSTEM.ADDRESS); pragma INTERFACE (C, XTADDCALLBACKS); pragma INTERFACE_NAME (XTADDCALLBACKS, "XtAddCallbacks"); begin if CALLBACKS /= NULL_CALLBACK_LIST and then CALLBACKS.INDEX > 0 then XTADDCALLBACKS (SYSTEM.ADDRESS(TO), KIND, CALLBACKS.LIST'address); else raise CALLBACK_LIST_EMPTY; end if; end XT_ADD_CALLBACKS; procedure XT_REMOVE_CALLBACKS (FROM : in WIDGET; KIND : in XTN_RESOURCE_STRING; CALLBACKS : in XT_CALLBACK_LIST) is procedure XTREMOVECALLBACKS (FROM : in SYSTEM.ADDRESS; KIND : in XTN_RESOURCE_STRING; CALLBACKS : in SYSTEM.ADDRESS); pragma INTERFACE (C, XTREMOVECALLBACKS); pragma INTERFACE_NAME (XTREMOVECALLBACKS, "XtRemoveCallbacks"); begin if CALLBACKS /= NULL_CALLBACK_LIST and then CALLBACKS.INDEX > 0 then XTREMOVECALLBACKS (SYSTEM.ADDRESS(FROM), KIND, CALLBACKS.LIST'address); else raise CALLBACK_LIST_EMPTY; end if; end XT_REMOVE_CALLBACKS; procedure XT_CALL_CALLBACKS (FROM : in WIDGET; KIND : in XTN_RESOURCE_STRING; CALL_DATA : in SYSTEM.ADDRESS := NULL_ADDRESS) is procedure CALLCALLBACKS (FROM : in SYSTEM.ADDRESS; KIND : in XTN_RESOURCE_STRING; CALL_DATA : in SYSTEM.ADDRESS); pragma INTERFACE (C, CALLCALLBACKS); pragma INTERFACE_NAME (CALLCALLBACKS, "XtCallCallbacks"); begin CALLCALLBACKS (SYSTEM.ADDRESS(FROM), KIND, CALL_DATA); end XT_CALL_CALLBACKS; procedure REMOVECALLBACK (FROM_WIDGET : in SYSTEM.ADDRESS; KIND : in XTN_RESOURCE_STRING; CALLBACK : in SYSTEM.ADDRESS; CLIENT_DATA : in SYSTEM.ADDRESS); pragma INTERFACE (C, REMOVECALLBACK); pragma INTERFACE_NAME (REMOVECALLBACK, "XtRemoveCallback"); procedure XT_REMOVE_CALLBACK (FROM : in WIDGET; KIND : in XTN_RESOURCE_STRING; CALLBACK : in SYSTEM.ADDRESS; CLIENT_DATA : in SYSTEM.ADDRESS := NULL_ADDRESS) is begin REMOVECALLBACK (SYSTEM.ADDRESS(FROM), KIND, CALLBACK, CLIENT_DATA); end XT_REMOVE_CALLBACK; procedure XT_REMOVE_CALLBACK (FROM : in WIDGET; KIND : in XTN_RESOURCE_STRING; CALLBACK : in SYSTEM.ADDRESS; CLIENT_DATA : in WIDGET) is begin REMOVECALLBACK (SYSTEM.ADDRESS(FROM), KIND, CALLBACK, SYSTEM.ADDRESS(CLIENT_DATA)); end XT_REMOVE_CALLBACK; procedure XT_REMOVE_CALLBACK (FROM : in WIDGET; KIND : in XTN_RESOURCE_STRING; CALLBACK : in XT_PREDEFINED_CALLBACK; CLIENT_DATA : in SYSTEM.ADDRESS := NULL_ADDRESS) is ADDR : SYSTEM.ADDRESS := NULL_ADDRESS; begin case CALLBACK is when XT_CALLBACK_NONE => ADDR := CALLBACKNONE'address; when XT_CALLBACK_NONEXCLUSIVE => ADDR := CALLBACKNONEXCLUSIVE'address; when XT_CALLBACK_EXCLUSIVE => ADDR := CALLBACKEXCLUSIVE'address; when XT_CALLBACK_POPDOWN => ADDR := CALLBACKPOPDOWN'address; end case; REMOVECALLBACK (SYSTEM.ADDRESS(FROM), KIND, ADDR, CLIENT_DATA); end XT_REMOVE_CALLBACK; procedure XT_REMOVE_CALLBACK (FROM : in WIDGET; KIND : in XTN_RESOURCE_STRING; CALLBACK : in XT_PREDEFINED_CALLBACK; CLIENT_DATA : in WIDGET) is ADDR : SYSTEM.ADDRESS := NULL_ADDRESS; begin case CALLBACK is when XT_CALLBACK_NONE => ADDR := CALLBACKNONE'address; when XT_CALLBACK_NONEXCLUSIVE => ADDR := CALLBACKNONEXCLUSIVE'address; when XT_CALLBACK_EXCLUSIVE => ADDR := CALLBACKEXCLUSIVE'address; when XT_CALLBACK_POPDOWN => ADDR := CALLBACKPOPDOWN'address; end case; REMOVECALLBACK (SYSTEM.ADDRESS(FROM), KIND, ADDR, SYSTEM.ADDRESS(CLIENT_DATA)); end XT_REMOVE_CALLBACK; procedure XT_REMOVE_ALL_CALLBACKS (FROM : in WIDGET; KIND : in XTN_RESOURCE_STRING) is procedure REMOVEALL (FROM : in SYSTEM.ADDRESS; KIND : in XTN_RESOURCE_STRING); pragma INTERFACE (C, REMOVEALL); pragma INTERFACE_NAME (REMOVEALL, "XtRemoveAllCallbacks"); begin REMOVEALL (SYSTEM.ADDRESS(FROM), KIND); end XT_REMOVE_ALL_CALLBACKS; -------------------------------------------------------------------------------------- -- -- ARGUMENT LISTS -- procedure XT_MAKE_ARG_LIST (SIZE : in AFS_MEDIUM_NATURAL := 50; ARGS : in out ARG_LIST) is begin if ARGS = NULL_ARG_LIST then ARGS := new ARG_LIST_REC (SIZE); else raise ARG_LIST_NOT_EMPTY; end if; end XT_MAKE_ARG_LIST; procedure XT_CLEAR_ARG_LIST (ARGS : in out ARG_LIST) is procedure FREE_ARG_LIST is new UNCHECKED_DEALLOCATION (ARG_LIST_REC, ARG_LIST); begin if ARGS /= NULL then FREE_ARG_LIST (ARGS); ARGS := NULL_ARG_LIST; end if; end XT_CLEAR_ARG_LIST; -- XT_NUMBER returns the number of Arg_list_rec's that are -- filled in ARGS. function XT_NUMBER (ARGS : in ARG_LIST) return AFS_MEDIUM_NATURAL is begin if ARGS /= NULL_ARG_LIST then return ARGS.INDEX; else return 0; end if; end Xt_NUMBER; -- XT_SET_ARG for INTEGER type arguments- procedure XT_SET_ARG (ARGS : in ARG_LIST; NAME : in XTN_RESOURCE_STRING; VALUE : in AFS_LARGE_INTEGER) is begin if ARGS /= NULL_ARG_LIST then if ARGS.all.INDEX < ARGS.all.LIST'last then ARGS.all.INDEX := ARGS.all.INDEX +1; ARGS.all.LIST(ARGS.all.INDEX).NAME := NAME; ARGS.all.LIST(ARGS.all.INDEX).VALUE := VALUE; else raise ARG_LIST_FULL; end if; else raise ARG_LIST_EMPTY; -- emu 02/07/89 end if; end XT_SET_ARG; -- XT_SET_ARG for FLOAT type argument- procedure XT_SET_ARG (ARGS : in ARG_LIST; NAME : in XTN_RESOURCE_STRING; VALUE : in AFS_MEDIUM_FLOAT) is begin XT_SET_ARG (ARGS => ARGS, NAME => NAME, VALUE => FLOAT_TO_INTEGER (VALUE)); end XT_SET_ARG; -- XT_SET_ARG for BOOLEAN type arguments procedure XT_SET_ARG (ARGS : in ARG_LIST; NAME : in XTN_RESOURCE_STRING; VALUE : in BOOLEAN) is begin XT_SET_ARG ( ARGS => ARGS, NAME => NAME, VALUE => AFS_LARGE_INTEGER (BOOLEAN'pos (VALUE))); end XT_SET_ARG; -- XT_SET_ARG for SYSTEM.ADDRESS type arguments procedure XT_SET_ARG (ARGS : in ARG_LIST; NAME : in XTN_RESOURCE_STRING; VALUE : in SYSTEM.ADDRESS) is begin XT_SET_ARG (ARGS => ARGS, NAME => NAME, VALUE => TO_INTEGER (VALUE)); end XT_SET_ARG; procedure XT_SET_ARG (ARGS : in ARG_LIST; NAME : in XTN_RESOURCE_STRING; VALUE : in WIDGET) is begin XT_SET_ARG (ARGS => ARGS, NAME => NAME, VALUE => SYSTEM.ADDRESS(VALUE)); end XT_SET_ARG; -- XT_SET_ARG for XT_CALLBACK_LIST type arguments procedure XT_SET_ARG (ARGS : in ARG_LIST; NAME : in XTN_RESOURCE_STRING; VALUE : in XT_CALLBACK_LIST) is begin XT_SET_ARG (ARGS => ARGS, NAME => NAME, VALUE => TO_INTEGER(VALUE.LIST'address)); end XT_SET_ARG; -- XT_SET_ARG for CHARACTER type arguments procedure XT_SET_ARG (ARGS : in ARG_LIST; NAME : in XTN_RESOURCE_STRING; VALUE : in CHARACTER) is TEMP : AFS_LARGE_INTEGER; begin TEMP := CHARACTER'pos(VALUE); XT_SET_ARG (ARGS => ARGS, NAME => NAME, VALUE => TEMP); end XT_SET_ARG; procedure XT_MERGE_ARG_LISTS (ARGS_1 : in ARG_LIST; ARGS_2 : in ARG_LIST; RESULT : in out ARG_LIST) is begin XT_CLEAR_ARG_LIST (RESULT); XT_MAKE_ARG_LIST ((XT_NUMBER(ARGS_1) + XT_NUMBER(ARGS_2)), RESULT); RESULT.LIST := ARGS_1.LIST (1..XT_NUMBER(ARGS_1)) & ARGS_2.LIST (1..XT_NUMBER(ARGS_2)); RESULT.INDEX := XT_NUMBER(ARGS_1) + XT_NUMBER(ARGS_2); end XT_MERGE_ARG_LISTS; -------------------------------------------------------------------------------------- -- -- WIDGET_MANIPULATION -- -- -- WIDGET LIST MANAGEMENT -- procedure XT_MAKE_WIDGET_LIST (SIZE : in AFS_MEDIUM_NATURAL; LIST : in out WIDGET_LIST) is begin if LIST = NULL_WIDGET_LIST then LIST := new WIDGET_LIST_REC (SIZE); else raise WIDGET_LIST_NOT_EMPTY; end if; end XT_MAKE_WIDGET_LIST; procedure XT_SET_WIDGET (LIST : in WIDGET_LIST; W : in WIDGET) is begin if LIST.INDEX < LIST.LIST'last then LIST.INDEX := LIST.INDEX + 1; LIST.LIST(LIST.INDEX) := W; else raise WIDGET_LIST_FULL; end if; end XT_SET_WIDGET; function XT_NUMBER (LIST : in WIDGET_LIST) return AFS_MEDIUM_NATURAL is begin if LIST = NULL_WIDGET_LIST then return 0; else return LIST.INDEX; end if; end XT_NUMBER; procedure XT_CLEAR_WIDGET_LIST (LIST : in out WIDGET_LIST) is procedure FREE is new UNCHECKED_DEALLOCATION (WIDGET_LIST_REC, WIDGET_LIST); begin if LIST /= NULL_WIDGET_LIST then FREE(LIST); LIST := NULL_WIDGET_LIST; end if; end; -- -- WIDGET CREATION -- function XT_CREATE_WIDGET ( NAME : in STRING; CLASS : in WIDGET_CLASS; PARENT : in WIDGET; ARGS : in ARG_LIST := NULL_ARG_LIST) return WIDGET is function XTCREATE ( NAME : in SYSTEM.ADDRESS; CLASS : in WIDGET_CLASS; PARENT : in WIDGET; ARGS : in SYSTEM.ADDRESS; COUNT : in CARDINAL) return SYSTEM.ADDRESS; pragma INTERFACE (C, XTCREATE); pragma INTERFACE_NAME (XTCREATE, "XtCreateWidget"); TEMP_NAME : constant STRING := NAME & ASCII.NUL; begin if ARGS /= NULL_ARG_LIST then return WIDGET (XTCREATE (TEMP_NAME'address, CLASS, PARENT, ARGS.all.LIST'address, CARDINAL(ARGS.all.INDEX))); else return WIDGET (XTCREATE (TEMP_NAME'address, CLASS, PARENT, NULL_ADDRESS, 0)); end if; end XT_CREATE_WIDGET; -- XT_CREATE_APPLICATION_SHELL converts the NAME into a C-string, -- allows the user to use the XT_NUMBER so the user wont have to -- for ARGS, and converts ARGS to a C-type. function XT_CREATE_APPLICATION_SHELL ( NAME : in STRING; CLASS : in WIDGET_CLASS; ARGS : in ARG_LIST := NULL_ARG_LIST) return WIDGET is function XTCREATEAPPLICATIONSHELL ( NAME : in SYSTEM.ADDRESS; CLASS : in SYSTEM.ADDRESS; ARGS : in SYSTEM.ADDRESS; COUNT : in CARDINAL) return SYSTEM.ADDRESS; pragma INTERFACE (C, XTCREATEAPPLICATIONSHELL); pragma INTERFACE_NAME(XTCREATEAPPLICATIONSHELL,"XtCreateApplicationShell"); TEMP_NAME : constant STRING := NAME & ASCII.NUL; begin if ARGS /= NULL_ARG_LIST then return WIDGET (XTCREATEAPPLICATIONSHELL (TEMP_NAME'address, SYSTEM.ADDRESS(CLASS), ARGS.all.LIST'address, CARDINAL(ARGS.INDEX))); else return WIDGET (XTCREATEAPPLICATIONSHELL (TEMP_NAME'address, SYSTEM.ADDRESS(CLASS), NULL_ADDRESS, 0)); end if; end XT_CREATE_APPLICATION_SHELL; -- XT_CREATE_POPUP_SHELL converts the NAME into a C-string, -- allows the user to use the XT_NUMBER so the user wont have to -- for ARGS, and converts ARGS to a C-type. function XT_CREATE_POPUP_SHELL ( NAME : in STRING; CLASS : in WIDGET_CLASS; PARENT : in WIDGET; ARGS : in ARG_LIST := NULL_ARG_LIST) return WIDGET is function XTCREATEPOPUP (NAME : in SYSTEM.ADDRESS; CLASS : in SYSTEM.ADDRESS; PARENT : in SYSTEM.ADDRESS; ARGS : in SYSTEM.ADDRESS; COUNT : in CARDINAL) return SYSTEM.ADDRESS; pragma INTERFACE (C, XTCREATEPOPUP); pragma INTERFACE_NAME (XTCREATEPOPUP, "XtCreatePopupShell"); TEMP_NAME : constant STRING := NAME & ASCII.NUL; begin if ARGS /= NULL_ARG_LIST then return WIDGET (XTCREATEPOPUP (TEMP_NAME'address, SYSTEM.ADDRESS(CLASS), SYSTEM.ADDRESS(PARENT), ARGS.all.LIST'address, CARDINAL(ARGS.INDEX))); else return WIDGET (XTCREATEPOPUP (TEMP_NAME'address, SYSTEM.ADDRESS(CLASS), SYSTEM.ADDRESS(PARENT), NULL_ADDRESS, 0)); end if; end XT_CREATE_POPUP_SHELL; -- XT_CREATE_MANAGED_WIDGET converts the NAME into a C-string, -- allows the user to use the XT_NUMBER so the user wont have to -- for ARGS, and converts ARGS to a C-type. function XT_CREATE_MANAGED_WIDGET (NAME : in STRING; CLASS : in WIDGET_CLASS; PARENT : in WIDGET; ARGS : in ARG_LIST := NULL_ARG_LIST) return WIDGET is function XTCREATEMANAGED (NAME : in SYSTEM.ADDRESS; CLASS : in SYSTEM.ADDRESS; PARENT : in SYSTEM.ADDRESS; ARGS : in SYSTEM.ADDRESS; COUNT : in CARDINAL) return SYSTEM.ADDRESS; pragma INTERFACE (C, XTCREATEMANAGED); pragma INTERFACE_NAME (XTCREATEMANAGED, "XtCreateManagedWidget"); TEMP_NAME : constant STRING := NAME & ASCII.NUL; begin if ARGS /= NULL_ARG_LIST then return WIDGET (XTCREATEMANAGED (TEMP_NAME'address, SYSTEM.ADDRESS(CLASS), SYSTEM.ADDRESS(PARENT), ARGS.all.LIST'address, CARDINAL(ARGS.INDEX))); else return WIDGET (XTCREATEMANAGED (TEMP_NAME'address, SYSTEM.ADDRESS(CLASS), SYSTEM.ADDRESS(PARENT), NULL_ADDRESS, 0)); end if; end XT_CREATE_MANAGED_WIDGET; -- -- WIDGET CHILDCARE -- -- XT_MANAGE_CHILDREN converts the array CHILDREN into the -- C array and the count of elements. procedure XT_MANAGE_CHILDREN (CHILDREN : in WIDGET_LIST) is procedure XTMANAGECHILDREN (KIDS : in SYSTEM.ADDRESS; NUM_KIDS : in CARDINAL); pragma INTERFACE (C, XTMANAGECHILDREN); pragma INTERFACE_NAME (XTMANAGECHILDREN, "XtManageChildren"); begin XTMANAGECHILDREN (CHILDREN.LIST'address, CARDINAL(CHILDREN.INDEX)); end XT_MANAGE_CHILDREN; -- XT_UNMANAGE_CHILDREN converts the array CHILDREN into the -- C array and the count of elements. procedure XT_UNMANAGE_CHILDREN (CHILDREN : in WIDGET_LIST) is procedure XTUNMANAGECHILDREN (KIDS : in SYSTEM.ADDRESS; NUMBER_KIDS : in CARDINAL); pragma INTERFACE (C, XTUNMANAGECHILDREN); pragma INTERFACE_NAME (XTUNMANAGECHILDREN, "XtUnmanageChildren"); begin XTUNMANAGECHILDREN (CHILDREN.LIST'address, CARDINAL(CHILDREN.INDEX)); end XT_UNMANAGE_CHILDREN; procedure XT_MANAGE_CHILD (CHILD : in WIDGET) is procedure MANAGECHILD (CHILD : in SYSTEM.ADDRESS); pragma INTERFACE (C, MANAGECHILD); pragma INTERFACE_NAME (MANAGECHILD, "XtManageChild"); begin MANAGECHILD (SYSTEM.ADDRESS(CHILD)); end XT_MANAGE_CHILD; procedure XT_UNMANAGE_CHILD (CHILD : in WIDGET) is procedure UNMANAGECHILD (CHILD : in SYSTEM.ADDRESS); pragma INTERFACE (C, UNMANAGECHILD); pragma INTERFACE_NAME (UNMANAGECHILD, "XtUnmanageChild"); begin UNMANAGECHILD (SYSTEM.ADDRESS(CHILD)); end XT_UNMANAGE_CHILD; -- -- REALIZE/MAP WIDGETS -- -- XT_MAP_WIDGET is a macro in C. We convert it to the -- appropriate calls. procedure XT_MAP_WIDGET (W : in WIDGET) is procedure X_MAP_WINDOW (DISPLAY : SYSTEM.ADDRESS; WINDOW : XLIB.WINDOW_ID); pragma INTERFACE (C, X_MAP_WINDOW); pragma INTERFACE_NAME (X_MAP_WINDOW, "XMapWindow"); begin X_MAP_WINDOW (DISPLAY => XLIB.DISPLAY_POINTER_TO_ADDR ((XT_DISPLAY (W))), WINDOW => XT_WINDOW (W)); end XT_MAP_WIDGET; -- XT_UNMAP_WIDGET is a macro in C. We convert it to the -- appropriate calls. procedure XT_UNMAP_WIDGET (W : in WIDGET) is procedure X_UNMAP_WINDOW (DISPLAY : SYSTEM.ADDRESS; WINDOW : XLIB.WINDOW_ID); pragma INTERFACE (C, X_UNMAP_WINDOW); pragma INTERFACE_NAME (X_UNMAP_WINDOW, "XUnmapWindow"); begin X_UNMAP_WINDOW (DISPLAY => XLIB.DISPLAY_POINTER_TO_ADDR((XT_DISPLAY (W))), WINDOW => XT_WINDOW (W)); end XT_UNMAP_WIDGET; procedure XT_REALIZE_WIDGET (W : in WIDGET) is procedure REALIZE (W : in SYSTEM.ADDRESS); pragma INTERFACE (C, REALIZE); pragma INTERFACE_NAME (REALIZE, "XtRealizeWidget"); begin REALIZE (SYSTEM.ADDRESS (W)); end XT_REALIZE_WIDGET; -- -- DESTROY WIDGETS -- procedure XT_DESTROY_WIDGET (W : in WIDGET) is procedure DESTROY (W : in SYSTEM.ADDRESS); pragma INTERFACE (C, DESTROY); pragma INTERFACE_NAME (DESTROY, "XtDestroyWidget"); begin DESTROY (SYSTEM.ADDRESS (W)); end XT_DESTROY_WIDGET; -- -- GETTING/SETTING WIDGET STATE -- procedure XT_SET_VALUES (W : in WIDGET; ARGS : in ARG_LIST) is procedure XTSETVALUES (W : SYSTEM.ADDRESS; ARGS : SYSTEM.ADDRESS; NUM_ARGS : CARDINAL); pragma INTERFACE (C, XTSETVALUES); pragma INTERFACE_NAME (XTSETVALUES, "XtSetValues"); begin if ARGS /= NULL_ARG_LIST then XTSETVALUES (SYSTEM.ADDRESS(W), ARGS.all.LIST'address, CARDINAL(XT_NUMBER(ARGS))); else raise ARG_LIST_EMPTY; end if; end XT_SET_VALUES; procedure XT_GET_VALUES (W : in WIDGET; ARGS : in ARG_LIST) is procedure XTGETVALUES (WIDG : in SYSTEM.ADDRESS; ARGS : in SYSTEM.ADDRESS; COUNT : in CARDINAL); pragma INTERFACE (C, XTGETVALUES); pragma INTERFACE_NAME (XTGETVALUES, "XtGetValues"); begin if ARGS /= NULL_ARG_LIST then XTGETVALUES (SYSTEM.ADDRESS(W), ARGS.all.LIST'ADDRESS, CARDINAL(XT_NUMBER(ARGS))); else raise ARG_LIST_EMPTY; end if; end XT_GET_VALUES; -- -- CONVERSION FUNCTIONS ( Used in creating Ada bindings to C ) -- function ADDR_TO_WIDGET ( ADDR : SYSTEM.ADDRESS ) return WIDGET is begin return WIDGET ( ADDR ); end ADDR_TO_WIDGET; function WIDGET_TO_ADDR ( W: WIDGET ) return SYSTEM.ADDRESS is begin return SYSTEM.ADDRESS(W); end WIDGET_TO_ADDR; -- -- WIDGET MISC. -- procedure XT_SET_SENSITIVE (W : in WIDGET; SENSITIVE : in BOOLEAN) is procedure XTSETSENSITIVE (WIDG : in SYSTEM.ADDRESS; SENSITIVE : in AFS_LARGE_INTEGER); pragma INTERFACE (C, XTSETSENSITIVE); pragma INTERFACE_NAME (XTSETSENSITIVE, "XtSetSensitive"); begin XTSETSENSITIVE (SYSTEM.ADDRESS(W), AFS_LARGE_INTEGER (BOOLEAN'pos (SENSITIVE))); end XT_SET_SENSITIVE; -- XT_SET_MAPPED_WHEN_MANAGED converts the MAPPED_WHEN_MANAGED -- boolean into a C integer. procedure XT_SET_MAPPED_WHEN_MANAGED (W : in WIDGET; MAPPED : in BOOLEAN) is procedure XTSETMAPPEDWHENMANAGED (W : in WIDGET; MWM : in AFS_LARGE_INTEGER); pragma INTERFACE (C, XTSETMAPPEDWHENMANAGED); pragma INTERFACE_NAME (XTSETMAPPEDWHENMANAGED, "XtSetMappedWhenManaged"); begin XTSETMAPPEDWHENMANAGED (W, AFS_LARGE_INTEGER (BOOLEAN'pos (MAPPED))); end XT_SET_MAPPED_WHEN_MANAGED; -------------------------------------------------------------------------------------- -- -- POPUP SHELLS -- procedure XT_POPUP (POPUP_SHELL : in WIDGET; GRAB_KIND : in XT_GRAB_KIND) is procedure POPUP (SHELL : in SYSTEM.ADDRESS; KIND : in AFS_LARGE_INTEGER); pragma INTERFACE (C, POPUP); pragma INTERFACE_NAME (POPUP, "XtPopup"); begin POPUP (SYSTEM.ADDRESS (POPUP_SHELL), AFS_LARGE_INTEGER (XT_GRAB_KIND'pos(GRAB_KIND))); end XT_POPUP; procedure XT_POPDOWN (POPUP_SHELL : in WIDGET) is procedure POPDOWN (POPUP_SHELL : in SYSTEM.ADDRESS); pragma INTERFACE (C, POPDOWN); pragma INTERFACE_NAME (POPDOWN, "XtPopdown"); begin POPDOWN (SYSTEM.ADDRESS(POPUP_SHELL)); end XT_POPDOWN; -------------------------------------------------------------------------------------- -- -- QUERIES -- function XT_CLASS (W : in WIDGET) return WIDGET_CLASS is function CLASS (W : in SYSTEM.ADDRESS) return SYSTEM.ADDRESS; pragma INTERFACE (C, CLASS); pragma INTERFACE_NAME (CLASS, "XtClass"); begin return WIDGET_CLASS (CLASS(SYSTEM.ADDRESS(W))); end XT_CLASS; function XT_SUPERCLASS (W : in WIDGET) return WIDGET_CLASS is function SUPERCLASS (W : in SYSTEM.ADDRESS) return SYSTEM.ADDRESS; pragma INTERFACE (C, SUPERCLASS); pragma INTERFACE_NAME (SUPERCLASS, "XtSuperclass"); begin return WIDGET_CLASS (SUPERCLASS(SYSTEM.ADDRESS(W))); end XT_SUPERCLASS; function XT_IS_SUBCLASS (W : in WIDGET; CLASS : in WIDGET_CLASS) return BOOLEAN is function ISSUBCLASS (W : in SYSTEM.ADDRESS; CLASS : in SYSTEM.ADDRESS) return AFS_LARGE_INTEGER; pragma INTERFACE (C, ISSUBCLASS); pragma INTERFACE_NAME (ISSUBCLASS, "XtIsSubclass"); begin if ISSUBCLASS (SYSTEM.ADDRESS(W), SYSTEM.ADDRESS(CLASS)) = 0 then return FALSE; else return TRUE; end if; end XT_IS_SUBCLASS; function XT_IS_COMPOSITE (W : in WIDGET) return BOOLEAN is begin return XT_IS_SUBCLASS (W, COMPOSITE_WIDGET_CLASS); end XT_IS_COMPOSITE; -- XT_IS_REALIZED converts the integer returned from the C call into -- a Ada boolean value. function XT_IS_REALIZED (W : in WIDGET) return BOOLEAN is function ISREALIZED (W : in SYSTEM.ADDRESS) return AFS_LARGE_INTEGER; pragma INTERFACE (C, ISREALIZED); pragma INTERFACE_NAME (ISREALIZED, "XtIsRealized"); begin if ISREALIZED(SYSTEM.ADDRESS(W)) = 0 then return FALSE; else return TRUE; end if; end XT_IS_REALIZED; function XT_HAS_CALLBACKS (W : in WIDGET; KIND : XTN_RESOURCE_STRING) return XT_CALLBACK_STATUS is function HAS_CALLBACKS (W : in SYSTEM.ADDRESS; KIND : XTN_RESOURCE_STRING) return AFS_LARGE_INTEGER; pragma INTERFACE (C, HAS_CALLBACKS); pragma INTERFACE_NAME (HAS_CALLBACKS, "XtHasCallbacks"); begin return XT_CALLBACK_STATUS'val(HAS_CALLBACKS(SYSTEM.ADDRESS(W), KIND)); end XT_HAS_CALLBACKS; function XT_PARENT (W : in WIDGET) return WIDGET is function PARENT (W : in SYSTEM.ADDRESS) return SYSTEM.ADDRESS; pragma INTERFACE (C, PARENT); pragma INTERFACE_NAME (PARENT, "XtParent"); begin return WIDGET(PARENT(SYSTEM.ADDRESS(W))); end XT_PARENT; function XT_WINDOW( W : in WIDGET ) return XLIB.WINDOW_ID is function XTWINDOW( W: in WIDGET ) return XLIB.WINDOW_ID; pragma INTERFACE( C,XTWINDOW); pragma INTERFACE_NAME( XTWINDOW,"XtWindow"); begin return( XTWINDOW( W )); end XT_WINDOW; function XT_DISPLAY (W : in WIDGET) return XLIB.DISPLAY_POINTER is function DISPLAY (W : in SYSTEM.ADDRESS) return SYSTEM.ADDRESS; pragma INTERFACE (C, DISPLAY); pragma INTERFACE_NAME (DISPLAY, "XtDisplay"); begin return XLIB.ADDR_TO_DISPLAY_POINTER(DISPLAY(SYSTEM.ADDRESS(W))); end XT_DISPLAY; function XT_SCREEN (W : in WIDGET) return XLIB.SCREEN_POINTER is function SCREEN (W : in SYSTEM.ADDRESS) return XLIB.SCREEN_POINTER; pragma INTERFACE (C, SCREEN); pragma INTERFACE_NAME (SCREEN, "XtScreen"); begin return (SCREEN(SYSTEM.ADDRESS(W))); end XT_SCREEN; function BLACK_PIXEL_OF_SCREEN (SCREEN : in XLIB.SCREEN_POINTER) return PIXEL is function BLACKPIXEL (SCREEN : in SYSTEM.ADDRESS) return PIXEL; pragma INTERFACE (C, BLACKPIXEL); pragma INTERFACE_NAME (BLACKPIXEL, "XBlackPixelOfScreen"); begin return BLACKPIXEL (XLIB.SCREEN_POINTER_TO_ADDR(SCREEN)); end BLACK_PIXEL_OF_SCREEN; function WHITE_PIXEL_OF_SCREEN (SCREEN : in XLIB.SCREEN_POINTER) return PIXEL is function WHITEPIXEL (SCREEN : in SYSTEM.ADDRESS) return PIXEL; pragma INTERFACE (C, WHITEPIXEL); pragma INTERFACE_NAME (WHITEPIXEL, "XWhitePixelOfScreen"); begin return WHITEPIXEL (XLIB.SCREEN_POINTER_TO_ADDR(SCREEN)); end WHITE_PIXEL_OF_SCREEN; -- -- TRANSLATE COORDINATES -- procedure XT_TRANSLATE_COORDS (W : in WIDGET; X : in POSITION; Y : in POSITION; RX : out POSITION; RY : out POSITION) is procedure XTTRANSLATECOORDS (W : in SYSTEM.ADDRESS; X : in POSITION; Y : in POSITION; RX : in SYSTEM.ADDRESS; RY : in SYSTEM.ADDRESS); pragma INTERFACE (C, XTTRANSLATECOORDS); pragma INTERFACE_NAME (XTTRANSLATECOORDS, "XtTranslateCoords"); LOCAL_RX : POSITION := 0; LOCAL_RY : POSITION := 0; begin XTTRANSLATECOORDS (SYSTEM.ADDRESS(W), X, Y, LOCAL_RX'address, LOCAL_RY'address); RX := LOCAL_RX; RY := LOCAL_RY; end XT_TRANSLATE_COORDS; -------------------------------------------------------------------------------------- -- -- EVENTS -- -- EVENT HANDLING FAKES -- -- CURRENT_EVENT is a C function that was created for purposes of the Ada Binding. -- current_event is found in spc_binding.c. -- This was needed to define the type in c instead of in Ada. Since we don't need the -- internals of XEVENT type, we defined a function to return the address of a -- valid XEVENT object. function CURRENT_EVENT return XEVENT; pragma INTERFACE (C, CURRENT_EVENT); pragma INTERFACE_NAME (CURRENT_EVENT, "current_event"); -- -- EVENT RELATED SUBPROGRAMS -- -- XT_NEXT_EVENT will set information in CURRENT_EVENT procedure XT_NEXT_EVENT is procedure XTNEXTEVENT (EVENT : in XEVENT); pragma INTERFACE (C, XTNEXTEVENT); pragma INTERFACE_NAME (XTNEXTEVENT, "XtNextEvent"); begin XTNEXTEVENT (CURRENT_EVENT); end XT_NEXT_EVENT; -- XT_NEXT_EVENT will use information in CURRENT_EVENT procedure XT_DISPATCH_EVENT is procedure XTDISPATCHEVENT (EVENT : in XEVENT); pragma INTERFACE (C, XTDISPATCHEVENT); pragma INTERFACE_NAME (XTDISPATCHEVENT, "XtDispatchEvent"); begin XTDISPATCHEVENT (CURRENT_EVENT); end XT_DISPATCH_EVENT; function XT_PENDING return BOOLEAN is function PENDING return AFS_LARGE_INTEGER; pragma INTERFACE (C, PENDING); pragma INTERFACE_NAME (PENDING, "XtPending"); begin if PENDING = 0 then return FALSE; else return TRUE; end if; end XT_PENDING; procedure XT_MAIN_LOOP is begin loop XT_NEXT_EVENT; XT_DISPATCH_EVENT; end loop; end XT_MAIN_LOOP; -- -- TIMEOUTS -- function XT_ADD_TIMEOUT (MILLISECONDS : in AFS_LARGE_INTEGER; CALLBACK : in SYSTEM.ADDRESS; CLIENT_DATA : in SYSTEM.ADDRESS) return EVENT_TIMER_ID is function ADD_TIMEOUT (MS : in AFS_LARGE_INTEGER; CB : in SYSTEM.ADDRESS; CD : in SYSTEM.ADDRESS) return SYSTEM.ADDRESS; pragma INTERFACE (C, ADD_TIMEOUT); pragma INTERFACE_NAME (ADD_TIMEOUT, "XtAddTimeOut"); begin return EVENT_TIMER_ID (ADD_TIMEOUT (MILLISECONDS, CALLBACK, CLIENT_DATA)); end XT_ADD_TIMEOUT; procedure XT_REMOVE_TIMEOUT (TIMER : in EVENT_TIMER_ID) is procedure REMOVE_TIMEOUT (T : in system.address); pragma INTERFACE (C, REMOVE_TIMEOUT); pragma INTERFACE_NAME (REMOVE_TIMEOUT, "XtRemoveTimeOut"); begin REMOVE_TIMEOUT (SYSTEM.ADDRESS(TIMER)); end XT_REMOVE_TIMEOUT; -- -- Resource Access -- procedure XT_GET_APPLICATION_RESOURCES ( W : in WIDGET := NULL_WIDGET; BASE : in SYSTEM.ADDRESS; RESOURCES : in XT_RESOURCE_LIST; NUM_RESOURCES : in CARDINAL; ARGS : in ARG_LIST ) is procedure XTGETAPPLICATIONRESOURCES ( W : in SYSTEM.ADDRESS; BASE : in SYSTEM.ADDRESS; RESOURCES : in SYSTEM.ADDRESS; NUM_RESOURCES : in CARDINAL; ARGS : in SYSTEM.ADDRESS; NUM_ARGS : in CARDINAL ); pragma INTERFACE (C, XTGETAPPLICATIONRESOURCES); pragma INTERFACE_NAME (XTGETAPPLICATIONRESOURCES, "XtGetApplicationResources" ); begin XTGETAPPLICATIONRESOURCES ( SYSTEM.ADDRESS ( W ), BASE, SYSTEM.ADDRESS ( RESOURCES ), NUM_RESOURCES, ARGS.all.LIST'ADDRESS, CARDINAL ( ARGS.all.INDEX ) ); end XT_GET_APPLICATION_RESOURCES; procedure XT_GET_SUBVALUES ( BASE : in SYSTEM.ADDRESS; RESOURCES : in XT_RESOURCE_LIST; NUM_RESOURCES : in CARDINAL; ARGS : in ARG_LIST ) is procedure XTGETSUBVALUES ( BASE : in SYSTEM.ADDRESS; RESOURCES : in SYSTEM.ADDRESS; NUM_RESOURCES : in CARDINAL; ARGS : in SYSTEM.ADDRESS; NUM_ARGS : in CARDINAL ); pragma INTERFACE (C, XTGETSUBVALUES); pragma INTERFACE_NAME (XTGETSUBVALUES, "XtGetSubvalues" ); begin XTGETSUBVALUES ( BASE, SYSTEM.ADDRESS ( RESOURCES ), NUM_RESOURCES, ARGS.all.LIST'ADDRESS, CARDINAL ( ARGS.all.INDEX ) ); end XT_GET_SUBVALUES; procedure XT_SET_SUBVALUES ( BASE : in SYSTEM.ADDRESS; RESOURCES : in XT_RESOURCE_LIST; NUM_RESOURCES : in CARDINAL; ARGS : in ARG_LIST ) is procedure XTSETSUBVALUES ( BASE : in SYSTEM.ADDRESS; RESOURCES : in SYSTEM.ADDRESS; NUM_RESOURCES : in CARDINAL; ARGS : in SYSTEM.ADDRESS; NUM_ARGS : in CARDINAL ); pragma INTERFACE (C, XTSETSUBVALUES); pragma INTERFACE_NAME (XTSETSUBVALUES, "XtSetSubvalues" ); begin XTSETSUBVALUES ( BASE, SYSTEM.ADDRESS ( RESOURCES ), NUM_RESOURCES, ARGS.all.LIST'ADDRESS, CARDINAL ( ARGS.all.INDEX ) ); end XT_SET_SUBVALUES; -------------------------------------------------------------------------------------- -- -- Translation Table Manipulation -- -- -- -- XT_PARSE_TRANSLATION_TABLE -- function XT_PARSE_TRANSLATION_TABLE ( TABLE : STRING ) return XT_TRANSLATIONS is function PARSE_TRANSLATION_TABLE ( T : SYSTEM.ADDRESS ) return XT_TRANSLATIONS; pragma INTERFACE (C, PARSE_TRANSLATION_TABLE); pragma INTERFACE_NAME (PARSE_TRANSLATION_TABLE,"XtParseTranslationTable"); begin return PARSE_TRANSLATION_TABLE( TABLE(1)'address ); end XT_PARSE_TRANSLATION_TABLE; -- -- XT_AUGMENT_TRANSLATIONS -- procedure XT_AUGMENT_TRANSLATIONS ( W : WIDGET; TRANSLATIONS : XT_TRANSLATIONS ) is procedure AUGMENT_TRANSLATIONS ( W : SYSTEM.ADDRESS ; TRANS : XT_TRANSLATIONS ); pragma INTERFACE (C, AUGMENT_TRANSLATIONS); pragma INTERFACE_NAME (AUGMENT_TRANSLATIONS,"XtAugmentTranslations"); begin AUGMENT_TRANSLATIONS(SYSTEM.ADDRESS(W),TRANSLATIONS); end XT_AUGMENT_TRANSLATIONS; -- -- XT_OVERRIDE_TRANSLATIONS -- procedure XT_OVERRIDE_TRANSLATIONS ( W : WIDGET; TRANSLATIONS : XT_TRANSLATIONS ) is procedure OVERRIDE_TRANSLATIONS ( W : SYSTEM.ADDRESS ; TRANS : XT_TRANSLATIONS ); pragma INTERFACE (C, OVERRIDE_TRANSLATIONS); pragma INTERFACE_NAME (OVERRIDE_TRANSLATIONS,"XtOverrideTranslations"); begin OVERRIDE_TRANSLATIONS(SYSTEM.ADDRESS(W),TRANSLATIONS); end XT_OVERRIDE_TRANSLATIONS; function XT_PARSE_ACCELERATOR_TABLE( TABLE : in STRING ) return XT_ACCELERATORS is function XTPARSEACCELERATORTABLE( TABLE : in SYSTEM.ADDRESS )return XT_ACCELERATORS; pragma INTERFACE( C, XTPARSEACCELERATORTABLE ); pragma INTERFACE_NAME( XTPARSEACCELERATORTABLE,"XtParseAcceleratorTable"); TEMP_STRING : constant STRING := TABLE & ASCII.NUL; begin return( XTPARSEACCELERATORTABLE( TEMP_STRING'address )); end XT_PARSE_ACCELERATOR_TABLE; procedure XT_INSTALL_ACCELERATORS( DESTINATION : in WIDGET ; SOURCE : in WIDGET ) is procedure XTINSTALLACCELERATOR( DEST : in SYSTEM.ADDRESS; SOURCE: in SYSTEM.ADDRESS); pragma INTERFACE( C, XTINSTALLACCELERATOR ); pragma INTERFACE_NAME( XTINSTALLACCELERATOR,"XtInstallAccelerators"); begin XTINSTALLACCELERATOR( SYSTEM.ADDRESS(DESTINATION), SYSTEM.ADDRESS(SOURCE) ); end XT_INSTALL_ACCELERATORS; -------------------------------------------------------------------------------------- -- -- MISCELLANEOUS JUNK -- -- This is all stuff we aren't sure we'll need or what to do with it. -- None of it should be useful in its current form. procedure XT_CREATE_WINDOW (W : in WIDGET; -- not tested ****** CLASS : in WINDOW_CLASS; VISUAL : in VISUAL_POINTER; VALUE_MASK : in XT_VALUE_MASK; ATTRIBUTES : in X_SET_WINDOW_ATTRIBUTES) is procedure CREATE_WINDOW (W : in SYSTEM.ADDRESS; CLASS : in SYSTEM.ADDRESS; VISUAL : in SYSTEM.ADDRESS; VALUE_MASK : in AFS_LARGE_INTEGER; ATTRIBUTES : in AFS_LARGE_INTEGER); pragma INTERFACE (C, CREATE_WINDOW); pragma INTERFACE_NAME (CREATE_WINDOW, "XtCreateWindow"); begin null; end XT_CREATE_WINDOW; end X_TOOLKIT_INTRINSICS_OSF;