+ ansistring to pchar type cast fixed

compiler/cg386cnv.pas

@@ -1039,12 +1039,54 @@ implementation
         p^.location.reference:=href;
       end;
 
+    procedure second_ansistring_to_pchar(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         l1,l2 : plabel;
+         hr : preference;
+
+      begin
+         p^.location.loc:=LOC_REGISTER;
+         getlabel(l1);
+         getlabel(l2);
+         case hp^.location.loc of
+            LOC_CREGISTER,LOC_REGISTER:
+              exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,S_L,0,
+                hp^.location.register)));
+            LOC_MEM,LOC_REFERENCE:
+              begin
+                 exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_L,0,
+                   newreference(hp^.location.reference))));
+                  del_reference(hp^.location.reference);
+                  p^.location.register:=getregister32;
+               end;
+         end;
+         emitl(A_JZ,l1);
+         if hp^.location.loc in [LOC_MEM,LOC_REFERENCE] then
+           exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(
+             hp^.location.reference),
+             p^.location.register)));
+         emitl(A_JMP,l2);
+         emitl(A_LABEL,l1);
+         new(hr);
+         reset_reference(hr^);
+         hr^.symbol:=stringdup('FPC_EMPTYCHAR');
+         exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,hr,
+           p^.location.register)));
+         emitl(A_LABEL,l2);
+      end;
+
+    procedure second_pchar_to_ansistring(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         p^.location.loc:=LOC_REGISTER;
+         internalerror(12121);
+      end;
 
     procedure second_nothing(p,hp : ptree;convtyp : tconverttype);
       begin
       end;
 
-
 {****************************************************************************
                              SecondTypeConv
 ****************************************************************************}
@@ -1077,7 +1119,9 @@ implementation
            second_proc_to_procvar,
            { is constant char to pchar, is done by firstpass }
            second_nothing,
-           second_load_smallset);
+           second_load_smallset,
+           second_ansistring_to_pchar,
+           second_pchar_to_ansistring);
 
       begin
          { this isn't good coding, I think tc_bool_2_int, shouldn't be }
@@ -1207,7 +1251,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.13  1998-08-28 10:56:56  peter
+  Revision 1.14  1998-08-28 12:51:39  florian
+    + ansistring to pchar type cast fixed
+
+  Revision 1.13  1998/08/28 10:56:56  peter
     * removed warnings
 
   Revision 1.12  1998/08/14 18:18:38  peter

compiler/pass_1.pas

@@ -550,7 +550,6 @@ unit pass_1;
                 b:=true;
              end
          else
-
            { ansi- and wide strings can be assigned to void pointers }
            if (def_from^.deftype=stringdef) and
              (pstringdef(def_from)^.string_typ in [st_ansistring,st_widestring]) and
@@ -562,6 +561,26 @@ unit pass_1;
                 b:=true;
              end
          else
+           { ansistrings can be assigned to pchar }
+           if is_ansistring(def_from) and
+             (def_to^.deftype=pointerdef) and
+             (ppointerdef(def_to)^.definition^.deftype=orddef) and
+             (porddef(ppointerdef(def_to)^.definition)^.typ=uchar) then
+             begin
+                doconv:=tc_ansistring_2_pchar;
+                b:=true;
+             end
+         else
+           { pchar can be assigned to ansistrings }
+           if ((def_from^.deftype=pointerdef) and
+             (ppointerdef(def_from)^.definition^.deftype=orddef) and
+             (porddef(ppointerdef(def_from)^.definition)^.typ=uchar)) and
+             is_ansistring(def_to) then
+             begin
+                doconv:=tc_pchar_2_ansistring;
+                b:=true;
+             end
+         else
 
          { procedure variable can be assigned to an void pointer }
          { Not anymore. Use the @ operator now.}
@@ -2441,6 +2460,7 @@ unit pass_1;
     procedure first_proc_to_procvar(var p : ptree);
 
       begin
