← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to compiler/ptype.pas

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
compiler/ptype.pas
1
 
{
2
 
    $Id: ptype.pas,v 1.66 2004/03/29 14:44:10 peter Exp $
3
 
    Copyright (c) 1998-2002 by Florian Klaempfl
4
 
 
5
 
    Does parsing types for Free Pascal
6
 
 
7
 
    This program is free software; you can redistribute it and/or modify
8
 
    it under the terms of the GNU General Public License as published by
9
 
    the Free Software Foundation; either version 2 of the License, or
10
 
    (at your option) any later version.
11
 
 
12
 
    This program is distributed in the hope that it will be useful,
13
 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
14
 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15
 
    GNU General Public License for more details.
16
 
 
17
 
    You should have received a copy of the GNU General Public License
18
 
    along with this program; if not, write to the Free Software
19
 
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20
 
 
21
 
 ****************************************************************************
22
 
}
23
 
unit ptype;
24
 
 
25
 
{$i fpcdefs.inc}
26
 
 
27
 
interface
28
 
 
29
 
    uses
30
 
       globtype,symtype;
31
 
 
32
 
    const
33
 
       { forward types should only be possible inside a TYPE statement }
34
 
       typecanbeforward : boolean = false;
35
 
 
36
 
    var
37
 
       { hack, which allows to use the current parsed }
38
 
       { object type as function argument type  }
39
 
       testcurobject : byte;
40
 
       curobjectname : stringid;
41
 
 
42
 
    { reads a string, file type or a type id and returns a name and }
43
 
    { tdef }
44
 
    procedure single_type(var tt:ttype;var s : string;isforwarddef:boolean);
45
 
 
46
 
    procedure read_type(var tt:ttype;const name : stringid;parseprocvardir:boolean);
47
 
 
48
 
    { reads a type definition }
49
 
    { to a appropriating tdef, s gets the name of   }
50
 
    { the type to allow name mangling          }
51
 
    procedure id_type(var tt : ttype;var s : string;isforwarddef:boolean);
52
 
 
53
 
 
54
 
implementation
55
 
 
56
 
    uses
57
 
       { common }
58
 
       cutils,
59
 
       { global }
60
 
       globals,tokens,verbose,
61
 
       systems,
62
 
       { target }
63
 
       paramgr,
64
 
       { symtable }
65
 
       symconst,symbase,symdef,symsym,symtable,
66
 
       defutil,defcmp,
67
 
       { pass 1 }
68
 
       node,
69
 
       nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
70
 
       { parser }
71
 
       scanner,
72
 
       pbase,pexpr,pdecsub,pdecvar,pdecobj;
73
 
 
74
 
 
75
 
    procedure id_type(var tt : ttype;var s : string;isforwarddef:boolean);
76
 
    { reads a type definition }
77
 
    { to a appropriating tdef, s gets the name of   }
78
 
    { the type to allow name mangling          }
79
 
      var
80
 
        is_unit_specific : boolean;
81
 
        pos : tfileposinfo;
82
 
        srsym : tsym;
83
 
        srsymtable : tsymtable;
84
 
        sorg : stringid;
85
 
      begin
86
 
         s:=pattern;
87
 
         sorg:=orgpattern;
88
 
         pos:=akttokenpos;
89
 
         { classes can be used also in classes }
90
 
         if (curobjectname=pattern) and is_class_or_interface(aktobjectdef) then
91
 
           begin
92
 
              tt.setdef(aktobjectdef);
93
 
              consume(_ID);
94
 
              exit;
95
 
           end;
96
 
         { objects can be parameters }
97
 
         if (testcurobject=2) and (curobjectname=pattern) then
98
 
           begin
99
 
              tt.setdef(aktobjectdef);
100
 
              consume(_ID);
101
 
              exit;
102
 
           end;
103
 
         { try to load the symbol to see if it's a unitsym. Use the
104
 
           special searchsym_type that ignores records,objects and
105
 
           parameters }
106
 
         is_unit_specific:=false;
107
 
         searchsym_type(s,srsym,srsymtable);
108
 
         consume(_ID);
109
 
         if assigned(srsym) and
110
 
            (srsym.typ=unitsym) then
111
 
           begin
112
 
              is_unit_specific:=true;
113
 
              consume(_POINT);
