paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-18 14:59:29 +02:00
Code Issues Packages Projects Releases Wiki Activity
c995e56370
fpc/compiler/pdecl.pas
Jonas Maebe 43c5ed20c2 + support for initialising typed constants via compiler-generated 
assignment-nodes. For global typed constants and typed constants/
    local variable initialisers in regular functions/procedurs, the
    assignments are performed in the unit initialisation code. For
    those in object/record definitions and their methods, it's done
    in the class constructor. Since we may not yet have parsed all
    method implementations when the class constructor is parsed, part
    of these may be initialised in a helper routine called from the
    class constructor. The ones known when the class constructor is
    parsed are inited there, because the ones marked as "final" and
    declared as static class fields must be initialised in the class
    constructor for Java
   o new set systems_typed_constants_node_init in systems unit that
     indicates that a target uses node trees to initialise typed consts
     instead of an initialised data section
   o mark typed constants in {$j-} mode as "final" for JVM
   o mangle the name of staticvarsyms inside localtables a bit to avoid
     name clashes (only with procedure names for now, no parameters yet
     so can still cause problems with overloaded routines)
   o after a routine has been parsed, it is now processed by
     cnodeutils.wrap_proc_body(), which can add extra nodes before code
     generation (used for injected the typed constant node trees)

git-svn-id: branches/jvmbackend@18475 -
2011-08-20 08:02:58 +00:00

818 lines
31 KiB
ObjectPascal
Raw Blame History

