[ INHERIT('SYS$LIBRARY:DECW$MOTIF','SYS$LIBRARY:STARLET') ]
PROGRAM HELLOMOTIF (OUTPUT);
 
{+
COMPONENT: HELLOMOTIF.PAS
 
PROGRAM DESCRIPTION:
 
    Example program to demonstrate use of the Motif toolkit from Pascal.
 
    Requires SYS$LIBRARY:DECW$MOTIF.PEN, the Pascal environment file
    compiled from DECW$MOTIF.PAS as follows:
 
      $ PASCAL/ENVIRONMENT=SYS$LIBRARY:DECW$MOTIF.PEN -
	SYS$LIBRARY:DECW$MOTIF
 
    To compile and link:
 
      $ PASCAL DECW$EXAMPLES:HELLOMOTIF
      $ LINK HELLOMOTIF,SYS$INPUT:/OPTIONS
	sys$share:decw$mrmlibshr12/share
        sys$share:decw$dxmlibshr12/share
        sys$share:decw$xmlibshr12/share
        sys$share:decw$xtlibshrr5/share
        sys$share:decw$xlibshr/share
 
    To run, HELLOMOTIF.UID must be in your default directory.
    To create it:
 
      $ UIL/MOTIF DECW$EXAMPLES:HELLOMOTIF
 
    Then:
 
      $ RUN HELLOMOTIF
 
    A window will be displayed that will contain a pushbutton widget that
    says "Hello World!".  Click once on the button to cause the callback
    routine to be called to change the label.  The second click on the
    button will exit the program.
 
 
CREATION DATE: 21-Feb-1991
 
MODIFICATION HISTORY:
 
     Date     |   Name  | Description
--------------+---------+-------------------------------------------------------
21-Feb-1991   | SBL/RDJ | Original Motif version
--------------------------------------------------------------------------------
-}
 
VAR
    PUSHED: BOOLEAN := FALSE;
 
{+
    Routine to set an entry in an Arg list.
    Move the constant ("NAME") to a variable to get around the
    IADRESS(CONSTANT) problem .
-}
PROCEDURE SET_ARG
    ( VAR ARG_ENTRY: Arg; 
      VAR ARG_STRING: packed array [k..j:integer] of char;
      VAR NAME: [READONLY] packed array [l..u:integer] of char;
      VAR VALU: [UNSAFE,READONLY] INTEGER);
 
    BEGIN
    
    ARG_STRING := NAME;
 
    ARG_ENTRY.NAME := IADDRESS(ARG_STRING);
    ARG_ENTRY.VALUE := VALU::XtArgVal;
    END;
 
{+
    Routine to set an entry in an MrmRegisterArg list.
    Move the constant ("NAME") to a variable to get around the
    IADRESS(CONSTANT) problem .
-}
PROCEDURE SET_REGISTER_ARG
    ( VAR ARG_ENTRY: MrmRegisterArg; 
      VAR ARG_STRING: packed array [k..j:integer] of char;
      VAR NAME: [READONLY] packed array [l..u:integer] of char;
      VAR VALU: [UNSAFE,READONLY] INTEGER);
 
    BEGIN
    ARG_STRING := NAME;
    ARG_ENTRY.NAME := IADDRESS(ARG_STRING);
    ARG_ENTRY.VALUE := VALU::Opaque;
    END;
 
{+
    Callback routine which is called each time the pushbutton is pressed.
-}
PROCEDURE HELLOWORLD_BUTTON_ACTIVATE
    (VAR W : [READONLY] Widget; 
     VAR TAG: [READONLY] INTEGER ; 
     VAR REASON: [READONLY] INTEGER );
 
     
    VAR
	ARG_LIST : ARRAY [1..20] OF ARG;
	ARG_STRINGS : ARRAY [1..20] of packed array [1..20] of char;
			
	CSTRING: XmString;
    BEGIN
 
    { If button was pushed before, then exit the program. }
    IF PUSHED
    THEN
    	$exit (1)
 
 
    { Else change the label and set the PUSHED flag. }
    ELSE
    	BEGIN
	CSTRING := XmStringCreateLtoR ('Goodbye'(10)'World!'(0),
	    XmString_Default_Charset);
	SET_ARG (ARG_LIST[1],ARG_STRINGS[1],XmNlabelString,CSTRING);
	XtSetValues (W,ARG_LIST,1);
	XtFree (CSTRING);
	PUSHED := TRUE;
	END;
    END;
 
