+ some widestring stuff added

compiler/i386/cgai386.pas

@@ -2001,7 +2001,9 @@ implementation
        hp:=templist;
        while assigned(hp) do
          begin
-           if hp^.temptype in [tt_ansistring,tt_freeansistring,tt_interfacecom] then
+           if hp^.temptype in [tt_ansistring,tt_freeansistring,
+             tt_widestring,tt_freewidestring,
+             tt_interfacecom] then
              begin
                procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
                new(r);
@@ -2032,6 +2034,15 @@ implementation
                 emitpushreferenceaddr(hr);
                 emitcall('FPC_ANSISTR_DECR_REF');
               end
+            else if hp^.temptype in [tt_widestring,tt_freewidestring] then
+              begin
+                procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
+                reset_reference(hr);
+                hr.base:=procinfo^.framepointer;
+                hr.offset:=hp^.pos;
+                emitpushreferenceaddr(hr);
+                emitcall('FPC_WIDESTR_DECR_REF');
+              end
             else if hp^.temptype=tt_interfacecom then
               begin
                 procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
@@ -2986,7 +2997,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.23  2001-04-21 13:33:16  peter
+  Revision 1.24  2001-05-27 14:30:55  florian
+    + some widestring stuff added
+
+  Revision 1.23  2001/04/21 13:33:16  peter
     * move winstackpagesize const to cgai386 to remove uses t_win32
 
   Revision 1.22  2001/04/21 12:05:32  peter

compiler/i386/n386add.pas

@@ -42,7 +42,7 @@ interface
 
     uses
       globtype,systems,
-      cutils,verbose,globals,
+      cutils,verbose,globals,widestr,
       symconst,symdef,aasm,types,
       hcodegen,temp_gen,pass_2,
       cpuasm,
@@ -143,6 +143,7 @@ interface
         if nf_swaped in flags then
           swapleftright;
         case tstringdef(left.resulttype.def).string_typ of
+           st_widestring,
            st_ansistring:
              begin
                 case nodetype of
@@ -176,11 +177,12 @@ interface
                         emit_push_loc(right.location);
                         emit_push_loc(left.location);
                         saveregvars($ff);
-                        emitcall('FPC_ANSISTR_CONCAT');
+                        if tstringdef(left.resulttype.def).string_typ=st_widestring then
+                          emitcall('FPC_WIDESTR_CONCAT')
+                        else
+                          emitcall('FPC_ANSISTR_CONCAT');
                         popusedregisters(pushedregs);
                         maybe_loadself;
-                        ungetiftempansi(left.location.reference);
-                        ungetiftempansi(right.location.reference);
                      end;
                    ltn,lten,gtn,gten,
                    equaln,unequaln:
@@ -200,8 +202,6 @@ interface
                                LOC_REGISTER,LOC_CREGISTER:
                                  emit_const_reg(A_CMP,S_L,0,right.location.register);
                              end;
-                             ungetiftempansi(left.location.reference);
-                             ungetiftempansi(right.location.reference);
                           end
                         else if (nodetype in [equaln,unequaln]) and
                           (right.nodetype=stringconstn) and
@@ -217,8 +217,6 @@ interface
                                LOC_REGISTER,LOC_CREGISTER:
                                  emit_const_reg(A_CMP,S_L,0,left.location.register);
                              end;
-                             ungetiftempansi(left.location.reference);
-                             ungetiftempansi(right.location.reference);
                           end
                         else
                           begin
@@ -246,16 +244,27 @@ interface
                                  emit_reg(A_PUSH,S_L,left.location.register);
                              end;
                              saveregvars($ff);
-                             emitcall('FPC_ANSISTR_COMPARE');
+                             if tstringdef(left.resulttype.def).string_typ=st_widestring then
+                               emitcall('FPC_WIDESTR_COMPARE')
+                             else
+                               emitcall('FPC_ANSISTR_COMPARE');
                              emit_reg_reg(A_OR,S_L,R_EAX,R_EAX);
                              popusedregisters(pushedregs);
                              maybe_loadself;
