1{
2    This file is part of the Free Component Library (FCL)
3    Copyright (c) 1998 by Michael Van Canneyt and Florian Klaempfl
4
5    Classes unit for win32
6
7    See the file COPYING.FPC, included in this distribution,
8    for details about the copyright.
9
10    This program is distributed in the hope that it will be useful,
11    but WITHOUT ANY WARRANTY; without even the implied warranty of
12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14 **********************************************************************}
15
16{$mode objfpc}
17
18{ determine the type of the resource/form file }
19{$define Win16Res}
20
21unit Classes;
22
23interface
24
25uses
26  rtlconsts,
27  sysutils,
28  types,
29{$ifdef FPC_TESTGENERICS}
30  fgl,
31{$endif}
32  typinfo,
33  windows;
34
35type
36  TWndMethod = procedure(var msg : TMessage) of object;
37
38function MakeObjectInstance(Method: TWndMethod): Pointer;
39procedure FreeObjectInstance(ObjectInstance: Pointer);
40
41function AllocateHWnd(Method: TWndMethod): HWND;
42procedure DeallocateHWnd(Wnd: HWND);
43
44{$i classesh.inc}
45
46implementation
47
48uses
49  sysconst;
50
51{ OS - independent class implementations are in /inc directory. }
52{$i classes.inc}
53
54type
55  PMethodWrapperTrampoline = ^TMethodWrapperTrampoline;
56  PWrapperBlock = ^TWrapperBlock;
57
58  TMethodWrapperTrampoline = packed record
59    Call : byte;
60    CallOffset : PtrInt;
61    Jmp : byte;
62    JmpOffset : PtrInt;
63    case Integer of
64      0: (Next: PMethodWrapperTrampoline; Block : PWrapperBlock);
65      1: (Method: TWndMethod);
66  end;
67
68  TWrapperBlock = packed record
69    Next : PWrapperBlock;
70    UsageCount : Longint;
71    Trampolines : array[0..0] of TMethodWrapperTrampoline;
72  end;
73
74var
75  WrapperBlockList : PWrapperBlock;
76  TrampolineFreeList : PMethodWrapperTrampoline;
77  CritObjectInstance : TCriticalSection;
78
79function TrampolineWndProc(Window: HWND; Message, WParam: WPARAM;LParam: LPARAM): HRESULT; stdcall; assembler;
80asm
81  // build up tmessage structure
82  pushl $0
83  movl (%eax),%ecx
84  pushl LPARAM
85  pushl WPARAM
86  pushl Message
87  // msg
88  leal (%esp),%edx
89  // load self
90  movl 4(%eax),%eax
91  // call method
92  call %ecx
93  addl $12,%esp
94  // load result
95  popl %eax
96end;
97
98
99function get_method_offset : Pointer;assembler;nostackframe;
100  asm
101    movl    (%esp),%eax
102    addl    $5,%eax
103  end;
104
105
106const
107  SizeOfPage = 4096;
108
109
110function MakeObjectInstance(Method: TWndMethod): Pointer;
111  var
112    NewBlock : PWrapperBlock;
113    Trampoline : PMethodWrapperTrampoline;
114  begin
115    EnterCriticalSection(CritObjectInstance);
116    try
117      if not(assigned(TrampolineFreeList)) then
118        begin
119          NewBlock:=VirtualAlloc(nil,SizeOfPage,MEM_COMMIT,PAGE_EXECUTE_READWRITE);
120          NewBlock^.UsageCount:=0;
121          NewBlock^.Next:=WrapperBlockList;
122          WrapperBlockList:=NewBlock;
123          Trampoline:=@NewBlock^.Trampolines;
124          while pointer(Trampoline)+sizeof(Trampoline)<pointer(NewBlock)+SizeOfPage do
125            begin
126              Trampoline^.Next:=TrampolineFreeList;
127              Trampoline^.Block:=NewBlock;
128              TrampolineFreeList:=Trampoline;
129              inc(Trampoline);
130            end;
131        end;
132      Trampoline:=TrampolineFreeList;
133      TrampolineFreeList:=TrampolineFreeList^.Next;
134//      inc(Trampoline^.Block^.UsageCount);
135      Trampoline^.Call:=$e8;
136      Trampoline^.CallOffset:=pointer(@get_method_offset)-pointer(@Trampoline^.Call)-5;
137      Trampoline^.Jmp:=$e9;
138      Trampoline^.JmpOffset:=pointer(@TrampolineWndProc)-pointer(@Trampoline^.Jmp)-5;
139      Trampoline^.Method:=Method;
140      Result:=Trampoline;
141    finally
142      LeaveCriticalSection(CritObjectInstance);
143    end;
144  end;
145
146
147procedure FreeObjectInstance(ObjectInstance: Pointer);
148  begin
149    EnterCriticalSection(CritObjectInstance);
150    try
151      // block gets overwritten by method dec(PMethodWrapperTrampoline(ObjectInstance)^.Block^.UsageCount);
152      PMethodWrapperTrampoline(ObjectInstance)^.Next:=TrampolineFreeList;
153      TrampolineFreeList:=PMethodWrapperTrampoline(ObjectInstance);
154    finally
155      LeaveCriticalSection(CritObjectInstance);
156    end;
157  end;
158
159
160procedure DeleteInstBlockList;
161  var
162    hp : PWrapperBlock;
163  begin
164    EnterCriticalSection(CritObjectInstance);
165    try
166      while assigned(WrapperBlockList) do
167        begin
168          hp:=WrapperBlockList^.Next;
169          if VirtualFree(WrapperBlockList,4096,MEM_DECOMMIT) then
170            VirtualFree(WrapperBlockList,0,MEM_RELEASE);
171          WrapperBlockList:=hp;
172        end;
173    finally
174      LeaveCriticalSection(CritObjectInstance);
175    end;
176  end;
177
178
179function AllocateHWnd(Method: TWndMethod): HWND;
180  begin
181    { dummy }
182    runerror(217);
183    Result:=0;
184  end;
185
186
187procedure DeallocateHWnd(Wnd: HWND);
188  begin
189    { dummy }
190    runerror(217);
191  end;
192
193
194initialization
195  WrapperBlockList:=nil;
196  TrampolineFreeList:=nil;
197  InitCriticalSection(CritObjectInstance);
198  CommonInit;
199
200finalization
201  CommonCleanup;
202  DeleteInstBlockList;
203  DoneCriticalSection(CritObjectInstance);
204end.
205