paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 16:39:24 +01:00
Code Issues Packages Projects Releases Wiki Activity

* fixed snapshot building of win16-i8086 in the medium memory model, via the use of FarAddr()

Browse Source 
git-svn-id: trunk@37630 -
This commit is contained in:
nickysn 2017-11-28 00:03:19 +00:00
parent b571f48735
commit 07c18c8689
2 changed files with 18 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
packages/rtl-console/src/win16/keyboard.pp
View File

@ -80,8 +80,8 @@ begin
VK_MENU:
KbdShiftState:=KbdShiftState or %1000;
end;
GetKeyboardState(@KbdState);
charcount:=ToAscii(wParam,Byte(lParam shr 16),@KbdState,@charbuf,0);
GetKeyboardState(FarAddr(KbdState));
charcount:=ToAscii(wParam,Byte(lParam shr 16),FarAddr(KbdState),FarAddr(charbuf),0);
if charcount>0 then
for i:=0 to charcount-1 do
KbdBufEnqueue((kbPhys shl 24) or charbuf[i] or (KbdShiftState shl 16));
@ -118,10 +118,10 @@ function SysGetKeyEvent: TKeyEvent;
var
m: MSG;
begin
while KbdBufEmpty and GetMessage(@m,0,0,0) do
while KbdBufEmpty and GetMessage(FarAddr(m),0,0,0) do
begin
TranslateMessage(@m);
DispatchMessage(@m);
TranslateMessage(FarAddr(m));
DispatchMessage(FarAddr(m));
end;
if KbdBufEmpty then
SysGetKeyEvent:=0
@ -134,10 +134,10 @@ function SysPollKeyEvent: TKeyEvent;
var
m: MSG;
begin
while PeekMessage(@m,0,0,0,1) do
while PeekMessage(FarAddr(m),0,0,0,1) do
begin
TranslateMessage(@m);
DispatchMessage(@m);
TranslateMessage(FarAddr(m));
DispatchMessage(FarAddr(m));
end;
if KbdBufEmpty then
SysPollKeyEvent:=0

20
packages/rtl-console/src/win16/video.pp
View File

@ -51,9 +51,9 @@ var
ch: TVideoCell;
CharWidth,CharHeight: SmallInt;
begin
dc:=BeginPaint(hwnd,@ps);
dc:=BeginPaint(hwnd,FarAddr(ps));
oldfont:=SelectObject(dc,GetStockObject(OEM_FIXED_FONT));
GetTextMetrics(dc,@Metrics);
GetTextMetrics(dc,FarAddr(Metrics));
CharWidth:=Metrics.tmMaxCharWidth;
CharHeight:=Metrics.tmHeight+Metrics.tmExternalLeading;
x1:=ps.rcPaint.left div CharWidth;
@ -76,12 +76,12 @@ begin
ch:=videobuf^[y*ScreenWidth+x];
SetTextColor(dc,ColorRefs[(ch shr 8) and 15]);
SetBkColor(dc,ColorRefs[(ch shr 12) and 15]);
TextOut(dc,x*CharWidth,y*CharHeight,@ch,1);
TextOut(dc,x*CharWidth,y*CharHeight,FarAddr(ch),1);
end;
SetTextColor(dc,oldtextcolor);
SetBkColor(dc,oldbkcolor);
SelectObject(dc,oldfont);
EndPaint(hwnd,@ps);
EndPaint(hwnd,FarAddr(ps));
end;
function MainWndProc(hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; export;
@ -115,7 +115,7 @@ begin
wc.hbrBackground:=GetStockObject(BLACK_BRUSH);
wc.lpszMenuName:=nil;
wc.lpszClassName:='FPCConsoleWndClass';
if not RegisterClass(wc) then
if not RegisterClass(FarAddr(wc)) then
begin
MessageBox(0,'Error registering window class',nil,MB_OK or MB_ICONHAND or MB_TASKMODAL);
Halt(1);
@ -149,10 +149,10 @@ procedure ProcessMessages;
var
m: MSG;
begin
while PeekMessage(@m,0,0,0,1) do
while PeekMessage(FarAddr(m),0,0,0,1) do
begin
TranslateMessage(@m);
DispatchMessage(@m);
TranslateMessage(FarAddr(m));
DispatchMessage(FarAddr(m));
end;
end;
@ -182,7 +182,7 @@ var
begin
dc:=GetDC(VideoWindow);
oldfont:=SelectObject(dc,GetStockObject(OEM_FIXED_FONT));
GetTextMetrics(dc,@Metrics);
GetTextMetrics(dc,FarAddr(Metrics));
CharWidth:=Metrics.tmMaxCharWidth;
CharHeight:=Metrics.tmHeight+Metrics.tmExternalLeading;
oldtextcolor:=GetTextColor(dc);
@ -196,7 +196,7 @@ begin
oldvideobuf^[y*ScreenWidth+x]:=videobuf^[y*ScreenWidth+x];
SetTextColor(dc,ColorRefs[(ch shr 8) and 15]);
SetBkColor(dc,ColorRefs[(ch shr 12) and 15]);
TextOut(dc,x*CharWidth,y*CharHeight,@ch,1);
TextOut(dc,x*CharWidth,y*CharHeight,FarAddr(ch),1);
end;
end;
SetTextColor(dc,oldtextcolor);