os2pm.gml

开放源码的编译器open watcom 1.6.0版的源代码

    HWND        WinHandle;

.code break
    /* Initialize windowing and create message queue */
    AnchorBlock = WinInitialize( 0 );
    if( AnchorBlock == 0 ) return( 0 );
    hMessageQueue = WinCreateMsgQueue( AnchorBlock, 0 );
    if( hMessageQueue == 0 ) return( 0 );

.code break
    /* Register window class */
    if( !WinRegisterClass( AnchorBlock, "Watcom", (PFNWP)MainDriver,
                           CS_SIZEREDRAW, 0 ) ) {
        return( 0 );
    }

.code break
    /* Create frame and client windows */
    style = FCF_TITLEBAR | FCF_SYSMENU | FCF_SIZEBORDER | FCF_MINMAX |
            FCF_SHELLPOSITION | FCF_TASKLIST;
    FrameHandle = WinCreateStdWindow( HWND_DESKTOP, WS_VISIBLE, &style,
                                      "Watcom",
                                      "Shapes - C sample",
                                      0, NULL, 0, &WinHandle );

.code break
    /* If window creation failed, exit immediately! */
    if( FrameHandle == 0 ) return( 0 );

    /* Message loop */
    while( WinGetMsg( AnchorBlock, &qmsg, NULL, 0, 0 ) ) {
        WinDispatchMsg( AnchorBlock, &qmsg );
    }

.code break
    /* Shut down and clean up */
    WinDestroyWindow( FrameHandle );
    WinDestroyMsgQueue( hMessageQueue );
    WinTerminate( AnchorBlock );

    return( 1 );
}
.code end
.np
You can compile, link and run this demonstration by issuing the following
commands.
.millust begin
&prompt.&wclcmd32 &sw.l=os2v2_pm shapes
&prompt.shapes
.millust end
.do end
.*
.if '&lang' eq 'FORTRAN 77' .do begin
.np
A number of &lang include files (files with extension
.fi &hxt
or
.fi ~.fap
.ct ) are
provided which define Presentation Manager data structures and
constants.
They are located in the
.fi &pathnam.&pc.src&pc.fortran&pc.os2
directory.
These include files are equivalent to the C header files that are
available with the IBM OS/2 Developer's Toolkit.
.np
A sample FORTRAN 77 Presentation Manager application is also located in the
.fi &pathnam.&pc.samples&pc.fortran&pc.os2
directory.
It is contained in the files
.fi fshapes.for
and
.fi fshapes.fi.
The file
.fi fshapes.for
contains the following.
.code begin
c$define INCL_WINFRAMEMGR
c$define INCL_WINMESSAGEMGR
c$define INCL_WINWINDOWMGR
c$define INCL_WINTIMER
c$define INCL_GPIPRIMITIVES
c$include os2.fap

.code break
        program fshapes

        integer         style
        record /QMSG/   qmsg

        character*7     watcom
        parameter       (watcom='WATCOM'c)

        include 'fshapes.fi'

.code break
        AnchorBlock = WinInitialize( 0 )
        if( AnchorBlock .eq. 0 ) stop
        hMessageQueue = WinCreateMsgQueue( AnchorBlock, 0 )
        if( hMessageQueue .eq. 0 ) stop
        if( WinRegisterClass( AnchorBlock, watcom, MainDriver,
     +                        CS_SIZEREDRAW, 0 ) .eq. 0 ) stop
        style = FCF_TITLEBAR .or. FCF_SYSMENU .or. FCF_SIZEBORDER .or.
     +          FCF_MINMAX .or. FCF_SHELLPOSITION .or. FCF_TASKLIST
        FrameHandle = WinCreateStdWindow( HWND_DESKTOP, WS_VISIBLE,
     +                                    style, watcom,
     +                                    char(0), 0, NULL,
     +                                    0, WinHandle )
.code break
        if( FrameHandle .eq. 0 ) stop

        while( WinGetMsg( AnchorBlock, qmsg, NULL, 0, 0 ) ) do
            call WinDispatchMsg( AnchorBlock, qmsg )
        end while

        call WinDestroyWindow( FrameHandle )
        call WinDestroyMsgQueue( hMessageQueue )
        call WinTerminate( AnchorBlock )

        end

