Merged revisions 458,500,507 via svnmerge from

/trunk

git-svn-id: branches/fixes_2_0@894 -

.gitattributes

@@ -5642,6 +5642,7 @@ tests/webtbs/tw2388.pp svneol=native#text/plain
 tests/webtbs/tw2397.pp svneol=native#text/plain
 tests/webtbs/tw2409.pp svneol=native#text/plain
 tests/webtbs/tw2421.pp svneol=native#text/plain
+tests/webtbs/tw2423.pp svneol=native#text/plain
 tests/webtbs/tw2425.pp svneol=native#text/plain
 tests/webtbs/tw2432.pp svneol=native#text/plain
 tests/webtbs/tw2435.pp svneol=native#text/plain

compiler/i386/cpupara.pas

@@ -129,13 +129,15 @@ unit cpupara;
         case def.deftype of
           variantdef :
             begin
-              { Win32 stdcall passes small records on the stack for call by
-                value }
+              { variants are small enough to be passed by value except if
+                required by the windows api
+              }
               if (target_info.system=system_i386_win32) and
                  (calloption=pocall_stdcall) and
-                 (varspez=vs_value) and
-                 (def.size<=16) then
-                result:=false
+                 (varspez=vs_const) then
+                result:=true
+              else
+                result:=false;
             end;
           formaldef :
             result:=true;

rtl/inc/sstrings.inc

@@ -57,7 +57,7 @@ end;
 
 procedure insert(const source : shortstring;var s : shortstring;index : SizeInt);
 var
-  cut,srclen,indexlen : longint;
+  cut,srclen,indexlen : SizeInt;
 begin
   if index<1 then
    index:=1;
@@ -65,9 +65,9 @@ begin
    index:=length(s)+1;
   indexlen:=Length(s)-Index+1;
   srclen:=length(Source);
-  if length(source)+length(s)>=sizeof(s) then
+  if SizeInt(length(source)+length(s))>=sizeof(s) then
    begin
-     cut:=length(source)+length(s)-sizeof(s)+1;
+     cut:=SizeInt(length(source)+length(s))-sizeof(s)+1;
      if cut>indexlen then
       begin
         dec(srclen,cut-indexlen);
@@ -84,7 +84,7 @@ end;
 
 procedure insert(source : Char;var s : shortstring;index : SizeInt);
 var
-  indexlen : longint;
+  indexlen : SizeInt;
 begin
   if index<1 then
    index:=1;

rtl/inc/wstrings.inc

@@ -117,6 +117,13 @@ end;
                     Internal functions, not in interface.
 ****************************************************************************}
 
+
+procedure WideStringError;
+  begin
+    HandleErrorFrame(204,get_frame);
+  end;
+  
+  
 {$ifdef WideStrDebug}
 Procedure DumpWideRec(S : Pointer);
 begin
@@ -143,14 +150,20 @@ Function NewWideString(Len : SizeInt) : Pointer;
 Var
   P : Pointer;
 begin
+{$ifdef MSWINDOWS}
+  P:=SysAllocStringLen(nil,Len*sizeof(WideChar)+WideRecLen);
+{$else MSWINDOWS}
   GetMem(P,Len*sizeof(WideChar)+WideRecLen);
+{$endif MSWINDOWS}
   If P<>Nil then
-   begin
+    begin
      PWideRec(P)^.Len:=0;         { Initial length }
      PWideRec(P)^.Ref:=1;         { Set reference count }
      PWideRec(P)^.First:=#0;      { Terminating #0 }
      inc(p,WideFirstOff);         { Points to string now }
-   end;
+    end
+  else
+    WideStringError;
   NewWideString:=P;
 end;
 
@@ -163,7 +176,11 @@ begin
   If S=Nil then
     exit;
   Dec (S,WideFirstOff);
+{$ifdef MSWINDOWS}
+  SysFreeString(S);
+{$else MSWINDOWS}
   FreeMem (S);
+{$endif MSWINDOWS}
   S:=Nil;
 end;
 
@@ -607,13 +624,18 @@ begin
          { Need a complete new string...}
          Pointer(s):=NewWideString(l);
        end
+      { windows doesn't support reallocing widestrings, this code
+        is anyways subject to be removed because widestrings shouldn't be
+        ref. counted anymore (FK) }
+{$ifndef MSWINDOWS}       
       else if (PWideRec(Pointer(S)-WideFirstOff)^.Ref = 1) then
         begin
           Dec(Pointer(S),WideFirstOff);
           if L*sizeof(WideChar)+WideRecLen>MemSize(Pointer(S)) then
