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

- removed automatic int-string, string-int and int-array conversion for

Browse Source 
macpas after discussion on macpascal mailing list. The only thing left
    is automatic conversion of constant strings of length 4 to 32 bit ints.
  * adapted tests to this
  * fixed FOUR_CHAR_CODE and FCC functions in MacPas unit for little
    endian
  + FourCharArray type in macpas unit wich can be used to typecast
    int's "back" to an array[1..4] of char (though the characters
    will be in reverse on little endian systems in that case)

git-svn-id: trunk@5154 -
This commit is contained in:
Jonas Maebe 2006-11-01 16:34:37 +00:00
parent aee2da566d
commit d87f03eef5
6 changed files with 53 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
compiler/defcmp.pas
View File

@ -57,7 +57,6 @@ interface
tc_pointer_2_array,
tc_int_2_int,
tc_int_2_bool,
tc_int_2_string,
tc_bool_2_bool,
tc_bool_2_int,
tc_real_2_real,
@ -370,13 +369,6 @@ implementation
doconv:=tc_char_2_string;
eq:=te_convert_l1;
end;
if (m_mac in current_settings.modeswitches) and
is_integer(def_from) and
(def_from.size = 4) then
begin
doconv:=tc_int_2_string;
eq:=te_convert_l3
end;
end;
arraydef :
begin

89
compiler/ncnv.pas
View File

@ -63,7 +63,6 @@ interface
function typecheck_char_to_string : tnode;
function typecheck_char_to_chararray : tnode;
function typecheck_int_to_real : tnode;
function typecheck_int_to_string : tnode;
function typecheck_real_to_real : tnode;
function typecheck_real_to_currency : tnode;
function typecheck_cchar_to_pchar : tnode;
@ -206,7 +205,6 @@ interface
procedure inserttypeconv_internal(var p:tnode;def:tdef);
procedure arrayconstructor_to_set(var p : tnode);
procedure insert_varargstypeconv(var p : tnode; iscvarargs: boolean);
procedure int_to_4cc(var p: tnode);
implementation
@ -593,74 +591,6 @@ implementation
typecheckpass(p);
end;
procedure int_to_4cc(var p: tnode);
var
srsym: tsym;
srsymtable: tsymtable;
inttemp, chararrtemp: ttempcreatenode;
newblock: tblocknode;
newstatement: tstatementnode;
begin
if (m_mac in current_settings.modeswitches) and
is_integer(p.resultdef) and
(p.resultdef.size = 4) then
begin
if not searchsym_type('FPC_INTERNAL_FOUR_CHAR_ARRAY',srsym,srsymtable) then
internalerror(2006101802);
if (target_info.endian = endian_big) then
inserttypeconv_internal(p,ttypesym(srsym).typedef)
else
begin
newblock := internalstatements(newstatement);
inttemp := ctempcreatenode.create(p.resultdef,4,tt_persistent,true);
chararrtemp := ctempcreatenode.create(ttypesym(srsym).typedef,4,tt_persistent,true);
addstatement(newstatement,inttemp);
addstatement(newstatement,cassignmentnode.create(
ctemprefnode.create(inttemp),p));
addstatement(newstatement,chararrtemp);
addstatement(newstatement,cassignmentnode.create(
cvecnode.create(ctemprefnode.create(chararrtemp),
cordconstnode.create(1,u32inttype,false)),
ctypeconvnode.create_explicit(
cshlshrnode.create(shrn,ctemprefnode.create(inttemp),
cordconstnode.create(24,s32inttype,false)),
cchartype)));
addstatement(newstatement,cassignmentnode.create(
cvecnode.create(ctemprefnode.create(chararrtemp),
cordconstnode.create(2,u32inttype,false)),
ctypeconvnode.create_explicit(
cshlshrnode.create(shrn,ctemprefnode.create(inttemp),
cordconstnode.create(16,s32inttype,false)),
cchartype)));
addstatement(newstatement,cassignmentnode.create(
cvecnode.create(ctemprefnode.create(chararrtemp),
cordconstnode.create(3,u32inttype,false)),
ctypeconvnode.create_explicit(
cshlshrnode.create(shrn,ctemprefnode.create(inttemp),
cordconstnode.create(8,s32inttype,false)),
cchartype)));
addstatement(newstatement,cassignmentnode.create(
cvecnode.create(ctemprefnode.create(chararrtemp),
cordconstnode.create(4,u32inttype,false)),
ctypeconvnode.create_explicit(
ctemprefnode.create(inttemp),cchartype)));
addstatement(newstatement,ctempdeletenode.create(inttemp));
addstatement(newstatement,ctempdeletenode.create_normal_temp(chararrtemp));
addstatement(newstatement,ctemprefnode.create(chararrtemp));
p := newblock;
typecheckpass(p);
end;
end
else
internalerror(2006101803);
end;
{*****************************************************************************
TTYPECONVNODE
*****************************************************************************}
@ -764,7 +694,6 @@ implementation
'tc_pointer_2_array',
'tc_int_2_int',
'tc_int_2_bool',
'tc_int_2_string',
'tc_bool_2_bool',
'tc_bool_2_int',
'tc_real_2_real',
@ -1136,21 +1065,6 @@ implementation
end;
function ttypeconvnode.typecheck_int_to_string : tnode;
begin
if (m_mac in current_settings.modeswitches) and
is_integer(left.resultdef) and
(left.resultdef.size = 4) then
begin
int_to_4cc(left);
inserttypeconv(left,resultdef);
result := left;
left := nil;
end
else
internalerror(2006101803);
end;
function ttypeconvnode.typecheck_real_to_real : tnode;
begin
result:=nil;
@ -1476,7 +1390,6 @@ implementation
{ pointer_2_array } nil,
{ int_2_int } @ttypeconvnode.typecheck_int_to_int,
{ int_2_bool } nil,
{ int_2_string } @ttypeconvnode.typecheck_int_to_string,
{ bool_2_bool } nil,
{ bool_2_int } nil,
{ real_2_real } @ttypeconvnode.typecheck_real_to_real,
@ -2428,7 +2341,6 @@ implementation
@ttypeconvnode._first_pointer_to_array,
@ttypeconvnode._first_int_to_int,
@ttypeconvnode._first_int_to_bool,
nil, { removed in typecheck_int_to_string }
@ttypeconvnode._first_bool_to_bool,
@ttypeconvnode._first_bool_to_int,
@ttypeconvnode._first_real_to_real,
@ -2673,7 +2585,6 @@ implementation
@ttypeconvnode._second_pointer_to_array,
@ttypeconvnode._second_int_to_int,
@ttypeconvnode._second_int_to_bool,
@ttypeconvnode._second_nothing, { int_to_string, handled in resultdef pass }
@ttypeconvnode._second_bool_to_bool,
@ttypeconvnode._second_bool_to_int,
@ttypeconvnode._second_real_to_real,