.code break
        function MainDriver( hwnd, msg, mp1, mp2 )

        integer hwnd
        integer msg
        integer mp1
        integer mp2

.code break
        include 'fshapes.fi'

        integer         ps
        record /RECTL/  rcl

        select case ( msg )
        case ( WM_CREATE )
            WinHandle = hwnd
            call WinStartTimer( AnchorBlock, WinHandle, 1, 150 )
        case ( WM_TIMER )
            call DrawEllipse()
            MainDriver = 0
            return
.code break
        case ( WM_SIZE )
            SizeX = SHORT1FROMMP( mp2 )
            SizeY = SHORT2FROMMP( mp2 )
            MainDriver = 0
            return
        case ( WM_PAINT )
            ps = WinBeginPaint( WinHandle, NULL, NULL_POINTER )
            call WinQueryWindowRect( WinHandle, rcl )
            call WinFillRect( ps, rcl, CLR_WHITE )
            call WinEndPaint( ps )
            MainDriver = 0
            return
        end select

.code break
        MainDriver = WinDefWindowProc( WinHandle, msg, mp1, mp2 )
        return

        end

.code break
        subroutine DrawEllipse

        record /POINTL/         ptl
        integer                 ps
        integer                 Odd /0/
        integer                 parm1
        integer                 parm2

        include 'fshapes.fi'

.code break
        ps = WinGetPS( WinHandle )
        ptl.x = Random( SizeX )
        ptl.y = Random( SizeY )
        call GpiMove( ps, ptl )
        ptl.x = Random( SizeX )
        ptl.y = Random( SizeY )
        parm1 = Random( 32767 )
        parm2 = Random( 32767 )
.code break
        if( Random( 10 ) .ge. 5 ) then
            execute NewColor
            call GpiBox( ps, DRO_FILL, ptl, 0, 0 )
            execute NewColor
            call GpiBox( ps, DRO_OUTLINE, ptl, 0, 0 )
        else
            execute NewColor
            call GpiBox( ps, DRO_FILL, ptl, parm1, parm2 )
            execute NewColor
            call GpiBox( ps, DRO_OUTLINE, ptl, parm1, parm2 )
        end if

.code break
        Odd = Odd + 1
        Odd = Odd .and. 1
        call WinReleasePS( ps )

        remote block NewColor
        call GpiSetColor( ps, Random( 15 ) + 1 )
        end block

        end

.code break
        integer function Random( high )
        integer         high

        external        urand
        real            urand
        integer         seed /75347/
        Random = urand( seed ) * high

        end
.code end
.np
The include file
.fi fshapes.fi
contains the following.
.code begin
        include 'os2.fi'

        integer         SizeX
        integer         SizeY
        integer         FrameHandle
        integer         WinHandle
        integer         hMessageQueue
        integer         AnchorBlock

.code break
        common /globals/
     +  SizeX,
     +  SizeY,
     +  FrameHandle,
     +  WinHandle,
     +  hMessageQueue,
     +  AnchorBlock

.code break
        external                Random
        integer                 Random

        external                MainDriver
        integer                 MainDriver
c$pragma aux (FNWP)             MainDriver
.code end
.np
.autonote Notes:
.note
Include files with extension
.fi ~.fap
define the calling conventions for each of the OS/2 API functions.
These files must be included at the top of each FORTRAN 77 source module.
.note
Include files with extension
.fi &hxt
define the data structures and constants
used by the OS/2 API functions.
These files must be included in each subprogram that requires them.
.note
Each call-back function (i.e. window procedure) must be defined using the
following pragma.
.millust begin
c$pragma aux (FNWP) WindowProc
.millust end
.note
The include file
.fi os2.fap
is included at the beginning
of the source file and
.fi os2.fi
is included in each subprogram.
Also note that a number of macros were defined at the top of the file.
By defining these macros, only those components of the OS/2 API required
by the module will be compiled.
.endnote
.np
You can compile, link and run this demonstration by issuing the following
commands.
.millust begin
&prompt.&setcmd finclude=&pathnam.&pc.src&pc.fortran&pc.os2
&prompt.&wclcmd32 &sw.l=os2v2_pm fshapes
&prompt.fshapes
.millust end
.do end
:set symbol="prompt"     value=&oprompt.