* fixed problem with default properties which are a class

* case bug (from the mailing list with -O2) fixed, the
    distance of the case labels can be greater than the positive
    range of a longint => it is now a dword for fpc

compiler/cg386set.pas

@@ -659,6 +659,7 @@ implementation
       var
          lv,hv,min_label,max_label,labels : longint;
          max_linear_list : longint;
+         dist : dword;
 
       begin
          getlabel(endlabel);
@@ -732,14 +733,26 @@ implementation
               min_label:=case_get_min(p^.nodes);
               max_label:=case_get_max(p^.nodes);
               labels:=case_count_labels(p^.nodes);
-              { can we omit the range check of the jump table }
+              { can we omit the range check of the jump table ? }
               getrange(p^.left^.resulttype,lv,hv);
               jumptable_no_range:=(lv=min_label) and (hv=max_label);
+              { hack a little bit, because the range can be greater }
+              { than the positive range of a longint                }
+
+              if (min_label<0) and (max_label>0) then
+                begin
+                   if min_label=$80000000 then
+                     dist:=dword(max_label)+dword($80000000)
+                   else
+                     dist:=dword(max_label)+dword(-min_label)
+                end
+              else
+                dist:=max_label-min_label;
 
               { optimize for size ? }
               if cs_littlesize in aktglobalswitches  then
                 begin
-                   if (labels<=2) or ((max_label-min_label)>3*labels) then
+                   if (labels<=2) or (dist>3*labels) then
                   { a linear list is always smaller than a jump tree }
                      genlinearlist(p^.nodes)
                    else
@@ -764,7 +777,7 @@ implementation
                      genlinearlist(p^.nodes)
                    else
                      begin
-                        if ((max_label-min_label)>4*labels) then
+                        if (dist>4*labels) then
                           begin
                              if labels>16 then
                                gentreejmp(p^.nodes)
