* various widestring updates, it works now mostly without charset

    mapping supported

compiler/i386/n386add.pas

@@ -165,8 +165,16 @@ interface
                           still used for the push (PFV) }
                         clear_location(location);
                         location.loc:=LOC_MEM;
-                        gettempansistringreference(location.reference);
-                        decrstringref(cansistringtype.def,location.reference);
+                        if (tstringdef(left.resulttype.def).string_typ=st_widestring) then
+                         begin
+                           gettempwidestringreference(location.reference);
+                           decrstringref(cwidestringtype.def,location.reference);
+                         end
+                        else
+                         begin
+                           gettempansistringreference(location.reference);
+                           decrstringref(cansistringtype.def,location.reference);
+                         end;
                         { release used registers }
                         del_location(right.location);
                         del_location(left.location);
@@ -2285,7 +2293,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.15  2001-06-25 14:11:37  jonas
+  Revision 1.16  2001-07-08 21:00:16  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.15  2001/06/25 14:11:37  jonas
     * fixed set bug discovered by Carl (merged)
 
   Revision 1.14  2001/06/18 20:36:25  peter

compiler/i386/n386cal.pas

@@ -1271,8 +1271,16 @@ implementation
                 begin
                    hregister:=getexplicitregister32(R_EAX);
                    emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
-                   gettempansistringreference(hr);
-                   decrstringref(resulttype.def,hr);
+                   if tstringdef(resulttype.def).string_typ=st_widestring then
+                    begin
+                      gettempwidestringreference(hr);
+                      decrstringref(resulttype.def,hr);
+                    end
+                   else
+                    begin
+                      gettempansistringreference(hr);
+                      decrstringref(resulttype.def,hr);
+                    end;
                    emit_reg_ref(A_MOV,S_L,hregister,
                      newreference(hr));
                    ungetregister32(hregister);
@@ -1576,7 +1584,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.26  2001-07-01 20:16:20  peter
+  Revision 1.27  2001-07-08 21:00:16  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.26  2001/07/01 20:16:20  peter
     * alignmentinfo record added
     * -Oa argument supports more alignment settings that can be specified
       per type: PROC,LOOP,VARMIN,VARMAX,CONSTMIN,CONSTMAX,RECORDMIN

compiler/i386/n386cnv.pas

@@ -217,59 +217,79 @@ implementation
                    begin
                       gettempofsizereference(resulttype.def.size,location.reference);
                       copyshortstring(location.reference,left.location.reference,
-                        tstringdef(resulttype.def).len,false,true);
-{                      done by copyshortstring now (JM)          }
-{                      del_reference(left.location.reference); }
+                                      tstringdef(resulttype.def).len,false,true);
                       ungetiftemp(left.location.reference);
                    end;
-                 st_longstring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
                  st_ansistring:
                    begin
                       gettempofsizereference(resulttype.def.size,location.reference);
                       loadansi2short(left,self);
-                      { this is done in secondtypeconv (FK)
-                      removetemps(exprasmlist,temptoremove);
-                      destroys:=true;
-                      }
                    end;
                  st_widestring:
+                   begin
+                      gettempofsizereference(resulttype.def.size,location.reference);
+                      loadwide2short(left,self);
+                   end;
+                 st_longstring:
                    begin
                       {!!!!!!!}
                       internalerror(8888);
                    end;
               end;
 
-            st_longstring:
+            st_ansistring:
               case tstringdef(left.resulttype.def).string_typ of
                  st_shortstring:
                    begin
