Merged revisions 2310,2312,2317,2320,2325,2331,2333,2340,2347,2358-2359,2373,2380-2381,2390,2402-2403,2405-2406,2436-2437 via svnmerge from

http://[email protected]/svn/fpc/trunk

........
r2310 | peter | 2006-01-17 09:44:57 +0100 (Tue, 17 Jan 2006) | 2 lines

  * fix compare with null

........
r2312 | hajny | 2006-01-18 23:48:19 +0100 (Wed, 18 Jan 2006) | 1 line

  * fix for web bug #4518 by Salvatore Licciardi
........
r2317 | jonas | 2006-01-21 21:19:19 +0100 (Sat, 21 Jan 2006) | 5 lines

  * use vfork instead of fork for popen and one variant of executeprocess   
    if USE_VFORK is defined (currently only if both BSD and FPC_USE_LIBC
    are defined). Speeds up the compilation of the compiler under Darwin
    by 20-25% (the larger the project, the bigger the speedup).

........
r2320 | daniel | 2006-01-22 12:06:10 +0100 (Sun, 22 Jan 2006) | 3 lines

  * Add --64 or --32 to as call to allow i386 make cycle using -Aas on
    x64_64 systems.

........
r2325 | daniel | 2006-01-22 15:29:07 +0100 (Sun, 22 Jan 2006) | 2 lines

  * Add --32 or --64 to to ensure functionality of i386 compiler on x64_64 OSes.

........
r2331 | olle | 2006-01-23 22:34:24 +0100 (Mon, 23 Jan 2006) | 1 line

Added short circuit evaluation of compile time expressions
........
r2333 | michael | 2006-01-24 21:04:46 +0100 (Tue, 24 Jan 2006) | 1 line

+ Enabled use of embedded firebird library.
........
r2340 | peter | 2006-01-25 23:05:31 +0100 (Wed, 25 Jan 2006) | 2 lines

  * added missing varString,varOlestr to ordinals

........
r2347 | marco | 2006-01-26 22:11:37 +0100 (Thu, 26 Jan 2006) | 2 lines

 * fdset is now array of unsigned.

........
r2358 | michael | 2006-01-28 19:07:23 +0100 (Sat, 28 Jan 2006) | 1 line

+ Patch from Graeme Geldenhuys to add delphi compatibility function
........
r2359 | michael | 2006-01-28 19:10:07 +0100 (Sat, 28 Jan 2006) | 1 line

+ Patch from Graeme Geldenhuys to fix ExtractFileDrive
........
r2373 | michael | 2006-01-29 11:28:37 +0100 (Sun, 29 Jan 2006) | 1 line

+ Patch from Michalis Kamburelis to fix hex2dec behaviour in case of error
........
r2380 | peter | 2006-01-29 20:46:14 +0100 (Sun, 29 Jan 2006) | 2 lines

  * added sumInt

........
r2381 | jonas | 2006-01-29 23:46:46 +0100 (Sun, 29 Jan 2006) | 2 lines

  + added (not yet fixed)

........
r2390 | jonas | 2006-02-01 11:22:52 +0100 (Wed, 01 Feb 2006) | 4 lines

  * fixed some FloatToStrF and FloatToStr precision problems. Still fails
    for some corner cases (e.g. 8.502 as double), but that problem is in
    str_real

........
r2402 | peter | 2006-02-02 10:03:02 +0100 (Thu, 02 Feb 2006) | 2 lines

  * range check errors

........
r2403 | jonas | 2006-02-02 11:33:12 +0100 (Thu, 02 Feb 2006) | 2 lines

  + comp and int64 overloads for floattostr(f)

........
r2405 | peter | 2006-02-02 14:17:05 +0100 (Thu, 02 Feb 2006) | 2 lines

  * test for enums in record

........
r2406 | peter | 2006-02-02 14:41:17 +0100 (Thu, 02 Feb 2006) | 2 lines

  * more tests for symtable insert/search

........
r2436 | peter | 2006-02-05 02:55:44 +0100 (Sun, 05 Feb 2006) | 2 lines

  * duplicate names fixed

........
r2437 | peter | 2006-02-05 02:57:23 +0100 (Sun, 05 Feb 2006) | 2 lines

  * duplicate names fixed

........

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

.gitattributes

@@ -4559,6 +4559,7 @@ tests/tbf/tb0174c.pp svneol=native#text/plain
 tests/tbf/tb0174d.pp svneol=native#text/plain
 tests/tbf/tb0175.pp svneol=native#text/plain
 tests/tbf/tb0176.pp svneol=native#text/plain
+tests/tbf/tb0177.pp svneol=native#text/plain
 tests/tbf/ub0115.pp svneol=native#text/plain
 tests/tbf/ub0149.pp svneol=native#text/plain
 tests/tbf/ub0158a.pp svneol=native#text/plain
@@ -5053,6 +5054,8 @@ tests/tbs/tb0496.pp svneol=native#text/plain
 tests/tbs/tb0497a.pp -text
 tests/tbs/tb0497b.pp -text
 tests/tbs/tb0497c.pp -text
+tests/tbs/tb0498.pp svneol=native#text/plain
+tests/tbs/tb0499.pp svneol=native#text/plain
 tests/tbs/ub0060.pp svneol=native#text/plain
 tests/tbs/ub0069.pp svneol=native#text/plain
 tests/tbs/ub0119.pp svneol=native#text/plain
@@ -5403,6 +5406,7 @@ tests/test/tstring7.pp svneol=native#text/plain
 tests/test/tstring8.pp svneol=native#text/plain
 tests/test/tstrreal1.pp svneol=native#text/plain
 tests/test/tstrreal2.pp svneol=native#text/plain
+tests/test/tstrreal3.pp -text
 tests/test/tsubdecl.pp svneol=native#text/plain
 tests/test/tunit1.pp svneol=native#text/plain
 tests/test/tunit2.pp svneol=native#text/plain
@@ -6389,6 +6393,7 @@ tests/webtbs/tw4533.pp svneol=native#text/plain
 tests/webtbs/tw4534.pp svneol=native#text/plain
 tests/webtbs/tw4537.pp svneol=native#text/plain
 tests/webtbs/tw4540.pp -text svneol=unset#text/plain
+tests/webtbs/tw4541.pp svneol=native#text/plain
 tests/webtbs/tw4557.pp svneol=native#text/plain
 tests/webtbs/tw4566.pp -text svneol=unset#text/plain
 tests/webtbs/tw4574.pp svneol=native#text/plain
@@ -6402,6 +6407,7 @@ tests/webtbs/tw4635.pp svneol=native#text/plain
 tests/webtbs/tw4640.pp svneol=native#text/plain
 tests/webtbs/tw4669.pp svneol=native#text/plain
 tests/webtbs/tw4675.pp svneol=native#text/plain
+tests/webtbs/tw4700.pp svneol=native#text/plain
 tests/webtbs/ub1873.pp svneol=native#text/plain
 tests/webtbs/ub1883.pp svneol=native#text/plain
 tests/webtbs/uw0555.pp svneol=native#text/plain
@@ -6446,6 +6452,7 @@ tests/webtbs/uw4352b.pp svneol=native#text/plain
 tests/webtbs/uw4352c.pp svneol=native#text/plain
 tests/webtbs/uw4352d.pp svneol=native#text/plain
 tests/webtbs/uw4352e.pp svneol=native#text/plain
+tests/webtbs/uw4541.pp svneol=native#text/plain
 utils/Makefile svneol=native#text/plain
 utils/Makefile.fpc svneol=native#text/plain
 utils/README -text

compiler/scanner.pas

@@ -510,6 +510,12 @@ The TRUE/FALSE format is new from 22 august 2005, but the above scheme
 means that units which is not recompiled, and thus stores
 compile time variables as the old format (0/1), continue to work.
 
+Short circuit evaluation
+------------------------
+For this to work, the part of a compile time expression which is short
+circuited, should not be evaluated, while it still should be parsed.
+Therefor there is a parameter eval, telling whether evaluation is needed.
+In case not, the value returned can be arbitrary.
 }
 
     type
@@ -550,16 +556,16 @@ compile time variables as the old format (0/1), continue to work.
 
     function parse_compiler_expr(var compileExprType: TCTETypeSet):string;
 
-        function read_expr(var exprType: TCTETypeSet) : string; forward;
+        function read_expr(var exprType: TCTETypeSet; eval : Boolean) : string; forward;
 
         procedure preproc_consume(t : ttoken);
         begin
           if t<>current_scanner.preproc_token then