-                             ungetiftempansi(left.location.reference);
-                             ungetiftempansi(right.location.reference);
                           end;
                      end;
                 end;
-               { the result of ansicompare is signed }
+               if tstringdef(left.resulttype.def).string_typ=st_widestring then
+                 begin
+                    ungetiftempwidestr(left.location.reference);
+                    ungetiftempwidestr(right.location.reference);
+                 end
+               else
+                 begin
+                    ungetiftempansi(left.location.reference);
+                    ungetiftempansi(right.location.reference);
+                 end;
+               { the result of wide/ansicompare is signed :/ }
                SetResultLocation(cmpop,false);
              end;
            st_shortstring:
@@ -2276,7 +2285,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.12  2001-05-06 17:12:14  jonas
+  Revision 1.13  2001-05-27 14:30:56  florian
+    + some widestring stuff added
+
+  Revision 1.12  2001/05/06 17:12:14  jonas
     * fixed an IE10 and another bug with [var1..var2] construct
 
   Revision 1.11  2001/04/13 01:22:18  peter

compiler/i386/n386ld.pas

@@ -479,7 +479,8 @@ implementation
 {$endif test_dest_loc}
          if left.resulttype.def.deftype=stringdef then
            begin
-              if is_ansistring(left.resulttype.def) then
+              if is_ansistring(left.resulttype.def) or
+                is_widestring(left.resulttype.def) then
                 begin
                   { before pushing any parameter, we have to save all used      }
                   { registers, but before that we have to release the       }
@@ -516,7 +517,10 @@ implementation
                   emitpushreferenceaddr(left.location.reference);
                   del_reference(left.location.reference);
                   saveregvars($ff);
-                  emitcall('FPC_ANSISTR_ASSIGN');
+                  if is_ansistring(left.resulttype.def) then
+                    emitcall('FPC_ANSISTR_ASSIGN')
+                  else
+                    emitcall('FPC_WIDESTR_ASSIGN');
                   maybe_loadself;
                   popusedregisters(regspushed);
                   if ungettemp then
@@ -550,6 +554,7 @@ implementation
                 end
               else if is_longstring(left.resulttype.def) then
                 begin
+                   internalerror(200105261);
                 end
               else
                 begin
@@ -1068,7 +1073,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.13  2001-04-13 01:22:19  peter
+  Revision 1.14  2001-05-27 14:30:56  florian
+    + some widestring stuff added
+
+  Revision 1.13  2001/04/13 01:22:19  peter
     * symtable change to classes
     * range check generation and errors fixed, make cycle DEBUG=1 works
     * memory leaks fixed

compiler/messages.pas

@@ -54,6 +54,7 @@ type
     procedure CreateIdx;
     function  GetPChar(nr:longint):pchar;
     function  Get(nr:longint):string;
+    function  Get4(nr:longint;const s1,s2,s3,s4:string):string;
     function  Get3(nr:longint;const s1,s2,s3:string):string;
     function  Get2(nr:longint;const s1,s2:string):string;
     function  Get1(nr:longint;const s1:string):string;
@@ -405,6 +406,19 @@ begin
 end;
 
 
+function TMessage.Get4(nr:longint;const s1,s2,s3,s4:string):string;
+var
+  s : string;
+begin
+  s:=Get(nr);
+  Replace(s,'$1',s1);
+  Replace(s,'$2',s2);
+  Replace(s,'$3',s3);
+  Replace(s,'$4',s3);
+  Get4:=s;
+end;
+
+
 function TMessage.Get2(nr:longint;const s1,s2:string):string;
 var
   s : string;
@@ -429,7 +443,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.8  2001-04-21 13:32:07  peter
+  Revision 1.9  2001-05-27 14:30:55  florian
+    + some widestring stuff added
+
+  Revision 1.8  2001/04/21 13:32:07  peter
     * remove endless loop with replacements (merged)
 
   Revision 1.7  2001/04/14 16:05:41  jonas

compiler/nadd.pas

