paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-05-17 05:02:32 +02:00
Code Issues Packages Projects Releases Wiki Activity
f16acaf9b5
fpc/compiler/new/psub.pas
florian 8e9d97e1fe * made it again compilable
1999-08-01 18:22:31 +00:00

1439 lines
48 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1998 by Florian Klaempfl, Daniel Mantione
Does the parsing of the procedures/functions
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 psub;
interface
uses cobjects,symtable;
const
pd_global = $1; { directive must be global }
pd_body = $2; { directive needs a body }
pd_implemen = $4; { directive can be used implementation section }
pd_interface = $8; { directive can be used interface section }
pd_object = $10; { directive can be used object declaration }
pd_procvar = $20; { directive can be used procvar declaration }
procedure compile_proc_body(const proc_names:Tstringcontainer;
make_global,parent_has_class:boolean);
procedure parse_proc_head(options : word);
procedure parse_proc_dec;
procedure parse_var_proc_directives(var sym : ptypesym);
procedure read_proc;
implementation
uses
globtype,systems,tokens,
strings,globals,verbose,comphook,files,
scanner,aasm,tree,types,
import,gendef,
convtree,
hcodegen,temp_gen,pass_1,pass_2,cgobj
{$ifdef GDB}
,gdb
{$endif GDB}
{$ifdef i386}
,i386base,tgeni386
{$ifndef NoOpt}
,aopt386
{$endif}
{$endif}
{$ifdef m68k}
,m68k,tgen68k,cga68k
{$endif}
{ parser specific stuff }
,pbase,pdecl,pexpr,pstatmnt
;
var
realname:string; { contains the real name of a procedure as it's typed }
procedure formal_parameter_list;
{
handle_procvar needs the same changes
}
var
sc : Pstringcontainer;
s : string;
filepos : tfileposinfo;
p : Pdef;
vs : Pvarsym;
l : longint;
hs1,hs2 : string;
varspez : Tvarspez;
begin
consume(LKLAMMER);
inc(testcurobject);
repeat
case token of
_VAR : begin
consume(_VAR);
varspez:=vs_var;
end;
_CONST : begin
consume(_CONST);
varspez:=vs_const;
end;
else
varspez:=vs_value;
end;
{ read identifiers }
sc:=idlist;
{ read type declaration, force reading for value and const paras }
if (token=COLON) or (varspez=vs_value) then
begin
consume(COLON);
{ check for an open array }
if token=_ARRAY then
begin
consume(_ARRAY);
consume(_OF);
{ define range and type of range }
p:=new(Parraydef,init(0,-1,s32bitdef));
{ array of const ? }
if (token=_CONST) and (m_objpas in aktmodeswitches) then
begin
consume(_CONST);
srsym:=nil;
if assigned(objpasunit) then
getsymonlyin(objpasunit,'TVARREC');
if not assigned(srsym) then
InternalError(1234124);
Parraydef(p)^.definition:=ptypesym(srsym)^.definition;
Parraydef(p)^.IsArrayOfConst:=true;
hs1:='array_of_const';
end
else
begin
{ define field type }
Parraydef(p)^.definition:=single_type(hs1);
hs1:='array_of_'+hs1;
end;
end
{ open string ? }
else if ((token=_STRING) or (idtoken=_SHORTSTRING)) and
(varspez=vs_var) and
(cs_openstring in aktmoduleswitches) and
not(cs_ansistrings in aktlocalswitches) then
begin
consume(token);
p:=openshortstringdef;
hs1:='openstring';
end
{ everything else }
else
p:=single_type(hs1);
end
else
begin
{$ifdef NoNiceNames}
hs1:='$$$';
{$else UseNiceNames}
hs1:='var';
{$endif UseNiceNames}
p:=new(Pformaldef,init);
end;
hs2:=aktprocsym^.definition^.mangledname;
while not sc^.empty do
begin
s:=sc^.get_with_tokeninfo(filepos);
aktprocsym^.definition^.concatdef(p,varspez);
{$ifdef NoNiceNames}
hs2:=hs2+'$'+hs1;
{$else UseNiceNames}
hs2:=hs2+tostr(length(hs1))+hs1;
{$endif UseNiceNames}
vs:=new(Pvarsym,init(s,p));
vs^.fileinfo:=filepos;
vs^.varspez:=varspez;
{ we have to add this to avoid var param to be in registers !!!}
if (varspez in [vs_var,vs_const]) and push_addr_param(p) then
vs^.var_options := vs^.var_options or vo_regable;
{ search for duplicate ids in object members/methods }
{ but only the current class, I don't know why ... }
{ at least TP and Delphi do it in that way (FK) }
if assigned(procinfo._class) and (lexlevel=normal_function_level) and
(procinfo._class^.publicsyms^.search(vs^.name)<>nil) then
{ (search_class_member(procinfo._class,vs^.name)<>nil) then }
Message1(sym_e_duplicate_id,vs^.name);
{ when it is a value para and it needs a local copy then rename
the parameter and insert a copy in the localst }
if (varspez=vs_value) and push_addr_param(p) then
begin
vs^.islocalcopy:=true;
aktprocsym^.definition^.localst^.insert(vs);
vs^.is_valid:=1;
l:=vs^.address; { save local address }
vs:=new(Pvarsym,init('val'+s,p));
vs^.fileinfo:=filepos;
vs^.varspez:=varspez;
aktprocsym^.definition^.parast^.insert(vs);
end
else
aktprocsym^.definition^.parast^.insert(vs);
end;
dispose(sc,done);
aktprocsym^.definition^.setmangledname(hs2);
if token=SEMICOLON then
consume(SEMICOLON)
else
break;
until false;
dec(testcurobject);
consume(RKLAMMER);
end;
procedure parse_proc_head(options : word);
var sp:stringid;
pd:Pprocdef;
paramoffset:longint;
sym:Psym;
hs:string;
overloaded_level:word;
realfilepos : tfileposinfo;
begin
if (options and pooperator) <> 0 then
begin
sp:=overloaded_names[optoken];
realname:=sp;
end
else
begin
sp:=pattern;
realname:=orgpattern;
realfilepos:=aktfilepos;
consume(ID);
end;
{ method ? }
if (token=POINT) and not(parse_only) then
begin
consume(POINT);
getsym(sp,true);
sym:=srsym;
{ qualifier is class name ? }
if (sym^.typ<>typesym) or
(ptypesym(sym)^.definition^.deftype<>objectdef) then
begin
Message(parser_e_class_id_expected);
aktprocsym:=nil;
consume(ID);
end
else
begin
{ used to allow private syms to be seen }
aktobjectdef:=pobjectdef(ptypesym(sym)^.definition);
sp:=pattern;
realname:=orgpattern;
consume(ID);
procinfo._class:=pobjectdef(ptypesym(sym)^.definition);
aktprocsym:=pprocsym(procinfo._class^.publicsyms^.search(sp));
aktobjectdef:=nil;
{ we solve this below }
if not(assigned(aktprocsym)) then
Message(parser_e_methode_id_expected);
end;
end
else
begin
{ check for constructor/destructor which is not allowed here }
if (not parse_only) and
((options and (poconstructor or podestructor))<>0) then
Message(parser_e_constructors_always_objects);
aktprocsym:=pprocsym(symtablestack^.search(sp));
if lexlevel=normal_function_level then
{$ifdef UseNiceNames}
hs:=procprefix+'_'+tostr(length(sp))+sp
{$else UseNiceNames}
hs:=procprefix+'_'+sp
{$endif UseNiceNames}
else
{$ifdef UseNiceNames}
hs:=lowercase(procprefix)+'_'+tostr(length(sp))+sp;
{$else UseNiceNames}
hs:=procprefix+'_$'+sp;
{$endif UseNiceNames}
if not(parse_only) then
begin
{The procedure we prepare for is in the implementation
part of the unit we compile. It is also possible that we
are compiling a program, which is also some kind of
implementaion part.
We need to find out if the procedure is global. If it is
global, it is in the global symtable.}
if not assigned(aktprocsym) then
begin
{Search the procedure in the global symtable.}
aktprocsym:=Pprocsym(search_a_symtable(sp,globalsymtable));
if assigned(aktprocsym) then
begin
{Check if it is a procedure.}
if aktprocsym^.typ<>procsym then
Message1(sym_e_duplicate_id,aktprocsym^.Name);
{The procedure has been found. So it is
a global one. Set the flags to mark this.}
procinfo.flags:=procinfo.flags or pi_is_global;
end;
end;
end;
end;
{ problem with procedures inside methods }
{$ifndef UseNiceNames}
if assigned(procinfo._class) then
if (pos('_$$_',procprefix)=0) then
hs:=procprefix+'_$$_'+procinfo._class^.name+'_'+sp
else
hs:=procprefix+'_$'+sp;
{$else UseNiceNames}
if assigned(procinfo._class) then
if (pos('_5Class_',procprefix)=0) then
hs:=procprefix+'_5Class_'+procinfo._class^.name^+'_'+tostr(length(sp))+sp
else
hs:=procprefix+'_'+tostr(length(sp))+sp;
{$endif UseNiceNames}
if assigned(aktprocsym) then
begin
{ Check if overloading is enabled }
if not(m_fpc in aktmodeswitches) then
begin
if aktprocsym^.typ<>procsym then
begin
Message1(sym_e_duplicate_id,aktprocsym^.name);
{ try to recover by creating a new aktprocsym }
aktprocsym:=new(pprocsym,init(sp));
end
else
begin
if not(aktprocsym^.definition^.forwarddef) then
Message(parser_e_procedure_overloading_is_off);
end;
end
else
begin
{ Check if the overloaded sym is realy a procsym }
if aktprocsym^.typ<>procsym then
begin
Message1(parser_e_overloaded_no_procedure,aktprocsym^.name);
{ try to recover by creating a new aktprocsym }
aktprocsym:=new(pprocsym,init(sp));
end;
end;
end
else
begin
{ create a new procsym and set the real filepos }
aktprocsym:=new(pprocsym,init(sp));
aktprocsym^.fileinfo:=realfilepos;
{ for operator we have only one definition for each overloaded
operation }
if ((options and pooperator) <> 0) then
begin
{ the only problem is that nextoverloaded might not be in a unit
known for the unit itself }
if assigned(overloaded_operators[optoken]) then
aktprocsym^.definition:=overloaded_operators[optoken]^.definition;
end;
symtablestack^.insert(aktprocsym);
end;
{ create a new procdef }
pd:=new(pprocdef,init);
if assigned(procinfo._class) then
pd^._class := procinfo._class;
{ set the options from the caller (podestructor or poconstructor) }
pd^.options:=pd^.options or options;
{ calculate the offset of the parameters }
paramoffset:=8;
{ calculate frame pointer offset }
if lexlevel>normal_function_level then
begin
procinfo.framepointer_offset:=paramoffset;
inc(paramoffset,target_os.size_of_pointer);
end;
if assigned (Procinfo._Class) and not(procinfo._class^.isclass) and
(((pd^.options and poconstructor)<>0) or ((pd^.options and podestructor)<>0)) then
inc(paramoffset,target_os.size_of_pointer);
{ self pointer offset }
{ self isn't pushed in nested procedure of methods }
if assigned(procinfo._class) and (lexlevel=normal_function_level) then
begin
procinfo.ESI_offset:=paramoffset;
inc(paramoffset,target_os.size_of_pointer);
end;
procinfo.call_offset:=paramoffset;
pd^.parast^.datasize:=0;
pd^.nextoverloaded:=aktprocsym^.definition;
aktprocsym^.definition:=pd;
aktprocsym^.definition^.setmangledname(hs);
overloaded_level:=1;
if assigned(pd^.nextoverloaded) and
(pd^.nextoverloaded^.owner^.symtabletype in [globalsymtable,staticsymtable]) then
begin
{ we need another procprefix !!! }
{ count, but only those in the same unit !!}
while assigned(pd^.nextoverloaded) and
(pd^.nextoverloaded^.owner^.symtabletype in [globalsymtable,staticsymtable]) do
begin
{ only count already implemented functions }
if not(pd^.forwarddef) then
inc(overloaded_level);
pd:=pd^.nextoverloaded;
end;
end;
if not parse_only then
procprefix:=hs+'$'+tostr(overloaded_level)+'$';
if token=LKLAMMER then
formal_parameter_list;
if ((options and pooperator)<>0) {and (overloaded_operators[optoken]=nil) } then
overloaded_operators[optoken]:=aktprocsym;
end;
procedure parse_proc_dec;
var
hs : string;
isclassmethod : boolean;
begin
inc(lexlevel);
{ read class method }
if token=_CLASS then
begin
consume(_CLASS);
isclassmethod:=true;
end
else
isclassmethod:=false;
case token of
_FUNCTION : begin
consume(_FUNCTION);
parse_proc_head(0);
if token<>COLON then
begin
if not(aktprocsym^.definition^.forwarddef) and
not(m_repeat_forward in aktmodeswitches) then
begin
consume(COLON);
consume_all_until(SEMICOLON);
end;
end
else
begin
consume(COLON);
aktprocsym^.definition^.retdef:=single_type(hs);
aktprocsym^.definition^.test_if_fpu_result;
end;
end;
_PROCEDURE : begin
consume(_PROCEDURE);
parse_proc_head(0);
aktprocsym^.definition^.retdef:=voiddef;
end;
_CONSTRUCTOR : begin
consume(_CONSTRUCTOR);
parse_proc_head(poconstructor);
if (procinfo._class^.options and oo_is_class)<>0 then
begin
{ CLASS constructors return the created instance }
aktprocsym^.definition^.retdef:=procinfo._class;
end
else
begin
{ OBJECT constructors return a boolean }
{$IfDef GDB}
{ GDB doesn't like unnamed types !}
aktprocsym^.definition^.retdef:=globaldef('boolean');
{$Else GDB}
aktprocsym^.definition^.retdef:=new(porddef,init(bool8bit,0,1));
{$Endif GDB}
end;
end;
_DESTRUCTOR : begin
consume(_DESTRUCTOR);
parse_proc_head(podestructor);
aktprocsym^.definition^.retdef:=voiddef;
end;
_OPERATOR : begin
if lexlevel>normal_function_level then
Message(parser_e_no_local_operator);
consume(_OPERATOR);
if not(token in [PLUS..last_overloaded]) then
Message(parser_e_overload_operator_failed);
optoken:=token;
consume(Token);
procinfo.flags:=procinfo.flags or pi_operator;
parse_proc_head(pooperator);
if token<>ID then
consume(ID)
else
begin
opsym:=new(pvarsym,init(pattern,voiddef));
consume(ID);
end;
if token<>COLON then
begin
consume(COLON);
aktprocsym^.definition^.retdef:=generrordef;
consume_all_until(SEMICOLON);
end
else
begin
consume(COLON);
aktprocsym^.definition^.retdef:=
single_type(hs);
aktprocsym^.definition^.test_if_fpu_result;
if (optoken in [EQUAL,GT,LT,GTE,LTE]) and
((aktprocsym^.definition^.retdef^.deftype<>
orddef) or (porddef(aktprocsym^.definition^.
retdef)^.typ<>bool8bit)) then
Message(parser_e_comparative_operator_return_boolean);
opsym^.definition:=aktprocsym^.definition^.retdef;
end;
end;
end;
if isclassmethod and
assigned(aktprocsym) then
aktprocsym^.definition^.options:=aktprocsym^.definition^.options or poclassmethod;
consume(SEMICOLON);
dec(lexlevel);
end;
{****************************************************************************
Procedure directive handlers
****************************************************************************}
{$ifdef tp}
{$F+}
{$endif}
procedure pd_far(const procnames:Tstringcontainer);
begin
Message(parser_w_proc_far_ignored);
end;
procedure pd_near(const procnames:Tstringcontainer);
begin
Message(parser_w_proc_near_ignored);
end;
procedure pd_export(const procnames:Tstringcontainer);
begin
procnames.insert(realname);
procinfo.exported:=true;
if cs_link_deffile in aktglobalswitches then
deffile.AddExport(aktprocsym^.definition^.mangledname);
if assigned(procinfo._class) then
Message(parser_e_methods_dont_be_export);
if lexlevel<>normal_function_level then
Message(parser_e_dont_nest_export);
end;
procedure pd_inline(const procnames:Tstringcontainer);
begin
if not(cs_support_inline in aktmoduleswitches) then
Message(parser_e_proc_inline_not_supported);
end;
procedure pd_forward(const procnames:Tstringcontainer);
begin
aktprocsym^.definition^.forwarddef:=true;
aktprocsym^.properties:=aktprocsym^.properties or sp_forwarddef;
end;
procedure pd_stdcall(const procnames:Tstringcontainer);
begin
end;
procedure pd_alias(const procnames:Tstringcontainer);
begin
consume(COLON);
procnames.insert(get_stringconst);
end;
procedure pd_asmname(const procnames:Tstringcontainer);
begin
aktprocsym^.definition^.setmangledname(target_os.Cprefix+pattern);
if token=CCHAR then
consume(CCHAR)
else
consume(CSTRING);
{ we don't need anything else }
aktprocsym^.definition^.forwarddef:=false;
end;
procedure pd_intern(const procnames:Tstringcontainer);
begin
consume(COLON);
aktprocsym^.definition^.extnumber:=get_intconst;
end;
procedure pd_system(const procnames:Tstringcontainer);
begin
aktprocsym^.definition^.setmangledname(realname);
end;
procedure pd_cdecl(const procnames:Tstringcontainer);
begin
if aktprocsym^.definition^.deftype<>procvardef then
aktprocsym^.definition^.setmangledname(target_os.Cprefix+realname);
end;
procedure pd_register(const procnames:Tstringcontainer);
begin
Message(parser_w_proc_register_ignored);
end;
procedure pd_syscall(const procnames:Tstringcontainer);
begin
aktprocsym^.definition^.options:=aktprocsym^.definition^.options or poclearstack;
aktprocsym^.definition^.forwarddef:=false;
aktprocsym^.definition^.extnumber:=get_intconst;
end;
procedure pd_external(const procnames:Tstringcontainer);
{
If import_dll=nil the procedure is assumed to be in another
object file. In that object file it should have the name to
which import_name is pointing to. Otherwise, the procedure is
assumed to be in the DLL to which import_dll is pointing to. In
that case either import_nr<>0 or import_name<>nil is true, so
the procedure is either imported by number or by name. (DM)
}
var
import_dll,
import_name : string;
import_nr : word;
begin
aktprocsym^.definition^.forwarddef:=false;
{ If the procedure should be imported from a DLL, a constant string follows.
This isn't really correct, an contant string expression follows
so we check if an semicolon follows, else a string constant have to
follow (FK) }
import_nr:=0;
import_name:='';
if not(token=SEMICOLON) and not(idtoken=_NAME) then
begin
import_dll:=get_stringconst;
if (idtoken=_NAME) then
begin
consume(_NAME);
import_name:=get_stringconst;
end;
if (idtoken=_INDEX) then
begin
{After the word index follows the index number in the DLL.}
consume(_INDEX);
import_nr:=get_intconst;
end;
if (import_nr=0) and (import_name='') then
Message(parser_w_empty_import_name);
if not(current_module^.uses_imports) then
begin
current_module^.uses_imports:=true;
importlib^.preparelib(current_module^.modulename^);
end;
importlib^.importprocedure(aktprocsym^.mangledname,import_dll,import_nr,import_name)
end
else
begin
if (idtoken=_NAME) then
begin
consume(_NAME);
aktprocsym^.definition^.setmangledname(get_stringconst);
end
else
begin
{ external shouldn't override the cdecl/system name }
if (aktprocsym^.definition^.options and poclearstack)=0 then
aktprocsym^.definition^.setmangledname(aktprocsym^.name);
end;
end;
end;
{$ifdef TP}
{$F-}
{$endif}
function parse_proc_direc(const name:string;const proc_names:Tstringcontainer;var pdflags:word):boolean;
{
Parse the procedure directive, returns true if a correct directive is found
}
const
namelength=15;
type
pd_handler=procedure(const procnames:Tstringcontainer);
proc_dir_rec=record
name : string[namelength]; {15 letters should be enough.}
handler : pd_handler; {Handler.}
flag : longint; {Procedure flag. May be zero}
pd_flags : longint; {Parse options}
mut_excl : longint; {List of mutually exclusive flags.}
end;
const
{Should contain the number of procedure directives we support.}
num_proc_directives=21;
{Should contain the largest power of 2 lower than
num_proc_directives, the int value of the 2-log of it. Cannot be
calculated using an constant expression, as far as I know.}
num_proc_directives_2log=16;
proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
((name:'ALIAS' ;handler:{$ifdef FPC}@{$endif}pd_alias;
flag:0 ;pd_flags:pd_implemen+pd_body;
mut_excl:poinline+poexternal),
(name:'ASMNAME' ;handler:{$ifdef FPC}@{$endif}pd_asmname;
flag:pocdecl+poclearstack+poexternal;pd_flags:pd_interface+pd_implemen;
mut_excl:pointernproc+poexternal),
(name:'ASSEMBLER' ;handler:nil;
flag:poassembler ;pd_flags:pd_implemen+pd_body;
mut_excl:pointernproc+poexternal),
(name:'CDECL' ;handler:{$ifdef FPC}@{$endif}pd_cdecl;
flag:pocdecl+poclearstack;pd_flags:pd_interface+pd_implemen+pd_body+pd_procvar;
mut_excl:poleftright+poinline+poassembler+pointernproc+poexternal),
(name:'EXPORT' ;handler:{$ifdef FPC}@{$endif}pd_export;
flag:poexports ;pd_flags:pd_body+pd_global+pd_interface+pd_implemen{??};
mut_excl:poexternal+poinline+pointernproc+pointerrupt),
(name:'EXTERNAL' ;handler:{$ifdef FPC}@{$endif}pd_external;
flag:poexternal ;pd_flags:pd_implemen;
mut_excl:poexports+poinline+pointernproc+pointerrupt+poassembler+popalmossyscall),
(name:'FAR' ;handler:{$ifdef FPC}@{$endif}pd_far;
flag:0 ;pd_flags:pd_implemen+pd_body+pd_interface+pd_procvar;
mut_excl:pointernproc),
(name:'FORWARD' ;handler:{$ifdef FPC}@{$endif}pd_forward;
flag:0 ;pd_flags:pd_implemen;
mut_excl:pointernproc+poexternal),
(name:'INLINE' ;handler:{$ifdef FPC}@{$endif}pd_inline;
flag:poinline ;pd_flags:pd_implemen+pd_body;
mut_excl:poexports+poexternal+pointernproc+pointerrupt+poconstructor+podestructor),
(name:'INTERNCONST';handler:{$ifdef FPC}@{$endif}pd_intern;
flag:pointernconst;pd_flags:pd_implemen+pd_body;
mut_excl:pointernproc+pooperator),
(name:'INTERNPROC';handler:{$ifdef FPC}@{$endif}pd_intern;
flag:pointernproc ;pd_flags:pd_implemen;
mut_excl:poexports+poexternal+pointerrupt+poassembler+poclearstack+poleftright+poiocheck+
poconstructor+podestructor+pooperator),
(name:'INTERRUPT' ;handler:nil;
flag:pointerrupt ;pd_flags:pd_implemen+pd_body;
mut_excl:pointernproc+poclearstack+poleftright+poinline+
poconstructor+podestructor+pooperator+poexternal),
(name:'IOCHECK' ;handler:nil;
flag:poiocheck ;pd_flags:pd_implemen+pd_body;
mut_excl:pointernproc+poexternal),
(name:'NEAR' ;handler:{$ifdef FPC}@{$endif}pd_near;
flag:0 ;pd_flags:pd_implemen+pd_body+pd_procvar;
mut_excl:pointernproc),
(name:'PASCAL' ;handler:nil;
flag:poleftright ;pd_flags:pd_implemen+pd_body+pd_procvar;
mut_excl:pointernproc+poexternal),
(name:'POPSTACK' ;handler:nil;
flag:poclearstack ;pd_flags:pd_interface+pd_implemen+pd_body+pd_procvar;
mut_excl:poinline+pointernproc+poassembler+poexternal),
(name:'PUBLIC' ;handler:nil;
flag:0 ;pd_flags:pd_implemen+pd_body+pd_global;
mut_excl:pointernproc+poinline+poexternal),
(name:'REGISTER' ;handler:{$ifdef FPC}@{$endif}pd_register;
flag:poregister ;pd_flags:pd_interface+pd_implemen+pd_body+pd_procvar;
mut_excl:poleftright+pocdecl+pointernproc+poexternal),
(name:'STDCALL' ;handler:{$ifdef FPC}@{$endif}pd_stdcall;
flag:postdcall ;pd_flags:pd_interface+pd_implemen+pd_body+pd_procvar;
mut_excl:poleftright+pocdecl+pointernproc+poinline+poexternal),
(name:'SYSCALL' ;handler:{$ifdef FPC}@{$endif}pd_syscall;
flag:popalmossyscall;pd_flags:pd_interface;
mut_excl:poexports+poinline+pointernproc+pointerrupt+poassembler+poexternal),
(name:'SYSTEM' ;handler:{$ifdef FPC}@{$endif}pd_system;
flag:poclearstack ;pd_flags:pd_implemen;
mut_excl:poleftright+poinline+poassembler+pointernproc+poexternal));
var
p,w : longint;
begin
parse_proc_direc:=false;
{ Search the procedure directive in the array. We shoot with a bazooka
on a bug, that is, we release a binary search }
p:=1;
if (length(name)<=namelength) then
begin
w:=num_proc_directives_2log;
while w<>0 do
begin
if proc_direcdata[p+w].name<=name then
inc(p,w);
w:=w shr 1;
while p+w>num_proc_directives do
w:=w shr 1;
end;
end;
{ Check if the procedure directive is known }
if name<>proc_direcdata[p].name then
begin
{ parsing a procvar type the name can be any
next variable !! }
if (pdflags and pd_procvar)=0 then
Message1(parser_w_unknown_proc_directive_ignored,name);
exit;
end;
{ consume directive, and turn flag on }
consume(token);
parse_proc_direc:=true;
{ Conflicts between directives ? }
if (aktprocsym^.definition^.options and proc_direcdata[p].mut_excl)<>0 then
begin
Message1(parser_e_proc_dir_conflict,name);
exit;
end;
{ Check the pd_flags if the directive should be allowed }
if ((pdflags and pd_interface)<>0) and
((proc_direcdata[p].pd_flags and pd_interface)=0) then
begin
Message1(parser_e_proc_dir_not_allowed_in_interface,name);
exit;
end;
if ((pdflags and pd_implemen)<>0) and
((proc_direcdata[p].pd_flags and pd_implemen)=0) then
begin
Message1(parser_e_proc_dir_not_allowed_in_implementation,name);
exit;
end;
if ((pdflags and pd_procvar)<>0) and
((proc_direcdata[p].pd_flags and pd_procvar)=0) then
begin
Message1(parser_e_proc_dir_not_allowed_in_procvar,name);
exit;
end;
{ Return the new pd_flags }
if (proc_direcdata[p].pd_flags and pd_body)=0 then
pdflags:=pdflags and (not pd_body);
if (proc_direcdata[p].pd_flags and pd_global)<>0 then
pdflags:=pdflags or pd_global;
{ Add the correct flag }
aktprocsym^.definition^.options:=aktprocsym^.definition^.options or proc_direcdata[p].flag;
{ Call the handler }
if pointer({$ifndef FPC}@{$endif}proc_direcdata[p].handler)<>nil then
proc_direcdata[p].handler(proc_names);
end;
{***************************************************************************}
function check_identical:boolean;
{
Search for idendical definitions,
if there is a forward, then kill this.
Returns the result of the forward check.
Removed from unter_dec to keep the source readable
}
const
{List of procedure options that affect the procedure type.}
po_type_params=poconstructor+podestructor+pooperator;
po_call_params=pocdecl+poclearstack+poleftright+poregister;
var
hd,pd : Pprocdef;
storeparast : psymtable;
ad,fd : psym;
begin
check_identical:=false;
pd:=aktprocsym^.definition;
if assigned(pd) then
begin
{ Is there an overload/forward ? }
if assigned(pd^.nextoverloaded) then
begin
{ walk the procdef list }
while (assigned(pd)) and (assigned(pd^.nextoverloaded)) do
begin
if not(m_repeat_forward in aktmodeswitches) or
equal_paras(aktprocsym^.definition^.para1,pd^.nextoverloaded^.para1,false) then
begin
if pd^.nextoverloaded^.forwarddef then
{ remove the forward definition but don't delete it, }
{ the symtable is the owner !! }
begin
hd:=pd^.nextoverloaded;
{ Check if the procedure type and return type are correct }
if ((hd^.options and po_type_params)<>(aktprocsym^.definition^.options and po_type_params)) or
(not(is_equal(hd^.retdef,aktprocsym^.definition^.retdef)) and
(m_repeat_forward in aktmodeswitches)) then
begin
Message1(parser_e_header_dont_match_forward,aktprocsym^.demangledName);
exit;
end;
{ Check calling convention }
if ((hd^.options and po_call_params)<>(aktprocsym^.definition^.options and po_call_params)) then
begin
{ only trigger a error, becuase it doesn't hurt }
Message(parser_e_call_convention_dont_match_forward);
end;
{ manglednames are equal? }
if (m_repeat_forward in aktmodeswitches) or
aktprocsym^.definition^.haspara then
if (hd^.mangledname<>aktprocsym^.definition^.mangledname) then
begin
if (aktprocsym^.definition^.options and poexternal)=0 then
Message(parser_n_interface_name_diff_implementation_name);
{ reset the mangledname of the interface part to be sure }
{ this is wrong because the mangled name might have been used already !! }
{ hd^.setmangledname(aktprocsym^.definition^.mangledname);}
{ so we need to keep the name of interface !! }
aktprocsym^.definition^.setmangledname(hd^.mangledname);
end
else
begin
{ If mangled names are equal, therefore }
{ they have the same number of parameters }
{ Therefore we can check the name of these }
{ parameters... }
if hd^.forwarddef and aktprocsym^.definition^.forwarddef then
begin
Message1(parser_e_function_already_declared_public_forward,aktprocsym^.demangledName);
Check_identical:=true;
{ Remove other forward from the list to reduce errors }
pd^.nextoverloaded:=pd^.nextoverloaded^.nextoverloaded;
exit;
end;
end;
{ also the call_offset }
hd^.parast^.address_fixup:=aktprocsym^.definition^.parast^.address_fixup;
{ remove pd^.nextoverloaded from the list }
{ and add aktprocsym^.definition }
pd^.nextoverloaded:=pd^.nextoverloaded^.nextoverloaded;
hd^.nextoverloaded:=aktprocsym^.definition^.nextoverloaded;
{ Alert! All fields of aktprocsym^.definition that are modified
by the procdir handlers must be copied here!.}
hd^.forwarddef:=false;
hd^.options:=hd^.options or aktprocsym^.definition^.options;
if aktprocsym^.definition^.extnumber=-1 then
aktprocsym^.definition^.extnumber:=hd^.extnumber
else
if hd^.extnumber=-1 then
hd^.extnumber:=aktprocsym^.definition^.extnumber;
{ switch parast for warning in implementation PM }
if (m_repeat_forward in aktmodeswitches) or
aktprocsym^.definition^.haspara then
begin
storeparast:=hd^.parast;
hd^.parast:=aktprocsym^.definition^.parast;
aktprocsym^.definition^.parast:=storeparast;
end;
aktprocsym^.definition:=hd;
check_identical:=true;
end
else
{ abstract methods aren't forward defined, but this }
{ needs another error message }
if (pd^.nextoverloaded^.options and poabstractmethod)=0 then
Message(parser_e_overloaded_have_same_parameters)
else
Message(parser_e_abstract_no_definition);
break;
end;
pd:=pd^.nextoverloaded;
end;
end
else
begin
{ there is no overloaded, so its always identical with itself }
check_identical:=true;
end;
end;
{ insert opsym only in the right symtable }
if ((procinfo.flags and pi_operator)<>0) and not parse_only then
begin
if ret_in_param(aktprocsym^.definition^.retdef) then
begin
pprocdef(aktprocsym^.definition)^.parast^.insert(opsym);
{ this increases the data size }
{ correct this to get the right ret $value }
dec(pprocdef(aktprocsym^.definition)^.parast^.datasize,opsym^.getsize);
{ this allows to read the funcretoffset }
opsym^.address:=-4;
opsym^.varspez:=vs_var;
end
else
pprocdef(aktprocsym^.definition)^.localst^.insert(opsym);
end;
end;
procedure compile_proc_body(const proc_names : tstringcontainer;
make_global,parent_has_class : boolean);
{
Compile the body of a procedure
}
var
oldexitlabel,oldexit2label,oldquickexitlabel:Pasmlabel;
_class,hp:Pobjectdef;
{ switches can change inside the procedure }
entryswitches, exitswitches : tlocalswitches;
{ code for the subroutine as tree }
code : pnode;
{ size of the local strackframe }
stackframe : longint;
{ true when no stackframe is required }
nostackframe : boolean;
{ number of bytes which have to be cleared by RET }
parasize : longint;
{ filepositions }
entrypos,
savepos,
exitpos : tfileposinfo;
begin
{ calculate the lexical level }
inc(lexlevel);
if lexlevel>32 then
Message(parser_e_too_much_lexlevel);
{ save old labels }
oldexitlabel:=aktexitlabel;
oldexit2label:=aktexit2label;
oldquickexitlabel:=quickexitlabel;
{ get new labels }
getlabel(aktexitlabel);
getlabel(aktexit2label);
{ exit for fail in constructors }
if (aktprocsym^.definition^.options and poconstructor)<>0 then
getlabel(quickexitlabel);
{ reset break and continue labels }
in_except_block:=false;
aktbreaklabel:=nil;
aktcontinuelabel:=nil;
{ insert symtables for the class, by only if it is no nested function }
if assigned(procinfo._class) and not(parent_has_class) then
begin
{ insert them in the reverse order ! }
hp:=nil;
repeat
_class:=procinfo._class;
while _class^.childof<>hp do
_class:=_class^.childof;
hp:=_class;
_class^.publicsyms^.next:=symtablestack;
symtablestack:=_class^.publicsyms;
until hp=procinfo._class;
end;
{ insert parasymtable in symtablestack}
{ only if lexlevel > 1 !!! global symtable should be right after staticsymtazble
for checking of same names used in interface and implementation !! }
if lexlevel>=normal_function_level then
begin
aktprocsym^.definition^.parast^.next:=symtablestack;
symtablestack:=aktprocsym^.definition^.parast;
symtablestack^.symtablelevel:=lexlevel;
end;
{ insert localsymtable in symtablestack}
aktprocsym^.definition^.localst^.next:=symtablestack;
symtablestack:=aktprocsym^.definition^.localst;
symtablestack^.symtablelevel:=lexlevel;
{ constant symbols are inserted in this symboltable }
constsymtable:=symtablestack;
{ reset the temporary memory }
cleartempgen;
{ no registers are used }
usedinproc:=0;
{ save entry info }
entrypos:=aktfilepos;
entryswitches:=aktlocalswitches;
{ parse the code ... }
if (aktprocsym^.definition^.options and poassembler)<> 0 then
code:=convtree2node(assembler_block)
else
code:=convtree2node(block(current_module^.islibrary));
{ get a better entry point }
if assigned(code) then
entrypos:=code^.fileinfo;
{ save exit info }
exitswitches:=aktlocalswitches;
exitpos:=last_endtoken_filepos;
{ save current filepos }
savepos:=aktfilepos;
{When we are called to compile the body of a unit, aktprocsym should
point to the unit initialization. If the unit has no initialization,
aktprocsym=nil. But in that case code=nil. hus we should check for
code=nil, when we use aktprocsym.}
{ set the framepointer to esp for assembler functions }
{ but only if the are no local variables }
{ already done in assembler_block }
setfirsttemp(procinfo.firsttemp);
{ ... and generate assembler }
{ but set the right switches for entry !! }
aktlocalswitches:=entryswitches;
if assigned(code) then
generatecode(code);
{ set switches to status at end of procedure }
aktlocalswitches:=exitswitches;
if assigned(code) then
begin
aktprocsym^.definition^.code:=code;
{ the procedure is now defined }
aktprocsym^.definition^.forwarddef:=false;
aktprocsym^.definition^.usedregisters:=usedinproc;
end;
stackframe:=gettempsize;
{ only now we can remove the temps }
resettempgen;
{ first generate entry code with the correct position and switches }
aktfilepos:=entrypos;
aktlocalswitches:=entryswitches;
if assigned(code) then
cg^.g_entrycode(procinfo.aktentrycode,proc_names,make_global,stackframe,parasize,nostackframe,false);
{ now generate exit code with the correct position and switches }
aktfilepos:=exitpos;
aktlocalswitches:=exitswitches;
if assigned(code) then
begin
cg^.g_exitcode(procinfo.aktexitcode,parasize,nostackframe,false);
procinfo.aktproccode^.insertlist(procinfo.aktentrycode);
procinfo.aktproccode^.concatlist(procinfo.aktexitcode);
{$ifdef i386}
{$ifndef NoOpt}
if (cs_optimize in aktglobalswitches) and
{ no asm block allowed }
((procinfo.flags and pi_uses_asm)=0) then
Optimize(procinfo.aktproccode);
{$endif NoOpt}
{$endif}
{ save local data (casetable) also in the same file }
if assigned(procinfo.aktlocaldata) and
(not procinfo.aktlocaldata^.empty) then
begin
procinfo.aktproccode^.concat(new(pai_section,init(sec_data)));
procinfo.aktproccode^.concatlist(procinfo.aktlocaldata);
end;
{ now we can insert a cut }
if (cs_smartlink in aktmoduleswitches) then
codesegment^.concat(new(pai_cut,init));
{ add the procedure to the codesegment }
codesegment^.concatlist(procinfo.aktproccode);
end;
{ ... remove symbol tables, for the browser leave the static table }
{ if (cs_browser in aktmoduleswitches) and (symtablestack^.symtabletype=staticsymtable) then
symtablestack^.next:=symtablestack^.next^.next
else }
if lexlevel>=normal_function_level then
symtablestack:=symtablestack^.next^.next
else
symtablestack:=symtablestack^.next;
{ ... check for unused symbols }
{ but only if there is no asm block }
if assigned(code) then
begin
if (status.errorcount=0) then
begin
aktprocsym^.definition^.localst^.check_forwards;
aktprocsym^.definition^.localst^.checklabels;
end;
if (procinfo.flags and pi_uses_asm)=0 then
begin
{ not for unit init, becuase the var can be used in finalize,
it will be done in proc_unit }
if (aktprocsym^.definition^.options and (pounitinit or pounitfinalize))=0 then
aktprocsym^.definition^.localst^.allsymbolsused;
aktprocsym^.definition^.parast^.allsymbolsused;
end;
end;
{ the local symtables can be deleted, but the parast }
{ doesn't, (checking definitons when calling a }
{ function }
{ not for a inline procedure !! (PM) }
{ at lexlevel = 1 localst is the staticsymtable itself }
{ so no dispose here !! }
if assigned(code) and
not(cs_browser in aktmoduleswitches) and
((aktprocsym^.definition^.options and poinline)=0) then
begin
if lexlevel>=normal_function_level then
dispose(aktprocsym^.definition^.localst,done);
aktprocsym^.definition^.localst:=nil;
end;
{ remove code tree, if not inline procedure }
if assigned(code) and ((aktprocsym^.definition^.options and poinline)=0) then
dispose(code,done);
{ remove class member symbol tables }
while symtablestack^.symtabletype=objectsymtable do
symtablestack:=symtablestack^.next;
{ restore filepos, the switches are already set }
aktfilepos:=savepos;
{ free labels }
freelabel(aktexitlabel);
freelabel(aktexit2label);
if (aktprocsym^.definition^.options and poconstructor)<>0 then
freelabel(quickexitlabel);
{ restore labels }
aktexitlabel:=oldexitlabel;
aktexit2label:=oldexit2label;
quickexitlabel:=oldquickexitlabel;
{ previous lexlevel }
dec(lexlevel);
end;
procedure parse_proc_directives(Anames:Pstringcontainer;var pdflags:word);
{
Parse the procedure directives. It does not matter if procedure directives
are written using ;procdir; or ['procdir'] syntax.
}
var
name : string;
res : boolean;
begin
while token in [ID,LECKKLAMMER] do
begin
if token=LECKKLAMMER then
begin
consume(LECKKLAMMER);
repeat
name:=pattern;
{ consume(ID);
now done in the function }
parse_proc_direc(name,Anames^,pdflags);
if token=COMMA then
consume(COMMA)
else
break;
until false;
consume(RECKKLAMMER);
{ we always expect at least '[];' }
res:=true;
end
else
begin
name:=pattern;
res:=parse_proc_direc(name,Anames^,pdflags);
end;
{ A procedure directive is always followed by a semicolon }
if res then
consume(SEMICOLON)
else
break;
end;
end;
procedure parse_var_proc_directives(var sym : ptypesym);
var
anames : pstringcontainer;
pdflags : word;
oldsym : pprocsym;
begin
oldsym:=aktprocsym;
anames:=new(pstringcontainer,init);
pdflags:=pd_procvar;
{ we create a temporary aktprocsym to read the directives }
aktprocsym:=new(pprocsym,init(sym^.name));
aktprocsym^.definition:=pprocdef(sym^.definition);
{ anmes should never be used anyway }
inc(lexlevel);
parse_proc_directives(anames,pdflags);
dec(lexlevel);
aktprocsym^.definition:=nil;
dispose(aktprocsym,done);
dispose(anames,done);
aktprocsym:=oldsym;
end;
procedure read_proc;
{
Parses the procedure directives, then parses the procedure body, then
generates the code for it
}
var
oldprefix : string;
oldprocsym : Pprocsym;
oldprocinfo : tprocinfo;
oldconstsymtable : Psymtable;
names : Pstringcontainer;
pdflags : word;
begin
{ save old state }
oldprocsym:=aktprocsym;
oldprefix:=procprefix;
oldconstsymtable:=constsymtable;
oldprocinfo:=procinfo;
{ create a new procedure }
new(names,init);
codegen_newprocedure;
with procinfo do
begin
parent:=@oldprocinfo;
{ clear flags }
flags:=0;
{ standard frame pointer }
framepointer:=frame_pointer;
funcret_is_valid:=false;
{ is this a nested function of a method ? }
_class:=oldprocinfo._class;
end;
parse_proc_dec;
{ set the default function options }
if parse_only then
begin
aktprocsym^.properties:=aktprocsym^.properties or sp_forwarddef;
aktprocsym^.definition^.forwarddef:=true;
pdflags:=pd_interface;
end
else
begin
pdflags:=pd_body;
if current_module^.in_implementation then
pdflags:=pdflags or pd_implemen;
if (not current_module^.is_unit) or (cs_smartlink in aktmoduleswitches) then
pdflags:=pdflags or pd_global;
procinfo.exported:=false;
aktprocsym^.definition^.forwarddef:=false;
end;
{ parse the directives that may follow }
inc(lexlevel);
parse_proc_directives(names,pdflags);
dec(lexlevel);
{ search for forward declarations }
if (not check_identical) then
begin
{ A method must be forward defined (in the object declaration) }
if assigned(procinfo._class) and (not assigned(oldprocinfo._class)) then
Message(parser_e_header_dont_match_any_member);
{ check the global flag }
if (procinfo.flags and pi_is_global)<>0 then
Message(parser_e_overloaded_must_be_all_global);
end;
{ set return type here, becuase the aktprocsym^.definition can be
changed by check_identical (PFV) }
procinfo.retdef:=aktprocsym^.definition^.retdef;
{ pointer to the return value ? }
if ret_in_param(procinfo.retdef) then
begin
procinfo.retoffset:=procinfo.call_offset;
inc(procinfo.call_offset,target_os.size_of_pointer);
end;
{ allows to access the parameters of main functions in nested functions }
aktprocsym^.definition^.parast^.address_fixup:=procinfo.call_offset;
{ compile procedure when a body is needed }
if (pdflags and pd_body)<>0 then
begin
Message1(parser_p_procedure_start,aktprocsym^.demangledname);
names^.insert(aktprocsym^.definition^.mangledname);
{ set _FAIL as keyword if constructor }
if (aktprocsym^.definition^.options and poconstructor)<>0 then
tokeninfo[_FAIL].keyword:=m_all;
if assigned(aktprocsym^.definition^._class) then
tokeninfo[_SELF].keyword:=m_all;
compile_proc_body(names^,((pdflags and pd_global)<>0),assigned(oldprocinfo._class));
{ reset _FAIL as normal }
if (aktprocsym^.definition^.options and poconstructor)<>0 then
tokeninfo[_FAIL].keyword:=m_none;
if assigned(aktprocsym^.definition^._class) and (lexlevel=main_program_level) then
tokeninfo[_SELF].keyword:=m_none;
consume(SEMICOLON);
end;
{ close }
dispose(names,done);
codegen_doneprocedure;
{ Restore old state }
constsymtable:=oldconstsymtable;
aktprocsym:=oldprocsym;
procprefix:=oldprefix;
procinfo:=oldprocinfo;
opsym:=nil;
end;
end.
{
$Log$
Revision 1.3 1999-08-01 18:22:38 florian
* made it again compilable
Revision 1.2 1999/01/13 22:52:39 florian
+ YES, finally the new code generator is compilable, but it doesn't run yet :(
Revision 1.1 1998/12/26 15:20:31 florian
+ more changes for the new version
}
Reference in New Issue View Git Blame Copy Permalink