107
compiler/pexpr.pas
View File

@ -1783,7 +1783,6 @@ implementation
srsym : tsym;
srsymtable : tsymtable;
classh : tobjectdef;
ok: boolean;
label
skipreckklammercheck;
@ -1853,7 +1852,6 @@ implementation
begin
consume(_LECKKLAMMER);
repeat
ok := true;
case p1.resultdef.deftype of
pointerdef:
begin
@ -1881,76 +1879,57 @@ implementation
p2:=crangenode.create(p2,comp_expr(true));
p1:=cvecnode.create(p1,p2);
end;
arraydef,
orddef :
arraydef:
begin
{ in MacPas mode, you can treat a 32bit int as }
{ an array[1..4] of char. The }
{ FPC_Internal_Four_Char_Array is defined in }
{ the macpas unit }
if (p1.resultdef.deftype = orddef) then
p2:=comp_expr(true);
{ support SEG:OFS for go32v2 Mem[] }
if (target_info.system in [system_i386_go32v2,system_i386_watcom]) and
(p1.nodetype=loadn) and
assigned(tloadnode(p1).symtableentry) and
assigned(tloadnode(p1).symtableentry.owner.name) and
(tloadnode(p1).symtableentry.owner.name^='SYSTEM') and
((tloadnode(p1).symtableentry.name='MEM') or
(tloadnode(p1).symtableentry.name='MEMW') or
(tloadnode(p1).symtableentry.name='MEML')) then
begin
if (m_mac in current_settings.modeswitches) and
is_integer(p1.resultdef) and
(p1.resultdef.size = 4) then
int_to_4cc(p1)
if try_to_consume(_COLON) then
begin
p3:=caddnode.create(muln,cordconstnode.create($10,s32inttype,false),p2);
p2:=comp_expr(true);
p2:=caddnode.create(addn,p2,p3);
if try_to_consume(_POINTPOINT) then
{ Support mem[$a000:$0000..$07ff] which returns array [0..$7ff] of memtype.}
p2:=crangenode.create(p2,caddnode.create(addn,comp_expr(true),p3.getcopy));
p1:=cvecnode.create(p1,p2);
include(tvecnode(p1).flags,nf_memseg);
include(tvecnode(p1).flags,nf_memindex);
end
else
ok := false;
end;
if ok then
begin
if try_to_consume(_POINTPOINT) then
{ Support mem[$80000000..$80000002] which returns array [0..2] of memtype.}
p2:=crangenode.create(p2,comp_expr(true));
p1:=cvecnode.create(p1,p2);
include(tvecnode(p1).flags,nf_memindex);
end;
end
else
begin
p2:=comp_expr(true);
{ support SEG:OFS for go32v2 Mem[] }
if (target_info.system in [system_i386_go32v2,system_i386_watcom]) and
(p1.nodetype=loadn) and
assigned(tloadnode(p1).symtableentry) and
assigned(tloadnode(p1).symtableentry.owner.name) and
(tloadnode(p1).symtableentry.owner.name^='SYSTEM') and
((tloadnode(p1).symtableentry.name='MEM') or
(tloadnode(p1).symtableentry.name='MEMW') or
(tloadnode(p1).symtableentry.name='MEML')) then
begin
if try_to_consume(_COLON) then
begin
p3:=caddnode.create(muln,cordconstnode.create($10,s32inttype,false),p2);
p2:=comp_expr(true);
p2:=caddnode.create(addn,p2,p3);
if try_to_consume(_POINTPOINT) then
{ Support mem[$a000:$0000..$07ff] which returns array [0..$7ff] of memtype.}
p2:=crangenode.create(p2,caddnode.create(addn,comp_expr(true),p3.getcopy));
p1:=cvecnode.create(p1,p2);
include(tvecnode(p1).flags,nf_memseg);
include(tvecnode(p1).flags,nf_memindex);
end
else
begin
if try_to_consume(_POINTPOINT) then
{ Support mem[$80000000..$80000002] which returns array [0..2] of memtype.}
p2:=crangenode.create(p2,comp_expr(true));
p1:=cvecnode.create(p1,p2);
include(tvecnode(p1).flags,nf_memindex);
end;
end
else
begin
if try_to_consume(_POINTPOINT) then
{ Support arrayvar[0..9] which returns array [0..9] of arraytype.}
p2:=crangenode.create(p2,comp_expr(true));
p1:=cvecnode.create(p1,p2);
end;
if try_to_consume(_POINTPOINT) then
{ Support arrayvar[0..9] which returns array [0..9] of arraytype.}
p2:=crangenode.create(p2,comp_expr(true));
p1:=cvecnode.create(p1,p2);
end;
end;
else
ok := false;
begin
Message(parser_e_invalid_qualifier);
p1.destroy;
p1:=cerrornode.create;
comp_expr(true);
again:=false;
end;
end;
if not ok then
begin
Message(parser_e_invalid_qualifier);
p1.destroy;
p1:=cerrornode.create;
comp_expr(true);
again:=false;
end;
do_typecheckpass(p1);
until not try_to_consume(_COMMA);
consume(_RECKKLAMMER);