-                      {!!!!!!!}
-                      internalerror(8888);
+                      clear_location(location);
+                      location.loc:=LOC_REFERENCE;
+                      gettempansistringreference(location.reference);
+                      decrstringref(cansistringtype.def,location.reference);
+                      { We don't need the source regs anymore (JM) }
+                      regs_to_push := $ff;
+                      remove_non_regvars_from_loc(left.location,regs_to_push);
+                      pushusedregisters(pushed,regs_to_push);
+                      release_loc(left.location);
+                      emit_push_lea_loc(left.location,true);
+                      emit_push_lea_loc(location,false);
+                      saveregvars(regs_to_push);
+                      emitcall('FPC_SHORTSTR_TO_ANSISTR');
+                      maybe_loadself;
+                      popusedregisters(pushed);
                    end;
-                 st_ansistring:
+                 st_widestring:
                    begin
-                      {!!!!!!!}
-                      internalerror(8888);
+                      clear_location(location);
+                      location.loc:=LOC_REFERENCE;
+                      gettempansistringreference(location.reference);
+                      decrstringref(cansistringtype.def,location.reference);
+                      { We don't need the source regs anymore (JM) }
+                      regs_to_push := $ff;
+                      remove_non_regvars_from_loc(left.location,regs_to_push);
+                      pushusedregisters(pushed,regs_to_push);
+                      release_loc(left.location);
+                      emit_push_loc(left.location);
+                      emit_push_lea_loc(location,false);
+                      saveregvars(regs_to_push);
+                      emitcall('FPC_WIDESTR_TO_ANSISTR');
+                      maybe_loadself;
+                      popusedregisters(pushed);
                    end;
-                 st_widestring:
+                 st_longstring:
                    begin
                       {!!!!!!!}
                       internalerror(8888);
                    end;
               end;
 
-            st_ansistring:
+            st_widestring:
               case tstringdef(left.resulttype.def).string_typ of
                  st_shortstring:
                    begin
                       clear_location(location);
                       location.loc:=LOC_REFERENCE;
-                      gettempansistringreference(location.reference);
-                      decrstringref(cansistringtype.def,location.reference);
+                      gettempwidestringreference(location.reference);
+                      decrstringref(cwidestringtype.def,location.reference);
                       { We don't need the source regs anymore (JM) }
                       regs_to_push := $ff;
                       remove_non_regvars_from_loc(left.location,regs_to_push);
@@ -278,34 +298,42 @@ implementation
                       emit_push_lea_loc(left.location,true);
                       emit_push_lea_loc(location,false);
                       saveregvars(regs_to_push);
-                      emitcall('FPC_SHORTSTR_TO_ANSISTR');
+                      emitcall('FPC_SHORTSTR_TO_WIDESTR');
                       maybe_loadself;
                       popusedregisters(pushed);
                    end;
-                 st_longstring:
+                 st_ansistring:
                    begin
-                      {!!!!!!!}
-                      internalerror(8888);
+                      clear_location(location);
+                      location.loc:=LOC_REFERENCE;
+                      gettempwidestringreference(location.reference);
+                      decrstringref(cwidestringtype.def,location.reference);
+                      { We don't need the source regs anymore (JM) }
+                      regs_to_push := $ff;
+                      remove_non_regvars_from_loc(left.location,regs_to_push);
+                      pushusedregisters(pushed,regs_to_push);
+                      release_loc(left.location);
+                      emit_push_loc(left.location);
+                      emit_push_lea_loc(location,false);
+                      saveregvars(regs_to_push);
+                      emitcall('FPC_ANSISTR_TO_WIDESTR');
+                      maybe_loadself;
+                      popusedregisters(pushed);
                    end;
-                 st_widestring:
+                 st_longstring:
                    begin
                       {!!!!!!!}
                       internalerror(8888);
                    end;
               end;
 
-            st_widestring:
+            st_longstring:
               case tstringdef(left.resulttype.def).string_typ of
                  st_shortstring:
                    begin
                       {!!!!!!!}
                       internalerror(8888);
                    end;
-                 st_longstring:
-                   begin
-                      {!!!!!!!}
-                      internalerror(8888);
-                   end;
                  st_ansistring:
                    begin
                       {!!!!!!!}
@@ -356,8 +384,17 @@ implementation
              end;
            st_widestring:
              begin
-               {!!!!!!!}
-               internalerror(8888);
+               if (left.nodetype=stringconstn) and
+                  (str_length(left)=0) then
+                begin
+                  new(hr);
+                  reset_reference(hr^);
+                  hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR');
+                  emit_ref_reg(A_LEA,S_L,hr,location.register);
+                end
+               else
+                emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
+                  location.register);
              end;
          end;
       end;
@@ -542,12 +579,23 @@ implementation
                popusedregisters(pushed);
                maybe_loadself;
              end;
-           st_longstring:
+           st_widestring :
              begin
-               {!!!!!!!}
-               internalerror(8888);
+               gettempwidestringreference(location.reference);
+               decrstringref(cwidestringtype.def,location.reference);
+               regstopush := $ff;
+               remove_non_regvars_from_loc(left.location,regstopush);
+               pushusedregisters(pushed,regstopush);
+               push_int(l);
+               emitpushreferenceaddr(left.location.reference);
+               release_loc(left.location);
+               emitpushreferenceaddr(location.reference);
+               saveregvars(regstopush);
+               emitcall('FPC_CHARARRAY_TO_WIDESTR');
+               popusedregisters(pushed);
+               maybe_loadself;
              end;
-           st_widestring:
+           st_longstring:
              begin
                {!!!!!!!}
                internalerror(8888);
@@ -582,6 +630,19 @@ implementation
                popusedregisters(pushed);
                maybe_loadself;
              end;
+           st_widestring :
+             begin
+               gettempwidestringreference(location.reference);
+               decrstringref(cwidestringtype.def,location.reference);
+               release_loc(left.location);
+               pushusedregisters(pushed,$ff);
+               emit_pushw_loc(left.location);
+               emitpushreferenceaddr(location.reference);
+               saveregvars($ff);
+               emitcall('FPC_CHAR_TO_WIDESTR');
+               popusedregisters(pushed);
+               maybe_loadself;
+             end;
            else
             internalerror(4179);
         end;
@@ -1039,6 +1100,37 @@ implementation
                 maybe_loadself;
                 popusedregisters(pushed);
              end;
+           st_widestring:
+             begin
+                location.loc:=LOC_REFERENCE;
+                gettempwidestringreference(location.reference);
+                decrstringref(cwidestringtype.def,location.reference);
+                { Find out which regs have to be pushed (JM) }
+                regs_to_push := $ff;
+                remove_non_regvars_from_loc(left.location,regs_to_push);
+                pushusedregisters(pushed,regs_to_push);
+                case left.location.loc of
+                  LOC_REFERENCE,LOC_MEM:
+                    begin
+                      { Now release the registers (see cgai386.pas:     }
+                      { loadansistring for more info on the order) (JM) }
+                      del_reference(left.location.reference);
+                      emit_push_mem(left.location.reference);
+                    end;
+                  LOC_REGISTER,LOC_CREGISTER:
+                    begin
+                       { Now release the registers (see cgai386.pas:     }
+                       { loadansistring for more info on the order) (JM) }
+                      emit_reg(A_PUSH,S_L,left.location.register);
+                      ungetregister32(left.location.register);
+                   end;
+                end;
+                emitpushreferenceaddr(location.reference);
+                saveregvars(regs_to_push);
+                emitcall('FPC_PCHAR_TO_WIDESTR');
+                maybe_loadself;
+                popusedregisters(pushed);
+             end;
          else
           begin
             internalerror(12121);
@@ -1083,19 +1175,10 @@ implementation
 
 
     procedure ti386typeconvnode.second_char_to_char;
-      var
-         hreg : tregister;
       begin
-         case torddef(resulttype.def).typ of
-            uwidechar:
-              begin
-                 internalerror(200105021);
-              end;
-            uchar:
-              begin
-                 internalerror(200105022);
-              end;
-         end;
+        {$warning todo: add RTL routine for widechar-char conversion }
+        { Quick hack to atleast generate 'working' code (PFV) }
+        second_int_to_int;
       end;
 
 
@@ -1331,7 +1414,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.15  2001-05-08 21:06:33  florian
+  Revision 1.16  2001-07-08 21:00:17  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.15  2001/05/08 21:06:33  florian
     * some more support for widechars commited especially
       regarding type casting and constants
 

compiler/i386/n386con.pas

@@ -342,14 +342,13 @@ implementation
 
                                 { we use always UTF-16 coding for constants }
                                 { at least for now                          }
-                                Consts.concat(Tai_const.Create_8bit(2));
+                                { Consts.concat(Tai_const.Create_8bit(2)); }
                                 Consts.concat(Tai_const.Create_32bit(len));
                                 Consts.concat(Tai_const.Create_32bit(len));
                                 Consts.concat(Tai_const.Create_32bit(-1));
                                 Consts.concat(Tai_label.Create(l1));
                                 for i:=0 to len-1 do
-                                  Consts.concat(Tai_const.Create_16bit(
-                                    pcompilerwidestring(value_str)^.data[i]));
+                                  Consts.concat(Tai_const.Create_16bit(pcompilerwidestring(value_str)^.data[i]));
                                 { return the offset of the real string }
                                 lab_str:=l2;
                              end;
@@ -500,7 +499,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.8  2001-04-13 01:22:18  peter
+  Revision 1.9  2001-07-08 21:00:18  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.8  2001/04/13 01:22:18  peter
     * symtable change to classes
     * range check generation and errors fixed, make cycle DEBUG=1 works
     * memory leaks fixed

compiler/i386/n386inl.pas

@@ -468,6 +468,8 @@ implementation
                                     emitcall(rdwrprefix[doread]+'UINT');
                                   uchar :
                                     emitcall(rdwrprefix[doread]+'CHAR');
+                                  uwidechar :
+                                    emitcall(rdwrprefix[doread]+'WIDECHAR');
                                   s64bit :
                                     emitcall(rdwrprefix[doread]+'INT64');
                                   u64bit :
@@ -1678,7 +1680,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.14  2001-04-13 01:22:19  peter
+  Revision 1.15  2001-07-08 21:00:18  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.14  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/i386/n386mem.pas

@@ -525,8 +525,8 @@ implementation
                 begin
                    { in widestrings S[1] is pwchar(S)[0] !! }
                    dec(location.reference.offset,2);
-                   emit_const_reg(A_SHL,S_L,
-                     1,location.reference.base);
+//                   emit_const_reg(A_SHL,S_L,
+//                     1,location.reference.base);
                 end;
 
               { we've also to keep left up-to-date, because it is used   }
@@ -1055,7 +1055,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.13  2001-04-18 22:02:03  peter
+  Revision 1.14  2001-07-08 21:00:18  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.13  2001/04/18 22:02:03  peter
     * registration of targets and assemblers
 
   Revision 1.12  2001/04/13 01:22:19  peter

compiler/i386/n386util.pas

@@ -43,6 +43,7 @@ interface
     procedure loadshortstring(source,dest : tnode);
     procedure loadlongstring(p:tbinarynode);
     procedure loadansi2short(source,dest : tnode);
+    procedure loadwide2short(source,dest : tnode);
     procedure loadinterfacecom(p: tbinarynode);
 
     procedure maketojumpbool(p : tnode);
@@ -1420,6 +1421,42 @@ implementation
          maybe_loadself;
       end;
 
+
+    procedure loadwide2short(source,dest : tnode);
+      var
+         pushed : tpushed;
+         regs_to_push: byte;
+      begin
+         { Find out which registers have to be pushed (JM) }
+         regs_to_push := $ff;
+         remove_non_regvars_from_loc(source.location,regs_to_push);
+         { Push them (JM) }
+         pushusedregisters(pushed,regs_to_push);
+         case source.location.loc of
+           LOC_REFERENCE,LOC_MEM:
+             begin
+                { Now release the location and registers (see cgai386.pas: }
+                { loadansistring for more info on the order) (JM)          }
+                ungetiftemp(source.location.reference);
+                del_reference(source.location.reference);
+                emit_push_mem(source.location.reference);
+             end;
+           LOC_REGISTER,LOC_CREGISTER:
+             begin
+                emit_reg(A_PUSH,S_L,source.location.register);
+                { Now release the register (JM) }
+                ungetregister32(source.location.register);
+             end;
+         end;
+         push_shortstring_length(dest);
+         emitpushreferenceaddr(dest.location.reference);
+         saveregvars($ff);
+         emitcall('FPC_WIDESTR_TO_SHORTSTR');
+         popusedregisters(pushed);
+         maybe_loadself;
+      end;
+
+
     procedure loadinterfacecom(p: tbinarynode);
     {
       copies an com interface from n.right to n.left, we
@@ -1472,7 +1509,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.17  2001-07-01 20:16:20  peter
+  Revision 1.18  2001-07-08 21:00:18  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.17  2001/07/01 20:16:20  peter
     * alignmentinfo record added
     * -Oa argument supports more alignment settings that can be specified
       per type: PROC,LOOP,VARMIN,VARMAX,CONSTMIN,CONSTMAX,RECORDMIN

compiler/nadd.pas

@@ -86,8 +86,7 @@ implementation
          i       : longint;
          b       : boolean;
          s1,s2   : pchar;
-         ws1,ws2,
-         ws3     : tcompilerwidestring;
+         ws1,ws2 : pcompilerwidestring;
          l1,l2   : longint;
          rv,lv   : tconstexprint;
          rvd,lvd : bestreal;
@@ -345,15 +344,13 @@ implementation
            begin
               initwidestring(ws1);
               initwidestring(ws2);
-              copywidestring(pcompilerwidestring(tstringconstnode(left).value_str)^,ws1);
-              copywidestring(pcompilerwidestring(tstringconstnode(right).value_str)^,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);
+                      concatwidestrings(ws1,ws2);
+                      t:=cstringconstnode.createwstr(ws1);
                    end;
                  ltn :
                    t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<0),booltype);
@@ -708,16 +705,10 @@ implementation
            end
 
          { if both are floatdefs, conversion is already done before constant folding }
-           else if (ld.deftype=floatdef) then
-            begin
-              { already converted }
-            end
-
-         else if (right.resulttype.def.deftype=floatdef) or (left.resulttype.def.deftype=floatdef) then
-          begin
-            inserttypeconv(right,pbestrealtype^);
-            inserttypeconv(left,pbestrealtype^);
-          end
+         else if (ld.deftype=floatdef) then
+           begin
+             { already converted }
+           end
 
          { left side a setdef, must be before string processing,
            else array constructor can be seen as array of char (PFV) }
@@ -1296,7 +1287,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.30  2001-06-04 21:41:26  peter
+  Revision 1.31  2001-07-08 21:00:14  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.30  2001/06/04 21:41:26  peter
     * readded generic conversion to s32bit that i removed yesterday. It
       is still used for error recovery, added a small note about that
 

compiler/ncnv.pas

@@ -47,6 +47,7 @@ interface
           function resulttype_int_to_real : tnode;
           function resulttype_real_to_real : tnode;
           function resulttype_cchar_to_pchar : tnode;
+          function resulttype_cstring_to_pchar : tnode;
           function resulttype_char_to_char : tnode;
           function resulttype_arrayconstructor_to_set : tnode;
           function resulttype_call_helper(c : tconverttype) : tnode;
@@ -425,10 +426,33 @@ implementation
 
 
     function ttypeconvnode.resulttype_string_to_string : tnode;
+      var
+        pw : pcompilerwidestring;
+        pc : pchar;
       begin
          result:=nil;
          if left.nodetype=stringconstn then
           begin
+             { convert ascii 2 unicode }
+             if (tstringdef(resulttype.def).string_typ=st_widestring) and
+                (tstringconstnode(left).st_type in [st_ansistring,st_shortstring,st_longstring]) then
+              begin
+                initwidestring(pw);
+                ascii2unicode(tstringconstnode(left).value_str,tstringconstnode(left).len,pw);
+                ansistringdispose(tstringconstnode(left).value_str,tstringconstnode(left).len);
+                pcompilerwidestring(tstringconstnode(left).value_str):=pw;
+              end
+             else
+             { convert unicode 2 ascii }
+             if (tstringconstnode(left).st_type=st_widestring) and
+                (tstringdef(resulttype.def).string_typ in [st_ansistring,st_shortstring,st_longstring]) then
+              begin
+                pw:=pcompilerwidestring(tstringconstnode(left).value_str);
+                getmem(pc,getlengthwidestring(pw)+1);
+                unicode2ascii(pw,pc);
+                donewidestring(pw);
+                tstringconstnode(left).value_str:=pc;
+              end;
              tstringconstnode(left).st_type:=tstringdef(resulttype.def).string_typ;
              tstringconstnode(left).resulttype:=resulttype;
              result:=left;
@@ -440,12 +464,20 @@ implementation
     function ttypeconvnode.resulttype_char_to_string : tnode;
       var
          hp : tstringconstnode;
+         ws : pcompilerwidestring;
       begin
          result:=nil;
          if left.nodetype=ordconstn then
            begin
-              hp:=cstringconstnode.createstr(chr(tordconstnode(left).value),st_default);
-              hp.st_type:=tstringdef(resulttype.def).string_typ;
+              if tstringdef(resulttype.def).string_typ=st_widestring then
+               begin
+                 initwidestring(ws);
+                 concatwidestringchar(ws,tcompilerwidechar(chr(tordconstnode(left).value)));
+                 hp:=cstringconstnode.createwstr(ws);
+                 donewidestring(ws);
+               end
+              else
+               hp:=cstringconstnode.createstr(chr(tordconstnode(left).value),tstringdef(resulttype.def).string_typ);
               resulttypepass(hp);
               result:=hp;
            end;
@@ -457,24 +489,28 @@ implementation
          hp : tordconstnode;
       begin
          result:=nil;
-         if (torddef(resulttype.def).typ=uchar) and
-           (torddef(left.resulttype.def).typ=uwidechar) then
-           begin
-              hp:=cordconstnode.create(
-                ord(unicode2asciichar(tcompilerwidechar(tordconstnode(left).value))),cchartype);
-              resulttypepass(hp);
-              result:=hp;
-           end
-         else if (torddef(resulttype.def).typ=uwidechar) and
-           (torddef(left.resulttype.def).typ=uchar) then
+         if left.nodetype=ordconstn then
            begin
-              hp:=cordconstnode.create(
-                asciichar2unicode(chr(tordconstnode(left).value)),cwidechartype);
-              resulttypepass(hp);
-              result:=hp;
-           end
-         else
-           internalerror(200105131);
+             if (torddef(resulttype.def).typ=uchar) and
+                (torddef(left.resulttype.def).typ=uwidechar) then
+              begin
+                hp:=cordconstnode.create(
+                      ord(unicode2asciichar(tcompilerwidechar(tordconstnode(left).value))),cchartype);
+                resulttypepass(hp);
+                result:=hp;
+              end
+             else if (torddef(resulttype.def).typ=uwidechar) and
+                     (torddef(left.resulttype.def).typ=uchar) then
+              begin
+                hp:=cordconstnode.create(
+                      asciichar2unicode(chr(tordconstnode(left).value)),cwidechartype);
+                resulttypepass(hp);
+                result:=hp;
+              end
+             else
+              internalerror(200105131);
+             exit;
+           end;
       end;
 
 
@@ -510,13 +546,25 @@ implementation
     function ttypeconvnode.resulttype_cchar_to_pchar : tnode;
       begin
          result:=nil;
-         inserttypeconv(left,cshortstringtype);
+         if is_pwidechar(resulttype.def) then
+          inserttypeconv(left,cwidestringtype)
+         else
+          inserttypeconv(left,cshortstringtype);
          { evaluate again, reset resulttype so the convert_typ
-           will be calculated again }
+           will be calculated again and cstring_to_pchar will
+           be used for futher conversion }
          result:=det_resulttype;
       end;
 
 
+    function ttypeconvnode.resulttype_cstring_to_pchar : tnode;
+      begin
+         result:=nil;
+         if is_pwidechar(resulttype.def) then
+           inserttypeconv(left,cwidestringtype);
+      end;
+
+
     function ttypeconvnode.resulttype_arrayconstructor_to_set : tnode;
       var
         hp : tnode;
@@ -545,7 +593,7 @@ implementation
           { char_2_string } @ttypeconvnode.resulttype_char_to_string,
           { pchar_2_string } nil,
           { cchar_2_pchar } @ttypeconvnode.resulttype_cchar_to_pchar,
-          { cstring_2_pchar } nil,
+          { cstring_2_pchar } @ttypeconvnode.resulttype_cstring_to_pchar,
           { ansistring_2_pchar } nil,
           { string_2_chararray } nil,
           { chararray_2_string } nil,
@@ -1367,7 +1415,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.28  2001-05-13 15:43:46  florian
+  Revision 1.29  2001-07-08 21:00:15  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.28  2001/05/13 15:43:46  florian
     * made resultype_char_to_char a little bit robuster
 
   Revision 1.27  2001/05/08 21:06:30  florian
@@ -1375,9 +1427,9 @@ end.
       regarding type casting and constants
 
   Revision 1.26  2001/05/04 15:52:03  florian
-    * some Delphi incompatibilities fixed:
-       - out, dispose and new can be used as idenfiers now
-       - const p = apointerype(nil); is supported now
+    * some Delphi incompatibilities fixed:
+       - out, dispose and new can be used as idenfiers now
+       - const p = apointerype(nil); is supported now
     + support for const p = apointertype(pointer(1234)); added
 
   Revision 1.25  2001/04/13 22:20:58  peter

compiler/ncon.pas

@@ -71,7 +71,7 @@ interface
           st_type : tstringtype;
           constructor createstr(const s : string;st:tstringtype);virtual;
           constructor createpchar(s : pchar;l : longint);virtual;
-          constructor createwstr(const w : tcompilerwidestring);virtual;
+          constructor createwstr(w : pcompilerwidestring);virtual;
           destructor destroy;override;
           function getcopy : tnode;override;
           function pass_1 : tnode;override;
@@ -454,14 +454,13 @@ implementation
           st_type:=st;
       end;
 
-    constructor tstringconstnode.createwstr(const w : tcompilerwidestring);
+    constructor tstringconstnode.createwstr(w : pcompilerwidestring);
 
       begin
          inherited create(stringconstn);
          len:=getlengthwidestring(w);
-         new(pcompilerwidestring(value_str));
-         initwidestring(pcompilerwidestring(value_str)^);
-         copywidestring(w,pcompilerwidestring(value_str)^);
+         initwidestring(pcompilerwidestring(value_str));
+         copywidestring(w,pcompilerwidestring(value_str));
          lab_str:=nil;
          st_type:=st_widestring;
       end;
@@ -482,7 +481,10 @@ implementation
 
     destructor tstringconstnode.destroy;
       begin
-        ansistringdispose(value_str,len);
+        if st_type=st_widestring then
+         donewidestring(pcompilerwidestring(value_str))
+        else
+         ansistringdispose(value_str,len);
         inherited destroy;
       end;
 
@@ -497,7 +499,10 @@ implementation
          n.len:=len;
          n.lab_str:=lab_str;
          if st_type=st_widestring then
-           copywidestring(pcompilerwidestring(value_str)^,pcompilerwidestring(n.value_str)^)
+           begin
+             initwidestring(pcompilerwidestring(n.value_str));
+             copywidestring(pcompilerwidestring(value_str),pcompilerwidestring(n.value_str));
+           end
          else
            n.value_str:=getpcharcopy;
          getcopy:=n;
@@ -652,7 +657,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.18  2001-05-08 21:06:30  florian
+  Revision 1.19  2001-07-08 21:00:15  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.18  2001/05/08 21:06:30  florian
     * some more support for widechars commited especially
       regarding type casting and constants
 

compiler/ninl.pas

@@ -569,12 +569,10 @@ implementation
                        goto myexit;
                     end;
 
-                  if is_ansistring(left.resulttype.def) or
-                      is_widestring(left.resulttype.def) or
-                      is_dynamic_array(left.resulttype.def) then
-                     resulttype:=s32bittype
+                  if is_shortstring(left.resulttype.def) then
+                     resulttype:=u8bittype
                    else
-                     resulttype:=u8bittype;
+                     resulttype:=s32bittype;
 
                    { check the type, must be string or char }
                    if (left.resulttype.def.deftype<>stringdef) and
@@ -826,7 +824,7 @@ implementation
                                    orddef :
                                      begin
                                        case torddef(tcallparanode(hp).left.resulttype.def).typ of
-                                         uchar,
+                                         uchar,uwidechar,
                                          u32bit,s32bit,
                                          u64bit,s64bit:
                                            ;
@@ -1750,7 +1748,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.42  2001-06-04 11:48:01  peter
+  Revision 1.43  2001-07-08 21:00:15  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.42  2001/06/04 11:48:01  peter
     * better const to var checking
 
   Revision 1.41  2001/06/03 20:12:53  peter

compiler/options.pas

@@ -1269,10 +1269,8 @@ begin
 {$endif}
 
 { Temporary defines, until things settle down }
-{$ifdef SUPPORT_FIXED}
-  def_symbol('HASFIXED');
-{$endif SUPPORT_FIXED}
   def_symbol('HASWIDECHAR');
+  def_symbol('HASWIDESTRING');
   def_symbol('HASOUT');
   def_symbol('HASINTF');
   def_symbol('HASVARIANT');
@@ -1564,7 +1562,11 @@ finalization
 end.
 {
   $Log$
-  Revision 1.47  2001-07-01 20:16:16  peter
+  Revision 1.48  2001-07-08 21:00:15  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.47  2001/07/01 20:16:16  peter
     * alignmentinfo record added
     * -Oa argument supports more alignment settings that can be specified
       per type: PROC,LOOP,VARMIN,VARMAX,CONSTMIN,CONSTMAX,RECORDMIN

compiler/ptconst.pas

@@ -42,7 +42,7 @@ implementation
        strings,
 {$endif Delphi}
        globtype,systems,tokens,cpuinfo,
-       cutils,globals,scanner,
+       cutils,globals,widestr,scanner,
        symconst,symbase,symdef,aasm,types,verbose,
        { pass 1 }
        node,pass_1,
@@ -422,6 +422,9 @@ implementation
               { load strval and strlength of the constant tree }
               if p.nodetype=stringconstn then
                 begin
+                  { convert to the expected string type so that
+                    for widestrings strval is a pcompilerwidestring }
+                  inserttypeconv(p,t);
                   strlength:=tstringconstnode(p).len;
                   strval:=tstringconstnode(p).value_str;
                 end
@@ -468,20 +471,6 @@ implementation
                           curconstSegment.concat(Tai_string.Create_length_pchar(ca,t.def.size-strlength-1));
                         end;
                      end;
-{$ifdef UseLongString}
-                   st_longstring:
-                     begin
-                       { first write the maximum size }
-                       curconstSegment.concat(Tai_const.Create_32bit(strlength))));
-                       { fill byte }
-                       curconstSegment.concat(Tai_const.Create_8bit(0));
-                       getmem(ca,strlength+1);
-                       move(strval^,ca^,strlength);
-                       ca[strlength]:=#0;
-                       generate_pascii(consts,ca,strlength);
-                       curconstSegment.concat(Tai_const.Create_8bit(0));
-                     end;
-{$endif UseLongString}
                    st_ansistring:
                      begin
                         { an empty ansi string is nil! }
@@ -509,6 +498,34 @@ implementation
                             Consts.concat(Tai_string.Create_length_pchar(ca,strlength+1));
                           end;
                      end;
+                   st_widestring:
+                     begin
+                        { an empty ansi string is nil! }
+                        if (strlength=0) then
+                          curconstSegment.concat(Tai_const.Create_32bit(0))
+                        else
+                          begin
+                            getdatalabel(ll);
+                            curconstSegment.concat(Tai_const_symbol.Create(ll));
+                            Consts.concat(Tai_const.Create_32bit(strlength));
+                            Consts.concat(Tai_const.Create_32bit(strlength));
+                            Consts.concat(Tai_const.Create_32bit(-1));
+                            Consts.concat(Tai_label.Create(ll));
+                            for i:=0 to strlength-1 do
+                              Consts.concat(Tai_const.Create_16bit(pcompilerwidestring(strval)^.data[i]));
+                          end;
+                     end;
+                   st_longstring:
+                     begin
+                       internalerror(200107081);
+                       {curconstSegment.concat(Tai_const.Create_32bit(strlength))));
+                       curconstSegment.concat(Tai_const.Create_8bit(0));
+                       getmem(ca,strlength+1);
+                       move(strval^,ca^,strlength);
+                       ca[strlength]:=#0;
+                       generate_pascii(consts,ca,strlength);
+                       curconstSegment.concat(Tai_const.Create_8bit(0));}
+                     end;
                  end;
                end;
               p.free;
