[fpc-pascal]mysterious error

Hans Mårtensson hm at os.dk
Wed Dec 18 20:17:00 CET 2002


I've got a problem with an error in a Windows program that I cannot locate.
It is about the following procedure:

Procedure OpenFile;
var datafile: file;
Begin
  Assign(datafile,'C:\pp\work\a');
  Reset(datafile,1); if IOResult<>0 then exit;
  Close(datafile);
end;

This procedure, when called from the menu in a window, does nothing and
does no harm.
(The file mentioned exists.)

BUT if I remove the file declaration and put it at the top of the program
to make it a global variabel, the procedure makes the system crash.
The error is a general protection error in modul kernel32.dll.
I enclose the full test program that crashes (on my machine).
In this test program the procedure 'vis' shows the file length in a message
box, and this is shown correct.
Only after pressing the OK button, the program crashes, which shows that it
is on returning from the procedure that the error is invoked.

Maybe something in the windows program is rotten, but what?
(I've taken it mostly from the examples that comes with the Free Pascal
system.)
And how can it be infered by moving the declaration of the file from the
procedure to the program?

Can anyone help me with solving this riddle?

Here is the full testprogram that crashes.
(But add the datafile declaration to the OpenFile procedure, and it works.)
(All this asumes that the file C:\pp\work\a exists.)

//*****************************************************
{$APPTYPE GUI}
{$I-}

Uses Windows;

Const
  AppName = 'test';

Var 
  AMessage: Msg;
  hWindow: HWnd;
  WindowClass: WndClass;
  Menu: hMenu;
  datafile: file;
    
procedure vis(txt: PChar; n: integer);
var p: PChar; i: integer;
begin p:='Værdi=     *'; if n<10000 then begin
    i:=n div 1000; n:=n-i*1000; if i>0 then p[8]:=chr(48+i);
    i:=n div 100; n:=n-i*100; if i>0 then p[9]:=chr(48+i);
    i:=n div 10; n:=n-i*10; if i>0 then p[10]:=chr(48+i);
    i:=n mod 10; p[11]:=chr(48+i); end;
  MessageBox(hWindow,p,txt, MB_OK);
end;

Procedure SaveText;
Begin 
  MessageBox(hWindow,'Not implemented',nil, MB_OK);
End;

Procedure OpenFile;
Var Len: LongInt;
Begin
  Assign(datafile,'C:\pp\work\a');
  Reset(datafile,1); if IOResult<>0 then exit;
  Len := FileSize(datafile); if IOResult<>0 then exit;
  vis('LEN',len);
  Close(datafile);
end;

Function WindowProc(Window:HWnd;AMessage : UINT; WParam : WParam;
LParam:LParam): LResult; export;
Var
  ps: paintstruct;
  dc: hdc;
  r: rect;
  nrmenu : longint;
Begin WindowProc := 0;
  Case AMessage Of
    wm_Paint: Begin
      dc:=BeginPaint(Window, at ps);
      GetClientRect(Window, at r);
      DrawText(dc,'Testprogram',-1, at r, DT_SINGLELINE or DT_CENTER or
DT_VCENTER);
      EndPaint(Window,ps);
      Exit; End;
    wm_Destroy: Begin PostQuitMessage (0); Exit; End;
    wm_Command: Begin
      NrMenu := WParam And $FFFF;
      Case NrMenu Of
        101: Openfile;
        102: SaveText;
        103: PostMessage(Window,WM_Close,0,0);
      End; 
    End;
  End;
  WindowProc := DefWindowProc(Window,AMessage,WParam,LParam);
End;

Function WinRegister: Boolean;
Begin
  With WindowClass Do
    Begin
      Style := cs_hRedraw Or cs_vRedraw;
      lpfnWndProc := WndProc(@WindowProc);
      cbClsExtra := 0;
      cbWndExtra := 0;
      hInstance := system.MainInstance;
      hIcon := LoadIcon (0,idi_Application);
      hCursor := LoadCursor (0,idc_Arrow);
      hbrBackground := GetStockObject(WHITE_BRUSH);
      lpszMenuName := 'Files';
      lpszClassName := AppName;
    End;
  WinRegister := RegisterClass (WindowClass)<>0;
End;

Function WinCreate: HWnd;
Var hWindow: HWnd;
    SubMenu: hMenu;
Begin
  hWindow := CreateWindow (AppName,'Test',
             ws_OverlappedWindow or ws_vscroll,
             cw_UseDefault,cw_UseDefault,cw_UseDefault,
             cw_UseDefault,0,0,system.MainInstance,Nil);
  If hWindow<>0 then begin
    Menu := CreateMenu;
    SubMenu := CreateMenu;
    AppendMenu(Submenu,MF_STRING,101,'&Open file');
    AppendMenu(Submenu,MF_STRING,102,'&Save copy');
    AppendMenu(Submenu,MF_SEPARATOR,0,Nil);
    AppendMenu(SubMenu,MF_String,103,'E&xit');
    AppendMenu(Menu,MF_POPUP,SubMenu,'&Files');
    SubMenu := CreateMenu;
    AppendMenu(Menu,MF_STRING,0,'&Help');
    SetMenu(hWindow,menu);
    ShowWindow(hWindow,CmdShow);
    ShowWindow(hWindow,SW_SHOW);
    UpdateWindow(hWindow);
    End;
  Wincreate := hWindow;
End;

//*************** Main program ********************
Begin
  If Not WinRegister Then
    Begin
      MessageBox (0,'Register failed',Nil, mb_Ok);
    End
  Else
    Begin
      hWindow := WinCreate;
      If longint(hWindow)=0 Then
        Begin
          MessageBox (0,'WinCreate failed',Nil,MB_OK);
        End
      Else
        Begin
          While GetMessage(@AMessage,0,0,0) Do
          Begin
            TranslateMessage(AMessage);
            DispatchMessage(AMessage);
          End;
          Halt(AMessage.wParam);
        End;
    End;
End.





More information about the fpc-pascal mailing list