+ Val/str/read/write support for enumeration types.

git-svn-id: branches/fpc_2_3@6546 -

compiler/ncginl.pas

@@ -715,22 +715,37 @@ implementation
     procedure Tcginlinenode.second_get_caller_frame;
 
     var frame_ref:Treference;
+        frame_reg:Tregister;
+        use_frame_pointer:boolean;
 
     begin
-      if current_procinfo.framepointer=NR_STACK_POINTER_REG then
+      if left<>nil then
+        begin
+          secondpass(left);
+          if left.location.loc=LOC_CONSTANT then
+            use_frame_pointer:=true
+          else
+            begin
+              location_force_reg(current_asmdata.currasmlist,left.location,OS_ADDR,false);
+              frame_reg:=left.location.register;
+              use_frame_pointer:=false;
+            end
+        end
+      else
+        begin
+          use_frame_pointer:=current_procinfo.framepointer=NR_STACK_POINTER_REG;
+          frame_reg:=current_procinfo.framepointer;
+        end;
+
+      if use_frame_pointer then
         begin
           location_reset(location,LOC_CREGISTER,OS_ADDR);
           location.register:=NR_FRAME_POINTER_REG;
-{          location_reset(location,LOC_REGISTER,OS_ADDR);
-          location.register:=cg.getaddressregister(current_asmdata.currasmlist);
-          cg.a_load_reg_reg(current_asmdata.currasmlist,OS_ADDR,OS_ADDR,NR_FRAME_POINTER_REG,location.register);}
         end
       else
         begin
-          location_reset(location,LOC_REGISTER,OS_ADDR);
-          location.register:=cg.getaddressregister(current_asmdata.currasmlist);
-          reference_reset_base(frame_ref,current_procinfo.framepointer,0);
-          cg.a_load_ref_reg(current_asmdata.currasmlist,OS_ADDR,OS_ADDR,frame_ref,location.register);
+          location_reset(location,LOC_REFERENCE,OS_ADDR);
+          location.reference.base:=frame_reg;
         end;
     end;
 
@@ -743,7 +758,7 @@ implementation
         begin
           location_reset(location,LOC_REGISTER,OS_ADDR);
           location.register:=cg.getaddressregister(current_asmdata.currasmlist);
-          reference_reset_base(frame_ref,NR_STACK_POINTER_REG,0);
+          reference_reset_base(frame_ref,NR_STACK_POINTER_REG,{current_procinfo.calc_stackframe_size}tg.lasttemp);
           cg.a_load_ref_reg(current_asmdata.currasmlist,OS_ADDR,OS_ADDR,frame_ref,location.register);
         end
       else

compiler/ncgld.pas

@@ -1059,7 +1059,14 @@ implementation
     procedure tcgrttinode.pass_generate_code;
       begin
         location_reset(location,LOC_CREFERENCE,OS_NO);
-        location.reference.symbol:=RTTIWriter.get_rtti_label(rttidef,rttitype);
+        case rttidatatype of
+          rdt_normal:
+            location.reference.symbol:=RTTIWriter.get_rtti_label(rttidef,rttitype);
+          rdt_o2s:
+            location.reference.symbol:=RTTIWriter.get_rtti_label_o2s(rttidef,rttitype);
+          rdt_s2o:
+            location.reference.symbol:=RTTIWriter.get_rtti_label_s2o(rttidef,rttitype);
+        end;
       end;
 
 

compiler/ncgrtti.pas

@@ -39,6 +39,7 @@ interface
         function  fields_count(st:tsymtable;rt:trttitype):longint;
         procedure fields_write_rtti(st:tsymtable;rt:trttitype);
         procedure fields_write_rtti_data(st:tsymtable;rt:trttitype);
+        procedure write_rtti_extrasyms(def:Tdef;rt:Trttitype;mainrtti:Tasmsymbol);
         procedure published_write_rtti(st:tsymtable;rt:trttitype);
         function  published_properties_count(st:tsymtable):longint;
         procedure published_properties_write_rtti_data(propnamelist:TFPHashObjectList;st:tsymtable);
@@ -50,6 +51,8 @@ interface
       public
         procedure write_rtti(def:tdef;rt:trttitype);
         function  get_rtti_label(def:tdef;rt:trttitype):tasmsymbol;
+        function  get_rtti_label_o2s(def:tdef;rt:trttitype):tasmsymbol;
+        function  get_rtti_label_s2o(def:tdef;rt:trttitype):tasmsymbol;
       end;
 
     var
@@ -389,7 +392,7 @@ implementation
           current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkEnumeration));
           write_rtti_name(def);
 {$ifdef cpurequiresproperalignment}
-          current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
+          current_asmdata.asmlists[al_rtti].concat(Cai_align.Create(sizeof(TConstPtrUInt)));
 {$endif cpurequiresproperalignment}
           case longint(def.size) of
             1 :
@@ -400,7 +403,7 @@ implementation
               current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(otULong));
           end;
 {$ifdef cpurequiresproperalignment}
-          current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
+          current_asmdata.asmlists[al_rtti].concat(Cai_align.Create(sizeof(TConstPtrUInt)));
 {$endif cpurequiresproperalignment}
           current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(def.min));
           current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(def.max));
