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

* basic support for generic classes

Browse Source 
git-svn-id: trunk@2020 -
This commit is contained in:
peter 2005-12-21 10:11:15 +00:00
parent 82a94db712
commit 95879fe8a7
36 changed files with 1128 additions and 471 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.gitattributes vendored
View File

@ -5578,6 +5578,11 @@ tests/test/tfpu3.pp svneol=native#text/plain
tests/test/tfpu4.pp svneol=native#text/plain
tests/test/tfpu5.pp svneol=native#text/plain
tests/test/tfpuover.pp svneol=native#text/plain
tests/test/tgeneric1.pp svneol=native#text/plain
tests/test/tgeneric2.pp svneol=native#text/plain
tests/test/tgeneric3.pp svneol=native#text/plain
tests/test/tgeneric4.pp svneol=native#text/plain
tests/test/tgeneric5.pp svneol=native#text/plain
tests/test/tgoto.pp svneol=native#text/plain
tests/test/theap.pp svneol=native#text/plain
tests/test/thintdir.pp svneol=native#text/plain
@ -5666,6 +5671,8 @@ tests/test/tutf82.pp svneol=native#text/plain%3Bcharset%3Dutf-8
tests/test/twide1.pp svneol=native#text/plain
tests/test/twide2.pp svneol=native#text/plain
tests/test/uabstrcl.pp svneol=native#text/plain
tests/test/ugeneric3.pp svneol=native#text/plain
tests/test/ugeneric4.pp svneol=native#text/plain
tests/test/uimpluni1.pp svneol=native#text/plain
tests/test/uimpluni2.pp svneol=native#text/plain
tests/test/uinline4a.pp svneol=native#text/plain

30
compiler/cgobj.pas
View File

@ -1434,20 +1434,7 @@ implementation
if is_interfacecom(t) then
incrfunc:='FPC_INTF_INCR_REF'
else if is_ansistring(t) then
{$ifdef ansistring_bits}
begin
case Tstringdef(t).string_typ of
st_ansistring16:
incrfunc:='FPC_ANSISTR16_INCR_REF';
st_ansistring32:
incrfunc:='FPC_ANSISTR32_INCR_REF';
st_ansistring64:
incrfunc:='FPC_ANSISTR64_INCR_REF';
end;
end
{$else}
incrfunc:='FPC_ANSISTR_INCR_REF'
{$endif}
incrfunc:='FPC_ANSISTR_INCR_REF'
else if is_widestring(t) then
incrfunc:='FPC_WIDESTR_INCR_REF'
else if is_dynamic_array(t) then
@ -1499,20 +1486,7 @@ implementation
if is_interfacecom(t) then
decrfunc:='FPC_INTF_DECR_REF'
else if is_ansistring(t) then
{$ifdef ansistring_bits}
begin
case Tstringdef(t).string_typ of
st_ansistring16:
decrfunc:='FPC_ANSISTR16_DECR_REF';
st_ansistring32:
decrfunc:='FPC_ANSISTR32_DECR_REF';
st_ansistring64:
decrfunc:='FPC_ANSISTR64_DECR_REF';
end;
end
{$else}
decrfunc:='FPC_ANSISTR_DECR_REF'
{$endif}
decrfunc:='FPC_ANSISTR_DECR_REF'
else if is_widestring(t) then
decrfunc:='FPC_WIDESTR_DECR_REF'
else if is_dynamic_array(t) then

37
compiler/dbgstabs.pas
View File

@ -730,7 +730,11 @@ implementation
result:=strpnew('*f'+def_stab_number(tprocvardef(def).rettype.def));
objectdef :
result:=objectdef_stabstr(tobjectdef(def));
undefineddef :
result:=def_stabstr_evaluate(def,'formal${numberstring};',[]);
end;
if result=nil then
internalerror(200512203);
end;
@ -798,10 +802,15 @@ implementation
var
anc : tobjectdef;
oldtypesym : tsym;
// nb : string[12];
begin
if (def.stab_state in [stab_state_writing,stab_state_written]) then
exit;
{ never write generic template defs }
if df_generic in def.defoptions then
begin
def.stab_state:=stab_state_written;
exit;
end;
{ to avoid infinite loops }
def.stab_state := stab_state_writing;
{ write dependencies first }
@ -857,31 +866,7 @@ implementation
tobjectdef(def).symtable.foreach(@method_write_defs,list);
end;
end;
(*
{ Handle pointerdefs to records and objects to avoid recursion }
if (def.deftype=pointerdef) and
(tpointerdef(def).pointertype.def.deftype in [recorddef,objectdef]) then
begin
def.stab_state:=stab_state_used;
write_def_stabstr(list,def);
{to avoid infinite recursion in record with next-like fields }
if tdef(tpointerdef(def).pointertype.def).stab_state=stab_state_writing then
begin
if assigned(tpointerdef(def).pointertype.def.typesym) then
begin
if is_class(tpointerdef(def).pointertype.def) then
nb:=def_stab_classnumber(tobjectdef(tpointerdef(def).pointertype.def))
else
nb:=def_stab_number(tpointerdef(def).pointertype.def);
list.concat(Tai_stab.create(stab_stabs,def_stabstr_evaluate(
def,'"${sym_name}:t${numberstring}=*$1=xs$2:",${N_LSYM},0,0,0',
[nb,tpointerdef(def).pointertype.def.typesym.name])));
end;
def.stab_state:=stab_state_written;
end
end
else
*)
case def.deftype of
objectdef :
begin

18
compiler/defcmp.pas
View File

@ -186,6 +186,24 @@ implementation
exit;
end;
{ undefined def? then mark it as equal }
if (def_from.deftype=undefineddef) or
(def_to.deftype=undefineddef) then
begin
doconv:=tc_equal;
compare_defs_ext:=te_equal;
exit;
end;
{ undefined def? then mark it as equal }
if (def_from.deftype=undefineddef) or
(def_to.deftype=undefineddef) then
begin
doconv:=tc_equal;
compare_defs_ext:=te_equal;
exit;
end;
{ we walk the wanted (def_to) types and check then the def_from
types if there is a conversion possible }
case def_to.deftype of

9
compiler/defutil.pas
View File

@ -525,21 +525,12 @@ implementation
);
end;
{$ifdef ansistring_bits}
{ true if p is an ansi string def }
function is_ansistring(p : tdef) : boolean;
begin
is_ansistring:=(p.deftype=stringdef) and
(tstringdef(p).string_typ in [st_ansistring16,st_ansistring32,st_ansistring64]);
end;
{$else}
{ true if p is an ansi string def }
function is_ansistring(p : tdef) : boolean;
begin
is_ansistring:=(p.deftype=stringdef) and
(tstringdef(p).string_typ=st_ansistring);
end;
{$endif}
{ true if p is an long string def }
function is_longstring(p : tdef) : boolean;

12
compiler/globals.pas
View File

@ -210,9 +210,6 @@ interface
Initsetalloc, {0=fixed, 1 =var}
{$ENDIF}
initpackenum : shortint;
{$ifdef ansistring_bits}
initansistring_bits: Tstringbits;
{$endif}
initalignment : talignmentinfo;
initoptprocessor,
initspecificoptprocessor : tprocessors;
@ -234,9 +231,6 @@ interface
{$ENDIF}
aktpackrecords,
aktpackenum : shortint;
{$ifdef ansistring_bits}
aktansistring_bits : Tstringbits;
{$endif}
aktmaxfpuregisters : longint;
aktalignment : talignmentinfo;
aktoptprocessor,
@ -1820,11 +1814,11 @@ end;
p := @r;
{$ifdef CPU_ARM}
inc(p,4);
{$else}
{$else}
{$ifdef FPC_LITTLE_ENDIAN}
inc(p,sizeof(r)-1);
{$endif}
{$endif}
{$endif}
{$endif}
if (p^ and $80) = 0 then
result := 1
else

4
compiler/globtype.pas
View File