-            reallocmem(pointer(S), L*sizeof(WideChar)+WideRecLen);
+              reallocmem(pointer(S), L*sizeof(WideChar)+WideRecLen);
           Inc(Pointer(S), WideFirstOff);
         end
+{$endif MSWINDOWS}        
       else
         begin
           { Reallocation is needed... }

rtl/win32/system.pp

@@ -36,7 +36,7 @@ const
 { FileNameCaseSensitive is defined separately below!!! }
  maxExitCode = 65535;
  MaxPathLen = 260;
- 
+
 type
    PEXCEPTION_FRAME = ^TEXCEPTION_FRAME;
    TEXCEPTION_FRAME = record
@@ -111,6 +111,19 @@ type
 
 implementation
 
+{ used by wstrings.inc because wstrings.inc is included before sysos.inc
+  this is put here (FK) }
+
+function SysAllocStringLen(psz:pointer;len:dword):pointer;stdcall;
+ external 'oleaut32.dll' name 'SysAllocStringLen';
+
+procedure SysFreeString(bstr:pointer);stdcall;
+ external 'oleaut32.dll' name 'SysFreeString';
+
+function SysReAllocStringLen(var bstr:pointer;psz: pointer;
+  len:dword): Integer; stdcall;external 'oleaut32.dll' name 'SysReAllocStringLen';
+
+
 { include system independent routines }
 {$I system.inc}
 

tests/webtbs/tw2423.pp

@@ -0,0 +1,106 @@
+{ %target=win32 }
+{ Source provided for Free Pascal Bug Report 2423 }
+{ Submitted by "Pavel V. Ozerski" on  2003-03-18 }
+{ e-mail: [email protected] }
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+{ $define BugAvoid}
+type
+ pVariant=^Variant;
+function ShowHTMLDialog(const hwndParent:longint;const pmk:pointer;
+                                const pvarArgIn:Variant;const pchOptions:{pwidechar}pointer;
+                                pvarArgOut:pVariant):longint;stdcall;
+ external 'MSHTML.DLL';
+function CreateURLMoniker(const pmkContext:pointer;const szURL:pWideChar;var ppmk:pointer):longint;stdcall;
+ external 'URLMON.DLL';
+
+{$ifdef BugAvoid}
+
+function SysAllocStringLen(psz:pointer;len:Integer):pointer;stdcall;
+ external 'oleaut32.dll' name 'SysAllocStringLen';
+
+procedure SysFreeString(bstr:pointer);stdcall;
+ external 'oleaut32.dll' name 'SysFreeString';
+
+function MultiByteToWideChar(CodePage:cardinal;dwFlags:cardinal;
+                             lpMultiByteStr:pChar;cchMultiByte:longint;
+                             lpWideCharStr:pointer;cchWideChar:longint
+                             ):longint;stdcall;
+ external 'kernel32.dll';
+
+function MakeWide(const s:ansistring):pointer;
+ var
+  l:cardinal;
+ begin
+  l:=succ(length(s));
+  Result:=SysAllocStringLen(nil,l);
+  MultiByteToWideChar(0,1,@s[1],length(s),Result,l);
+ end;
+
+{$endif}
+
+var
+ buf:pointer;
+const
+ Htm:AnsiString='<HTML><SCRIPT language="JavaScript">document.write(window.dialogArguments)</SCRIPT></HTML>';
+var
+ t:file;
+ ws:widestring;
+ s:ansistring;
+ pmk:pointer;
+
+ {$ifdef BugAvoid}
+
+  InParam_data:TVarData;
+  InParam:variant absolute InParam_data;
+
+ {$else}
+
+ inparam:variant;
+
+ {$endif}
+
+ i:longint;
+begin
+ s:=paramstr(0);
+ for i:=length(s)downto 1 do
+  if s[i]='\'then
+   begin
+    setlength(s,i);
+    break;
+   end; 
+ s:=s+'demo.htm';
+ assign(t,s);
+ rewrite(t,1);
+ blockwrite(t,Htm[1],length(Htm));
+ close(t);
+ ws:=s;
+
+
+{$ifdef BugAvoid}
+
+ buf:=MakeWide(s);
+
+
+{$else}
+
+ buf:=pWideChar(ws);
+
+{$endif}
+
+ CreateURLMoniker(nil,buf,pmk);
+
+{$ifdef BugAvoid}
+
+ InParam_data.VType:=8;
+ InParam_data.VPointer:=buf;
+
+{$else}
+
+ InParam:=ws;
+
+{$endif}
+
+ ShowHTMLDialog(0,pmk,InParam,nil,nil);
+end.