@@ -868,7 +885,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.26  2001-06-29 14:16:57  jonas
+  Revision 1.27  2001-07-08 21:00:15  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.26  2001/06/29 14:16:57  jonas
     * fixed inconsistent handling of procvars in FPC mode (sometimes @ was
       required to assign the address of a procedure to a procvar, sometimes
       not. Now it is always required) (merged)

compiler/scanner.pas

@@ -167,7 +167,7 @@ interface
         c              : char;
         orgpattern,
         pattern        : string;
-        patternw       : tcompilerwidestring;
+        patternw       : pcompilerwidestring;
 
         { token }
         token,                        { current token being parsed }
@@ -2274,9 +2274,8 @@ implementation
                            begin
                               if (m>=0) and (m<=65535) then
                                 begin
-                                   ascii2unicode(pattern,patternw);
-                                   concatwidestringchar(patternw,
-                                     tcompilerwidechar(m));
+                                   ascii2unicode(@pattern[1],length(pattern),patternw);
+                                   concatwidestringchar(patternw,tcompilerwidechar(m));
                                    iswidestring:=true;
                                 end
                               else
@@ -2304,8 +2303,7 @@ implementation
                                end;
                            end;
                            if iswidestring then
-                             concatwidestringchar(patternw,
-                               asciichar2unicode(c))
+                             concatwidestringchar(patternw,asciichar2unicode(c))
                            else
                              pattern:=pattern+c;
                          until false;