@ -244,10 +244,6 @@ than 255 characters. That's why using Ansi Strings}
);
tprocinfoflags=set of tprocinfoflag;
{$ifdef ansistring_bits}
Tstringbits=(sb_16,sb_32,sb_64);
{$endif}
const
proccalloptionStr : array[tproccalloption] of string[14]=('',
'CDecl',

8
compiler/ncgmem.pas
View File

@ -575,11 +575,7 @@ implementation
case tstringdef(left.resulttype.def).string_typ of
{ it's the same for ansi- and wide strings }
st_widestring,
{$ifdef ansistring_bits}
st_ansistring16,st_ansistring32,st_ansistring64:
{$else}
st_ansistring:
{$endif}
begin
paramanager.getintparaloc(pocall_default,1,paraloc1);
paramanager.getintparaloc(pocall_default,2,paraloc2);
@ -713,11 +709,7 @@ implementation
case tstringdef(left.resulttype.def).string_typ of
{ it's the same for ansi- and wide strings }
st_widestring,
{$ifdef ansistring_bits}
st_ansistring16,st_ansistring32,st_ansistring64:
{$else}
st_ansistring:
{$endif}
begin
paramanager.getintparaloc(pocall_default,1,paraloc1);
paramanager.getintparaloc(pocall_default,2,paraloc2);

15
compiler/nld.pas
View File

@ -245,20 +245,7 @@ implementation
constsym:
begin
if tconstsym(symtableentry).consttyp=constresourcestring then
begin
{$ifdef ansistring_bits}
case aktansistring_bits of
sb_16:
resulttype:=cansistringtype16;
sb_32:
resulttype:=cansistringtype32;
sb_64:
resulttype:=cansistringtype64;
end;
{$else}
resulttype:=cansistringtype
{$endif}
end
resulttype:=cansistringtype
else
internalerror(22799);
end;

4
compiler/nmem.pas
View File

@ -714,11 +714,7 @@ implementation
case tstringdef(left.resulttype.def).string_typ of
st_widestring :
resulttype:=cwidechartype;
{$ifdef ansistring_bits}
st_ansistring16,st_ansistring32,st_ansistring64 :
{$else}
st_ansistring :
{$endif}
resulttype:=cchartype;
st_longstring :
resulttype:=cchartype;

4
compiler/parser.pas
View File

@ -184,7 +184,7 @@ implementation
current_module.scanner:=current_scanner;
{ loop until EOF is found }
repeat
current_scanner^.readtoken;
current_scanner^.readtoken(true);
preprocfile^.AddSpace;
case token of
_ID :
@ -465,7 +465,7 @@ implementation
macrosymtablestack:= current_module.localmacrosymtable;
{ read the first token }
current_scanner.readtoken;
current_scanner.readtoken(false);
{ init code generator for a new module }
init_module;

4
compiler/pbase.pas
View File

@ -134,7 +134,7 @@ implementation
begin
if token=_END then
last_endtoken_filepos:=akttokenpos;
current_scanner.readtoken;
current_scanner.readtoken(true);
end;
end;
@ -147,7 +147,7 @@ implementation
try_to_consume:=true;
if token=_END then
last_endtoken_filepos:=akttokenpos;
current_scanner.readtoken;
current_scanner.readtoken(true);
end;
end;

74
compiler/pdecl.pas
View File

@ -194,7 +194,7 @@ implementation
block_type:=bt_type;
consume(_COLON);
ignore_equal:=true;
read_type(tt,'',false);
read_anon_type(tt,false);
ignore_equal:=false;
block_type:=bt_const;
skipequal:=false;
@ -369,6 +369,22 @@ implementation
{ reads a type declaration to the symbol table }
procedure type_dec;
function parse_generic_parameters:tsinglelist;
var
generictype : ttypesym;
begin
result:=tsinglelist.create;
repeat
if token=_ID then
begin
generictype:=ttypesym.create(orgpattern,cundefinedtype);
result.insert(generictype);
end;
consume(_ID);
until not try_to_consume(_COMMA) ;
end;
var
typename,orgtypename : stringid;
newtype : ttypesym;
@ -379,22 +395,46 @@ implementation
defpos,storetokenpos : tfileposinfo;
old_block_type : tblock_type;
ch : tclassheader;
unique,istyperenaming : boolean;
isunique,
istyperenaming : boolean;
generictypelist : tsinglelist;
generictokenbuf : tdynamicarray;
begin
old_block_type:=block_type;
block_type:=bt_type;
consume(_TYPE);
typecanbeforward:=true;
repeat
typename:=pattern;
orgtypename:=orgpattern;
defpos:=akttokenpos;
istyperenaming:=false;
generictypelist:=nil;
generictokenbuf:=nil;
typename:=pattern;
orgtypename:=orgpattern;
consume(_ID);
{$ifdef GENERICSHARPBRACKET}
{ Generic type declaration? }
if try_to_consume(_LSHARPBRACKET) then
begin
generictypelist:=parse_generic_parameters;
consume(_RSHARPBRACKET);
end;
{$endif GENERICSHARPBRACKET}
consume(_EQUAL);
{ support 'ttype=type word' syntax }
unique:=try_to_consume(_TYPE);
isunique:=try_to_consume(_TYPE);
{ Generic type declaration? }
if try_to_consume(_GENERIC) then
begin
consume(_LKLAMMER);
generictypelist:=parse_generic_parameters;
consume(_RKLAMMER);
end;
{ MacPas object model is more like Delphi's than like TP's, but }
{ uses the object keyword instead of class }
@ -402,6 +442,13 @@ implementation
(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? }
searchsym(typename,sym,srsymtable);
newtype:=nil;
@ -418,7 +465,7 @@ implementation
begin
{ we can ignore the result }
{ the definition is modified }
object_dec(orgtypename,tobjectdef(ttypesym(sym).restype.def));
object_dec(orgtypename,nil,nil,tobjectdef(ttypesym(sym).restype.def));
newtype:=ttypesym(sym);
tt:=newtype.restype;
end
@ -439,14 +486,14 @@ implementation
akttokenpos:=defpos;
akttokenpos:=storetokenpos;
{ read the type definition }
read_type(tt,orgtypename,false);
read_named_type(tt,orgtypename,nil,generictypelist,false);
{ update the definition of the type }
newtype.restype:=tt;
if assigned(tt.sym) then
istyperenaming:=true
else
tt.sym:=newtype;
if unique and assigned(tt.def) then
if isunique and assigned(tt.def) then
begin
tt.setdef(tstoreddef(tt.def).getcopy);
include(tt.def.defoptions,df_unique);
@ -496,6 +543,15 @@ implementation
end;
end;
{ Stop recording a generic template }
if assigned(generictypelist) then
begin
current_scanner.stoprecordtokens;
tstoreddef(tt.def).generictokenbuf:=generictokenbuf;
{ Generic is never a type renaming }
tt.def.typesym:=newtype;
end;
{ Write tables if we are the typesym that defines
this type. This will not be done for simple type renamings }
if (tt.def.typesym=newtype) then

24
compiler/pdecobj.pas
View File

@ -26,15 +26,16 @@ unit pdecobj;
interface
uses
cclasses,
globtype,symtype,symdef;
{ parses a object declaration }
function object_dec(const n : stringid;fd : tobjectdef) : tdef;
function object_dec(const n : stringid;genericdef:tstoreddef;genericlist:tsinglelist;fd : tobjectdef) : tdef;
implementation
uses
cutils,cclasses,
cutils,
globals,verbose,systems,tokens,
symconst,symbase,symsym,
node,nld,nmem,ncon,ncnv,ncal,
@ -49,7 +50,7 @@ implementation
current_procinfo = 'error';
function object_dec(const n : stringid;fd : tobjectdef) : tdef;
function object_dec(const n : stringid;genericdef:tstoreddef;genericlist:tsinglelist;fd : tobjectdef) : tdef;
{ this function parses an object or class declaration }
var
there_is_a_destructor : boolean;
@ -498,6 +499,7 @@ implementation
var
pd : tprocdef;
dummysymoptions : tsymoptions;
generictype : ttypesym;
begin
old_object_option:=current_object_option;
@ -540,6 +542,22 @@ implementation
symtablestack:=aktobjectdef.symtable;
testcurobject:=1;
{ add generic type parameters }
aktobjectdef.genericdef:=genericdef;
if assigned(genericlist) then
begin
generictype:=ttypesym(genericlist.first);
while assigned(generictype) do
begin
if generictype.restype.def.deftype=undefineddef then
include(aktobjectdef.defoptions,df_generic)
else
include(aktobjectdef.defoptions,df_specialization);
symtablestack.insert(generictype);
generictype:=ttypesym(generictype.listnext);
end;
end;
{ short class declaration ? }
if (classtype<>odt_class) or (token<>_SEMICOLON) then
begin

46
compiler/pdecsub.pas
View File

@ -639,6 +639,7 @@ implementation
orgsp,sp : stringid;
sym : tsym;
srsym : tsym;
oldsymtablestack,
srsymtable : tsymtable;
storepos,
procstartfilepos : tfileposinfo;
@ -838,6 +839,31 @@ implementation
pd._class:=aclass;
pd.procsym:=aprocsym;
pd.proctypeoption:=potype;
{ methods inherit df_generic or df_specialization from the objectdef }
if assigned(pd._class) then
begin
if (df_generic in pd._class.defoptions) then
include(pd.defoptions,df_generic);
if (df_specialization in pd._class.defoptions) then
begin
include(pd.defoptions,df_specialization);
{ Find corresponding genericdef, we need it later to
replay the tokens to generate the body }
if not assigned(pd._class.genericdef) then
internalerror(200512113);
st:=pd._class.genericdef.getsymtable(gs_record);
if not assigned(st) then
internalerror(200512114);
{ We are parsing the same objectdef, the def index numbers
are the same }
pd.genericdef:=tstoreddef(st.getdefnr(pd.indexnr));
if not assigned(pd.genericdef) or
(pd.genericdef.deftype<>procdef) then
internalerror(200512115);
end;
end;
{ methods need to be exported }
if assigned(aclass) and
(
@ -852,7 +878,25 @@ implementation
{ parse parameters }
if token=_LKLAMMER then
parse_parameter_dec(pd);
begin
{ Add objectsymtable to be able to find generic type definitions }
oldsymtablestack:=symtablestack;
if assigned(pd._class) and
(pd.parast.symtablelevel=normal_function_level) and
(symtablestack.symtabletype<>objectsymtable) then
begin
pd._class.symtable.next:=symtablestack;
symtablestack:=pd._class.symtable;
end;
{ Add parameter symtable }
if pd.parast.symtabletype<>staticsymtable then
begin
pd.parast.next:=symtablestack;
symtablestack:=pd.parast;
end;
parse_parameter_dec(pd);
symtablestack:=oldsymtablestack;
end;
result:=true;
end;

13
compiler/pdecvar.pas
View File

@ -768,17 +768,20 @@ implementation
{ this is needed for Delphi mode at least
but should be OK for all modes !! (PM) }
ignore_equal:=true;
if options*[vd_record,vd_object]<>[] then
if ((vd_record in options) or
(vd_object in options)) and
not(df_generic in tdef(symtablestack.defowner).defoptions) and
not(df_specialization in tdef(symtablestack.defowner).defoptions) then
begin
{ for records, don't search the recordsymtable for
the symbols of the types }
oldsymtablestack:=symtablestack;
symtablestack:=symtablestack.next;
read_type(tt,'',false);
read_anon_type(tt,false);
symtablestack:=oldsymtablestack;
end
else
read_type(tt,'',false);
read_anon_type(tt,false);
ignore_equal:=false;
{ Process procvar directives }
if (tt.def.deftype=procvardef) and
@ -1209,7 +1212,7 @@ implementation
the symbols of the types }
oldsymtablestack:=symtablestack;
symtablestack:=symtablestack.next;
read_type(casetype,'',true);
read_anon_type(casetype,true);
symtablestack:=oldsymtablestack;
end
else
@ -1220,7 +1223,7 @@ implementation
the symbols of the types }
oldsymtablestack:=symtablestack;
symtablestack:=symtablestack.next;
read_type(casetype,'',true);
read_anon_type(casetype,true);
symtablestack:=oldsymtablestack;
fieldvs:=tfieldvarsym.create(sorg,vs_value,casetype,[]);
tabstractrecordsymtable(symtablestack).insertfield(fieldvs,true);

32
compiler/pexpr.pas
View File

@ -75,7 +75,7 @@ implementation
nmat,nadd,nmem,nset,ncnv,ninl,ncon,nld,nflw,nbas,nutils,
{ parser }
scanner,
pbase,pinline,
pbase,pinline,ptype,
{ codegen }
cgbase,procinfo,cpuinfo
;
@ -139,18 +139,7 @@ implementation
else
begin
if cs_ansistrings in aktlocalswitches then
{$ifdef ansistring_bits}
case aktansistring_bits of
sb_16:
t:=cansistringtype16;
sb_32:
t:=cansistringtype32;
sb_64:
t:=cansistringtype64;
end
{$else}
t:=cansistringtype
{$endif}
else
t:=cshortstringtype;
end;
@ -1323,7 +1312,8 @@ implementation
if (htype.def=cvarianttype.def) and
not(cs_compilesystem in aktmoduleswitches) then
current_module.flags:=current_module.flags or uf_uses_variants;
if try_to_consume(_LKLAMMER) then
if (block_type<>bt_type) and
try_to_consume(_LKLAMMER) then
begin
p1:=comp_expr(true);
consume(_RKLAMMER);
@ -1450,18 +1440,7 @@ implementation
begin
p1:=cloadnode.create(srsym,srsymtable);
do_resulttypepass(p1);
{$ifdef ansistring_bits}
case aktansistring_bits of
sb_16:
p1.resulttype:=cansistringtype16;
sb_32:
p1.resulttype:=cansistringtype32;
sb_64:
p1.resulttype:=cansistringtype64;
end;
{$else}
p1.resulttype:=cansistringtype;
{$endif}
end;
constguid :
p1:=cguidconstnode.create(pguid(tconstsym(srsym).value.valueptr)^);
@ -2425,9 +2404,10 @@ implementation
else
begin
p1:=cerrornode.create;
consume(token);
Message(parser_e_illegal_expression);
p1:=cerrornode.create;
{ recover }
consume(token);
end;
end;

35
compiler/pinline.pas
View File

@ -110,7 +110,7 @@ implementation
end;
do_member_read(classh,false,sym,p2,again,[]);
{ we need the real called method }
do_resulttypepass(p2);
@ -127,7 +127,7 @@ implementation
end
else
begin
{ Free is not a destructor
{ Free is not a destructor
if (tcallnode(p2).procdefinition.proctypeoption<>potype_destructor) then
Message(parser_e_expr_have_to_be_destructor_call);
}
@ -678,9 +678,6 @@ implementation
ppn : tcallparanode;
paradef : tdef;
counter : integer;
{$ifdef ansistring_bits}
mode : byte;
{$endif ansistring_bits}
begin
{ for easy exiting if something goes wrong }
result := cerrornode.create;
@ -704,40 +701,12 @@ implementation
ppn:=tcallparanode(ppn.right);
end;
paradef:=ppn.left.resulttype.def;
{$ifdef ansistring_bits}
if is_ansistring(paradef) then
case Tstringdef(paradef).string_typ of
st_ansistring16:
mode:=16;
st_ansistring32:
mode:=32;
st_ansistring64:
mode:=64;
end;
if (is_chararray(paradef) and (paradef.size>255)) or
((cs_ansistrings in aktlocalswitches) and is_pchar(paradef)) then
case aktansistring_bits of
sb_16:
mode:=16;
sb_32:
mode:=32;
sb_64:
mode:=64;
end;
if mode=16 then
copynode:=ccallnode.createintern('fpc_ansistr16_copy',paras)
else if mode=32 then
copynode:=ccallnode.createintern('fpc_ansistr32_copy',paras)
else if mode=64 then
copynode:=ccallnode.createintern('fpc_ansistr64_copy',paras)
{$else}
if is_ansistring(paradef) or
(is_chararray(paradef) and
(paradef.size>255)) or
((cs_ansistrings in aktlocalswitches) and
is_pchar(paradef)) then
copynode:=ccallnode.createintern('fpc_ansistr_copy',paras)
{$endif}
else
if is_widestring(paradef) or
is_widechararray(paradef) or

6
compiler/pmodules.pas
View File

@ -1091,6 +1091,9 @@ implementation
release_main_proc(pd);
end;
{ Generate specializations of objectdefs methods }
generate_specialization_procs;
{ if the unit contains ansi/widestrings, initialization and
finalization code must be forced }
force_init_final:=tglobalsymtable(current_module.globalsymtable).needs_init_final or
@ -1405,6 +1408,9 @@ implementation
current_module.mainfilepos:=current_procinfo.entrypos;
release_main_proc(pd);
{ Generate specializations of objectdefs methods }
generate_specialization_procs;
{ should we force unit initialization? }
if tstaticsymtable(current_module.localsymtable).needs_init_final then
begin

9
compiler/ppu.pas
View File

@ -43,7 +43,7 @@ type
{$endif Test_Double_checksum}
const
CurrentPPUVersion=50;
CurrentPPUVersion=51;
{ buffer sizes }
maxentrysize = 1024;
@ -116,15 +116,10 @@ const
ibfloatdef = 52;
ibclassrefdef = 53;
iblongstringdef = 54;
{$ifdef ansistring_bits}
ibansistring16def = 58;
ibansistring32def = 55;
ibansistring64def = 59;
{$else}
ibansistringdef = 55;
{$endif}
ibwidestringdef = 56;
ibvariantdef = 57;
ibundefineddef = 58;
{implementation/objectdata}
ibnodetree = 80;
ibasmsymbols = 81;

278
compiler/psub.pas
View File

@ -65,6 +65,7 @@ interface
{ reads declarations in the interface part of a unit }
procedure read_interface_declarations;
procedure generate_specialization_procs;
implementation
@ -622,6 +623,10 @@ implementation
if Errorcount<>0 then
exit;
{ No code can be generated for generic template }
if (df_generic in procdef.defoptions) then
internalerror(200511152);
{ The RA and Tempgen shall not be available yet }
if assigned(tg) then
internalerror(200309201);
@ -672,7 +677,7 @@ implementation
add_entry_exit_code;
{ only do secondpass if there are no errors }
if ErrorCount=0 then
if (ErrorCount=0) then
begin
{ set the start offset to the start of the temp area in the stack }
tg:=ttgobj.create;
@ -991,9 +996,13 @@ implementation
var
oldprocinfo : tprocinfo;
oldblock_type : tblock_type;
oldconstsymtable : tsymtable;
st : tsymtable;
begin
oldprocinfo:=current_procinfo;
oldblock_type:=block_type;
oldconstsymtable:=constsymtable;
{ reset break and continue labels }
block_type:=bt_body;
@ -1027,8 +1036,31 @@ implementation
entrypos:=aktfilepos;
entryswitches:=aktlocalswitches;
if (df_generic in procdef.defoptions) then
begin
{ start token recorder for generic template }
procdef.initgeneric;
current_scanner.startrecordtokens(procdef.generictokenbuf);
end;
{ parse the code ... }
code:=block(current_module.islibrary);
if (df_generic in procdef.defoptions) then
begin
{ stop token recorder for generic template }
current_scanner.stoprecordtokens;
{ Give a warning for accesses in the static symtable that aren't visible
outside the current unit }
st:=procdef.owner;
while (st.symtabletype=objectsymtable) do
st:=st.defowner.owner;
if (pi_uses_static_symtable in flags) and
(st.symtabletype<>staticsymtable) then
Comment(V_Warning,'Global Generic template references static symtable');
end;
{ save exit info }
exitswitches:=aktlocalswitches;
exitpos:=last_endtoken_filepos;
@ -1096,6 +1128,8 @@ implementation
allow_only_static:=false;
current_procinfo:=oldprocinfo;
{ Restore old state }
constsymtable:=oldconstsymtable;
block_type:=oldblock_type;
end;
@ -1117,6 +1151,115 @@ implementation
end;
procedure read_proc_body(old_current_procinfo:tprocinfo;pd:tprocdef);
{
Parses the procedure directives, then parses the procedure body, then
generates the code for it
}
procedure do_generate_code(pi:tcgprocinfo);
var
hpi : tcgprocinfo;
begin
{ generate code for this procedure }
pi.generate_code;
{ process nested procs }
hpi:=tcgprocinfo(pi.nestedprocs.first);
while assigned(hpi) do
begin
do_generate_code(hpi);
hpi:=tcgprocinfo(hpi.next);
end;
pi.resetprocdef;
end;
var
oldfailtokenmode : tmodeswitch;
isnestedproc : boolean;
begin
Message1(parser_d_procedure_start,pd.fullprocname(false));
{ create a new procedure }
current_procinfo:=cprocinfo.create(old_current_procinfo);
current_module.procinfo:=current_procinfo;
current_procinfo.procdef:=pd;
isnestedproc:=(current_procinfo.procdef.parast.symtablelevel>normal_function_level);
{ Insert mangledname }
pd.aliasnames.insert(pd.mangledname);
{ Handle Export of this procedure }
if (po_exports in pd.procoptions) and
(target_info.system in [system_i386_os2,system_i386_emx]) then
begin
pd.aliasnames.insert(pd.procsym.realname);
if cs_link_deffile in aktglobalswitches then
deffile.AddExport(pd.mangledname);
end;
{ Insert result variables in the localst }
insert_funcret_local(pd);
{ check if there are para's which require initing -> set }
{ pi_do_call (if not yet set) }
if not(pi_do_call in current_procinfo.flags) then
pd.parast.foreach_static(@check_init_paras,nil);
{ set _FAIL as keyword if constructor }
if (pd.proctypeoption=potype_constructor) then
begin
oldfailtokenmode:=tokeninfo^[_FAIL].keyword;
tokeninfo^[_FAIL].keyword:=m_all;
end;
tcgprocinfo(current_procinfo).parse_body;
{ When it's a nested procedure then defer the code generation,
when back at normal function level then generate the code
for all defered nested procedures and the current procedure }
if isnestedproc then
tcgprocinfo(current_procinfo.parent).nestedprocs.insert(current_procinfo)
else
begin
{ We can't support inlining for procedures that have nested
procedures because the nested procedures use a fixed offset
for accessing locals in the parent procedure (PFV) }
if (tcgprocinfo(current_procinfo).nestedprocs.count>0) then
begin
if (df_generic in current_procinfo.procdef.defoptions) then
{$warning TODO Add error message for nested procs in generics}
internalerror(200511151)
else if (po_inline in current_procinfo.procdef.procoptions) then
begin
Message1(parser_w_not_supported_for_inline,'nested procedures');
Message(parser_w_inlining_disabled);
current_procinfo.procdef.proccalloption:=pocall_default;
end;
end;
if not(df_generic in current_procinfo.procdef.defoptions) then
do_generate_code(tcgprocinfo(current_procinfo));
end;
{ reset _FAIL as _SELF normal }
if (pd.proctypeoption=potype_constructor) then
tokeninfo^[_FAIL].keyword:=oldfailtokenmode;
{ release procinfo }
if tprocinfo(current_module.procinfo)<>current_procinfo then
internalerror(200304274);
current_module.procinfo:=current_procinfo.parent;
if not isnestedproc then
current_procinfo.free;
{ For specialization we didn't record the last semicolon. Moving this parsing
into the parse_body routine is not done because of having better file position
information available }
if not(df_specialization in current_procinfo.procdef.defoptions) then
consume(_SEMICOLON);
end;
procedure read_proc;
{
Parses the procedure directives, then parses the procedure body, then
@ -1141,15 +1284,11 @@ implementation
var
old_current_procinfo : tprocinfo;
oldconstsymtable : tsymtable;
oldfailtokenmode : tmodeswitch;
pdflags : tpdflags;
pd : tprocdef;
isnestedproc : boolean;
s : string;
begin
{ save old state }
oldconstsymtable:=constsymtable;
old_current_procinfo:=current_procinfo;
{ reset current_procinfo.procdef to nil to be sure that nothing is writing
@ -1233,75 +1372,7 @@ implementation
{ compile procedure when a body is needed }
if (pd_body in pdflags) then
begin
Message1(parser_d_procedure_start,pd.fullprocname(false));
{ create a new procedure }
current_procinfo:=cprocinfo.create(old_current_procinfo);
current_module.procinfo:=current_procinfo;
current_procinfo.procdef:=pd;
isnestedproc:=(current_procinfo.procdef.parast.symtablelevel>normal_function_level);
{ Insert mangledname }
pd.aliasnames.insert(pd.mangledname);
{ Handle Export of this procedure }
if (po_exports in pd.procoptions) and
(target_info.system in [system_i386_os2,system_i386_emx]) then
begin
pd.aliasnames.insert(pd.procsym.realname);
if cs_link_deffile in aktglobalswitches then
deffile.AddExport(pd.mangledname);
end;
{ Insert result variables in the localst }
insert_funcret_local(pd);
{ check if there are para's which require initing -> set }
{ pi_do_call (if not yet set) }
if not(pi_do_call in current_procinfo.flags) then
pd.parast.foreach_static(@check_init_paras,nil);
{ set _FAIL as keyword if constructor }
if (pd.proctypeoption=potype_constructor) then
begin
oldfailtokenmode:=tokeninfo^[_FAIL].keyword;
tokeninfo^[_FAIL].keyword:=m_all;
end;
tcgprocinfo(current_procinfo).parse_body;
{ When it's a nested procedure then defer the code generation,
when back at normal function level then generate the code
for all defered nested procedures and the current procedure }
if isnestedproc then
tcgprocinfo(current_procinfo.parent).nestedprocs.insert(current_procinfo)
else
begin
{ We can't support inlining for procedures that have nested
procedures because the nested procedures use a fixed offset
for accessing locals in the parent procedure (PFV) }
if (po_inline in current_procinfo.procdef.procoptions) and
(tcgprocinfo(current_procinfo).nestedprocs.count>0) then
begin
Message1(parser_w_not_supported_for_inline,'nested procedures');
Message(parser_w_inlining_disabled);
current_procinfo.procdef.proccalloption:=pocall_default;
end;
do_generate_code(tcgprocinfo(current_procinfo));
end;
{ reset _FAIL as _SELF normal }
if (pd.proctypeoption=potype_constructor) then
tokeninfo^[_FAIL].keyword:=oldfailtokenmode;
{ release procinfo }
if tprocinfo(current_module.procinfo)<>current_procinfo then
internalerror(200304274);
current_module.procinfo:=current_procinfo.parent;
if not isnestedproc then
current_procinfo.free;
consume(_SEMICOLON);
read_proc_body(old_current_procinfo,pd);
end
else
begin
@ -1348,9 +1419,6 @@ implementation
end;
end;
{ Restore old state }
constsymtable:=oldconstsymtable;
current_procinfo:=old_current_procinfo;
end;
@ -1483,4 +1551,60 @@ implementation
end;
{****************************************************************************
SPECIALIZATION BODY GENERATION
****************************************************************************}
procedure specialize_objectdefs(p:tnamedindexitem;arg:pointer);
var
hp : tdef;
oldaktfilepos : tfileposinfo;
begin
if not((tsym(p).typ=typesym) and
(ttypesym(p).restype.def.deftype=objectdef) and
(df_specialization in ttypesym(p).restype.def.defoptions)
) then
exit;
{ definitions }
hp:=tdef(tobjectdef(ttypesym(p).restype.def).symtable.defindex.first);
while assigned(hp) do
begin
if hp.deftype=procdef then
begin
if not(
assigned(tprocdef(hp).genericdef) and
(tprocdef(hp).genericdef.deftype=procdef) and
assigned(tprocdef(tprocdef(hp).genericdef).generictokenbuf)
) then
internalerror(200512111);
oldaktfilepos:=aktfilepos;
aktfilepos:=tprocdef(tprocdef(hp).genericdef).fileinfo;
akttokenpos:=aktfilepos;
current_scanner.startreplaytokens(tprocdef(tprocdef(hp).genericdef).generictokenbuf);
read_proc_body(nil,tprocdef(hp));
aktfilepos:=oldaktfilepos;
end;
hp:=tdef(hp.indexnext);
end;
end;
procedure generate_specialization_procs;
var
oldsymtablestack : tsymtable;
begin
if assigned(current_module.globalsymtable) then
current_module.globalsymtable.foreach_static(@specialize_objectdefs,nil);
if assigned(current_module.localsymtable) then
begin
oldsymtablestack:=symtablestack;
current_module.localsymtable.next:=symtablestack;
symtablestack:=current_module.localsymtable;
current_module.localsymtable.foreach_static(@specialize_objectdefs,nil);
symtablestack:=oldsymtablestack;
end;
end;
end.

27
compiler/psystem.pas
View File

@ -158,13 +158,7 @@ implementation
{$ifdef support_longstring}
addtype('LongString',clongstringtype);
{$endif support_longstring}
{$ifdef ansistring_bits}
addtype('AnsiString',cansistringtype16);
addtype('AnsiString',cansistringtype32);
addtype('AnsiString',cansistringtype64);
{$else}
addtype('AnsiString',cansistringtype);
{$endif}
addtype('WideString',cwidestringtype);
addtype('Boolean',booltype);
addtype('ByteBool',booltype);
@ -185,6 +179,7 @@ implementation
addtype('Variant',cvarianttype);
addtype('OleVariant',colevarianttype);
{ Internal types }
addtype('$undefined',cundefinedtype);
addtype('$formal',cformaltype);
addtype('$void',voidtype);
addtype('$byte',u8inttype);
@ -199,13 +194,7 @@ implementation
addtype('$widechar',cwidechartype);
addtype('$shortstring',cshortstringtype);
addtype('$longstring',clongstringtype);
{$ifdef ansistring_bits}
addtype('$ansistring16',cansistringtype16);
addtype('$ansistring32',cansistringtype32);
addtype('$ansistring64',cansistringtype64);
{$else}
addtype('$ansistring',cansistringtype);
{$endif}
addtype('$widestring',cwidestringtype);
addtype('$openshortstring',openshortstringtype);
addtype('$boolean',booltype);
@ -277,19 +266,14 @@ implementation
loadtype('longint',s32inttype);
loadtype('qword',u64inttype);
loadtype('int64',s64inttype);
loadtype('undefined',cundefinedtype);
loadtype('formal',cformaltype);
loadtype('void',voidtype);
loadtype('char',cchartype);
loadtype('widechar',cwidechartype);
loadtype('shortstring',cshortstringtype);
loadtype('longstring',clongstringtype);
{$ifdef ansistring_bits}
loadtype('ansistring16',cansistringtype16);
loadtype('ansistring32',cansistringtype32);
loadtype('ansistring64',cansistringtype64);
{$else}
loadtype('ansistring',cansistringtype);
{$endif}
loadtype('widestring',cwidestringtype);
loadtype('openshortstring',openshortstringtype);
loadtype('openchararray',openchararraytype);
@ -332,6 +316,7 @@ implementation
{ create definitions for constants }
oldregisterdef:=registerdef;
registerdef:=false;
cundefinedtype.setdef(tundefineddef.create);
cformaltype.setdef(tformaldef.create);
voidtype.setdef(torddef.create(uvoid,0,0));
u8inttype.setdef(torddef.create(u8bit,0,255));
@ -348,13 +333,7 @@ implementation
cshortstringtype.setdef(tstringdef.createshort(255));
{ should we give a length to the default long and ansi string definition ?? }
clongstringtype.setdef(tstringdef.createlong(-1));
{$ifdef ansistring_bits}
cansistringtype16.setdef(tstringdef.createansi(-1,sb_16));
cansistringtype32.setdef(tstringdef.createansi(-1,sb_32));
cansistringtype64.setdef(tstringdef.createansi(-1,sb_64));
{$else}
cansistringtype.setdef(tstringdef.createansi(-1));
{$endif}
cwidestringtype.setdef(tstringdef.createwide(-1));
{ length=0 for shortstring is open string (needed for readln(string) }
openshortstringtype.setdef(tstringdef.createshort(0));

135
compiler/ptype.pas
View File

@ -26,7 +26,7 @@ unit ptype;
interface
uses
globtype,symtype;
globtype,cclasses,symtype,symdef;
const
{ forward types should only be possible inside a TYPE statement }
@ -41,7 +41,8 @@ interface
{ tdef }
procedure single_type(var tt:ttype;isforwarddef:boolean);
procedure read_type(var tt:ttype;const name : stringid;parseprocvardir:boolean);
procedure read_named_type(var tt:ttype;const name : stringid;genericdef:tstoreddef;genericlist:tsinglelist;parseprocvardir:boolean);
procedure read_anon_type(var tt : ttype;parseprocvardir:boolean);
{ reads a type definition }
{ to a appropriating tdef, s gets the name of }
@ -60,7 +61,7 @@ implementation
{ target }
paramgr,
{ symtable }
symconst,symbase,symdef,symsym,symtable,
symconst,symbase,symsym,symtable,
defutil,defcmp,
{ pass 1 }
node,
@ -70,6 +71,101 @@ implementation
pbase,pexpr,pdecsub,pdecvar,pdecobj;
procedure generate_specialization(var pt1:tnode;const name:string);
var
st : tsymtable;
pt2 : tnode;
first,
err : boolean;
sym : tsym;
genericdef : tstoreddef;
generictype : ttypesym;
generictypelist : tsinglelist;
begin
{ retrieve generic def that we are going to replace }
genericdef:=tstoreddef(pt1.resulttype.def);
pt1.resulttype.reset;
if not(df_generic in genericdef.defoptions) then
begin
Comment(V_Error,'Specialization is only supported for generic types');
pt1.resulttype:=generrortype;
{ recover }
{$ifdef GENERICSHARPBRACKET}
consume(_LSHARPBRACKET);
{$endif GENERICSHARPBRACKET}
consume(_LKLAMMER);
repeat
pt2:=factor(false);
pt2.free;
until not try_to_consume(_COMMA);
{$ifdef GENERICSHARPBRACKET}
consume(_RSHARPBRACKET);
{$endif GENERICSHARPBRACKET}
consume(_RKLAMMER);
exit;
end;
{$ifdef GENERICSHARPBRACKET}
consume(_LSHARPBRACKET);
{$endif GENERICSHARPBRACKET}
consume(_LKLAMMER);
{ Parse generic parameters, for each undefineddef in the symtable of
the genericdef we need to have a new def }
err:=false;
first:=true;
generictypelist:=tsinglelist.create;
case genericdef.deftype of
procdef :
st:=genericdef.getsymtable(gs_para);
objectdef,
recorddef :
st:=genericdef.getsymtable(gs_record);
end;
if not assigned(st) then
internalerror(200511182);
sym:=tsym(st.symindex.first);
while assigned(sym) do
begin
if (sym.typ=typesym) and
(ttypesym(sym).restype.def.deftype=undefineddef) then
begin
if not first then
begin
consume(_COMMA);
first:=false;
end;
pt2:=factor(false);
if pt2.nodetype=typen then
begin
generictype:=ttypesym.create(sym.realname,pt2.resulttype);
generictypelist.insert(generictype);
end
else
begin
Message(type_e_type_id_expected);
err:=true;
end;
pt2.free;
end;
sym:=tsym(sym.indexnext);
end;
{ Reparse the original type definition }
if not err then
begin
if not assigned(genericdef.generictokenbuf) then
internalerror(200511171);
current_scanner.startreplaytokens(genericdef.generictokenbuf);
read_named_type(pt1.resulttype,name,genericdef,generictypelist,false);
{ Consume the semicolon if it is also recorded }
try_to_consume(_SEMICOLON);
end;
generictypelist.free;
{$ifdef GENERICSHARPBRACKET}
consume(_RSHARPBRACKET);
{$endif GENERICSHARPBRACKET}
consume(_RKLAMMER);
end;
procedure id_type(var tt : ttype;isforwarddef:boolean);
{ reads a type definition }
{ to a appropriating tdef, s gets the name of }
@ -188,6 +284,7 @@ implementation
case token of
_STRING:
string_dec(tt);
_FILE:
begin
consume(_FILE);
@ -200,8 +297,10 @@ implementation
else
tt:=cfiletype;
end;
_ID:
id_type(tt,isforwarddef);
else
begin
message(type_e_type_id_expected);
@ -244,7 +343,7 @@ implementation
{ reads a type definition and returns a pointer to it }
procedure read_type(var tt : ttype;const name : stringid;parseprocvardir:boolean);
procedure read_named_type(var tt : ttype;const name : stringid;genericdef:tstoreddef;genericlist:tsinglelist;parseprocvardir:boolean);
var
pt : tnode;
tt2 : ttype;
@ -259,6 +358,7 @@ implementation
var
pt1,pt2 : tnode;
lv,hv : TConstExprInt;
ispecialization : boolean;
begin
{ use of current parsed object:
- classes can be used also in classes
@ -275,6 +375,8 @@ implementation
tt.setdef(aktobjectdef);
exit;
end;
{ Generate a specialization? }
ispecialization:=try_to_consume(_SPECIALIZE);
{ we can't accept a equal in type }
pt1:=comp_expr(not(ignore_equal));
if (token=_POINTPOINT) then
@ -322,9 +424,13 @@ implementation
end
else
begin
{ a simple type renaming }
{ a simple type renaming or generic specialization }
if (pt1.nodetype=typen) then
tt:=ttypenode(pt1).resulttype
begin
if ispecialization then
generate_specialization(pt1,name);
tt:=ttypenode(pt1).resulttype;
end
else
Message(sym_e_error_in_type_def);
end;
@ -390,7 +496,7 @@ implementation
be parsed by readtype (PFV) }
if token=_LKLAMMER then
begin
read_type(ht,'',true);
read_anon_type(ht,true);
setdefdecl(ht);
end
else
@ -458,7 +564,7 @@ implementation
tt.setdef(ap);
end;
consume(_OF);
read_type(tt2,'',true);
read_anon_type(tt2,true);
{ if no error, set element type }
if assigned(ap) then
ap.setelementtype(tt2);
@ -544,7 +650,7 @@ implementation
begin
consume(_SET);
consume(_OF);
read_type(tt2,'',true);
read_anon_type(tt2,true);
if assigned(tt2.def) then
begin
case tt2.def.deftype of
@ -591,7 +697,7 @@ implementation
oldaktpackrecords:=aktpackrecords;
aktpackrecords:=1;
if token in [_CLASS,_OBJECT] then
tt.setdef(object_dec(name,nil))
tt.setdef(object_dec(name,genericdef,genericlist,nil))
else
tt.setdef(record_dec);
aktpackrecords:=oldaktpackrecords;
@ -602,7 +708,7 @@ implementation
_INTERFACE,
_OBJECT:
begin
tt.setdef(object_dec(name,nil));
tt.setdef(object_dec(name,genericdef,genericlist,nil));
end;
_PROCEDURE,
_FUNCTION:
@ -646,4 +752,11 @@ implementation
tt:=generrortype;
end;
procedure read_anon_type(var tt : ttype;parseprocvardir:boolean);
begin
read_named_type(tt,'',nil,nil,parseprocvardir);
end;
end.

235
compiler/scanner.pas
View File

@ -83,6 +83,10 @@ interface
lasttoken,
nexttoken : ttoken;
replaysavetoken : ttoken;
replaytokenbuf,
recordtokenbuf : tdynamicarray;
comment_level,
yylexcount : longint;
lastasmgetchar : char;
@ -121,6 +125,11 @@ interface
procedure handleconditional(p:tdirectiveitem);
procedure handledirectives;
procedure linebreak;
procedure recordtoken;
procedure startrecordtokens(buf:tdynamicarray);
procedure stoprecordtokens;
procedure replaytoken;
procedure startreplaytokens(buf:tdynamicarray);
procedure readchar;
procedure readstring;
procedure readnumber;
@ -136,7 +145,7 @@ interface
procedure skipcomment;
procedure skipdelphicomment;
procedure skipoldtpcomment;
procedure readtoken;
procedure readtoken(allowrecordtoken:boolean);
function readpreproc:ttoken;
function asmgetcharstart : char;
function asmgetchar:char;
@ -1741,6 +1750,119 @@ compile time variables as the old format (0/1), continue to work.
end;
procedure tscannerfile.startrecordtokens(buf:tdynamicarray);
begin
if not assigned(buf) then
internalerror(200511172);
if assigned(recordtokenbuf) then
internalerror(200511173);
recordtokenbuf:=buf;
end;
procedure tscannerfile.stoprecordtokens;
begin
if not assigned(recordtokenbuf) then
internalerror(200511174);
recordtokenbuf:=nil;
end;
procedure tscannerfile.recordtoken;
begin
if not assigned(recordtokenbuf) then
internalerror(200511176);
recordtokenbuf.write(token,1);
if token=_ID then
recordtokenbuf.write(idtoken,1);
case token of
_CWCHAR,
_CWSTRING :
begin
recordtokenbuf.write(patternw^.len,sizeof(sizeint));
recordtokenbuf.write(patternw^.data^,patternw^.len*sizeof(tcompilerwidechar));
end;
_CCHAR,
_CSTRING,
_INTCONST,
_REALNUMBER :
begin
recordtokenbuf.write(pattern[0],1);
recordtokenbuf.write(pattern[1],length(pattern));
end;
_ID :
begin
recordtokenbuf.write(orgpattern[0],1);
recordtokenbuf.write(orgpattern[1],length(orgpattern));
end;
end;
end;
procedure tscannerfile.startreplaytokens(buf:tdynamicarray);
begin
if not assigned(buf) then
internalerror(200511175);
{ save current token }
if token in [_CWCHAR,_CWSTRING,_CCHAR,_CSTRING,_INTCONST,_REALNUMBER,_ID] then
internalerror(200511178);
replaysavetoken:=token;
dec(inputpointer);
{ install buffer }
replaytokenbuf:=buf;
{ reload next token }
replaytokenbuf.seek(0);
replaytoken;
end;
procedure tscannerfile.replaytoken;
var
wlen : sizeint;
begin
if not assigned(replaytokenbuf) then
internalerror(200511177);
{ End of replay buffer? Then load the next char from the file again }
if replaytokenbuf.pos>=replaytokenbuf.size then
begin
replaytokenbuf:=nil;
c:=inputpointer^;
inc(inputpointer);
token:=replaysavetoken;
exit;
end;
{ load token from the buffer }
replaytokenbuf.read(token,1);
if token=_ID then
replaytokenbuf.read(idtoken,1);
case token of
_CWCHAR,
_CWSTRING :
begin
replaytokenbuf.read(wlen,sizeof(SizeInt));
setlengthwidestring(patternw,wlen);
replaytokenbuf.read(patternw^.data^,patternw^.len*sizeof(tcompilerwidechar));
pattern:='';
end;
_CCHAR,
_CSTRING,
_INTCONST,
_REALNUMBER :
begin
replaytokenbuf.read(pattern[0],1);
replaytokenbuf.read(pattern[1],length(pattern));
orgpattern:='';
end;
_ID :
begin
replaytokenbuf.read(orgpattern[0],1);
replaytokenbuf.read(orgpattern[1],length(orgpattern));
pattern:=upper(orgpattern);
end;
end;
end;
procedure tscannerfile.addfile(hp:tinputfile);
begin
saveinputfile;
@ -2776,7 +2898,7 @@ compile time variables as the old format (0/1), continue to work.
Token Scanner
****************************************************************************}
procedure tscannerfile.readtoken;
procedure tscannerfile.readtoken(allowrecordtoken:boolean);
var
code : integer;
len,
@ -2795,6 +2917,19 @@ compile time variables as the old format (0/1), continue to work.
aktlocalswitches:=nextaktlocalswitches;
localswitcheschanged:=false;
end;
{ record tokens? }
if allowrecordtoken and
assigned(recordtokenbuf) then
recordtoken;
{ replay tokens? }
if assigned(replaytokenbuf) then
begin
replaytoken;
goto exit_label;
end;
{ was there already a token read, then return that token }
if nexttoken<>NOTOKEN then
begin
@ -2885,7 +3020,7 @@ compile time variables as the old format (0/1), continue to work.
{ handle empty macros }
if c=#0 then
reload;
readtoken;
readtoken(false);
{ that's all folks }
dec(yylexcount);
exit;
@ -3028,7 +3163,7 @@ compile time variables as the old format (0/1), continue to work.
begin
c:=#0;{Signal skipoldtpcomment to reload a char }
skipoldtpcomment;
readtoken;
readtoken(false);
exit;
end;
'.' :
@ -3123,7 +3258,7 @@ compile time variables as the old format (0/1), continue to work.
'/' :
begin
skipdelphicomment;
readtoken;
readtoken(false);
exit;
end;
end;
@ -3422,54 +3557,64 @@ compile time variables as the old format (0/1), continue to work.
'>' :
begin
readchar;
case c of
'=' :
begin
readchar;
token:=_GTE;
goto exit_label;
if (block_type=bt_type) then
token:=_RSHARPBRACKET
else
begin
case c of
'=' :
begin
readchar;
token:=_GTE;
goto exit_label;
end;
'>' :
begin
readchar;
token:=_OP_SHR;
goto exit_label;
end;
'<' :
begin { >< is for a symetric diff for sets }
readchar;
token:=_SYMDIF;
goto exit_label;
end;
end;
'>' :
begin
readchar;
token:=_OP_SHR;
goto exit_label;
end;
'<' :
begin { >< is for a symetric diff for sets }
readchar;
token:=_SYMDIF;
goto exit_label;
end;
end;
token:=_GT;
token:=_GT;
end;
goto exit_label;
end;
'<' :
begin
readchar;
case c of
'>' :
begin
readchar;
token:=_UNEQUAL;
goto exit_label;
if (block_type=bt_type) then
token:=_LSHARPBRACKET
else
begin
case c of
'>' :
begin
readchar;
token:=_UNEQUAL;
goto exit_label;
end;
'=' :
begin
readchar;
token:=_LTE;
goto exit_label;
end;
'<' :
begin
readchar;
token:=_OP_SHL;
goto exit_label;
end;
end;
'=' :
begin
readchar;
token:=_LTE;
goto exit_label;
end;
'<' :
begin
readchar;
token:=_OP_SHL;
goto exit_label;
end;
end;
token:=_LT;
token:=_LT;
end;
goto exit_label;
end;

20
compiler/symconst.pas
View File

@ -43,11 +43,7 @@ const
tkSString = 7;
tkString = tkSString;
tkLString = 8;
{$ifdef ansistring_bits}
tkA32String = 9;
{$else}
tkAString = 9;
{$endif}
tkWString = 10;
tkVariant = 11;
tkArray = 12;
@ -61,11 +57,7 @@ const
tkQWord = 20;
tkDynArray = 21;
tkInterfaceCorba = 22;
{$ifdef ansistring_bits}
tkA16string = 23;
tkA64string = 24;
{$endif}
tkprocvar = 25;
tkProcVar = 23;
otSByte = 0;
otUByte = 1;
@ -159,7 +151,11 @@ type
{ rtti data has been generated }
df_has_rttitable,
{ type is unique, i.e. declared with type = type <tdef>; }
df_unique
df_unique,
{ type is a generic }
df_generic,
{ type is a specialization of a generic type }
df_specialization
);
tdefoptions=set of tdefoption;
@ -353,7 +349,7 @@ type
tdeftype = (abstractdef,arraydef,recorddef,pointerdef,orddef,
stringdef,enumdef,procdef,objectdef,errordef,
filedef,formaldef,setdef,procvardef,floatdef,
classrefdef,forwarddef,variantdef);
classrefdef,forwarddef,variantdef,undefineddef);
{ possible types for symtable entries }
tsymtyp = (abstractsym,globalvarsym,localvarsym,paravarsym,fieldvarsym,
@ -421,7 +417,7 @@ const
'abstractdef','arraydef','recorddef','pointerdef','orddef',
'stringdef','enumdef','procdef','objectdef','errordef',
'filedef','formaldef','setdef','procvardef','floatdef',
'classrefdef','forwarddef','variantdef'
'classrefdef','forwarddef','variantdef','undefineddef'
);
EqualTypeName : array[tequaltype] of string[16] = (

204
compiler/symdef.pas
View File

@ -59,12 +59,16 @@ interface
inittablesymderef : tderef;
{ local (per module) rtti and init tables }
localrttilab : array[trttitype] of tasmlabel;
{ linked list of global definitions }
{$ifdef EXTDEBUG}
fileinfo : tfileposinfo;
{$endif}
{ generic support }
genericdef : tstoreddef;
genericdefderef : tderef;
generictokenbuf : tdynamicarray;
constructor create;
constructor ppuloaddef(ppufile:tcompilerppufile);
destructor destroy;override;
procedure reset;virtual;
function getcopy : tstoreddef;virtual;
procedure ppuwritedef(ppufile:tcompilerppufile);
@ -86,6 +90,8 @@ interface
{ regvars }
function is_intregable : boolean;
function is_fpuregable : boolean;
{ generics }
procedure initgeneric;
private
savesize : aint;
end;
@ -136,6 +142,13 @@ interface
function gettypename:string;override;
end;
tundefineddef = class(tstoreddef)
constructor create;
constructor ppuload(ppufile:tcompilerppufile);
procedure ppuwrite(ppufile:tcompilerppufile);override;
function gettypename:string;override;
end;
terrordef = class(tstoreddef)
constructor create;
procedure ppuwrite(ppufile:tcompilerppufile);override;
@ -552,13 +565,8 @@ interface
constructor loadshort(ppufile:tcompilerppufile);
constructor createlong(l : aint);
constructor loadlong(ppufile:tcompilerppufile);
{$ifdef ansistring_bits}
constructor createansi(l:aint;bits:Tstringbits);
constructor loadansi(ppufile:tcompilerppufile;bits:Tstringbits);
{$else}
constructor createansi(l : aint);
constructor loadansi(ppufile:tcompilerppufile);
{$endif}
constructor createwide(l : aint);
constructor loadwide(ppufile:tcompilerppufile);
function getcopy : tstoreddef;override;
@ -634,6 +642,7 @@ interface
charpointertype, { pointer for Char-Pointerdef }
widecharpointertype, { pointer for WideChar-Pointerdef }
voidfarpointertype,
cundefinedtype,
cformaltype, { unique formal definition }
voidtype, { Void (procedure) }
cchartype, { Char }
@ -653,13 +662,7 @@ interface
s64currencytype, { pointer to a currency type }
cshortstringtype, { pointer to type of short string const }
clongstringtype, { pointer to type of long string const }
{$ifdef ansistring_bits}
cansistringtype16, { pointer to type of ansi string const }
cansistringtype32, { pointer to type of ansi string const }
cansistringtype64, { pointer to type of ansi string const }
{$else}
cansistringtype, { pointer to type of ansi string const }
{$endif}
cwidestringtype, { pointer to type of wide string const }
openshortstringtype, { pointer to type of an open shortstring,
needed for readln() }
@ -899,10 +902,23 @@ implementation
if registerdef then
symtablestack.registerdef(self);
fillchar(localrttilab,sizeof(localrttilab),0);
generictokenbuf:=nil;
genericdef:=nil;
end;
destructor tstoreddef.destroy;
begin
if assigned(generictokenbuf) then
generictokenbuf.free;
inherited destroy;
end;
constructor tstoreddef.ppuloaddef(ppufile:tcompilerppufile);
var
sizeleft,i : longint;
buf : array[0..255] of byte;
begin
inherited create;
{$ifdef EXTDEBUG}
@ -917,6 +933,23 @@ implementation
ppufile.getderef(rttitablesymderef);
if df_has_inittable in defoptions then
ppufile.getderef(inittablesymderef);
if df_generic in defoptions then
begin
sizeleft:=ppufile.getlongint;
initgeneric;
while sizeleft>0 do
begin
if sizeleft>sizeof(buf) then
i:=sizeof(buf)
else
i:=sizeleft;
ppufile.getdata(buf,i);
generictokenbuf.write(buf,i);
dec(sizeleft,i);
end;
end;
if df_specialization in defoptions then
ppufile.getderef(genericdefderef);
end;
@ -939,6 +972,10 @@ implementation
procedure tstoreddef.ppuwritedef(ppufile:tcompilerppufile);
var
sizeleft,i : longint;
buf : array[0..255] of byte;
oldintfcrc : boolean;
begin
ppufile.putword(indexnr);
ppufile.putderef(typesymderef);
@ -947,6 +984,32 @@ implementation
ppufile.putderef(rttitablesymderef);
if df_has_inittable in defoptions then
ppufile.putderef(inittablesymderef);
if df_generic in defoptions then
begin
oldintfcrc:=ppufile.do_interface_crc;
ppufile.do_interface_crc:=false;
if assigned(generictokenbuf) then
begin
sizeleft:=generictokenbuf.size;
generictokenbuf.seek(0);
end
else
sizeleft:=0;
ppufile.putlongint(sizeleft);
while sizeleft>0 do
begin
if sizeleft>sizeof(buf) then
i:=sizeof(buf)
else
i:=sizeleft;
generictokenbuf.read(buf,i);
ppufile.putdata(buf,i);
dec(sizeleft,i);
end;
ppufile.do_interface_crc:=oldintfcrc;
end;
if df_specialization in defoptions then
ppufile.putderef(genericdefderef);
end;
@ -955,6 +1018,7 @@ implementation
typesymderef.build(typesym);
rttitablesymderef.build(rttitablesym);
inittablesymderef.build(inittablesym);
genericdefderef.build(genericdef);
end;
@ -970,6 +1034,8 @@ implementation
rttitablesym:=trttisym(rttitablesymderef.resolve);
if df_has_inittable in defoptions then
inittablesym:=trttisym(inittablesymderef.resolve);
if df_specialization in defoptions then
genericdef:=tstoreddef(genericdefderef.resolve);
end;
@ -1091,6 +1157,13 @@ implementation
end;
procedure tstoreddef.initgeneric;
begin
if assigned(generictokenbuf) then
internalerror(200512131);
generictokenbuf:=tdynamicarray.create(256);
end;
{****************************************************************************
Tstringdef
@ -1135,40 +1208,7 @@ implementation
savesize:=sizeof(aint);
end;
{$ifdef ansistring_bits}
constructor tstringdef.createansi(l:aint;bits:Tstringbits);
begin
inherited create;
case bits of
sb_16:
string_typ:=st_ansistring16;
sb_32:
string_typ:=st_ansistring32;
sb_64:
string_typ:=st_ansistring64;
end;
deftype:=stringdef;
len:=l;
savesize:=POINTER_SIZE;
end;
constructor tstringdef.loadansi(ppufile:tcompilerppufile;bits:Tstringbits);
begin
inherited ppuloaddef(ppufile);
deftype:=stringdef;
case bits of
sb_16:
string_typ:=st_ansistring16;
sb_32:
string_typ:=st_ansistring32;
sb_64:
string_typ:=st_ansistring64;
end;
len:=ppufile.getaint;
savesize:=POINTER_SIZE;
end;
{$else}
constructor tstringdef.createansi(l:aint);
begin
inherited create;
@ -1180,7 +1220,6 @@ implementation
constructor tstringdef.loadansi(ppufile:tcompilerppufile);
begin
inherited ppuloaddef(ppufile);
deftype:=stringdef;
@ -1188,7 +1227,7 @@ implementation
len:=ppufile.getaint;
savesize:=sizeof(aint);
end;
{$endif}
constructor tstringdef.createwide(l : aint);
begin
@ -1221,17 +1260,10 @@ implementation
function tstringdef.stringtypname:string;
{$ifdef ansistring_bits}
const
typname:array[tstringtype] of string[9]=('',
'shortstr','longstr','ansistr16','ansistr32','ansistr64','widestr'
);
{$else}
const
typname:array[tstringtype] of string[8]=('',
'shortstr','longstr','ansistr','widestr'
);
{$endif}
begin
stringtypname:=typname[string_typ];
end;
@ -1252,13 +1284,7 @@ implementation
case string_typ of
st_shortstring : ppufile.writeentry(ibshortstringdef);
st_longstring : ppufile.writeentry(iblongstringdef);
{$ifdef ansistring_bits}
st_ansistring16 : ppufile.writeentry(ibansistring16def);
st_ansistring32 : ppufile.writeentry(ibansistring32def);
st_ansistring64 : ppufile.writeentry(ibansistring64def);
{$else}
st_ansistring : ppufile.writeentry(ibansistringdef);
{$endif}
st_widestring : ppufile.writeentry(ibwidestringdef);
end;
end;
@ -1266,24 +1292,14 @@ implementation
function tstringdef.needs_inittable : boolean;
begin
{$ifdef ansistring_bits}
needs_inittable:=string_typ in [st_ansistring16,st_ansistring32,st_ansistring64,st_widestring];
{$else}
needs_inittable:=string_typ in [st_ansistring,st_widestring];
{$endif}
end;
function tstringdef.gettypename : string;
{$ifdef ansistring_bits}
const
names : array[tstringtype] of string[20] = ('',
'shortstring','longstring','ansistring16','ansistring32','ansistring64','widestring');
{$else}
const
names : array[tstringtype] of string[20] = ('',
'ShortString','LongString','AnsiString','WideString');
{$endif}
begin
gettypename:=names[string_typ];
end;
@ -1312,29 +1328,11 @@ implementation
procedure tstringdef.write_rtti_data(rt:trttitype);
begin
case string_typ of
{$ifdef ansistring_bits}
st_ansistring16:
begin
asmlist[al_rtti].concat(Tai_const.Create_8bit(tkA16String));
write_rtti_name;
end;
st_ansistring32:
begin
asmlist[al_rtti].concat(Tai_const.Create_8bit(tkA32String));
write_rtti_name;
end;
st_ansistring64:
begin
asmlist[al_rtti].concat(Tai_const.Create_8bit(tkA64String));
write_rtti_name;
end;
{$else}
st_ansistring:
begin
asmlist[al_rtti].concat(Tai_const.Create_8bit(tkAString));
write_rtti_name;
end;
{$endif}
st_widestring:
begin
asmlist[al_rtti].concat(Tai_const.Create_8bit(tkWString));
@ -5380,6 +5378,36 @@ implementation
end;
{****************************************************************************
TUNDEFINEDDEF
****************************************************************************}
constructor tundefineddef.create;
begin
inherited create;
deftype:=undefineddef;
end;
constructor tundefineddef.ppuload(ppufile:tcompilerppufile);
begin
inherited ppuloaddef(ppufile);
deftype:=undefineddef;
end;
function tundefineddef.gettypename:string;
begin
gettypename:='<undefined type>';
end;
procedure tundefineddef.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwritedef(ppufile);
ppufile.writeentry(ibundefineddef);
end;
{****************************************************************************
TERRORDEF
****************************************************************************}

14
compiler/symtable.pas
View File

@ -314,13 +314,7 @@ implementation
ibprocdef : hp:=tprocdef.ppuload(ppufile);
ibshortstringdef : hp:=tstringdef.loadshort(ppufile);
iblongstringdef : hp:=tstringdef.loadlong(ppufile);
{$ifdef ansistring_bits}
ibansistring16def : hp:=tstringdef.loadansi(ppufile,sb_16);
ibansistring32def : hp:=tstringdef.loadansi(ppufile,sb_32);
ibansistring64def : hp:=tstringdef.loadansi(ppufile,sb_64);
{$else}
ibansistringdef : hp:=tstringdef.loadansi(ppufile);
{$endif}
ibwidestringdef : hp:=tstringdef.loadwide(ppufile);
ibrecorddef : hp:=trecorddef.ppuload(ppufile);
ibobjectdef : hp:=tobjectdef.ppuload(ppufile);
@ -331,6 +325,7 @@ implementation
ibclassrefdef : hp:=tclassrefdef.ppuload(ppufile);
ibformaldef : hp:=tformaldef.ppuload(ppufile);
ibvariantdef : hp:=tvariantdef.ppuload(ppufile);
ibundefineddef : hp:=tundefineddef.ppuload(ppufile);
ibenddefs : break;
ibend : Message(unit_f_ppu_read_error);
else
@ -1672,7 +1667,12 @@ implementation
objects
parameters
}
if not(srsymtable.symtabletype in [recordsymtable,objectsymtable,parasymtable]) then
if not(srsymtable.symtabletype in [recordsymtable,objectsymtable,parasymtable]) or
(assigned(srsymtable.defowner) and
(
(df_generic in tdef(srsymtable.defowner).defoptions) or
(df_specialization in tdef(srsymtable.defowner).defoptions))
) then
begin
srsym:=tsym(srsymtable.speedsearch(s,speedvalue));
if assigned(srsym) and

8
compiler/tokens.pas
View File

@ -78,6 +78,8 @@ type
_CCHAR,
_CWSTRING,
_CWCHAR,
_LSHARPBRACKET,
_RSHARPBRACKET,
{ C like operators }
_PLUSASN,
_MINUSASN,
@ -177,6 +179,7 @@ type
_EXPORTS,
_FINALLY,
_FORWARD,
_GENERIC,
_IOCHECK,
_LIBRARY,
_MESSAGE,
@ -225,6 +228,7 @@ type
_INTERNPROC,
_OLDFPCCALL,
_OPENSTRING,
_SPECIALIZE,
_CONSTRUCTOR,
_INTERNCONST,
_REINTRODUCE,
@ -318,6 +322,8 @@ const
(str:'const char' ;special:true ;keyword:m_none;op:NOTOKEN),
(str:'const wstring' ;special:true ;keyword:m_none;op:NOTOKEN),
(str:'const wchar' ;special:true ;keyword:m_none;op:NOTOKEN),
(str:'<' ;special:true ;keyword:m_none;op:NOTOKEN),
(str:'>' ;special:true ;keyword:m_none;op:NOTOKEN),
{ C like operators }
(str:'+=' ;special:true ;keyword:m_none;op:NOTOKEN),
(str:'-=' ;special:true ;keyword:m_none;op:NOTOKEN),
@ -417,6 +423,7 @@ const
(str:'EXPORTS' ;special:false;keyword:m_all;op:NOTOKEN),
(str:'FINALLY' ;special:false;keyword:m_class;op:NOTOKEN),
(str:'FORWARD' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'GENERIC' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'IOCHECK' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'LIBRARY' ;special:false;keyword:m_all;op:NOTOKEN),
(str:'MESSAGE' ;special:false;keyword:m_none;op:NOTOKEN),
@ -465,6 +472,7 @@ const
(str:'INTERNPROC' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'OLDFPCCALL' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'OPENSTRING' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'SPECIALIZE' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'CONSTRUCTOR' ;special:false;keyword:m_all;op:NOTOKEN),
(str:'INTERNCONST' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'REINTRODUCE' ;special:false;keyword:m_none;op:NOTOKEN),

89
compiler/utils/ppudump.pp
View File

@ -748,33 +748,85 @@ end;
procedure readcommondef(const s:string);
type
tdefoption=(df_none,
df_has_inittable, { init data has been generated }
df_has_rttitable, { rtti data has been generated }
df_unique
{ init data has been generated }
df_has_inittable,
{ rtti data has been generated }
df_has_rttitable,
{ type is unique, i.e. declared with type = type <tdef>; }
df_unique,
{ type is a generic }
df_generic,
{ type is a specialization of a generic type }
df_specialization
);
tdefoptions=set of tdefoption;
tdefopt=record
mask : tdefoption;
str : string[30];
end;
const
defopts=5;
defopt : array[1..defopts] of tdefopt=(
(mask:df_has_inittable; str:'InitTable'),
(mask:df_has_rttitable; str:'RTTITable'),
(mask:df_unique; str:'Unique Type'),
(mask:df_generic; str:'Generic'),
(mask:df_specialization; str:'Specialization')
);
var
defopts : tdefoptions;
defoptions : tdefoptions;
i : longint;
first : boolean;
tokenbufsize : longint;
tokenbuf : pointer;
begin
writeln(space,'** Definition Nr. ',ppufile.getword,' **');
writeln(space,s);
write (space,' Type symbol : ');
readderef;
ppufile.getsmallset(defopts);
write (space,' DefOptions : ');
ppufile.getsmallset(defoptions);
if defoptions<>[] then
begin
first:=true;
for i:=1to defopts do
if (defopt[i].mask in defoptions) then
begin
if first then
first:=false
else
write(', ');
write(defopt[i].str);
end;
end;
writeln;
if df_unique in defopts then
if df_unique in defoptions then
writeln (space,' Unique type symbol');
if df_has_rttitable in defopts then
begin
write (space,' RTTI symbol : ');
readderef;
end;
if df_has_inittable in defopts then
begin
write (space,' Init symbol : ');
readderef;
end;
if df_has_rttitable in defoptions then
begin
write (space,' RTTI symbol : ');
readderef;
end;
if df_has_inittable in defoptions then
begin
write (space,' Init symbol : ');
readderef;
end;
if df_generic in defoptions then
begin
tokenbufsize:=ppufile.getlongint;
writeln(space,' Tokenbuffer size : ',tokenbufsize);
tokenbuf:=allocmem(tokenbufsize);
ppufile.getdata(tokenbuf^,tokenbufsize);
freemem(tokenbuf);
end;
if df_specialization in defoptions then
begin
write (space,' Orig. GenericDef : ');
readderef;
end;
end;
@ -1680,7 +1732,10 @@ begin
end;
ibformaldef :
readcommondef('Generic Definition (void-typ)');
readcommondef('Generic definition (void-typ)');
ibundefineddef :
readcommondef('Undefined definition (generic parameter)');
ibenumdef :
begin

35
tests/test/tgeneric1.pp Normal file
View File

@ -0,0 +1,35 @@
{$mode objfpc}
type
TList=generic(_T) class(TObject)
data : _T;
procedure Add(item: _T);
end;
procedure TList.Add(item: _T);
begin
data:=item;
end;
type
TMyIntList = specialize TList(integer);
TMyStringList = specialize TList(string);
var
ilist : TMyIntList;
slist : TMyStringList;
someInt : integer;
begin
someInt:=10;
ilist := TMyIntList.Create;
ilist.Add(someInt);
writeln(ilist.data);
if ilist.data<>10 then
halt(1);
slist := TMyStringList.Create;
slist.Add('Test');
writeln(slist.data);
if slist.data<>'Test' then
halt(1);
end.

29
tests/test/tgeneric2.pp Normal file
View File

@ -0,0 +1,29 @@
{ %fail }
{$mode objfpc}
type
TList=generic(_T) class(TObject)
data : _T;
procedure Add(item: _T);
end;
procedure TList.Add(item: _T);
var
i : integer;
begin
{ The next line should fail for TList(string) }
i:=item;
data:=item;
end;
type
TMyStringList = specialize TList(string);
var
slist : TMyStringList;
begin
slist := TMyStringList.Create;
slist.Add('Test');
writeln(slist.data);
end.

12
tests/test/tgeneric3.pp Normal file
View File

@ -0,0 +1,12 @@
uses ugeneric3;
type
TMyStringList = specialize TList(string);
var
slist : TMyStringList;
begin
slist := TMyStringList.Create;
slist.Add('Test');
writeln(slist.data);
end.

19
tests/test/tgeneric4.pp Normal file
View File

@ -0,0 +1,19 @@
uses ugeneric4;
procedure LocalFill;
begin
globaldata:='Program';
end;
type
TMyStringList = specialize TList(string);
var
slist : TMyStringList;
begin
slist := TMyStringList.Create;
slist.Fill;
writeln(slist.data);
if slist.data<>'Program' then
halt(1);
end.

53
tests/test/tgeneric5.pp Normal file
View File

@ -0,0 +1,53 @@
{$mode objfpc}
uses
typinfo;
type
TList=generic(_T) class(TObject)
data : _T;
procedure Add(item: _T);
end;
var
err : boolean;
procedure TList.Add(item: _T);
var
i : integer;
p : pointer;
begin
i:=item;
if item=i then;
p:=typeinfo(_T);
if p<>typeinfo(integer) then
begin
writeln('Typeinfo error');
err:=true;
end;
if sizeof(item)<>4 then
begin
writeln('Sizeof error');
err:=true;
end;
end;
type
TMyIntList = specialize TList(integer);
var
ilist : TMyIntList;
someInt : integer;
begin
someInt:=10;
ilist := TMyIntList.Create;
ilist.Add(someInt);
writeln(ilist.data);
if ilist.data<>10 then
err:=true;
if err then
begin
writeln('ERROR!');
halt(1);
end;
end.

20
tests/test/ugeneric3.pp Normal file
View File

@ -0,0 +1,20 @@
unit ugeneric3;
interface
{$mode objfpc}
type
TList=generic(_T) class(TObject)
data : _T;
procedure Add(item: _T);
end;
implementation
procedure TList.Add(item: _T);
begin
data:=item;
end;
end.

30
tests/test/ugeneric4.pp Normal file
View File

@ -0,0 +1,30 @@
unit ugeneric4;
interface
{$mode objfpc}
type
TList=generic(_T) class(TObject)
data : _T;
procedure Fill;
end;
var
globaldata : string;
implementation
procedure LocalFill;
begin
globaldata:='Unit';
end;
procedure TList.Fill;
begin
LocalFill;
data:=globaldata;
end;
end.