* cleanup of case <string> of code by Sergei Gorelkin, resolves #13700

git-svn-id: trunk@14467 -

.gitattributes

@@ -8807,6 +8807,7 @@ tests/test/tasout.pp svneol=native#text/plain
 tests/test/tassignmentoperator1.pp svneol=native#text/pascal
 tests/test/tbopr.pp svneol=native#text/plain
 tests/test/tbrtlevt.pp svneol=native#text/plain
+tests/test/tcase0.pp svneol=native#text/pascal
 tests/test/tcase1.pp svneol=native#text/plain
 tests/test/tcase10.pp svneol=native#text/pascal
 tests/test/tcase11.pp svneol=native#text/pascal

compiler/ncon.pas

@@ -135,6 +135,7 @@ interface
           function getpcharcopy : pchar;
           function docompare(p: tnode) : boolean; override;
           procedure changestringtype(def:tdef);
+          function fullcompare(p: tstringconstnode): longint;
        end;
        tstringconstnodeclass = class of tstringconstnode;
 
@@ -191,8 +192,7 @@ interface
 
     { some helper routines }
     function get_ordinal_value(p : tnode) : TConstExprInt;
-    function get_string_value(p : tnode; is_wide : boolean = false) : TConstString;
-    function compare_strings(str1, str2: pchar) : longint;
+    function get_string_value(p : tnode; def: tstringdef) : tstringconstnode;
     function is_constresourcestringnode(p : tnode) : boolean;
     function is_emptyset(p : tnode):boolean;
     function genconstsymtree(p : tconstsym) : tnode;
@@ -238,103 +238,32 @@ implementation
           Message(type_e_constant_expr_expected);
       end;
 
-    function get_string_value(p : tnode; is_wide : boolean) : TConstString;
+    function get_string_value(p: tnode; def: tstringdef): tstringconstnode;
       var
-        pCharVal: pchar;
         stringVal: string;
         pWideStringVal: pcompilerwidestring;
-        ordValRecord: TConstExprInt;
       begin
-        if is_conststring_or_constcharnode(p) then
+        if is_constcharnode(p) then
           begin
-            if is_constcharnode(p) or is_constwidecharnode(p) then
-              begin
-                { if we have case like 'aa'..'b' the right part will never be ordinal }
-                { but in case 'a' it will go here }
-                ordValRecord := tordconstnode(p).value;
-                if (not is_wide) then
-                  begin
-                    if ordValRecord.signed then
-                      stringVal := char(ordValRecord.svalue)
-                    else
-                      stringVal := char(ordValRecord.uvalue);
-                    getmem(pCharVal, length(stringVal) + 1);
-                    strpcopy(pCharVal, stringVal);
-                    pCharVal[length(stringVal)] := #0;
-                    get_string_value := pCharVal;
-                  end
-                else
-                  begin
-                    initwidestring(pWideStringVal);
-                    if ordValRecord.signed then
-                      concatwidestringchar(pWideStringVal, tcompilerwidechar(ordValRecord.svalue))
-                    else
-                      concatwidestringchar(pWideStringVal, tcompilerwidechar(ordValRecord.uvalue));
-                    get_string_value := TConstString(pWideStringVal);
-                  end;
-              end
-            else
-              begin
-                if is_wide then
-                  begin
-                    if (tstringconstnode(p).cst_type in [cst_widestring, cst_unicodestring]) then
-                      begin
-                        initwidestring(pWideStringVal);
-                        copywidestring(pcompilerwidestring(tstringconstnode(p).value_str), pWideStringVal);
-                        get_string_value := TConstString(pWideStringVal);
-                      end
-                    else
-                      { if string must be wide, but actually was parsed as usual }
-                      begin
-                        initwidestring(pWideStringVal);
-                        ascii2unicode(tstringconstnode(p).value_str, tstringconstnode(p).len, pWideStringVal);
-                        get_string_value := TConstString(pWideStringVal);
-                      end;
-                  end
-                else
-                  begin
-                    if (tstringconstnode(p).cst_type in [cst_widestring, cst_unicodestring]) then
-                      { string is wide but it must be usual }
-                      begin
-                        getmem(pCharVal, pcompilerwidestring(tstringconstnode(p).value_str)^.len + 1);
-                        unicode2ascii(pcompilerwidestring(tstringconstnode(p).value_str), pCharVal);
-                        pCharVal[pcompilerwidestring(tstringconstnode(p).value_str)^.len] := #0;
-                        get_string_value := pCharVal;
-                      end
-                    else
-                      begin
-                        getmem(pCharVal, tstringconstnode(p).len + 1);
-                        move(tstringconstnode(p).value_str^, pCharVal^, tstringconstnode(p).len);
-                        pCharVal[tstringconstnode(p).len] := #0;
-                        get_string_value := pCharVal;
-                      end;
-                  end;
-              end;
+            SetLength(stringVal,1);
+            stringVal[1]:=char(tordconstnode(p).value.uvalue);
+            result:=cstringconstnode.createstr(stringVal);
+          end
+        else if is_constwidecharnode(p) then
+          begin
+            initwidestring(pWideStringVal);
+            concatwidestringchar(pWideStringVal, tcompilerwidechar(tordconstnode(p).value.uvalue));
+            result:=cstringconstnode.createwstr(pWideStringVal);
           end