@@ -821,6 +824,235 @@ implementation
         end;
       end;
 
+    procedure TRTTIWriter.write_rtti_extrasyms(def:Tdef;rt:Trttitype;mainrtti:Tasmsymbol);
+
+        procedure enumdef_rtti_ord2stringindex(def:Tenumdef);
+
+        var rttilab:Tasmsymbol;
+            t:Tenumsym;
+            syms:^Tenumsym;
+            offsets:^longint;
+            sym_count,sym_alloc:longint;
+            h,i,p,o,st:longint;
+            mode:(lookup,search); {Modify with care, ordinal value of enum is written.}
+            r:single;             {Must be real type because of integer overflow risk.}
+
+        begin
+          {Random access needed, put in array.}
+          getmem(syms,64*sizeof(Tenumsym));
+          getmem(offsets,64*sizeof(longint));
+          sym_count:=0;
+          sym_alloc:=64;
+          st:=0;
+          t:=Tenumsym(def.firstenum);
+          while assigned(t) do
+            begin
+              if sym_count>=sym_alloc then
+                begin
+                  reallocmem(syms,2*sym_alloc*sizeof(Tenumsym));
+                  reallocmem(offsets,2*sym_alloc*sizeof(longint));
+                  sym_alloc:=sym_alloc*2;
+                end;
+              syms[sym_count]:=t;
+              offsets[sym_count]:=st;
+              inc(sym_count);
+              st:=st+length(t.realname)+1;
+              t:=t.nextenum;
+            end;
+          {Sort the syms by enum value}
+          if sym_count>=2 then
+            begin
+              p:=1;
+              while 2*p<sym_count do
+                p:=2*p;
+              while p<>0 do
+                begin
+                  for h:=p to sym_count-1 do
+                    begin
+                      i:=h;
+                      t:=syms[i];
+                      o:=offsets[i];
+                      repeat
+                        if syms[i-p].value<=t.value then
+                          break;
+                        syms[i]:=syms[i-p];
+                        offsets[i]:=offsets[i-p];
+                        dec(i,p);
+                      until i<p;
+                      syms[i]:=t;
+                      offsets[i]:=o;
+                    end;
+                  p:=p shr 1;
+                end;
+            end;
+          {Decide wether a lookup array is size efficient.}
+          mode:=lookup;
+          if sym_count>0 then
+            begin
+              i:=1;
+              r:=0;
+              h:=syms[0].value; {Next expected enum value is min.}
+              while i<sym_count do
+                begin
+                  {Calculate size of hole between values. Avoid integer overflows.}
+                  r:=r+(single(syms[i].value)-single(h))-1;
+                  h:=syms[i].value;
+                  inc(i);
+                end;
+              if r>sym_count then
+                mode:=search; {Don't waste more than 50% space.}
+            end;
+          {Calculate start of string table.}
+          st:=1;
+          if assigned(def.typesym) then
+            inc(st,length(def.typesym.realname)+1)
+          else
+            inc(st);
+          {$ifdef cpurequiresproperalignment}
+          align(st,sizeof(Tconstptruint);
+          {$endif}
+          inc(st);
+          {$ifdef cpurequiresproperalignment}
+          align(st,sizeof(Tconstptruint);
+          {$endif}
+          inc(st,8+sizeof(aint));
+          { write rtti data }
+          with current_asmdata do
+            begin
+              rttilab:=defineasmsymbol(Tstoreddef(def).rtti_mangledname(rt)+'_o2s',AB_GLOBAL,AT_DATA);
+              maybe_new_object_file(asmlists[al_rtti]);
+              new_section(asmlists[al_rtti],sec_rodata,rttilab.name,const_align(sizeof(aint)));
+              asmlists[al_rtti].concat(Tai_symbol.create_global(rttilab,0));
+              asmlists[al_rtti].concat(Tai_const.create_32bit(longint(mode)));
+              if mode=lookup then
+                begin
+                  o:=syms[0].value;  {Start with min value.}
+                  for i:=0 to sym_count-1 do
+                    begin
+                      while o<syms[i].value do
+                        begin
+                          asmlists[al_rtti].concat(Tai_const.create_aint(0));
+                          inc(o);
+                        end;
+                      inc(o);
+                      asmlists[al_rtti].concat(Tai_const.create_sym_offset(mainrtti,st+offsets[i]));
+                    end;
+                end
+              else
+                begin
+                  asmlists[al_rtti].concat(Tai_const.create_32bit(sym_count));
+                  for i:=0 to sym_count-1 do
+                    begin
+                      asmlists[al_rtti].concat(Tai_const.create_32bit(syms[i].value));
+                      asmlists[al_rtti].concat(Tai_const.create_sym_offset(mainrtti,st+offsets[i]));
+                    end;
+                end;
+              asmlists[al_rtti].concat(Tai_symbol_end.create(rttilab));
+            end;
+          dispose(syms);
+          dispose(offsets);
+        end;
+
+        procedure enumdef_rtti_string2ordindex(def:Tenumdef);
+
+        var rttilab:Tasmsymbol;
+            t:Tenumsym;
+            syms:^Tenumsym;
+            offsets:^longint;
+            sym_count,sym_alloc:longint;
+            h,i,p,o,st:longint;
+
+        begin
+          {Random access needed, put in array.}
+          getmem(syms,64*sizeof(Tenumsym));
+          getmem(offsets,64*sizeof(longint));
+          sym_count:=0;
+          sym_alloc:=64;
+          st:=0;
+          t:=Tenumsym(def.firstenum);
+          while assigned(t) do
+            begin
+              if sym_count>=sym_alloc then
+                begin
+                  reallocmem(syms,2*sym_alloc*sizeof(Tenumsym));
+                  reallocmem(offsets,2*sym_alloc*sizeof(longint));
+                  sym_alloc:=sym_alloc*2;
+                end;
+              syms[sym_count]:=t;
+              offsets[sym_count]:=st;
+              inc(sym_count);
+              st:=st+length(t.realname)+1;
+              t:=t.nextenum;
+            end;
+          {Sort the syms by enum name}
+          if sym_count>=2 then
+            begin
+              p:=1;
+              while 2*p<sym_count do
+                p:=2*p;
+              while p<>0 do
+                begin
+                  for h:=p to sym_count-1 do
+                    begin
+                      i:=h;
+                      t:=syms[i];
+                      o:=offsets[i];
+                      repeat
+                        if syms[i-p].name<=t.name then
+                          break;
+                        syms[i]:=syms[i-p];
+                        offsets[i]:=offsets[i-p];
+                        dec(i,p);
+                      until i<p;
+                      syms[i]:=t;
+                      offsets[i]:=o;
+                    end;
+                  p:=p shr 1;
+                end;
+            end;
+          {Calculate start of string table.}
+          st:=1;
+          if assigned(def.typesym) then
+            inc(st,length(def.typesym.realname)+1)
+          else
+            inc(st);
+          {$ifdef cpurequiresproperalignment}
+          align(st,sizeof(Tconstptruint);
+          {$endif}
+          inc(st);
+          {$ifdef cpurequiresproperalignment}
+          align(st,sizeof(Tconstptruint);
+          {$endif}
+          inc(st,8+sizeof(aint));
+          { write rtti data }
+          with current_asmdata do
+            begin
+              rttilab:=defineasmsymbol(Tstoreddef(def).rtti_mangledname(rt)+'_s2o',AB_GLOBAL,AT_DATA);
+              maybe_new_object_file(asmlists[al_rtti]);
+              new_section(asmlists[al_rtti],sec_rodata,rttilab.name,const_align(sizeof(aint)));
+              asmlists[al_rtti].concat(Tai_symbol.create_global(rttilab,0));
+              asmlists[al_rtti].concat(Tai_const.create_32bit(sym_count));
+              for i:=0 to sym_count-1 do
+                begin
+                  asmlists[al_rtti].concat(Tai_const.create_32bit(syms[i].value));
+                  asmlists[al_rtti].concat(Tai_const.create_sym_offset(mainrtti,st+offsets[i]));
+                end;
+              asmlists[al_rtti].concat(Tai_symbol_end.create(rttilab));
+            end;
+          dispose(syms);
+          dispose(offsets);
+        end;
+
+    begin
+      case def.typ of
+        enumdef:
+          if rt=fullrtti then
+            begin
+              enumdef_rtti_ord2stringindex(Tenumdef(def));
+              enumdef_rtti_string2ordindex(Tenumdef(def));
+            end;
+      end;
+    end;
 
     procedure TRTTIWriter.write_child_rtti_data(def:tdef;rt:trttitype);
       begin
@@ -873,6 +1105,7 @@ implementation
         current_asmdata.asmlists[al_rtti].concat(Tai_symbol.Create_global(rttilab,0));
         write_rtti_data(def,rt);
         current_asmdata.asmlists[al_rtti].concat(Tai_symbol_end.Create(rttilab));
+        write_rtti_extrasyms(def,rt,rttilab);
       end;
 
 
@@ -881,5 +1114,15 @@ implementation
         result:=current_asmdata.RefAsmSymbol(def.rtti_mangledname(rt));
       end;
 
+    function TRTTIWriter.get_rtti_label_o2s(def:tdef;rt:trttitype):tasmsymbol;
+      begin
+        result:=current_asmdata.RefAsmSymbol(def.rtti_mangledname(rt)+'_o2s');
+      end;
+
+    function TRTTIWriter.get_rtti_label_s2o(def:tdef;rt:trttitype):tasmsymbol;
+      begin
+        result:=current_asmdata.RefAsmSymbol(def.rtti_mangledname(rt)+'_s2o');
+      end;
+
 end.
 

compiler/ncnv.pas

@@ -1200,7 +1200,7 @@ implementation
       begin
         result := ccallnode.createinternres(
           'fpc_variant_to_dynarray',
-          ccallparanode.create(caddrnode.create_internal(crttinode.create(tstoreddef(resultdef),initrtti)),
+          ccallparanode.create(caddrnode.create_internal(crttinode.create(tstoreddef(resultdef),initrtti,rdt_normal)),
             ccallparanode.create(left,nil)
           ),resultdef);
         typecheckpass(result);
@@ -1213,7 +1213,7 @@ implementation
       begin
         result := ccallnode.createinternres(
           'fpc_dynarray_to_variant',
-          ccallparanode.create(caddrnode.create_internal(crttinode.create(tstoreddef(left.resultdef),initrtti)),
+          ccallparanode.create(caddrnode.create_internal(crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
             ccallparanode.create(ctypeconvnode.create_explicit(left,voidpointertype),nil)
           ),resultdef);
         typecheckpass(result);
@@ -1306,7 +1306,7 @@ implementation
                ccallparanode.create(cordconstnode.create
                   (1,s32inttype,true),
                ccallparanode.create(caddrnode.create_internal
-                  (crttinode.create(tstoreddef(resultdef),initrtti)),
+                  (crttinode.create(tstoreddef(resultdef),initrtti,rdt_normal)),
                ccallparanode.create(
                  ctypeconvnode.create_internal(
                    ctemprefnode.create(temp),voidpointertype),

compiler/nld.pas

@@ -33,6 +33,8 @@ interface
        symconst,symbase,symtype,symsym,symdef;
 
     type
+       Trttidatatype=(rdt_normal,rdt_o2s,rdt_s2o);
+
        tloadnode = class(tunarynode)
        protected
           procdef : tprocdef;
@@ -116,7 +118,8 @@ interface
           rttitype : trttitype;
           rttidef : tstoreddef;
           rttidefderef : tderef;
-          constructor create(def:tstoreddef;rt:trttitype);virtual;
+          rttidatatype : Trttidatatype;
+          constructor create(def:tstoreddef;rt:trttitype;dt:Trttidatatype);virtual;
           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           procedure buildderefimpl;override;
@@ -595,7 +598,7 @@ implementation
            (right.nodetype=niln) then
          begin
            hp:=ccallparanode.create(caddrnode.create_internal
-                   (crttinode.create(tstoreddef(left.resultdef),initrtti)),
+                   (crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
                ccallparanode.create(ctypeconvnode.create_internal(left,voidpointertype),nil));
            result := ccallnode.createintern('fpc_dynarray_clear',hp);
            left:=nil;
@@ -1142,11 +1145,12 @@ implementation
 *****************************************************************************}
 
 
-    constructor trttinode.create(def:tstoreddef;rt:trttitype);
+    constructor trttinode.create(def:tstoreddef;rt:trttitype;dt:Trttidatatype);
       begin
          inherited create(rttin);
          rttidef:=def;
          rttitype:=rt;
+         rttidatatype:=dt;
       end;
 
 

compiler/nutils.pas

@@ -498,7 +498,7 @@ implementation
                   ccallparanode.create(
                       caddrnode.create_internal(
                           crttinode.create(
-                              tstoreddef(p.resultdef),initrtti)),
+                              tstoreddef(p.resultdef),initrtti,rdt_normal)),
                   ccallparanode.create(
                       caddrnode.create_internal(p),
                   nil)));
@@ -541,7 +541,7 @@ implementation
                 ccallparanode.create(
                     caddrnode.create_internal(
                         crttinode.create(
-                            tstoreddef(p.resultdef),initrtti)),
+                            tstoreddef(p.resultdef),initrtti,rdt_normal)),
                 ccallparanode.create(
                     caddrnode.create_internal(p),
                 nil)));

compiler/pinline.pas

@@ -391,7 +391,7 @@ implementation
             if tpointerdef(p1.resultdef).pointeddef.needs_inittable then
              begin
                para := ccallparanode.create(caddrnode.create_internal(crttinode.create
-                          (tstoreddef(tpointerdef(p1.resultdef).pointeddef),initrtti)),
+                          (tstoreddef(tpointerdef(p1.resultdef).pointeddef),initrtti,rdt_normal)),
                        ccallparanode.create(ctemprefnode.create
                           (temp),nil));
                addstatement(newstatement,ccallnode.createintern('fpc_initialize',para));
@@ -563,7 +563,7 @@ implementation
                    ccallparanode.create(cordconstnode.create
                       (counter,s32inttype,true),
                    ccallparanode.create(caddrnode.create_internal
-                      (crttinode.create(tstoreddef(destppn.resultdef),initrtti)),
+                      (crttinode.create(tstoreddef(destppn.resultdef),initrtti,rdt_normal)),
                    ccallparanode.create(ctypeconvnode.create_internal(destppn,voidpointertype),nil))));
             addstatement(newstatement,ccallnode.createintern('fpc_dynarray_setlength',npara));
             addstatement(newstatement,ctempdeletenode.create(temp));
@@ -657,7 +657,7 @@ implementation
                   ccallparanode.create(ctypeconvnode.create
                      (ppn.left,s32inttype),
                   ccallparanode.create(caddrnode.create_internal
-                     (crttinode.create(tstoreddef(destppn.left.resultdef),initrtti)),
+                     (crttinode.create(tstoreddef(destppn.left.resultdef),initrtti,rdt_normal)),
                   ccallparanode.create(caddrnode.create_internal
                      (destppn.left),nil))));
            newblock:=ccallnode.createintern('fpc_finalize_array',npara);
@@ -750,7 +750,7 @@ implementation
             npara:=ccallparanode.create(highppn,
                    ccallparanode.create(lowppn,
                    ccallparanode.create(caddrnode.create_internal
-                      (crttinode.create(tstoreddef(ppn.left.resultdef),initrtti)),
+                      (crttinode.create(tstoreddef(ppn.left.resultdef),initrtti,rdt_normal)),
                    ccallparanode.create
                       (ctypeconvnode.create_internal(ppn.left,voidpointertype),nil))));
             copynode:=ccallnode.createinternres('fpc_dynarray_copy',npara,ppn.left.resultdef);

rtl/inc/astrings.inc

@@ -863,6 +863,14 @@ begin
   s:=ss;
 end;
 
+procedure fpc_ansistr_enum(ordinal,len:sizeint;typinfo,o2sindex:pointer;out s:shortstring);[public,alias:'FPC_ANSISTR_ENUM'];compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
+
+var ss:shortstring;
+
+begin
+  fpc_shortstr_enum(ordinal,len,typinfo,o2sindex,ss);
+  s:=ss;
+end;
 
 {$ifdef FPC_HAS_STR_CURRENCY}
 procedure fpc_AnsiStr_Currency(c : currency;len,fr : SizeInt;out s : ansistring);[public,alias:'FPC_ANSISTR_CURRENCY']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}

rtl/inc/compproc.inc

@@ -74,6 +74,7 @@ procedure fpc_dynarray_setlength(var p : pointer;pti : pointer; dimcount : dword
 procedure fpc_ShortStr_sint(v : valsint;len : SizeInt;out s : shortstring); compilerproc;
 procedure fpc_shortstr_uint(v : valuint;len : SizeInt;out s : shortstring); compilerproc;
 procedure fpc_ShortStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : shortstring); compilerproc;
+procedure fpc_shortstr_enum(ordinal,len:sizeint;typinfo,o2sindex:pointer;out s:shortstring);compilerproc;
 procedure fpc_ShortStr_Currency(c : currency; len,f : SizeInt; out s : shortstring); compilerproc;
 
 procedure fpc_chararray_sint(v : valsint;len : SizeInt;out a : array of char); compilerproc;
@@ -122,6 +123,7 @@ procedure fpc_chararray_Currency(c : Currency;len,fr : SizeInt;out a : array of
 Function fpc_Val_Real_ShortStr(const s : shortstring; out code : ValSInt): ValReal; compilerproc;
 Function fpc_Val_SInt_ShortStr(DestSize: SizeInt; Const S: ShortString; out Code: ValSInt): ValSInt; compilerproc;
 Function fpc_Val_UInt_Shortstr(Const S: ShortString; out Code: ValSInt): ValUInt; compilerproc;
+function fpc_val_enum_shortstr(s2oindex:pointer;const s:shortstring;out code:valsint):longint; compilerproc;
 Function fpc_Val_Currency_ShortStr(const s : shortstring; out Code : ValSInt): currency; compilerproc;
 {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
 Function fpc_Val_Real_AnsiStr(Const S : AnsiString; out Code : ValSInt): ValReal; compilerproc;
@@ -131,8 +133,9 @@ Function fpc_Val_Currency_AnsiStr(Const S : AnsiString; out Code : ValSInt): Cur
 {$endif FPC_HAS_FEATURE_ANSISTRINGS}
 {$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
 Function fpc_Val_Real_WideStr(Const S : WideString; out Code : ValSInt): ValReal; compilerproc;
-Function fpc_Val_UInt_WideStr (Const S : WideString; out Code : ValSInt): ValUInt; compilerproc;
 Function fpc_Val_SInt_WideStr (DestSize: SizeInt; Const S : WideString; out Code : ValSInt): ValSInt; compilerproc;
+Function fpc_Val_UInt_WideStr (Const S : WideString; out Code : ValSInt): ValUInt; compilerproc;
+function fpc_val_enum_widestr(s2oindex:pointer;const s:widestring;out code:valsint):longint;compilerproc;
 Function fpc_Val_Currency_WideStr(Const S : WideString; out Code : ValSInt): Currency; compilerproc;
 {$endif FPC_HAS_FEATURE_WIDESTRINGS}
 {$ifndef CPU64}
@@ -248,6 +251,7 @@ procedure fpc_write_text_qword(len : longint;var t : text;q : qword); compilerpr
 procedure fpc_write_text_int64(len : longint;var t : text;i : int64); compilerproc;
 {$endif CPU64}
 Procedure fpc_Write_Text_Float(rt,fixkomma,Len : Longint;var t : Text;r : ValReal); compilerproc;
+procedure fpc_write_text_enum(typinfo,o2sindex:pointer;len:sizeint;var t:text;ordinal:longint); compilerproc;
 {$ifdef FPC_HAS_STR_CURRENCY}
 Procedure fpc_Write_Text_Currency(fixkomma,Len : Longint;var t : Text;c : Currency); compilerproc;
 {$endif FPC_HAS_STR_CURRENCY}
@@ -282,6 +286,7 @@ Procedure fpc_Read_Text_Char(var f : Text; out c : char); compilerproc;
 Procedure fpc_Read_Text_SInt(var f : Text; out l :ValSInt); compilerproc;
 Procedure fpc_Read_Text_UInt(var f : Text; out u :ValUInt); compilerproc;
 Procedure fpc_Read_Text_Float(var f : Text; out v :ValReal); compilerproc;
+procedure fpc_read_text_enum(s2oindex:pointer;var t:text;out ordinal:longint); compilerproc;
 procedure fpc_Read_Text_Currency(var f : Text; out v : Currency); compilerproc;
 {$ifndef CPU64}
 Procedure fpc_Read_Text_QWord(var f : text; out q : qword); compilerproc;

rtl/inc/sstrings.inc

@@ -356,20 +356,20 @@ end;
 
 {$ifndef CPU64}
 
-  procedure fpc_shortstr_qword(v : qword;len : longint;out s : shortstring);[public,alias:'FPC_SHORTSTR_QWORD']; compilerproc;
-    begin
-       int_str(v,s);
-       if length(s)<len then
-         s:=space(len-length(s))+s;
-    end;
+procedure fpc_shortstr_qword(v : qword;len : longint;out s : shortstring);[public,alias:'FPC_SHORTSTR_QWORD']; compilerproc;
+begin
+  int_str(v,s);
+  if length(s)<len then
+    s:=space(len-length(s))+s;
+end;
 
 
-  procedure fpc_shortstr_int64(v : int64;len : longint;out s : shortstring);[public,alias:'FPC_SHORTSTR_INT64'];  compilerproc;
-    begin
-       int_str(v,s);
-       if length(s)<len then
-         s:=space(len-length(s))+s;
-    end;
+procedure fpc_shortstr_int64(v : int64;len : longint;out s : shortstring);[public,alias:'FPC_SHORTSTR_INT64'];  compilerproc;
+begin
+  int_str(v,s);
+  if length(s)<len then
+    s:=space(len-length(s))+s;
+end;
 
 {$endif CPU64}
 
@@ -380,12 +380,94 @@ end;
 
 {$I real2str.inc}
 
-procedure fpc_ShortStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_FLOAT']; compilerproc;
+procedure fpc_shortstr_float(d : ValReal;len,fr,rt : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_FLOAT']; compilerproc;
 begin
   str_real(len,fr,d,treal_type(rt),s);
 end;
 
-procedure fpc_ShortStr_Currency(c : currency; len,f : SizeInt; out s : shortstring);[public,alias:'FPC_SHORTSTR_CURRENCY']; compilerproc;
+procedure fpc_shortstr_enum(ordinal,len:sizeint;typinfo,o2sindex:pointer;out s:shortstring);[public,alias:'FPC_SHORTSTR_ENUM'];compilerproc;
+
+type  Ptypeinfo=^Ttypeinfo;
+      Ttypeinfo=record
+        kind:byte;
+        name:shortstring;
+       end;
+
+      Penuminfo=^Tenuminfo;
+      Tenuminfo={$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
+        ordtype:byte;
+        minvalue,maxvalue:longint;
+        basetype:pointer;
+        namelist:shortstring;
+      end;
+
+      Tsorted_array={$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
+        o:longint;
+        s:Pstring;
+      end;
+
+var e:Penuminfo;
+    p:Pstring;
+    l,h,m:cardinal;
+    sorted_array:^Tsorted_array;
+    i,spaces:byte;
+
+label error;
+
+begin
+  if Pcardinal(o2sindex)^=0 then
+    begin
+      {The compiler did generate a lookup table.}
+      with Penuminfo(Pbyte(typinfo)+2+length(Ptypeinfo(typinfo)^.name))^ do 
+        begin
+          if (ordinal<minvalue) or (ordinal>maxvalue) then
+            goto error;  {Invalid ordinal value for this enum.}
+          dec(ordinal,minvalue);
+        end;
+      {Get the address of the string.}
+      p:=Pshortstring((PPpointer(o2sindex)+1+ordinal)^);
+      if p=nil then
+        goto error;      {Invalid ordinal value for this enum.}
+      s:=p^;
+    end
+  else
+    begin
+      {The compiler did generate a sorted array of (ordvalue,Pstring) tuples.}
+      sorted_array:=pointer(Pcardinal(o2sindex)+2);
+      {Use a binary search to get the string.}
+      l:=0;
+      h:=(Pcardinal(o2sindex)+1)^-1;
+      repeat
+        m:=(l+h) div 2;
+        if ordinal>sorted_array[m].o then
+          l:=m+1
+        else if ordinal<sorted_array[m].o then
+          h:=m-1
+        else
+          break;
+        if l>h then
+          goto error; {Ordinal value not found? Kaboom.}
+      until false;
+      s:=sorted_array[m].s^;
+    end;
+  {Pad the string with spaces if necessary.}
+  if len>length(s) then
+    begin
+      spaces:=len-length(s);
+      for i:=1 to spaces do
+        s[length(s)+i]:=' ';
+      inc(byte(s[0]),spaces);
+    end;
+  exit;
+error:
+  {Call runtime error in a central place, this saves space.}
+  runerror(107);
+end;
+
+{ also define alias for internal use in the system unit }
+procedure fpc_shortstr_enum(ordinal,len:sizeint;typinfo,o2sindex:pointer;out s:shortstring);external name 'FPC_SHORTSTR_ENUM';
+
+procedure fpc_shortstr_currency(c : currency; len,f : SizeInt; out s : shortstring);[public,alias:'FPC_SHORTSTR_CURRENCY']; compilerproc;
 const
   MinLen = 8; { Minimal string length in scientific format }
 
@@ -794,38 +876,20 @@ end;
 {$ifndef CPU64}
 
   Function fpc_val_int64_shortstr(Const S: ShortString; out Code: ValSInt): Int64; [public, alias:'FPC_VAL_INT64_SHORTSTR']; compilerproc;
-   type
-     QWordRec = packed record
-       l1,l2: longint;
-     end;
 
-    var
-       u, temp, prev, maxint64, maxqword : qword;
+  var  u, temp, prev : qword;
        base : byte;
        negative : boolean;
 
+  const maxint64=int64($7fffffffffffffff);
+        maxqword=qword($ffffffffffffffff);
+
   begin
     fpc_val_int64_shortstr := 0;
     Temp:=0;
     Code:=InitVal(s,negative,base);
     if Code>length(s) then
      exit;
-    { high(int64) produces 0 in version 1.0 (JM) }
-    with qwordrec(maxint64) do
-      begin
-{$ifdef ENDIAN_LITTLE}
-        l1 := longint($ffffffff);
-        l2 := $7fffffff;
-{$else ENDIAN_LITTLE}
-        l1 := $7fffffff;
-        l2 := longint($ffffffff);
-{$endif ENDIAN_LITTLE}
-      end;
-    with qwordrec(maxqword) do
-      begin
-        l1 := longint($ffffffff);
-        l2 := longint($ffffffff);
-      end;
 
     while Code<=Length(s) do
      begin
@@ -859,23 +923,18 @@ end;
 
 
   Function fpc_val_qword_shortstr(Const S: ShortString; out Code: ValSInt): QWord; [public, alias:'FPC_VAL_QWORD_SHORTSTR']; compilerproc;
-    type qwordrec = packed record
-      l1,l2: longint;
-    end;
-    var
-       u, prev, maxqword: QWord;
+
+  var  u, prev: QWord;
        base : byte;
        negative : boolean;
+
+  const maxqword=word($ffffffffffffffff);
+
   begin
     fpc_val_qword_shortstr:=0;
     Code:=InitVal(s,negative,base);
     If Negative or (Code>length(s)) Then
       Exit;
-    with qwordrec(maxqword) do
-      begin
-        l1 := longint($ffffffff);
-        l2 := longint($ffffffff);
-      end;
     while Code<=Length(s) do
      begin
        case s[Code] of
@@ -1029,8 +1088,60 @@ begin
   code:=0;
 end;
 
+function fpc_val_enum_shortstr(s2oindex:pointer;const s:shortstring;out code:valsint):longint; [public, alias:'FPC_VAL_ENUM_SHORTSTR']; compilerproc;
+
+type  Tsorted_array={$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
+        o:longint;
+        s:Pstring;
+      end;
+
+var l,h,m:cardinal;
+    sorted_array:^Tsorted_array;
+    spaces:byte;
+    t:shortstring;
+
+label error;
+
+begin
+  {Val for numbers accepts spaces at the start, so lets do the same
+   for enums. Skip spaces at the start of the string.}
+  spaces:=1;
+  while (spaces<=length(s)) and (s[spaces]=' ')  do
+    inc(spaces);
+  t:=upcase(copy(s,spaces,255));
+  sorted_array:=pointer(Pcardinal(s2oindex)+1);
+  {Use a binary search to get the string.}
+  l:=1;
+  h:=Pcardinal(s2oindex)^;
+  repeat
+    m:=(l+h) div 2;
+    if t>upcase(sorted_array[m-1].s^) then
+      l:=m+1
+    else if t<upcase(sorted_array[m-1].s^) then
+      h:=m-1
+    else
+      break;
+    if l>h then
+      goto error;
+  until false;
+  fpc_val_enum_shortstr:=sorted_array[m-1].o;
+  exit;
+error:
+  {Not found. Find first error position. Take care of the string length.}
+  code:=1;
+  while (code<=length(s)) and (s[code]=sorted_array[m].s^[code]) do
+    inc(code);
+  if code>length(s) then
+    code:=length(s)+1;
+  inc(code,spaces-1); {Add skipped spaces again.}
+  {The result of val in case of error is undefined, don't assign a function
+   result.}
+end;
+
+{Redeclare fpc_val_enum_shortstr for internal use in the system unit.}
+function fpc_val_enum_shortstr(s2oindex:pointer;const s:shortstring;out code:valsint):longint;external name 'FPC_VAL_ENUM_SHORTSTR';
 
-Function fpc_Val_Currency_ShortStr(const s : shortstring; out Code : ValSInt): currency; [public, alias:'FPC_VAL_CURRENCY_SHORTSTR']; compilerproc;
+function fpc_Val_Currency_ShortStr(const s : shortstring; out Code : ValSInt): currency; [public, alias:'FPC_VAL_CURRENCY_SHORTSTR']; compilerproc;
 const
   MaxInt64 : Int64  = $7FFFFFFFFFFFFFFF;
   Int64Edge : Int64 = ($7FFFFFFFFFFFFFFF - 10) div 10;

rtl/inc/text.inc

@@ -696,6 +696,92 @@ Begin
   Write_Str(Len,t,s);
 End;
 
+procedure fpc_write_text_enum(typinfo,o2sindex:pointer;len:sizeint;var t:text;ordinal:longint); iocheck; [Public,Alias:'FPC_WRITE_TEXT_ENUM']; compilerproc;
+
+type  Ptypeinfo=^Ttypeinfo;
+      Ttypeinfo=record
+        kind:byte;
+        name:shortstring;
+       end;
+
+      Penuminfo=^Tenuminfo;
+      Tenuminfo={$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
+        ordtype:byte;
+        minvalue,maxvalue:longint;
+        basetype:pointer;
+        namelist:shortstring;
+      end;
+
+      Tsorted_array={$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
+        o:longint;
+        s:Pstring;
+      end;
+
+var e:Penuminfo;
+    p:Pstring;
+    l,h,m:cardinal;
+    sorted_array:^Tsorted_array;
+    s:string;
+
+begin
+  if textrec(t).mode<>fmoutput then
+    begin
+      if textrec(t).mode=fminput then
+        inoutres:=105
+      else
+        inoutres:=103;
+      exit;
+    end;
+  if Pcardinal(o2sindex)^=0 then
+    begin
+      {The compiler did generate a lookup table.}
+      with Penuminfo(Pbyte(typinfo)+2+length(Ptypeinfo(typinfo)^.name))^ do
+        begin
+          if (ordinal<minvalue) or (ordinal>maxvalue) then
+            begin
+              inoutres:=107;  {Invalid ordinal value for this enum.}
+              exit;
+            end;
+          dec(ordinal,minvalue);
+        end;
+      {Get the address of the string.}
+      p:=Pshortstring((PPpointer(o2sindex)+1+ordinal)^);
+      if p=nil then
+        begin
+          inoutres:=107;      {Invalid ordinal value for this enum.}
+          exit;
+        end;
+      s:=p^;
+    end
+  else
+    begin
+      {The compiler did generate a sorted array of (ordvalue,Pstring) tuples.}
+      sorted_array:=pointer(Pcardinal(o2sindex)+2);
+      {Use a binary search to get the string.}
+      l:=0;
+      h:=(Pcardinal(o2sindex)+1)^-1;
+      repeat
+        m:=(l+h) div 2;
+        if ordinal>sorted_array[m].o then
+          l:=m+1
+        else if ordinal<sorted_array[m].o then
+          h:=m-1
+        else
+          break;
+        if l>h then
+          begin
+            inoutres:=107;      {Invalid ordinal value for this enum.}
+            exit;
+          end;
+      until false;
+      s:=sorted_array[m].s^;
+    end;
+  fpc_writeBuffer(t,s[1],length(s));
+  {Pad the string with spaces if necessary.}
+  if len>length(s) then
+    fpc_writeblanks(t,len-length(s));
+end;
+
 {$ifdef FPC_HAS_STR_CURRENCY}
 Procedure fpc_Write_Text_Currency(fixkomma,Len : Longint;var t : Text;c : Currency); iocheck; [Public,Alias:'FPC_WRITE_TEXT_CURRENCY']; compilerproc;
 var
@@ -1104,6 +1190,26 @@ begin
    InOutRes:=106;
 end;
 
+procedure fpc_read_text_enum(s2oindex:pointer;var t:text;out ordinal:longint); iocheck; [Public,Alias:'FPC_READ_TEXT_ENUM'];compilerproc;
+
+var s:string;
+    code:longint;
+
+begin
+  if not checkread(t) then
+    exit;
+  s:='';
+  if ignorespaces(t) then
+    begin
+      { When spaces were found and we are now at EOF, then we return 0 }
+      if (TextRec(t).BufPos>=TextRec(t).BufEnd) then
+        exit;
+      ReadNumeric(t,s);
+    end;
+  ordinal:=fpc_val_enum_shortstr(s2oindex,s,code);
+  if code<>0 then
+   InOutRes:=106;
+end;
 
 procedure fpc_Read_Text_Currency(var f : Text; out v : Currency); iocheck; [Public,Alias:'FPC_READ_TEXT_CURRENCY']; compilerproc;
 var

rtl/inc/wstrings.inc

@@ -1163,6 +1163,19 @@ begin
     end;
 end;
 
+function fpc_val_enum_widestr(s2oindex:pointer;const s:widestring;out code:valsint):longint;compilerproc;
+
+var ss:shortstring;
+
+begin
+  if length(s)>255 then
+    code:=256
+  else
+    begin
+      ss:=s;
+      val(ss,fpc_val_enum_widestr,code);
+    end;
+end;
 
 Function fpc_Val_Currency_WideStr(Const S : WideString; out Code : ValSInt): Currency; [public, alias:'FPC_VAL_CURRENCY_WIDESTR']; compilerproc;
 Var
@@ -1253,6 +1266,15 @@ begin
   s:=ss;
 end;
 
+procedure fpc_widestr_enum(ordinal,len:sizeint;typinfo,o2sindex:pointer;out s:widestring);compilerproc;
+
+var ss:shortstring;
+
+begin
+  fpc_shortstr_enum(ordinal,len,typinfo,o2sindex,ss);
+  s:=ss;
+end;
+
 {$ifdef FPC_HAS_STR_CURRENCY}
 procedure fpc_WideStr_Currency(c : Currency;len,fr : SizeInt;out s : WideString);compilerproc;
 var