paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-23 02:29:34 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ ansistring to pchar type cast fixed

Browse Source
This commit is contained in:
florian 1998-08-28 12:51:39 +00:00
parent d0f86beed2
commit 8cf2b05bf3
4 changed files with 179 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
compiler/cg386cnv.pas
View File

@ -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

81
compiler/pass_1.pas
View File

@ -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
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;
begin
end;
procedure first_pchar_to_ansistring(var p : ptree);
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
hp : ptree;
aprocdef : pprocdef;
proctype : tdeftype;
var
hp : ptree;
aprocdef : pprocdef;
proctype : tdeftype;
const
firstconvert : array[tc_u8bit_2_s32bit..tc_cchar_charpointer] of
tfirstconvproc = (first_bigger_smaller,first_nothing,first_bigger_smaller,
firstconvert : array[tconverttype] of
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

69
compiler/symdef.inc
View File

@ -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_32bit(len)));
rttilist^.concat(new(pai_const,init_8bit(tkLString)));
end;
st_shortstring:
begin
rttilist^.concat(new(pai_const,init_8bit(8)));
rttilist^.concat(new(pai_const,init_32bit(len)));
rttilist^.concat(new(pai_const,init_8bit(tkSString)));
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)

8
compiler/tree.pas
View File

@ -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