mirror of
				https://gitlab.com/freepascal.org/fpc/source.git
				synced 2025-10-31 23:30:39 +01:00 
			
		
		
		
	
		
			
				
	
	
		
			787 lines
		
	
	
		
			28 KiB
		
	
	
	
		
			ObjectPascal
		
	
	
	
	
	
			
		
		
	
	
			787 lines
		
	
	
		
			28 KiB
		
	
	
	
		
			ObjectPascal
		
	
	
	
	
	
| {
 | |
|     $Id$
 | |
|     Copyright (c) 1998-2002 by Florian Klaempfl
 | |
| 
 | |
|     Does parsing types for Free Pascal
 | |
| 
 | |
|     This program is free software; you can redistribute it and/or modify
 | |
|     it under the terms of the GNU General Public License as published by
 | |
|     the Free Software Foundation; either version 2 of the License, or
 | |
|     (at your option) any later version.
 | |
| 
 | |
|     This program is distributed in the hope that it will be useful,
 | |
|     but WITHOUT ANY WARRANTY; without even the implied warranty of
 | |
|     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 | |
|     GNU General Public License for more details.
 | |
| 
 | |
|     You should have received a copy of the GNU General Public License
 | |
|     along with this program; if not, write to the Free Software
 | |
|     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 | |
| 
 | |
|  ****************************************************************************
 | |
| }
 | |
| unit ptype;
 | |
| 
 | |
| {$i fpcdefs.inc}
 | |
| 
 | |
| interface
 | |
| 
 | |
|     uses
 | |
|        globtype,symtype;
 | |
| 
 | |
|     const
 | |
|        { forward types should only be possible inside a TYPE statement }
 | |
|        typecanbeforward : boolean = false;
 | |
| 
 | |
|     var
 | |
|        { hack, which allows to use the current parsed }
 | |
|        { object type as function argument type  }
 | |
|        testcurobject : byte;
 | |
|        curobjectname : stringid;
 | |
| 
 | |
|     { reads a string, file type or a type id and returns a name and }
 | |
|     { tdef }
 | |
|     procedure single_type(var tt:ttype;var s : string;isforwarddef:boolean);
 | |
| 
 | |
|     procedure read_type(var tt:ttype;const name : stringid;parseprocvardir:boolean);
 | |
| 
 | |
|     { reads a type definition }
 | |
|     { to a appropriating tdef, s gets the name of   }
 | |
|     { the type to allow name mangling          }
 | |
|     procedure id_type(var tt : ttype;var s : string;isforwarddef:boolean);
 | |
| 
 | |
| 
 | |
| implementation
 | |
| 
 | |
|     uses
 | |
|        { common }
 | |
|        cutils,
 | |
|        { global }
 | |
|        globals,tokens,verbose,
 | |
|        systems,
 | |
|        { target }
 | |
|        paramgr,
 | |
|        { symtable }
 | |
|        symconst,symbase,symdef,symsym,symtable,
 | |
|        defutil,defcmp,
 | |
|        { pass 1 }
 | |
|        node,
 | |
|        nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
 | |
|        { parser }
 | |
|        scanner,
 | |
|        pbase,pexpr,pdecsub,pdecvar,pdecobj;
 | |
| 
 | |
| 
 | |
|     procedure id_type(var tt : ttype;var s : string;isforwarddef:boolean);
 | |
|     { reads a type definition }
 | |
|     { to a appropriating tdef, s gets the name of   }
 | |
|     { the type to allow name mangling          }
 | |
|       var
 | |
|         is_unit_specific : boolean;
 | |
|         pos : tfileposinfo;
 | |
|         srsym : tsym;
 | |
|         srsymtable : tsymtable;
 | |
|         sorg : stringid;
 | |
|       begin
 | |
|          s:=pattern;
 | |
|          sorg:=orgpattern;
 | |
|          pos:=akttokenpos;
 | |
|          { classes can be used also in classes }
 | |
|          if (curobjectname=pattern) and is_class_or_interface(aktobjectdef) then
 | |
|            begin
 | |
|               tt.setdef(aktobjectdef);
 | |
|               consume(_ID);
 | |
|               exit;
 | |
|            end;
 | |
|          { objects can be parameters }
 | |
|          if (testcurobject=2) and (curobjectname=pattern) then
 | |
|            begin
 | |