@@ -2320,8 +2318,7 @@ implementation
                           c:=chr(ord(c)-64);
 
                          if iswidestring then
-                           concatwidestringchar(patternw,
-                             asciichar2unicode(c))
+                           concatwidestringchar(patternw,asciichar2unicode(c))
                          else
                            pattern:=pattern+c;
 
@@ -2568,6 +2565,7 @@ exit_label:
 
     procedure InitScanner;
       begin
+        InitWideString(patternw);
         scannerdirectives:=TDictionary.Create;
         { Default directives }
         AddDirective('DEFINE',{$ifdef FPCPROCVAR}@{$endif}dir_define);
@@ -2587,13 +2585,18 @@ exit_label:
     procedure DoneScanner;
       begin
         scannerdirectives.Free;
+        DoneWideString(patternw);
       end;
 
 
 end.
 {
   $Log$
-  Revision 1.18  2001-06-03 21:57:38  peter
+  Revision 1.19  2001-07-08 21:00:16  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.18  2001/06/03 21:57:38  peter
     + hint directive parsing support
 
   Revision 1.17  2001/05/27 14:30:55  florian

compiler/temp_gen.pas

@@ -125,6 +125,12 @@ interface
                        ':'+tostr(templist^.posinfo.column)+
                        ' at pos '+tostr(templist^.pos)+
                      ' not freed at the end of the procedure');
+             tt_widestring :
+               Comment(V_Warning,'temporary WIDE assignment of size '+
+                       tostr(templist^.size)+' from pos '+tostr(templist^.posinfo.line)+
+                       ':'+tostr(templist^.posinfo.column)+
+                       ' at pos '+tostr(templist^.pos)+
+                     ' not freed at the end of the procedure');
            end;
 {$endif}
            hp:=templist;
@@ -409,7 +415,7 @@ const
 
     function ungetiftempwidestr(const ref : treference) : boolean;
       begin
-        ungetiftempwidestr:=ungettemppointeriftype(ref,tt_widestring,tt_widestring);
+        ungetiftempwidestr:=ungettemppointeriftype(ref,tt_widestring,tt_freewidestring);
       end;
 
 
@@ -588,7 +594,9 @@ const
          if istemp(ref) then
            begin
               { first check if ansistring }
-              if ungetiftempansi(ref) then
+              if ungetiftempansi(ref) or
+                 ungetiftempwidestr(ref) or
+                 ungetiftempintfcom(ref) then
                 exit;
 {$ifndef EXTDEBUG}
               ungettemp(ref.offset,tt_normal);
@@ -614,7 +622,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.16  2001-07-01 20:16:18  peter
+  Revision 1.17  2001-07-08 21:00:16  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.16  2001/07/01 20:16:18  peter
     * alignmentinfo record added
     * -Oa argument supports more alignment settings that can be specified
       per type: PROC,LOOP,VARMIN,VARMAX,CONSTMIN,CONSTMAX,RECORDMIN

compiler/types.pas

@@ -1309,7 +1309,8 @@ implementation
                  orddef :
                    begin
                    { char to string}
-                     if is_char(def_from) then
+                     if is_char(def_from) or
+                        is_widechar(def_from) then
                       begin
                         doconv:=tc_char_2_string;
                         b:=1;
@@ -1474,7 +1475,7 @@ implementation
                      { string constant (which can be part of array constructor)
                        to zero terminated string constant }
                      if (fromtreetype in [arrayconstructorn,stringconstn]) and
-                        is_pchar(def_to) then
+                        is_pchar(def_to) or is_pwidechar(def_to) then
                       begin
                         doconv:=tc_cstring_2_pchar;
                         b:=1;
@@ -1746,7 +1747,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.43  2001-06-29 14:16:57  jonas
+  Revision 1.44  2001-07-08 21:00:16  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.43  2001/06/29 14:16:57  jonas
     * fixed inconsistent handling of procvars in FPC mode (sometimes @ was
       required to assign the address of a procedure to a procvar, sometimes
       not. Now it is always required) (merged)

compiler/widestr.pas

@@ -40,25 +40,25 @@ unit widestr;
        pcompilerwidechar = ^tcompilerwidechar;
 {$endif}
 
-       pcompilerwidestring = ^tcompilerwidestring;
-       tcompilerwidestring = record
+       pcompilerwidestring = ^_tcompilerwidestring;
+       _tcompilerwidestring = record
           data : pcompilerwidechar;
           maxlen,len : longint;
        end;
 
-    procedure initwidestring(var r : tcompilerwidestring);
-    procedure donewidestring(var r : tcompilerwidestring);
-    procedure setlengthwidestring(var r : tcompilerwidestring;l : longint);
-    function getlengthwidestring(const r : tcompilerwidestring) : longint;
-    procedure concatwidestringchar(var r : tcompilerwidestring;c : tcompilerwidechar);
-    procedure concatwidestrings(const s1,s2 : tcompilerwidestring;
-      var r : tcompilerwidestring);
-    function comparewidestrings(const s1,s2 : tcompilerwidestring) : shortint;
-    procedure copywidestring(const s : tcompilerwidestring;var d : tcompilerwidestring);
+    procedure initwidestring(var r : pcompilerwidestring);
+    procedure donewidestring(var r : pcompilerwidestring);
+    procedure setlengthwidestring(r : pcompilerwidestring;l : longint);
+    function getlengthwidestring(r : pcompilerwidestring) : longint;
+    procedure concatwidestringchar(r : pcompilerwidestring;c : tcompilerwidechar);
+    procedure concatwidestrings(s1,s2 : pcompilerwidestring);
+    function comparewidestrings(s1,s2 : pcompilerwidestring) : longint;
+    procedure copywidestring(s,d : pcompilerwidestring);
     function asciichar2unicode(c : char) : tcompilerwidechar;
     function unicode2asciichar(c : tcompilerwidechar) : char;
-    procedure ascii2unicode(const s : string;var r : tcompilerwidestring);
-    function getcharwidestring(const r : tcompilerwidestring;l : longint) : tcompilerwidechar;
+    procedure ascii2unicode(p:pchar; l:longint;r : pcompilerwidestring);
+    procedure unicode2ascii(r : pcompilerwidestring;p:pchar);
+    function getcharwidestring(r : pcompilerwidestring;l : longint) : tcompilerwidechar;
     function cpavailable(const s : string) : boolean;
 
   implementation
@@ -69,82 +69,79 @@ unit widestr;
     uses
        globals;
 
-    procedure initwidestring(var r : tcompilerwidestring);
+    procedure initwidestring(var r : pcompilerwidestring);
 
       begin
-         r.data:=nil;
-         r.len:=0;
-         r.maxlen:=0;
+         new(r);
+         r^.data:=nil;
+         r^.len:=0;
+         r^.maxlen:=0;
       end;
 
-    procedure donewidestring(var r : tcompilerwidestring);
+    procedure donewidestring(var r : pcompilerwidestring);
 
       begin
-         if assigned(r.data) then
-           freemem(r.data);
-         r.data:=nil;
-         r.maxlen:=0;
-         r.len:=0;
+         if assigned(r^.data) then
+           freemem(r^.data);
+         dispose(r);
+         r:=nil;
       end;
 
-    function getcharwidestring(const r : tcompilerwidestring;l : longint) : tcompilerwidechar;
+    function getcharwidestring(r : pcompilerwidestring;l : longint) : tcompilerwidechar;
 
       begin
-         getcharwidestring:=r.data[l];
+         getcharwidestring:=r^.data[l];
       end;
 
-    function getlengthwidestring(const r : tcompilerwidestring) : longint;
+    function getlengthwidestring(r : pcompilerwidestring) : longint;
 
       begin
-         getlengthwidestring:=r.len;
+         getlengthwidestring:=r^.len;
       end;
 
-    procedure setlengthwidestring(var r : tcompilerwidestring;l : longint);
+    procedure setlengthwidestring(r : pcompilerwidestring;l : longint);
 
       begin
-         if r.maxlen>=l then
+         if r^.maxlen>=l then
            exit;
-         if assigned(r.data) then
-           reallocmem(r.data,sizeof(tcompilerwidechar)*l)
+         if assigned(r^.data) then
+           reallocmem(r^.data,sizeof(tcompilerwidechar)*l)
          else
-           getmem(r.data,sizeof(tcompilerwidechar)*l);
+           getmem(r^.data,sizeof(tcompilerwidechar)*l);
       end;
 
-    procedure concatwidestringchar(var r : tcompilerwidestring;c : tcompilerwidechar);
+    procedure concatwidestringchar(r : pcompilerwidestring;c : tcompilerwidechar);
 
       begin
-         if r.len>=r.maxlen then
-           setlengthwidestring(r,r.len+16);
-         r.data[r.len]:=c;
-         inc(r.len);
+         if r^.len>=r^.maxlen then
+           setlengthwidestring(r,r^.len+16);
+         r^.data[r^.len]:=c;
+         inc(r^.len);
       end;
 
-    procedure concatwidestrings(const s1,s2 : tcompilerwidestring;
-      var r : tcompilerwidestring);
-
+    procedure concatwidestrings(s1,s2 : pcompilerwidestring);
       begin
-         setlengthwidestring(r,s1.len+s2.len);
-         r.len:=s1.len+s2.len;
-         move(s1.data^,r.data^,s1.len*2);
-         move(s2.data^,r.data[s1.len],s2.len*2);
+         setlengthwidestring(s1,s1^.len+s2^.len);
+         inc(s1^.len,s2^.len);
+         move(s2^.data^,s1^.data[s1^.len],s2^.len*sizeof(tcompilerwidechar));
       end;
 
-    function comparewidestringwidestring(const s1,s2 : tcompilerwidestring) : longint;
+    function comparewidestringwidestring(s1,s2 : pcompilerwidestring) : longint;
 
       begin
         {$ifdef fpc}{$warning todo}{$endif}
         comparewidestringwidestring:=0;
       end;
 
-    procedure copywidestring(const s : tcompilerwidestring;var d : tcompilerwidestring);
+    procedure copywidestring(s,d : pcompilerwidestring);
 
       begin
-         setlengthwidestring(d,s.len);
-         d.len:=s.len;
-         move(s.data^,d.data^,s.len);
+         setlengthwidestring(d,s^.len);
+         d^.len:=s^.len;
+         move(s^.data^,d^.data^,s^.len*sizeof(tcompilerwidechar));
       end;
 
-    function comparewidestrings(const s1,s2 : tcompilerwidestring) : shortint;
+    function comparewidestrings(s1,s2 : pcompilerwidestring) : longint;
 
       begin
          {!!!!!! FIXME }
@@ -169,9 +166,11 @@ unit widestr;
     function unicode2asciichar(c : tcompilerwidechar) : char;
 
       begin
+        {$ifdef fpc}{$warning todo}{$endif}
+        unicode2asciichar:=#0;
       end;
 
-    procedure ascii2unicode(const s : string;var r : tcompilerwidestring);
+    procedure ascii2unicode(p:pchar; l:longint;r : pcompilerwidestring);
 (*
       var
          m : punicodemap;
@@ -187,9 +186,62 @@ unit widestr;
            end;
       end;
 *)