@@ -47,7 +47,7 @@ implementation
 
     uses
       globtype,systems,
-      cutils,verbose,globals,
+      cutils,verbose,globals,widestr,
       symconst,symtype,symdef,types,
       cpuinfo,
 {$ifdef newcg}
@@ -86,6 +86,8 @@ implementation
          i       : longint;
          b       : boolean;
          s1,s2   : pchar;
+         ws1,ws2,
+         ws3     : tcompilerwidestring;
          l1,l2   : longint;
          rv,lv   : tconstexprint;
          rvd,lvd : bestreal;
@@ -133,6 +135,18 @@ implementation
             inserttypeconv(left,pbestrealtype^);
           end;
 
+         { if one operand is a widechar or a widestring, both operands    }
+         { are converted to widestring. This must be done before constant }
+         { folding to allow char+widechar etc.                            }
+         if is_widestring(right.resulttype.def) or
+           is_widestring(left.resulttype.def) or
+           is_widechar(right.resulttype.def) or
+           is_widechar(left.resulttype.def) then
+           begin
+              inserttypeconv(right,cwidestringtype);
+              inserttypeconv(left,cwidestringtype);
+           end;
+
          { load easier access variables }
          rd:=right.resulttype.def;
          ld:=left.resulttype.def;
@@ -294,10 +308,53 @@ implementation
               exit;
            end;
 
-       { concating strings ? }
+         { first, we handle widestrings, so we can check later for }
+         { stringconstn only                                       }
+
+         { widechars are converted above to widestrings too }
+         { this isn't veryy efficient, but I don't think    }
+         { that it does matter that much (FK)               }
+         if (lt=stringconstn) and (rt=stringconstn) and
+           (tstringconstnode(left).st_type=st_widestring) and
+           (tstringconstnode(right).st_type=st_widestring) then
+           begin
+              initwidestring(ws1);
+              initwidestring(ws2);
+              copywidestring(pcompilerwidestring(tstringconstnode(left).value_str)^,ws1);
+              copywidestring(pcompilerwidestring(tstringconstnode(right).value_str)^,ws2);
+              case nodetype of
+                 addn :
+                   begin
+                      initwidestring(ws3);
+                      concatwidestrings(ws1,ws2,ws3);
+                      t:=cstringconstnode.createwstr(ws3);
+                      donewidestring(ws3);
+                   end;
+                 ltn :
+                   t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<0),booltype);
+                 lten :
+                   t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<=0),booltype);
+                 gtn :
+                   t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)>0),booltype);
+                 gten :
+                   t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)>=0),booltype);
+                 equaln :
+                   t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)=0),booltype);
+                 unequaln :
+                   t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<>0),booltype);
+              end;
+              donewidestring(ws1);
+              donewidestring(ws2);
+              resulttypepass(t);
+              result:=t;
+              exit;
+           end;
+
+         { concating strings ? }
          concatstrings:=false;
          s1:=nil;
          s2:=nil;
+
          if (lt=ordconstn) and (rt=ordconstn) and
             is_char(ld) and is_char(rd) then
            begin
@@ -1217,7 +1274,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.27  2001-05-19 21:11:50  peter
+  Revision 1.28  2001-05-27 14:30:55  florian
+    + some widestring stuff added
+
+  Revision 1.27  2001/05/19 21:11:50  peter
     * first check for overloaded operator before doing inserting any
       typeconvs
 

compiler/scanner.pas

@@ -44,6 +44,7 @@ interface
 
        pmacrobuffer = ^tmacrobuffer;
        tmacrobuffer = array[0..maxmacrolen-1] of char;
+       tscannerfile = class;
 
        tmacro = class(TNamedIndexItem)
           defined,
@@ -63,6 +64,7 @@ interface
           next    : tpreprocstack;
           name    : stringid;
           line_nb : longint;
+          owner   : tscannerfile;
           constructor Create(atyp:preproctyp;a:boolean;n:tpreprocstack);
        end;
 
