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