@@ -805,7 +818,13 @@ implementation
 end.
 {
   $Log$
-  Revision 1.24  1999-03-02 18:21:35  peter
+  Revision 1.25  1999-04-08 20:59:37  florian
+    * fixed problem with default properties which are a class
+    * case bug (from the mailing list with -O2) fixed, the
+      distance of the case labels can be greater than the positive
+      range of a longint => it is now a dword for fpc
+
+  Revision 1.24  1999/03/02 18:21:35  peter
     + flags support for add and case
 
   Revision 1.23  1999/02/25 21:02:31  peter

compiler/cobjects.pas

@@ -47,6 +47,13 @@ unit cobjects;
     type
        pstring = ^string;
 
+{$ifdef TP}
+       { redeclare dword only in case of emergency, some small things
+         of the compiler won't work then correctly (FK)
+       }
+       dword = longint;
+{$endif TP}
+
        pfileposinfo = ^tfileposinfo;
        tfileposinfo = record
          line      : longint;
@@ -1612,7 +1619,13 @@ end;
 end.
 {
   $Log$
-  Revision 1.22  1999-03-31 13:55:10  peter
+  Revision 1.23  1999-04-08 20:59:39  florian
+    * fixed problem with default properties which are a class
+    * case bug (from the mailing list with -O2) fixed, the
+      distance of the case labels can be greater than the positive
+      range of a longint => it is now a dword for fpc
+
+  Revision 1.22  1999/03/31 13:55:10  peter
     * assembler inlining working for ag386bin
 
   Revision 1.21  1999/03/19 16:35:29  pierre

compiler/pbase.pas

@@ -100,7 +100,10 @@ unit pbase;
     procedure consume(i : ttoken);
       begin
         if (token<>i) and (idtoken<>i) then
-          Message2(scan_f_syn_expected,tokeninfo[i].str,tokeninfo[token].str)
+          if token=ID then
+            Message2(scan_f_syn_expected,tokeninfo[i].str,'identifier '+pattern)
+          else
+            Message2(scan_f_syn_expected,tokeninfo[i].str,tokeninfo[token].str)
         else
           begin
             if token=_END then
@@ -180,7 +183,13 @@ end.
 
 {
   $Log$
-  Revision 1.18  1998-12-11 00:03:29  peter
+  Revision 1.19  1999-04-08 20:59:42  florian
+    * fixed problem with default properties which are a class
+    * case bug (from the mailing list with -O2) fixed, the
+      distance of the case labels can be greater than the positive
+      range of a longint => it is now a dword for fpc
+
+  Revision 1.18  1998/12/11 00:03:29  peter
     + globtype,tokens,version unit splitted from globals
 
   Revision 1.17  1998/09/26 17:45:31  peter

compiler/pexpr.pas

@@ -1231,10 +1231,7 @@ unit pexpr;
                              message(parser_e_no_default_property_available);
                           end
                         else
-                          begin
+                          handle_propertysym(propsym,propsym^.owner,p1,pd);
-                             p1:=nil;
-                             handle_propertysym(propsym,propsym^.owner,p1,pd);
-                          end;
                       end
                     else
                       begin
@@ -1976,7 +1973,13 @@ unit pexpr;
 end.
 {
   $Log$
-  Revision 1.91  1999-04-06 11:21:56  peter
+  Revision 1.92  1999-04-08 20:59:43  florian
+    * fixed problem with default properties which are a class
+    * case bug (from the mailing list with -O2) fixed, the
+      distance of the case labels can be greater than the positive
+      range of a longint => it is now a dword for fpc
+
+  Revision 1.91  1999/04/06 11:21:56  peter
     * more use of ttoken
 
   Revision 1.90  1999/03/31 13:55:12  peter

compiler/temp_gen.pas

@@ -37,6 +37,15 @@ unit temp_gen;
 {$endif m68k}
        cobjects,globals,tree,hcodegen,verbose,files,aasm;
 
+      type
+{ this saves some memory }
+{$ifdef FPC}
+{$minenumsize 1}
+{$endif FPC}
+       ttemptype = (tt_normal,tt_ansistring,tt_widestring);
+{$ifdef FPC}
+{$minenumsize default}
+{$endif FPC}
     { generates temporary variables }
     procedure resettempgen;
     procedure setfirsttemp(l : longint);
@@ -49,9 +58,10 @@ unit temp_gen;
     procedure ungettemp(pos : longint;size : longint);
     procedure ungetpersistanttemp(pos : longint;size : longint);
     procedure gettempofsizereference(l : longint;var ref : treference);
-    procedure gettempansistringreference(var ref : treference);
+    procedure gettempslotreference(slottype : ttemptype;var ref : treference);
     function istemp(const ref : treference) : boolean;
     procedure ungetiftemp(const ref : treference);
+    procedure gettempansistringreference(var ref : treference);
 
 
   implementation
@@ -74,14 +84,19 @@ unit temp_gen;
           pos : longint;
           size : longint;
           persistant : boolean; { used for inlined procedures }
+          temptype : ttemptype;
 {$ifdef EXTDEBUG}
           posinfo,releaseposinfo : tfileposinfo;
 {$endif}
        end;
 
     var
+       { contains all free temps }
        tmpfreelist : pfreerecord;
+       { contains all used temps }
        templist : pfreerecord;
+       { contains the slots for ansi/wide string temps }
+       reftempslots : pfreerecord;
 {$ifdef EXTDEBUG}
        tempfreedlist : pfreerecord;
 {$endif}
@@ -252,6 +267,7 @@ unit temp_gen;
       end;
 
     procedure gettempansistringreference(var ref : treference);
+
       begin
          { do a reset, because the reference isn't used }
          reset_reference(ref);
@@ -259,6 +275,15 @@ unit temp_gen;
          ref.base:=procinfo.framepointer;
       end;
 
+    procedure gettempslotreference(slottype : ttemptype;var ref : treference);
+      begin
+         { do a reset, because the reference isn't used }
+         reset_reference(ref);
+         ref.offset:=gettempofsize(4);
+         ref.base:=procinfo.framepointer;
+         templist^.temptype:=slottype;
+      end;
+
 
     function istemp(const ref : treference) : boolean;
 
@@ -439,13 +464,13 @@ unit temp_gen;
               while assigned(tl) do
                 begin
                    { no release of persistant blocks this way!! }
-                   if tl^.persistant then
+                   if (tl^.persistant) or (tl^.temptype<>tt_normal) then
                      if (ref.offset>=tl^.pos) and
                         (ref.offset<tl^.pos+tl^.size) then
                        begin
 {$ifdef EXTDEBUG}
                           Comment(V_Debug,'temp '+
-                            ' at pos '+tostr(ref.offset)+ ' not released because persistant !');
+                            ' at pos '+tostr(ref.offset)+ ' not released because persistant or slot!');
 {$endif}
                           exit;
                        end;
@@ -453,8 +478,8 @@ unit temp_gen;
                      begin
                         ungettemp(ref.offset,tl^.size);
 {$ifdef TEMPDEBUG}
-                   Comment(V_Debug,'temp managment  : ungettemp()'+
+                        Comment(V_Debug,'temp managment  : ungettemp()'+
-                     ' at pos '+tostr(tl^.pos)+ ' found !');
+                          ' at pos '+tostr(tl^.pos)+ ' found !');
 {$endif}
                         if assigned(prev) then
                           prev^.next:=tl^.next
@@ -500,13 +525,26 @@ unit temp_gen;
            end;
       end;
 
+   procedure inittemps;
+
+     begin
+        { hp:=temp }
+     end;
+
 begin
    tmpfreelist:=nil;
    templist:=nil;
+   reftempslots:=nil;
 end.
 {
   $Log$
-  Revision 1.10  1999-04-06 11:19:49  peter
+  Revision 1.11  1999-04-08 20:59:44  florian
+    * fixed problem with default properties which are a class
+    * case bug (from the mailing list with -O2) fixed, the
+      distance of the case labels can be greater than the positive
+      range of a longint => it is now a dword for fpc
+
+  Revision 1.10  1999/04/06 11:19:49  peter
     * fixed temp reuse
 
   Revision 1.9  1999/02/22 02:15:56  peter