-           Message(scan_e_preproc_syntax_error);
+            Message(scan_e_preproc_syntax_error);
           current_scanner.preproc_token:=current_scanner.readpreproc;
         end;
 
-        function preproc_substitutedtoken(var macroType: TCTETypeSet): string;
+        function preproc_substitutedtoken(var macroType: TCTETypeSet; eval : Boolean): string;
                                 { Currently this parses identifiers as well as numbers.
           The result from this procedure can either be that the token
           itself is a value, or that it is a compile time variable/macro,
@@ -575,6 +581,9 @@ compile time variables as the old format (0/1), continue to work.
           w: word;
         begin
           result := current_scanner.preproc_pattern;
+          if not eval then
+            exit;
+
           mac:= nil;
           { Substitue macros and compiler variables with their content/value.
             For real macros also do recursive substitution. }
@@ -651,7 +660,7 @@ compile time variables as the old format (0/1), continue to work.
             macroType:= [ctetString];
         end;
 
-        function read_factor(var factorType: TCTETypeSet) : string;
+        function read_factor(var factorType: TCTETypeSet; eval : Boolean) : string;
         var
            hs : string;
            mac: tmacro;
@@ -777,33 +786,36 @@ compile time variables as the old format (0/1), continue to work.
                         current_scanner.skipspace;
                       end
                     else
-                      Message(scan_e_error_in_preproc_expr);
-                    if searchsym(current_scanner.preproc_pattern,srsym,srsymtable) then
-                      begin
-                        l:=0;
-                        case srsym.typ of
-                          globalvarsym,
-                          localvarsym,
-                          paravarsym :
-                            l:=tabstractvarsym(srsym).getsize;
-                          typedconstsym :
-                            l:=ttypedconstsym(srsym).getsize;
-                          typesym:
-                            l:=ttypesym(srsym).restype.def.size;
-                          else
-                            Message(scan_e_error_in_preproc_expr);
-                        end;
-                        str(l,read_factor);
-                        preproc_consume(_ID);
-                        current_scanner.skipspace;
-                      end
-                    else
-                      Message1(sym_e_id_not_found,current_scanner.preproc_pattern);
+                      Message(scan_e_preproc_syntax_error);
+
+                    if eval then
+                      if searchsym(current_scanner.preproc_pattern,srsym,srsymtable) then
+                        begin
+                          l:=0;
+                          case srsym.typ of
+                            globalvarsym,
+                            localvarsym,
+                            paravarsym :
+                              l:=tabstractvarsym(srsym).getsize;
+                            typedconstsym :
+                              l:=ttypedconstsym(srsym).getsize;
+                            typesym:
+                              l:=ttypesym(srsym).restype.def.size;
+                            else
+                              Message(scan_e_error_in_preproc_expr);
+                          end;
+                          str(l,read_factor);
+                        end
+                      else
+                        Message1(sym_e_id_not_found,current_scanner.preproc_pattern);
+
+                    preproc_consume(_ID);
+                    current_scanner.skipspace;
 
                     if current_scanner.preproc_token =_RKLAMMER then
                       preproc_consume(_RKLAMMER)
                     else
-                      Message(scan_e_error_in_preproc_expr);
+                      Message(scan_e_preproc_syntax_error);
                   end
                 else
                 if current_scanner.preproc_pattern='DECLARED' then
@@ -841,14 +853,19 @@ compile time variables as the old format (0/1), continue to work.
                   begin
                     factorType:= [ctetBoolean];
                     preproc_consume(_ID);
-                    hs:=read_factor(factorType);
-                    if not (ctetBoolean in factorType) then
-                      CTEError(factorType, [ctetBoolean], 'NOT');
-                    val(hs,l,w);
-                    if l<>0 then
-                      read_factor:='0'
+                    hs:=read_factor(factorType, eval);
+                    if eval then
+                      begin
+                        if not (ctetBoolean in factorType) then
+                          CTEError(factorType, [ctetBoolean], 'NOT');
+                        val(hs,l,w);
+                        if l<>0 then
+                          read_factor:='0'
+                        else
+                          read_factor:='1';
+                      end
                     else
-                      read_factor:='1';
+                      read_factor:='0'; {Just to have something}
                   end
                 else
                 if (m_mac in aktmodeswitches) and (current_scanner.preproc_pattern='TRUE') then
@@ -866,11 +883,11 @@ compile time variables as the old format (0/1), continue to work.
                   end
                 else
                   begin
-                    hs:=preproc_substitutedtoken(factorType);
+                    hs:=preproc_substitutedtoken(factorType, eval);
 
                     { Default is to return the original symbol }
                     read_factor:=hs;
-                    if (m_delphi in aktmodeswitches) and (ctetString in factorType) then
+                    if eval and (m_delphi in aktmodeswitches) and (ctetString in factorType) then
                       if searchsym(current_scanner.preproc_pattern,srsym,srsymtable) then
                         begin
                           case srsym.typ of
@@ -938,7 +955,7 @@ compile time variables as the old format (0/1), continue to work.
            else if current_scanner.preproc_token =_LKLAMMER then
              begin
                 preproc_consume(_LKLAMMER);
-                read_factor:=read_expr(factorType);
+                read_factor:=read_expr(factorType, eval);
                 preproc_consume(_RKLAMMER);
              end
            else if current_scanner.preproc_token = _LECKKLAMMER then
@@ -947,7 +964,7 @@ compile time variables as the old format (0/1), continue to work.
                read_factor := ',';
                while current_scanner.preproc_token = _ID do
                begin
-                 read_factor := read_factor+read_factor(setElemType)+',';
+                 read_factor := read_factor+read_factor(setElemType, eval)+',';
                  if current_scanner.preproc_token = _COMMA then
                    preproc_consume(_COMMA);
                end;
@@ -959,80 +976,98 @@ compile time variables as the old format (0/1), continue to work.
              Message(scan_e_error_in_preproc_expr);
         end;
 
-        function read_term(var termType: TCTETypeSet) : string;
+        function read_term(var termType: TCTETypeSet; eval : Boolean) : string;
         var
            hs1,hs2 : string;
            l1,l2 : longint;
            w : integer;
            termType2: TCTETypeSet;
         begin
-          hs1:=read_factor(termType);
+          hs1:=read_factor(termType, eval);
           repeat
             if (current_scanner.preproc_token<>_ID) then
               break;
             if current_scanner.preproc_pattern<>'AND' then
               break;
 
-            {Check if first expr is boolean. Must be done here, after we know
-             it is an AND expression.}
-            if not (ctetBoolean in termType) then
-              CTEError(termType, [ctetBoolean], 'AND');
-            termType:= [ctetBoolean];
+            val(hs1,l1,w);
+            if l1=0 then
+              eval:= false; {Short circuit evaluation of OR}
+
+            if eval then
+               begin
+                {Check if first expr is boolean. Must be done here, after we know
+                 it is an AND expression.}
+                if not (ctetBoolean in termType) then
+                  CTEError(termType, [ctetBoolean], 'AND');
+                termType:= [ctetBoolean];
+              end;
 
             preproc_consume(_ID);
-            hs2:=read_factor(termType2);
+            hs2:=read_factor(termType2, eval);
 
-            if not (ctetBoolean in termType2) then
-              CTEError(termType2, [ctetBoolean], 'AND');
+            if eval then
+              begin
+                if not (ctetBoolean in termType2) then
+                  CTEError(termType2, [ctetBoolean], 'AND');
 
-            val(hs1,l1,w);
-            val(hs2,l2,w);
-            if (l1<>0) and (l2<>0) then
-              hs1:='1'
-            else
-              hs1:='0';
+                val(hs2,l2,w);
+                if (l1<>0) and (l2<>0) then
+                  hs1:='1'
+                else
+                  hs1:='0';
+              end;
            until false;
            read_term:=hs1;
         end;
 
 
-        function read_simple_expr(var simpleExprType: TCTETypeSet) : string;
+        function read_simple_expr(var simpleExprType: TCTETypeSet; eval : Boolean) : string;
         var
            hs1,hs2 : string;
            l1,l2 : longint;
            w : integer;
            simpleExprType2: TCTETypeSet;
         begin
-          hs1:=read_term(simpleExprType);
+          hs1:=read_term(simpleExprType, eval);
           repeat
             if (current_scanner.preproc_token<>_ID) then
               break;
             if current_scanner.preproc_pattern<>'OR' then
               break;
 
-            {Check if first expr is boolean. Must be done here, after we know
-             it is an OR expression.}
-            if not (ctetBoolean in simpleExprType) then
-              CTEError(simpleExprType, [ctetBoolean], 'OR');
-            simpleExprType:= [ctetBoolean];
+            val(hs1,l1,w);
+            if l1<>0 then
+              eval:= false; {Short circuit evaluation of OR}
+
+            if eval then
+              begin
+                {Check if first expr is boolean. Must be done here, after we know
+                 it is an OR expression.}
+                if not (ctetBoolean in simpleExprType) then
+                  CTEError(simpleExprType, [ctetBoolean], 'OR');
+                simpleExprType:= [ctetBoolean];
+              end;
 
             preproc_consume(_ID);
-            hs2:=read_term(simpleExprType2);
+            hs2:=read_term(simpleExprType2, eval);
 
-            if not (ctetBoolean in simpleExprType2) then
-              CTEError(simpleExprType2, [ctetBoolean], 'OR');
+            if eval then
+              begin
+                if not (ctetBoolean in simpleExprType2) then
+                  CTEError(simpleExprType2, [ctetBoolean], 'OR');
 
-            val(hs1,l1,w);
-            val(hs2,l2,w);
-            if (l1<>0) or (l2<>0) then
-              hs1:='1'
-            else
-              hs1:='0';
+                val(hs2,l2,w);
+                if (l1<>0) or (l2<>0) then
+                  hs1:='1'
+                else
+                  hs1:='0';
+              end;
           until false;
           read_simple_expr:=hs1;
         end;
 
-        function read_expr(var exprType: TCTETypeSet) : string;
+        function read_expr(var exprType: TCTETypeSet; eval : Boolean) : string;
         var
            hs1,hs2 : string;
            b : boolean;
@@ -1041,7 +1076,7 @@ compile time variables as the old format (0/1), continue to work.
            l1,l2 : longint;
            exprType2: TCTETypeSet;
         begin
-           hs1:=read_simple_expr(exprType);
+           hs1:=read_simple_expr(exprType, eval);
            op:=current_scanner.preproc_token;
            if (op = _ID) and (current_scanner.preproc_pattern = 'IN') then
              op := _IN;
@@ -1055,64 +1090,69 @@ compile time variables as the old format (0/1), continue to work.
              preproc_consume(_ID)
            else
              preproc_consume(op);
-           hs2:=read_simple_expr(exprType2);
+           hs2:=read_simple_expr(exprType2, eval);
 
-           if op = _IN then
-             begin
-               if exprType2 <> [ctetSet] then
-                 CTEError(exprType2, [ctetSet], 'IN');
-               if exprType = [ctetSet] then
-                 CTEError(exprType, setElementTypes, 'IN');
-
-              if is_number(hs1) and is_number(hs2) then
-                Message(scan_e_preproc_syntax_error)
-              else if hs2[1] = ',' then
-                b:=pos(','+hs1+',', hs2) > 0   { TODO For integer sets, perhaps check for numeric equivalence so that 0 = 00 }
-              else
-                Message(scan_e_preproc_syntax_error);
-             end
-           else
+           if eval then
              begin
-               if (exprType * exprType2) = [] then
-                 CTEError(exprType2, exprType, tokeninfo^[op].str);
-
-               if is_number(hs1) and is_number(hs2) then
+               if op = _IN then
                  begin
-                   val(hs1,l1,w);
-                   val(hs2,l2,w);
-                   case op of
-                     _EQUAL :
-                       b:=l1=l2;
-                     _UNEQUAL :
-                       b:=l1<>l2;
-                     _LT :
-                       b:=l1<l2;
-                     _GT :
-                       b:=l1>l2;
-                     _GTE :
-                       b:=l1>=l2;
-                     _LTE :
-                       b:=l1<=l2;
-                   end;
+                   if exprType2 <> [ctetSet] then
+                     CTEError(exprType2, [ctetSet], 'IN');
+                   if exprType = [ctetSet] then
+                     CTEError(exprType, setElementTypes, 'IN');
+    
+                  if is_number(hs1) and is_number(hs2) then
+                    Message(scan_e_preproc_syntax_error)
+                  else if hs2[1] = ',' then
+                    b:=pos(','+hs1+',', hs2) > 0   { TODO For integer sets, perhaps check for numeric equivalence so that 0 = 00 }
+                  else
+                    Message(scan_e_preproc_syntax_error);
                  end
                else
                  begin
-                   case op of
-                     _EQUAL :
-                       b:=hs1=hs2;
-                     _UNEQUAL :
-                       b:=hs1<>hs2;
-                     _LT :
-                       b:=hs1<hs2;
-                     _GT :
-                        b:=hs1>hs2;
-                     _GTE :
-                        b:=hs1>=hs2;
-                     _LTE :
-                       b:=hs1<=hs2;
-                   end;
+                   if (exprType * exprType2) = [] then
+                     CTEError(exprType2, exprType, tokeninfo^[op].str);
+    
+                   if is_number(hs1) and is_number(hs2) then
+                     begin
+                       val(hs1,l1,w);
+                       val(hs2,l2,w);
+                       case op of
+                         _EQUAL :
+                           b:=l1=l2;
+                         _UNEQUAL :
+                           b:=l1<>l2;
+                         _LT :
+                           b:=l1<l2;
+                         _GT :
+                           b:=l1>l2;
+                         _GTE :
+                           b:=l1>=l2;
+                         _LTE :
+                           b:=l1<=l2;
+                       end;
+                     end
+                   else
+                     begin
+                       case op of
+                         _EQUAL :
+                           b:=hs1=hs2;
+                         _UNEQUAL :
+                           b:=hs1<>hs2;
+                         _LT :
+                           b:=hs1<hs2;
+                         _GT :
+                            b:=hs1>hs2;
+                         _GTE :
+                            b:=hs1>=hs2;
+                         _LTE :
+                           b:=hs1<=hs2;
+                       end;
+                     end;
                  end;
-             end;
+              end
+           else
+             b:= false; {Just to have something}
 
            if b then
              read_expr:='1'
@@ -1120,11 +1160,12 @@ compile time variables as the old format (0/1), continue to work.
              read_expr:='0';
            exprType:= [ctetBoolean];
         end;
+
      begin
         current_scanner.skipspace;
         { start preproc expression scanner }
         current_scanner.preproc_token:=current_scanner.readpreproc;
-        parse_compiler_expr:=read_expr(compileExprType);
+        parse_compiler_expr:=read_expr(compileExprType, true);
      end;
 
     function boolean_compile_time_expr(var valuedescr: String): Boolean;

fv/dialogs.pas

@@ -1335,11 +1335,11 @@ END;
 {---------------------------------------------------------------------------}
 FUNCTION TInputLine.Valid (Command: Word): Boolean;
 
-   FUNCTION AppendError (Validator: PValidator): Boolean;
+   FUNCTION AppendError (AValidator: PValidator): Boolean;
    BEGIN
      AppendError := False;                            { Preset false }
      If (Data <> Nil) Then
-       With Validator^ Do
+       With AValidator^ Do
          If (Options AND voOnAppend <> 0) AND         { Check options }
          (CurPos <> Length(Data^)) AND                { Exceeds max length }
          NOT IsValidInput(Data^, True) Then Begin     { Check data valid }

fv/menus.pas

@@ -430,10 +430,10 @@ END;
 CONSTRUCTOR TMenuView.Load (Var S: TStream);
 
    FUNCTION DoLoadMenu: PMenu;
-   VAR Tok: Byte; Item: PMenuItem; Last: ^PMenuItem; Menu: PMenu;
+   VAR Tok: Byte; Item: PMenuItem; Last: ^PMenuItem; HMenu: PMenu;
    BEGIN
-     New(Menu);                                       { Create new menu }
-     Last := @Menu^.Items;                            { Start on first item }
+     New(HMenu);                                       { Create new menu }
+     Last := @HMenu^.Items;                            { Start on first item }
      Item := Nil;                                     { Clear pointer }
      S.Read(Tok, SizeOf(Tok));                        { Read token }
      While (Tok <> 0) Do Begin
@@ -460,8 +460,8 @@ CONSTRUCTOR TMenuView.Load (Var S: TStream);
        S.Read(Tok, SizeOf(Tok));                      { Read token }
      End;
      Last^ := Nil;                                    { List complete }
-     Menu^.Default := Menu^.Items;                    { Set menu default }
-     DoLoadMenu := Menu;                              { Return menu }
+     HMenu^.Default := HMenu^.Items;                    { Set menu default }
+     DoLoadMenu := HMenu;                              { Return menu }
    End;
 
 BEGIN
@@ -772,11 +772,11 @@ END;
 {---------------------------------------------------------------------------}
 PROCEDURE TMenuView.Store (Var S: TStream);
 
-   PROCEDURE DoStoreMenu (Menu: PMenu);
+   PROCEDURE DoStoreMenu (AMenu: PMenu);
    VAR Item: PMenuItem; Tok: Byte;
    BEGIN
      Tok := $FF;                                      { Preset max count }
-     Item := Menu^.Items;                             { Start first item }
+     Item := AMenu^.Items;                             { Start first item }
      While (Item <> Nil) Do Begin
        With Item^ Do Begin
          S.Write(Tok, SizeOf(Tok));                      { Write tok value }
@@ -806,10 +806,10 @@ END;
 PROCEDURE TMenuView.HandleEvent (Var Event: TEvent);
 VAR CallDraw: Boolean; P: PMenuItem;
 
-   PROCEDURE UpdateMenu (Menu: PMenu);
+   PROCEDURE UpdateMenu (AMenu: PMenu);
    VAR P: PMenuItem; CommandState: Boolean;
    BEGIN
-     P := Menu^.Items;                                { Start on first item }
+     P := AMenu^.Items;                                { Start on first item }
      While (P <> Nil) Do Begin
        If (P^.Name <> Nil) Then                       { Valid name }
        If (P^.Command = 0) Then UpdateMenu(P^.SubMenu){ Update menu }

ide/fpcalc.pas

@@ -371,7 +371,7 @@ begin
                   '*', '/': R := R / 100;
                 end;
               case _Operator of
-                '^': SetDisplay(Power(Operand,R),false);
+                '^': if (Operand = 0)and(R <= 0) then Error else SetDisplay(Power(Operand,R),false);
                 '+': SetDisplay(Operand + R,false);
                 '-': SetDisplay(Operand - R,false);
                 '*': SetDisplay(Operand * R,false);

packages/base/ibase/ibase60.inc

@@ -8,6 +8,10 @@ interface
 
 {$IFDEF LinkDynamically}
 uses Dynlibs, sysutils;
+
+Var
+  UseEmbeddedFirebird : Boolean = False;
+
 {$ENDIF}
 
 {$IFDEF Unix}
@@ -15,18 +19,21 @@ uses Dynlibs, sysutils;
   const
     gdslib = 'libgds.so';
     fbclib = 'libfbclient.so';
+    fbembedlib = 'libfbembed.so';
 {$ENDIF}
 {$IFDEF Win32}
   {$DEFINE extdecl:=stdcall}
   const
     gdslib = 'gds32.dll';
     fbclib = 'fbclient.dll';
+    fbembedlib = 'fbembed.dll';
 {$ENDIF}
 {$IFDEF Wince}
   {$DEFINE extdecl:=stdcall}
   const
     gdslib = 'gds32.dll';
     fbclib = 'fbclient.dll';
+    fbembedlib = 'fbembed.dll';
 {$ENDIF}
 
 type
@@ -2456,17 +2463,25 @@ begin
   inc(RefCount);
   if RefCount = 1 then
     begin
-    IBaseLibraryHandle := loadlibrary(fbclib);
-    if IBaseLibraryHandle = nilhandle then
+    If UseEmbeddedFirebird then
       begin
-      IBaseLibraryHandle := loadlibrary(gdslib);
-      if loadlibrary(gdslib) = nilhandle then
+      IBaseLibraryHandle:=loadlibrary(fbembedlib);
+      if (IBaseLibraryHandle=nilhandle) then
+        Raise EInOutError.Create('Can not load Firebird Embedded client. Is it installed? ('+fbembedlib+')');
+      end
+    else 
+      begin
+      IBaseLibraryHandle:=loadlibrary(fbclib);
+      if (IBaseLibraryHandle=nilhandle) then
         begin
-        RefCount := 0;
-        Raise EInOutError.Create('Can not load Firebird or Interbase client. Is it installed? ('+gdslib+' or '+fbclib+')');
+        IBaseLibraryHandle:=loadlibrary(gdslib);
+        if (IBaseLibraryHandle=nilhandle) then
+          begin
+          RefCount := 0;
+          Raise EInOutError.Create('Can not load Firebird or Interbase client. Is it installed? ('+gdslib+' or '+fbclib+')');
+          end;
         end;
-      end;
-
+      end;  
     pointer(isc_attach_database) := GetProcedureAddress(IBaseLibraryHandle,'isc_attach_database');
     pointer(isc_array_gen_sdl) := GetProcedureAddress(IBaseLibraryHandle,'isc_array_gen_sdl');
     pointer(isc_array_get_slice) := GetProcedureAddress(IBaseLibraryHandle,'isc_array_get_slice');

rtl/linux/ostypes.inc

@@ -1,3 +1,4 @@
+
 {
     This file is part of the Free Pascal run time library.
     Copyright (c) 2001 by Free Pascal development team
@@ -207,7 +208,7 @@ type
    TTms      = tms;
    PTms      = ^tms;
 
- TFDSet    = ARRAY[0..(FD_MAXFDSET div BITSINWORD)-1] of cLong;
+ TFDSet    = ARRAY[0..(FD_MAXFDSET div BITSINWORD)-1] of cuLong;
  pFDSet    = ^TFDSet;
 
   timezone = packed record

rtl/objpas/cvarutil.inc

@@ -56,7 +56,8 @@ end;
   ---------------------------------------------------------------------}
 
 Function VariantToSmallInt(Const VargSrc : TVarData) : SmallInt;
-
+var
+  l : longint;
 begin
   With VargSrc do
     Case (VType and VarTypeMask) of
@@ -67,20 +68,32 @@ begin
       VarDouble  : Result:=Round(VDouble);
       VarCurrency: Result:=Round(VCurrency);
       VarDate    : Result:=Round(VDate);
-      VarOleStr  : Result:=StrToInt(WideCharToString(vOleStr));
       VarBoolean : Result:=SmallInt(VBoolean);
       VarByte    : Result:=VByte;
       VarWord    : Result:=VWord;
       VarLongWord   : Result:=VLongWord;
       VarInt64   : Result:=VInt64;
       VarQword   : Result:=VQWord;
+      VarOleStr  :
+        begin
+          if not(TryStrToInt(WideCharToString(vOleStr),l)) then
+            VariantTypeMismatch;
+          result:=l;
+        end;
+      VarString  :
+        begin
+          if not(TryStrToInt(ansistring(vString),l)) then
+            VariantTypeMismatch;
+          result:=l;
+        end;
   else
     VariantTypeMismatch;
   end;
 end;
 
 Function VariantToShortInt(Const VargSrc : TVarData) : ShortInt;
-
+var
+  l : longint;
 begin
   With VargSrc do
     Case (VType and VarTypeMask) of
@@ -91,13 +104,24 @@ begin
       VarDouble  : Result:=Round(VDouble);
       VarCurrency: Result:=Round(VCurrency);
       VarDate    : Result:=Round(VDate);
-      VarOleStr  : Result:=StrToInt(WideCharToString(vOleStr));
       VarBoolean : Result:=SmallInt(VBoolean);
       VarByte    : Result:=VByte;
       VarWord    : Result:=VWord;
       VarLongWord   : Result:=VLongWord;
       VarInt64   : Result:=VInt64;
       VarQword   : Result:=VQWord;
+      VarOleStr  :
+        begin
+          if not(TryStrToInt(WideCharToString(vOleStr),l)) then
+            VariantTypeMismatch;
+          result:=l;
+        end;
+      VarString  :
+        begin
+          if not(TryStrToInt(ansistring(vString),l)) then
+            VariantTypeMismatch;
+          result:=l;
+        end;
   else
     VariantTypeMismatch;
   end;
@@ -191,7 +215,6 @@ Function VariantToSingle(Const VargSrc : TVarData) : Single;
             if not(TryStrToFloat(ansistring(vString),Result)) then
               VariantTypeMismatch;
           end;
-
         VarBoolean : Result:=Longint(VBoolean);
         VarByte    : Result:=VByte;
         VarWord    : Result:=VWord;
@@ -220,6 +243,11 @@ Function VariantToDouble(Const VargSrc : TVarData) : Double;
             if not(TryStrToFloat(WideCharToString(vOleStr),Result)) then
               VariantTypeMismatch;
           end;
+        VarString  :
+          begin
+            if not(TryStrToFloat(ansistring(vString),Result)) then
+              VariantTypeMismatch;
+          end;
         VarBoolean : Result:=Longint(VBoolean);
         VarByte    : Result:=VByte;
         VarWord    : Result:=VWord;
@@ -324,7 +352,8 @@ begin
 end;
 
 Function VariantToByte(Const VargSrc : TVarData) : Byte;
-
+var
+  l : longint;
 begin
   Try
     With VargSrc do
@@ -336,13 +365,24 @@ begin
         VarDouble  : Result:=Round(VDouble);
         VarCurrency: Result:=Round(VCurrency);
         VarDate    : Result:=Round(VDate);
-        VarOleStr  : NoWideStrings;
         VarBoolean : Result:=Longint(VBoolean);
         VarByte    : Result:=VByte;
         VarWord    : Result:=VWord;
         VarLongWord   : Result:=VLongWord;
         VarInt64   : Result:=Vint64;
         VarQword   : Result:=VQWord;
+      VarOleStr  :
+        begin
+          if not(TryStrToInt(WideCharToString(vOleStr),l)) then
+            VariantTypeMismatch;
+          result:=l;
+        end;
+      VarString  :
+        begin
+          if not(TryStrToInt(ansistring(vString),l)) then
+            VariantTypeMismatch;
+          result:=l;
+        end;
     else
       VariantTypeMismatch;
     end;
@@ -367,13 +407,18 @@ begin
         VarDouble  : Result:=Trunc(VDouble);
         VarCurrency: Result:=Trunc(VCurrency);
         VarDate    : Result:=Trunc(VDate);
-        VarOleStr  : NoWideStrings;
         VarBoolean : Result:=Longint(VBoolean);
         VarByte    : Result:=VByte;
         VarWord    : Result:=VWord;
         VarLongWord   : Result:=VLongWord;
         VarInt64   : Result:=VInt64;
         VarQword   : Result:=VQWord;
+        VarOleStr  :
+          if not(TryStrToInt64(WideCharToString(vOleStr),Result)) then
+            VariantTypeMismatch;
+        VarString  :
+          if not(TryStrToInt64(ansistring(vString),Result)) then
+            VariantTypeMismatch;
     else
       VariantTypeMismatch;
     end;
@@ -386,7 +431,8 @@ begin
 end;
 
 Function VariantToQWord(Const VargSrc : TVarData) : QWord;
-
+var
+  l : int64;
 begin
   Try
     With VargSrc do
@@ -398,13 +444,24 @@ begin
         VarDouble  : Result:=Trunc(VDouble);
         VarCurrency: Result:=Trunc(VCurrency);
         VarDate    : Result:=Trunc(VDate);
-        VarOleStr  : NoWideStrings;
         VarBoolean : Result:=Longint(VBoolean);
         VarByte    : Result:=VByte;
         VarWord    : Result:=VWord;
         VarLongWord   : Result:=VLongWord;
         VarInt64   : Result:=VInt64;
         VarQword   : Result:=VQWord;
+        VarOleStr  :
+          begin
+            if not(TryStrToInt64(WideCharToString(vOleStr),l)) then
+              VariantTypeMismatch;
+            result:=l;
+          end;
+        VarString  :
+          begin
+            if not(TryStrToInt64(ansistring(vString),l)) then
+              VariantTypeMismatch;
+            result:=l;
+          end;
     else
       VariantTypeMismatch;
     end;

rtl/objpas/math.pp

@@ -304,6 +304,8 @@ function mean(const data : array of float) : float;
 function sum(const data : array of float) : float;
 function mean(const data : PFloat; Const N : longint) : float;
 function sum(const data : PFloat; Const N : Longint) : float;
+function sumInt(const data : PInt64;Const N : longint) : Int64;
+function sumInt(const data : array of Int64) : Int64;
 function sumofsquares(const data : array of float) : float;
 function sumofsquares(const data : PFloat; Const N : Integer) : float;
 { calculates the sum and the sum of squares of data }
@@ -752,6 +754,23 @@ function sum(const data : PFloat;Const N : longint) : float;
        sum:=sum+data[i];
   end;
 
+function sumInt(const data : PInt64;Const N : longint) : Int64;
+
+  var
+     i : longint;
+
+  begin
+     sumInt:=0;
+     for i:=0 to N-1 do
+       sumInt:=sumInt+data[i];
+  end;
+
+function sumInt(const data : array of Int64) : Int64;
+
+  begin
+     Result:=SumInt(@Data[0],High(Data)+1);
+  end;
+
  function sumofsquares(const data : array of float) : float;
 
  begin

rtl/objpas/strutils.pp

@@ -1156,7 +1156,7 @@ begin
     HexStr:='$'+ S
   else
     HexStr:=S;
-  Result:=StrTointDef(HexStr,0);
+  Result:=StrToInt(HexStr);
 end;
 
 function Dec2Numb(N: Longint; Len, Base: Byte): string;

rtl/objpas/sysutils/fina.inc

@@ -55,7 +55,7 @@ end;
 function ExtractFileDrive(const FileName: string): string;
 var i: longint;
 begin
-if (Length(FileName) >= 3) and (FileName[2] = ':') then
+if (Length(FileName) >= 2) and (FileName[2] = ':') then
    result := Copy(FileName, 1, 2)
 else if (Length(FileName) >= 2) and (FileName[1] in ['/', '\']) and
    (FileName[2] in ['/', '\']) then begin

rtl/objpas/sysutils/sysstr.inc

@@ -1012,33 +1012,19 @@ Begin
 End;
 {$endif FPC_HAS_TYPE_EXTENDED}
 
-Function FloatToStr(Value: Extended): String;
-Begin
-  Result := FloatToStrF(Value, ffGeneral, 15, 0);
-End;
-
-Function FloatToText(Buffer: PChar; Value: Extended; format: TFloatFormat; Precision, Digits: Integer): Longint;
-Var
-  Tmp: String[40];
-Begin
-  Tmp := FloatToStrF(Value, format, Precision, Digits);
-  Result := Length(Tmp);
-  Move(Tmp[1], Buffer[0], Result);
-End;
 
 const
-{$if sizeof(extended) > sizeof(double)}
+{$ifdef FPC_HAS_TYPE_EXTENDED}
   maxdigits = 15;
 {$else}
   maxdigits = 14;
 {$endif}
 
-Function FloatToStrF(Value: Extended; format: TFloatFormat; Precision, Digits: Integer): String;
+Function FloatToStrFIntl(Value: Extended; format: TFloatFormat; Precision, Digits: Integer; ValueType: TFloatValue): String;
 Var
   P: Integer;
   Negative, TooSmall, TooLarge: Boolean;
 
-
 Begin
   Case format Of
 
@@ -1049,7 +1035,14 @@ Begin
         TooSmall := (Abs(Value) < 0.00001) and (Value>0.0);
         If Not TooSmall Then
         Begin
-          Str(Value:digits:precision, Result);
+          case ValueType of
+            fvDouble:
+              Str(Double(Value):digits:precision, Result);
+            fvSingle:
+              Str(Single(Value):digits:precision, Result);
+            else
+              Str(Extended(Value):digits:precision, Result);
+          end;
           P := Pos('.', Result);
           if P<>0 then
             Result[P] := DecimalSeparator;
@@ -1093,7 +1086,14 @@ Begin
 
       Begin
         If (Precision = -1) Or (Precision > maxdigits) Then Precision := maxdigits;
-        Str(Value:Precision + 8, Result);
+        case ValueType of
+          fvDouble:
+            Str(Double(Value):Precision+8, Result);
+          fvSingle:
+            Str(Single(Value):Precision+8, Result);
+          else
+            Str(Extended(Value):Precision+8, Result);
+        end;
         Result[3] := DecimalSeparator;
         P:=4;
         While (P>0) and (Digits < P) And (Result[Precision + 5] = '0') do
@@ -1113,7 +1113,14 @@ Begin
       Begin
         If Digits = -1 Then Digits := 2
         Else If Digits > 18 Then Digits := 18;
-        Str(Value:0:Digits, Result);
+        case ValueType of
+          fvDouble:
+            Str(Double(Value):0:Digits, Result);
+          fvSingle:
+            Str(Single(Value):0:Digits, Result);
+          else
+            Str(Extended(Value):0:Digits, Result);
+        end;
         If Result[1] = ' ' Then
           System.Delete(Result, 1, 1);
         P := Pos('.', Result);
@@ -1125,7 +1132,14 @@ Begin
       Begin
         If Digits = -1 Then Digits := 2
         Else If Digits > maxdigits Then Digits := maxdigits;
-        Str(Value:0:Digits, Result);
+        case ValueType of
+          fvDouble:
+            Str(Double(Value):0:Digits, Result);
+          fvSingle:
+            Str(Single(Value):0:Digits, Result);
+          else
+            Str(Extended(Value):0:Digits, Result);
+        end;
         If Result[1] = ' ' Then System.Delete(Result, 1, 1);
         P := Pos('.', Result);
         If P <> 0 Then
@@ -1152,7 +1166,14 @@ Begin
 
         If Digits = -1 Then Digits := CurrencyDecimals
         Else If Digits > 18 Then Digits := 18;
-        Str(Value:0:Digits, Result);
+        case ValueType of
+          fvDouble:
+            Str(Double(Value):0:Digits, Result);
+          fvSingle:
+            Str(Single(Value):0:Digits, Result);
+          else
+            Str(Extended(Value):0:Digits, Result);
+        end;
         If Result[1] = ' ' Then System.Delete(Result, 1, 1);
         P := Pos('.', Result);
         If P <> 0 Then Result[P] := DecimalSeparator;
@@ -1192,11 +1213,91 @@ Begin
   End;
 End;
 
+{$ifdef FPC_HAS_TYPE_EXTENDED}
+Function FloatToStr(Value: Extended): String;
+Begin
+  Result := FloatToStrFIntl(Value, ffGeneral, 15, 0, fvExtended);
+End;
+{$endif FPC_HAS_TYPE_EXTENDED}
+
+Function FloatToStr(Value: Currency): String;
+Begin
+  Result := FloatToStrFIntl(Value, ffGeneral, 15, 0, fvCurrency);
+End;
+
+Function FloatToStr(Value: Double): String;
+Begin
+  Result := FloatToStrFIntl(Value, ffGeneral, 15, 0, fvDouble);
+End;
+
+Function FloatToStr(Value: Single): String;
+Begin
+  Result := FloatToStrFIntl(Value, ffGeneral, 15, 0, fvSingle);
+End;
+
+Function FloatToStr(Value: Comp): String;
+Begin
+  Result := FloatToStrFIntl(Value, ffGeneral, 15, 0, fvComp);
+End;
+
+{$ifndef FPC_COMP_IS_INT64}
+Function FloatToStr(Value: Int64): String;
+Begin
+  Result := FloatToStrFIntl(Comp(Value), ffGeneral, 15, 0, fvComp);
+End;
+{$endif FPC_COMP_IS_INT64}
+
+
+Function FloatToText(Buffer: PChar; Value: Extended; format: TFloatFormat; Precision, Digits: Integer): Longint;
+Var
+  Tmp: String[40];
+Begin
+  Tmp := FloatToStrF(Value, format, Precision, Digits);
+  Result := Length(Tmp);
+  Move(Tmp[1], Buffer[0], Result);
+End;
+
+{$ifdef FPC_HAS_TYPE_EXTENDED}
+Function FloatToStrF(Value: Extended; format: TFloatFormat; Precision, Digits: Integer): String;
+begin
+  result := FloatToStrFIntl(value,format,precision,digits,fvExtended);
+end;
+{$endif}
+
+Function FloatToStrF(Value: Currency; format: TFloatFormat; Precision, Digits: Integer): String;
+begin
+  result := FloatToStrFIntl(value,format,precision,digits,fvCurrency);
+end;
+
+Function FloatToStrF(Value: Double; format: TFloatFormat; Precision, Digits: Integer): String;
+begin
+  result := FloatToStrFIntl(value,format,precision,digits,fvDouble);
+end;
+
+Function FloatToStrF(Value: Single; format: TFloatFormat; Precision, Digits: Integer): String;
+begin
+  result := FloatToStrFIntl(value,format,precision,digits,fvSingle);
+end;
+
+Function FloatToStrF(Value: Comp; format: TFloatFormat; Precision, Digits: Integer): String;
+begin
+  result := FloatToStrFIntl(value,format,precision,digits,fvComp);
+end;
+
+{$ifndef FPC_COMP_IS_INT64}
+Function FloatToStrF(Value: Int64; format: TFloatFormat; Precision, Digits: Integer): String;
+begin
+  result := FloatToStrFIntl(Comp(value),format,precision,digits,fvComp);
+end;
+{$endif FPC_COMP_IS_INT64}
+
+
 Function CurrToStrF(Value: Currency; Format: TFloatFormat; Digits: Integer): string;
   begin
     result:=FloatToStrF(Value,Format,19,Digits);
   end;
 
+
 Function FloatToDateTime (Const Value : Extended) : TDateTime;
 begin
   If (Value<MinDateTime) or (Value>MaxDateTime) then

rtl/objpas/sysutils/sysstrh.inc

@@ -119,9 +119,27 @@ Function FormatBuf (Var Buffer; BufLen : Cardinal; Const Fmt; fmtLen : Cardinal;
 Function StrFmt(Buffer,Fmt : PChar; Const args: Array of const) : Pchar;
 Function StrLFmt(Buffer : PCHar; Maxlen : Cardinal;Fmt : PChar; Const args: Array of const) : Pchar;
 Procedure FmtStr(Var Res: String; Const Fmt : String; Const args: Array of const);
+{$ifdef FPC_HAS_TYPE_EXTENDED}
 Function FloatToStrF(Value: Extended; format: TFloatFormat; Precision, Digits: Integer): String;
+{$endif FPC_HAS_TYPE_EXTENDED}
+Function FloatToStrF(Value: Double; format: TFloatFormat; Precision, Digits: Integer): String;
+Function FloatToStrF(Value: Single; format: TFloatFormat; Precision, Digits: Integer): String;
+Function FloatToStrF(Value: Comp; format: TFloatFormat; Precision, Digits: Integer): String;
+Function FloatToStrF(Value: Currency; format: TFloatFormat; Precision, Digits: Integer): String;
+{$ifndef FPC_COMP_IS_INT64}
+Function FloatToStrF(Value: Int64; format: TFloatFormat; Precision, Digits: Integer): String;
+{$endif FPC_COMP_IS_INT64}
 Function CurrToStrF(Value: Currency; Format: TFloatFormat; Digits: Integer): string;
+{$ifdef FPC_HAS_TYPE_EXTENDED}
 Function FloatToStr(Value: Extended): String;
+{$endif FPC_HAS_TYPE_EXTENDED}
+Function FloatToStr(Value: Double): String;
+Function FloatToStr(Value: Single): String;
+Function FloatToStr(Value: Currency): String;
+Function FloatToStr(Value: Comp): String;
+{$ifndef FPC_COMP_IS_INT64}
+Function FloatToStr(Value: Int64): String;
+{$endif FPC_COMP_IS_INT64}
 Function StrToFloat(Const S : String) : Extended;
 Function StrToFloatDef(Const S: String; Const Default: Extended): Extended;
 Function TryStrToFloat(Const S : String; Var Value: Single): Boolean;

rtl/objpas/typinfo.pp

@@ -195,8 +195,10 @@ Function GetPropInfo(AClass: TClass; const PropName: string): PPropInfo;
 Function FindPropInfo(Instance: TObject; const PropName: string): PPropInfo;
 Function FindPropInfo(AClass:TClass;const PropName: string): PPropInfo;
 Procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList);
-Function  GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds; PropList : PPropList;Sorted : boolean = true):longint;
+Function GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds; PropList : PPropList;Sorted : boolean = true):longint;
 Function GetPropList(TypeInfo: PTypeInfo; out PropList: PPropList): SizeInt;
+function GetPropList(AObject: TObject; out PropList: PPropList): Integer;
+
 
 
 // Property information routines.
@@ -690,16 +692,21 @@ end;
 
 
 Function GetPropList(TypeInfo: PTypeInfo; out PropList: PPropList): SizeInt;
-  begin
-    result:=GetTypeData(TypeInfo)^.Propcount;
-    if result>0 then
-      begin
-        getmem(PropList,result*sizeof(pointer));
-        GetPropInfos(TypeInfo,PropList);
-      end;
-  end;
+begin
+  result:=GetTypeData(TypeInfo)^.Propcount;
+  if result>0 then
+    begin
+      getmem(PropList,result*sizeof(pointer));
+      GetPropInfos(TypeInfo,PropList);
+    end;
+end;
 
 
+function GetPropList(AObject: TObject; out PropList: PPropList): Integer;
+begin
+  Result := GetPropList(PTypeInfo(AObject.ClassInfo), PropList);
+end;
+
 { ---------------------------------------------------------------------
   Property access functions
   ---------------------------------------------------------------------}

rtl/unix/oscdeclh.inc

@@ -33,6 +33,7 @@ Type TGrpArr = Array [0..0] of TGid;            { C style array workarounds}
     function  FpDup2    (oldd:cint;newd:cint):cint; cdecl; external clib name 'dup2';
     function  FpExecve  (path : pchar; argv : ppchar; envp: ppchar): cint; cdecl; external clib name 'execve';
     function  FpFork  : TPid; cdecl; external clib name 'fork';
+    function  FpvFork  : TPid; cdecl; external clib name 'vfork';
     function  FpFtruncate(fd : cint; flength : TOff): cint; cdecl; external clib name 'ftruncate';
     function  FpLseek   (fd : cint; offset : TOff; whence : cint): TOff; cdecl; external clib name 'lseek';
     function  FpMkdir   (path : pchar; mode: TMode):cint; cdecl; external clib name 'mkdir';

rtl/unix/sysutils.pp

@@ -20,6 +20,10 @@ interface
 { force ansistrings }
 {$H+}
 
+{$if defined(BSD) and defined(FPC_USE_LIBC)}
+{$define USE_VFORK}
+{$endif}
+
 {$DEFINE OS_FILESETDATEBYNAME}
 {$DEFINE HAS_SLEEP}
 {$DEFINE HAS_OSERROR}
@@ -984,7 +988,11 @@ Begin
   if ComLine <> '' then
     CommandLine := Commandline + ' ' + ComLine;
   {$endif}
+  {$ifdef USE_VFORK}
+  pid:=fpvFork;
+  {$else USE_VFORK}
   pid:=fpFork;
+  {$endif USE_VFORK}
   if pid=0 then
    begin
    {The child does the actual exec, and then exits}

rtl/unix/unix.pp

@@ -17,6 +17,10 @@ Interface
 
 Uses BaseUnix,UnixType;
 
+{$if defined(BSD) and defined(FPC_USE_LIBC)}
+{$define USE_VFORK}
+{$endif}
+
 {$i aliasptp.inc}
 
 { Get Types and Constants only exported in this unit }
@@ -128,8 +132,8 @@ Function AssignPipe  (var pipe_in,pipe_out:text):cint;
 Function AssignPipe  (var pipe_in,pipe_out:file):cint;
 //Function PClose      (Var F:text) : cint;
 //Function PClose      (Var F:file) : cint;
-Function POpen       (var F:text;const Prog:String;rw:char):cint;
-Function POpen       (var F:file;const Prog:String;rw:char):cint;
+Function POpen       (var F:text;const Prog:Ansistring;rw:char):cint;
+Function POpen       (var F:file;const Prog:Ansistring;rw:char):cint;
 Function AssignStream(Var StreamIn,Streamout:text;Const Prog:ansiString;const args : array of ansistring) : cint;
 Function AssignStream(Var StreamIn,Streamout,streamerr:text;Const Prog:ansiString;const args : array of ansistring) : cint;
 
@@ -736,7 +740,7 @@ begin
 end;
 
 
-function POpen(var F:text;const Prog:String;rw:char):cint;
+Function POpen(var F:text;const Prog:Ansistring;rw:char):cint;
 {
   Starts the program in 'Prog' and makes it's input or out put the
   other end of a pipe. If rw is 'w' or 'W', then whatever is written to
@@ -747,11 +751,12 @@ function POpen(var F:text;const Prog:String;rw:char):cint;
 var
   pipi,
   pipo : text;
-  pid  : pid_t;
+  pid  : cint;
   pl   : ^cint;
-{$ifndef FPC_USE_FPEXEC}
-  pp   : ppchar;
-{$endif not FPC_USE_FPEXEC}
+{$if not defined(FPC_USE_FPEXEC) or defined(USE_VFORK)}
+  pp : array[0..3] of pchar;
+  temp : string[255];
+{$endif not FPC_USE_FPEXEC or USE_VFORK}
   ret  : cint;
 begin
   rw:=upcase(rw);
@@ -760,9 +765,14 @@ begin
      FpSetErrno(ESysEnoent);
      exit(-1);
    end;
-  if AssignPipe(pipi,pipo)=-1 Then
-    Exit(-1);
-  pid:=fpfork;          // vfork in FreeBSD.
+  ret:=AssignPipe(pipi,pipo);
+  if ret=-1 then
+   exit(-1);
+{$ifdef USE_VFORK}
+  pid:=fpvfork;
+{$else USE_VFORK}
+  pid:=fpfork;
+{$endif USE_VFORK}
   if pid=-1 then
    begin
      close(pipi);
@@ -774,27 +784,53 @@ begin
    { We're in the child }
      if rw='W' then
       begin
+        if (textrec(pipi).handle <> stdinputhandle) then
+          begin
+            ret:=fpdup2(pipi,input);
+{$ifdef USE_VFORK}
+            fpclose(textrec(pipi).handle);
+{$else USE_VFORK}
+            close(pipi);
+{$endif USE_VFORK}
+          end;
+{$ifdef USE_VFORK}
+        fpclose(textrec(pipo).handle);
+{$else USE_VFORK}
         close(pipo);
-        ret:=fpdup2(pipi,input);
-        close(pipi);
+{$endif USE_VFORK}
         if ret=-1 then
-         halt(127);
+         fpexit(127);
       end
      else
       begin
+{$ifdef USE_VFORK}
+        fpclose(textrec(pipi).handle);
+{$else USE_VFORK}
         close(pipi);
-        ret:=fpdup2(pipo,output);
-        close(pipo);
-        if ret=-1 then
-         halt(127);
+{$endif USE_VFORK}
+        if (textrec(pipo).handle <> stdoutputhandle) then
+          begin
+            ret:=fpdup2(pipo,output);
+{$ifdef USE_VFORK}
+            fpclose(textrec(pipo).handle);
+{$else USE_VFORK}
+            close(pipo);
+{$endif USE_VFORK}
+          end;
+        if ret=1 then
+         fpexit(127);
       end;
-     {$ifdef FPC_USE_FPEXEC}
-     fpexecl('/bin/sh',['-c',Prog]);
+     {$if defined(FPC_USE_FPEXEC) and not defined(USE_VFORK)}
+     fpexecl(pchar('/bin/sh'),['-c',Prog]);
      {$else}
-     pp:=createshellargv(prog);
-     fpExecve(pp^,pp,envp);
+     temp:='/bin/sh'#0'-c'#0;
+     pp[0]:=@temp[1];
+     pp[1]:=@temp[9];
+     pp[2]:=@prog[1];
+     pp[3]:=Nil;
+     fpExecve('/bin/sh',@pp,envp);
      {$endif}
-     halt(127);
+     fpexit(127);
    end
   else
    begin
@@ -803,23 +839,22 @@ begin
       begin
         close(pipi);
         f:=pipo;
-        textrec(f).bufptr:=@textrec(f).buffer;
       end
      else
       begin
         close(pipo);
         f:=pipi;
-        textrec(f).bufptr:=@textrec(f).buffer;
       end;
+     textrec(f).bufptr:=@textrec(f).buffer;
    {Save the process ID - needed when closing }
      pl:=@(textrec(f).userdata[2]);
      pl^:=pid;
      textrec(f).closefunc:=@PCloseText;
    end;
- ret:=0;
+ POpen:=0;
 end;
 
-Function POpen(var F:file;const Prog:String;rw:char):cint;
+Function POpen(var F:file;const Prog:Ansistring;rw:char):cint;
 {
   Starts the program in 'Prog' and makes it's input or out put the
   other end of a pipe. If rw is 'w' or 'W', then whatever is written to
@@ -832,10 +867,10 @@ var
   pipo : file;
   pid  : cint;
   pl   : ^cint;
-{$ifndef FPC_USE_FPEXEC}
-  p,pp : ppchar;
+{$if not defined(FPC_USE_FPEXEC) or defined(USE_VFORK)}
+  pp : array[0..3] of pchar;
   temp : string[255];
-{$endif not FPC_USE_FPEXEC}
+{$endif not FPC_USE_FPEXEC or USE_VFORK}
   ret  : cint;
 begin
   rw:=upcase(rw);
@@ -847,7 +882,11 @@ begin
   ret:=AssignPipe(pipi,pipo);
   if ret=-1 then
    exit(-1);
+{$ifdef USE_VFORK}
+  pid:=fpvfork;
+{$else USE_VFORK}
   pid:=fpfork;
+{$endif USE_VFORK}
   if pid=-1 then
    begin
      close(pipi);
@@ -859,36 +898,53 @@ begin
    { We're in the child }
      if rw='W' then
       begin
+        if (filerec(pipi).handle <> stdinputhandle) then
+          begin
+            ret:=fpdup2(filerec(pipi).handle,stdinputhandle);
+{$ifdef USE_VFORK}
+            fpclose(filerec(pipi).handle);
+{$else USE_VFORK}
+            close(pipi);
+{$endif USE_VFORK}
+          end;
+{$ifdef USE_VFORK}
+        fpclose(filerec(pipo).handle);
+{$else USE_VFORK}
         close(pipo);
-        ret:=fpdup2(filerec(pipi).handle,stdinputhandle);
-        close(pipi);
+{$endif USE_VFORK}
         if ret=-1 then
-         halt(127);
+         fpexit(127);
       end
      else
       begin
+{$ifdef USE_VFORK}
+        fpclose(filerec(pipi).handle);
+{$else USE_VFORK}
         close(pipi);
-        ret:=fpdup2(filerec(pipo).handle,stdoutputhandle);
-        close(pipo);
+{$endif USE_VFORK}
+        if (filerec(pipo).handle <> stdoutputhandle) then
+          begin
+            ret:=fpdup2(filerec(pipo).handle,stdoutputhandle);
+{$ifdef USE_VFORK}
+            fpclose(filerec(pipo).handle);
+{$else USE_VFORK}
+            close(pipo);
+{$endif USE_VFORK}
+          end;
         if ret=1 then
-         halt(127);
+         fpexit(127);
       end;
-     {$ifdef FPC_USE_FPEXEC}
-     fpexecl('/bin/sh',['-c',Prog]);
+     {$if defined(FPC_USE_FPEXEC) and not defined(USE_VFORK)}
+     fpexecl(pchar('/bin/sh'),['-c',Prog]);
      {$else}
-     getmem(pp,sizeof(pchar)*4);
-     temp:='/bin/sh'#0'-c'#0+prog+#0;
-     p:=pp;
-     p^:=@temp[1];
-     inc(p);
-     p^:=@temp[9];
-     inc(p);
-     p^:=@temp[12];
-     inc(p);
-     p^:=Nil;
-     fpExecve(ansistring('/bin/sh'),pp,envp);
+     temp:='/bin/sh'#0'-c'#0;
+     pp[0]:=@temp[1];
+     pp[1]:=@temp[9];
+     pp[2]:=@prog[1];
+     pp[3]:=Nil;
+     fpExecve('/bin/sh',@pp,envp);
      {$endif}
-     halt(127);
+     fpexit(127);
    end
   else
    begin
@@ -931,8 +987,12 @@ begin
   AssignStream:=-1;
   if AssignPipe(streamin,pipo)=-1 Then
    exit(-1);
-  if AssignPipe(pipi,streamout)=-1 Then // shouldn't this close streamin and pipo?
-   exit(-1);
+  if AssignPipe(pipi,streamout)=-1 Then
+    begin
+      close(streamin);
+      close(pipo);
+      exit(-1);
+    end;
   pid:=fpfork;
   if pid=-1 then
    begin

tests/tbf/tb0177.pp

@@ -0,0 +1,16 @@
+{ %fail }
+
+procedure p;
+var
+  e1     : byte;
+  r : record
+    e : (e1,e2);
+  end;
+
+begin
+  r.e:=e1;
+end;
+
+begin
+end.
+

tests/tbs/tb0498.pp

@@ -0,0 +1,15 @@
+type
+  t1 = longint;
+
+procedure p(t3:word);
+var
+  t2 : record
+    t1 : t1;
+end;
+begin
+  writeln(t3);
+end;
+
+begin
+  p(10);
+end.

tests/tbs/tb0499.pp

@@ -0,0 +1,16 @@
+var
+  e1     : byte;
+
+procedure p;
+var
+  r : record
+    e : (e1,e2);
+  end;
+
+begin
+  r.e:=e1;
+end;
+
+begin
+end.
+

tests/test/tstrreal3.pp

@@ -0,0 +1,51 @@
+{ test by Graeme Geldenhuys }
+
+{$mode delphi}
+uses sysutils;
+
+
+procedure test;
+var
+ Result: string;
+ e: extended;
+ r: double;
+begin
+ e := 234.502;
+ Result := FloatToStrF(e, ffGeneral, 15, 0);
+// Memo1.Lines.Add(Result);      { prints 234.502  }
+ writeln(result);
+ if (result <> '234.502') then
+   halt(1);
+
+ r := 234.502;
+ Result := FloatToStrF(r, ffGeneral, 15, 0);
+// Memo1.Lines.Add(Result);  { prints 234.50200000000001 }
+ writeln(result);
+ if (result <> '234.502') then
+   halt(1);
+
+ r := 234.501;
+ Result := FloatToStrF(r, ffGeneral, 15, 0);
+// Memo1.Lines.Add(Result);  { prints 234.501  Why does this work? }
+ writeln(result);
+ if (result <> '234.501') then
+   halt(1);
+
+ r := 7.502;
+ Result := FloatToStrF(r, ffGeneral, 15, 0);
+// Memo1.Lines.Add(Result);  { prints 7.502 }
+ writeln(result);
+ if (result <> '7.502') then
+   halt(1);
+
+ r := 8.502;
+ Result := FloatToStrF(r, ffGeneral, 15, 0);
+// Memo1.Lines.Add(Result);  { prints 8.502000000000001 }
+ writeln(result);
+ if (result <> '8.502') then
+   halt(1);
+end;
+
+begin
+  test;
+end.

tests/webtbs/tw4541.pp

@@ -0,0 +1,12 @@
+{ Source provided for Free Pascal Bug Report 4541 }
+{ Submitted by "Vincent Snijders" on  2005-11-23 }
+{ e-mail: [email protected] }
+program tw4541;
+
+{$mode objfpc}{$H+}
+
+uses
+  uw4541;
+
+begin
+end.

tests/webtbs/tw4700.pp

@@ -0,0 +1,12 @@
+var
+  a: Boolean;
+  b,c,d : Variant;
+  e : Integer;
+begin
+  b := 'abc';
+  c := null;
+  a := b = c;
+  a := b <> c;
+  d := e - c;
+  d := e + c;
+end.

tests/webtbs/uw4541.pp

@@ -0,0 +1,26 @@
+unit uw4541;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes;
+
+type
+
+  TA = class(TComponent)
+    D: TComponent;
+  end;
+
+  TB= class(TComponent)
+  private
+    FA: TA;
+  public
+    property C: TComponent read FA.D;
+  end;
+
+implementation
+
+end.
+

utils/fpdoc/dglobals.pp

@@ -595,24 +595,24 @@ var
     var
       DotPos, DotPos2, i: Integer;
       s: String;
-      Package: TPasPackage;
+      HPackage: TPasPackage;
       Module: TPasModule;
     begin
       // Find or create package
       DotPos := Pos('.', AName);
       s := Copy(AName, 1, DotPos - 1);
-      Package := nil;
+      HPackage := nil;
       for i := 0 to FPackages.Count - 1 do
         if CompareText(TPasPackage(FPackages[i]).Name, s) = 0 then
         begin
-          Package := TPasPackage(FPackages[i]);
+          HPackage := TPasPackage(FPackages[i]);
           break;
         end;
-      if not Assigned(Package) then
+      if not Assigned(HPackage) then
       begin
-        Package := TPasPackage(inherited CreateElement(TPasPackage, s, nil,
+        HPackage := TPasPackage(inherited CreateElement(TPasPackage, s, nil,
           '', 0));
-        FPackages.Add(Package);
+        FPackages.Add(HPackage);
       end;
 
       // Find or create module
@@ -622,17 +622,17 @@ var
       until AName[DotPos2] = '.';
       s := Copy(AName, DotPos + 1, DotPos2 - DotPos - 1);
       Module := nil;
-      for i := 0 to Package.Modules.Count - 1 do
-        if CompareText(TPasModule(Package.Modules[i]).Name, s) = 0 then
+      for i := 0 to HPackage.Modules.Count - 1 do
+        if CompareText(TPasModule(HPackage.Modules[i]).Name, s) = 0 then
         begin
-          Module := TPasModule(Package.Modules[i]);
+          Module := TPasModule(HPackage.Modules[i]);
           break;
         end;
       if not Assigned(Module) then
       begin
-        Module := TPasModule.Create(s, Package);
+        Module := TPasModule.Create(s, HPackage);
         Module.InterfaceSection := TPasSection.Create('', Module);
-        Package.Modules.Add(Module);
+        HPackage.Modules.Add(Module);
       end;
 
       // Create node for class