|               tt.setdef(aktobjectdef);
 | |
|               consume(_ID);
 | |
|               exit;
 | |
|            end;
 | |
|          { try to load the symbol to see if it's a unitsym. Use the
 | |
|            special searchsym_type that ignores records,objects and
 | |
|            parameters }
 | |
|          is_unit_specific:=false;
 | |
|          searchsym_type(s,srsym,srsymtable);
 | |
|          consume(_ID);
 | |
|          if assigned(srsym) and
 | |
|             (srsym.typ=unitsym) then
 | |
|            begin
 | |
|               is_unit_specific:=true;
 | |
|               consume(_POINT);
 | |
|               if srsym.owner.unitid=0 then
 | |
|                begin
 | |
|                  srsym:=searchsymonlyin(tunitsym(srsym).unitsymtable,pattern);
 | |
|                  pos:=akttokenpos;
 | |
|                  s:=pattern;
 | |
|                end
 | |
|               else
 | |
|                srsym:=nil;
 | |
|               consume(_ID);
 | |
|            end;
 | |
|          { Types are first defined with an error def before assigning
 | |
|            the real type so check if it's an errordef. if so then
 | |
|            give an error. Only check for typesyms in the current symbol
 | |
|            table as forwarddef are not resolved directly }
 | |
|          if assigned(srsym) and
 | |
|             (srsym.typ=typesym) and
 | |
|             (srsym.owner=symtablestack) and
 | |
|             (ttypesym(srsym).restype.def.deftype=errordef) then
 | |
|           begin
 | |
|             Message1(type_e_type_is_not_completly_defined,ttypesym(srsym).realname);
 | |
|             tt:=generrortype;
 | |
|             exit;
 | |
|           end;
 | |
|          { are we parsing a possible forward def ? }
 | |
|          if isforwarddef and
 | |
|             not(is_unit_specific) then
 | |
|           begin
 | |
|             tt.setdef(tforwarddef.create(s,pos));
 | |
|             exit;
 | |
|           end;
 | |
|          { unknown sym ? }
 | |
|          if not assigned(srsym) then
 | |
|           begin
 | |
|             Message1(sym_e_id_not_found,sorg);
 | |
|             tt:=generrortype;
 | |
|             exit;
 | |
|           end;
 | |
|          { type sym ? }
 | |
|          if (srsym.typ<>typesym) then
 | |
|           begin
 | |
|             Message(type_e_type_id_expected);
 | |
|             tt:=generrortype;
 | |
|             exit;
 | |
|           end;
 | |
|          { Give an error when referring to an errordef }
 | |
|          if (ttypesym(srsym).restype.def.deftype=errordef) then
 | |
|           begin
 | |
|             Message(sym_e_error_in_type_def);
 | |
|             tt:=generrortype;
 | |
|             exit;
 | |
|           end;
 | |
|          { Use the definitions for current unit, because
 | |
|            they can be refered from the parameters and symbols are not
 | |
|            loaded at that time. Only write the definition when the
 | |
|            symbol is the real owner of the definition (not a redefine) }
 | |
|          if (ttypesym(srsym).owner.unitid=0) and
 | |
|             ((ttypesym(srsym).restype.def.typesym=nil) or
 | |
|              (srsym=ttypesym(srsym).restype.def.typesym)) then
 | |
|           tt.setdef(ttypesym(srsym).restype.def)
 | |
|          else
 | |
|           tt.setsym(srsym);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure single_type(var tt:ttype;var s : string;isforwarddef:boolean);
 | |
|     { reads a string, file type or a type id and returns a name and }
 | |
|     { tdef                                                        }
 | |
|        var
 | |
|           hs : string;
 | |
|           t2 : ttype;
 | |
|        begin
 | |
|           case token of
 | |
|             _STRING:
 | |
|                 begin
 | |
|                    string_dec(tt);
 | |
|                    s:='STRING';
 | |
|                 end;
 | |
|             _FILE:
 | |
|                 begin
 | |
|                    consume(_FILE);
 | |
|                    if token=_OF then
 | |
|                      begin
 | |
|                         consume(_OF);
 | |
|                         single_type(t2,hs,false);
 | |
|                         tt.setdef(tfiledef.createtyped(t2));
 | |
|                         s:='FILE$OF$'+hs;
 | |
|                      end
 | |
|                    else
 | |
|                      begin
 | |
