dlgtest.for

来自「开放源码的编译器open watcom 1.6.0版的源代码」· FOR 代码 · 共 569 行 · 第 1/2 页

!               ADS Programmable Dialog Box Test Program
!
!    Programmable Dialog Box Test Program
!
!         This program is the ADS counterpart to the LISP test
!    program, dlgtest.lsp.  It provides a simple dimensioning
!    dialog invoked with the command "dimen" and a simple color
!    dialog invoked with the command "setcolor".
!
!         The purposes of providing this program:
!    1) Demonstrate Programmable Dialog Box use with minimum of code
!       to sort through
!    2) Demonstrate differences between LISP and ADS dialog
!        programming
!    3) Use as a starting point to try out new dialog code
!
!         Dlgtest uses the file dlgtest.dcl as the DCL (Dialog
!    Control Language) file.
!
!         ADS functions are associated with dialog buttons with
!    the ads_action_tile functions.  These functions are called
!    when the user presses buttons during the ads_start_dialog
!    function.
!
!    Special tile names (keys):
!        "accept" - Ok button
!        "cancel" - Cancel button

c$include adsapi.fi
c$include adsdlgap.fi

        program dlgtest

        include 'adslib.fi'

        integer*2 scode/RSRSLT/
        integer stat

        integer dofun, loadfuncs, funcinit
        external dofun, loadfuncs, funcinit

        call funcinit()

        call ads_init( 0, 0 )

        loop

            stat = ads_link( scode )
            if( stat .lt. 0 )then
                print *, 'TEST: bad status from ads_link() = ', stat
                return
            endif

            scode = RSRSLT              ! default return code

            ! Check for AT LEAST the following cases here
            select( stat )

                ! Load or define Lisp functions
            case( RQXLOAD )             ! Load request.  Send function defuns
                if( loadfuncs() .ne. 0 )then
                    scode = -RSRSLT
                else
                    scode = -RSERR
                endif

                ! Unload or undefine ALL functions previously defined.
            case( RQXUNLD )             ! Unload request. Do cleanup
                ! This defaults to sending an RSRSLT.  If you send an
                ! RSERR, you can refuse to unload the program, but Lisp
                ! will still ask you to terminate.

                ! Execute a "loaded" function that was defined via RQXLOAD
            case( RQSUBR )
                call dofun()

            endselect
        endloop
        end


! FUNCINIT  --  Initialize function definition structure

        integer function funcinit()

        include 'adslib.fi'

        integer loadfuncs

        integer id, rb, i

        integer  setcolor
        external setcolor, setdimen

        structure /func_entry/
            character*32        func_name
            integer             func
        end structure

        ! To add another function, change the value of "NUM_FUNS" and
        ! add the new function(s) to the function table ("func_table").

        integer NUM_FUNS
        parameter (NUM_FUNS = 2)
        record /func_entry/ func_table(NUM_FUNS)

        ! Subroutines names to be registered with AutoLisp and provided
        ! in this application.
        func_table(1).func_name = 'C:dimen'c
        func_table(1).func = loc( setdimen )
        func_table(2).func_name = 'C:setcolor'c
        func_table(2).func = loc( setcolor )

        funcinit = 1

        return

        entry loadfuncs()

        do i = 1, NUM_FUNS
            if( ads_defun( func_table(i).func_name, i - 1 ) .eq. 0 )then
                loadfuncs = 0
                return
            endif
        end do

        call ads_printf( 'Functions: 1-dimen 2-setcolor.'//
     &                   char(10)//char(0) )
        loadfuncs = 1

        return


! Execute a defined function.

        entry dofun()

        ! Get the function code from the combuf
        id = ads_getfuncode()
        if( id .lt. 0 )then
            dofun = 0
            return
        endif

        rb = ads_getargs()
        if( rb .ne. NULL )then
            call ads_printf( 'No arguments expected'c )
            call ads_relrb( rb )
        endif

        select( id )    ! Which function is called?

        case( 0 )
            ! dimen -- AutoCAD dimensioning dialog
            call setdimen()

        case( 1 )
            ! setcolor -- AutoCAD color dialog
            call setcolor()

        endselect

        dofun = 1

        end


! DIMEN -- Dimensioning Dialog

        block data dims_init

        integer dimx, dimy
        common /dims/ dimx, dimy
        ! Position of dialog, centered to start
        data dimx/-1/, dimy/-1/

        character*7 dimbools(10)
        common /dimbools/ dimbools
        data dimbools/ 'dimse1'c, 'dimse2'c, 'dimtih'c, 'dimtoh'c,
     &                 'dimtad'c, 'dimtol'c, 'dimlim'c, 'dimalt'c,
     &                 'dimaso'c, 'dimsho'c /

        character*7 dimreals(7)
        common /dimreals/ dimreals
        data dimreals/ 'dimasz'c, 'dimtsz'c, 'dimtxt'c, 'dimcen'c,
     &                 'dimexo'c, 'dimexe'c, 'dimdle'c /

        end


        subroutine setdimen()

        include 'adslib.fi'
        include 'adsdlg.fi'

        integer hdlg, dlg_status, dcl_id

        integer dimx, dimy
        common /dims/ dimx, dimy

        external dimen_ok

        call ads_load_dialog( 'dlgtest.dcl'c, dcl_id )
        if( dcl_id .lt. 0 )then
            call ads_printf( 'Error loading "dlgtest.dcl"'//
     &                       char(10)//char(0) )
            return
        endif
        ! Display the "dimensions" dialog
        call ads_new_positioned_dialog( 'dimensions'c, dcl_id, NULL_PTR,
     &                                  dimx, dimy, hdlg )
        if( hdlg .eq. NULL )then
            call ads_printf( 'The ads_new_dialog function failed',
     &                       char(10)//char(0) )
            call ads_unload_dialog( dcl_id )
            return
        endif

        ! Register dimen_ok function with the OK button
        call ads_action_tile( hdlg, 'accept'c, dimen_ok )

        ! show current values in dialog
        call get_dimvars( hdlg )

        ! run the dialog
        call ads_start_dialog( hdlg, dlg_status )

        ! free all memory for dialog
        call ads_unload_dialog( dcl_id )

        end


! DIMEN_OK -- callback function for OK button of dimension dialog.

        subroutine dimen_ok( cpkt )
        record /ads_callback_packet/ cpkt

        include 'adslib.fi'
        include 'adsdlg.fi'

        integer dimx, dimy
        common /dims/ dimx, dimy

        ! User pressed OK button to end dialog.  Check modified data
        ! and send to AutoCAD.
        call set_dimvars( cpkt.dialog )
        call ads_done_positioned_dialog( cpkt.dialog, 1, dimx, dimy )
        end


! Show current values in dialog

        subroutine get_dimvars( hdlg )
        integer hdlg

        include 'adslib.fi'
        include 'adsdlg.fi'
        include 'malloc.fi'

        integer i
        character*80 value

        character*7 dimbools(10)
        common /dimbools/ dimbools

        character*7 dimreals(7)
        common /dimreals/ dimreals

        record /resbuf/ rb

        do i = 1, 10
            call ads_getvar( dimbools(i), rb )
            if( rb.restype .ne. RTSHORT )then
                call ads_printf( 'No such AutoCAD variable: %s'//
     &                           char(10)//char(0), dimbools(i) )
                if( rb.restype .eq. RTSTR )then
                    call free( rb.resval.rstring )
                endif
                cycle
            endif
            write( value, '(i10,a)' ) rb.resval.rint, char(0)
            call ads_set_tile( hdlg, dimbools(i), value )
        enddo