Conference bulova::decw_jan-89_to_nov-90

2478.0. "Shell Widget Creation." by UTRTSC::CAHILL () Tue Mar 20 1990 07:10

    I have a customer trying to craete an APPLICATION SHELL WIDGET in
    fortran,he get access violation.
    I have included the source and UIL,has anyone got any ideas why?
    
    FORTRAN SOURCE
    **************
    
      PROGRAM APP_SHELL_TEST
*
*     Test to position window with UIL and an Application Shell widget.
*     Argument TOPLEVELSHELLWIDGETCLASS causes always an access violation
*     All tests are tried and did not solve the problem.
*     Digital Log no. of problem 35025.
*     
*     Input via terminal:
*     Test no: 0 - 5.      (0 does not create an application shell)

*     Include files for DECwindows and UIL
      INCLUDE	'SYS$LIBRARY:DECW$DWTDEF'
      INCLUDE	'($DSCDEF)'
      
*     Callback routines
      EXTERNAL SELEC1,SELEC2,WDGCRE,SORTIE

      INTEGER I
      CHARACTER SHNAME*5
      CHARACTER WNAME*10, WCLASS*10, UIDFIL*20

*     Status return values
      INTEGER   ARGC, HIERARCHY_STATUS, FETCH_STATUS, REG_STATUS

      INTEGER   TOP_LEVEL, APP_SHELL
      INTEGER   MAIN_WINDOW
      INTEGER   DRM_HIERARCHY
      INTEGER   CLASS

*     Argument list for DWT$VMS_SET_ARG and XT$SET_VALUES
      RECORD /DWT$ARG/ ARGLST(0:2)

*     Structure for the descriptor of the DRM hierarchy file name
      STRUCTURE /DESCRIPTOR_STRUCT/
                 INTEGER*2 LENGTH
                 BYTE DTYPE
                 BYTE CLASS
                 INTEGER POINTER
      END STRUCTURE
      RECORD /DESCRIPTOR_STRUCT/ HIERARCHY_FILE_DESCR
*     Pointer to the descriptors
      INTEGER   FILES_NAME_LIST(1)

*     Record containing the names (as character string) and
*                       the addresses of the callback routines
*     that DRM has to bind
      RECORD / DWT$DRMREG_ARG / REGVEC(0:3)

*#######################################################################
*     Records tried with testing XT$CREATE_APPLICATION_SHELL
      RECORD /DWT$SHELL_CLS_REC/ SHCLASSREC
      RECORD /DWT$T_L_SH_CLS_REC/ TOPLEVELSHCLASSREC
      RECORD /DWT$APL_SH_CLS_REC/ APPLICATIONSHCLASSREC
*#######################################################################

*     Filespec of the UID - file
      DATA UIDFIL/'APP_SHELL_TEST.UID'/
      DATA WNAME/'Test'/,WCLASS/'Class'/
      
*     Fill in the DRM hierarchy file descriptor
      HIERARCHY_FILE_DESCR.LENGTH  = LEN(UIDFIL)
      HIERARCHY_FILE_DESCR.DTYPE   = DSC$K_DTYPE_T
      HIERARCHY_FILE_DESCR.CLASS   = DSC$K_CLASS_S
      HIERARCHY_FILE_DESCR.POINTER = %LOC(UIDFIL)
      FILES_NAME_LIST(1) = %LOC(HIERARCHY_FILE_DESCR)

*     Fill in the callback routines in the register vector
      REGVEC(0).DWT$A_DRMR_NAME  = %LOC('selec1')
      REGVEC(0).DWT$L_DRMR_VALUE = %LOC(SELEC1)
      REGVEC(1).DWT$A_DRMR_NAME  = %LOC('selec2')
      REGVEC(1).DWT$L_DRMR_VALUE = %LOC(SELEC2)
      REGVEC(2).DWT$A_DRMR_NAME  = %LOC('wdgcre')
      REGVEC(2).DWT$L_DRMR_VALUE = %LOC(WDGCRE)
      REGVEC(3).DWT$A_DRMR_NAME  = %LOC('sortie')
      REGVEC(3).DWT$L_DRMR_VALUE = %LOC(SORTIE)