114
 
              if srsym.owner.unitid=0 then
115
 
               begin
116
 
                 srsym:=searchsymonlyin(tunitsym(srsym).unitsymtable,pattern);
117
 
                 pos:=akttokenpos;
118
 
                 s:=pattern;
119
 
               end
120
 
              else
121
 
               srsym:=nil;
122
 
              consume(_ID);
123
 
           end;
124
 
         { Types are first defined with an error def before assigning
125
 
           the real type so check if it's an errordef. if so then
126
 
           give an error. Only check for typesyms in the current symbol
127
 
           table as forwarddef are not resolved directly }
128
 
         if assigned(srsym) and
129
 
            (srsym.typ=typesym) and
130
 
            (srsym.owner=symtablestack) and
131
 
            (ttypesym(srsym).restype.def.deftype=errordef) then
132
 
          begin
133
 
            Message1(type_e_type_is_not_completly_defined,ttypesym(srsym).realname);
134
 
            tt:=generrortype;
135
 
            exit;
136
 
          end;
137
 
         { are we parsing a possible forward def ? }
138
 
         if isforwarddef and
139
 
            not(is_unit_specific) then
140
 
          begin
141
 
            tt.setdef(tforwarddef.create(s,pos));
142
 
            exit;
143
 
          end;
144
 
         { unknown sym ? }
145
 
         if not assigned(srsym) then
146
 
          begin
147
 
            Message1(sym_e_id_not_found,sorg);
148
 
            tt:=generrortype;
149
 
            exit;
150
 
          end;
151
 
         { type sym ? }
152
 
         if (srsym.typ<>typesym) then
153
 
          begin
154
 
            Message(type_e_type_id_expected);
155
 
            tt:=generrortype;
156
 
            exit;
157
 
          end;
158
 
         { Give an error when referring to an errordef }
159
 
         if (ttypesym(srsym).restype.def.deftype=errordef) then
160
 
          begin
161
 
            Message(sym_e_error_in_type_def);
162
 
            tt:=generrortype;
163
 
            exit;
164
 
          end;
165
 
         { Use the definitions for current unit, because
166
 
           they can be refered from the parameters and symbols are not
167
 
           loaded at that time. Only write the definition when the
168
 
           symbol is the real owner of the definition (not a redefine) }
169
 
         if (ttypesym(srsym).owner.unitid=0) and
170
 
            ((ttypesym(srsym).restype.def.typesym=nil) or
171
 
             (srsym=ttypesym(srsym).restype.def.typesym)) then
172
 
          tt.setdef(ttypesym(srsym).restype.def)
173
 
         else
174
 
          tt.setsym(srsym);
175
 
      end;
176
 
 
177
 
 
178
 
    procedure single_type(var tt:ttype;var s : string;isforwarddef:boolean);
179
 
    { reads a string, file type or a type id and returns a name and }
180
 
    { tdef                                                        }
181
 
       var
182
 
          hs : string;
183
 
          t2 : ttype;
184
 
       begin
185
 
          case token of
186
 
            _STRING:
187
 
                begin
188
 
                   string_dec(tt);
189
 
                   s:='STRING';
190
 
                end;
191
 
            _FILE:
192
 
                begin
193
 
                   consume(_FILE);
194
 
                   if token=_OF then
195
 
                     begin
196
 
                        consume(_OF);
197
 
                        single_type(t2,hs,false);
198
 
                        tt.setdef(tfiledef.createtyped(t2));
199
 
                        s:='FILE$OF$'+hs;
200
 
                     end
201
 
                   else
202
 
                     begin
203
 
                        tt:=cfiletype;
204
 
                        s:='FILE';
205
 
                     end;
206
 
                end;
207
 
            _ID:
208
 
              begin
209
 
                id_type(tt,s,isforwarddef);
210
 
              end;
211
 
            else
212
 
              begin
213
 
                message(type_e_type_id_expected);
214
 
                s:='<unknown>';
215
 
                tt:=generrortype;
216
 
              end;
217
 
         end;
218
 
      end;
219
 
 
220
 
    { reads a record declaration }
221
 
    function record_dec : tdef;
222
 
 
223
 
      var
224
 
         symtable : tsymtable;
225
 
         storetypecanbeforward : boolean;
226
 
         old_object_option : tsymoptions;
227
 
      begin
