with Motif.Xm; -- #include with Mrm.MrmPublic; -- #include with Mrm.MrmDecls; -- #include with Xt.Intrinsic; -- #include with Xt.Composite; -- #include with X.Args; with X.Strings; with Stdarg; with Ada.Text_IO; -- #include with Ada.Command_Line; -- Error reporting with Interfaces.C; procedure Hello_World is -- (int argc, char *argv[]) -- -- error - Print an error message and exit with failure status. -- procedure Error(Message : in String) is begin Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, "hello_world: " & Message); Ada.Command_Line.Set_Exit_Status(Ada.Command_Line.Failure); -- exit(1) end Error; -- -- quit - The quit callback procedure. Exits the program with success status. -- procedure Quit (W : in Xt.Intrinsic.Widget; Client_Data : in Xt.Intrinsic.XtPointer; Call_Data : in Xt.Intrinsic.XtPointer); pragma Convention(C, Quit); procedure Quit (W : in Xt.Intrinsic.Widget; Client_Data : in Xt.Intrinsic.XtPointer; Call_Data : in Xt.Intrinsic.XtPointer) is begin -- Quit Ada.Text_IO.Put_Line(Client_Data); -- Convert to String first Ada.Command_Line.Set_Exit_Status(Ada.Command_Line.Success); -- exit(0) end Quit; Callback_List : constant Mrm.MrmPublic.MrmRegisterArgList := (("Quit", Quit'Access)); App_Context : aliased Xt.Intrinsic.XtAppContext; -- Application Context TopLevel : Xt.Intrinsic.Widget; -- Top level widget Hello_Main : aliased Xt.Intrinsic.Widget; -- Main Widget (for 'access) Status : Xt.Intrinsic.Cardinal; -- Mrm return status UID_File_List : constant String := "hello_world"; Hierarchy : aliased Mrm.MrmPublic.MrmHierarchy; Class_Code : aliased Mrm.MrmPublic.MrmType; -- for 'access The_String : Motif.Xm.XmString; -- Label and Pushbutton string Null_String : constant X.Strings.Const_Charp := null; function "&" is new Stdarg.Concat(X.Strings.Const_Charp); function "&" is new Stdarg.Concat(Motif.Xm.XmString); use type Xt.Intrinsic.Cardinal; -- Compare status values begin -- Hello_World Xt.Intrinsic.XtSetLanguageProc(null, null, null); -- app_context,proc,client_data TopLevel := Xt.Intrinsic.XtVaAppInitialize (App_Context'access, -- Application context "Hello", -- Application class name null, -- Command-line option list 0, -- No Options X.Args.Argc'access, -- Arg count X.Args.Argv, -- Args null, -- No app-defaults file Stdarg.Empty & Null_String); -- No arguments Status := Mrm.MrmDecls.MrmOpenHierarchyPerDisplay (Xt.Intrinsic.XtDisplay(TopLevel), -- Display UID_File_List'length, -- Num files UID_File_List, -- File list *** NEED access to "Charp" *** null, -- OS Data Hierarchy'Access); if (Status /= Mrm.MrmPublic.MrmSUCCESS) then Error("Unable to open hello_world.uid file."); end if; -- Instead of the XtNumber macro, in Ada use Array'Length Status := Mrm.MrmDecls.MrmRegisterNames (Callback_List, Callback_List'length); -- *** Must be array *** if (Status /= Mrm.MrmPublic.MrmSUCCESS) then Error("Unable to register callback functions with Mrm"); end if; The_String := Motif.Xm.XmStringCreateSimple("Hello_World"); Status := Mrm.MrmDecls.MrmFetchWidget (Hierarchy, -- Hierarchy to search Stdarg.Empty & The_String & Null_String, TopLevel, -- Parent Hello_World'Access, -- Widget created Class_Code'Access); -- Widget's class code if (Status /= Mrm.MrmPublic.MrmSUCCESS) then Error("Unable to create interface from UID file."); end if; Mrm.MrmDecls.MrmCloseHierarchy(Hierarchy); -- *** Expect procedure name in procedure call! Xt.Composite.XtManageChild(Hello_Main); Xt.Intrinsic.XtRealizeWidget(TopLevel); Xt.Intrinsic.XtAppMainLoop(App_Context); end Hello_World;