+        else if is_conststringnode(p) then
+          result:=tstringconstnode(p.getcopy)
         else
           begin
             Message(type_e_string_expr_expected);
-            getmem(get_string_value, 1);
-            get_string_value[0] := #0;
+            stringVal:='';
+            result:=cstringconstnode.createstr(stringVal);
           end;
-      end;
-
-
-    function compare_strings(str1, str2: pchar) : longint;
-      var
-        minlen, len1, len2: integer;
-      begin
-        len1 := length(str1);
-        len2 := length(str2);
-        if len1 < len2 then
-          minlen := len1
-        else
-          minlen := len2;
-
-        minlen := comparebyte(str1^, str2^, minlen);
-        if minlen = 0 then
-          minlen := len1 - len2;
-        Result := minlen;
+        result.changestringtype(def);
       end;
 
 
@@ -1049,6 +978,15 @@ implementation
         resultdef:=def;
       end;
 
+    function tstringconstnode.fullcompare(p: tstringconstnode): longint;
+      begin
+        if cst_type<>p.cst_type then
+          InternalError(2009121701);
+        if cst_type in [cst_widestring,cst_unicodestring] then
+          result:=comparewidestrings(pcompilerwidestring(value_str),pcompilerwidestring(p.value_str))
+        else
+          result:=compareansistrings(value_str,p.value_str,len,p.len);
+      end;
 
 {*****************************************************************************
                              TSETCONSTNODE

compiler/nset.pas

@@ -28,7 +28,7 @@ interface
     uses
        cclasses,constexp,
        node,globtype,globals,
-       aasmbase,aasmtai,aasmdata,ncon,symtype,strings;
+       aasmbase,aasmtai,aasmdata,ncon,symtype;
 
     type
        TLabelType = (ltOrdinal, ltConstString);
@@ -51,8 +51,7 @@ interface
             ltConstString:
             (
               _low_str,
-              _high_str   : TConstString;
-              _str_type   : TConstStringType;
+              _high_str   : tstringconstnode;
             );
        end;
 
@@ -102,7 +101,7 @@ interface
           function pass_1 : tnode;override;
           function docompare(p: tnode): boolean; override;
           procedure addlabel(blockid:longint;l,h : TConstExprInt); overload;
-          procedure addlabel(blockid:longint;l,h : TConstString; str_type : TConstStringType); overload;
+          procedure addlabel(blockid:longint;l,h : tstringconstnode); overload;
           procedure addblock(blockid:longint;instr:tnode);
           procedure addelseblock(instr:tnode);
        end;
@@ -474,16 +473,8 @@ implementation
            deletecaselabels(p^.less);
          if (p^.label_type = ltConstString) then
            begin
-             if (p^._str_type in [cst_widestring, cst_unicodestring]) then
-               begin
-                 donewidestring(pcompilerwidestring(p^._low_str));
-                 donewidestring(pcompilerwidestring(p^._high_str));
-               end
-             else
-               begin
-                 freemem(p^._low_str);
-                 freemem(p^._high_str);
-               end;
+             p^._low_str.Free;
+             p^._high_str.Free;
            end;
          dispose(p);
       end;
@@ -498,24 +489,8 @@ implementation
          n^:=p^;
          if (p^.label_type = ltConstString) then
            begin
-             if (p^._str_type in [cst_widestring, cst_unicodestring]) then
-               begin
-                 initwidestring(pcompilerwidestring(n^._low_str));
-                 initwidestring(pcompilerwidestring(n^._high_str));
-                 copywidestring(
-                   pcompilerwidestring(p^._low_str), pcompilerwidestring(n^._low_str));
-                 copywidestring(
-                   pcompilerwidestring(p^._high_str), pcompilerwidestring(n^._high_str));
-               end
-             else
-               begin
-                 getmem(n^._low_str, strlen(p^._low_str) + 1);
-                 strcopy(n^._low_str, p^._low_str);
-                 n^._low_str[strlen(p^._low_str)] := #0;
-                 getmem(n^._high_str, strlen(p^._high_str) + 1);
-                 strcopy(n^._high_str, p^._high_str);
-                 n^._high_str[strlen(p^._high_str)] := #0;
-               end;
+             n^._low_str := tstringconstnode(p^._low_str.getcopy);
+             n^._high_str := tstringconstnode(p^._high_str.getcopy);
            end;
          if assigned(p^.greater) then
            n^.greater:=copycaselabel(p^.greater);
@@ -526,35 +501,14 @@ implementation
 
 
     procedure ppuwritecaselabel(ppufile:tcompilerppufile;p : pcaselabel);
-
-      procedure ppuwritestring(str_type : tconststringtype; value : pchar);
-
-        var
-          len : integer;
-        begin
-          if str_type in [cst_widestring, cst_unicodestring] then
-            begin
-              len := pcompilerwidestring(value)^.len;
-              ppufile.putlongint(len);
-              ppufile.putdata(pcompilerwidestring(value)^.data, len * sizeof(tcompilerwidechar));
-            end
-          else
-            begin
-              len := strlen(value);
-              ppufile.putlongint(len);
-              ppufile.putdata(value^, len);
-            end;
-        end;
-
       var
         b : byte;
       begin
         ppufile.putbyte(byte(p^.label_type = ltConstString));
         if (p^.label_type = ltConstString) then
           begin
-            ppufile.putbyte(byte(p^._str_type));
-            ppuwritestring(p^._str_type, p^._low_str);
-            ppuwritestring(p^._str_type, p^._high_str);
+            p^._low_str.ppuwrite(ppufile);
+            p^._high_str.ppuwrite(ppufile);
           end
         else
           begin
@@ -563,11 +517,7 @@ implementation
           end;
 
         ppufile.putlongint(p^.blockid);
-        b:=0;
-        if assigned(p^.greater) then
-         b:=b or 1;
-        if assigned(p^.less) then
-         b:=b or 2;
+        b:=ord(assigned(p^.greater)) or (ord(assigned(p^.less)) shl 1);
         ppufile.putbyte(b);
         if assigned(p^.greater) then
           ppuwritecaselabel(ppufile,p^.greater);
@@ -577,29 +527,6 @@ implementation
 
 
     function ppuloadcaselabel(ppufile:tcompilerppufile):pcaselabel;
-
-      procedure ppuloadstring(str_type : tconststringtype; out value : pchar);
-
-        var
-          pw : pcompilerwidestring;
-          len : integer;
-        begin
-          len := ppufile.getlongint;
-          if str_type in [cst_widestring, cst_unicodestring] then
-            begin
-              initwidestring(pw);
-              setlengthwidestring(pw, len);
-              ppufile.getdata(pw^.data, pw^.len * sizeof(tcompilerwidechar));
-              pcompilerwidestring(value) := pw
-            end
-          else
-            begin
-              getmem(value, len + 1);
-              ppufile.getdata(value^, len);
-              value[len] := #0;
-            end;
-        end;
-
       var
         b : byte;
         p : pcaselabel;
@@ -608,10 +535,8 @@ implementation
         if boolean(ppufile.getbyte) then
           begin
             p^.label_type := ltConstString;
-            p^._str_type := tconststringtype(ppufile.getbyte);
-
-            ppuloadstring(p^._str_type, p^._low_str);
-            ppuloadstring(p^._str_type, p^._high_str);
+            p^._low_str := cstringconstnode.ppuload(stringconstn,ppufile);
+            p^._high_str := cstringconstnode.ppuload(stringconstn,ppufile);
           end
         else
           begin
@@ -736,45 +661,21 @@ implementation
         var
           condit : tnode;
         begin
-          result := nil;
           if assigned(labtree^.less) then
             result := makeifblock(labtree^.less, prevconditblock)
           else
             result := prevconditblock;
-          prevconditblock := nil;
 
-          if (labtree^._str_type in [cst_widestring, cst_unicodestring]) then
-            begin
-              condit := caddnode.create(
-                equaln, left.getcopy,
-                cstringconstnode.createwstr(pcompilerwidestring(labtree^._low_str)));
- 
-              if (
-                comparewidestrings(
-                  pcompilerwidestring(labtree^._low_str),
-                  pcompilerwidestring(labtree^._high_str)) <> 0) then
-                begin
-                  condit.nodetype := gten;
-                  condit := caddnode.create(
-                    andn, condit, caddnode.create(
-                      lten, left.getcopy, cstringconstnode.createwstr(
-                        pcompilerwidestring(labtree^._high_str))));
-                end;
-            end
-          else
+          condit := caddnode.create(equaln, left.getcopy, labtree^._low_str.getcopy);
+
+          if (labtree^._low_str.fullcompare(labtree^._high_str)<>0) then
             begin
+              condit.nodetype := gten;
               condit := caddnode.create(
-                equaln, left.getcopy, cstringconstnode.createstr(labtree^._low_str));
-
-              if (compare_strings(labtree^._low_str, labtree^._high_str) <> 0) then
-                begin
-                  condit.nodetype := gten;
-                  condit := caddnode.create(
-                    andn, condit, caddnode.create(
-                      lten, left.getcopy, cstringconstnode.createstr(labtree^._high_str)));
-                end;
+                andn, condit, caddnode.create(
+                  lten, left.getcopy, labtree^._high_str.getcopy));
             end;