228
 
         { create recdef }
229
 
         symtable:=trecordsymtable.create(aktpackrecords);
230
 
         record_dec:=trecorddef.create(symtable);
231
 
         { update symtable stack }
232
 
         symtable.next:=symtablestack;
233
 
         symtablestack:=symtable;
234
 
         { parse record }
235
 
         consume(_RECORD);
236
 
         old_object_option:=current_object_option;
237
 
         current_object_option:=[sp_public];
238
 
         storetypecanbeforward:=typecanbeforward;
239
 
         { for tp7 don't allow forward types }
240
 
         if m_tp7 in aktmodeswitches then
241
 
           typecanbeforward:=false;
242
 
         read_var_decs(true,false,false);
243
 
         consume(_END);
244
 
         typecanbeforward:=storetypecanbeforward;
245
 
         current_object_option:=old_object_option;
246
 
         { make the record size aligned }
247
 
         trecordsymtable(symtablestack).addalignmentpadding;
248
 
         { restore symtable stack }
249
 
         symtablestack:=symtable.next;
250
 
      end;
251
 
 
252
 
 
253
 
    { reads a type definition and returns a pointer to it }
254
 
    procedure read_type(var tt : ttype;const name : stringid;parseprocvardir:boolean);
255
 
      var
256
 
        pt : tnode;
257
 
        tt2 : ttype;
258
 
        aktenumdef : tenumdef;
259
 
        ap : tarraydef;
260
 
        s : stringid;
261
 
        l,v : TConstExprInt;
262
 
        oldaktpackrecords : longint;
263
 
        hs : string;
264
 
        defpos,storepos : tfileposinfo;
265
 
 
266
 
        procedure expr_type;
267
 
        var
268
 
           pt1,pt2 : tnode;
269
 
           lv,hv   : TConstExprInt;
270
 
        begin
271
 
           { use of current parsed object ? }
272
 
           if (token=_ID) and (testcurobject=2) and (curobjectname=pattern) then
273
 
             begin
274
 
                consume(_ID);
275
 
                tt.setdef(aktobjectdef);
276
 
                exit;
277
 
             end;
278
 
           { classes can be used also in classes }
279
 
           if (curobjectname=pattern) and is_class_or_interface(aktobjectdef) then
280
 
             begin
281
 
                tt.setdef(aktobjectdef);
282
 
                consume(_ID);
283
 
                exit;
284
 
             end;
285
 
           { we can't accept a equal in type }
286
 
           pt1:=comp_expr(not(ignore_equal));
287
 
           if (token=_POINTPOINT) then
288
 
             begin
289
 
               consume(_POINTPOINT);
290
 
               { get high value of range }
291
 
               pt2:=comp_expr(not(ignore_equal));
292
 
               { make both the same type or give an error. This is not
293
 
                 done when both are integer values, because typecasting
294
 
                 between -3200..3200 will result in a signed-unsigned
295
 
                 conflict and give a range check error (PFV) }
296
 
               if not(is_integer(pt1.resulttype.def) and is_integer(pt2.resulttype.def)) then
297
 
                 inserttypeconv(pt1,pt2.resulttype);
298
 
               { both must be evaluated to constants now }
299
 
               if (pt1.nodetype=ordconstn) and
300
 
                  (pt2.nodetype=ordconstn) then
301
 
                 begin
302
 
                   lv:=tordconstnode(pt1).value;
303
 
                   hv:=tordconstnode(pt2).value;
304
 
                   { Check bounds }
305
 
                   if hv<lv then
306
 
                     Message(cg_e_upper_lower_than_lower)
307
 
                   else
308
 
                     begin
309
 
                       { All checks passed, create the new def }
310
 
                       case pt1.resulttype.def.deftype of
311
 
                         enumdef :
312
 
                           tt.setdef(tenumdef.create_subrange(tenumdef(pt1.resulttype.def),lv,hv));
313
 
                         orddef :
314
 
                           begin
315
 
                             if is_char(pt1.resulttype.def) then
316
 
                               tt.setdef(torddef.create(uchar,lv,hv))
317
 
                             else
318
 
                               if is_boolean(pt1.resulttype.def) then
319
 
                                 tt.setdef(torddef.create(bool8bit,l,hv))
320
 
                               else
321
 
                                 tt.setdef(torddef.create(range_to_basetype(lv,hv),lv,hv));
322
 
                           end;
323
 
                       end;
324
 
                     end;
325
 
                 end
326
 
               else
327
 
                 Message(sym_e_error_in_type_def);
328
 
               pt2.free;
329
 
             end
330
 
           else
331
 
             begin
332
 
               { a simple type renaming }
333
 
               if (pt1.nodetype=typen) then
334
 
                 tt:=ttypenode(pt1).resulttype
335
 
               else
336
 
                 Message(sym_e_error_in_type_def);
337
 
             end;
338
 
           pt1.free;
339
 
        end;
340
 
 
341
 
        procedure array_dec;
342
 
        var
343
 
          lowval,
344
 
          highval   : longint;
345
 
          arraytype : ttype;
346
 
          ht        : ttype;
347
 
 
348
 
          procedure setdefdecl(const t:ttype);
349
 
          begin
350
 
            case t.def.deftype of
351
 
              enumdef :
352
 
                begin
353
 
                  lowval:=tenumdef(t.def).min;
354
 
                  highval:=tenumdef(t.def).max;
355
 
                  if tenumdef(t.def).has_jumps then
356
 
                   Message(type_e_array_index_enums_with_assign_not_possible);
357
 
                  arraytype:=t;
358
 
                end;
359
 
              orddef :
360
 
                begin
361
 
                  if torddef(t.def).typ in [uchar,
362
 
                    u8bit,u16bit,
363
 
                    s8bit,s16bit,s32bit,
364
 
                    bool8bit,bool16bit,bool32bit,
365
 
                    uwidechar] then
366
 
                    begin
367
 
                       lowval:=torddef(t.def).low;
368
 
                       highval:=torddef(t.def).high;
369
 
                       arraytype:=t;
370
 
                    end
371
 
                  else
372
 
                    Message1(parser_e_type_cant_be_used_in_array_index,t.def.gettypename);
373
 
                end;
374
 
              else
375
 
                Message(sym_e_error_in_type_def);
376
 
            end;
377
 
          end;
378
 
 
379
 
        begin
380
 
           consume(_ARRAY);
381
 
           { open array? }
382
 
           if token=_LECKKLAMMER then
383
 
             begin
384
 
                consume(_LECKKLAMMER);
385
 
                { defaults }
386
 
                arraytype:=generrortype;
387
 
                lowval:=longint($80000000);
388
 
                highval:=$7fffffff;
389
 
                tt.reset;
390
 
                repeat
391
 
                  { read the expression and check it, check apart if the
392
 
                    declaration is an enum declaration because that needs to
393
 
                    be parsed by readtype (PFV) }
394
 
                  if token=_LKLAMMER then
395
 
                   begin
396
 
                     read_type(ht,'',true);
397
 
                     setdefdecl(ht);
398
 
                   end
399
 
                  else
400
 
                   begin
401
 
                     pt:=expr;
402
 
                     if pt.nodetype=typen then
403
 
                      setdefdecl(pt.resulttype)
404
 
                     else
405
 
                       begin
406
 
                          if (pt.nodetype=rangen) then
407
 
                           begin
408
 
                             if (trangenode(pt).left.nodetype=ordconstn) and
409
 
                                (trangenode(pt).right.nodetype=ordconstn) then
410
 
                              begin
411
 
                                { make both the same type or give an error. This is not
412
 
                                  done when both are integer values, because typecasting
413
 
                                  between -3200..3200 will result in a signed-unsigned
414
 
                                  conflict and give a range check error (PFV) }
415
 
                                if not(is_integer(trangenode(pt).left.resulttype.def) and is_integer(trangenode(pt).left.resulttype.def)) then
416
 
                                  inserttypeconv(trangenode(pt).left,trangenode(pt).right.resulttype);
417
 
                                lowval:=tordconstnode(trangenode(pt).left).value;
418
 
                                highval:=tordconstnode(trangenode(pt).right).value;
419
 
                                if highval<lowval then
420
 
                                 begin
421
 
                                   Message(parser_e_array_lower_less_than_upper_bound);
422
 
                                   highval:=lowval;
423
 
                                 end;
424
 
                                if is_integer(trangenode(pt).left.resulttype.def) then
425
 
                                  range_to_type(lowval,highval,arraytype)
426
 
                                else
427
 
                                  arraytype:=trangenode(pt).left.resulttype;
428
 
                              end
429
 
                             else
430
 
                              Message(type_e_cant_eval_constant_expr);
431
 
                           end
432
 
                          else
433
 
                           Message(sym_e_error_in_type_def)
434
 
                       end;
435
 
                     pt.free;
436
 
                   end;
437
 
 
438
 
                { create arraydef }
439
 
                  if not assigned(tt.def) then
440
 
                   begin
441
 
                     ap:=tarraydef.create(lowval,highval,arraytype);
442
 
                     tt.setdef(ap);
443
 
                   end
444
 
                  else
445
 
                   begin
446
 
                     ap.elementtype.setdef(tarraydef.create(lowval,highval,arraytype));
447
 
                     ap:=tarraydef(ap.elementtype.def);
448
 
                   end;
449
 
 
450
 
                  if token=_COMMA then
451
 
                    consume(_COMMA)
452
 
                  else
453
 
                    break;
454
 
                until false;
455
 
                consume(_RECKKLAMMER);
456
 
             end
457
 
           else
458
 
             begin
459
 
                ap:=tarraydef.create(0,-1,s32inttype);
460
 
                ap.IsDynamicArray:=true;
461
 
                tt.setdef(ap);
462
 
             end;
463
 
           consume(_OF);
464
 
           read_type(tt2,'',true);
465
 
           { if no error, set element type }
466
 
           if assigned(ap) then
467
 
             ap.setelementtype(tt2);
468
 
        end;
469
 
 
470
 
      var
471
 
        p  : tnode;
472
 
        pd : tabstractprocdef;
473
 
        is_func,
474
 
        enumdupmsg : boolean;
475
 
        newtype : ttypesym;
476
 
      begin
477
 
         tt.reset;
478
 
         case token of
479
 
            _STRING,_FILE:
480
 
              begin
481
 
                single_type(tt,hs,false);
482
 
              end;
483
 
           _LKLAMMER:
484
 
              begin
485
 
                consume(_LKLAMMER);
486
 
                { allow negativ value_str }
487
 
                l:=-1;
488
 
                enumdupmsg:=false;
489
 
                aktenumdef:=tenumdef.create;
490
 
                repeat
491
 
                  s:=orgpattern;
492
 
                  defpos:=akttokenpos;
493
 
                  consume(_ID);
494
 
                  { only allow assigning of specific numbers under fpc mode }
495
 
                  if not(m_tp7 in aktmodeswitches) and
496
 
                     (
497
 
                      { in fpc mode also allow := to be compatible
498
 
                        with previous 1.0.x versions }
499
 
                      ((m_fpc in aktmodeswitches) and
500
 
                       try_to_consume(_ASSIGNMENT)) or
501
 
                      try_to_consume(_EQUAL)
502
 
                     ) then
503
 
                    begin
504
 
                       p:=comp_expr(true);
505
 
                       if (p.nodetype=ordconstn) then
506
 
                        begin
507
 
                          { we expect an integer or an enum of the
508
 
                            same type }
509
 
                          if is_integer(p.resulttype.def) or
510
 
                             is_char(p.resulttype.def) or
511
 
                             equal_defs(p.resulttype.def,aktenumdef) then
512
 
                           v:=tordconstnode(p).value
513
 
                          else
514
 
                           IncompatibleTypes(p.resulttype.def,s32inttype.def);
515
 
                        end
516
 
                       else
517
 
                        Message(cg_e_illegal_expression);
518
 
                       p.free;
519
 
                       { please leave that a note, allows type save }
520
 
                       { declarations in the win32 units ! }
521
 
                       if (v<=l) and (not enumdupmsg) then
522
 
                        begin
523
 
                          Message(parser_n_duplicate_enum);
524
 
                          enumdupmsg:=true;
525
 
                        end;
526
 
                       l:=v;
527
 
                    end
528
 
                  else
529
 
                    inc(l);
530
 
                  storepos:=akttokenpos;
531
 
                  akttokenpos:=defpos;
532
 
                  constsymtable.insert(tenumsym.create(s,aktenumdef,l));
533
 
                  akttokenpos:=storepos;
534
 
                until not try_to_consume(_COMMA);
535
 
                tt.setdef(aktenumdef);
536
 
                consume(_RKLAMMER);
537
 
              end;
538
 
            _ARRAY:
539
 
              begin
540
 
                array_dec;
541
 
              end;
542
 
            _SET:
543
 
              begin
544
 
                consume(_SET);
545
 
                consume(_OF);
546
 
                read_type(tt2,'',true);
547
 
                if assigned(tt2.def) then
548
 
                 begin
549
 
                   case tt2.def.deftype of
550
 
                     { don't forget that min can be negativ  PM }
551
 
                     enumdef :
552
 
                       if tenumdef(tt2.def).min>=0 then
553
 
                        tt.setdef(tsetdef.create(tt2,tenumdef(tt2.def).max))
554
 
                       else
555
 
                        Message(sym_e_ill_type_decl_set);
556
 
                     orddef :
557
 
                       begin
558
 
                         case torddef(tt2.def).typ of
559
 
                           uchar :
560
 
                             tt.setdef(tsetdef.create(tt2,255));
561
 
                           u8bit,u16bit,u32bit,
562
 
                           s8bit,s16bit,s32bit :
563
 
                             begin
564
 
                               if (torddef(tt2.def).low>=0) then
565
 
                                tt.setdef(tsetdef.create(tt2,torddef(tt2.def).high))
566
 
                               else
567
 
                                Message(sym_e_ill_type_decl_set);
568
 
                             end;
569
 
                           else
570
 
                             Message(sym_e_ill_type_decl_set);
571
 
                         end;
572
 
                       end;
573
 
                     else
574
 
                       Message(sym_e_ill_type_decl_set);
575
 
                   end;
576
 
                 end
577
 
                else
578
 
                 tt:=generrortype;
579
 
              end;
580
 
           _CARET:
581
 
              begin
582
 
                consume(_CARET);
583
 
                single_type(tt2,hs,typecanbeforward);
584
 
                tt.setdef(tpointerdef.create(tt2));
585
 
              end;
586
 
            _RECORD:
587
 
              begin
588
 
                tt.setdef(record_dec);
589
 
              end;
590
 
            _PACKED:
591
 
              begin
592
 
                consume(_PACKED);
593
 
                if token=_ARRAY then
594
 
                  array_dec
595
 
                else
596
 
                  begin
597
 
                    oldaktpackrecords:=aktpackrecords;
598
 
                    aktpackrecords:=1;
599
 
                    if token in [_CLASS,_OBJECT] then
600
 
                      tt.setdef(object_dec(name,nil))
601
 
                    else
602
 
                      tt.setdef(record_dec);
603
 
                    aktpackrecords:=oldaktpackrecords;
604
 
                  end;
605
 
              end;
606
 
            _CLASS,
607
 
            _CPPCLASS,
608
 
            _INTERFACE,
609
 
            _OBJECT:
610
 
              begin
611
 
                tt.setdef(object_dec(name,nil));
612
 
              end;
613
 
            _PROCEDURE,
614
 
            _FUNCTION:
615
 
              begin
616
 
                is_func:=(token=_FUNCTION);
617
 
                consume(token);
618
 
                pd:=tprocvardef.create(normal_function_level);
619
 
                if token=_LKLAMMER then
620
 
                  parse_parameter_dec(pd);
621
 
                if is_func then
622
 
                 begin
623
 
                   consume(_COLON);
624
 
                   single_type(pd.rettype,hs,false);
625
 
                 end;
626
 
                if token=_OF then
627
 
                  begin
628
 
                    consume(_OF);
629
 
                    consume(_OBJECT);
630
 
                    include(pd.procoptions,po_methodpointer);
631
 
                  end;
632
 
                tt.def:=pd;
633
 
                { possible proc directives }
634
 
                if parseprocvardir then
635
 
                  begin
636
 
                    if is_proc_directive(token,true) then
637
 
                      begin
638
 
                         newtype:=ttypesym.create('unnamed',tt);
639
 
                         parse_var_proc_directives(tsym(newtype));
640
 
                         newtype.restype.def:=nil;
641
 
                         tt.def.typesym:=nil;
642
 
                         newtype.free;
643
 
                      end;
644
 
                    { Add implicit hidden parameters and function result }
645
 
                    handle_calling_convention(pd);
646
 
                    calc_parast(pd);
647
 
                  end;
648
 
              end;
649
 
            else
650
 
              expr_type;
651
 
         end;
652
 
         if tt.def=nil then
653
 
          tt:=generrortype;
654
 
      end;
655
 
 
656
 
end.
657
 
{
658
 
  $Log: ptype.pas,v $
659
 
  Revision 1.66  2004/03/29 14:44:10  peter
660
 
    * fixes to previous constant integer commit
661
 
 
662
 
  Revision 1.65  2004/03/23 22:34:49  peter
663
 
    * constants ordinals now always have a type assigned
664
 
    * integer constants have the smallest type, unsigned prefered over
665
 
      signed
666
 
 
667
 
  Revision 1.64  2004/02/03 22:32:54  peter
668
 
    * renamed xNNbittype to xNNinttype
669
 
    * renamed registers32 to registersint
670
 
    * replace some s32bit,u32bit with torddef([su]inttype).def.typ
671
 
 
672
 
  Revision 1.63  2004/01/29 16:51:29  peter
673
 
    * fixed alignment calculation for variant records
674
 
    * fixed alignment padding of records
675
 
 
676
 
  Revision 1.62  2004/01/28 22:16:31  peter
677
 
    * more record alignment fixes
678
 
 
679
 
  Revision 1.61  2004/01/28 20:30:18  peter
680
 
    * record alignment splitted in fieldalignment and recordalignment,
681
 
      the latter is used when this record is inserted in another record.
682
 
 
683
 
  Revision 1.60  2003/10/21 18:16:13  peter
684
 
    * IncompatibleTypes() added that will include unit names when
685
 
      the typenames are the same
686
 
 
687
 
  Revision 1.59  2003/10/03 14:45:09  peter
688
 
    * more proc directive for procvar fixes
689
 
 
690
 
  Revision 1.58  2003/10/02 21:13:09  peter
691
 
    * procvar directive parsing fixes
692
 
 
693
 
  Revision 1.57  2003/10/01 19:05:33  peter
694
 
    * searchsym_type to search for type definitions. It ignores
695
 
      records,objects and parameters
696
 
 
697
 
  Revision 1.56  2003/09/23 17:56:06  peter
698
 
    * locals and paras are allocated in the code generation
699
 
    * tvarsym.localloc contains the location of para/local when
700
 
      generating code for the current procedure
701
 
 
702
 
  Revision 1.55  2003/05/15 18:58:53  peter
703
 
    * removed selfpointer_offset, vmtpointer_offset
704
 
    * tvarsym.adjusted_address
705
 
    * address in localsymtable is now in the real direction
706
 
    * removed some obsolete globals
707
 
 
708
 
  Revision 1.54  2003/05/09 17:47:03  peter
709
 
    * self moved to hidden parameter
710
 
    * removed hdisposen,hnewn,selfn
711
 
 
712
 
  Revision 1.53  2003/04/27 11:21:34  peter
713
 
    * aktprocdef renamed to current_procdef
714
 
    * procinfo renamed to current_procinfo
715
 
    * procinfo will now be stored in current_module so it can be
716
 
      cleaned up properly
717
 
    * gen_main_procsym changed to create_main_proc and release_main_proc
718
 
      to also generate a tprocinfo structure
719
 
    * fixed unit implicit initfinal
720
 
 
721
 
  Revision 1.52  2003/04/27 07:29:51  peter
722
 
    * current_procdef cleanup, current_procdef is now always nil when parsing
723
 
      a new procdef declaration
724
 
    * aktprocsym removed
725
 
    * lexlevel removed, use symtable.symtablelevel instead
726
 
    * implicit init/final code uses the normal genentry/genexit
727
 
    * funcret state checking updated for new funcret handling
728
 
 
729
 
  Revision 1.51  2003/04/25 20:59:34  peter
730
 
    * removed funcretn,funcretsym, function result is now in varsym
731
 
      and aliases for result and function name are added using absolutesym
732
 
    * vs_hidden parameter for funcret passed in parameter
733
 
    * vs_hidden fixes
734
 
    * writenode changed to printnode and released from extdebug
735
 
    * -vp option added to generate a tree.log with the nodetree
736
 
    * nicer printnode for statements, callnode
737
 
 
738
 
  Revision 1.50  2003/01/05 15:54:15  florian
739
 
    + added proper support of type = type <type>; for simple types
740
 
 
741
 
  Revision 1.49  2003/01/03 23:50:41  peter
742
 
    * also allow = in fpc mode to assign enums
743
 
 
744
 
  Revision 1.48  2003/01/02 19:49:00  peter
745
 
    * update self parameter only for methodpointer and methods
746
 
 
747
 
  Revision 1.47  2002/12/21 13:07:34  peter
748
 
    * type redefine fix for tb0437
749
 
 
750
 
  Revision 1.46  2002/11/25 17:43:23  peter
751
 
    * splitted defbase in defutil,symutil,defcmp
752
 
    * merged isconvertable and is_equal into compare_defs(_ext)
753
 
    * made operator search faster by walking the list only once
754
 
 
755
 
  Revision 1.45  2002/09/27 21:13:29  carl
756
 
    * low-highval always checked if limit ober 2GB is reached (to avoid overflow)
757
 
 
758
 
  Revision 1.44  2002/09/10 16:26:39  peter
759
 
    * safety check for typesym added for incomplete type def check
760
 
 
761
 
  Revision 1.43  2002/09/09 19:34:07  peter
762
 
    * check for incomplete types in the current symtable when parsing
763
 
      forwarddef. Maybe this shall be delphi/tp only
764
 
 
765
 
  Revision 1.42  2002/07/20 11:57:56  florian
766
 
    * types.pas renamed to defbase.pas because D6 contains a types
767
 
      unit so this would conflicts if D6 programms are compiled
768
 
    + Willamette/SSE2 instructions to assembler added
769
 
 
770
 
  Revision 1.41  2002/05/18 13:34:16  peter
771
 
    * readded missing revisions
772
 
 
773
 
  Revision 1.40  2002/05/16 19:46:44  carl
774
 
  + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
775
 
  + try to fix temp allocation (still in ifdef)
776
 
  + generic constructor calls
777
 
  + start of tassembler / tmodulebase class cleanup
778
 
 
779
 
  Revision 1.38  2002/05/12 16:53:10  peter
780
 
    * moved entry and exitcode to ncgutil and cgobj
781
 
    * foreach gets extra argument for passing local data to the
782
 
      iterator function
783
 
    * -CR checks also class typecasts at runtime by changing them
784
 
      into as
785
 
    * fixed compiler to cycle with the -CR option
786
 
    * fixed stabs with elf writer, finally the global variables can
787
 
      be watched
788
 
    * removed a lot of routines from cga unit and replaced them by
789
 
      calls to cgobj
790
 
    * u32bit-s32bit updates for and,or,xor nodes. When one element is
791
 
      u32bit then the other is typecasted also to u32bit without giving
792
 
      a rangecheck warning/error.
793
 
    * fixed pascal calling method with reversing also the high tree in
794
 
      the parast, detected by tcalcst3 test
795
 
 
796
 
  Revision 1.37  2002/04/19 15:46:03  peter
797
 
    * mangledname rewrite, tprocdef.mangledname is now created dynamicly
798
 
      in most cases and not written to the ppu
799
 
    * add mangeledname_prefix() routine to generate the prefix of
800
 
      manglednames depending on the current procedure, object and module
801
 
    * removed static procprefix since the mangledname is now build only
802
 
      on demand from tprocdef.mangledname
803
 
 
804
 
  Revision 1.36  2002/04/16 16:12:47  peter
805
 
    * give error when using enums with jumps as array index
806
 
    * allow char as enum value
807
 
 
808
 
  Revision 1.35  2002/04/04 19:06:04  peter
809
 
    * removed unused units
810
 
    * use tlocation.size in cg.a_*loc*() routines
811
 
 
812
 
  Revision 1.34  2002/01/24 18:25:49  peter
813
 
   * implicit result variable generation for assembler routines
814
 
   * removed m_tp modeswitch, use m_tp7 or not(m_fpc) instead
815
 
 
816
 
  Revision 1.33  2002/01/15 16:13:34  jonas
817
 
    * fixed web bugs 1758 and 1760
818
 
 
819
 
  Revision 1.32  2002/01/06 12:08:15  peter
820
 
    * removed uauto from orddef, use new range_to_basetype generating
821
 
      the correct ordinal type for a range
822
 
 
823
 
}