freepascal.compiler/docs/go32ex/callback.pp

Program callback;

uses crt,
     go32;

const mouseint = $33;          

var mouse_regs    : trealregs;
    mouse_seginfo : tseginfo;

var mouse_numbuttons : longint;

    mouse_action : word;
    mouse_x, mouse_y : Word;
    mouse_b : Word;

    userproc_installed : Longbool;
    userproc_length : Longint;
    userproc_proc : pointer;

{$ASMMODE DIRECT}
procedure callback_handler; assembler;
asm
   pushw %es
   pushw %ds
   pushl %edi
   pushl %esi
   cmpl $1, _USERPROC_INSTALLED
   je .LNoCallback
   pushal
   movw %es, %ax 
   movw %ax, %ds
   movw U_GO32_DOSMEMSELECTOR, %ax
   movw %ax, %fs  
   call *_USERPROC_PROC
   popal
.LNoCallback:

   popl %esi
   popl %edi
   popw %ds
   popw %es

   movl (%esi), %eax
   movl %eax, %es: 42(%edi) 
   addw $4, %es: 46(%edi)
   iret
end;

procedure mouse_dummy; begin end;

procedure textuserproc;
begin
     mouse_b := mouse_regs.bx;
     mouse_x := (mouse_regs.cx shr 3) + 1;
     mouse_y := (mouse_regs.dx shr 3) + 1;
end;

procedure install_mouse (userproc : pointer; 
                         userproclen : longint);
var r : trealregs;
begin
     r.eax := $0; realintr(mouseint, r);
     if (r.eax <> $FFFF) then begin
        Writeln('No Mircosoft compatible mouse found');
        Write('A Mircosoft compatible mouse driver is');
        writeln(' necessary to run this example');
        halt;
     end;
     if (r.bx = $ffff) then mouse_numbuttons := 2
     else mouse_numbuttons := r.bx;
     Writeln(mouse_numbuttons, 
             ' button Mircosoft compatible mouse found.');
     if (userproc <> nil) then begin
        userproc_proc := userproc;
        userproc_installed := true;
        userproc_length := userproclen;
        lock_code(userproc_proc, userproc_length);
     end else begin
         userproc_proc := nil;
         userproc_length := 0;
         userproc_installed := false;
     end;
     lock_data(mouse_x, sizeof(mouse_x));
     lock_data(mouse_y, sizeof(mouse_y));
     lock_data(mouse_b, sizeof(mouse_b));
     lock_data(mouse_action, sizeof(mouse_action));

     lock_data(userproc_installed, sizeof(userproc_installed));
     lock_data(@userproc_proc, sizeof(userproc_proc));

     lock_data(mouse_regs, sizeof(mouse_regs));
     lock_data(mouse_seginfo, sizeof(mouse_seginfo));
     lock_code(@callback_handler, 
               longint(@mouse_dummy) 
                - longint(@callback_handler));
     get_rm_callback(@callback_handler, mouse_regs, mouse_seginfo);
     r.eax := $0c; r.ecx := $7f; r.edx := longint(mouse_seginfo.offset);
     r.es := mouse_seginfo.segment;
     realintr(mouseint, r);
     r.eax := $01;
     realintr(mouseint, r);
end;

procedure remove_mouse;
var r : trealregs;
begin
     r.eax := $02; realintr(mouseint, r);
     r.eax := $0c; r.ecx := 0; r.edx := 0; r.es := 0;
     realintr(mouseint, r);
     free_rm_callback(mouse_seginfo);
     if (userproc_installed) then begin
        unlock_code(userproc_proc, userproc_length);
        userproc_proc := nil;
        userproc_length := 0;
        userproc_installed := false;
     end;
     unlock_data(mouse_x, sizeof(mouse_x));
     unlock_data(mouse_y, sizeof(mouse_y));
     unlock_data(mouse_b, sizeof(mouse_b));
     unlock_data(mouse_action, sizeof(mouse_action));

     unlock_data(@userproc_proc, sizeof(userproc_proc));
     unlock_data(userproc_installed, 
                 sizeof(userproc_installed));

     unlock_data(mouse_regs, sizeof(mouse_regs));
     unlock_data(mouse_seginfo, sizeof(mouse_seginfo));
     unlock_code(@callback_handler, 
                 longint(@mouse_dummy)
                  - longint(@callback_handler));
     fillchar(mouse_seginfo, sizeof(mouse_seginfo), 0);
end;


begin
     install_mouse(@textuserproc, 400);
     Writeln('Press any key to exit...');
     while (not keypressed) do begin
           { write mouse state info }
           gotoxy(1, wherey);
           write('MouseX : ', mouse_x:2, 
                 ' MouseY : ', mouse_y:2, 
                 ' Buttons : ', mouse_b:2);
     end;
     remove_mouse;
end.