-          
+
           result :=
             cifnode.create(
               condit, pcaseblock(blocks[labtree^.blockid])^.statement, result);
@@ -855,7 +756,6 @@ implementation
                end
              else
                result := if_node;
-             init_block := nil;
              elseblock := nil;
              exit;
            end;
@@ -1046,7 +946,10 @@ implementation
                       result:=insertlabel(p^.greater);
                  end
              else
-               Message(parser_e_double_caselabel);
+               begin
+                 dispose(hcaselabel);
+                 Message(parser_e_double_caselabel);
+               end
           end;
 
       begin
@@ -1059,15 +962,7 @@ implementation
         insertlabel(labels);
       end;
 
-    procedure tcasenode.addlabel(blockid : longint; l, h : TConstString; str_type : TConstStringType);
-
-      function str_compare(l, h : TConstString) : longint;
-        begin
-          if (str_type in [cst_widestring, cst_unicodestring]) then
-            result := comparewidestrings(pcompilerwidestring(l), pcompilerwidestring(h))
-          else
-            result := compare_strings(l, h);
-        end;
+    procedure tcasenode.addlabel(blockid: longint; l, h: tstringconstnode);
 
       var
         hcaselabel : pcaselabel;
@@ -1080,13 +975,18 @@ implementation
               result := p;
             end
           else
