mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 11:48:10 +02:00
507 lines
20 KiB
ObjectPascal
507 lines
20 KiB
ObjectPascal
{
|
|
$Id$
|
|
Copyright (c) 1998 by Florian Klaempfl
|
|
|
|
Reads typed constants
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
|
****************************************************************************
|
|
}
|
|
unit ptconst;
|
|
|
|
interface
|
|
|
|
uses symtable;
|
|
|
|
{ this procedure reads typed constants }
|
|
procedure readtypedconst(def : pdef);
|
|
|
|
implementation
|
|
|
|
uses
|
|
cobjects,globals,scanner,aasm,tree,pass_1,
|
|
hcodegen,types,verbose
|
|
{ parser specific stuff }
|
|
,pbase,pexpr
|
|
{ processor specific stuff }
|
|
{$ifdef i386}
|
|
,i386
|
|
{$endif}
|
|
{$ifdef m68k}
|
|
,m68k
|
|
{$endif}
|
|
;
|
|
|
|
{ this procedure reads typed constants }
|
|
procedure readtypedconst(def : pdef);
|
|
|
|
var
|
|
p : ptree;
|
|
i,l : longint;
|
|
ll : plabel;
|
|
s : string;
|
|
ca : pchar;
|
|
aktpos : longint;
|
|
pd : pprocdef;
|
|
hp1,hp2 : pdefcoll;
|
|
|
|
value : bestreal;
|
|
{problem with fldt !!
|
|
anyway .valued is not extended !!
|
|
value : double; }
|
|
|
|
procedure check_range;
|
|
|
|
begin
|
|
if ((p^.value>porddef(def)^.bis) or
|
|
(p^.value<porddef(def)^.von)) then
|
|
Message(parser_e_range_check_error);
|
|
end;
|
|
|
|
{$R-} {Range check creates problem with init_8bit(-1) !!}
|
|
begin
|
|
case def^.deftype of
|
|
orddef:
|
|
begin
|
|
p:=expr;
|
|
do_firstpass(p);
|
|
case porddef(def)^.typ of
|
|
s8bit,
|
|
u8bit : begin
|
|
if not is_constintnode(p) then
|
|
{ is't an int expected }
|
|
Message(cg_e_illegal_expression)
|
|
else
|
|
begin
|
|
datasegment^.concat(new(pai_const,init_8bit(p^.value)));
|
|
check_range;
|
|
end;
|
|
end;
|
|
s32bit : begin
|
|
if not is_constintnode(p) then
|
|
Message(cg_e_illegal_expression)
|
|
else
|
|
begin
|
|
datasegment^.concat(new(pai_const,init_32bit(p^.value)));
|
|
check_range;
|
|
end;
|
|
end;
|
|
u32bit : begin
|
|
if not is_constintnode(p) then
|
|
Message(cg_e_illegal_expression)
|
|
else
|
|
datasegment^.concat(new(pai_const,init_32bit(p^.value)));
|
|
end;
|
|
bool8bit : begin
|
|
if not is_constboolnode(p) then
|
|
Message(cg_e_illegal_expression);
|
|
datasegment^.concat(new(pai_const,init_8bit(p^.value)));
|
|
end;
|
|
uchar : begin
|
|
if not is_constcharnode(p) then
|
|
Message(cg_e_illegal_expression);
|
|
datasegment^.concat(new(pai_const,init_8bit(p^.value)));
|
|
end;
|
|
u16bit,
|
|
s16bit : begin
|
|
if not is_constintnode(p) then
|
|
Message(cg_e_illegal_expression);
|
|
datasegment^.concat(new(pai_const,init_16bit(p^.value)));
|
|
check_range;
|
|
end;
|
|
end;
|
|
disposetree(p);
|
|
end;
|
|
floatdef:
|
|
begin
|
|
p:=expr;
|
|
do_firstpass(p);
|
|
if is_constrealnode(p) then
|
|
value:=p^.valued
|
|
else if is_constintnode(p) then
|
|
value:=p^.value
|
|
else
|
|
Message(cg_e_illegal_expression);
|
|
|
|
case pfloatdef(def)^.typ of
|
|
s64real : datasegment^.concat(new(pai_double,init(value)));
|
|
s32real : datasegment^.concat(new(pai_single,init(value)));
|
|
s80real : datasegment^.concat(new(pai_extended,init(value)));
|
|
s64bit : datasegment^.concat(new(pai_comp,init(value)));
|
|
f32bit : datasegment^.concat(new(pai_const,init_32bit(trunc(value*65536))));
|
|
else internalerror(18);
|
|
end;
|
|
disposetree(p);
|
|
end;
|
|
pointerdef:
|
|
begin
|
|
p:=expr;
|
|
do_firstpass(p);
|
|
{ nil pointer ? }
|
|
if p^.treetype=niln then
|
|
datasegment^.concat(new(pai_const,init_32bit(0)))
|
|
{ maybe pchar ? }
|
|
else if (ppointerdef(def)^.definition^.deftype=orddef) and
|
|
(porddef(ppointerdef(def)^.definition)^.typ=uchar) then
|
|
begin
|
|
getlabel(ll);
|
|
{ insert string at the begin }
|
|
if p^.treetype=stringconstn then
|
|
generate_ascii_insert((p^.values^)+#0)
|
|
else if is_constcharnode(p) then
|
|
datasegment^.insert(new(pai_string,init(char(byte(p^.value))+#0)))
|
|
else Message(cg_e_illegal_expression);
|
|
datasegment^.insert(new(pai_label,init(ll)));
|
|
{ insert label }
|
|
datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str(ll)))));
|
|
end
|
|
else if p^.treetype=addrn then
|
|
begin
|
|
if (is_equal(ppointerdef(p^.resulttype)^.definition,ppointerdef(def)^.definition) or
|
|
(is_equal(ppointerdef(p^.resulttype)^.definition,voiddef)) or
|
|
(is_equal(ppointerdef(def)^.definition,voiddef))) and
|
|
(p^.left^.treetype = loadn) then
|
|
begin
|
|
datasegment^.concat(new(pai_const,init_symbol(
|
|
strpnew(p^.left^.symtableentry^.mangledname))));
|
|
if p^.left^.symtableentry^.owner^.symtabletype=unitsymtable then
|
|
concat_external(p^.left^.symtableentry^.mangledname,EXT_NEAR);
|
|
end
|
|
else
|
|
Message(cg_e_illegal_expression);
|
|
end
|
|
else
|
|
{ allow typeof(Object type)}
|
|
if (p^.treetype=inlinen) and
|
|
(p^.inlinenumber=in_typeof_x) then
|
|
if (p^.left^.treetype=typen) then
|
|
begin
|
|
datasegment^.concat(new(pai_const,init_symbol(
|
|
strpnew(pobjectdef(p^.left^.resulttype)^.vmt_mangledname))));
|
|
if pobjectdef(p^.left^.resulttype)^.owner^.symtabletype=unitsymtable then
|
|
concat_external(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,EXT_NEAR);
|
|
end
|
|
else
|
|
begin
|
|
Message(cg_e_illegal_expression);
|
|
end
|
|
else
|
|
Message(cg_e_illegal_expression);
|
|
disposetree(p);
|
|
end;
|
|
setdef:
|
|
begin
|
|
p:=expr;
|
|
do_firstpass(p);
|
|
if p^.treetype=setconstrn then
|
|
begin
|
|
{ we only allow const sets }
|
|
if assigned(p^.left) then
|
|
Message(cg_e_illegal_expression)
|
|
else
|
|
begin
|
|
for l:=0 to def^.savesize-1 do
|
|
datasegment^.concat(
|
|
new(pai_const,init_8bit(p^.constset^[l])));
|
|
end;
|
|
end
|
|
else
|
|
Message(cg_e_illegal_expression);
|
|
disposetree(p);
|
|
end;
|
|
enumdef:
|
|
begin
|
|
p:=expr;
|
|
do_firstpass(p);
|
|
if p^.treetype=ordconstn then
|
|
begin
|
|
if is_equal(p^.resulttype,def) then
|
|
begin
|
|
datasegment^.concat(new(pai_const,init_32bit(p^.value)));
|
|
end
|
|
else
|
|
Message(cg_e_illegal_expression);
|
|
end
|
|
else
|
|
Message(cg_e_illegal_expression);
|
|
disposetree(p);
|
|
end;
|
|
stringdef:
|
|
begin
|
|
p:=expr;
|
|
do_firstpass(p);
|
|
if pstringdef(def)^.string_typ=shortstring then
|
|
begin
|
|
if p^.treetype=stringconstn then
|
|
begin
|
|
s:=p^.values^;
|
|
if length(s)+1>def^.size then
|
|
s[0]:=char(def^.size-1);
|
|
generate_ascii(char(length(s))+s);
|
|
end
|
|
else if is_constcharnode(p) then
|
|
begin
|
|
datasegment^.concat(new(pai_string,init(#1+char(byte(p^.value)))));
|
|
s:=char(byte(p^.value));
|
|
end
|
|
else Message(cg_e_illegal_expression);
|
|
if def^.size>length(s) then
|
|
begin
|
|
getmem(ca,def^.size-length(s));
|
|
fillchar(ca[0],def^.size-length(s)-1,' ');
|
|
ca[def^.size-length(s)-1]:=#0;
|
|
datasegment^.concat(new(pai_string,init_pchar(ca)));
|
|
disposetree(p);
|
|
end;
|
|
end
|
|
else if pstringdef(def)^.string_typ=longstring then
|
|
begin
|
|
if p^.treetype=stringconstn then
|
|
begin
|
|
s:=p^.values^;
|
|
if length(s)+1>def^.size then
|
|
s[0]:=char(def^.size-1);
|
|
generate_ascii(char(length(s))+s);
|
|
end
|
|
else if is_constcharnode(p) then
|
|
begin
|
|
datasegment^.concat(new(pai_string,init(#1+char(byte(p^.value)))));
|
|
s:=char(byte(p^.value));
|
|
end
|
|
else Message(cg_e_illegal_expression);
|
|
if def^.size>length(s) then
|
|
begin
|
|
getmem(ca,def^.size-length(s));
|
|
fillchar(ca[0],def^.size-length(s)-1,' ');
|
|
ca[def^.size-length(s)-1]:=#0;
|
|
datasegment^.concat(new(pai_string,init_pchar(ca)));
|
|
disposetree(p);
|
|
end;
|
|
end
|
|
else if pstringdef(def)^.string_typ=ansistring then
|
|
begin
|
|
end
|
|
end;
|
|
arraydef:
|
|
begin
|
|
if token=LKLAMMER then
|
|
begin
|
|
consume(LKLAMMER);
|
|
for l:=parraydef(def)^.lowrange to parraydef(def)^.highrange-1 do
|
|
begin
|
|
readtypedconst(parraydef(def)^.definition);
|
|
consume(COMMA);
|
|
end;
|
|
readtypedconst(parraydef(def)^.definition);
|
|
consume(RKLAMMER);
|
|
end
|
|
else
|
|
begin
|
|
p:=expr;
|
|
do_firstpass(p);
|
|
if p^.treetype=stringconstn then
|
|
s:=p^.values^
|
|
else if is_constcharnode(p) then
|
|
s:=char(byte(p^.value))
|
|
else Message(cg_e_illegal_expression);
|
|
l:=length(s);
|
|
for i:=Parraydef(def)^.lowrange to Parraydef(def)^.highrange do
|
|
begin
|
|
if i+1-Parraydef(def)^.lowrange<=l then
|
|
begin
|
|
datasegment^.concat(new(pai_const,init_8bit(byte(s[1]))));
|
|
delete(s,1,1);
|
|
end
|
|
else
|
|
{Fill the remaining positions with #0.}
|
|
datasegment^.concat(new(pai_const,init_8bit(0)));
|
|
end;
|
|
if length(s)>0 then
|
|
Message(parser_e_string_too_long);
|
|
end;
|
|
end;
|
|
procvardef:
|
|
begin
|
|
{ Procvars and pointers are no longer compatible. }
|
|
{ under tp: =nil or =var under fpc: =nil or =@var }
|
|
if token=_NIL then
|
|
begin
|
|
datasegment^.concat(new(pai_const,init_32bit(0)));
|
|
consume(_NIL);
|
|
exit;
|
|
end
|
|
else
|
|
if not(cs_tp_compatible in aktswitches) then
|
|
if token=KLAMMERAFFE then
|
|
consume(KLAMMERAFFE);
|
|
getsym(pattern,true);
|
|
consume(ID);
|
|
if srsym^.typ=unitsym then
|
|
begin
|
|
consume(POINT);
|
|
getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
|
|
consume(ID);
|
|
end;
|
|
if srsym^.typ<>procsym then
|
|
Message(cg_e_illegal_expression)
|
|
else
|
|
begin
|
|
pd:=pprocsym(srsym)^.definition;
|
|
if assigned(pd^.nextoverloaded) then
|
|
Message(parser_e_no_overloaded_procvars);
|
|
if not((pprocvardef(def)^.options=pd^.options)) or
|
|
not(is_equal(pprocvardef(def)^.retdef,pd^.retdef)) then
|
|
Message(sym_e_type_mismatch)
|
|
else
|
|
begin
|
|
hp1:=pprocvardef(def)^.para1;
|
|
hp2:=pd^.para1;
|
|
while assigned(hp1) and assigned(hp2) do
|
|
begin
|
|
if not(is_equal(hp1^.data,hp2^.data)) or
|
|
not(hp1^.paratyp=hp2^.paratyp) then
|
|
begin
|
|
Message(sym_e_type_mismatch);
|
|
break;
|
|
end;
|
|
hp1:=hp1^.next;
|
|
hp2:=hp2^.next;
|
|
end;
|
|
if not((hp1=nil) and (hp2=nil)) then
|
|
Message(sym_e_type_mismatch);
|
|
end;
|
|
datasegment^.concat(new(pai_const,init_symbol(strpnew(pd^.mangledname))));
|
|
if pd^.owner^.symtabletype=unitsymtable then
|
|
concat_external(pd^.mangledname,EXT_NEAR);
|
|
end;
|
|
end;
|
|
{ reads a typed constant record }
|
|
recorddef:
|
|
begin
|
|
consume(LKLAMMER);
|
|
aktpos:=0;
|
|
while token<>RKLAMMER do
|
|
begin
|
|
s:=pattern;
|
|
consume(ID);
|
|
consume(COLON);
|
|
srsym:=precdef(def)^.symtable^.search(s);
|
|
if srsym=nil then
|
|
begin
|
|
Message1(sym_e_id_not_found,s);
|
|
consume_all_until(SEMICOLON);
|
|
end
|
|
else
|
|
begin
|
|
{ check position }
|
|
if pvarsym(srsym)^.address<aktpos then
|
|
Message(parser_e_invalid_record_const);
|
|
|
|
{ if needed fill }
|
|
if pvarsym(srsym)^.address>aktpos then
|
|
for i:=1 to pvarsym(srsym)^.address-aktpos do
|
|
datasegment^.concat(new(pai_const,init_8bit(0)));
|
|
|
|
{ new position }
|
|
aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.definition^.size;
|
|
|
|
{ read the data }
|
|
readtypedconst(pvarsym(srsym)^.definition);
|
|
|
|
if token=SEMICOLON then
|
|
consume(SEMICOLON)
|
|
else break;
|
|
end;
|
|
end;
|
|
for i:=1 to def^.size-aktpos do
|
|
datasegment^.concat(new(pai_const,init_8bit(0)));
|
|
consume(RKLAMMER);
|
|
end;
|
|
else Message(parser_e_type_const_not_possible);
|
|
end;
|
|
end;
|
|
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.1 1998-03-25 11:18:15 root
|
|
Initial revision
|
|
|
|
Revision 1.13 1998/03/20 23:31:35 florian
|
|
* bug0113 fixed
|
|
* problem with interdepened units fixed ("options.pas problem")
|
|
* two small extensions for future AMD 3D support
|
|
|
|
Revision 1.12 1998/03/18 22:50:11 florian
|
|
+ fstp/fld optimization
|
|
* routines which contains asm aren't longer optimzed
|
|
* wrong ifdef TEST_FUNCRET corrected
|
|
* wrong data generation for array[0..n] of char = '01234'; fixed
|
|
* bug0097 is fixed partial
|
|
* bug0116 fixed (-Og doesn't use enter of the stack frame is greater than
|
|
65535)
|
|
|
|
Revision 1.11 1998/03/13 22:45:59 florian
|
|
* small bug fixes applied
|
|
|
|
Revision 1.10 1998/03/11 11:23:57 florian
|
|
* bug0081 and bug0109 fixed
|
|
|
|
Revision 1.9 1998/03/10 01:17:25 peter
|
|
* all files have the same header
|
|
* messages are fully implemented, EXTDEBUG uses Comment()
|
|
+ AG... files for the Assembler generation
|
|
|
|
Revision 1.8 1998/03/06 00:52:50 peter
|
|
* replaced all old messages from errore.msg, only ExtDebug and some
|
|
Comment() calls are left
|
|
* fixed options.pas
|
|
|
|
Revision 1.7 1998/03/02 01:49:10 peter
|
|
* renamed target_DOS to target_GO32V1
|
|
+ new verbose system, merged old errors and verbose units into one new
|
|
verbose.pas, so errors.pas is obsolete
|
|
|
|
Revision 1.6 1998/02/13 10:35:33 daniel
|
|
* Made Motorola version compilable.
|
|
* Fixed optimizer
|
|
|
|
Revision 1.5 1998/02/12 11:50:32 daniel
|
|
Yes! Finally! After three retries, my patch!
|
|
|
|
Changes:
|
|
|
|
Complete rewrite of psub.pas.
|
|
Added support for DLL's.
|
|
Compiler requires less memory.
|
|
Platform units for each platform.
|
|
|
|
Revision 1.4 1998/01/24 23:08:19 carl
|
|
+ compile time range checking should logically always be on!
|
|
|
|
Revision 1.3 1998/01/23 17:12:20 pierre
|
|
* added some improvements for as and ld :
|
|
- doserror and dosexitcode treated separately
|
|
- PATH searched if doserror=2
|
|
+ start of long and ansi string (far from complete)
|
|
in conditionnal UseLongString and UseAnsiString
|
|
* options.pas cleaned (some variables shifted to globals)gl
|
|
|
|
Revision 1.2 1998/01/09 09:10:03 michael
|
|
+ Initial implementation, second try
|
|
|
|
}
|