19
rtl/inc/macpas.pp
View File

@ -26,7 +26,7 @@ interface
type
LongDouble = ValReal;
FPC_Internal_Four_Char_Array = array[1..4] of Char;
FourCharArray = packed array[1..4] of char;
{FourCharCode coercion
This routine coreces string literals to a FourCharCode.}
@ -35,10 +35,6 @@ function FCC(const literal: string): LongWord; {$ifdef systeminline}inline;{$end
{Same as FCC, to be compatible with GPC}
function FOUR_CHAR_CODE(const literal: string): LongWord; {$ifdef systeminline}inline;{$endif}
{This makes casts from ShortString to FourCharCode automatically,
to emulate the behaviour of mac pascal compilers}
operator := (const s: ShortString) res: LongWord; {$ifdef systeminline}inline;{$endif}
{ Same as the "is" operator }
Function Member (Instance : TObject; AClass : TClass) : boolean; {$ifdef systeminline}inline;{$endif}
@ -93,17 +89,20 @@ implementation
function FCC(const literal: string): LongWord; {$ifdef systeminline}inline;{$endif}
begin
{$ifdef FPC_LITTLE_ENDIAN}
FCC := (ord(literal[1]) shl 24) or (ord(literal[2]) shl 16) or ord(literal[3] shl 8) or ord(literal[4]);
{$else FPC_LITTLE_ENDIAN}
FCC := PLongWord(@literal[1])^;
{$endif FPC_LITTLE_ENDIAN}
end;
function FOUR_CHAR_CODE(const literal: string): LongWord; {$ifdef systeminline}inline;{$endif}
begin
{$ifdef FPC_LITTLE_ENDIAN}
FOUR_CHAR_CODE := (ord(literal[1]) shl 24) or (ord(literal[2]) shl 16) or ord(literal[3] shl 8) or ord(literal[4]);
{$else FPC_LITTLE_ENDIAN}
FOUR_CHAR_CODE := PLongWord(@literal[1])^;
end;
operator := (const s: ShortString) res: LongWord; {$ifdef systeminline}inline;{$endif}
begin
res := PLongWord(@s[1])^;
{$endif FPC_LITTLE_ENDIAN}
end;
Function Member (Instance : TObject; AClass : TClass) : boolean; {$ifdef systeminline}inline;{$endif}

1
tests/test/t4cc1.pp
View File

@ -1,3 +1,4 @@
{ %fail }
{$mode macpas}
type

7
tests/test/tint2str1.pp
View File

@ -1,11 +1,5 @@
{$mode macpas}
procedure test(const s: string);
begin
if s <> 'abcd' then
halt(1);
end;
procedure test2(c1,c2,c3,c4: char);
begin
if (c1 <> 'a') or (c2 <> 'b') or (c3 <> 'c') or (c4 <> 'd') then
@ -17,6 +11,5 @@ var
l: longint;
begin
l := 'abcd';
test(l);
test2(char(l shr 24),char(l shr 16),char(l shr 8),char(l));
end.