paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-13 17:29:42 +02:00
Code Issues Packages Projects Releases Wiki Activity

* a lot of small changes:

Browse Source 
- setlength is internal
     - win32 graph unit extended
     ....
This commit is contained in:
florian 2000-10-21 18:20:17 +00:00
parent f80c24177a
commit 1a2851eb47
11 changed files with 605 additions and 163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
rtl/i386/math.inc
View File

@ -179,6 +179,36 @@
end; end;
end; end;
{****************************************************************************
Helper routines to support old TP styled reals
****************************************************************************}
function real2double(r : real48) : double;
var
res : array[0..7] of byte;
exponent : word;
begin
{ copy mantissa }
res[0]:=0;
res[1]:=r[1] shl 5;
res[2]:=(r[1] shr 3) or (r[2] shl 5);
res[3]:=(r[2] shr 3) or (r[3] shl 5);
res[4]:=(r[3] shr 3) or (r[4] shl 5);
res[5]:=(r[4] shr 3) or (r[5] and $7f) shl 5;
res[6]:=(r[5] and $7f) shr 3;
{ copy exponent }
{ correct exponent: }
exponent:=(word(r[0])+(1023-129));
res[6]:=res[6] or ((exponent and $f) shl 4);
res[7]:=exponent shr 4;
{ set sign }
res[7]:=res[7] or (r[5] and $80);
real2double:=double(res);
end;
{**************************************************************************** {****************************************************************************
Fixed data type routines Fixed data type routines
@ -299,10 +329,16 @@
{ {
$Log$ $Log$
Revision 1.3 2000-07-14 10:33:10 michael Revision 1.4 2000-10-21 18:20:17 florian
* a lot of small changes:
- setlength is internal
- win32 graph unit extended
....
Revision 1.3 2000/07/14 10:33:10 michael
+ Conditionals fixed + Conditionals fixed
Revision 1.2 2000/07/13 11:33:41 michael Revision 1.2 2000/07/13 11:33:41 michael
+ removed logs + removed logs
} }

115
rtl/i386/rttip.inc
View File

@ -14,6 +14,8 @@
**********************************************************************} **********************************************************************}
{ Run-Time type information routines - processor dependent part } { Run-Time type information routines - processor dependent part }
{ I think we should use the pascal version, this code isn't }
{ much faster }
Procedure Initialize (Data,TypeInfo : pointer);[Public,Alias:'FPC_INITIALIZE'];assembler; Procedure Initialize (Data,TypeInfo : pointer);[Public,Alias:'FPC_INITIALIZE'];assembler;
asm asm
@ -30,17 +32,37 @@ asm
jz .LDoAnsiStringInit jz .LDoAnsiStringInit
decb %al decb %al
jz .LDoAnsiStringInit jz .LDoAnsiStringInit
subb $2,%al decb %al
jz .LDoVariantInit
decb %al
jz .LDoArrayInit jz .LDoArrayInit
decb %al decb %al
jz .LDoRecordInit jz .LDoRecordInit
subb $2,%al decb %al
jz .LDoInterfaceInit
decb %al
jz .LDoClassInit jz .LDoClassInit
decb %al decb %al
jz .LDoObjectInit jz .LDoObjectInit
decb %al decb %al
// what is called here ??? FK
jz .LDoClassInit jz .LDoClassInit
subb $4,%al
jz .LDoDynArrayInit
jmp .LExitInitialize jmp .LExitInitialize
// Interfaces
.LDoInterfaceInit:
movl Data, %eax
movl $0,(%eax)
jmp .LExitInitialize
// Variants
.LDoVariantInit:
jmp .LExitInitialize
// dynamic Array
.LDoDynArrayInit:
movl Data, %eax
movl $0,(%eax)
jmp .LExitInitialize
.LDoObjectInit: .LDoObjectInit:
.LDoClassInit: .LDoClassInit:
.LDoRecordInit: .LDoRecordInit:
@ -122,17 +144,46 @@ asm
jz .LDoAnsiStringFinal jz .LDoAnsiStringFinal
decb %al decb %al
jz .LDoAnsiStringFinal jz .LDoAnsiStringFinal
subb $2,%al decb %al
jz .LDoVariantFinal
decb %al
jz .LDoArrayFinal jz .LDoArrayFinal
decb %al decb %al
jz .LDoRecordFinal jz .LDoRecordFinal
subb $2,%al decb %al
jz .LDoInterfaceFinal
decb %al
jz .LDoClassFinal jz .LDoClassFinal
decb %al decb %al
jz .LDoObjectFinal jz .LDoObjectFinal
decb %al decb %al
// what is called here ??? FK
jz .LDoClassFinal jz .LDoClassFinal
subb $4,%al
jz .LDoDynArrayFinal
jmp .LExitFinalize jmp .LExitFinalize
// Interfaces
.LDoInterfaceFinal:
jmp .LExitFinalize
// Variants
.LDoVariantFinal:
jmp .LExitFinalize
// dynamic Array
.LDoDynArrayFinal:
// load count
movl Data,%edx
orl %edx,%edx
jz .LExitFinalize
movl -4(%edx),%edx
incl %ebx
movzbl (%ebx),%eax
incl %eax
addl %eax,%ebx
// %ebx points to size. Put size in ecx
movl (%ebx),%ecx
// %ebx points to type. Put into ebx.
addl $4, %ebx
jmp .LMyArrayFinalLoop
.LDoClassFinal: .LDoClassFinal:
.LDoObjectFinal: .LDoObjectFinal:
.LDoRecordFinal: .LDoRecordFinal:
@ -215,16 +266,37 @@ asm
jz .LDoAnsiStringAddRef jz .LDoAnsiStringAddRef
decb %al decb %al
jz .LDoAnsiStringAddRef jz .LDoAnsiStringAddRef
subb $2,%al decb %al
jz .LDoVariantAddRef
decb %al
jz .LDoArrayAddRef jz .LDoArrayAddRef
decb %al decb %al
jz .LDoRecordAddRef jz .LDoRecordAddRef
subb $2,%al decb %al
jz .LDoInterfaceAddRef
decb %al
jz .LDoClassAddRef jz .LDoClassAddRef
decb %al decb %al
jz .LDoObjectAddRef jz .LDoObjectAddRef
decb %al decb %al
// what is called here ??? FK
jz .LDoClassAddRef jz .LDoClassAddRef
subb $4,%al
jz .LDoDynArrayAddRef
jmp .LExitAddRef
// Interfaces
.LDoInterfaceAddRef:
jmp .LExitAddRef
// Variants
.LDoVariantAddRef:
jmp .LExitAddRef
// Dynamic Arrays
.LDoDynArrayAddRef:
movl Data,%eax
testl %eax,%eax
je .LExitAddRef
lock
incl -4(%eax)
jmp .LExitAddRef jmp .LExitAddRef
.LDoClassAddRef: .LDoClassAddRef:
.LDoObjectAddRef: .LDoObjectAddRef:
@ -306,16 +378,32 @@ asm
jz .LDoAnsiStringDecRef jz .LDoAnsiStringDecRef
decb %al decb %al
jz .LDoAnsiStringDecRef jz .LDoAnsiStringDecRef
subb $2,%al decb %al
jz .LDoVariantDecRef
decb %al
jz .LDoArrayDecRef jz .LDoArrayDecRef
decb %al decb %al
jz .LDoRecordDecRef jz .LDoRecordDecRef
subb $2,%al decb %al
jz .LDoInterfaceDecRef
decb %al
jz .LDoClassDecRef jz .LDoClassDecRef
decb %al decb %al
jz .LDoObjectDecRef jz .LDoObjectDecRef
decb %al decb %al
// what is called here ??? FK
jz .LDoClassDecRef jz .LDoClassDecRef
subb $4,%al
jz .LDoDynArrayDecRef
jmp .LExitDecRef
// Interfaces
.LDoInterfaceDecRef:
jmp .LExitDecRef
// Variants
.LDoVariantDecRef:
jmp .LExitDecRef
// Dynamic Arrays
.LDoDynArrayDecRef:
jmp .LExitDecRef jmp .LExitDecRef
.LDoClassDecRef: .LDoClassDecRef:
.LDoObjectDecRef: .LDoObjectDecRef:
@ -385,7 +473,12 @@ end;
{ {
$Log$ $Log$
Revision 1.2 2000-07-13 11:33:41 michael Revision 1.3 2000-10-21 18:20:17 florian
* a lot of small changes:
- setlength is internal
- win32 graph unit extended
....
Revision 1.2 2000/07/13 11:33:41 michael
+ removed logs + removed logs
}
}

102
rtl/inc/astrings.inc
View File

@ -344,52 +344,11 @@ begin
HandleErrorFrame(201,get_frame); HandleErrorFrame(201,get_frame);
end; end;
{$ifdef ver1_0}
{$ifdef EXTRAANSISHORT}
Function AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString): Longint;
{
Compares a AnsiString with a ShortString;
The result is
<0 if S1<S2
0 if S1=S2
>0 if S1>S2
}
Var
i,MaxI,Temp : Longint;
begin
Temp:=0;
i:=0;
MaxI:=Length(AnsiString(S1));
if MaxI>byte(S2[0]) then
MaxI:=Byte(S2[0]);
While (i<MaxI) and (Temp=0) do
begin
Temp:= PByte(S1+I)^ - Byte(S2[i+1]);
inc(i);
end;
AnsiStr_ShortStr_Compare:=Temp;
end;
{$endif EXTRAANSISHORT}
{*****************************************************************************
Public functions, In interface.
*****************************************************************************}
Function Length (Const S : AnsiString) : Longint;
{
Returns the length of an AnsiString.
Takes in acount that zero strings are NIL;
}
begin
If Pointer(S)=Nil then
Length:=0
else
Length:=PAnsiRec(Pointer(S)-FirstOff)^.Len;
end;
Procedure SetLength (Var S : AnsiString; l : Longint); Procedure SetLength (Var S : AnsiString; l : Longint);
{$else ver1_0}
Procedure AnsiStr_SetLength (Var S : AnsiString; l : Longint);[Public,Alias : 'FPC_ANSISTR_SETLENGTH'];
{$endif ver1_0}
{ {
Sets The length of string S to L. Sets The length of string S to L.
Makes sure S is unique, and contains enough room. Makes sure S is unique, and contains enough room.
@ -435,6 +394,49 @@ begin
end; end;
end; end;
{$ifdef EXTRAANSISHORT}
Function AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString): Longint;
{
Compares a AnsiString with a ShortString;
The result is
<0 if S1<S2
0 if S1=S2
>0 if S1>S2
}
Var
i,MaxI,Temp : Longint;
begin
Temp:=0;
i:=0;
MaxI:=Length(AnsiString(S1));
if MaxI>byte(S2[0]) then
MaxI:=Byte(S2[0]);
While (i<MaxI) and (Temp=0) do
begin
Temp:= PByte(S1+I)^ - Byte(S2[i+1]);
inc(i);
end;
AnsiStr_ShortStr_Compare:=Temp;
end;
{$endif EXTRAANSISHORT}
{*****************************************************************************
Public functions, In interface.
*****************************************************************************}
Function Length (Const S : AnsiString) : Longint;
{
Returns the length of an AnsiString.
Takes in acount that zero strings are NIL;
}
begin
If Pointer(S)=Nil then
Length:=0
else
Length:=PAnsiRec(Pointer(S)-FirstOff)^.Len;
end;
Procedure UniqueString(Var S : AnsiString); [Public,Alias : 'FPC_ANSISTR_UNIQUE']; Procedure UniqueString(Var S : AnsiString); [Public,Alias : 'FPC_ANSISTR_UNIQUE'];
{ {
@ -666,7 +668,13 @@ end;
{ {
$Log$ $Log$
Revision 1.5 2000-08-29 18:39:42 peter Revision 1.6 2000-10-21 18:20:17 florian
* a lot of small changes:
- setlength is internal
- win32 graph unit extended
....
Revision 1.5 2000/08/29 18:39:42 peter
* fixed chararray to ansistring (merged) * fixed chararray to ansistring (merged)
Revision 1.4 2000/08/24 07:37:21 jonas Revision 1.4 2000/08/24 07:37:21 jonas
@ -680,4 +688,4 @@ end;
Revision 1.2 2000/07/13 11:33:42 michael Revision 1.2 2000/07/13 11:33:42 michael
+ removed logs + removed logs
} }

84
rtl/inc/charset.pp
View File

@ -39,7 +39,7 @@ unit charset;
punicodemap = ^tunicodemap; punicodemap = ^tunicodemap;
tunicodemap = record tunicodemap = record
cpname : shortstring; cpname : string[20];
map : punicodecharmapping; map : punicodecharmapping;
lastchar : longint; lastchar : longint;
next : punicodemap; next : punicodemap;
@ -51,6 +51,10 @@ unit charset;
function loadunicodemapping(const cpname,f : string) : punicodemap; function loadunicodemapping(const cpname,f : string) : punicodemap;
procedure registermapping(p : punicodemap); procedure registermapping(p : punicodemap);
function getmap(const s : string) : punicodemap;
function mappingavailable(const s : string) : boolean;
function getunicode(c : char;p : punicodemap) : tunicodechar;
function getascii(c : tunicodechar;p : punicodemap) : string;
implementation implementation
@ -84,9 +88,9 @@ unit charset;
freemem(data,sizeof(tunicodecharmapping)*datasize); freemem(data,sizeof(tunicodecharmapping)*datasize);
exit; exit;
end; end;
readln(t,s);
while not(eof(t)) do while not(eof(t)) do
begin begin
readln(t,s);
if (s[1]='0') and (s[2]='x') then if (s[1]='0') and (s[2]='x') then
begin begin
flag:=umf_unused; flag:=umf_unused;
@ -147,7 +151,6 @@ unit charset;
if charpos>lastchar then if charpos>lastchar then
lastchar:=charpos; lastchar:=charpos;
end; end;
readln(t,s);
end; end;
close(t); close(t);
new(p); new(p);
@ -166,6 +169,70 @@ unit charset;
mappings:=p; mappings:=p;
end; end;
function getmap(const s : string) : punicodemap;
var
hp : punicodemap;
const
mapcache : string = '';
mapcachep : punicodemap = nil;
begin
if (mapcache=s) and (mapcachep^.cpname=s) then
begin
getmap:=mapcachep;
exit;
end;
hp:=mappings;
while assigned(hp) do
begin
if hp^.cpname=s then
begin
getmap:=hp;
mapcache:=s;
mapcachep:=hp;
exit;
end;
hp:=hp^.next;
end;
getmap:=nil;
end;
function mappingavailable(const s : string) : boolean;
begin
mappingavailable:=getmap(s)<>nil;
end;
function getunicode(c : char;p : punicodemap) : tunicodechar;
begin
if ord(c)<=p^.lastchar then
getunicode:=p^.map[ord(c)].unicode
else
getunicode:=0;
end;
function getascii(c : tunicodechar;p : punicodemap) : string;
var
i : longint;
begin
{ at least map to space }
getascii:=#32;
for i:=0 to p^.lastchar do
if p^.map[i].unicode=c then
begin
if i<256 then
getascii:=chr(i)
else
getascii:=chr(i div 256)+chr(i mod 256);
exit;
end;
end;
var var
hp : punicodemap; hp : punicodemap;
@ -185,7 +252,12 @@ finalization
end. end.
{ {
$Log$ $Log$
Revision 1.1 2000-08-17 07:29:39 florian Revision 1.2 2000-10-21 18:20:17 florian
+ initial revision * a lot of small changes:
- setlength is internal
- win32 graph unit extended
....
} Revision 1.1 2000/08/17 07:29:39 florian
+ initial revision
}

13
rtl/inc/mathh.inc
View File

@ -49,6 +49,11 @@
function power(bas,expo : longint) : longint; function power(bas,expo : longint) : longint;
type
real48 = array[0..5] of byte;
function Real2Double(r : real48) : double;
{$ifdef HASFIXED} {$ifdef HASFIXED}
function sqrt(d : fixed) : fixed; function sqrt(d : fixed) : fixed;
function Round(x: fixed): longint; function Round(x: fixed): longint;
@ -61,7 +66,13 @@
{ {
$Log$ $Log$
Revision 1.2 2000-07-13 11:33:44 michael Revision 1.3 2000-10-21 18:20:17 florian
* a lot of small changes:
- setlength is internal
- win32 graph unit extended
....
Revision 1.2 2000/07/13 11:33:44 michael
+ removed logs + removed logs
} }

13
rtl/inc/rtti.inc
View File

@ -40,6 +40,7 @@ Const
tkBool = 18; tkBool = 18;
tkInt64 = 19; tkInt64 = 19;
tkQWord = 20; tkQWord = 20;
tkDynArray = 21;
{ A record is designed as follows : { A record is designed as follows :
1 : tkrecord 1 : tkrecord
@ -88,7 +89,13 @@ TArrayRec = record
{ {
$Log$ $Log$
Revision 1.2 2000-07-13 11:33:45 michael Revision 1.3 2000-10-21 18:20:17 florian
* a lot of small changes:
- setlength is internal
- win32 graph unit extended
....
Revision 1.2 2000/07/13 11:33:45 michael
+ removed logs + removed logs
} }

29
rtl/inc/sstrings.inc
View File

@ -17,6 +17,16 @@
****************************************************************************} ****************************************************************************}
{$I real2str.inc} {$I real2str.inc}
{$ifdef ver1_0}
procedure SetLength(var s:shortstring;len:StrLenInt);
{$else ver1_0}
procedure Shortstr_SetLength(var s:shortstring;len:StrLenInt);[Public,Alias : 'FPC_SHORTSTR_SETLENGTH'];
{$endif ver1_0}
begin
if Len>255 then
Len:=255;
s[0]:=chr(len);
end;
function copy(const s : shortstring;index : StrLenInt;count : StrLenInt): shortstring; function copy(const s : shortstring;index : StrLenInt;count : StrLenInt): shortstring;
begin begin
@ -133,15 +143,6 @@ begin
pos:=0; pos:=0;
end; end;
procedure SetLength(var s:shortstring;len:StrLenInt);
begin
if Len>255 then
Len:=255;
s[0]:=chr(len);
end;
function copy(c:char;index : StrLenInt;count : StrLenInt): shortstring; function copy(c:char;index : StrLenInt;count : StrLenInt): shortstring;
begin begin
if (index=1) and (Count>0) then if (index=1) and (Count>0) then
@ -558,12 +559,18 @@ end;
{ {
$Log$ $Log$
Revision 1.3 2000-07-28 12:29:49 jonas Revision 1.4 2000-10-21 18:20:17 florian
* a lot of small changes:
- setlength is internal
- win32 graph unit extended
....
Revision 1.3 2000/07/28 12:29:49 jonas
* fixed web bug1069 * fixed web bug1069
* fixed similar (and other) problems in val() for int64 and qword * fixed similar (and other) problems in val() for int64 and qword
(both merged from fixes branch) (both merged from fixes branch)
Revision 1.2 2000/07/13 11:33:45 michael Revision 1.2 2000/07/13 11:33:45 michael
+ removed logs + removed logs
} }

30
rtl/inc/systemh.inc
View File

@ -93,15 +93,15 @@ Type
PInt64 = ^Int64; PInt64 = ^Int64;
currency = int64; currency = int64;
HRESULT = Longint; HRESULT = Longint;
TDateTime = Double; TDateTime = Double;
Error = Longint; Error = Longint;
PSmallInt = ^Smallint; PSmallInt = ^Smallint;
PInteger = ^Longint; PInteger = ^Longint;
PSingle = ^Single; PSingle = ^Single;
PDouble = ^Double; PDouble = ^Double;
PCurrency = ^Currency; PCurrency = ^Currency;
PDate = ^TDateTime; PDate = ^TDateTime;
PPWideChar = ^PWideChar; PPWideChar = ^PWideChar;
PError = ^Error; PError = ^Error;
@ -267,13 +267,15 @@ function strpas(p:pchar):shortstring;
function strlen(p:pchar):longint; function strlen(p:pchar):longint;
{ Shortstring functions } { Shortstring functions }
{$ifdef ver1_0}
Procedure SetLength (Var S : ShortString; l : Longint);
{$endif ver1_0}
Function Copy(const s:shortstring;index:StrLenInt;count:StrLenInt):shortstring; Function Copy(const s:shortstring;index:StrLenInt;count:StrLenInt):shortstring;
Procedure Delete(Var s:shortstring;index:StrLenInt;count:StrLenInt); Procedure Delete(Var s:shortstring;index:StrLenInt;count:StrLenInt);
Procedure Insert(const source:shortstring;Var s:shortstring;index:StrLenInt); Procedure Insert(const source:shortstring;Var s:shortstring;index:StrLenInt);
Procedure Insert(source:Char;Var s:shortstring;index:StrLenInt); Procedure Insert(source:Char;Var s:shortstring;index:StrLenInt);
Function Pos(const substr:shortstring;const s:shortstring):StrLenInt; Function Pos(const substr:shortstring;const s:shortstring):StrLenInt;
Function Pos(C:Char;const s:shortstring):StrLenInt; Function Pos(C:Char;const s:shortstring):StrLenInt;
Procedure SetLength(var s:shortstring;len:StrLenInt);
Procedure SetString (Var S : Shortstring; Buf : PChar; Len : Longint); Procedure SetString (Var S : Shortstring; Buf : PChar; Len : Longint);
Procedure SetString (Var S : AnsiString; Buf : PChar; Len : Longint); Procedure SetString (Var S : AnsiString; Buf : PChar; Len : Longint);
Function Length(s:string):byte; Function Length(s:string):byte;
@ -302,7 +304,9 @@ function length(c:char):byte;
AnsiString Handling AnsiString Handling
****************************************************************************} ****************************************************************************}
{$ifdef ver1_0}
Procedure SetLength (Var S : AnsiString; l : Longint); Procedure SetLength (Var S : AnsiString; l : Longint);
{$endif ver1_0}
Procedure UniqueString (Var S : AnsiString); Procedure UniqueString (Var S : AnsiString);
Function Length (Const S : AnsiString) : Longint; Function Length (Const S : AnsiString) : Longint;
Function Copy (Const S : AnsiString; Index,Size : Longint) : AnsiString; Function Copy (Const S : AnsiString; Index,Size : Longint) : AnsiString;
@ -316,13 +320,17 @@ Function StringOfChar(c : char;l : longint) : AnsiString;
WideString Handling WideString Handling
****************************************************************************} ****************************************************************************}
{$ifdef haswidechar}
{$ifdef ver1_0}
Procedure SetLength (Var S : WideString; l : Longint); Procedure SetLength (Var S : WideString; l : Longint);
{$endif ver1_0}
Procedure UniqueString (Var S : WideString); Procedure UniqueString (Var S : WideString);
Function Length (Const S : WideString) : Longint; Function Length (Const S : WideString) : Longint;
Function Copy (Const S : WideString; Index,Size : Longint) : WideString; Function Copy (Const S : WideString; Index,Size : Longint) : WideString;
Function Pos (Const Substr : WideString; Const Source : WideString) : Longint; Function Pos (Const Substr : WideString; Const Source : WideString) : Longint;
Procedure Insert (Const Source : WideString; Var S : WideString; Index : Longint); Procedure Insert (Const Source : WideString; Var S : WideString; Index : Longint);
Procedure Delete (Var S : WideString; Index,Size: Longint); Procedure Delete (Var S : WideString; Index,Size: Longint);
{$endif haswidechar}
{**************************************************************************** {****************************************************************************
@ -476,7 +484,13 @@ const
{ {
$Log$ $Log$
Revision 1.5 2000-08-13 17:55:15 michael Revision 1.6 2000-10-21 18:20:17 florian
* a lot of small changes:
- setlength is internal
- win32 graph unit extended
....
Revision 1.5 2000/08/13 17:55:15 michael
+ Added some delphi compatibility types + Added some delphi compatibility types
Revision 1.4 2000/08/08 22:11:45 sg Revision 1.4 2000/08/08 22:11:45 sg
@ -487,5 +501,5 @@ const
Revision 1.2 2000/07/13 11:33:45 michael Revision 1.2 2000/07/13 11:33:45 michael
+ removed logs + removed logs
} }

53
rtl/inc/wstrings.inc
View File

@ -294,25 +294,11 @@ begin
HandleErrorFrame(201,get_frame); HandleErrorFrame(201,get_frame);
end; end;
{$ifdef ver1_0}
{*****************************************************************************
Public functions, In interface.
*****************************************************************************}
Function Length (Const S : WideString) : Longint;
{
Returns the length of an WideString.
Takes in acount that zero strings are NIL;
}
begin
If Pointer(S)=Nil then
Length:=0
else
Length:=PWideRec(Pointer(S)-WideFirstOff)^.Len;
end;
Procedure SetLength (Var S : WideString; l : Longint); Procedure SetLength (Var S : WideString; l : Longint);
{$else ver1_0}
Procedure WideStr_SetLength (Var S : WideString; l : Longint);[Public,Alias : 'FPC_WIDESTR_SETLENGTH'];
{$endif ver1_0}
{ {
Sets The length of string S to L. Sets The length of string S to L.
Makes sure S is unique, and contains enough room. Makes sure S is unique, and contains enough room.
@ -352,6 +338,25 @@ begin
end; end;
{*****************************************************************************
Public functions, In interface.
*****************************************************************************}
Function Length (Const S : WideString) : Longint;
{
Returns the length of an WideString.
Takes in acount that zero strings are NIL;
}
begin
If Pointer(S)=Nil then
Length:=0
else
Length:=PWideRec(Pointer(S)-WideFirstOff)^.Len;
end;
Procedure UniqueString(Var S : WideString); [Public,Alias : 'FPC_WIDESTR_UNIQUE']; Procedure UniqueString(Var S : WideString); [Public,Alias : 'FPC_WIDESTR_UNIQUE'];
{ {
Make sure reference count of S is 1, Make sure reference count of S is 1,
@ -495,11 +500,17 @@ end;}
{ {
$Log$ $Log$
Revision 1.3 2000-08-08 22:12:36 sg Revision 1.4 2000-10-21 18:20:17 florian
* a lot of small changes:
- setlength is internal
- win32 graph unit extended
....
Revision 1.3 2000/08/08 22:12:36 sg
* Implemented WideString helper functions (but they are not tested yet * Implemented WideString helper functions (but they are not tested yet
due to the lack of full compiler support for WideString/WideChar!) due to the lack of full compiler support for WideString/WideChar!)
Revision 1.2 2000/07/13 11:33:46 michael Revision 1.2 2000/07/13 11:33:46 michael
+ removed logs + removed logs
} }

273
rtl/win32/graph.pp
View File

@ -28,7 +28,16 @@ uses
{ this procedure allows to hook mouse messages } { this procedure allows to hook mouse messages }
mousemessagehandler : function(Window: hwnd; AMessage, WParam, mousemessagehandler : function(Window: hwnd; AMessage, WParam,
LParam: Longint): Longint; LParam: Longint): Longint;
mainwindow : HWnd; { this procedure allows to wm_command messages }
commandmessagehandler : function(Window: hwnd; AMessage, WParam,
LParam: Longint): Longint;
NotifyMessageHandler : function(Window: hwnd; AMessage, WParam,
LParam: Longint): Longint;
OnGraphWindowCreation : procedure;
GraphWindow,ParentWindow : HWnd;
// this allows direct drawing to the window // this allows direct drawing to the window
bitmapdc : hdc; bitmapdc : hdc;
windc : hdc; windc : hdc;
@ -41,8 +50,15 @@ uses
graphwindowstyle : DWord = cs_hRedraw or cs_vRedraw; graphwindowstyle : DWord = cs_hRedraw or cs_vRedraw;
windowtitle : pchar = 'Graph window application'; windowtitle : pchar = 'Graph window application';
menu : hmenu = 0;
icon : hicon = 0;
drawtoscreen : boolean = true; drawtoscreen : boolean = true;
drawtobitmap : boolean = true; drawtobitmap : boolean = true;
// the graph window can be a child window, this allows to add toolbars
// to the main window
UseChildWindow : boolean = false;
// this allows to specify an offset for the child child window
ChildOffset : rect = (left:0;top:0;right:0;bottom:0);
CONST CONST
@ -227,7 +243,7 @@ procedure DirectPutPixel16Win32GUI(x,y : integer);
case currentwritemode of case currentwritemode of
XorPut: XorPut:
Begin Begin
c2:=Windows.GetPixel(bitmapdc,x,y); c2:=Windows.GetPixel(windc,x,y);
c:=RGB(pal[col].red,pal[col].green,pal[col].blue) xor c2; c:=RGB(pal[col].red,pal[col].green,pal[col].blue) xor c2;
if drawtobitmap then if drawtobitmap then
SetPixelV(bitmapdc,x,y,c); SetPixelV(bitmapdc,x,y,c);
@ -236,7 +252,7 @@ procedure DirectPutPixel16Win32GUI(x,y : integer);
End; End;
AndPut: AndPut:
Begin Begin
c2:=Windows.GetPixel(bitmapdc,x,y); c2:=Windows.GetPixel(windc,x,y);
c:=RGB(pal[col].red,pal[col].green,pal[col].blue) and c2; c:=RGB(pal[col].red,pal[col].green,pal[col].blue) and c2;
if drawtobitmap then if drawtobitmap then
SetPixelV(bitmapdc,x,y,c); SetPixelV(bitmapdc,x,y,c);
@ -245,7 +261,7 @@ procedure DirectPutPixel16Win32GUI(x,y : integer);
End; End;
OrPut: OrPut:
Begin Begin
c2:=Windows.GetPixel(bitmapdc,x,y); c2:=Windows.GetPixel(windc,x,y);
c:=RGB(pal[col].red,pal[col].green,pal[col].blue) or c2; c:=RGB(pal[col].red,pal[col].green,pal[col].blue) or c2;
if drawtobitmap then if drawtobitmap then
SetPixelV(bitmapdc,x,y,c); SetPixelV(bitmapdc,x,y,c);
@ -740,13 +756,13 @@ procedure HLine16Win32GUI(x,x2,y: integer);
col:=CurrentColor; col:=CurrentColor;
for i:=x to x2 do for i:=x to x2 do
begin begin
c2:=Windows.GetPixel(bitmapdc,i,y); c2:=Windows.GetPixel(windc,i,y);
c:=RGB(pal[col].red,pal[col].green,pal[col].blue) and c2; c:=RGB(pal[col].red,pal[col].green,pal[col].blue) and c2;
if drawtobitmap then if drawtobitmap then
SetPixel(bitmapdc,i,y,c); SetPixelV(bitmapdc,i,y,c);
if drawtoscreen then if drawtoscreen then
SetPixel(windc,i,y,c); SetPixelV(windc,i,y,c);
end; end;
LeaveCriticalSection(graphdrawing); LeaveCriticalSection(graphdrawing);
End; End;
@ -756,14 +772,14 @@ procedure HLine16Win32GUI(x,x2,y: integer);
col:=CurrentColor; col:=CurrentColor;
for i:=x to x2 do for i:=x to x2 do
begin begin
c2:=Windows.GetPixel(bitmapdc,i,y); c2:=Windows.GetPixel(windc,i,y);
c:=RGB(pal[col].red,pal[col].green,pal[col].blue) xor c2; c:=RGB(pal[col].red,pal[col].green,pal[col].blue) xor c2;
if drawtobitmap then if drawtobitmap then
SetPixel(bitmapdc,i,y,c); SetPixelV(bitmapdc,i,y,c);
if drawtoscreen then if drawtoscreen then
SetPixel(windc,i,y,c); SetPixelV(windc,i,y,c);
end; end;
LeaveCriticalSection(graphdrawing); LeaveCriticalSection(graphdrawing);
End; End;
@ -773,14 +789,14 @@ procedure HLine16Win32GUI(x,x2,y: integer);
col:=CurrentColor; col:=CurrentColor;
for i:=x to x2 do for i:=x to x2 do
begin begin
c2:=Windows.GetPixel(bitmapdc,i,y); c2:=Windows.GetPixel(windc,i,y);
c:=RGB(pal[col].red,pal[col].green,pal[col].blue) or c2; c:=RGB(pal[col].red,pal[col].green,pal[col].blue) or c2;
if drawtobitmap then if drawtobitmap then
SetPixel(bitmapdc,i,y,c); SetPixelV(bitmapdc,i,y,c);
if drawtoscreen then if drawtoscreen then
SetPixel(windc,i,y,c); SetPixelV(windc,i,y,c);
end; end;
LeaveCriticalSection(graphdrawing); LeaveCriticalSection(graphdrawing);
End End
@ -1144,7 +1160,7 @@ procedure restorestate;
begin begin
end; end;
function WindowProc(Window: HWnd; AMessage, WParam, function WindowProcGraph(Window: HWnd; AMessage, WParam,
LParam: Longint): Longint; stdcall; export; LParam: Longint): Longint; stdcall; export;
var var
@ -1156,7 +1172,7 @@ function WindowProc(Window: HWnd; AMessage, WParam,
i : longint; i : longint;
begin begin
WindowProc := 0; WindowProcGraph := 0;
case AMessage of case AMessage of
wm_lbuttondown, wm_lbuttondown,
@ -1180,18 +1196,33 @@ begin
wm_ncrbuttondblclk, wm_ncrbuttondblclk,
wm_ncmbuttondblclk: wm_ncmbuttondblclk:
} }
if assigned(mousemessagehandler) then begin
WindowProc:=mousemessagehandler(window,amessage,wparam,lparam); if assigned(mousemessagehandler) then
WindowProcGraph:=mousemessagehandler(window,amessage,wparam,lparam);
end;
wm_notify:
begin
if assigned(notifymessagehandler) then
WindowProcGraph:=notifymessagehandler(window,amessage,wparam,lparam);
end;
wm_command:
if assigned(commandmessagehandler) then
WindowProcGraph:=commandmessagehandler(window,amessage,wparam,lparam);
wm_keydown, wm_keydown,
wm_keyup, wm_keyup,
wm_char: wm_char:
if assigned(charmessagehandler) then begin
WindowProc:=charmessagehandler(window,amessage,wparam,lparam); if assigned(charmessagehandler) then
WindowProcGraph:=charmessagehandler(window,amessage,wparam,lparam);
end;
wm_paint: wm_paint:
begin begin
{$ifdef DEBUG_WM_PAINT} {$ifdef DEBUG_WM_PAINT}
inc(wm_paint_count); inc(wm_paint_count);
{$endif DEBUG_WM_PAINT} {$endif DEBUG_WM_PAINT}
{$ifdef DEBUGCHILDS}
writeln('Start child painting');
{$endif DEBUGCHILDS}
if not GetUpdateRect(Window,@r,false) then if not GetUpdateRect(Window,@r,false) then
exit; exit;
EnterCriticalSection(graphdrawing); EnterCriticalSection(graphdrawing);
@ -1214,8 +1245,15 @@ begin
assign(graphdebug,'wingraph.log'); assign(graphdebug,'wingraph.log');
rewrite(graphdebug); rewrite(graphdebug);
{$endif DEBUG_WM_PAINT} {$endif DEBUG_WM_PAINT}
{$ifdef DEBUGCHILDS}
writeln('Creating window (HWND: ',window,')... ');
{$endif DEBUGCHILDS}
GraphWindow:=window;
EnterCriticalSection(graphdrawing); EnterCriticalSection(graphdrawing);
dc:=GetDC(window); dc:=GetDC(window);
{$ifdef DEBUGCHILDS}
writeln('Window DC: ',dc);
{$endif DEBUGCHILDS}
bitmapdc:=CreateCompatibleDC(dc); bitmapdc:=CreateCompatibleDC(dc);
savedscreen:=CreateCompatibleBitmap(dc,maxx+1,maxy+1); savedscreen:=CreateCompatibleBitmap(dc,maxx+1,maxy+1);
ReleaseDC(window,dc); ReleaseDC(window,dc);
@ -1239,14 +1277,20 @@ begin
// clear predefined pens // clear predefined pens
fillchar(pens,sizeof(pens),0); fillchar(pens,sizeof(pens),0);
if assigned(OnGraphWindowCreation) then
OnGraphWindowCreation;
LeaveCriticalSection(graphdrawing); LeaveCriticalSection(graphdrawing);
{$ifdef DEBUGCHILDS}
writeln('done');
GetClientRect(window,@r);
writeln('Window size: ',r.right,',',r.bottom);
{$endif DEBUGCHILDS}
end; end;
wm_Destroy: wm_Destroy:
begin begin
EnterCriticalSection(graphdrawing); EnterCriticalSection(graphdrawing);
graphrunning:=false; graphrunning:=false;
ReleaseDC(mainwindow,windc); ReleaseDC(GraphWindow,windc);
SelectObject(bitmapdc,oldbitmap); SelectObject(bitmapdc,oldbitmap);
DeleteObject(savedscreen); DeleteObject(savedscreen);
DeleteDC(bitmapdc); DeleteDC(bitmapdc);
@ -1270,7 +1314,33 @@ begin
Exit; Exit;
end end
else else
WindowProc := DefWindowProc(Window, AMessage, WParam, LParam); WindowProcGraph := DefWindowProc(Window, AMessage, WParam, LParam);
end;
end;
function WindowProcParent(Window: HWnd; AMessage, WParam,
LParam: Longint): Longint; stdcall; export;
begin
WindowProcParent := 0;
case AMessage of
wm_keydown,
wm_keyup,
wm_char:
begin
if assigned(charmessagehandler) then
WindowProcParent:=charmessagehandler(window,amessage,wparam,lparam);
end;
wm_notify:
begin
if assigned(notifymessagehandler) then
WindowProcParent:=notifymessagehandler(window,amessage,wparam,lparam);
end;
wm_command:
if assigned(commandmessagehandler) then
WindowProcParent:=commandmessagehandler(window,amessage,wparam,lparam);
else
WindowProcParent := DefWindowProc(Window, AMessage, WParam, LParam);
end; end;
end; end;
@ -1279,19 +1349,69 @@ var
WindowClass: WndClass; WindowClass: WndClass;
begin begin
WindowClass.Style := graphwindowstyle; WindowClass.Style := graphwindowstyle;
WindowClass.lpfnWndProc := WndProc(@WindowProc); WindowClass.lpfnWndProc := WndProc(@WindowProcGraph);
WindowClass.cbClsExtra := 0; WindowClass.cbClsExtra := 0;
WindowClass.cbWndExtra := 0; WindowClass.cbWndExtra := 0;
WindowClass.hInstance := system.MainInstance; WindowClass.hInstance := system.MainInstance;
WindowClass.hIcon := LoadIcon(0, idi_Application); if icon<>0 then
WindowClass.hIcon := icon
else
WindowClass.hIcon := LoadIcon(0, idi_Application);
WindowClass.hCursor := LoadCursor(0, idc_Arrow); WindowClass.hCursor := LoadCursor(0, idc_Arrow);
WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH); WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH);
WindowClass.lpszMenuName := nil; if menu<>0 then
WindowClass.lpszMenuName := MAKEINTRESOURCE(menu)
else
WindowClass.lpszMenuName := nil;
WindowClass.lpszClassName := 'FPCGraphWindow'; WindowClass.lpszClassName := 'FPCGraphWindow';
winregister:=RegisterClass(WindowClass) <> 0; winregister:=RegisterClass(WindowClass) <> 0;
end; end;
function WinRegisterWithChild: Boolean;
var
WindowClass: WndClass;
begin
WindowClass.Style := graphwindowstyle;
WindowClass.lpfnWndProc := WndProc(@WindowProcParent);
WindowClass.cbClsExtra := 0;
WindowClass.cbWndExtra := 0;
WindowClass.hInstance := system.MainInstance;
if icon<>0 then
WindowClass.hIcon := icon
else
WindowClass.hIcon := LoadIcon(0, idi_Application);
WindowClass.hCursor := LoadCursor(0, idc_Arrow);
WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH);
if menu<>0 then
WindowClass.lpszMenuName := MAKEINTRESOURCE(menu)
else
WindowClass.lpszMenuName := nil;
WindowClass.lpszClassName := 'FPCGraphWindowMain';
WinRegisterWithChild:=RegisterClass(WindowClass) <> 0;
{$ifdef DEBUGCHILDS}
writeln('Main window successfully registered: WinRegisterWithChild is ',WinRegisterWithChild);
{$endif DEBUGCHILDS}
if WinRegisterWithChild then
begin
WindowClass.Style := CS_HREDRAW or CS_VREDRAW;
WindowClass.lpfnWndProc := WndProc(@WindowProcGraph);
WindowClass.cbClsExtra := 0;
WindowClass.cbWndExtra := 0;
WindowClass.hInstance := system.MainInstance;
WindowClass.hIcon := 0;
WindowClass.hCursor := LoadCursor(0, idc_Arrow);
WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH);
WindowClass.lpszMenuName := nil;
WindowClass.lpszClassName := 'FPCGraphWindowChild';
WinRegisterWithChild:=RegisterClass(WindowClass)<>0;
{$ifdef DEBUGCHILDS}
writeln('Child window registered: WinRegisterWithChild is ',WinRegisterWithChild);
{$endif DEBUGCHILDS}
end;
end;
var var
// here we can force the creation of a maximized window } // here we can force the creation of a maximized window }
extrastyle : longint; extrastyle : longint;
@ -1301,20 +1421,52 @@ function WinCreate : HWnd;
var var
hWindow: HWnd; hWindow: HWnd;
begin begin
WinCreate:=0;
hWindow := CreateWindow('FPCGraphWindow', windowtitle, if UseChildWindow then
ws_OverlappedWindow or extrastyle, CW_USEDEFAULT, 0, begin
maxx+1+2*GetSystemMetrics(SM_CXFRAME), ParentWindow:=CreateWindow('FPCGraphWindowMain', windowtitle,
maxy+1+2*GetSystemMetrics(SM_CYFRAME)+ WS_OVERLAPPEDWINDOW or WS_CLIPCHILDREN or extrastyle, CW_USEDEFAULT, 0,
GetSystemMetrics(SM_CYCAPTION), maxx+ChildOffset.Left+ChildOffset.Right+1+
0, 0, system.MainInstance, nil); 2*GetSystemMetrics(SM_CXFRAME),
maxy+ChildOffset.Top+ChildOffset.Bottom+1+
if hWindow <> 0 then begin 2*GetSystemMetrics(SM_CYFRAME)+
ShowWindow(hWindow, SW_SHOW); GetSystemMetrics(SM_CYCAPTION),
UpdateWindow(hWindow); 0, 0, system.MainInstance, nil);
end; if ParentWindow<>0 then
begin
wincreate:=hWindow; ShowWindow(ParentWindow, SW_SHOW);
UpdateWindow(ParentWindow);
end
else
exit;
hWindow:=CreateWindow('FPCGraphWindowChild',nil,
WS_CHILD, ChildOffset.Left,ChildOffset.Top,
maxx+1,maxy+1,
ParentWindow, 0, system.MainInstance, nil);
if hwindow<>0 then
begin
ShowWindow(hwindow, SW_SHOW);
UpdateWindow(hwindow);
end
else
exit;
WinCreate:=hWindow;
end
else
begin
hWindow:=CreateWindow('FPCGraphWindow', windowtitle,
ws_OverlappedWindow or extrastyle, CW_USEDEFAULT, 0,
maxx+1+2*GetSystemMetrics(SM_CXFRAME),
maxy+1+2*GetSystemMetrics(SM_CYFRAME)+
GetSystemMetrics(SM_CYCAPTION),
0, 0, system.MainInstance, nil);
if hWindow <> 0 then
begin
ShowWindow(hWindow, SW_SHOW);
UpdateWindow(hWindow);
WinCreate:=hWindow;
end;
end;
end; end;
const const
@ -1328,15 +1480,26 @@ function MessageHandleThread(p : pointer) : DWord;StdCall;
begin begin
if not(winregistered) then if not(winregistered) then
begin begin
if not WinRegister then if UseChildWindow then
begin begin
MessageBox(0, 'Window registration failed', nil, mb_Ok); if not(WinRegisterWithChild) then
ExitThread(1); begin
MessageBox(0, 'Window registration failed', nil, mb_Ok);
ExitThread(1);
end;
end
else
begin
if not(WinRegister) then
begin
MessageBox(0, 'Window registration failed', nil, mb_Ok);
ExitThread(1);
end;
end; end;
GraphWindow:=WinCreate;
winregistered:=true; winregistered:=true;
end; end;
MainWindow := WinCreate; if longint(GraphWindow) = 0 then begin
if longint(mainwindow) = 0 then begin
MessageBox(0, 'Window creation failed', nil, mb_Ok); MessageBox(0, 'Window creation failed', nil, mb_Ok);
ExitThread(1); ExitThread(1);
end; end;
@ -1383,7 +1546,10 @@ procedure CloseGraph;
_graphresult := grnoinitgraph; _graphresult := grnoinitgraph;
exit exit
end; end;
PostMessage(MainWindow,wm_destroy,0,0); if UseChildWindow then
PostMessage(ParentWindow,wm_destroy,0,0)
else
PostMessage(GraphWindow,wm_destroy,0,0);
PostThreadMessage(MessageThreadHandle,wm_quit,0,0); PostThreadMessage(MessageThreadHandle,wm_quit,0,0);
WaitForSingleObject(MessageThreadHandle,Infinite); WaitForSingleObject(MessageThreadHandle,Infinite);
CloseHandle(MessageThreadHandle); CloseHandle(MessageThreadHandle);
@ -2041,10 +2207,21 @@ function queryadapterinfo : pmodeinfo;
begin begin
InitializeGraph; InitializeGraph;
charmessagehandler:=nil;
mousemessagehandler:=nil;
commandmessagehandler:=nil;
notifymessagehandler:=nil;
OnGraphWindowCreation:=nil;
end. end.
{ {
$Log$ $Log$
Revision 1.2 2000-07-13 11:33:57 michael Revision 1.3 2000-10-21 18:20:17 florian
* a lot of small changes:
- setlength is internal
- win32 graph unit extended
....
Revision 1.2 2000/07/13 11:33:57 michael
+ removed logs + removed logs
} }

14
rtl/win32/winmouse.pp
View File

@ -179,7 +179,7 @@ unit winmouse;
begin begin
buttons:=mousebuttonstate; buttons:=mousebuttonstate;
GetCursorPos(@pos); GetCursorPos(@pos);
ScreenToClient(mainwindow,@pos); ScreenToClient(GraphWindow,@pos);
x:=pos.x; x:=pos.x;
y:=pos.y; y:=pos.y;
end; end;
@ -200,7 +200,13 @@ unit winmouse;
end. end.
{ {
$Log$ $Log$
Revision 1.2 2000-07-13 11:33:58 michael Revision 1.3 2000-10-21 18:20:17 florian
* a lot of small changes:
- setlength is internal
- win32 graph unit extended
....
Revision 1.2 2000/07/13 11:33:58 michael
+ removed logs + removed logs
} }