@@ -1198,7 +1200,8 @@ implementation
       { check for missing ifdefs }
         while assigned(preprocstack) do
          begin
-           Message3(scan_e_endif_expected,preprocstring[preprocstack.typ],preprocstack.name,tostr(preprocstack.line_nb));
+           Message4(scan_e_endif_expected,preprocstring[preprocstack.typ],preprocstack.name,
+             preprocstack.owner.inputfile.name^,tostr(preprocstack.line_nb));
            poppreprocstack;
          end;
       end;
@@ -1225,6 +1228,7 @@ implementation
         preprocstack:=tpreprocstack.create(atyp,((preprocstack=nil) or preprocstack.accept) and a,preprocstack);
         preprocstack.name:=s;
         preprocstack.line_nb:=line_no;
+        preprocstack.owner:=self;
         if preprocstack.accept then
          Message2(w,preprocstack.name,'accepted')
         else
@@ -2589,7 +2593,10 @@ exit_label:
 end.
 {
   $Log$
-  Revision 1.16  2001-04-13 22:12:34  peter
+  Revision 1.17  2001-05-27 14:30:55  florian
+    + some widestring stuff added
+
+  Revision 1.16  2001/04/13 22:12:34  peter
     * fixed comment after comment parsing in assembler blocks
 
   Revision 1.15  2001/04/13 18:00:36  peter

compiler/temp_gen.pas

@@ -41,6 +41,7 @@ interface
       ttemptype = (tt_none,tt_free,tt_normal,tt_persistant,
                    tt_ansistring,tt_freeansistring,tt_widestring,tt_freewidestring,
                    tt_interfacecom,tt_freeinterfacecom);
+
       ttemptypeset = set of ttemptype;
 
       ptemprecord = ^ttemprecord;
@@ -91,6 +92,9 @@ interface
     function ungetiftempansi(const ref : treference) : boolean;
     procedure gettempansistringreference(var ref : treference);
 
+    function ungetiftempwidestr(const ref : treference) : boolean;
+    procedure gettempwidestringreference(var ref : treference);
+
     function ungetiftempintfcom(const ref : treference) : boolean;
     procedure gettempintfcomreference(var ref : treference);
 
@@ -384,11 +388,21 @@ const
         gettemppointerreferencefortype(ref,tt_ansistring,tt_freeansistring);
       end;
 
+    procedure gettempwidestringreference(var ref : treference);
+      begin
+        gettemppointerreferencefortype(ref,tt_widestring,tt_freewidestring);
+      end;
+
     function ungetiftempansi(const ref : treference) : boolean;
       begin
         ungetiftempansi:=ungettemppointeriftype(ref,tt_ansistring,tt_freeansistring);
       end;
 
+    function ungetiftempwidestr(const ref : treference) : boolean;
+      begin
+        ungetiftempwidestr:=ungettemppointeriftype(ref,tt_widestring,tt_widestring);
+      end;
+
 
     procedure gettempintfcomreference(var ref : treference);
       begin
@@ -591,7 +605,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.13  2001-04-18 22:02:00  peter
+  Revision 1.14  2001-05-27 14:30:55  florian
+    + some widestring stuff added
+
+  Revision 1.13  2001/04/18 22:02:00  peter
     * registration of targets and assemblers
 
   Revision 1.12  2001/04/13 01:22:17  peter

compiler/verbose.pas

@@ -86,10 +86,12 @@ procedure Message(w:longint);
 procedure Message1(w:longint;const s1:string);
 procedure Message2(w:longint;const s1,s2:string);
 procedure Message3(w:longint;const s1,s2,s3:string);
+procedure Message4(w:longint;const s1,s2,s3,s4:string);
 procedure MessagePos(const pos:tfileposinfo;w:longint);
 procedure MessagePos1(const pos:tfileposinfo;w:longint;const s1:string);
 procedure MessagePos2(const pos:tfileposinfo;w:longint;const s1,s2:string);
 procedure MessagePos3(const pos:tfileposinfo;w:longint;const s1,s2,s3:string);
+procedure MessagePos4(const pos:tfileposinfo;w:longint;const s1,s2,s3,s4:string);
 
 procedure InitVerbose;
 procedure DoneVerbose;
@@ -568,6 +570,13 @@ var
       end;
 
 
+    procedure Message4(w:longint;const s1,s2,s3,s4:string);
+      begin
+        MaybeLoadMessageFile;
+        Msg2Comment(msg^.Get4(w,s1,s2,s3,s4));
+      end;
+
+
     procedure MessagePos(const pos:tfileposinfo;w:longint);
       var
         oldpos : tfileposinfo;
@@ -616,6 +625,18 @@ var
       end;
 
 
+    procedure MessagePos4(const pos:tfileposinfo;w:longint;const s1,s2,s3,s4:string);
+      var
+        oldpos : tfileposinfo;
+      begin
+        oldpos:=aktfilepos;
+        aktfilepos:=pos;
+        MaybeLoadMessageFile;
+        Msg2Comment(msg^.Get4(w,s1,s2,s3,s4));
+        aktfilepos:=oldpos;
+      end;
+
+
     procedure InitVerbose;
       begin
       { Init }
@@ -651,7 +672,10 @@ var
 end.
 {
   $Log$
-  Revision 1.13  2001-04-13 01:22:17  peter
+  Revision 1.14  2001-05-27 14:30:55  florian
+    + some widestring stuff added
+
+  Revision 1.13  2001/04/13 01:22:17  peter
     * symtable change to classes
     * range check generation and errors fixed, make cycle DEBUG=1 works
     * memory leaks fixed

compiler/widestr.pas

@@ -51,8 +51,9 @@ unit widestr;
     procedure setlengthwidestring(var r : tcompilerwidestring;l : longint);
     function getlengthwidestring(const r : tcompilerwidestring) : longint;
     procedure concatwidestringchar(var r : tcompilerwidestring;c : tcompilerwidechar);
-    procedure concatwidestringwidestring(const s1,s2 : tcompilerwidestring;
+    procedure concatwidestrings(const s1,s2 : tcompilerwidestring;
       var r : tcompilerwidestring);
+    function comparewidestrings(const s1,s2 : tcompilerwidestring) : shortint;
     procedure copywidestring(const s : tcompilerwidestring;var d : tcompilerwidestring);
     function asciichar2unicode(c : char) : tcompilerwidechar;
     function unicode2asciichar(c : tcompilerwidechar) : char;
@@ -118,14 +119,14 @@ unit widestr;
          inc(r.len);
       end;
 
-    procedure concatwidestringwidestring(const s1,s2 : tcompilerwidestring;
+    procedure concatwidestrings(const s1,s2 : tcompilerwidestring;
       var r : tcompilerwidestring);
 
       begin
          setlengthwidestring(r,s1.len+s2.len);
          r.len:=s1.len+s2.len;
-         move(s1.data^,r.data^,s1.len);
-         move(s2.data^,r.data[s1.len],s2.len);
+         move(s1.data^,r.data^,s1.len*2);
+         move(s2.data^,r.data[s1.len],s2.len*2);
       end;
 
     function comparewidestringwidestring(const s1,s2 : tcompilerwidestring) : longint;
@@ -143,6 +144,13 @@ unit widestr;
          move(s.data^,d.data^,s.len);
       end;
 
+    function comparewidestrings(const s1,s2 : tcompilerwidestring) : shortint;
+
+      begin
+         {!!!!!! FIXME }
+         comparewidestrings:=0;
+      end;
+
     function asciichar2unicode(c : char) : tcompilerwidechar;
 {!!!!!!!!
       var
@@ -196,7 +204,10 @@ unit widestr;
 end.
 {
   $Log$
-  Revision 1.4  2001-05-08 21:06:33  florian
+  Revision 1.5  2001-05-27 14:30:55  florian
+    + some widestring stuff added
+
+  Revision 1.4  2001/05/08 21:06:33  florian
     * some more support for widechars commited especially
       regarding type casting and constants