*     Initialize DRM
      CALL DWT$INITIALIZE_DRM()

*     Initialize the XUI toolkit
      TOP_LEVEL = XT$INITIALIZE(WNAME,WCLASS,%VAL(0),0,ARGC,%VAL(0))

*     Names DWT$C_NTITLE (shell widget), 
*           DWT$C_NX and DWT$C_NY (resouce names) from DECW$DWTDEF.FOR
      CALL DWT$VMS_SET_ARG('Top one',ARGLST,0,DWT$C_NTITLE)
      CALL DWT$VMS_SET_ARG(200,ARGLST,1,DWT$C_NX)
      CALL DWT$VMS_SET_ARG(500,ARGLST,2,DWT$C_NY)

*     Create the application shell
      SHNAME = ' '
*#######################################################################
*     These tests are tried
      WRITE(*,*) 'Give test no.'
      READ(*,*) I
      IF (I .EQ. 1) THEN
         APP_SHELL = XT$CREATE_APPLICATION_SHELL(SHNAME,
     >               TOPLEVELSHELLWIDGETCLASS,ARGLST,3)
      ELSE IF (I .EQ. 2) THEN
         APP_SHELL = XT$CREATE_APPLICATION_SHELL(SHNAME,
     >               %LOC(TOPLEVELSHELLWIDGETCLASS),ARGLST,3)
      ELSE IF (I .EQ. 3) THEN
         TOPLEVELSHELLWIDGETCLASS = %LOC(SHCLASSREC)
         APP_SHELL = XT$CREATE_APPLICATION_SHELL(SHNAME,
     >               TOPLEVELSHELLWIDGETCLASS,ARGLST,3)
      ELSE IF (I .EQ. 4) THEN
         TOPLEVELSHELLWIDGETCLASS = %LOC(TOPLEVELSHCLASSREC)
         APP_SHELL = XT$CREATE_APPLICATION_SHELL(SHNAME,
     >               TOPLEVELSHELLWIDGETCLASS,ARGLST,3)
      ELSE IF (I .EQ. 5) THEN
         TOPLEVELSHELLWIDGETCLASS = %LOC(APPLICATIONSHCLASSREC)
         APP_SHELL = XT$CREATE_APPLICATION_SHELL(SHNAME,
     >               TOPLEVELSHELLWIDGETCLASS,ARGLST,3)
      END IF
*#######################################################################

*     Open the DRM hierarchy, read the UID-file
      HIERARCHY_STATUS = DWT$OPEN_HIERARCHY(1, FILES_NAME_LIST,
     >                   %VAL(0), DRM_HIERARCHY )
      IF (HIERARCHY_STATUS .NE. DWT$C_DRM_SUCCESS) THEN
         TYPE * , 'Can''t open hierarchy , STATUS = ' , HIERARCHY_STATUS
         STOP
      END IF
      
*     Register the callback routines
      REG_STATUS = DWT$REGISTER_DRM_NAMES(REGVEC,4)
      IF (REG_STATUS .NE. DWT$C_DRM_SUCCESS) THEN
         TYPE * , 'Can''t register callb., STATUS = ' , HIERARCHY_STATUS
         STOP
      END IF

*     Fetch the interface defintion, create the widgets
      FETCH_STATUS = DWT$FETCH_WIDGET(%VAL(DRM_HIERARCHY), 'W_MAIN',
     >               TOP_LEVEL, MAIN_WINDOW, CLASS )
      IF (FETCH_STATUS .NE. DWT$C_DRM_SUCCESS) THEN
         TYPE * , 'CAN''T FETCH INTERFACE , STATUS = ' , FETCH_STATUS
         STOP
      END IF
      
*     Manage the topmost widget in the app. widget hierarchy
      CALL XT$MANAGE_CHILD(MAIN_WINDOW)
*     Make the interface appear on the display
      CALL XT$REALIZE_WIDGET(TOP_LEVEL)