|                         tt:=cfiletype;
 | |
|                         s:='FILE';
 | |
|                      end;
 | |
|                 end;
 | |
|             _ID:
 | |
|               begin
 | |
|                 id_type(tt,s,isforwarddef);
 | |
|               end;
 | |
|             else
 | |
|               begin
 | |
|                 message(type_e_type_id_expected);
 | |
|                 s:='<unknown>';
 | |
|                 tt:=generrortype;
 | |
|               end;
 | |
|          end;
 | |
|       end;
 | |
| 
 | |
|     { reads a record declaration }
 | |
|     function record_dec : tdef;
 | |
| 
 | |
|       var
 | |
|          symtable : tsymtable;
 | |
|          storetypecanbeforward : boolean;
 | |
|          old_object_option : tsymoptions;
 | |
|       begin
 | |
|          { create recdef }
 | |
|          symtable:=trecordsymtable.create;
 | |
|          record_dec:=trecorddef.create(symtable);
 | |
|          { update symtable stack }
 | |
|          symtable.next:=symtablestack;
 | |
|          symtablestack:=symtable;
 | |
|          { parse record }
 | |
|          consume(_RECORD);
 | |
|          old_object_option:=current_object_option;
 | |
|          current_object_option:=[sp_public];
 | |
|          storetypecanbeforward:=typecanbeforward;
 | |