{ Begin main program declarations. }
VAR
    TOPLEVEL, HELLOWORLD_MAIN: WIDGET;
    ARG_LIST : ARRAY [1..20] OF ARG;
    ARG_STRINGS : ARRAY [1..20] of packed array [1..20] of char;
    ARGC : INTEGER := 0;
    HIERARCHY : MrmHierarchy := nil;
    CLASS : MrmType;
    REGVEC : ARRAY [1..20] OF MrmRegisterArg;
    REGVEC_STRINGS : ARRAY [1..20] of packed array [1..40] of char;
    APPLICATION_CONTEXT : XtAppContext;
    DPY : Display;
 
TYPE
    POINTER = [UNSAFE] ^INTEGER;
 
VAR
    HIERARCHY_FILE_NAME : PACKED ARRAY [1..17] OF CHAR := '[]HELLOMOTIF.UID'(0);
    HIERARCHY_FILE_NAME_ARRAY: ARRAY [1..1] OF POINTER;
 
BEGIN
	(* Set up UID file specification and pointer array		*)
 
	HIERARCHY_FILE_NAME_ARRAY[1]:= IADDRESS (HIERARCHY_FILE_NAME);
 
	(* Initialize the toolkit					*)
 
	XtToolkitInitialize;
 
	(* Initialize Mrm						*)
 
	MrmInitialize;
 
	(* Create a new application context				*)
 
	APPLICATION_CONTEXT := XtCreateApplicationContext;
 
	(* Open the display						*)
 
	DPY := XtOpenDisplay (APPLICATION_CONTEXT,
			      %IMMED XtNull,
			      'Hello Motif in Pascal'(0),
			      'helloworldclass'(0),
			      %IMMED XtNull,
			      0,
			      ARGC,
			      %IMMED XtNull);
 
	IF DPY::INTEGER = 0 THEN
	BEGIN
	    WRITELN ( 'Unable to open display' );
	    $EXIT( 1 );
	    END;
 
	(* Create a resizable toplevel application shell *)
 
	SET_ARG (ARG_LIST[1],ARG_STRINGS[1], XmNallowShellResize, XtTrue);
	SET_ARG (ARG_LIST[2],ARG_STRINGS[2], XmNx, 100);
	SET_ARG (ARG_LIST[3],ARG_STRINGS[3], XmNy, 100);
   	SET_ARG (ARG_LIST[4],ARG_STRINGS[4], XmNwidth,200 );
	SET_ARG (ARG_LIST[5],ARG_STRINGS[5], XmNheight, 250);
 
	TOPLEVEL := XtAppCreateShell (%IMMED XtNull,
				      %IMMED XtNull,
				      applicationshellwidgetclass,
				      DPY,
				      ARG_LIST,
				      5);
	
 
	(*  Define the Mrm hierarchy (only 1 file) *)
 
	IF MrmOpenHierarchy (1,
			     HIERARCHY_FILE_NAME_ARRAY,
			     %Immed 0,
			     HIERARCHY) <> MrmSUCCESS 
	THEN 
	    BEGIN
	    WRITELN ('Unable to open hierarchy');
	    $EXIT(1);
	    END;
 
	(* Register our callback routines				   *)
 
	SET_REGISTER_ARG (REGVEC[1],REGVEC_STRINGS[1],
			  'helloworld_button_activate'(0), 
			  IADDRESS( HELLOWORLD_BUTTON_ACTIVATE));
 
	MrmRegisterNames ( REGVEC, 1 );
 
	(* Call Mrm to fetch and create the widget hierarchy		   *)
 
	If MrmFetchWidget(  HIERARCHY, 
			   'helloworld_main'(0), 
			    TOPLEVEL,
			    HELLOWORLD_MAIN, 
			    CLASS ) <> MrmSUCCESS
	THEN 
	    BEGIN
	    WRITELN ('Unable to fetch interface');
	    $EXIT (1);
	    END;
 
	(* Make the toplevel widget "manage" the main window (or whatever   *)
	(* the uil defines as the topmost widget).  This will		    *)
	(* cause it to be "realized" when the toplevel widget is "realized" *)
 
	XtManageChild (HELLOWORLD_MAIN);
    
	(*  Realize the toplevel widget.  This will cause the entire  *)
	(*  "managed" widget hierarchy to be displayed		      *)
 
	XtRealizeWidget (TOPLEVEL);
 
	(*  Loop and process events  *)
 
	XtAppMainLoop (APPLICATION_CONTEXT);
 
    END.