*     Wait for events to process
      CALL XT$MAIN_LOOP()
      END

     
      SUBROUTINE SELEC1(WIDGET,TAG,REASON)
      INCLUDE	'SYS$LIBRARY:DECW$DWTDEF'
      RECORD /DWT$LISTBOX_CB_ST/ REASON
      INTEGER WIDGET,TAG
      INTEGER STATUS,CS
      INTEGER WID(2)
      COMMON /WIDID/ WID

*     Copy the compound string in CS, so we can delete the item
*     first and then add it in the other widget
*     If it is added first and then deleted the screen flickers
      STATUS = DWT$CSTRCPY(%VAL(REASON.DWT$A_LISTBOX_ITEM),CS)

*     The compund string must be passed by value
      CALL DWT$LIST_BOX_DELETE_ITEM(WID(1),%VAL(CS))
      CALL DWT$LIST_BOX_ADD_ITEM(WID(2),%VAL(CS),1)
      END

      SUBROUTINE SELEC2(WIDGET,TAG,REASON)
      INCLUDE	'SYS$LIBRARY:DECW$DWTDEF'
      RECORD /DWT$LISTBOX_CB_ST/ REASON
      INTEGER WIDGET,TAG
      INTEGER STATUS,CS
      INTEGER WID(2)
      COMMON /WIDID/ WID

*     Copy the compound string in CS, so we can delete the item
*     first and then add it in the other widget
*     If it is added first and then deleted the screen flickers
      STATUS = DWT$CSTRCPY(%VAL(REASON.DWT$A_LISTBOX_ITEM),CS)

*     The compund string must be passed by value
      CALL DWT$LIST_BOX_DELETE_ITEM(WID(2),%VAL(CS))
      CALL DWT$LIST_BOX_ADD_ITEM(WID(1),%VAL(CS),1)
      END

      SUBROUTINE SORTIE(WIDGET,TAG,REASON)
      INTEGER WIDGET,TAG,REASON
      INTEGER STATUS,CS
      STOP
      END


      SUBROUTINE WDGCRE(WIDGET,TAG,REASON)
      INTEGER WIDGET,TAG,REASON
      INTEGER STATUS,CS
      INTEGER WID(2)
      COMMON /WIDID/ WID

      WID(TAG) = WIDGET
      END
    
     ----------------------------------------------------------------
    
    
    UIL 
    ***
    
    
    
module app_shell_test
      version = 'v1.0'
      names   = case_sensitive
      include file 'Decw$include:DwtAppl.uil';

procedure
      selec1();
      selec2();
      wdgcre(integer);
      sortie();

value
      kw_list1 :         1;
      kw_list2 :         2;
      White    : color ('White');
      Red      : color ('Red');
      Yellow   : color ('Yellow');
      Black    : color ('Black');

object
      W_MAIN : main_window 
         {
         arguments 
            {
            x      = 200;
            y      = 100;
            width  = 500;
            height = 300;
            };
         controls 
            {
            dialog_box w_dialog;
            };
         };

object
      w_dialog : dialog_box
         {
         arguments 
            {
            background_color = Red;
            margin_width = 20;
            };
         controls 
            {
            list_box w_list1;
            list_box w_list2;
            push_button w_pushexit;
            };
         };

object
      w_list1 : list_box
         {
         arguments
            {
            x = 100;
            y = 100;
            visible_items_count = 5;
            items = string_table('Itempje1','Item2','Item3','Item4','Item5',
                                 'Itempje6','Item7','Item8');
            };
         callbacks
            {
            single = procedure selec1();
            create = procedure wdgcre(kw_list1);
            };                 
         };

object
      w_list2 : list_box
         {
         arguments
            {
            background_color = White;
            x = 130;
            y = 10;
            visible_items_count = 7;
            };
         callbacks
            {
            single = procedure selec2();
            create = procedure wdgcre(kw_list2);
            };
         };

object
      w_pushexit: push_button 
         {
         arguments 
            {
            foreground_color = Black;
            background_color = White;
            highlight_color  = Yellow;
            x      = 10;
            y      = 10;
            label_label = compound_string("Exit");
            };
         callbacks
            {
            activate = procedure sortie();
            };
         };

end module;
    
    
    Thanks..........