{
Copyright (c) 1998-2002 by Florian Klaempfl
Does declaration (but not type) parsing for Free Pascal
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 pdecl;
{$i fpcdefs.inc}
interface
uses
{ common }
cclasses,
{ global }
globtype,
{ symtable }
symsym,symdef,
{ pass_1 }
node;
function readconstant(const orgname:string;const filepos:tfileposinfo):tconstsym;
procedure const_dec;
procedure consts_dec(in_structure, allow_typed_const: boolean);
procedure label_dec;
procedure type_dec;
procedure types_dec(in_structure: boolean);
procedure var_dec;
procedure threadvar_dec;
procedure property_dec(is_classpropery: boolean);
procedure resourcestring_dec;
{ generics support }
function parse_generic_parameters:TFPObjectList;
procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:TFPObjectList);
implementation
uses
SysUtils,
{ common }
cutils,
{ global }
globals,tokens,verbose,widestr,constexp,
systems,
{ aasm }
aasmbase,aasmtai,aasmdata,fmodule,
{ symtable }
symconst,symbase,symtype,symtable,paramgr,defutil,
{ pass 1 }
nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nobj,
{ codegen }
ncgutil,ngenutil,
{ parser }
scanner,
pbase,pexpr,ptype,ptconst,pdecsub,pdecvar,pdecobj,
{ cpu-information }
cpuinfo
;
function readconstant(const orgname:string;const filepos:tfileposinfo):tconstsym;
var
hp : tconstsym;
p : tnode;
ps : pconstset;
pd : pbestreal;
pg : pguid;
sp : pchar;
pw : pcompilerwidestring;
storetokenpos : tfileposinfo;
begin
readconstant:=nil;
if orgname='' then
internalerror(9584582);
hp:=nil;
p:=comp_expr(true,false);
storetokenpos:=current_tokenpos;
current_tokenpos:=filepos;
case p.nodetype of
ordconstn:
begin
if p.resultdef.typ=pointerdef then
hp:=tconstsym.create_ordptr(orgname,constpointer,tordconstnode(p).value.uvalue,p.resultdef)
else
hp:=tconstsym.create_ord(orgname,constord,tordconstnode(p).value,p.resultdef);
end;
stringconstn:
begin
if is_wide_or_unicode_string(p.resultdef) then
begin
initwidestring(pw);
copywidestring(pcompilerwidestring(tstringconstnode(p).value_str),pw);
hp:=tconstsym.create_wstring(orgname,constwstring,pw);
end
else
begin
getmem(sp,tstringconstnode(p).len+1);
move(tstringconstnode(p).value_str^,sp^,tstringconstnode(p).len+1);
hp:=tconstsym.create_string(orgname,conststring,sp,tstringconstnode(p).len);
end;
end;
realconstn :
begin
new(pd);
pd^:=trealconstnode(p).value_real;
hp:=tconstsym.create_ptr(orgname,constreal,pd,p.resultdef);
end;
setconstn :
begin
new(ps);
ps^:=tsetconstnode(p).value_set^;
hp:=tconstsym.create_ptr(orgname,constset,ps,p.resultdef);
end;
pointerconstn :
begin
hp:=tconstsym.create_ordptr(orgname,constpointer,tpointerconstnode(p).value,p.resultdef);
end;
niln :
begin
hp:=tconstsym.create_ord(orgname,constnil,0,p.resultdef);
end;
typen :
begin
if is_interface(p.resultdef) then
begin
if assigned(tobjectdef(p.resultdef).iidguid) then
begin
new(pg);
pg^:=tobjectdef(p.resultdef).iidguid^;
hp:=tconstsym.create_ptr(orgname,constguid,pg,p.resultdef);
end
else
Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^);
end
else
Message(parser_e_illegal_expression);
end;
else
Message(parser_e_illegal_expression);
end;
current_tokenpos:=storetokenpos;
p.free;
readconstant:=hp;
end;
procedure const_dec;
begin
consume(_CONST);
consts_dec(false,true);
end;
procedure consts_dec(in_structure, allow_typed_const: boolean);
var
orgname : TIDString;
hdef : tdef;
sym, tmp : tsym;
dummysymoptions : tsymoptions;
deprecatedmsg : pshortstring;
storetokenpos,filepos : tfileposinfo;
old_block_type : tblock_type;
skipequal : boolean;
tclist : tasmlist;
varspez : tvarspez;
static_name : string;
sl : tpropaccesslist;
begin
old_block_type:=block_type;
block_type:=bt_const;
repeat
orgname:=orgpattern;
filepos:=current_tokenpos;
consume(_ID);
case token of
_EQ:
begin
consume(_EQ);
sym:=readconstant(orgname,filepos);
{ Support hint directives }
dummysymoptions:=[];
deprecatedmsg:=nil;
try_consume_hintdirective(dummysymoptions,deprecatedmsg);
if assigned(sym) then
begin
sym.symoptions:=sym.symoptions+dummysymoptions;
sym.deprecatedmsg:=deprecatedmsg;
sym.visibility:=symtablestack.top.currentvisibility;
symtablestack.top.insert(sym);
end
else
stringdispose(deprecatedmsg);
consume(_SEMICOLON);
end;
_COLON:
begin
if not allow_typed_const then
begin
Message(parser_e_no_typed_const);
consume_all_until(_SEMICOLON);
end;
{ set the blocktype first so a consume also supports a
caret, to support const s : ^string = nil }
block_type:=bt_const_type;
consume(_COLON);
read_anon_type(hdef,false);
block_type:=bt_const;
skipequal:=false;
{ create symbol }
storetokenpos:=current_tokenpos;
current_tokenpos:=filepos;
if not (cs_typed_const_writable in current_settings.localswitches) then
varspez:=vs_const
else
varspez:=vs_value;
{ if we are dealing with structure const then we need to handle it as a
structure static variable: create a symbol in unit symtable and a reference
to it from the structure or linking will fail }
if symtablestack.top.symtabletype in [recordsymtable,ObjectSymtable] then
begin
{ generate the symbol which reserves the space }
static_name:=lower(generate_nested_name(symtablestack.top,'_'))+'_'+orgname;
{$ifndef jvm}
sym:=tstaticvarsym.create(internal_static_field_name(static_name),varspez,hdef,[]);
include(sym.symoptions,sp_internal);
tabstractrecordsymtable(symtablestack.top).get_unit_symtable.insert(sym);
{$else not jvm}
sym:=tstaticvarsym.create(orgname,varspez,hdef,[]);
include(sym.symoptions,sp_internal);
symtablestack.top.insert(sym);
orgname:=static_name;
{$endif not jvm}
{ generate the symbol for the access }
sl:=tpropaccesslist.create;
sl.addsym(sl_load,sym);
tmp:=tabsolutevarsym.create_ref(orgname,hdef,sl);
tmp.visibility:=symtablestack.top.currentvisibility;
symtablestack.top.insert(tmp);
end
else
begin
sym:=tstaticvarsym.create(orgname,varspez,hdef,[]);
sym.visibility:=symtablestack.top.currentvisibility;
symtablestack.top.insert(sym);
end;
current_tokenpos:=storetokenpos;
{ procvar can have proc directives, but not type references }
if (hdef.typ=procvardef) and
(hdef.typesym=nil) then
begin
{ support p : procedure;stdcall=nil; }
if try_to_consume(_SEMICOLON) then
begin
if check_proc_directive(true) then
parse_var_proc_directives(sym)
else
begin
Message(parser_e_proc_directive_expected);
skipequal:=true;
end;
end
else
{ support p : procedure stdcall=nil; }
begin
if check_proc_directive(true) then
parse_var_proc_directives(sym);
end;
{ add default calling convention }
handle_calling_convention(tabstractprocdef(hdef));
end;
if not skipequal then
begin
{ get init value }
consume(_EQ);
if (cs_typed_const_writable in current_settings.localswitches) then
tclist:=current_asmdata.asmlists[al_typedconsts]
else
tclist:=current_asmdata.asmlists[al_rotypedconsts];
read_typed_const(tclist,tstaticvarsym(sym),in_structure);
end;
end;
else
{ generate an error }
consume(_EQ);
end;
until (token<>_ID) or
(in_structure and
((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
((m_final_fields in current_settings.modeswitches) and
(idtoken=_FINAL))));
block_type:=old_block_type;
end;
procedure label_dec;
var
labelsym : tlabelsym;
begin
consume(_LABEL);
if not(cs_support_goto in current_settings.moduleswitches) then
Message(sym_e_goto_and_label_not_supported);
repeat
if not(token in [_ID,_INTCONST]) then
consume(_ID)
else
begin
if token=_ID then
labelsym:=tlabelsym.create(orgpattern)
else
labelsym:=tlabelsym.create(pattern);
symtablestack.top.insert(labelsym);
if m_non_local_goto in current_settings.modeswitches then
begin
if symtablestack.top.symtabletype=localsymtable then
begin
labelsym.jumpbuf:=tlocalvarsym.create('LABEL$_'+labelsym.name,vs_value,rec_jmp_buf,[]);
symtablestack.top.insert(labelsym.jumpbuf);
end
else
begin
labelsym.jumpbuf:=tstaticvarsym.create('LABEL$_'+labelsym.name,vs_value,rec_jmp_buf,[]);
symtablestack.top.insert(labelsym.jumpbuf);
cnodeutils.insertbssdata(tstaticvarsym(labelsym.jumpbuf));
end;
include(labelsym.jumpbuf.symoptions,sp_internal);
{ the buffer will be setup later, but avoid a hint }
tabstractvarsym(labelsym.jumpbuf).varstate:=vs_written;
end;
consume(token);
end;
if token<>_SEMICOLON then consume(_COMMA);
until not(token in [_ID,_INTCONST]);
consume(_SEMICOLON);
end;
function parse_generic_parameters:TFPObjectList;
var
generictype : ttypesym;
begin
result:=TFPObjectList.Create(false);
repeat
if token=_ID then
begin
generictype:=ttypesym.create(orgpattern,cundefinedtype);
include(generictype.symoptions,sp_generic_para);
result.add(generictype);
end;
consume(_ID);
until not try_to_consume(_COMMA) ;
end;
procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:TFPObjectList);
var
i: longint;
generictype: ttypesym;
st: tsymtable;
begin
def.genericdef:=genericdef;
if not assigned(genericlist) then
exit;
case def.typ of
recorddef,objectdef: st:=tabstractrecorddef(def).symtable;
arraydef: st:=tarraydef(def).symtable;
procvardef,procdef: st:=tabstractprocdef(def).parast;
else
internalerror(201101020);
end;
for i:=0 to genericlist.count-1 do
begin
generictype:=ttypesym(genericlist[i]);
if generictype.typedef.typ=undefineddef then
include(def.defoptions,df_generic)
else
include(def.defoptions,df_specialization);
st.insert(generictype);
end;
end;
procedure types_dec(in_structure: boolean);
procedure finalize_class_external_status(od: tobjectdef);
begin
if [oo_is_external,oo_is_forward] <= od.objectoptions then
begin
{ formal definition: x = objcclass external; }
exclude(od.objectoptions,oo_is_forward);
include(od.objectoptions,oo_is_formal);
end;
end;
var
typename,orgtypename : TIDString;
newtype : ttypesym;
sym : tsym;
hdef : tdef;
defpos,storetokenpos : tfileposinfo;
old_block_type : tblock_type;
old_checkforwarddefs: TFPObjectList;
objecttype : tobjecttyp;
isgeneric,
isunique,
istyperenaming : boolean;
generictypelist : TFPObjectList;
generictokenbuf : tdynamicarray;
vmtbuilder : TVMTBuilder;
begin
old_block_type:=block_type;
{ save unit container of forward declarations -
we can be inside nested class type block }
old_checkforwarddefs:=current_module.checkforwarddefs;
current_module.checkforwarddefs:=TFPObjectList.Create(false);
block_type:=bt_type;
repeat
defpos:=current_tokenpos;
istyperenaming:=false;
generictypelist:=nil;
generictokenbuf:=nil;
{ fpc generic declaration? }
isgeneric:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_GENERIC);
typename:=pattern;
orgtypename:=orgpattern;
consume(_ID);
{ delphi generic declaration? }
if (m_delphi in current_settings.modeswitches) then
isgeneric:=token=_LSHARPBRACKET;
{ Generic type declaration? }
if isgeneric then
begin
if assigned(current_genericdef) then
Message(parser_f_no_generic_inside_generic);
consume(_LSHARPBRACKET);
generictypelist:=parse_generic_parameters;
consume(_RSHARPBRACKET);
end;
consume(_EQ);
{ support 'ttype=type word' syntax }
isunique:=try_to_consume(_TYPE);
{ MacPas object model is more like Delphi's than like TP's, but }
{ uses the object keyword instead of class }
if (m_mac in current_settings.modeswitches) and
(token = _OBJECT) then
token := _CLASS;
{ Start recording a generic template }
if assigned(generictypelist) then
begin
generictokenbuf:=tdynamicarray.create(256);
current_scanner.startrecordtokens(generictokenbuf);
end;
{ is the type already defined? -- must be in the current symtable,
not in a nested symtable or one higher up the stack -> don't
use searchsym & frinds! }
sym:=tsym(symtablestack.top.find(typename));
newtype:=nil;
{ found a symbol with this name? }
if assigned(sym) then
begin
if (sym.typ=typesym) then
begin
if ((token=_CLASS) or
(token=_INTERFACE) or
(token=_DISPINTERFACE) or
(token=_OBJCCLASS) or
(token=_OBJCPROTOCOL) or
(token=_OBJCCATEGORY)) and
(assigned(ttypesym(sym).typedef)) and
is_implicit_pointer_object_type(ttypesym(sym).typedef) and
(oo_is_forward in tobjectdef(ttypesym(sym).typedef).objectoptions) then
begin
case token of
_CLASS :
objecttype:=default_class_type;
_INTERFACE :
case current_settings.interfacetype of
it_interfacecom:
objecttype:=odt_interfacecom;
it_interfacecorba:
objecttype:=odt_interfacecorba;
it_interfacejava:
objecttype:=odt_interfacejava;
else
internalerror(2010122611);
end;
_DISPINTERFACE :
objecttype:=odt_dispinterface;
_OBJCCLASS,
_OBJCCATEGORY :
objecttype:=odt_objcclass;
_OBJCPROTOCOL :
objecttype:=odt_objcprotocol;
else
internalerror(200811072);
end;
consume(token);
{ we can ignore the result, the definition is modified }
object_dec(objecttype,orgtypename,nil,nil,tobjectdef(ttypesym(sym).typedef),ht_none);
newtype:=ttypesym(sym);
hdef:=newtype.typedef;
end
else
message1(parser_h_type_redef,orgtypename);
end;
end;
{ no old type reused ? Then insert this new type }
if not assigned(newtype) then
begin
{ insert the new type first with an errordef, so that
referencing the type before it's really set it
will give an error (PFV) }
hdef:=generrordef;
storetokenpos:=current_tokenpos;
newtype:=ttypesym.create(orgtypename,hdef);
newtype.visibility:=symtablestack.top.currentvisibility;
symtablestack.top.insert(newtype);
current_tokenpos:=defpos;
current_tokenpos:=storetokenpos;
{ read the type definition }
read_named_type(hdef,orgtypename,nil,generictypelist,false);
{ update the definition of the type }
if assigned(hdef) then
begin
if assigned(hdef.typesym) then
istyperenaming:=true;
if isunique then
begin
if is_objc_class_or_protocol(hdef) or
is_java_class_or_interface(hdef) then
Message(parser_e_unique_unsupported);
hdef:=tstoreddef(hdef).getcopy;
{ fix name, it is used e.g. for tables }
if is_class_or_interface_or_dispinterface(hdef) then
with tobjectdef(hdef) do
begin
stringdispose(objname);
stringdispose(objrealname);
objrealname:=stringdup(orgtypename);
objname:=stringdup(upper(orgtypename));
end;
include(hdef.defoptions,df_unique);
if (hdef.typ in [pointerdef,classrefdef]) and
(tabstractpointerdef(hdef).pointeddef.typ=forwarddef) then
current_module.checkforwarddefs.add(hdef);
end;
if not assigned(hdef.typesym) then
hdef.typesym:=newtype;
end;
newtype.typedef:=hdef;
{ KAZ: handle TGUID declaration in system unit }
if (cs_compilesystem in current_settings.moduleswitches) and not assigned(rec_tguid) and
(typename='TGUID') and { name: TGUID and size=16 bytes that is 128 bits }
assigned(hdef) and (hdef.typ=recorddef) and (hdef.size=16) then
rec_tguid:=trecorddef(hdef);
end;
if assigned(hdef) then
begin
case hdef.typ of
pointerdef :
begin
try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
consume(_SEMICOLON);
if try_to_consume(_FAR) then
begin
tpointerdef(hdef).is_far:=true;
consume(_SEMICOLON);
end;
end;
procvardef :
begin
{ in case of type renaming, don't parse proc directives }
if istyperenaming then
begin
try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
consume(_SEMICOLON);
end
else
begin
if not check_proc_directive(true) then
begin
try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
consume(_SEMICOLON);
end;
parse_var_proc_directives(tsym(newtype));
handle_calling_convention(tprocvardef(hdef));
if try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg) then
consume(_SEMICOLON);
end;
end;
objectdef :
begin
try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
consume(_SEMICOLON);
{ change a forward and external class declaration into
formal external definition, so the compiler does not
expect an real definition later }
if is_objc_class_or_protocol(hdef) or
is_java_class_or_interface(hdef) then
finalize_class_external_status(tobjectdef(hdef));
{ Build VMT indexes, skip for type renaming and forward classes }
if (hdef.typesym=newtype) and
not(oo_is_forward in tobjectdef(hdef).objectoptions) and
not(df_generic in hdef.defoptions) then
begin
vmtbuilder:=TVMTBuilder.Create(tobjectdef(hdef));
vmtbuilder.generate_vmt;
vmtbuilder.free;
end;
{ In case of an objcclass, verify that all methods have a message
name set. We only check this now, because message names can be set
during the protocol (interface) mapping. At the same time, set the
mangled names (these depend on the "external" name of the class),
and mark private fields of external classes as "used" (to avoid
bogus notes about them being unused)
}
{ watch out for crashes in case of errors }
if is_objc_class_or_protocol(hdef) and
(not is_objccategory(hdef) or
assigned(tobjectdef(hdef).childof)) then
tobjectdef(hdef).finish_objc_data;
if is_cppclass(hdef) then
tobjectdef(hdef).finish_cpp_data;
end;
recorddef :
begin
try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
consume(_SEMICOLON);
end;
else
begin
try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
consume(_SEMICOLON);
end;
end;
end;
if isgeneric and (not(hdef.typ in [objectdef,recorddef,arraydef,procvardef])
or is_objectpascal_helper(hdef)) then
message(parser_e_cant_create_generics_of_this_type);
{ Stop recording a generic template }
if assigned(generictypelist) then
begin
current_scanner.stoprecordtokens;
tstoreddef(hdef).generictokenbuf:=generictokenbuf;
{ Generic is never a type renaming }
hdef.typesym:=newtype;
generictypelist.free;
end;
until (token<>_ID) or
(in_structure and
((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
((m_final_fields in current_settings.modeswitches) and
(idtoken=_FINAL))));
{ resolve type block forward declarations and restore a unit
container for them }
resolve_forward_types;
current_module.checkforwarddefs.free;
current_module.checkforwarddefs:=old_checkforwarddefs;
block_type:=old_block_type;
end;
{ reads a type declaration to the symbol table }
procedure type_dec;
begin
consume(_TYPE);
types_dec(false);
end;
procedure var_dec;
{ parses variable declarations and inserts them in }
{ the top symbol table of symtablestack }
begin
consume(_VAR);
read_var_decls([]);
end;
procedure property_dec(is_classpropery: boolean);
var
old_block_type : tblock_type;
begin
consume(_PROPERTY);
if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
message(parser_e_resourcestring_only_sg);
old_block_type:=block_type;
block_type:=bt_const;
repeat
read_property_dec(is_classpropery, nil);
consume(_SEMICOLON);
until token<>_ID;
block_type:=old_block_type;
end;
procedure threadvar_dec;
{ parses thread variable declarations and inserts them in }
{ the top symbol table of symtablestack }
begin
consume(_THREADVAR);
if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
message(parser_e_threadvars_only_sg);
read_var_decls([vd_threadvar]);
end;
procedure resourcestring_dec;
var
orgname : TIDString;
p : tnode;
dummysymoptions : tsymoptions;
deprecatedmsg : pshortstring;
storetokenpos,filepos : tfileposinfo;
old_block_type : tblock_type;
sp : pchar;
sym : tsym;
begin
consume(_RESOURCESTRING);
if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
message(parser_e_resourcestring_only_sg);
old_block_type:=block_type;
block_type:=bt_const;
repeat
orgname:=orgpattern;
filepos:=current_tokenpos;
consume(_ID);
case token of
_EQ:
begin
consume(_EQ);
p:=comp_expr(true,false);
storetokenpos:=current_tokenpos;
current_tokenpos:=filepos;
sym:=nil;
case p.nodetype of
ordconstn:
begin
if is_constcharnode(p) then
begin
getmem(sp,2);
sp[0]:=chr(tordconstnode(p).value.svalue);
sp[1]:=#0;
sym:=tconstsym.create_string(orgname,constresourcestring,sp,1);
end
else
Message(parser_e_illegal_expression);
end;
stringconstn:
with Tstringconstnode(p) do
begin
getmem(sp,len+1);
move(value_str^,sp^,len+1);
sym:=tconstsym.create_string(orgname,constresourcestring,sp,len);
end;
else
Message(parser_e_illegal_expression);
end;
current_tokenpos:=storetokenpos;
{ Support hint directives }
dummysymoptions:=[];
deprecatedmsg:=nil;
try_consume_hintdirective(dummysymoptions,deprecatedmsg);
if assigned(sym) then
begin
sym.symoptions:=sym.symoptions+dummysymoptions;
sym.deprecatedmsg:=deprecatedmsg;
symtablestack.top.insert(sym);
end
else
stringdispose(deprecatedmsg);
consume(_SEMICOLON);
p.free;
end;
else consume(_EQ);
end;
until token<>_ID;
block_type:=old_block_type;
end;
end.
Reference in New Issue View Git Blame Copy Permalink