|
Hi fpc developers, here enclosed a patch to the compiler (and ppudump) to support
the BASED construct (PL/1 and PL/M style), together with a patch
to Lazarus codetools in order to be able to use it with Lazarus
IDE. For those unfamiliar with the BASED construct, here's a short description taken from Intel's PL/M-86 manual: Based VariablesSometimes a direct reference to a PL/M-86 data element is either impossible or inconvenient. This happens for example, when the location of a data element must remain unknown until it is computed ad run time. In such cases, it may be necessary to write PL/M-86 code to manipulate the locations of data elements themselves. To permit this type of manipulation PL/M-86 uses "based variables". A based variable is one that is pointed to by another variable called its "base". This means the base contains the address of the desired (based) variable. In short the BASED construct makes the C-style dereferencing operator unnecessary, by moving dereferencing from code to declaration. In fpc this translates into code looking like this, in this trivial example: var I: BYTE; I1: INTEGER; ItemPtr: Pointer; Item: BYTE BASED ItemPtr; IntegerItem: INTEGER BASED ItemPtr; .... ItemPtr := @I; Item := $41; .... ItemPtr := @I1; IntegerItem := -32767;This code will load the BYTE value $41 into the variable I, and the INTEGER value -32767 into the variable I1. In more formal terms, the Declaration section of the fpc manual should include a new path: >--Variable modifiers ---------- based ---------- pointer -------------->
| | | | |
| -- PUint _expression_ --- | |
etc..
The main points are:
The enclosed patches are provided just to permit testing, evaluation and scrutiny from fpc maintainers. They only contain what is required for my personal usage. If the idea is not rejected, then a number of refinements (which I'm ready to implement) are required to make the feature generally available: - All architectures should be supported (now it's only for x86_64
- symcpu.pas). - It should be decided if to make the feature generally
available, or conditioned by an {$IFDEF FPCHASBASED} - It should be decided if the feature should be available in all modes or only in a selected number of modes (what of TurboPascal Mode or Delphi Mode?). - It should be decided if error messages should be specific for the BASED construct or common to the ABSOLUTE one, slightly rephrasing the error message. - It should be decided if internal error # which currently keep the same number of the nearby ABSOLUTE internal error should be given new values. - Maybe something else which I failed to notice. I'd love to see my favourite programming language enriched by such a feature! Giuliano
|
Index: nld.pas
===================================================================
--- nld.pas (revisione 37753)
+++ nld.pas (copia locale)
@@ -292,6 +292,8 @@
case symtableentry.typ of
absolutevarsym :
resultdef:=tabsolutevarsym(symtableentry).vardef;
+ basedvarsym:
+ resultdef:=tbasedvarsym(symtableentry).vardef;
constsym:
begin
if tconstsym(symtableentry).consttyp=constresourcestring then
@@ -404,7 +406,8 @@
include(current_procinfo.flags,pi_needs_got);
case symtableentry.typ of
- absolutevarsym :
+ absolutevarsym,
+ basedvarsym:
;
constsym:
begin
Index: ncgld.pas
===================================================================
--- ncgld.pas (revisione 37753)
+++ ncgld.pas (copia locale)
@@ -33,10 +33,14 @@
node,nld,cgutils;
type
+
+ { tcgloadnode }
+
tcgloadnode = class(tloadnode)
protected
procedure generate_nested_access(vs: tsym);virtual;
procedure generate_absaddr_access(vs: tabsolutevarsym); virtual;
+ procedure generate_basedval_access(vs: tbasedvarsym); virtual;
procedure generate_threadvar_access(gvs: tstaticvarsym); virtual;
function use_indirect_symbol(gvs: tstaticvarsym): boolean;
public
@@ -254,6 +258,11 @@
location.reference.volatility:=[vol_read,vol_write];
end;
+ procedure tcgloadnode.generate_basedval_access(vs: tbasedvarsym);
+ begin
+ location.reference.offset:=asizeint(vs.addroffset);
+ location.reference.volatility:=[vol_read,vol_write];
+ end;
procedure tcgloadnode.generate_threadvar_access(gvs: tstaticvarsym);
var
@@ -438,6 +447,18 @@
internalerror(200310283);
end;
end;
+ basedvarsym:
+ begin
+ { this is only for toasm and toaddr }
+ case tbasedvarsym(symtableentry).basedtyp of
+ toaddr :
+ generate_basedval_access(tbasedvarsym(symtableentry));
+ toasm :
+ location.reference.symbol:=current_asmdata.RefAsmSymbol(tbasedvarsym(symtableentry).mangledname,AT_DATA);
+ else
+ internalerror(200310283);
+ end;
+ end;
constsym:
begin
if tconstsym(symtableentry).consttyp=constresourcestring then
Index: pexpr.pas
===================================================================
--- pexpr.pas (revisione 37753)
+++ pexpr.pas (copia locale)
@@ -1403,6 +1403,13 @@
p1:=nil;
{ typed constants are absolutebarsyms now to handle storage properly }
propaccesslist_to_node(p1,nil,tabsolutevarsym(sym).ref);
+ end;
+ basedvarsym:
+ begin
+ p1.free;
+ p1:=nil;
+ { typed constants are absolutebarsyms now to handle storage properly }
+ propaccesslist_to_node(p1,nil,tbasedvarsym(sym).ref);
end
else
internalerror(16);
@@ -2984,7 +2991,7 @@
end;
{ Access to funcret or need to call the function? }
- if (srsym.typ in [absolutevarsym,localvarsym,paravarsym]) and
+ if (srsym.typ in [absolutevarsym,basedvarsym,localvarsym,paravarsym]) and
(vo_is_funcret in tabstractvarsym(srsym).varoptions) and
{ result(x) is not allowed }
not(vo_is_result in tabstractvarsym(srsym).varoptions) and
@@ -3023,6 +3030,22 @@
p1:=cloadnode.create(srsym,srsymtable);
end;
+ basedvarsym :
+ begin
+ if (tbasedvarsym(srsym).basedtyp=tovar) then
+ begin
+ p1:=nil;
+ propaccesslist_to_node(p1,nil,tbasedvarsym(srsym).ref);
+ p1:=cderefnode.create(p1);
+ p1:=ctypeconvnode.create(p1,tbasedvarsym(srsym).vardef);
+ include(p1.flags,nf_absolute);
+ end
+ else begin
+ p1:=cderefnode.create(p1);
+ p1:=cloadnode.create(srsym,srsymtable);
+ end;
+ end;
+
staticvarsym,
localvarsym,
paravarsym,
Index: x86_64/symcpu.pas
===================================================================
--- x86_64/symcpu.pas (revisione 37753)
+++ x86_64/symcpu.pas (copia locale)
@@ -160,6 +160,10 @@
end;
tcpuabsolutevarsymclass = class of tcpuabsolutevarsym;
+ tcpubasedvarsym = class(tbasedvarsym)
+ end;
+ tcpubasedvarsymclass = class of tcpubasedvarsym;
+
tcpupropertysym = class(tpropertysym)
end;
tcpupropertysymclass = class of tcpupropertysym;
@@ -263,6 +267,7 @@
cparavarsym:=tcpuparavarsym;
cstaticvarsym:=tcpustaticvarsym;
cabsolutevarsym:=tcpuabsolutevarsym;
+ cbasedvarsym:=tcpubasedvarsym;
cpropertysym:=tcpupropertysym;
cconstsym:=tcpuconstsym;
cenumsym:=tcpuenumsym;
Index: htypechk.pas
===================================================================
--- htypechk.pas (revisione 37753)
+++ htypechk.pas (copia locale)
@@ -1103,7 +1103,7 @@
(p.resultdef=ttypeconvnode(p).left.resultdef) then
p:=ttypeconvnode(p).left;
if (p.nodetype=loadn) and
- (tloadnode(p).symtableentry.typ in [absolutevarsym,localvarsym,paravarsym]) and
+ (tloadnode(p).symtableentry.typ in [absolutevarsym,basedvarsym,localvarsym,paravarsym]) and
([vo_is_funcret,vo_is_result] * tabstractvarsym(tloadnode(p).symtableentry).varoptions = [vo_is_funcret]) then
begin
owningprocdef:=tprocdef(tloadnode(p).symtableentry.owner.defowner);
@@ -1785,6 +1785,7 @@
begin
case tloadnode(hp).symtableentry.typ of
absolutevarsym,
+ basedvarsym,
staticvarsym,
localvarsym,
paravarsym :
Index: tokens.pas
===================================================================
--- tokens.pas (revisione 37753)
+++ tokens.pas (copia locale)
@@ -154,6 +154,7 @@
_WITH,
_ALIAS,
_ARRAY,
+ _BASED,
_BEGIN,
_BREAK,
_CDECL,
@@ -493,6 +494,7 @@
(str:'WITH' ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
(str:'ALIAS' ;special:false;keyword:[m_none];op:NOTOKEN),
(str:'ARRAY' ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
+ (str:'BASED' ;special:false;keyword:[m_none];op:NOTOKEN),
(str:'BEGIN' ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
(str:'BREAK' ;special:false;keyword:[m_none];op:NOTOKEN),
(str:'CDECL' ;special:false;keyword:[m_none];op:NOTOKEN),
Index: symtable.pas
===================================================================
--- symtable.pas (revisione 37753)
+++ symtable.pas (copia locale)
@@ -600,6 +600,7 @@
ibparavarsym : sym:=cparavarsym.ppuload(ppufile);
ibfieldvarsym : sym:=cfieldvarsym.ppuload(ppufile);
ibabsolutevarsym : sym:=cabsolutevarsym.ppuload(ppufile);
+ ibbasedvarsym : sym:=cbasedvarsym.ppuload(ppufile);
ibenumsym : sym:=cenumsym.ppuload(ppufile);
ibpropertysym : sym:=cpropertysym.ppuload(ppufile);
ibunitsym : sym:=cunitsym.ppuload(ppufile);
Index: symsym.pas
===================================================================
--- symsym.pas (revisione 37753)
+++ symsym.pas (copia locale)
@@ -332,6 +332,27 @@
end;
tabsolutevarsymclass = class of tabsolutevarsym;
+ { tbasedvarsym }
+
+ tbasedvarsym = class(tabstractvarsym)
+ public
+ basedtyp : absolutetyp;
+ asmname : pshortstring;
+ addroffset : PUint;
+ ref : tpropaccesslist;
+ constructor create(const n : string;def:tdef);virtual;
+ constructor create_ref(const n : string;def:tdef;_ref:tpropaccesslist);virtual;
+ destructor destroy;override;
+ constructor ppuload(ppufile:tcompilerppufile);
+ procedure buildderef;override;
+ procedure deref;override;
+ function mangledname : TSymStr;override;
+ { do not override this routine in platform-specific subclasses,
+ override ppuwrite_platform instead }
+ procedure ppuwrite(ppufile:tcompilerppufile);override;final;
+ end;
+ tbasedvarsymclass = class of tbasedvarsym;
+
tpropaccesslisttypes=(palt_none,palt_read,palt_write,palt_stored);
tpropertysym = class(Tstoredsym)
@@ -468,6 +489,7 @@
cparavarsym: tparavarsymclass;
cstaticvarsym: tstaticvarsymclass;
cabsolutevarsym: tabsolutevarsymclass;
+ cbasedvarsym: tbasedvarsymclass;
cpropertysym: tpropertysymclass;
cconstsym: tconstsymclass;
cenumsym: tenumsymclass;
@@ -2282,7 +2304,91 @@
end;
end;
+{****************************************************************************
+ TBASEDVARSYM
+****************************************************************************}
+ { tbasedvarsym }
+
+ constructor tbasedvarsym.create(const n: string; def: tdef);
+ begin
+ inherited create(basedvarsym,n,vs_value,def,[],true);
+ ref:=nil;
+ end;
+
+ constructor tbasedvarsym.create_ref(const n: string; def: tdef;_ref: tpropaccesslist);
+ begin
+ inherited create(basedvarsym,n,vs_value,def,[],true);
+ ref:=_ref;
+ end;
+
+ destructor tbasedvarsym.destroy;
+ begin
+ if assigned(ref) then
+ ref.free;
+ inherited destroy;
+ end;
+
+ constructor tbasedvarsym.ppuload(ppufile: tcompilerppufile);
+ begin
+ inherited ppuload(basedvarsym,ppufile);
+ ref:=nil;
+ asmname:=nil;
+ basedtyp:=absolutetyp(ppufile.getbyte);
+ case basedtyp of
+ tovar :
+ ref:=ppufile.getpropaccesslist;
+ toasm :
+ asmname:=ppufile.getpshortstring;
+ toaddr :
+ addroffset:=ppufile.getpuint;
+ end;
+ ppuload_platform(ppufile);
+ end;
+
+ procedure tbasedvarsym.buildderef;
+ begin
+ inherited buildderef;
+ if (basedtyp=tovar) then
+ ref.buildderef;
+ end;
+
+ procedure tbasedvarsym.deref;
+ begin
+ inherited deref;
+ { own absolute deref }
+ if (basedtyp=tovar) then
+ ref.resolve;
+ end;
+
+ function tbasedvarsym.mangledname: TSymStr;
+ begin
+ case basedtyp of
+ toasm :
+ mangledname:=asmname^;
+ toaddr :
+ mangledname:='$'+tostr(addroffset);
+ else
+ internalerror(200411062);
+ end;
+ end;
+
+ procedure tbasedvarsym.ppuwrite(ppufile: tcompilerppufile);
+ begin
+ inherited ppuwrite(ppufile);
+ ppufile.putbyte(byte(basedtyp));
+ case basedtyp of
+ tovar :
+ ppufile.putpropaccesslist(ref);
+ toasm :
+ ppufile.putstring(asmname^);
+ toaddr :
+ ppufile.putpuint(addroffset);
+ end;
+ writeentry(ppufile,ibbasedvarsym);
+ end;
+
+
{****************************************************************************
TCONSTSYM
****************************************************************************}
Index: entfile.pas
===================================================================
--- entfile.pas (revisione 37753)
+++ entfile.pas (copia locale)
@@ -90,6 +90,7 @@
iblocalvarsym = 33;
ibparavarsym = 34;
ibmacrosym = 35;
+ ibbasedvarsym = 39;
{definitions}
iborddef = 40;
ibpointerdef = 41;
Index: dbgbase.pas
===================================================================
--- dbgbase.pas (revisione 37753)
+++ dbgbase.pas (copia locale)
@@ -34,6 +34,9 @@
aasmtai,aasmdata;
type
+
+ { TDebugInfo }
+
TDebugInfo=class
protected
{ definitions }
@@ -73,6 +76,7 @@
procedure appendsym_type(list:TAsmList;sym:ttypesym);virtual;
procedure appendsym_label(list:TAsmList;sym:tlabelsym);virtual;
procedure appendsym_absolute(list:TAsmList;sym:tabsolutevarsym);virtual;
+ procedure appendsym_based(list:TAsmList;sym:tbasedvarsym);virtual;
procedure appendsym_property(list:TAsmList;sym:tpropertysym);virtual;
{ symtable }
procedure write_symtable_parasyms(list:TAsmList;paras: tparalist);
@@ -410,7 +414,11 @@
begin
end;
+ procedure TDebugInfo.appendsym_based(list: TAsmList; sym: tbasedvarsym);
+ begin
+ end;
+
procedure TDebugInfo.appendsym(list:TAsmList;sym:tsym);
begin
if sym.isdbgwritten then
@@ -444,6 +452,8 @@
;
absolutevarsym :
appendsym_absolute(list,tabsolutevarsym(sym));
+ basedvarsym :
+ appendsym_based(list,tbasedvarsym(sym));
propertysym :
appendsym_property(list,tpropertysym(sym));
namespacesym :
Index: symconst.pas
===================================================================
--- symconst.pas (revisione 37753)
+++ symconst.pas (copia locale)
@@ -651,7 +651,7 @@
staticvarsym,localvarsym,paravarsym,fieldvarsym,
typesym,procsym,unitsym,constsym,enumsym,
errorsym,syssym,labelsym,absolutevarsym,propertysym,
- macrosym,namespacesym,undefinedsym,programparasym
+ macrosym,namespacesym,undefinedsym,programparasym,basedvarsym
);
{ State of the variable:
@@ -822,7 +822,7 @@
'abstractsym','globalvar','localvar','paravar','fieldvar',
'type','proc','unit','const','enum',
'errorsym','system sym','label','absolutevar','property',
- 'macrosym','namespace','undefinedsym','programparasym'
+ 'macrosym','namespace','undefinedsym','programparasym','basedvar'
);
typName : array[tdeftyp] of string[12] = (
Index: utils/ppuutils/ppudump.pp
===================================================================
--- utils/ppuutils/ppudump.pp (revisione 37753)
+++ utils/ppuutils/ppudump.pp (copia locale)
@@ -2763,6 +2763,34 @@
end;
end;
+ ibbasedvarsym :
+ begin
+ def:=TPpuVarDef.Create(ParentDef);
+ readabstractvarsym('Based variable symbol ',varoptions,TPpuVarDef(def));
+ Write ([space,' Relocated to ']);
+ b:=getbyte;
+ case absolutetyp(b) of
+ tovar :
+ readpropaccesslist(space+' Sym : ');
+ toasm :
+ Writeln(['Assembler name : ',getstring]);
+ toaddr :
+ begin
+ Write(['Address : ',getpuint]);
+ if tsystemcpu(ppufile.header.common.cpu)=cpu_i386 then
+ Write([' (Far: ',getbyte<>0,')']);
+ if tsystemcpu(ppufile.header.common.cpu)=cpu_i8086 then
+ if getbyte<>0 then
+ Write([' (Far: TRUE, Segment=',getaword,')'])
+ else
+ Write([' (Far: FALSE)']);
+ Writeln;
+ end;
+ else
+ Writeln (['!! Invalid unit format : Invalid absolute type encountered: ',b]);
+ end;
+ end;
+
ibfieldvarsym :
begin
def:=TPpuFieldDef.Create(ParentDef);
Index: pdecvar.pas
===================================================================
--- pdecvar.pas (revisione 37753)
+++ pdecvar.pas (copia locale)
@@ -1285,6 +1285,164 @@
end;
end;
+ procedure read_based(sc : TFPObjectList);
+ var
+ vs : tabstractvarsym;
+ basedsym : tbasedvarsym;
+ pt,hp : tnode;
+ st : tsymtable;
+ {$if defined(i386) or defined(i8086)}
+ tmpaddr : int64;
+ {$endif defined(i386) or defined(i8086)}
+ begin
+ basedsym:=nil;
+ { only allowed for one var }
+ vs:=tabstractvarsym(sc[0]);
+ if sc.count>1 then
+ Message1(parser_e_directive_only_one_var,'BASED');
+ if vo_is_typed_const in vs.varoptions then
+ Message(parser_e_initialized_not_for_external);
+ { parse the rest }
+ pt:=expr(true);
+ { check allowed absolute types }
+ if (pt.nodetype=stringconstn) or
+ (is_constcharnode(pt)) then
+ begin
+ basedsym:=cbasedvarsym.create(vs.realname,vs.vardef);
+ basedsym.fileinfo:=vs.fileinfo;
+ if pt.nodetype=stringconstn then
+ basedsym.asmname:=stringdup(strpas(tstringconstnode(pt).value_str))
+ else
+ basedsym.asmname:=stringdup(chr(tordconstnode(pt).value.svalue));
+ consume(token);
+ basedsym.basedtyp:=toasm;
+ end
+ { address }
+ else if is_constintnode(pt) then
+ begin
+ basedsym:=cbasedvarsym.create(vs.realname,vs.vardef);
+ basedsym.fileinfo:=vs.fileinfo;
+ basedsym.basedtyp:=toaddr;
+{$ifndef cpu64bitaddr}
+ { on 64 bit systems, basedsym.addroffset is a qword and hence this
+ test is useless (value is a 64 bit entity) and will always fail
+ for positive values (since int64(high(basedsym.addroffset))=-1
+ }
+ if (Tordconstnode(pt).value<int64(low(basedsym.addroffset))) or
+ (Tordconstnode(pt).value>int64(high(basedsym.addroffset))) then
+ message3(type_e_range_check_error_bounds,tostr(Tordconstnode(pt).value),tostr(low(basedsym.addroffset)),tostr(high(basedsym.addroffset)))
+ else
+{$endif}
+ basedsym.addroffset:=Tordconstnode(pt).value.svalue;
+{$if defined(i386) or defined(i8086)}
+ tcpuabsolutevarsym(basedsym).absseg:=false; // we may safely use absolutevarsym for that
+ if (target_info.system in [system_i386_go32v2,system_i386_watcom,system_i8086_msdos,system_i8086_win16,system_i8086_embedded]) and
+ try_to_consume(_COLON) then
+ begin
+ pt.free;
+ pt:=expr(true);
+ if is_constintnode(pt) then
+ begin
+ {$if defined(i8086)}
+ tcpuabsolutevarsym(basedsym).addrsegment:=basedsym.addroffset;
+ tmpaddr:=tordconstnode(pt).value.svalue;
+ if (tmpaddr<int64(low(basedsym.addroffset))) or
+ (tmpaddr>int64(high(basedsym.addroffset))) then
+ message3(type_e_range_check_error_bounds,tostr(Tordconstnode(pt).value),tostr(low(basedsym.addroffset)),tostr(high(basedsym.addroffset)))
+ else
+ basedsym.addroffset:=tmpaddr;
+ {$elseif defined(i386)}
+ tmpaddr:=basedsym.addroffset shl 4+tordconstnode(pt).value.svalue;
+ if (tmpaddr<int64(low(basedsym.addroffset))) or
+ (tmpaddr>int64(high(basedsym.addroffset))) then
+ message3(type_e_range_check_error_bounds,tostr(Tordconstnode(pt).value),tostr(low(basedsym.addroffset)),tostr(high(basedsym.addroffset)))
+ else
+ basedsym.addroffset:=tmpaddr;
+ {$endif}
+ tcpuabsolutevarsym(basedsym).absseg:=true;
+ end
+ else
+ Message(type_e_ordinal_expr_expected);
+ end;
+{$endif i386 or i8086}
+ end
+ { variable }
+ else
+ begin
+ { we have to be able to take the address of the absolute
+ expression
+ }
+ valid_for_addr(pt,true);
+ { remove subscriptn before checking for loadn }
+ hp:=pt;
+ while (hp.nodetype in [subscriptn,typeconvn,vecn]) do
+ begin
+ { check for implicit dereferencing and reject it }
+ if (hp.nodetype in [subscriptn,vecn]) then
+ begin
+ if (tunarynode(hp).left.resultdef.typ in [pointerdef,classrefdef]) then
+ break;
+ { catch, e.g., 'var b: char absolute pchar_var[5];"
+ (pchar_var[5] is a pchar_2_string typeconv ->
+ the vecn only sees an array of char)
+ I don't know if all of these type conversions are
+ possible, but they're definitely all bad.
+ }
+ if (tunarynode(hp).left.nodetype=typeconvn) and
+ (ttypeconvnode(tunarynode(hp).left).convtype in
+ [tc_pchar_2_string,tc_pointer_2_array,
+ tc_intf_2_string,tc_intf_2_guid,
+ tc_dynarray_2_variant,tc_interface_2_variant,
+ tc_array_2_dynarray]) then
+ break;
+
+ if (tunarynode(hp).left.resultdef.typ=stringdef) and
+ not(tstringdef(tunarynode(hp).left.resultdef).stringtype in [st_shortstring,st_longstring]) then
+ break;
+ if (tunarynode(hp).left.resultdef.typ=objectdef) and
+ (tobjectdef(tunarynode(hp).left.resultdef).objecttype<>odt_object) then
+ break;
+ if is_dynamic_array(tunarynode(hp).left.resultdef) then
+ break;
+ end;
+ hp:=tunarynode(hp).left;
+ end;
+ if (hp.nodetype=loadn) then
+ begin
+ { we should check the result type of loadn }
+ if not (tloadnode(hp).symtableentry.typ in [fieldvarsym,staticvarsym,localvarsym,paravarsym,basedvarsym]) then
+ Message(parser_e_absolute_only_to_var_or_const); //fixme - error message
+ basedsym:=cbasedvarsym.create(vs.realname,vs.vardef);
+ basedsym.fileinfo:=vs.fileinfo;
+ basedsym.basedtyp:=tovar;
+ basedsym.ref:=node_to_propaccesslist(pt);
+
+ { if the sizes are different, can't be a regvar since you }
+ { can't be "absolute upper 8 bits of a register" (except }
+ { if its a record field of the same size of a record }
+ { regvar, but in that case pt.resultdef.size will have }
+ { the same size since it refers to the field and not to }
+ { the whole record -- which is why we use pt and not hp) }
+
+ { we can't take the size of an open array }
+ if is_open_array(pt.resultdef) or
+ (vs.vardef.size <> pt.resultdef.size) then
+ make_not_regable(pt,[ra_addr_regable]);
+ end
+ else
+ Message(parser_e_absolute_only_to_var_or_const);
+ end;
+ pt.free;
+ { replace old varsym with the new basedvarsym }
+ if assigned(basedsym) then
+ begin
+ st:=vs.owner;
+ vs.owner.Delete(vs);
+ st.insert(basedsym);
+ sc[0]:=basedsym;
+ end;
+ end;
+
var
sc : TFPObjectList;
vs : tabstractvarsym;
@@ -1408,6 +1566,13 @@
allowdefaultvalue:=false;
end;
+ { check for based }
+ if try_to_consume(_BASED) then
+ begin
+ read_based(sc);
+ allowdefaultvalue:=false;
+ end;
+
{ Check for EXTERNAL etc directives before a semicolon }
if (idtoken in [_EXPORT,_EXTERNAL,_PUBLIC,_CVAR]) or (idtoken = _WEAKEXTERNAL) then
begin
Index: pascalparsertool.pas
===================================================================
--- pascalparsertool.pas (revisione 56829)
+++ pascalparsertool.pas (copia locale)
@@ -3427,7 +3427,7 @@
ParentNode:=CurNode.Parent;
- // optional: absolute
+ // optional: absolute or based
if (ParentNode.Desc=ctnVarSection) then begin
if UpAtomIs('ABSOLUTE') then begin
if ParentNode.Parent.Desc in AllCodeSections+[ctnProcedure] then begin
@@ -3440,6 +3440,18 @@
end;
end;
end;
+
+ if UpAtomIs('BASED') then begin
+ if ParentNode.Parent.Desc in AllCodeSections+[ctnProcedure] then begin
+ ReadNextAtom;
+ ReadConstant(true,false,[]);
+ if CurPos.Flag=cafColon then
+ begin
+ ReadNextAtom;
+ ReadConstant(true,false,[]);
+ end;
+ end;
+ end;
end;
// optional: hint modifier
_______________________________________________ fpc-devel maillist - fpc-devel@lists.freepascal.org http://lists.freepascal.org/cgi-bin/mailman/listinfo/fpc-devel
