|
|
@@ -1,1441 +0,0 @@
|
|
|
-{
|
|
|
- $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,tgobj,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.4 1999-08-02 17:14:11 florian
|
|
|
- + changed the temp. generator to an object
|
|
|
-
|
|
|
- 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
|
|
|
-
|
|
|
-}
|
florian