|          { for tp7 don't allow forward types }
 | |
|          if m_tp7 in aktmodeswitches then
 | |
|            typecanbeforward:=false;
 | |
|          read_var_decs(true,false,false);
 | |
|          consume(_END);
 | |
|          typecanbeforward:=storetypecanbeforward;
 | |
|          current_object_option:=old_object_option;
 | |
|          { may be scale record size to a size of n*4 ? }
 | |
|          trecordsymtable(symtablestack).datasize:=align(trecordsymtable(symtablestack).datasize,trecordsymtable(symtablestack).dataalignment);
 | |
|          { restore symtable stack }
 | |
|          symtablestack:=symtable.next;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     { reads a type definition and returns a pointer to it }
 | |
|     procedure read_type(var tt : ttype;const name : stringid;parseprocvardir:boolean);
 | |
|       var
 | |
|         pt : tnode;
 | |
|         tt2 : ttype;
 | |
|         aktenumdef : tenumdef;
 | |
|         ap : tarraydef;
 | |
|         s : stringid;
 | |
|         l,v : TConstExprInt;
 | |
|         oldaktpackrecords : longint;
 | |
|         hs : string;
 | |
|         defpos,storepos : tfileposinfo;
 | |
| 
 | |
|         procedure expr_type;
 | |
|         var
 | |
|            pt1,pt2 : tnode;
 | |
|            lv,hv   : TConstExprInt;
 | |
|         begin
 | |
|            { use of current parsed object ? }
 | |
|            if (token=_ID) and (testcurobject=2) and (curobjectname=pattern) then
 | |
|              begin
 | |
|                 consume(_ID);
 | |
|                 tt.setdef(aktobjectdef);
 | |
|                 exit;
 | |
|              end;
 | |
|            { classes can be used also in classes }
 | |
|            if (curobjectname=pattern) and is_class_or_interface(aktobjectdef) then
 | |
|              begin
 | |
|                 tt.setdef(aktobjectdef);
 | |
|                 consume(_ID);
 | |
|                 exit;
 | |
|              end;
 | |
|            { we can't accept a equal in type }
 | |
|            pt1:=comp_expr(not(ignore_equal));
 | |
|            if (token=_POINTPOINT) then
 | |
|              begin
 | |
|                consume(_POINTPOINT);
 | |
|                { get high value of range }
 | |
|                pt2:=comp_expr(not(ignore_equal));
 | |
|                { make both the same type }
 | |
|                inserttypeconv(pt1,pt2.resulttype);
 | |
|                { both must be evaluated to constants now }
 | |
|                if (pt1.nodetype=ordconstn) and
 | |
|                   (pt2.nodetype=ordconstn) then
 | |
|                  begin
 | |
|                    lv:=tordconstnode(pt1).value;
 | |
|                    hv:=tordconstnode(pt2).value;
 | |
|                    { Check bounds }
 | |
|                    if hv<lv then
 | |
|                      Message(cg_e_upper_lower_than_lower)
 | |
|                    else
 | |
|                      begin
 | |
|                        { All checks passed, create the new def }
 | |
|                        case pt1.resulttype.def.deftype of
 | |
|                          enumdef :
 | |
|                            tt.setdef(tenumdef.create_subrange(tenumdef(pt1.resulttype.def),lv,hv));
 | |
|                          orddef :
 | |
|                            begin
 | |
|                              if is_char(pt1.resulttype.def) then
 | |
|                                tt.setdef(torddef.create(uchar,lv,hv))
 | |
|                              else
 | |
|                                if is_boolean(pt1.resulttype.def) then
 | |
|                                  tt.setdef(torddef.create(bool8bit,l,hv))
 | |
|                                else
 | |
|                                  tt.setdef(torddef.create(range_to_basetype(lv,hv),lv,hv));
 | |
|                            end;
 | |
|                        end;
 | |
|                      end;
 | |
|                  end
 | |
|                else
 | |
|                  Message(sym_e_error_in_type_def);
 | |
|                pt2.free;
 | |
|              end
 | |
|            else
 | |
|              begin
 | |
|                { a simple type renaming }
 | |
|                if (pt1.nodetype=typen) then
 | |
|                  tt:=ttypenode(pt1).resulttype
 | |
|                else
 | |
|                  Message(sym_e_error_in_type_def);
 | |
|              end;
 | |
|            pt1.free;
 | |
|         end;
 | |
| 
 | |
|         procedure array_dec;
 | |
|         var
 | |
|           lowval,
 | |
|           highval   : longint;
 | |
|           arraytype : ttype;
 | |
|           ht        : ttype;
 | |
| 
 | |
|           procedure setdefdecl(const t:ttype);
 | |
|           begin
 | |
|             case t.def.deftype of
 | |
|               enumdef :
 | |
|                 begin
 | |
|                   lowval:=tenumdef(t.def).min;
 | |
|                   highval:=tenumdef(t.def).max;
 | |
|                   if tenumdef(t.def).has_jumps then
 | |
|                    Message(type_e_array_index_enums_with_assign_not_possible);
 | |
|                   arraytype:=t;
 | |
|                 end;
 | |
|               orddef :
 | |
|                 begin
 | |
|                   if torddef(t.def).typ in [uchar,
 | |
|                     u8bit,u16bit,
 | |
|                     s8bit,s16bit,s32bit,
 | |
|                     bool8bit,bool16bit,bool32bit,
 | |
|                     uwidechar] then
 | |
|                     begin
 | |
|                        lowval:=torddef(t.def).low;
 | |
|                        highval:=torddef(t.def).high;
 | |
|                        arraytype:=t;
 | |
|                     end
 | |
|                   else
 | |
|                     Message1(parser_e_type_cant_be_used_in_array_index,t.def.gettypename);
 | |
|                 end;
 | |
|               else
 | |
|                 Message(sym_e_error_in_type_def);
 | |
|             end;
 | |
|           end;
 | |
| 
 | |
|         begin
 | |
|            consume(_ARRAY);
 | |
|            { open array? }
 | |
|            if token=_LECKKLAMMER then
 | |
|              begin
 | |
|                 consume(_LECKKLAMMER);
 | |
|                 { defaults }
 | |
|                 arraytype:=generrortype;
 | |
|                 lowval:=longint($80000000);
 | |
|                 highval:=$7fffffff;
 | |
|                 tt.reset;
 | |
|                 repeat
 | |
|                   { read the expression and check it, check apart if the
 | |
|                     declaration is an enum declaration because that needs to
 | |
|                     be parsed by readtype (PFV) }
 | |
|                   if token=_LKLAMMER then
 | |
|                    begin
 | |
|                      read_type(ht,'',true);
 | |
|                      setdefdecl(ht);
 | |
|                    end
 | |
|                   else
 | |
|                    begin
 | |
|                      pt:=expr;
 | |
|                      if pt.nodetype=typen then
 | |
|                       setdefdecl(pt.resulttype)
 | |
|                      else
 | |
|                        begin
 | |
|                           if (pt.nodetype=rangen) then
 | |
|                            begin
 | |
|                              if (trangenode(pt).left.nodetype=ordconstn) and
 | |
|                                 (trangenode(pt).right.nodetype=ordconstn) then
 | |
|                               begin
 | |
|                                 lowval:=tordconstnode(trangenode(pt).left).value;
 | |
|                                 highval:=tordconstnode(trangenode(pt).right).value;
 | |
|                                 if highval<lowval then
 | |
|                                  begin
 | |
|                                    Message(parser_e_array_lower_less_than_upper_bound);
 | |
|                                    highval:=lowval;
 | |
|                                  end;
 | |
|                                 arraytype:=trangenode(pt).right.resulttype;
 | |
|                               end
 | |
|                              else
 | |
|                               Message(type_e_cant_eval_constant_expr);
 | |
|                            end
 | |
|                           else
 | |
|                            Message(sym_e_error_in_type_def)
 | |
|                        end;
 | |
|                      pt.free;
 | |
|                    end;
 | |
| 
 | |
|                 { create arraydef }
 | |
|                   if not assigned(tt.def) then
 | |
|                    begin
 | |
|                      ap:=tarraydef.create(lowval,highval,arraytype);
 | |
|                      tt.setdef(ap);
 | |
|                    end
 | |
|                   else
 | |
|                    begin
 | |
|                      ap.elementtype.setdef(tarraydef.create(lowval,highval,arraytype));
 | |
|                      ap:=tarraydef(ap.elementtype.def);
 | |
|                    end;
 | |
| 
 | |
|                   if token=_COMMA then
 | |
|                     consume(_COMMA)
 | |
|                   else
 | |
|                     break;
 | |
|                 until false;
 | |
|                 consume(_RECKKLAMMER);
 | |
|              end
 | |
|            else
 | |
|              begin
 | |
|                 ap:=tarraydef.create(0,-1,s32bittype);
 | |
|                 ap.IsDynamicArray:=true;
 | |
|                 tt.setdef(ap);
 | |
|              end;
 | |
|            consume(_OF);
 | |
|            read_type(tt2,'',true);
 | |
|            { if no error, set element type }
 | |
|            if assigned(ap) then
 | |
|              ap.setelementtype(tt2);
 | |
|         end;
 | |
| 
 | |
|       var
 | |
|         p  : tnode;
 | |
|         pd : tabstractprocdef;
 | |
|         is_func,
 | |
|         enumdupmsg : boolean;
 | |
|         newtype : ttypesym;
 | |
|       begin
 | |
|          tt.reset;
 | |
|          case token of
 | |
|             _STRING,_FILE:
 | |
|               begin
 | |
|                 single_type(tt,hs,false);
 | |
|               end;
 | |
|            _LKLAMMER:
 | |
|               begin
 | |
|                 consume(_LKLAMMER);
 | |
|                 { allow negativ value_str }
 | |
|                 l:=-1;
 | |
|                 enumdupmsg:=false;
 | |
|                 aktenumdef:=tenumdef.create;
 | |
|                 repeat
 | |
|                   s:=orgpattern;
 | |
|                   defpos:=akttokenpos;
 | |
|                   consume(_ID);
 | |
|                   { only allow assigning of specific numbers under fpc mode }
 | |
|                   if not(m_tp7 in aktmodeswitches) and
 | |
|                      (
 | |
|                       { in fpc mode also allow := to be compatible
 | |
|                         with previous 1.0.x versions }
 | |
|                       ((m_fpc in aktmodeswitches) and
 | |
|                        try_to_consume(_ASSIGNMENT)) or
 | |
|                       try_to_consume(_EQUAL)
 | |
|                      ) then
 | |
|                     begin
 | |
|                        p:=comp_expr(true);
 | |
|                        if (p.nodetype=ordconstn) then
 | |
|                         begin
 | |
|                           { we expect an integer or an enum of the
 | |
|                             same type }
 | |
|                           if is_integer(p.resulttype.def) or
 | |
|                              is_char(p.resulttype.def) or
 | |
|                              equal_defs(p.resulttype.def,aktenumdef) then
 | |
|                            v:=tordconstnode(p).value
 | |
|                           else
 | |
|                            IncompatibleTypes(p.resulttype.def,s32bittype.def);
 | |
|                         end
 | |
|                        else
 | |
|                         Message(cg_e_illegal_expression);
 | |
|                        p.free;
 | |
|                        { please leave that a note, allows type save }
 | |
|                        { declarations in the win32 units ! }
 | |
|                        if (v<=l) and (not enumdupmsg) then
 | |
|                         begin
 | |
|                           Message(parser_n_duplicate_enum);
 | |
|                           enumdupmsg:=true;
 | |
|                         end;
 | |
|                        l:=v;
 | |
|                     end
 | |
|                   else
 | |
|                     inc(l);
 | |
|                   storepos:=akttokenpos;
 | |
|                   akttokenpos:=defpos;
 | |
|                   constsymtable.insert(tenumsym.create(s,aktenumdef,l));
 | |
|                   akttokenpos:=storepos;
 | |
|                 until not try_to_consume(_COMMA);
 | |
|                 tt.setdef(aktenumdef);
 | |
|                 consume(_RKLAMMER);
 | |
|               end;
 | |
|             _ARRAY:
 | |
|               begin
 | |
|                 array_dec;
 | |
|               end;
 | |
|             _SET:
 | |
|               begin
 | |
|                 consume(_SET);
 | |
|                 consume(_OF);
 | |
|                 read_type(tt2,'',true);
 | |
|                 if assigned(tt2.def) then
 | |
|                  begin
 | |
|                    case tt2.def.deftype of
 | |
|                      { don't forget that min can be negativ  PM }
 | |
|                      enumdef :
 | |
|                        if tenumdef(tt2.def).min>=0 then
 | |
|                         tt.setdef(tsetdef.create(tt2,tenumdef(tt2.def).max))
 | |
|                        else
 | |
|                         Message(sym_e_ill_type_decl_set);
 | |
|                      orddef :
 | |
|                        begin
 | |
|                          case torddef(tt2.def).typ of
 | |
|                            uchar :
 | |
|                              tt.setdef(tsetdef.create(tt2,255));
 | |
|                            u8bit,u16bit,u32bit,
 | |
|                            s8bit,s16bit,s32bit :
 | |
|                              begin
 | |
|                                if (torddef(tt2.def).low>=0) then
 | |
|                                 tt.setdef(tsetdef.create(tt2,torddef(tt2.def).high))
 | |
|                                else
 | |
|                                 Message(sym_e_ill_type_decl_set);
 | |
|                              end;
 | |
|                            else
 | |
|                              Message(sym_e_ill_type_decl_set);
 | |
|                          end;
 | |
|                        end;
 | |
|                      else
 | |
|                        Message(sym_e_ill_type_decl_set);
 | |
|                    end;
 | |
|                  end
 | |
|                 else
 | |
|                  tt:=generrortype;
 | |
|               end;
 | |
|            _CARET:
 | |
|               begin
 | |
|                 consume(_CARET);
 | |
|                 single_type(tt2,hs,typecanbeforward);
 | |
|                 tt.setdef(tpointerdef.create(tt2));
 | |
|               end;
 | |
|             _RECORD:
 | |
|               begin
 | |
|                 tt.setdef(record_dec);
 | |
|               end;
 | |
|             _PACKED:
 | |
|               begin
 | |
|                 consume(_PACKED);
 | |
|                 if token=_ARRAY then
 | |
|                   array_dec
 | |
|                 else
 | |
|                   begin
 | |
|                     oldaktpackrecords:=aktalignment.recordalignmax;
 | |
|                     aktalignment.recordalignmax:=1;
 | |
|                     if token in [_CLASS,_OBJECT] then
 | |
|                       tt.setdef(object_dec(name,nil))
 | |
|                     else
 | |
|                       tt.setdef(record_dec);
 | |
|                     aktalignment.recordalignmax:=oldaktpackrecords;
 | |
|                   end;
 | |
|               end;
 | |
|             _CLASS,
 | |
|             _CPPCLASS,
 | |
|             _INTERFACE,
 | |
|             _OBJECT:
 | |
|               begin
 | |
|                 tt.setdef(object_dec(name,nil));
 | |
|               end;
 | |
|             _PROCEDURE,
 | |
|             _FUNCTION:
 | |
|               begin
 | |
|                 is_func:=(token=_FUNCTION);
 | |
|                 consume(token);
 | |
|                 pd:=tprocvardef.create(normal_function_level);
 | |
|                 if token=_LKLAMMER then
 | |
|                   parse_parameter_dec(pd);
 | |
|                 if is_func then
 | |
|                  begin
 | |
|                    consume(_COLON);
 | |
|                    single_type(pd.rettype,hs,false);
 | |
|                  end;
 | |
|                 if token=_OF then
 | |
|                   begin
 | |
|                     consume(_OF);
 | |
|                     consume(_OBJECT);
 | |
|                     include(pd.procoptions,po_methodpointer);
 | |
|                   end;
 | |
|                 tt.def:=pd;
 | |
|                 { possible proc directives }
 | |
|                 if parseprocvardir then
 | |
|                   begin
 | |
|                     if is_proc_directive(token,true) then
 | |
|                       begin
 | |
|                          newtype:=ttypesym.create('unnamed',tt);
 | |
|                          parse_var_proc_directives(tsym(newtype));
 | |
|                          newtype.restype.def:=nil;
 | |
|                          tt.def.typesym:=nil;
 | |
|                          newtype.free;
 | |
|                       end;
 | |
|                     { Add implicit hidden parameters and function result }
 | |
|                     handle_calling_convention(pd);
 | |
|                     calc_parast(pd);
 | |
|                   end;
 | |
|               end;
 | |
|             else
 | |
|               expr_type;
 | |
|          end;
 | |
|          if tt.def=nil then
 | |
|           tt:=generrortype;
 | |
|       end;
 | |
| 
 | |
| end.
 | |
| {
 | |
|   $Log$
 | |
|   Revision 1.60  2003-10-21 18:16:13  peter
 | |
|     * IncompatibleTypes() added that will include unit names when
 | |
|       the typenames are the same
 | |
| 
 | |
|   Revision 1.59  2003/10/03 14:45:09  peter
 | |
|     * more proc directive for procvar fixes
 | |
| 
 | |
|   Revision 1.58  2003/10/02 21:13:09  peter
 | |
|     * procvar directive parsing fixes
 | |
| 
 | |
|   Revision 1.57  2003/10/01 19:05:33  peter
 | |
|     * searchsym_type to search for type definitions. It ignores
 | |
|       records,objects and parameters
 | |
| 
 | |
|   Revision 1.56  2003/09/23 17:56:06  peter
 | |
|     * locals and paras are allocated in the code generation
 | |
|     * tvarsym.localloc contains the location of para/local when
 | |
|       generating code for the current procedure
 | |
| 
 | |
|   Revision 1.55  2003/05/15 18:58:53  peter
 | |
|     * removed selfpointer_offset, vmtpointer_offset
 | |
|     * tvarsym.adjusted_address
 | |
|     * address in localsymtable is now in the real direction
 | |
|     * removed some obsolete globals
 | |
| 
 | |
|   Revision 1.54  2003/05/09 17:47:03  peter
 | |
|     * self moved to hidden parameter
 | |
|     * removed hdisposen,hnewn,selfn
 | |
| 
 | |
|   Revision 1.53  2003/04/27 11:21:34  peter
 | |
|     * aktprocdef renamed to current_procdef
 | |
|     * procinfo renamed to current_procinfo
 | |
|     * procinfo will now be stored in current_module so it can be
 | |
|       cleaned up properly
 | |
|     * gen_main_procsym changed to create_main_proc and release_main_proc
 | |
|       to also generate a tprocinfo structure
 | |
|     * fixed unit implicit initfinal
 | |
| 
 | |
|   Revision 1.52  2003/04/27 07:29:51  peter
 | |
|     * current_procdef cleanup, current_procdef is now always nil when parsing
 | |
|       a new procdef declaration
 | |
|     * aktprocsym removed
 | |
|     * lexlevel removed, use symtable.symtablelevel instead
 | |
|     * implicit init/final code uses the normal genentry/genexit
 | |
|     * funcret state checking updated for new funcret handling
 | |
| 
 | |
|   Revision 1.51  2003/04/25 20:59:34  peter
 | |
|     * removed funcretn,funcretsym, function result is now in varsym
 | |
|       and aliases for result and function name are added using absolutesym
 | |
|     * vs_hidden parameter for funcret passed in parameter
 | |
|     * vs_hidden fixes
 | |
|     * writenode changed to printnode and released from extdebug
 | |
|     * -vp option added to generate a tree.log with the nodetree
 | |
|     * nicer printnode for statements, callnode
 | |
| 
 | |
|   Revision 1.50  2003/01/05 15:54:15  florian
 | |
|     + added proper support of type = type <type>; for simple types
 | |
| 
 | |
|   Revision 1.49  2003/01/03 23:50:41  peter
 | |
|     * also allow = in fpc mode to assign enums
 | |
| 
 | |
|   Revision 1.48  2003/01/02 19:49:00  peter
 | |
|     * update self parameter only for methodpointer and methods
 | |
| 
 | |
|   Revision 1.47  2002/12/21 13:07:34  peter
 | |
|     * type redefine fix for tb0437
 | |
| 
 | |
|   Revision 1.46  2002/11/25 17:43:23  peter
 | |
|     * splitted defbase in defutil,symutil,defcmp
 | |
|     * merged isconvertable and is_equal into compare_defs(_ext)
 | |
|     * made operator search faster by walking the list only once
 | |
| 
 | |
|   Revision 1.45  2002/09/27 21:13:29  carl
 | |
|     * low-highval always checked if limit ober 2GB is reached (to avoid overflow)
 | |
| 
 | |
|   Revision 1.44  2002/09/10 16:26:39  peter
 | |
|     * safety check for typesym added for incomplete type def check
 | |
| 
 | |
|   Revision 1.43  2002/09/09 19:34:07  peter
 | |
|     * check for incomplete types in the current symtable when parsing
 | |
|       forwarddef. Maybe this shall be delphi/tp only
 | |
| 
 | |
|   Revision 1.42  2002/07/20 11:57:56  florian
 | |
|     * types.pas renamed to defbase.pas because D6 contains a types
 | |
|       unit so this would conflicts if D6 programms are compiled
 | |
|     + Willamette/SSE2 instructions to assembler added
 | |
| 
 | |
|   Revision 1.41  2002/05/18 13:34:16  peter
 | |
|     * readded missing revisions
 | |
| 
 | |
|   Revision 1.40  2002/05/16 19:46:44  carl
 | |
|   + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
 | |
|   + try to fix temp allocation (still in ifdef)
 | |
|   + generic constructor calls
 | |
|   + start of tassembler / tmodulebase class cleanup
 | |
| 
 | |
|   Revision 1.38  2002/05/12 16:53:10  peter
 | |
|     * moved entry and exitcode to ncgutil and cgobj
 | |
|     * foreach gets extra argument for passing local data to the
 | |
|       iterator function
 | |
|     * -CR checks also class typecasts at runtime by changing them
 | |
|       into as
 | |
|     * fixed compiler to cycle with the -CR option
 | |
|     * fixed stabs with elf writer, finally the global variables can
 | |
|       be watched
 | |
|     * removed a lot of routines from cga unit and replaced them by
 | |
|       calls to cgobj
 | |
|     * u32bit-s32bit updates for and,or,xor nodes. When one element is
 | |
|       u32bit then the other is typecasted also to u32bit without giving
 | |
|       a rangecheck warning/error.
 | |
|     * fixed pascal calling method with reversing also the high tree in
 | |
|       the parast, detected by tcalcst3 test
 | |
| 
 | |
|   Revision 1.37  2002/04/19 15:46:03  peter
 | |
|     * mangledname rewrite, tprocdef.mangledname is now created dynamicly
 | |
|       in most cases and not written to the ppu
 | |
|     * add mangeledname_prefix() routine to generate the prefix of
 | |
|       manglednames depending on the current procedure, object and module
 | |
|     * removed static procprefix since the mangledname is now build only
 | |
|       on demand from tprocdef.mangledname
 | |
| 
 | |
|   Revision 1.36  2002/04/16 16:12:47  peter
 | |
|     * give error when using enums with jumps as array index
 | |
|     * allow char as enum value
 | |
| 
 | |
|   Revision 1.35  2002/04/04 19:06:04  peter
 | |
|     * removed unused units
 | |
|     * use tlocation.size in cg.a_*loc*() routines
 | |
| 
 | |
|   Revision 1.34  2002/01/24 18:25:49  peter
 | |
|    * implicit result variable generation for assembler routines
 | |
|    * removed m_tp modeswitch, use m_tp7 or not(m_fpc) instead
 | |
| 
 | |
|   Revision 1.33  2002/01/15 16:13:34  jonas
 | |
|     * fixed web bugs 1758 and 1760
 | |
| 
 | |
|   Revision 1.32  2002/01/06 12:08:15  peter
 | |
|     * removed uauto from orddef, use new range_to_basetype generating
 | |
|       the correct ordinal type for a range
 | |
| 
 | |
| }
 | 