+         { hmmm, I'am not sure if that is necessary (FK) }
          firstpass(p^.left);
          if codegenerror then
            exit;
@@ -2454,13 +2474,34 @@ unit pass_1;
          p^.location.loc:=LOC_REGISTER;
       end;
 
-        function is_procsym_load(p:Ptree):boolean;
+    procedure first_load_smallset(var p : ptree);
 
-        begin
+      begin
-           is_procsym_load:=((p^.treetype=loadn) and (p^.symtableentry^.typ=procsym)) or
+      end;
-                            ((p^.treetype=addrn) and (p^.left^.treetype=loadn)
+
-                            and (p^.left^.symtableentry^.typ=procsym)) ;
+    procedure first_pchar_to_ansistring(var p : ptree);
-        end;
+
+      begin
+         p^.location.loc:=LOC_REGISTER;
+         if p^.registers32<1 then
+           p^.registers32:=1;
+      end;
+
+    procedure first_ansistring_to_pchar(var p : ptree);
+
+      begin
+         p^.location.loc:=LOC_REGISTER;
+         if p^.registers32<1 then
+           p^.registers32:=1;
+      end;
+
+    function is_procsym_load(p:Ptree):boolean;
+
+      begin
+         is_procsym_load:=((p^.treetype=loadn) and (p^.symtableentry^.typ=procsym)) or
+                          ((p^.treetype=addrn) and (p^.left^.treetype=loadn)
+                          and (p^.left^.symtableentry^.typ=procsym)) ;
+      end;
 
    { change a proc call to a procload for assignment to a procvar }
    { this can only happen for proc/function without arguments }
@@ -2495,19 +2536,21 @@ unit pass_1;
               passproc:=passproc^.nextoverloaded;
             end;
        end;
+
     { Attention: do *** no ***  recursive call of firstpass }
     { because the child tree is always passed               }
 
-        procedure firsttypeconv(var p : ptree);
+  procedure firsttypeconv(var p : ptree);
 
-          var
+    var
-                 hp : ptree;
+           hp : ptree;
-                 aprocdef : pprocdef;
+           aprocdef : pprocdef;
-                 proctype : tdeftype;
+           proctype : tdeftype;
 
     const
-       firstconvert : array[tc_u8bit_2_s32bit..tc_cchar_charpointer] of
+       firstconvert : array[tconverttype] of
-         tfirstconvproc = (first_bigger_smaller,first_nothing,first_bigger_smaller,
+         tfirstconvproc = (first_nothing,first_nothing,
+                           first_bigger_smaller,first_nothing,first_bigger_smaller,
                            first_bigger_smaller,first_bigger_smaller,
                            first_bigger_smaller,first_bigger_smaller,
                            first_bigger_smaller,first_string_string,
@@ -2527,7 +2570,10 @@ unit pass_1;
                            first_int_real,first_real_fix,
                            first_fix_real,first_int_fix,first_real_real,
                            first_locmem,first_proc_to_procvar,
-                           first_cchar_charpointer);
+                           first_cchar_charpointer,
+                           first_load_smallset,
+                           first_ansistring_to_pchar,
+                           first_pchar_to_ansistring);
 
     begin
        aprocdef:=nil;
@@ -5280,7 +5326,10 @@ unit pass_1;
 end.
 {
   $Log$
-  Revision 1.64  1998-08-28 10:54:22  peter
+  Revision 1.65  1998-08-28 12:51:40  florian
+    + ansistring to pchar type cast fixed
+
+  Revision 1.64  1998/08/28 10:54:22  peter
     * fixed smallset generation from elements, it has never worked before!
 
   Revision 1.63  1998/08/24 10:05:39  florian

compiler/symdef.inc

@@ -21,10 +21,49 @@
 }
 
 {*************************************************************************************************************************
-                     TDEF (base class for defenitions)
+                     TDEF (base class for definitions)
 ****************************************************************************}
 
+    const
+       { if you change one of the following contants, }
+       { you have also to change the typinfo unit     }
+       tkUnknown       = 0;
+       tkInteger       = 1;
+       tkChar          = 2;
+       tkEnumeration   = 3;
+       tkFloat         = 4;
+       tkSet           = 6;
+       tkMethod        = 7;
+       tkSString       = 8;
+       tkString        = tkSString;
+       tkLString       = 9;
+       tkAString       = 10;
+       tkWString       = 11;
+       tkVariant       = 12;
+       tkArray         = 13;
+       tkRecord        = 14;
+       tkInterface     = 15;
+       tkClass         = 16;
+       tkObject        = 17;
+       tkWChar         = 18;
+
+       otSByte         = 0;
+       otUByte         = 1;
+       otSWord         = 2;
+       otUWord         = 3;
+       otSLong         = 4;
+       otULong         = 5;
+
+       ftSingle        = 0;
+       ftDouble        = 1;
+       ftExtended      = 2;
+       ftComp          = 3;
+       ftCurr          = 4;
+       ftFixed16       = 5;
+       ftFixed32       = 6;
+
     constructor tdef.init;
+
       begin
          deftype:=abstractdef;
          owner := nil;
@@ -395,7 +434,7 @@
          else
            writelong(len);
          case string_typ of
-          st_shortstring : current_ppu^.writeentry(ibstringdef);
+           st_shortstring : current_ppu^.writeentry(ibstringdef);
            st_longstring : current_ppu^.writeentry(iblongstringdef);
            st_ansistring : current_ppu^.writeentry(ibansistringdef);
            st_widestring : current_ppu^.writeentry(ibwidestringdef);
@@ -468,21 +507,20 @@
          case string_typ of
             st_ansistring:
               begin
-                 rttilist^.concat(new(pai_const,init_8bit(10)));
+                 rttilist^.concat(new(pai_const,init_8bit(tkAString)));
               end;
             st_widestring:
               begin
-                 rttilist^.concat(new(pai_const,init_8bit(11)));
+                 rttilist^.concat(new(pai_const,init_8bit(tkWString)));
               end;
             st_longstring:
               begin
-                 rttilist^.concat(new(pai_const,init_8bit(9)));
+                 rttilist^.concat(new(pai_const,init_8bit(tkLString)));
-                 rttilist^.concat(new(pai_const,init_32bit(len)));
               end;
             st_shortstring:
               begin
-                 rttilist^.concat(new(pai_const,init_8bit(8)));
+                 rttilist^.concat(new(pai_const,init_8bit(tkSString)));
-                 rttilist^.concat(new(pai_const,init_32bit(len)));
+                 rttilist^.concat(new(pai_const,init_8bit(len)));
               end;
          end;
       end;
@@ -584,7 +622,8 @@
 
       begin
          inherited generate_rtti;
-         rttilist^.concat(new(pai_const,init_8bit(255)));
+         rttilist^.concat(new(pai_const,init_8bit(tkEnumeration)));
+         rttilist^.concat(new(pai_const,init_8bit(0)));
       end;
 
 {*************************************************************************************************************************
@@ -803,9 +842,14 @@
 
     procedure tfloatdef.generate_rtti;
 
+      const
+         translate : array[tfloattype] of byte =
+           (ftFixed32,ftSingle,ftDouble,ftExtended,ftComp,ftFixed16);
+
       begin
          inherited generate_rtti;
-         rttilist^.concat(new(pai_const,init_8bit(255)));
+         rttilist^.concat(new(pai_const,init_8bit(tkFloat)));
+         rttilist^.concat(new(pai_const,init_8bit(translate[typ])));
       end;
 
 {*************************************************************************************************************************
@@ -2535,7 +2579,10 @@
 
 {
   $Log$
-  Revision 1.26  1998-08-25 12:42:44  pierre
+  Revision 1.27  1998-08-28 12:51:43  florian
+    + ansistring to pchar type cast fixed
+
+  Revision 1.26  1998/08/25 12:42:44  pierre
     * CDECL changed to CVAR for variables
       specifications are read in structures also
     + started adding GPC compatibility mode ( option  -Sp)

compiler/tree.pas

@@ -146,7 +146,8 @@ unit tree;
                       tc_int_2_real,tc_real_2_fix,
                       tc_fix_2_real,tc_int_2_fix,tc_real_2_real,
                       tc_chararray_2_string,
-                      tc_proc2procvar,tc_cchar_charpointer,tc_load_smallset);
+                      tc_proc2procvar,tc_cchar_charpointer,tc_load_smallset,
+                      tc_ansistring_2_pchar,tc_pchar_2_ansistring);
 
        { allows to determine which elementes are to be replaced }
        tdisposetyp = (dt_nothing,dt_leftright,dt_left,
@@ -1554,7 +1555,10 @@ unit tree;
 end.
 {
   $Log$
-  Revision 1.32  1998-08-28 10:54:25  peter
+  Revision 1.33  1998-08-28 12:51:44  florian
+    + ansistring to pchar type cast fixed
+
+  Revision 1.32  1998/08/28 10:54:25  peter
     * fixed smallset generation from elements, it has never worked before!
 
   Revision 1.31  1998/08/21 14:08:58  pierre