-            if (str_compare(p^._low_str, hcaselabel^._high_str) > 0) then
+            if (p^._low_str.fullcompare(hcaselabel^._high_str) > 0) then
               result := insertlabel(p^.less)
           else
-            if (str_compare(p^._high_str, hcaselabel^._low_str) < 0) then
+            if (p^._high_str.fullcompare(hcaselabel^._low_str) < 0) then
               result := insertlabel(p^.greater)
           else
-            Message(parser_e_double_caselabel);
+            begin
+              hcaselabel^._low_str.free;
+              hcaselabel^._high_str.free;
+              dispose(hcaselabel);
+              Message(parser_e_double_caselabel);
+            end;
         end;
 
       begin
@@ -1095,24 +995,9 @@ implementation
         hcaselabel^.blockid := blockid;
         hcaselabel^.label_type := ltConstString;
 
-        if (str_type in [cst_widestring, cst_unicodestring]) then
-          begin
-            initwidestring(pcompilerwidestring(hcaselabel^._low_str));
-            initwidestring(pcompilerwidestring(hcaselabel^._high_str));
-            copywidestring(pcompilerwidestring(l), pcompilerwidestring(hcaselabel^._low_str));
-            copywidestring(pcompilerwidestring(h), pcompilerwidestring(hcaselabel^._high_str));
-          end
-        else
-          begin
-            getmem(hcaselabel^._low_str, strlen(l) + 1);
-            getmem(hcaselabel^._high_str, strlen(h) + 1);
-            strcopy(hcaselabel^._low_str, l);
-            strcopy(hcaselabel^._high_str, h);
-            hcaselabel^._low_str[strlen(l)] := #0;
-            hcaselabel^._high_str[strlen(h)] := #0;
-          end;
+        hcaselabel^._low_str := tstringconstnode(l.getcopy);
+        hcaselabel^._high_str := tstringconstnode(h.getcopy);
 
-        hcaselabel^._str_type := str_type;
         insertlabel(labels);
       end;
 

compiler/pstatmnt.pas

@@ -42,7 +42,7 @@ implementation
        cutils,cclasses,
        { global }
        globtype,globals,verbose,constexp,
-       strings,systems,
+       systems,
        { aasm }
        cpubase,aasmbase,aasmtai,aasmdata,
        { symtable }