+      var
+        source : pchar;
+        dest   : pcompilerwidechar;
+        i      : longint;
       begin
+        setlengthwidestring(r,l);
+        source:=p;
+        r^.len:=l;
+        dest:=r^.data;
+        for i:=1 to l do
+         begin
+           if byte(source^)<128 then
+            dest^:=tcompilerwidechar(byte(source^))
+           else
+            dest^:=32;
+           inc(dest);
+           inc(source);
+         end;
       end;
 
+
+    procedure unicode2ascii(r : pcompilerwidestring;p:pchar);
+(*
+      var
+         m : punicodemap;
+         i : longint;
+
+      begin
+         m:=getmap(aktsourcecodepage);
+         { should be a very good estimation :) }
+         setlengthwidestring(r,length(s));
+         // !!!! MBCS
+         for i:=1 to length(s) do
+           begin
+           end;
+      end;
+*)
+      var
+        source : pcompilerwidechar;
+        dest   : pchar;
+        i      : longint;
+      begin
+        source:=r^.data;
+        dest:=p;
+        for i:=1 to r^.len do
+         begin
+           if word(source^)<128 then
+            dest^:=char(word(source^))
+           else
+            dest^:=' ';
+           inc(dest);
+           inc(source);
+         end;
+      end;
+
+
     function cpavailable(const s : string) : boolean;
 {!!!!!!
       begin
@@ -204,7 +256,11 @@ unit widestr;
 end.
 {
   $Log$
-  Revision 1.5  2001-05-27 14:30:55  florian
+  Revision 1.6  2001-07-08 21:00:16  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.5  2001/05/27 14:30:55  florian
     + some widestring stuff added
 
   Revision 1.4  2001/05/08 21:06:33  florian

rtl/i386/i386.inc

@@ -156,7 +156,7 @@ end ['EAX','ECX','EDX','EDI'];
 
 
 {$define FPC_SYSTEM_HAS_INDEXBYTE}
-function IndexByte(var buf;len:longint;b:byte):longint; assembler;
+function IndexByte(Const buf;len:longint;b:byte):longint; assembler;
 asm
         movl    Len,%ecx       // Load len
         movl    Buf,%edi       // Load String
@@ -179,7 +179,7 @@ end ['EAX','EBX','ECX','EDI'];
 
 
 {$define FPC_SYSTEM_HAS_INDEXWORD}
-function Indexword(var buf;len:longint;b:word):longint; assembler;
+function Indexword(Const buf;len:longint;b:word):longint; assembler;
 asm
         movl    Len,%ecx       // Load len
         movl    Buf,%edi       // Load String
@@ -202,7 +202,7 @@ end ['EAX','EBX','ECX','EDI'];
 
 
 {$define FPC_SYSTEM_HAS_INDEXDWORD}
-function IndexDWord(var buf;len:longint;b:DWord):longint; assembler;
+function IndexDWord(Const buf;len:longint;b:DWord):longint; assembler;
 asm
         movl    Len,%ecx       // Load len
         movl    Buf,%edi       // Load String
@@ -225,7 +225,7 @@ end ['EAX','EBX','ECX','EDI'];
 
 
 {$define FPC_SYSTEM_HAS_COMPAREBYTE}
-function CompareByte(var buf1,buf2;len:longint):longint; assembler;
+function CompareByte(Const buf1,buf2;len:longint):longint; assembler;
 asm
         cld
         movl    len,%eax
@@ -268,7 +268,7 @@ end ['ECX','EAX','ESI','EDI'];
 
 
 {$define FPC_SYSTEM_HAS_COMPAREWORD}
-function CompareWord(var buf1,buf2;len:longint):longint; assembler;
+function CompareWord(Const buf1,buf2;len:longint):longint; assembler;
 asm
         cld
         movl    len,%eax
@@ -320,7 +320,7 @@ end ['EBX','EDX','ECX','EAX','ESI','EDI'];
 
 
 {$define FPC_SYSTEM_HAS_COMPAREDWORD}
-function CompareDWord(var buf1,buf2;len:longint):longint; assembler;
+function CompareDWord(Const buf1,buf2;len:longint):longint; assembler;
 asm
         cld
         movl    len,%eax
@@ -370,7 +370,7 @@ end ['EBX','EDX','ECX','EAX','ESI','EDI'];
 
 
 {$define FPC_SYSTEM_HAS_INDEXCHAR0}
-function IndexChar0(var buf;len:longint;b:Char):longint; assembler;
+function IndexChar0(Const buf;len:longint;b:Char):longint; assembler;
 asm
 // Can't use scasb, or will have to do it twice, think this
 //   is faster for small "len"
@@ -1115,7 +1115,11 @@ procedure inclocked(var l : longint);assembler;
 
 {
   $Log$
-  Revision 1.12  2001-05-31 22:42:56  florian
+  Revision 1.13  2001-07-08 21:00:18  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.12  2001/05/31 22:42:56  florian
     * some fixes for widestrings and variants
 
   Revision 1.11  2001/04/21 12:18:09  peter

rtl/inc/astrings.inc

@@ -269,10 +269,7 @@ begin
     Pointer(a):=nil
   else
     begin
-      //!! Horribly inneficient, but I see no other way...
-      L:=1;
-      While P[l]<>#0 do
-        inc (l);
+      l:=IndexChar(p^,-1,#0);
       Pointer(a):=NewAnsistring(L);
       SetLength(A,L);
       Move (P[0],Pointer(A)^,L)
@@ -283,22 +280,14 @@ end;
 Procedure CharArray_To_AnsiStr(var a : ansistring;p : pchar;l:longint);[Public,Alias : 'FPC_CHARARRAY_TO_ANSISTR'];
 var
   i  : longint;
-  hp : pchar;
 begin
   if p[0]=#0 Then
     Pointer(a):=nil
   else
     begin
-      { p[0] <> #0, checked above (JM) }
-      hp:=p+1;
-      i:=1;
-      while (i<l) and (hp^<>#0) do
-       begin
-         inc(hp);
-         inc(i);
-       end;
+      i:=IndexChar(p^,L,#0);
       Pointer(a):=NewAnsistring(i);
-      SetLength(A,i);
+      SetLength(a,i);
       Move (P[0],Pointer(A)^,i);
     end;
 end;
@@ -313,19 +302,18 @@ Function AnsiStr_Compare(S1,S2 : Pointer): Longint;[Public,Alias : 'FPC_ANSISTR_
    >0 if S1>S2
 }
 Var
-  i,MaxI,Temp : Longint;
+  MaxI,Temp : Longint;
 begin
-  i:=0;
+  if S1=S2 then
+   begin
+     AnsiStr_Compare:=0;
+     exit;
+   end;
   Maxi:=Length(AnsiString(S1));
   temp:=Length(AnsiString(S2));
   If MaxI>Temp then
    MaxI:=Temp;
-  Temp:=0;
-  While (i<MaxI) and (Temp=0) do
-   begin
-     Temp:= PByte(S1+I)^ - PByte(S2+i)^;
-     inc(i);
-   end;
+  Temp:=CompareByte(S1^,S2^,MaxI);
   if temp=0 then
    temp:=Length(AnsiString(S1))-Length(AnsiString(S2));
   AnsiStr_Compare:=Temp;
@@ -446,14 +434,16 @@ Procedure UniqueString(Var S : AnsiString); [Public,Alias : 'FPC_ANSISTR_UNIQUE'
 }
 Var
   SNew : Pointer;
+  L    : Longint;
 begin
   If Pointer(S)=Nil then
     exit;
   if PAnsiRec(Pointer(S)-Firstoff)^.Ref<>1 then
    begin
-     SNew:=NewAnsiString (PAnsiRec(Pointer(S)-FirstOff)^.len);
-     Move (Pointer(S)^,SNew^,PAnsiRec(Pointer(S)-FirstOff)^.len+1);
-     PAnsiRec(SNew-FirstOff)^.len:=PAnsiRec(Pointer(S)-FirstOff)^.len;
+     L:=PAnsiRec(Pointer(S)-FirstOff)^.len;
+     SNew:=NewAnsiString (L);
+     Move (Pointer(S)^,SNew^,L+1);
+     PAnsiRec(SNew-FirstOff)^.len:=L;
      ansistr_decr_ref (Pointer(S));  { Thread safe }
      Pointer(S):=SNew;
    end;
@@ -491,33 +481,27 @@ end;
 
 Function Pos (Const Substr : AnsiString; Const Source : AnsiString) : Longint;
 var
-  substrlen,
-  maxi,
-  i,j : longint;
-  e   : boolean;
-  S   : AnsiString;
-  se  : Pointer;
-begin
-  i := 0;
-  j := 0;
-  substrlen:=Length(SubStr);
-  maxi:=length(source)-substrlen;
-  e:=(substrlen>0);
-  while (e) and (i <= maxi) do
+  i,MaxLen : StrLenInt;
+  pc : pchar;
+begin
+  Pos:=0;
+  if Length(SubStr)>0 then
    begin
-     inc (i);
-     if Source[i]=SubStr[1] then
+     MaxLen:=Length(source)-Length(SubStr);
+     i:=0;
+     pc:=@source[1];
+     while (i<=MaxLen) do
       begin
-        S:=copy(Source,i,substrlen);
-        Se:=pointer(SubStr);
-        if AnsiStr_Compare(se,Pointer(S))=0 then
+        inc(i);
+        if (SubStr[1]=pc^) and
+           (CompareChar(Substr[1],pc^,Length(SubStr))=0) then
          begin
-           j := i;
-           break;
+           Pos:=i;
+           exit;
          end;
+        inc(pc);
       end;
    end;
-  pos := j;
 end;
 
 
@@ -528,13 +512,18 @@ end;
 Function Pos (c : Char; Const s : AnsiString) : Longint;
 var
   i: longint;
+  pc : pchar;
 begin
+  pc:=@s[1];
   for i:=1 to length(s) do
-   if s[i]=c then
-    begin
-      pos:=i;
-      exit;
-    end;
+   begin
+     if pc^=c then
+      begin
+        pos:=i;
+        exit;
+      end;
+     inc(pc);
+   end;
   pos:=0;
 end;
 
@@ -600,16 +589,6 @@ begin
     end;
 end;
 
-{$IfDef SUPPORT_FIXED}
-Function ValAnsiFixed(Const S : AnsiString; Var Code : ValSint): ValReal; [public, alias:'FPC_VAL_FIXED_ANSISTR'];
-Var
-  SS : String;
-begin
-  AnsiStr_To_ShortStr (SS,Pointer(S));
-  ValAnsiFixed := Fixed(ValFloat(SS,Code));
-end;
-{$EndIf SUPPORT_FIXED}
-
 
 procedure AnsiStr_Float(d : ValReal;len,fr,rt : longint;var s : ansistring);[public,alias:'FPC_ANSISTR_FLOAT'];
 var
@@ -726,7 +705,11 @@ end;
 
 {
   $Log$
-  Revision 1.12  2001-07-04 12:17:09  jonas
+  Revision 1.13  2001-07-08 21:00:18  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.12  2001/07/04 12:17:09  jonas
     * removed DestSize parameter from declaration of ValAnsiSignedInt64
       (merged)
 

rtl/inc/generic.inc

@@ -102,7 +102,7 @@ end;
 
 
 {$ifndef FPC_SYSTEM_HAS_INDEXCHAR}
-function IndexChar(var buf;len:longint;b:char):longint;
+function IndexChar(Const buf;len:longint;b:char):longint;
 begin
   IndexChar:=IndexByte(Buf,Len,byte(B));
 end;
@@ -110,7 +110,7 @@ end;
 
 
 {$ifndef FPC_SYSTEM_HAS_INDEXBYTE}
-function IndexByte(var buf;len:longint;b:byte):longint;
+function IndexByte(Const buf;len:longint;b:byte):longint;
 type
   bytearray    = array [0..maxlongint] of byte;
 var
@@ -127,7 +127,7 @@ end;
 
 
 {$ifndef FPC_SYSTEM_HAS_INDEXWORD}
-function Indexword(var buf;len:longint;b:word):longint;
+function Indexword(Const buf;len:longint;b:word):longint;
 type
   wordarray    = array [0..maxlongint] of word;
 var
@@ -144,7 +144,7 @@ end;
 
 
 {$ifndef FPC_SYSTEM_HAS_INDEXDWORD}
-function IndexDWord(var buf;len:longint;b:DWord):longint;
+function IndexDWord(Const buf;len:longint;b:DWord):longint;
 type
   longintarray = array [0..maxlongint] of longint;
 var
@@ -160,7 +160,7 @@ end;
 
 
 {$ifndef FPC_SYSTEM_HAS_COMPARECHAR}
-function CompareChar(var buf1,buf2;len:longint):longint;
+function CompareChar(Const buf1,buf2;len:longint):longint;
 begin
   CompareChar:=CompareByte(buf1,buf2,len);
 end;
@@ -168,7 +168,7 @@ end;
 
 
 {$ifndef FPC_SYSTEM_HAS_COMPAREBYTE}
-function CompareByte(var buf1,buf2;len:longint):longint;
+function CompareByte(Const buf1,buf2;len:longint):longint;
 type
   bytearray    = array [0..maxlongint] of byte;
 var
@@ -197,7 +197,7 @@ end;
 
 
 {$ifndef FPC_SYSTEM_HAS_COMPAREWORD}
-function CompareWord(var buf1,buf2;len:longint):longint;
+function CompareWord(Const buf1,buf2;len:longint):longint;
 type
   wordarray    = array [0..maxlongint] of word;
 var
@@ -226,7 +226,7 @@ end;
 
 
 {$ifndef FPC_SYSTEM_HAS_COMPAREDWORD}
-function CompareDWord(var buf1,buf2;len:longint):longint;
+function CompareDWord(Const buf1,buf2;len:longint):longint;
 type
   longintarray    = array [0..maxlongint] of longint;
 var
@@ -255,7 +255,7 @@ end;
 
 
 {$ifndef FPC_SYSTEM_HAS_MOVECHAR0}
-procedure MoveChar0(var buf1,buf2;len:longint);
+procedure MoveChar0(Const buf1;var buf2;len:longint);
 var
   I : longint;
 begin
@@ -270,7 +270,7 @@ end;
 
 
 {$ifndef FPC_SYSTEM_HAS_INDEXCHAR0}
-function IndexChar0(var buf;len:longint;b:Char):longint;
+function IndexChar0(Const buf;len:longint;b:Char):longint;
 var
   I : longint;
 begin
@@ -286,7 +286,7 @@ end;
 
 
 {$ifndef FPC_SYSTEM_HAS_COMPARECHAR0}
-function CompareChar0(var buf1,buf2;len:longint):longint;
+function CompareChar0(Const buf1,buf2;len:longint):longint;
 type
   bytearray    = array [0..maxlongint] of byte;
 
@@ -828,7 +828,11 @@ end;
 
 {
   $Log$
-  Revision 1.13  2001-05-28 20:43:17  peter
+  Revision 1.14  2001-07-08 21:00:18  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.13  2001/05/28 20:43:17  peter
     * more saveregisters added (merged)
 
   Revision 1.12  2001/05/18 22:59:59  peter

rtl/inc/sstrings.inc

@@ -111,22 +111,27 @@ end;
 
 function pos(const substr : shortstring;const s : shortstring):StrLenInt;
 var
-  i,j : StrLenInt;
-  e   : boolean;
+  i,MaxLen : StrLenInt;
+  pc : pchar;
 begin
-  i := 0;
-  j := 0;
-  e:=(length(SubStr)>0);
-  while e and (i<=Length(s)-Length(SubStr)) do
+  Pos:=0;
+  if Length(SubStr)>0 then
    begin
-     inc(i);
-     if (SubStr[1]=s[i]) and (Substr=Copy(s,i,Length(SubStr))) then
+     MaxLen:=Length(s)-Length(SubStr);
+     i:=0;
+     pc:=@s[1];
+     while (i<=MaxLen) do
       begin
-        j:=i;
-        e:=false;
+        inc(i);
+        if (SubStr[1]=pc^) and
+           (CompareChar(Substr[1],pc^,Length(SubStr))=0) then
+         begin
+           Pos:=i;
+           exit;
+         end;
+        inc(pc);
       end;
    end;
-  Pos:=j;
 end;
 
 
@@ -134,16 +139,22 @@ end;
 function pos(c:char;const s:shortstring):StrLenInt;
 var
   i : StrLenInt;
+  pc : pchar;
 begin
+  pc:=@s[1];
   for i:=1 to length(s) do
-   if s[i]=c then
-    begin
-      pos:=i;
-      exit;
-    end;
+   begin
+     if pc^=c then
+      begin
+        pos:=i;
+        exit;
+      end;
+     inc(pc);
+   end;
   pos:=0;
 end;
 
+
 function copy(c:char;index : StrLenInt;count : StrLenInt): shortstring;
 begin
   if (index=1) and (Count>0) then
@@ -162,13 +173,6 @@ begin
 end;
 
 
-{ removed must be internal to be accepted in const expr !! PM
-function length(c:char):StrLenInt;
-begin
-  Length:=1;
-end;
-}
-
 {$ifdef IBM_CHAR_SET}
 const
   UpCaseTbl : shortstring[7]=#154#142#153#144#128#143#165;
@@ -557,14 +561,6 @@ begin
 end;
 
 
-{$ifdef SUPPORT_FIXED}
-Function ValFixed(const s : shortstring;var code : ValSInt): Fixed; [public, alias:'FPC_VAL_FIXED_SHORTSTR'];
-begin
-  ValFixed := Fixed(ValFloat(s,code));
-end;
-{$endif SUPPORT_FIXED}
-
-
 Procedure SetString (Var S : Shortstring; Buf : PChar; Len : Longint);
 begin
   Move (Buf[0],S[1],Len);
@@ -573,7 +569,11 @@ end;
 
 {
   $Log$
-  Revision 1.13  2001-07-04 12:02:14  jonas
+  Revision 1.14  2001-07-08 21:00:18  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.13  2001/07/04 12:02:14  jonas
     * fixed bug in ValSignedInt (it accepted some values slightly larger than
       high(cardinal) such as 4294967297) (merged)
 

rtl/inc/system.inc

@@ -177,9 +177,9 @@ End;
 {Requires int64.inc, since that contains the VAL functions for int64 and qword}
 {$i astrings.inc}
 
-{$ifdef haswidechar}
+{$ifdef HASWIDESTRING}
 {$i wstrings.inc}
-{$endif haswidechar}
+{$endif HASWIDESTRING}
 
 {*****************************************************************************
                         Dynamic Array support
@@ -656,7 +656,11 @@ end;
 
 {
   $Log$
-  Revision 1.15  2001-06-13 18:32:05  peter
+  Revision 1.16  2001-07-08 21:00:18  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.15  2001/06/13 18:32:05  peter
     * big endian updates (merged)
 
   Revision 1.14  2001/06/03 15:15:58  peter

rtl/inc/systemh.inc

@@ -61,8 +61,6 @@ Type
   {$define SUPPORT_EXTENDED}
   {$define SUPPORT_COMP}
 
-  { define SUPPORT_FIXED}
-
   ValSInt = Longint;
   ValUInt = Cardinal;
   ValReal = Extended;
@@ -135,8 +133,10 @@ Type
 {$ifdef HASWIDECHAR}
   PWideChar           = ^WideChar;
   PPWideChar          = ^PWideChar;
-  PWideString         = ^WideString;
 {$endif HASWIDECHAR}
+{$ifdef HASWIDESTRING}
+  PWideString         = ^WideString;
+{$endif HASWIDESTRING}
 
   TTextLineBreakStyle = (tlbsLF,tlbsCRLF,tlbsCR);
 
@@ -218,17 +218,17 @@ Procedure FillChar(Var x;count:Longint;Value:Byte);
 procedure FillByte(var x;count:longint;value:byte);
 Procedure FillWord(Var x;count:Longint;Value:Word);
 procedure FillDWord(var x;count:longint;value:DWord);
-function  IndexChar(var buf;len:longint;b:char):longint;
-function  IndexByte(var buf;len:longint;b:byte):longint;
-function  Indexword(var buf;len:longint;b:word):longint;
-function  IndexDWord(var buf;len:longint;b:DWord):longint;
-function  CompareChar(var buf1,buf2;len:longint):longint;
-function  CompareByte(var buf1,buf2;len:longint):longint;
-function  CompareWord(var buf1,buf2;len:longint):longint;
-function  CompareDWord(var buf1,buf2;len:longint):longint;
-procedure MoveChar0(var buf1,buf2;len:longint);
-function  IndexChar0(var buf;len:longint;b:char):longint;
-function  CompareChar0(var buf1,buf2;len:longint):longint;
+function  IndexChar(const buf;len:longint;b:char):longint;
+function  IndexByte(const buf;len:longint;b:byte):longint;
+function  Indexword(const buf;len:longint;b:word):longint;
+function  IndexDWord(const buf;len:longint;b:DWord):longint;
+function  CompareChar(const buf1,buf2;len:longint):longint;
+function  CompareByte(const buf1,buf2;len:longint):longint;
+function  CompareWord(const buf1,buf2;len:longint):longint;
+function  CompareDWord(const buf1,buf2;len:longint):longint;
+procedure MoveChar0(const buf1;var buf2;len:longint);
+function  IndexChar0(const buf;len:longint;b:char):longint;
+function  CompareChar0(const buf1,buf2;len:longint):longint;
 
 
 {****************************************************************************
@@ -340,7 +340,7 @@ function  lowercase(const s : ansistring) : ansistring;
                              WideString Handling
 ****************************************************************************}
 
-{$ifdef haswidechar}
+{$ifdef HASWIDESTRING}
 {$ifndef INTERNSETLENGTH}
 Procedure SetLength (Var S : WideString; l : Longint);
 {$endif INTERNSETLENGTH}
@@ -348,9 +348,11 @@ Procedure UniqueString (Var S : WideString);
 Function  Length (Const S : WideString) : Longint;
 Function  Copy (Const S : WideString; Index,Size : Longint) : WideString;
 Function  Pos (Const Substr : WideString; Const Source : WideString) : Longint;
+Function  Pos (c : Char; Const s : WideString) : Longint;
+Function  Pos (c : WideChar; Const s : WideString) : Longint;
 Procedure Insert (Const Source : WideString; Var S : WideString; Index : Longint);
 Procedure Delete (Var S : WideString; Index,Size: Longint);
-{$endif haswidechar}
+{$endif HASWIDESTRING}
 
 
 {****************************************************************************
@@ -502,7 +504,11 @@ const
 
 {
   $Log$
-  Revision 1.24  2001-06-04 11:43:51  peter
+  Revision 1.25  2001-07-08 21:00:18  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.24  2001/06/04 11:43:51  peter
     * Formal const to var fixes
     * Hexstr(int64) added
 

rtl/inc/text.inc

@@ -558,6 +558,30 @@ begin
 end;
 
 
+{$ifdef HASWIDESTRING}
+Procedure Write_Text_WideString (Len : Longint; Var f : TextRec; S : WideString);[Public,alias:'FPC_WRITE_TEXT_WIDESTR'];
+{
+ Writes a WideString to the Text file T
+}
+var
+  SLen : longint;
+begin
+  If (pointer(S)=nil) or (InOutRes<>0) then
+   exit;
+  case f.mode of
+    fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
+      begin
+        SLen:=Length(s);
+        If Len>SLen Then
+          WriteBlanks(f,Len-SLen);
+        WriteBuffer(f,PChar(AnsiString(S))^,SLen);
+      end;
+    fmInput: InOutRes:=105
+    else InOutRes:=103;
+  end;
+end;
+{$endif HASWIDESTRING}
+
 Procedure Write_SInt(Len : Longint;var t : TextRec;l : ValSInt);[Public,Alias:'FPC_WRITE_TEXT_SINT'];
 var
   s : String;
@@ -645,6 +669,32 @@ Begin
 End;
 
 
+{$ifdef HASWIDECHAR}
+Procedure Write_WideChar(Len : Longint;var t : TextRec;c : WideChar);[Public,Alias:'FPC_WRITE_TEXT_WIDECHAR'];
+var
+  ch : char;
+Begin
+  If (InOutRes<>0) then
+   exit;
+  if (TextRec(t).mode<>fmOutput) Then
+   begin
+     if TextRec(t).mode=fmClosed then
+      InOutRes:=103
+     else
+      InOutRes:=105;
+     exit;
+   end;
+  If Len>1 Then
+   WriteBlanks(t,Len-1);
+  If t.BufPos+1>=t.BufSize Then
+   FileFunc(t.InOutFunc)(t);
+  ch:=c;
+  t.Bufptr^[t.BufPos]:=ch;
+  Inc(t.BufPos);
+End;
+{$endif HASWIDECHAR}
+
+
 {*****************************************************************************
                                 Read(Ln)
 *****************************************************************************}
@@ -1049,7 +1099,11 @@ end;
 
 {
   $Log$
-  Revision 1.8  2001-06-27 21:37:38  peter
+  Revision 1.9  2001-07-08 21:00:18  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.8  2001/06/27 21:37:38  peter
     * v10 merges
 
   Revision 1.7  2001/06/04 11:43:51  peter

rtl/inc/wstrings.inc

@@ -43,7 +43,54 @@ Type
 
 Const
   WideRecLen = SizeOf(TWideRec);
-  WideFirstOff = SizeOf(TWideRec)-1;
+  WideFirstOff = SizeOf(TWideRec)-sizeof(WideChar);
+
+
+{
+  Default WideChar <-> Char conversion is to only convert the
+  lower 127 chars, all others are translated to spaces.
+
+  These routines can be overwritten for the Current Locale
+}
+
+procedure Wide2AnsiMove(source:pwidechar;dest:pchar;len:longint);
+var
+  i : longint;
+begin
+  for i:=1to len do
+   begin
+     if word(source^)<128 then
+      dest^:=char(word(source^))
+     else
+      dest^:=' ';
+     inc(dest);
+     inc(source);
+   end;
+end;
+
+
+procedure Ansi2WideMove(source:pchar;dest:pwidechar;len:longint);
+var
+  i : longint;
+begin
+  for i:=1to len do
+   begin
+     if byte(source^)<128 then
+      dest^:=widechar(byte(source^))
+     else
+      dest^:=' ';
+     inc(dest);
+     inc(source);
+   end;
+end;
+
+
+Type
+  TWide2AnsiMove=procedure(source:pwidechar;dest:pchar;len:longint);
+  TAnsi2WideMove=procedure(source:pchar;dest:pwidechar;len:longint);
+Const
+  Wide2AnsiMoveProc:TWide2AnsiMove=@Wide2AnsiMove;
+  Ansi2WideMoveProc:TAnsi2WideMove=@Ansi2WideMove;
 
 (*
 Procedure UniqueWideString(Var S : WideString); [Public,Alias : 'FPC_WIDESTR_UNIQUE'];
@@ -95,7 +142,7 @@ begin
      PWideRec(P)^.Len:=0;         { Initial length }
      PWideRec(P)^.Ref:=1;         { Set reference count }
      PWideRec(P)^.First:=#0;      { Terminating #0 }
-     P:=P+WideFirstOff;               { Points to string now }
+     inc(p,WideFirstOff);         { Points to string now }
    end;
   NewWideString:=P;
 end;
@@ -148,6 +195,7 @@ Begin
   inclocked(PWideRec(S-WideFirstOff)^.Ref);
 end;
 
+
 Procedure WideStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer);[Public, alias: 'FPC_WIDESTR_TO_SHORTSTR'];
 {
   Converts a WideString to a ShortString;
@@ -159,13 +207,11 @@ begin
    S1:=''
   else
    begin
-     {!!!!! FIXME
      Size:=PAnsiRec(S2-FirstOff)^.Len;
      If Size>high(S1) then
       Size:=high(S1);
-     Move (S2^,S1[1],Size);
+     Wide2AnsiMoveProc(PWideChar(S2),PChar(@S1[1]),Size);
      byte(S1[0]):=Size;
-     }
    end;
 end;
 
@@ -180,25 +226,29 @@ begin
   Size:=Length(S2);
   Setlength (WideString(S1),Size);
   if Size>0 then
-   begin
-     {!!!! FIXME
-     Move (S2[1],Pointer(S1)^,Size);
-      Terminating Zero
-     PByte(Pointer(S1)+Size)^:=0;
-     }
-   end;
+   Ansi2WideMoveProc(PChar(@S2[1]),PWideChar(S1),Size);
 end;
 
+
 Procedure WideStr_To_AnsiStr (Var S1 : Pointer;S2 : Pointer);[Public, alias: 'FPC_WIDESTR_TO_ANSISTR'];
 {
   Converts a WideString to an AnsiString
 }
+Var
+  Size : Longint;
 begin
   if s2=nil then
     s1:=nil
   else
     begin
-       {!!!!! FIXME }
+       Size:=Length(WideString(S2));
+       Setlength (AnsiString(S1),Size);
+       if Size>0 then
+        begin
+          Wide2AnsiMoveProc(PWideChar(S2),PChar(S1),Size);
+          { Terminating Zero }
+          PChar(S1+Size)^:=#0;
+        end;
     end;
 end;
 
@@ -214,10 +264,18 @@ begin
      s1:=nil
    else
      begin
-        {!!!! FIXME }
+       Size:=Length(AnsiString(S2));
+       Setlength (WideString(S1),Size);
+       if Size>0 then
+        begin
+          Ansi2WideMoveProc(PChar(S2),PWideChar(S1),Size);
+          { Terminating Zero }
+          PWideChar(S1+Size*sizeof(WideChar))^:=#0;
+        end;
      end;
 end;
 
+
 { checked against the ansistring routine, 2001-05-27 (FK) }
 Procedure WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_WIDESTR_ASSIGN'];
 {
@@ -256,8 +314,8 @@ begin
        Size:=PWideRec(S2-WideFirstOff)^.Len;
        Location:=Length(WideString(S1));
        SetLength (WideString(S3),Size+Location);
-       Move (S1^,S3^,Location*2);
-       Move (S2^,(S3+location*2)^,(Size+1)*2);
+       Move (S1^,S3^,Location*sizeof(WideChar));
+       Move (S2^,(S3+location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
     end;
 end;
 
@@ -268,9 +326,9 @@ Procedure Char_To_WideStr(var S1 : Pointer; c : Char);[Public, alias: 'FPC_CHAR_
 }
 begin
   Setlength (WideString(S1),1);
-  PByte(Pointer(S1))^:=byte(c);
+  PWideChar(S1)^:=c;
   { Terminating Zero }
-  PByte(Pointer(S1)+1)^:=0;
+  PWideChar(S1+sizeof(WideChar))^:=#0;
 end;
 
 
@@ -287,13 +345,10 @@ begin
     Pointer(a):=nil
   else
     begin
-      //!! Horribly inneficient, but I see no other way...
-      L:=1;
-      While P[l]<>#0 do
-        inc (l);
+      l:=IndexChar(p^,-1,#0);
       Pointer(a):=NewWidestring(L);
       SetLength(A,L);
-      Move (P[0],Pointer(A)^,L)
+      Ansi2WideMoveProc(P,PWideChar(A),L);
     end;
 end;
 
@@ -301,22 +356,15 @@ end;
 Procedure CharArray_To_WideStr(var a : widestring;p : pchar;l:longint);[Public,Alias : 'FPC_CHARARRAY_TO_WIDESTR'];
 var
   i  : longint;
-  hp : pchar;
 begin
   if p[0]=#0 Then
     Pointer(a):=nil
   else
     begin
-      Pointer(a):=NewWidestring(L);
-      hp:=p;
-      i:=0;
-      while (i<l) and (hp^<>#0) do
-       begin
-         inc(hp);
-         inc(i);
-       end;
-      SetLength(A,i);
-      Move (P[0],Pointer(A)^,i)
+      i:=IndexChar(p^,L,#0);
+      Pointer(a):=NewWidestring(i);
+      SetLength(a,i);
+      Ansi2WideMoveProc(P,PWideChar(A),i);
     end;
 end;
 
@@ -330,19 +378,18 @@ Function WideStr_Compare(S1,S2 : Pointer): Longint;[Public,Alias : 'FPC_WIDESTR_
    >0 if S1>S2
 }
 Var
-  i,MaxI,Temp : Longint;
+  MaxI,Temp : Longint;
 begin
-  i:=0;
+  if S1=S2 then
+   begin
+     WideStr_Compare:=0;
+     exit;
+   end;
   Maxi:=Length(WideString(S1));
   temp:=Length(WideString(S2));
   If MaxI>Temp then
    MaxI:=Temp;
-  Temp:=0;
-  While (i<MaxI) and (Temp=0) do
-   begin
-     Temp:= PWord(S1+I)^ - PWord(S2+i)^;
-     inc(i);
-   end;
+  Temp:=CompareWord(S1^,S2^,MaxI);
   if temp=0 then
    temp:=Length(WideString(S1))-Length(WideString(S2));
   WideStr_Compare:=Temp;
@@ -388,19 +435,19 @@ begin
           { Reallocation is needed... }
           Temp:=Pointer(NewWideString(L));
           if Length(S)>0 then
-            Move(Pointer(S)^,Temp^,L+L);
-          ansistr_decr_ref(Pointer(S));
+            Move(Pointer(S)^,Temp^,L*sizeof(WideChar));
+          WideStr_decr_ref(Pointer(S));
           Pointer(S):=Temp;
        end;
       { Force nil termination in case it gets shorter }
-      PByte(Pointer(S)+l)^:=0;
+      PWideChar(Pointer(S)+l*sizeof(WideChar))^:=#0;
       PWideRec(Pointer(S)-WideFirstOff)^.Len:=l;
     end
   else
     begin
       { Length=0 }
       if Pointer(S)<>nil then
-       ansistr_decr_ref (Pointer(S));
+       WideStr_decr_ref (Pointer(S));
       Pointer(S):=Nil;
     end;
 end;
@@ -432,15 +479,17 @@ Procedure UniqueString(Var S : WideString); [Public,Alias : 'FPC_WIDESTR_UNIQUE'
 }
 Var
   SNew : Pointer;
+  L    : Longint;
 begin
   If Pointer(S)=Nil then
     exit;
   if PWideRec(Pointer(S)-WideFirstOff)^.Ref<>1 then
    begin
-     SNew:=NewWideString (PWideRec(Pointer(S)-WideFirstOff)^.len);
-     Move (Pointer(S)^,SNew^,(PWideRec(Pointer(S)-WideFirstOff)^.len+1)*2);
-     PWideRec(SNew-WideFirstOff)^.len:=PWideRec(Pointer(S)-WideFirstOff)^.len;
-     ansistr_decr_ref (Pointer(S));  { Thread safe }
+     L:=PWideRec(Pointer(S)-WideFirstOff)^.len;
+     SNew:=NewWideString (L);
+     Move (PWideChar(S)^,SNew^,(L+1)*sizeof(WideChar));
+     PWideRec(SNew-WideFirstOff)^.len:=L;
+     widestr_decr_ref (Pointer(S));  { Thread safe }
      Pointer(S):=SNew;
    end;
 end;
@@ -466,9 +515,9 @@ begin
      ResultAddress:=Pointer(NewWideString (Size));
      if ResultAddress<>Nil then
       begin
-        Move (Pointer(Pointer(S)+index)^,ResultAddress^,Size*2);
+        Move (PWideChar(S)[Index],ResultAddress^,Size*sizeof(WideChar));
         PWideRec(ResultAddress-WideFirstOff)^.Len:=Size;
-        PWord(ResultAddress+Size*2)^:=0;
+        PWideChar(ResultAddress+Size*sizeof(WideChar))^:=#0;
       end;
    end;
   Pointer(Copy):=ResultAddress;
@@ -477,36 +526,76 @@ end;
 
 Function Pos (Const Substr : WideString; Const Source : WideString) : Longint;
 var
-  substrlen,
-  maxi,
-  i,j : longint;
-  e   : boolean;
-{  S   : WideString;
-  se  : Pointer; }
-begin
-  i := 0;
-  j := 0;
-  substrlen:=Length(SubStr);
-  maxi:=length(source)-substrlen;
-  e:=(substrlen>0);
-  while (e) and (i <= maxi) do
+  i,MaxLen : StrLenInt;
+  pc : pwidechar;
+begin
+  Pos:=0;
+  if Length(SubStr)>0 then
    begin
-     inc (i);
-{!!!:     if Source[i]=SubStr[1] then
+     MaxLen:=Length(source)-Length(SubStr);
+     i:=0;
+     pc:=@source[1];
+     while (i<=MaxLen) do
       begin
-        S:=copy(Source,i,substrlen);
-        Se:=pointer(SubStr);
-        if WideStr_Compare(se,Pointer(S))=0 then
+        inc(i);
+        if (SubStr[1]=pc^) and
+           (CompareWord(Substr[1],pc^,Length(SubStr))=0) then
          begin
-           j := i;
-           break;
+           Pos:=i;
+           exit;
          end;
-      end;}
+        inc(pc);
+      end;
+   end;
+end;
+
+
+{ Faster version for a widechar alone }
+Function Pos (c : WideChar; Const s : WideString) : Longint;
+var
+  i: longint;
+  pc : pwidechar;
+begin
+  pc:=@s[1];
+  for i:=1 to length(s) do
+   begin
+     if pc^=c then
+      begin
+        pos:=i;
+        exit;
+      end;
+     inc(pc);
+   end;
+  pos:=0;
+end;
+
+
+{ Faster version for a char alone. Must be implemented because   }
+{ pos(c: char; const s: shortstring) also exists, so otherwise   }
+{ using pos(char,pchar) will always call the shortstring version }
+{ (exact match for first argument), also with $h+ (JM)           }
+Function Pos (c : Char; Const s : WideString) : Longint;
+var
+  i: longint;
+  wc : widechar;
+  pc : pwidechar;
+begin
+  wc:=c;
+  pc:=@s[1];
+  for i:=1 to length(s) do
+   begin
+     if pc^=wc then
+      begin
+        pos:=i;
+        exit;
+      end;
+     inc(pc);
    end;
-  pos := j;
+  pos:=0;
 end;
 
 
+
 Procedure Delete (Var S : WideString; Index,Size: Longint);
 Var
   LS : Longint;
@@ -527,7 +616,7 @@ begin
      if Index+Size<=LS then
       begin
         Dec(Index);
-        Move(PByte(Pointer(S))[Index+Size],PByte(Pointer(S))[Index],(LS-Index+1)*2);
+        Move(PWideChar(S)[Index+Size],PWideChar(S)[Index],(LS-Index+1)*sizeof(WideChar));
       end;
      Setlength(s,LS-Size);
    end;
@@ -550,10 +639,10 @@ begin
   Pointer(Temp) := NewWideString(Length(Source)+LS);
   SetLength(Temp,Length(Source)+LS);
   If Index>0 then
-    move (Pointer(S)^,Pointer(Temp)^,Index*2);
-  Move (Pointer(Source)^,PByte(Temp)[Index],Length(Source)*2);
+    move (PWideChar(S)^,PWideChar(Temp)^,Index*sizeof(WideChar));
+  Move (PWideChar(Source)^,PWideChar(Temp)[Index],Length(Source)*sizeof(WideChar));
   If (LS-Index)>0 then
-    Move(PByte(Pointer(S))[Index],PByte(temp)[Length(Source)+index],(LS-Index)*2);
+    Move(PWideChar(S)[Index],PWideChar(temp)[Length(Source)+index],(LS-Index)*sizeof(WideChar));
   S:=Temp;
 end;
 
@@ -566,9 +655,104 @@ begin
 end;}
 
 
+Function ValWideFloat(Const S : WideString; Var Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_ANSISTR'];
+Var
+  SS : String;
+begin
+  WideStr_To_ShortStr(SS,Pointer(S));
+  ValWideFloat := ValFloat(SS,Code);
+end;
+
+
+Function ValWideUnsignedInt (Const S : WideString; Var Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_ANSISTR'];
+Var
+  SS : ShortString;
+begin
+  WideStr_To_ShortStr(SS,Pointer(S));
+  ValWideUnsignedInt := ValUnsignedInt(SS,Code);
+end;
+
+
+Function ValWideSignedInt (DestSize: longint; Const S : WideString; Var Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_ANSISTR'];
+Var
+  SS : ShortString;
+begin
+  ValWideSignedInt:=0;
+  if length(S)>255 then
+    code:=256
+  else
+    begin
+       WideStr_To_ShortStr (SS,Pointer(S));
+       ValWideSignedInt := ValSignedInt(DestSize,SS,Code);
+    end;
+end;
+
+Function ValWideUnsignedint64 (Const S : WideString; Var Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_ANSISTR'];
+Var
+  SS : ShortString;
+begin
+  ValWideUnsignedInt64:=0;
+  if length(S)>255 then
+    code:=256
+  else
+    begin
+       WideStr_To_ShortStr(SS,Pointer(S));
+       ValWideUnsignedInt64 := ValQWord(SS,Code);
+    end;
+end;
+
+
+Function ValWideSignedInt64 (Const S : WideString; Var Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_ANSISTR'];
+Var
+  SS : ShortString;
+begin
+  ValWideSignedInt64:=0;
+  if length(S)>255 then
+    code:=256
+  else
+    begin
+       WideStr_To_ShortStr (SS,Pointer(S));
+       ValWideSignedInt64 := valInt64(SS,Code);
+    end;
+end;
+
+
+procedure WideStr_Float(d : ValReal;len,fr,rt : longint;var s : WideString);[public,alias:'FPC_WIDESTR_FLOAT'];
+var
+  ss : shortstring;
+begin
+  str_real(len,fr,d,treal_type(rt),ss);
+  s:=ss;
+end;
+
+
+Procedure WideStr_Cardinal(C : Cardinal;Len : Longint; Var S : WideString);[Public,Alias : 'FPC_WIDESTR_CARDINAL'];
+Var
+  SS : ShortString;
+begin
+  int_str_cardinal(C,Len,SS);
+  S:=SS;
+end;
+
+
+
+Procedure WideStr_Longint(L : Longint; Len : Longint; Var S : WideString);[Public,Alias : 'FPC_WIDESTR_LONGINT'];
+Var
+  SS : ShortString;
+begin
+  int_Str_Longint (L,Len,SS);
+  S:=SS;
+end;
+
+
+
 {
   $Log$
-  Revision 1.7  2001-05-27 14:28:03  florian
+  Revision 1.8  2001-07-08 21:00:18  peter
+    * various widestring updates, it works now mostly without charset
+      mapping supported
+
+  Revision 1.7  2001/05/27 14:28:03  florian
     + some procedures added
 
   Revision 1.6  2000/11/06 23:17:15  peter

rtl/linux/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by fpcmake v1.99.0 [2001/06/10]
+# Don't edit, this file is generated by fpcmake v1.99.0 [2001/06/28]
 #
 default: all
 override PATH:=$(subst \,/,$(PATH))
@@ -144,7 +144,7 @@ USELIBGGI=NO
 endif
 override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings $(LINUXUNIT) unix ports initc dos crt objects printer graph ggigraph sysutils typinfo math varutils cpu mmx getopts heaptrc lineinfo errors sockets gpm ipc serial terminfo dl dynlibs video mouse keyboard
 override TARGET_LOADERS+=prt0 dllprt0 cprt0 gprt0 cprt21 gprt21
-override TARGET_RSTS+=math varutils
+override TARGET_RSTS+=math varutils typeinfo
 override CLEAN_UNITS+=syslinux linux
 override INSTALL_FPCPACKAGE=y
 override COMPILER_INCLUDEDIR+=$(INC) $(PROCINC) $(UNIXINC)

rtl/linux/Makefile.fpc

@@ -14,7 +14,7 @@ units=$(SYSTEMUNIT) objpas strings \
       cpu mmx getopts heaptrc lineinfo \
       errors sockets gpm ipc serial terminfo dl dynlibs \
       video mouse keyboard
-rsts=math varutils
+rsts=math varutils typeinfo
 
 [require]
 nortl=y

tests/tbs/tb0349.pp

@@ -3,11 +3,30 @@ var
    p : pwidechar;
    c1,c2 : widechar;
    i : longint;
-
+   a : ansistring;
+   w : widestring;
+   err : boolean;
 begin
    p:=@c1;
    i:=0;
    c2:=p[i];
+
+   w:='hello';
+   a:=w;
+
+   writeln(a);
+   if a<>'hello' then
+    err:=true;
+   writeln(w);
+   if w<>'hello' then
+    err:=true;
+
    p:='';
    p:='hello';
+   writeln(widestring(p));
+   if widestring(p)<>'hello' then
+    err:=true;
+
+   if err then
+    halt(1);
 end.