@@ -115,16 +115,12 @@ implementation
 
 
     function case_statement : tnode;
-      const
-        st2cst : array[tstringtype] of tconststringtype = (
-          cst_shortstring,cst_longstring,cst_ansistring,
-          cst_widestring,cst_unicodestring);
       var
          casedef : tdef;
          caseexpr,p : tnode;
          blockid : longint;
          hl1,hl2 : TConstExprInt;
-         sl1,sl2 : TConstString;
+         sl1,sl2 : tstringconstnode;
          casedeferror, caseofstring : boolean;
          casenode : tcasenode;
       begin
@@ -192,12 +188,10 @@ implementation
                    is_conststring_or_constcharnode(trangenode(p).left) and
                    is_conststring_or_constcharnode(trangenode(p).right) then
                  begin
-                   sl1 := get_string_value(trangenode(p).left, is_wide_or_unicode_string(casedef));
-                   sl2 := get_string_value(trangenode(p).right, is_wide_or_unicode_string(casedef));
-                   if (
-                     (is_wide_or_unicode_string(casedef) and (
-                       comparewidestrings(pcompilerwidestring(sl1), pcompilerwidestring(sl2)) > 0)) or
-                     ((not is_wide_or_unicode_string(casedef)) and (compare_strings(sl1, sl2) > 0))) then
+                   { we need stringconstnodes, even if expression contains single chars }
+                   sl1 := get_string_value(trangenode(p).left, tstringdef(casedef));
+                   sl2 := get_string_value(trangenode(p).right, tstringdef(casedef));
+                   if sl1.fullcompare(sl2) > 0 then
                      CGMessage(parser_e_case_lower_less_than_upper_bound);
                  end
                  { type checking for ordinal case statements }
@@ -219,7 +213,7 @@ implementation
                    CGMessage(parser_e_case_mismatch);
 
                  if caseofstring then
-                   casenode.addlabel(blockid,sl1,sl2,st2cst[tstringdef(casedef).stringtype])
+                   casenode.addlabel(blockid,sl1,sl2)
                  else
                    casenode.addlabel(blockid,hl1,hl2);
                end
@@ -233,8 +227,8 @@ implementation
                   
                  if caseofstring then
                    begin
-                     sl1:=get_string_value(p, is_wide_or_unicode_string(casedef));
-                     casenode.addlabel(blockid,sl1,sl1,st2cst[tstringdef(casedef).stringtype]);
+                     sl1:=get_string_value(p, tstringdef(casedef));
+                     casenode.addlabel(blockid,sl1,sl1);
                    end
                  else
                    begin
@@ -245,29 +239,9 @@ implementation
                    end;
                end;
              p.free;
-             if caseofstring then
-               begin
-                 if is_wide_or_unicode_string(casedef) then
-                   begin
-                     if assigned(sl1) then
-                       donewidestring(pcompilerwidestring(sl1));
-                     if assigned(sl2) then
-                       donewidestring(pcompilerwidestring(sl2));
-                   end
-                 else
-                   begin
-                     if assigned(sl1) then
-                       begin
-                         freemem(sl1);
-                         sl1 := nil;
-                       end;
-                     if assigned(sl2) then
-                       begin
-                         freemem(sl2);
-                         sl2 := nil;
-                       end;
-                   end;
-               end;
+             sl1.free;
+             sl2.free;
+
              if token=_COMMA then
                consume(_COMMA)
              else

tests/test/tcase0.pp

@@ -0,0 +1,37 @@
+{$mode objfpc}{$h+}
+
+// A basic test for 'case-of-string' with embedded zeroes
+var
+  s: string;
+  ss: shortstring;
+  ws: widestring;
+  us: unicodestring;
+  i: integer;
+
+begin
+  i:=15;
+
+  s:='aa'#0'bb';  
+  case s of  
+    'aa'#0'aa' .. 'aa'#0'cc': i:=i and (not 1);
+  end;
+
+  ss:='aa'#0'bb';
+  case ss of
+    'aa'#0'aa' .. 'aa'#0'cc': i:=i and (not 2);  
+  end;
+  
+  ws:='aa'#0'bb';
+  case ws of
+    'aa'#0'aa' .. 'aa'#0'cc': i:=i and (not 4);
+  end;
+  
+  us:='aa'#0'bb';
+  case us of
+    'aa'#0'aa' .. 'aa'#0'cc': i:=i and (not 8);
+  end;
+
+  if i=0 then
+    writeln('ok');
+  Halt(i);  
+end.