← Back to branch summary

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

« back to all changes in this revision

Viewing changes to compiler/symdef.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/symdef.pas
1
 
{
2
 
    $Id: symdef.pas,v 1.240 2004/05/25 18:51:14 peter Exp $
3
 
    Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller
4
 
 
5
 
    Symbol table implementation for the definitions
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
 
unit symdef;
23
 
 
24
 
{$i fpcdefs.inc}
25
 
 
26
 
interface
27
 
 
28
 
    uses
29
 
       { common }
30
 
       cutils,cclasses,
31
 
       { global }
32
 
       globtype,globals,tokens,
33
 
       { symtable }
34
 
       symconst,symbase,symtype,
35
 
       { ppu }
36
 
       ppu,
37
 
       { node }
38
 
       node,
39
 
       { aasm }
40
 
       aasmbase,aasmtai,
41
 
       cpubase,cpuinfo,
42
 
       cgbase
43
 
{$ifdef Delphi}
44
 
       ,dmisc
45
 
{$endif}
46
 
       ;
47
 
 
48
 
 
49
 
    type
50
 
{************************************************
51
 
                    TDef
52
 
************************************************}
53
 
 
54
 
       tstoreddef = class(tdef)
55
 
       protected
56
 
          typesymderef  : tderef;
57
 
       public
58
 
          { persistent (available across units) rtti and init tables }
59
 
          rttitablesym,
60
 
          inittablesym  : tsym; {trttisym}
61
 
          rttitablesymderef,
62
 
          inittablesymderef : tderef;
63
 
          { local (per module) rtti and init tables }
64
 
          localrttilab  : array[trttitype] of tasmlabel;
65
 
          { linked list of global definitions }
66
 
{$ifdef EXTDEBUG}
67
 
          fileinfo   : tfileposinfo;
68
 
{$endif}
69
 
{$ifdef GDB}
70
 
          globalnb   : word;
71
 
          stab_state : tdefstabstatus;
72
 
{$endif GDB}
73
 
          constructor create;
74
 
          constructor ppuloaddef(ppufile:tcompilerppufile);
75
 
          procedure reset;
76
 
          function getcopy : tstoreddef;virtual;
77
 
          procedure ppuwritedef(ppufile:tcompilerppufile);
78
 
          procedure ppuwrite(ppufile:tcompilerppufile);virtual;abstract;
79
 
          procedure buildderef;override;
80
 
          procedure buildderefimpl;override;
81
 
          procedure deref;override;
82
 
          procedure derefimpl;override;
83
 
          function  size:longint;override;
84
 
          function  alignment:longint;override;
85
 
          function  is_publishable : boolean;override;
86
 
          function  needs_inittable : boolean;override;
87
 
          { debug }
88
 
{$ifdef GDB}
89
 
          function get_var_value(const s:string):string;
90
 
          function stabstr_evaluate(const s:string;const vars:array of string):Pchar;
91
 
          function  stabstring : pchar;virtual;
92
 
          procedure concatstabto(asmlist : taasmoutput);virtual;
93
 
          function  numberstring:string;virtual;
94
 
          procedure set_globalnb;virtual;
95
 
          function  allstabstring : pchar;virtual;
96
 
{$endif GDB}
97
 
          { rtti generation }
98
 
          procedure write_rtti_name;
99
 
          procedure write_rtti_data(rt:trttitype);virtual;
100
 
          procedure write_child_rtti_data(rt:trttitype);virtual;
101
 
          function  get_rtti_label(rt:trttitype):tasmsymbol;
102
 
          { regvars }
103
 
          function is_intregable : boolean;
104
 
          function is_fpuregable : boolean;
105
 
       private
106
 
          savesize  : longint;
107
 
       end;
108
 
 
109
 
       tparaitem = class(TLinkedListItem)
110
 
          paratype     : ttype; { required for procvar }
111
 
          parasym      : tsym;
112
 
          parasymderef : tderef;
113
 
          defaultvalue : tsym; { tconstsym }
114
 
          defaultvaluederef : tderef;
115
 
          paratyp       : tvarspez; { required for procvar }
116
 
          paraloc       : array[tcallercallee] of tparalocation;
117
 
          is_hidden     : boolean; { is this a hidden (implicit) parameter }
118
 
{$ifdef EXTDEBUG}
119
 
          eqval         : tequaltype;
120
 
{$endif EXTDEBUG}
121
 
       end;
122
 
 
123
 
       tfiletyp = (ft_text,ft_typed,ft_untyped);
124
 
 
125
 
       tfiledef = class(tstoreddef)
126
 
          filetyp : tfiletyp;
127
 
          typedfiletype : ttype;
128
 
          constructor createtext;
129
 
          constructor createuntyped;
130
 
          constructor createtyped(const tt : ttype);
131
 
          constructor ppuload(ppufile:tcompilerppufile);
132
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
133
 
          procedure buildderef;override;
134
 
          procedure deref;override;
135
 
          function  gettypename:string;override;
136
 
          function  getmangledparaname:string;override;
137
 
          procedure setsize;
138
 
          { debug }
139
 
{$ifdef GDB}
140
 
          function  stabstring : pchar;override;
141
 
          procedure concatstabto(asmlist : taasmoutput);override;
142
 
{$endif GDB}
143
 
       end;
144
 
 
145
 
       tvariantdef = class(tstoreddef)
146
 
          varianttype : tvarianttype;
147
 
          constructor create(v : tvarianttype);
148
 
          constructor ppuload(ppufile:tcompilerppufile);
149
 
          function gettypename:string;override;
150
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
151
 
          procedure setsize;
152
 
          function needs_inittable : boolean;override;
153
 
          procedure write_rtti_data(rt:trttitype);override;
154
 
{$ifdef GDB}
155
 
          function  numberstring:string;override;
156
 
          function  stabstring : pchar;override;
157
 
          procedure concatstabto(asmlist : taasmoutput);override;
158
 
{$endif GDB}
159
 
       end;
160
 
 
161
 
       tformaldef = class(tstoreddef)
162
 
          constructor create;
163
 
          constructor ppuload(ppufile:tcompilerppufile);
164
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
165
 
          function  gettypename:string;override;
166
 
{$ifdef GDB}
167
 
          function  numberstring:string;override;
168
 
          function  stabstring : pchar;override;
169
 
          procedure concatstabto(asmlist : taasmoutput);override;
170
 
{$endif GDB}
171
 
       end;
172
 
 
173
 
       tforwarddef = class(tstoreddef)
174
 
          tosymname : pstring;
175
 
          forwardpos : tfileposinfo;
176
 
          constructor create(const s:string;const pos : tfileposinfo);
177
 
          destructor destroy;override;
178
 
          function  gettypename:string;override;
179
 
       end;
180
 
 
181
 
       terrordef = class(tstoreddef)
182
 
          constructor create;
183
 
          function  gettypename:string;override;
184
 
          function  getmangledparaname : string;override;
185
 
          { debug }
186
 
{$ifdef GDB}
187
 
          function  stabstring : pchar;override;
188
 
          procedure concatstabto(asmlist : taasmoutput);override;
189
 
{$endif GDB}
190
 
       end;
191
 
 
192
 
       { tpointerdef and tclassrefdef should get a common
193
 
         base class, but I derived tclassrefdef from tpointerdef
194
 
         to avoid problems with bugs (FK)
195
 
       }
196
 
 
197
 
       tpointerdef = class(tstoreddef)
198
 
          pointertype : ttype;
199
 
          is_far : boolean;
200
 
          constructor create(const tt : ttype);
201
 
          constructor createfar(const tt : ttype);
202
 
          constructor ppuload(ppufile:tcompilerppufile);
203
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
204
 
          procedure buildderef;override;
205
 
          procedure deref;override;
206
 
          function  gettypename:string;override;
207
 
          { debug }
208
 
{$ifdef GDB}
209
 
          function  stabstring : pchar;override;
210
 
          procedure concatstabto(asmlist : taasmoutput);override;
211
 
{$endif GDB}
212
 
       end;
213
 
 
214
 
       Trecord_stabgen_state=record
215
 
          stabstring:Pchar;
216
 
          stabsize,staballoc,recoffset:integer;
217
 
       end;
218
 
 
219
 
       tabstractrecorddef= class(tstoreddef)
220
 
       private
221
 
          Count         : integer;
222
 
          FRTTIType     : trttitype;
223
 
{$ifdef GDB}
224
 
          procedure field_addname(p:Tnamedindexitem;arg:pointer);
225
 
          procedure field_concatstabto(p:Tnamedindexitem;arg:pointer);
226
 
{$endif}
227
 
          procedure count_field_rtti(sym : tnamedindexitem;arg:pointer);
228
 
          procedure write_field_rtti(sym : tnamedindexitem;arg:pointer);
229
 
          procedure generate_field_rtti(sym : tnamedindexitem;arg:pointer);
230
 
       public
231
 
          symtable : tsymtable;
232
 
          function  getsymtable(t:tgetsymtable):tsymtable;override;
233
 
       end;
234
 
 
235
 
       trecorddef = class(tabstractrecorddef)
236
 
       public
237
 
          isunion       : boolean;
238
 
          constructor create(p : tsymtable);
239
 
          constructor ppuload(ppufile:tcompilerppufile);
240
 
          destructor destroy;override;
241
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
242
 
          procedure buildderef;override;
243
 
          procedure deref;override;
244
 
          function  size:longint;override;
245
 
          function  alignment : longint;override;
246
 
          function  gettypename:string;override;
247
 
          { debug }
248
 
{$ifdef GDB}
249
 
          function  stabstring : pchar;override;
250
 
          procedure concatstabto(asmlist:taasmoutput);override;
251
 
{$endif GDB}
252
 
          function  needs_inittable : boolean;override;
253
 
          { rtti }
254
 
          procedure write_child_rtti_data(rt:trttitype);override;
255
 
          procedure write_rtti_data(rt:trttitype);override;
256
 
       end;
257
 
 
258
 
       tprocdef = class;
259
 
 
260
 
       timplementedinterfaces = class;
261
 
 
262
 
       tobjectdef = class(tabstractrecorddef)
263
 
       private
264
 
{$ifdef GDB}
265
 
          procedure proc_addname(p :tnamedindexitem;arg:pointer);
266
 
          procedure proc_concatstabto(p :tnamedindexitem;arg:pointer);
267
 
{$endif GDB}
268
 
          procedure count_published_properties(sym:tnamedindexitem;arg:pointer);
269
 
          procedure write_property_info(sym : tnamedindexitem;arg:pointer);
270
 
          procedure generate_published_child_rtti(sym : tnamedindexitem;arg:pointer);
271
 
          procedure count_published_fields(sym:tnamedindexitem;arg:pointer);
272
 
          procedure writefields(sym:tnamedindexitem;arg:pointer);
273
 
       public
274
 
          childof  : tobjectdef;
275
 
          childofderef  : tderef;
276
 
          objname,
277
 
          objrealname   : pstring;
278
 
          objectoptions : tobjectoptions;
279
 
          { to be able to have a variable vmt position }
280
 
          { and no vmt field for objects without virtuals }
281
 
          vmt_offset : longint;
282
 
{$ifdef GDB}
283
 
          writing_class_record_stab : boolean;
284
 
{$endif GDB}
285
 
          objecttype : tobjectdeftype;
286
 
          iidguid: pguid;
287
 
          iidstr: pstring;
288
 
          lastvtableindex: longint;
289
 
          { store implemented interfaces defs and name mappings }
290
 
          implementedinterfaces: timplementedinterfaces;
291
 
          constructor create(ot : tobjectdeftype;const n : string;c : tobjectdef);
292
 
          constructor ppuload(ppufile:tcompilerppufile);
293
 
          destructor  destroy;override;
294
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
295
 
          function gettypename:string;override;
296
 
          procedure buildderef;override;
297
 
          procedure deref;override;
298
 
          function  getparentdef:tdef;override;
299
 
          function  size : longint;override;
300
 
          function  alignment:longint;override;
301
 
          function  vmtmethodoffset(index:longint):longint;
302
 
          function  members_need_inittable : boolean;
303
 
          { this should be called when this class implements an interface }
304
 
          procedure prepareguid;
305
 
          function  is_publishable : boolean;override;
306
 
          function  needs_inittable : boolean;override;
307
 
          function  vmt_mangledname : string;
308
 
          function  rtti_name : string;
309
 
          procedure check_forwards;
310
 
          function  is_related(d : tobjectdef) : boolean;
311
 
          function  next_free_name_index : longint;
312
 
          procedure insertvmt;
313
 
          procedure set_parent(c : tobjectdef);
314
 
          function searchdestructor : tprocdef;
315
 
          { debug }
316
 
{$ifdef GDB}
317
 
          function  stabstring : pchar;override;
318
 
          procedure set_globalnb;override;
319
 
          function  classnumberstring : string;
320
 
          procedure concatstabto(asmlist : taasmoutput);override;
321
 
          function  allstabstring : pchar;override;
322
 
{$endif GDB}
323
 
          { rtti }
324
 
          procedure write_child_rtti_data(rt:trttitype);override;
325
 
          procedure write_rtti_data(rt:trttitype);override;
326
 
          function generate_field_table : tasmlabel;
327
 
       end;
328
 
 
329
 
       timplementedinterfaces = class
330
 
          constructor create;
331
 
          destructor  destroy; override;
332
 
 
333
 
          function  count: longint;
334
 
          function  interfaces(intfindex: longint): tobjectdef;
335
 
          function  interfacesderef(intfindex: longint): tderef;
336
 
          function  ioffsets(intfindex: longint): plongint;
337
 
          function  searchintf(def: tdef): longint;
338
 
          procedure addintf(def: tdef);
339
 
 
340
 
          procedure buildderef;
341
 
          procedure deref;
342
 
          { add interface reference loaded from ppu }
343
 
          procedure addintf_deref(const d:tderef);
344
 
 
345
 
          procedure clearmappings;
346
 
          procedure addmappings(intfindex: longint; const name, newname: string);
347
 
          function  getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
348
 
 
349
 
          procedure clearimplprocs;
350
 
          procedure addimplproc(intfindex: longint; procdef: tprocdef);
351
 
          function  implproccount(intfindex: longint): longint;
352
 
          function  implprocs(intfindex: longint; procindex: longint): tprocdef;
353
 
          function  isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
354
 
 
355
 
       private
356
 
          finterfaces: tindexarray;
357
 
          procedure checkindex(intfindex: longint);
358
 
       end;
359
 
 
360
 
 
361
 
       tclassrefdef = class(tpointerdef)
362
 
          constructor create(const t:ttype);
363
 
          constructor ppuload(ppufile:tcompilerppufile);
364
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
365
 
          function gettypename:string;override;
366
 
          { debug }
367
 
{$ifdef GDB}
368
 
          function stabstring : pchar;override;
369
 
{$endif GDB}
370
 
       end;
371
 
 
372
 
       tarraydef = class(tstoreddef)
373
 
          lowrange,
374
 
          highrange  : longint;
375
 
          rangetype  : ttype;
376
 
          IsConvertedPointer,
377
 
          IsDynamicArray,
378
 
          IsVariant,
379
 
          IsConstructor,
380
 
          IsArrayOfConst : boolean;
381
 
       protected
382
 
          _elementtype : ttype;
383
 
       public
384
 
          function elesize : longint;
385
 
          constructor create_from_pointer(const elemt : ttype);
386
 
          constructor create(l,h : longint;const t : ttype);
387
 
          constructor ppuload(ppufile:tcompilerppufile);
388
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
389
 
          function  gettypename:string;override;
390
 
          function  getmangledparaname : string;override;
391
 
          procedure setelementtype(t: ttype);
392
 
{$ifdef GDB}
393
 
          function  stabstring : pchar;override;
394
 
          procedure concatstabto(asmlist : taasmoutput);override;
395
 
{$endif GDB}
396
 
          procedure buildderef;override;
397
 
          procedure deref;override;
398
 
          function size : longint;override;
399
 
          function alignment : longint;override;
400
 
          { returns the label of the range check string }
401
 
          function needs_inittable : boolean;override;
402
 
          procedure write_child_rtti_data(rt:trttitype);override;
403
 
          procedure write_rtti_data(rt:trttitype);override;
404
 
          property elementtype : ttype Read _ElementType;
405
 
       end;
406
 
 
407
 
       torddef = class(tstoreddef)
408
 
          low,high : TConstExprInt;
409
 
          typ      : tbasetype;
410
 
          constructor create(t : tbasetype;v,b : TConstExprInt);
411
 
          constructor ppuload(ppufile:tcompilerppufile);
412
 
          function getcopy : tstoreddef;override;
413
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
414
 
          function  is_publishable : boolean;override;
415
 
          function  gettypename:string;override;
416
 
          procedure setsize;
417
 
          { debug }
418
 
{$ifdef GDB}
419
 
          function  stabstring : pchar;override;
420
 
{$endif GDB}
421
 
          { rtti }
422
 
          procedure write_rtti_data(rt:trttitype);override;
423
 
       end;
424
 
 
425
 
       tfloatdef = class(tstoreddef)
426
 
          typ : tfloattype;
427
 
          constructor create(t : tfloattype);
428
 
          constructor ppuload(ppufile:tcompilerppufile);
429
 
          function getcopy : tstoreddef;override;
430
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
431
 
          function  gettypename:string;override;
432
 
          function  is_publishable : boolean;override;
433
 
          procedure setsize;
434
 
          { debug }
435
 
{$ifdef GDB}
436
 
          function stabstring : pchar;override;
437
 
          procedure concatstabto(asmlist:taasmoutput);override;
438
 
{$endif GDB}
439
 
          { rtti }
440
 
          procedure write_rtti_data(rt:trttitype);override;
441
 
       end;
442
 
 
443
 
       tabstractprocdef = class(tstoreddef)
444
 
          { saves a definition to the return type }
445
 
          rettype         : ttype;
446
 
          parast          : tsymtable;
447
 
          para            : tlinkedlist;
448
 
          proctypeoption  : tproctypeoption;
449
 
          proccalloption  : tproccalloption;
450
 
          procoptions     : tprocoptions;
451
 
          requiredargarea : aword;
452
 
          maxparacount,
453
 
          minparacount    : byte;
454
 
{$ifdef i386}
455
 
          fpu_used        : byte;    { how many stack fpu must be empty }
456
 
{$endif i386}
457
 
          funcret_paraloc : array[tcallercallee] of tparalocation;
458
 
          has_paraloc_info : boolean; { paraloc info is available }
459
 
          constructor create(level:byte);
460
 
          constructor ppuload(ppufile:tcompilerppufile);
461
 
          destructor destroy;override;
462
 
          procedure  ppuwrite(ppufile:tcompilerppufile);override;
463
 
          procedure buildderef;override;
464
 
          procedure deref;override;
465
 
          procedure releasemem;
466
 
          function  concatpara(afterpara:tparaitem;const tt:ttype;sym : tsym;defval:tsym;vhidden:boolean):tparaitem;
467
 
          function  insertpara(const tt:ttype;sym : tsym;defval:tsym;vhidden:boolean):tparaitem;
468
 
          procedure removepara(currpara:tparaitem);
469
 
          function  typename_paras(showhidden:boolean): string;
470
 
          procedure test_if_fpu_result;
471
 
          function  is_methodpointer:boolean;virtual;
472
 
          function  is_addressonly:boolean;virtual;
473
 
          { debug }
474
 
{$ifdef GDB}
475
 
          function  stabstring : pchar;override;
476
 
{$endif GDB}
477
 
       end;
478
 
 
479
 
       tprocvardef = class(tabstractprocdef)
480
 
          constructor create(level:byte);
481
 
          constructor ppuload(ppufile:tcompilerppufile);
482
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
483
 
          procedure buildderef;override;
484
 
          procedure deref;override;
485
 
          function  getsymtable(t:tgetsymtable):tsymtable;override;
486
 
          function  size : longint;override;
487
 
          function  gettypename:string;override;
488
 
          function  is_publishable : boolean;override;
489
 
          function  is_methodpointer:boolean;override;
490
 
          function  is_addressonly:boolean;override;
491
 
          { debug }
492
 
{$ifdef GDB}
493
 
          function stabstring : pchar;override;
494
 
          procedure concatstabto(asmlist:taasmoutput);override;
495
 
{$endif GDB}
496
 
          { rtti }
497
 
          procedure write_rtti_data(rt:trttitype);override;
498
 
       end;
499
 
 
500
 
       tmessageinf = record
501
 
         case integer of
502
 
           0 : (str : pchar);
503
 
           1 : (i : longint);
504
 
       end;
505
 
 
506
 
       tinlininginfo = record
507
 
         { node tree }
508
 
          code : tnode;
509
 
          flags : tprocinfoflags;
510
 
       end;
511
 
       pinlininginfo = ^tinlininginfo;
512
 
 
513
 
 
514
 
{$ifdef oldregvars}
515
 
       { register variables }
516
 
       pregvarinfo = ^tregvarinfo;
517
 
       tregvarinfo = record
518
 
          regvars : array[1..maxvarregs] of tsym;
519
 
          regvars_para : array[1..maxvarregs] of boolean;
520
 
          regvars_refs : array[1..maxvarregs] of longint;
521
 
 
522
 
          fpuregvars : array[1..maxfpuvarregs] of tsym;
523
 
          fpuregvars_para : array[1..maxfpuvarregs] of boolean;
524
 
          fpuregvars_refs : array[1..maxfpuvarregs] of longint;
525
 
       end;
526
 
{$endif oldregvars}
527
 
 
528
 
       tprocdef = class(tabstractprocdef)
529
 
       private
530
 
          _mangledname : pstring;
531
 
{$ifdef GDB}
532
 
          isstabwritten : boolean;
533
 
{$endif GDB}
534
 
       public
535
 
          extnumber      : word;
536
 
          overloadnumber : word;
537
 
          messageinf : tmessageinf;
538
 
{$ifndef EXTDEBUG}
539
 
          { where is this function defined and what were the symbol
540
 
            flags, needed here because there
541
 
            is only one symbol for all overloaded functions
542
 
            EXTDEBUG has fileinfo in tdef (PFV) }
543
 
          fileinfo : tfileposinfo;
544
 
{$endif}
545
 
          symoptions : tsymoptions;
546
 
          { symbol owning this definition }
547
 
          procsym : tsym;
548
 
          procsymderef : tderef;
549
 
          { alias names }
550
 
          aliasnames : tstringlist;
551
 
          { symtables }
552
 
          localst : tsymtable;
553
 
          funcretsym : tsym;
554
 
          funcretsymderef : tderef;
555
 
          { browser info }
556
 
          lastref,
557
 
          defref,
558
 
          lastwritten : tref;
559
 
          refcount : longint;
560
 
          _class : tobjectdef;
561
 
          _classderef : tderef;
562
 
{$ifdef powerpc}
563
 
          { library symbol for AmigaOS/MorphOS }
564
 
          libsym : tsym;
565
 
          libsymderef : tderef;
566
 
{$endif powerpc}
567
 
          { name of the result variable to insert in the localsymtable }
568
 
          resultname : stringid;
569
 
          { true, if the procedure is only declared
570
 
            (forward procedure) }
571
 
          forwarddef,
572
 
          { true if the procedure is declared in the interface }
573
 
          interfacedef : boolean;
574
 
          { true if the procedure has a forward declaration }
575
 
          hasforward : boolean;
576
 
          { check the problems of manglednames }
577
 
          has_mangledname : boolean;
578
 
          { info for inlining the subroutine, if this pointer is nil,
579
 
            the procedure can't be inlined }
580
 
          inlininginfo : pinlininginfo;
581
 
{$ifdef oldregvars}
582
 
          regvarinfo: pregvarinfo;
583
 
{$endif oldregvars}
584
 
          constructor create(level:byte);
585
 
          constructor ppuload(ppufile:tcompilerppufile);
586
 
          destructor  destroy;override;
587
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
588
 
          procedure buildderef;override;
589
 
          procedure buildderefimpl;override;
590
 
          procedure deref;override;
591
 
          procedure derefimpl;override;
592
 
          function  getsymtable(t:tgetsymtable):tsymtable;override;
593
 
          function gettypename : string;override;
594
 
          function  mangledname : string;
595
 
          procedure setmangledname(const s : string);
596
 
          procedure load_references(ppufile:tcompilerppufile;locals:boolean);
597
 
          function  write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
598
 
          { inserts the local symbol table, if this is not
599
 
            no local symbol table is built. Should be called only
600
 
            when we are sure that a local symbol table will be required.
601
 
          }
602
 
          procedure insert_localst;
603
 
          function  fullprocname(showhidden:boolean):string;
604
 
          function  cplusplusmangledname : string;
605
 
          function  is_methodpointer:boolean;override;
606
 
          function  is_addressonly:boolean;override;
607
 
          function  is_visible_for_object(currobjdef:tobjectdef):boolean;
608
 
          { debug }
609
 
{$ifdef GDB}
610
 
          function  numberstring:string;override;
611
 
          function  stabstring : pchar;override;
612
 
          procedure concatstabto(asmlist : taasmoutput);override;
613
 
{$endif GDB}
614
 
       end;
615
 
 
616
 
       { single linked list of overloaded procs }
617
 
       pprocdeflist = ^tprocdeflist;
618
 
       tprocdeflist = record
619
 
         def  : tprocdef;
620
 
         defderef : tderef;
621
 
         own  : boolean;
622
 
         next : pprocdeflist;
623
 
       end;
624
 
 
625
 
       tstringdef = class(tstoreddef)
626
 
          string_typ : tstringtype;
627
 
          len        : longint;
628
 
          constructor createshort(l : byte);
629
 
          constructor loadshort(ppufile:tcompilerppufile);
630
 
          constructor createlong(l : longint);
631
 
          constructor loadlong(ppufile:tcompilerppufile);
632
 
       {$ifdef ansistring_bits}
633
 
          constructor createansi(l:longint;bits:Tstringbits);
634
 
          constructor loadansi(ppufile:tcompilerppufile;bits:Tstringbits);
635
 
       {$else}
636
 
          constructor createansi(l : longint);
637
 
          constructor loadansi(ppufile:tcompilerppufile);
638
 
       {$endif}
639
 
          constructor createwide(l : longint);
640
 
          constructor loadwide(ppufile:tcompilerppufile);
641
 
          function getcopy : tstoreddef;override;
642
 
          function  stringtypname:string;
643
 
          function  size : longint;override;
644
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
645
 
          function  gettypename:string;override;
646
 
          function  getmangledparaname:string;override;
647
 
          function  is_publishable : boolean;override;
648
 
          { debug }
649
 
{$ifdef GDB}
650
 
          function  stabstring : pchar;override;
651
 
          procedure concatstabto(asmlist : taasmoutput);override;
652
 
{$endif GDB}
653
 
          { init/final }
654
 
          function  needs_inittable : boolean;override;
655
 
          { rtti }
656
 
          procedure write_rtti_data(rt:trttitype);override;
657
 
       end;
658
 
 
659
 
       tenumdef = class(tstoreddef)
660
 
          minval,
661
 
          maxval    : longint;
662
 
          has_jumps : boolean;
663
 
          firstenum : tsym;  {tenumsym}
664
 
          basedef   : tenumdef;
665
 
          basedefderef : tderef;
666
 
          constructor create;
667
 
          constructor create_subrange(_basedef:tenumdef;_min,_max:longint);
668
 
          constructor ppuload(ppufile:tcompilerppufile);
669
 
          destructor destroy;override;
670
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
671
 
          procedure buildderef;override;
672
 
          procedure deref;override;
673
 
          function  gettypename:string;override;
674
 
          function  is_publishable : boolean;override;
675
 
          procedure calcsavesize;
676
 
          procedure setmax(_max:longint);
677
 
          procedure setmin(_min:longint);
678
 
          function  min:longint;
679
 
          function  max:longint;
680
 
          { debug }
681
 
{$ifdef GDB}
682
 
          function stabstring : pchar;override;
683
 
{$endif GDB}
684
 
          { rtti }
685
 
          procedure write_rtti_data(rt:trttitype);override;
686
 
          procedure write_child_rtti_data(rt:trttitype);override;
687
 
       private
688
 
          procedure correct_owner_symtable;
689
 
       end;
690
 
 
691
 
       tsetdef = class(tstoreddef)
692
 
          elementtype : ttype;
693
 
          settype : tsettype;
694
 
          constructor create(const t:ttype;high : longint);
695
 
          constructor ppuload(ppufile:tcompilerppufile);
696
 
          destructor  destroy;override;
697
 
          procedure ppuwrite(ppufile:tcompilerppufile);override;
698
 
          procedure buildderef;override;
699
 
          procedure deref;override;
700
 
          function  gettypename:string;override;
701
 
          function  is_publishable : boolean;override;
702
 
          { debug }
703
 
{$ifdef GDB}
704
 
          function  stabstring : pchar;override;
705
 
          procedure concatstabto(asmlist : taasmoutput);override;
706
 
{$endif GDB}
707
 
          { rtti }
708
 
          procedure write_rtti_data(rt:trttitype);override;
709
 
          procedure write_child_rtti_data(rt:trttitype);override;
710
 
       end;
711
 
 
712
 
       Tdefmatch=(dm_exact,dm_equal,dm_convertl1);
713
 
 
714
 
    var
715
 
       aktobjectdef : tobjectdef;  { used for private functions check !! }
716
 
{$ifdef GDB}
717
 
       writing_def_stabs : boolean;
718
 
       { for STAB debugging }
719
 
       globaltypecount  : word;
720
 
       pglobaltypecount : pword;
721
 
{$endif GDB}
722
 
 
723
 
    { default types }
724
 
       generrortype,              { error in definition }
725
 
       voidpointertype,           { pointer for Void-Pointerdef }
726
 
       charpointertype,           { pointer for Char-Pointerdef }
727
 
       voidfarpointertype,
728
 
       cformaltype,               { unique formal definition }
729
 
       voidtype,                  { Void (procedure) }
730
 
       cchartype,                 { Char }
731
 
       cwidechartype,             { WideChar }
732
 
       booltype,                  { boolean type }
733
 
       u8inttype,                 { 8-Bit unsigned integer }
734
 
       s8inttype,                 { 8-Bit signed integer }
735
 
       u16inttype,                { 16-Bit unsigned integer }
736
 
       s16inttype,                { 16-Bit signed integer }
737
 
       u32inttype,                { 32-Bit unsigned integer }
738
 
       s32inttype,                { 32-Bit signed integer }
739
 
       u64inttype,                { 64-bit unsigned integer }
740
 
       s64inttype,                { 64-bit signed integer }
741
 
       s32floattype,              { pointer for realconstn }
742
 
       s64floattype,              { pointer for realconstn }
743
 
       s80floattype,              { pointer to type of temp. floats }
744
 
       s64currencytype,           { pointer to a currency type }
745
 
       s32fixedtype,              { pointer to type of temp. fixed }
746
 
       cshortstringtype,          { pointer to type of short string const   }
747
 
       clongstringtype,           { pointer to type of long string const   }
748
 
{$ifdef ansistring_bits}
749
 
       cansistringtype16,         { pointer to type of ansi string const  }
750
 
       cansistringtype32,         { pointer to type of ansi string const  }
751
 
       cansistringtype64,         { pointer to type of ansi string const  }
752
 
{$else}
753
 
       cansistringtype,           { pointer to type of ansi string const  }
754
 
{$endif}
755
 
       cwidestringtype,           { pointer to type of wide string const  }
756
 
       openshortstringtype,       { pointer to type of an open shortstring,
757
 
                                    needed for readln() }
758
 
       openchararraytype,         { pointer to type of an open array of char,
759
 
                                    needed for readln() }
760
 
       cfiletype,                 { get the same definition for all file }
761
 
                                  { used for stabs }
762
 
       methodpointertype,         { typecasting of methodpointers to extract self }
763
 
       { we use only one variant def for every variant class }
764
 
       cvarianttype,
765
 
       colevarianttype,
766
 
       ordpointertype,
767
 
       { default integer type s32inttype on 32 bit systems, s64bittype on 64 bit systems }
768
 
       sinttype,
769
 
       uinttype,
770
 
       { unsigned ord type with the same size as a pointer }
771
 
       ptrinttype,
772
 
       { several types to simulate more or less C++ objects for GDB }
773
 
       vmttype,
774
 
       vmtarraytype,
775
 
       pvmttype      : ttype;     { type of classrefs, used for stabs }
776
 
 
777
 
       { pointer to the anchestor of all classes }
778
 
       class_tobject : tobjectdef;
779
 
       { pointer to the ancestor of all COM interfaces }
780
 
       interface_iunknown : tobjectdef;
781
 
       { pointer to the TGUID type
782
 
         of all interfaces         }
783
 
       rec_tguid : trecorddef;
784
 
 
785
 
    const
786
 
{$ifdef i386}
787
 
       pbestrealtype : ^ttype = @s80floattype;
788
 
{$endif}
789
 
{$ifdef x86_64}
790
 
       pbestrealtype : ^ttype = @s80floattype;
791
 
{$endif}
792
 
{$ifdef m68k}
793
 
       pbestrealtype : ^ttype = @s64floattype;
794
 
{$endif}
795
 
{$ifdef alpha}
796
 
       pbestrealtype : ^ttype = @s64floattype;
797
 
{$endif}
798
 
{$ifdef powerpc}
799
 
       pbestrealtype : ^ttype = @s64floattype;
800
 
{$endif}
801
 
{$ifdef ia64}
802
 
       pbestrealtype : ^ttype = @s64floattype;
803
 
{$endif}
804
 
{$ifdef SPARC}
805
 
       pbestrealtype : ^ttype = @s64floattype;
806
 
{$endif SPARC}
807
 
{$ifdef vis}
808
 
       pbestrealtype : ^ttype = @s64floattype;
809
 
{$endif vis}
810
 
{$ifdef ARM}
811
 
       pbestrealtype : ^ttype = @s64floattype;
812
 
{$endif ARM}
813
 
 
814
 
    function reverseparaitems(p: tparaitem): tparaitem;
815
 
    function make_mangledname(const typeprefix:string;st:tsymtable;const suffix:string):string;
816
 
 
817
 
    { should be in the types unit, but the types unit uses the node stuff :( }
818
 
    function is_interfacecom(def: tdef): boolean;
819
 
    function is_interfacecorba(def: tdef): boolean;
820
 
    function is_interface(def: tdef): boolean;
821
 
    function is_object(def: tdef): boolean;
822
 
    function is_class(def: tdef): boolean;
823
 
    function is_cppclass(def: tdef): boolean;
824
 
    function is_class_or_interface(def: tdef): boolean;
825
 
 
826
 
 
827
 
implementation
828
 
 
829
 
    uses
830
 
{$ifdef Delphi}
831
 
       sysutils,
832
 
{$else Delphi}
833
 
       strings,
834
 
{$endif Delphi}
835
 
       { global }
836
 
       verbose,
837
 
       { target }
838
 
       systems,aasmcpu,paramgr,
839
 
       { symtable }
840
 
       symsym,symtable,symutil,defutil,
841
 
       { module }
842
 
{$ifdef GDB}
843
 
       gdb,
844
 
{$endif GDB}
845
 
       fmodule,
846
 
       { other }
847
 
       gendef
848
 
       ;
849
 
 
850
 
 
851
 
{****************************************************************************
852
 
                                  Helpers
853
 
****************************************************************************}
854
 
 
855
 
    function reverseparaitems(p: tparaitem): tparaitem;
856
 
      var
857
 
        hp1, hp2: tparaitem;
858
 
      begin
859
 
        hp1:=nil;
860
 
        while assigned(p) do
861
 
          begin
862
 
             { pull out }
863
 
             hp2:=p;
864
 
             p:=tparaitem(p.next);
865
 
             { pull in }
866
 
             hp2.next:=hp1;
867
 
             hp1:=hp2;
868
 
          end;
869
 
        reverseparaitems:=hp1;
870
 
      end;
871
 
 
872
 
 
873
 
    function make_mangledname(const typeprefix:string;st:tsymtable;const suffix:string):string;
874
 
      var
875
 
        s,
876
 
        prefix : string;
877
 
      begin
878
 
        prefix:='';
879
 
        if not assigned(st) then
880
 
         internalerror(200204212);
881
 
        { sub procedures }
882
 
        while (st.symtabletype=localsymtable) do
883
 
         begin
884
 
           if st.defowner.deftype<>procdef then
885
 
            internalerror(200204173);
886
 
           s:=tprocdef(st.defowner).procsym.name;
887
 
           if tprocdef(st.defowner).overloadnumber>0 then
888
 
            s:=s+'$'+tostr(tprocdef(st.defowner).overloadnumber);
889
 
           prefix:=s+'$'+prefix;
890
 
           st:=st.defowner.owner;
891
 
         end;
892
 
        { object/classes symtable }
893
 
        if (st.symtabletype=objectsymtable) then
894
 
         begin
895
 
           if st.defowner.deftype<>objectdef then
896
 
            internalerror(200204174);
897
 
           prefix:=tobjectdef(st.defowner).objname^+'_$_'+prefix;
898
 
           st:=st.defowner.owner;
899
 
         end;
900
 
        { symtable must now be static or global }
901
 
        if not(st.symtabletype in [staticsymtable,globalsymtable]) then
902
 
         internalerror(200204175);
903
 
        result:='';
904
 
        if typeprefix<>'' then
905
 
          result:=result+typeprefix+'_';
906
 
        { Add P$ for program, which can have the same name as
907
 
          a unit }
908
 
        if (tsymtable(main_module.localsymtable)=st) and
909
 
           (not main_module.is_unit) then
910
 
          result:=result+'P$'+st.name^
911
 
        else
912
 
          result:=result+st.name^;
913
 
        if prefix<>'' then
914
 
          result:=result+'_'+prefix;
915
 
        if suffix<>'' then
916
 
          result:=result+'_'+suffix;
917
 
        { the Darwin assembler assumes that all symbols starting with 'L' are local }
918
 
        if (target_info.system = system_powerpc_darwin) and
919
 
           (result[1] = 'L') then
920
 
          result := '_' + result;
921
 
      end;
922
 
 
923
 
 
924
 
{****************************************************************************
925
 
                     TDEF (base class for definitions)
926
 
****************************************************************************}
927
 
 
928
 
    constructor tstoreddef.create;
929
 
      begin
930
 
         inherited create;
931
 
         savesize := 0;
932
 
{$ifdef EXTDEBUG}
933
 
         fileinfo := aktfilepos;
934
 
{$endif}
935
 
         if registerdef then
936
 
           symtablestack.registerdef(self);
937
 
{$ifdef GDB}
938
 
         stab_state:=stab_state_unused;
939
 
         globalnb := 0;
940
 
{$endif GDB}
941
 
         fillchar(localrttilab,sizeof(localrttilab),0);
942
 
      end;
943
 
 
944
 
 
945
 
    constructor tstoreddef.ppuloaddef(ppufile:tcompilerppufile);
946
 
      begin
947
 
         inherited create;
948
 
{$ifdef EXTDEBUG}
949
 
         fillchar(fileinfo,sizeof(fileinfo),0);
950
 
{$endif}
951
 
{$ifdef GDB}
952
 
         stab_state:=stab_state_unused;
953
 
         globalnb := 0;
954
 
{$endif GDB}
955
 
         fillchar(localrttilab,sizeof(localrttilab),0);
956
 
      { load }
957
 
         indexnr:=ppufile.getword;
958
 
         ppufile.getderef(typesymderef);
959
 
         ppufile.getsmallset(defoptions);
960
 
         if df_has_rttitable in defoptions then
961
 
          ppufile.getderef(rttitablesymderef);
962
 
         if df_has_inittable in defoptions then
963
 
          ppufile.getderef(inittablesymderef);
964
 
      end;
965
 
 
966
 
 
967
 
    procedure Tstoreddef.reset;
968
 
      begin
969
 
{$ifdef GDB}
970
 
        stab_state:=stab_state_unused;
971
 
{$endif GDB}
972
 
        if assigned(rttitablesym) then
973
 
          trttisym(rttitablesym).lab := nil;
974
 
        if assigned(inittablesym) then
975
 
          trttisym(inittablesym).lab := nil;
976
 
        localrttilab[initrtti]:=nil;
977
 
        localrttilab[fullrtti]:=nil;
978
 
      end;
979
 
 
980
 
 
981
 
    function tstoreddef.getcopy : tstoreddef;
982
 
      begin
983
 
        Message(sym_e_cant_create_unique_type);
984
 
        getcopy:=terrordef.create;
985
 
      end;
986
 
 
987
 
 
988
 
    procedure tstoreddef.ppuwritedef(ppufile:tcompilerppufile);
989
 
      begin
990
 
        ppufile.putword(indexnr);
991
 
        ppufile.putderef(typesymderef);
992
 
        ppufile.putsmallset(defoptions);
993
 
        if df_has_rttitable in defoptions then
994
 
         ppufile.putderef(rttitablesymderef);
995
 
        if df_has_inittable in defoptions then
996
 
         ppufile.putderef(inittablesymderef);
997
 
{$ifdef GDB}
998
 
        if globalnb=0 then
999
 
          begin
1000
 
            if (cs_gdb_dbx in aktglobalswitches) and
1001
 
               assigned(owner) then
1002
 
              globalnb := owner.getnewtypecount
1003
 
            else
1004
 
              set_globalnb;
1005
 
          end;
1006
 
{$endif GDB}
1007
 
      end;
1008
 
 
1009
 
 
1010
 
    procedure tstoreddef.buildderef;
1011
 
      begin
1012
 
        typesymderef.build(typesym);
1013
 
        rttitablesymderef.build(rttitablesym);
1014
 
        inittablesymderef.build(inittablesym);
1015
 
      end;
1016
 
 
1017
 
 
1018
 
    procedure tstoreddef.buildderefimpl;
1019
 
      begin
1020
 
      end;
1021
 
 
1022
 
 
1023
 
    procedure tstoreddef.deref;
1024
 
      begin
1025
 
        typesym:=ttypesym(typesymderef.resolve);
1026
 
        if df_has_rttitable in defoptions then
1027
 
          rttitablesym:=trttisym(rttitablesymderef.resolve);
1028
 
        if df_has_inittable in defoptions then
1029
 
          inittablesym:=trttisym(inittablesymderef.resolve);
1030
 
      end;
1031
 
 
1032
 
 
1033
 
    procedure tstoreddef.derefimpl;
1034
 
      begin
1035
 
      end;
1036
 
 
1037
 
 
1038
 
    function tstoreddef.size : longint;
1039
 
      begin
1040
 
         size:=savesize;
1041
 
      end;
1042
 
 
1043
 
 
1044
 
    function tstoreddef.alignment : longint;
1045
 
      begin
1046
 
         { natural alignment by default }
1047
 
         alignment:=size_2_align(savesize);
1048
 
      end;
1049
 
 
1050
 
 
1051
 
{$ifdef GDB}
1052
 
    procedure tstoreddef.set_globalnb;
1053
 
      begin
1054
 
        globalnb:=PGlobalTypeCount^;
1055
 
        inc(PglobalTypeCount^);
1056
 
      end;
1057
 
 
1058
 
 
1059
 
    function Tstoreddef.get_var_value(const s:string):string;
1060
 
      begin
1061
 
        if s='numberstring' then
1062
 
          get_var_value:=numberstring
1063
 
        else if s='sym_name' then
1064
 
          if assigned(typesym) then
1065
 
             get_var_value:=Ttypesym(typesym).name
1066
 
          else
1067
 
             get_var_value:=' '
1068
 
        else if s='N_LSYM' then
1069
 
          get_var_value:=tostr(N_LSYM)
1070
 
        else if s='savesize' then
1071
 
          get_var_value:=tostr(savesize);
1072
 
      end;
1073
 
 
1074
 
 
1075
 
    function Tstoreddef.stabstr_evaluate(const s:string;const vars:array of string):Pchar;
1076
 
      begin
1077
 
        stabstr_evaluate:=string_evaluate(s,@get_var_value,vars);
1078
 
      end;
1079
 
 
1080
 
 
1081
 
    function tstoreddef.stabstring : pchar;
1082
 
      begin
1083
 
        stabstring:=stabstr_evaluate('t${numberstring};',[]);
1084
 
      end;
1085
 
 
1086
 
 
1087
 
    function tstoreddef.numberstring : string;
1088
 
      begin
1089
 
        { Stab must already be written, or we must be busy writing it }
1090
 
        if writing_def_stabs and
1091
 
           not(stab_state in [stab_state_writing,stab_state_written]) then
1092
 
          internalerror(200403091);
1093
 
        { Keep track of used stabs, this info is only usefull for stabs
1094
 
          referenced by the symbols. Definitions will always include all
1095
 
          required stabs }
1096
 
        if stab_state=stab_state_unused then
1097
 
          stab_state:=stab_state_used;
1098
 
        { Need a new number? }
1099
 
        if globalnb=0 then
1100
 
          begin
1101
 
            if (cs_gdb_dbx in aktglobalswitches) and
1102
 
               assigned(owner) then
1103
 
              globalnb := owner.getnewtypecount
1104
 
            else
1105
 
              set_globalnb;
1106
 
          end;
1107
 
        if (cs_gdb_dbx in aktglobalswitches) and
1108
 
           assigned(typesym) and
1109
 
           (ttypesym(typesym).owner.unitid<>0) then
1110
 
          result:='('+tostr(ttypesym(typesym).owner.unitid)+','+tostr(tstoreddef(ttypesym(typesym).restype.def).globalnb)+')'
1111
 
        else
1112
 
          result:=tostr(globalnb);
1113
 
      end;
1114
 
 
1115
 
 
1116
 
    function tstoreddef.allstabstring : pchar;
1117
 
      var
1118
 
        stabchar : string[2];
1119
 
        ss,st,su : pchar;
1120
 
      begin
1121
 
        ss := stabstring;
1122
 
        stabchar := 't';
1123
 
        if deftype in tagtypes then
1124
 
          stabchar := 'Tt';
1125
 
        { Here we maybe generate a type, so we have to use numberstring }
1126
 
        st:=stabstr_evaluate('"${sym_name}:$1$2=',[stabchar,numberstring]);
1127
 
        reallocmem(st,strlen(ss)+512);
1128
 
        { line info is set to 0 for all defs, because the def can be in an other
1129
 
          unit and then the linenumber is invalid in the current sourcefile }
1130
 
        su:=stabstr_evaluate('",${N_LSYM},0,0,0',[]);
1131
 
        strcopy(strecopy(strend(st),ss),su);
1132
 
        reallocmem(st,strlen(st)+1);
1133
 
        allstabstring:=st;
1134
 
        strdispose(ss);
1135
 
        strdispose(su);
1136
 
      end;
1137
 
 
1138
 
 
1139
 
    procedure tstoreddef.concatstabto(asmlist : taasmoutput);
1140
 
      var
1141
 
        stab_str : pchar;
1142
 
      begin
1143
 
        if (stab_state in [stab_state_writing,stab_state_written]) then
1144
 
          exit;
1145
 
        If cs_gdb_dbx in aktglobalswitches then
1146
 
          begin
1147
 
            { otherwise you get two of each def }
1148
 
            If assigned(typesym) then
1149
 
              begin
1150
 
                if (ttypesym(typesym).owner = nil) or
1151
 
                   ((ttypesym(typesym).owner.symtabletype = globalsymtable) and
1152
 
                    tglobalsymtable(ttypesym(typesym).owner).dbx_count_ok)  then
1153
 
                  begin
1154
 
                    {with DBX we get the definition from the other objects }
1155
 
                    stab_state := stab_state_written;
1156
 
                    exit;
1157
 
                  end;
1158
 
              end;
1159
 
          end;
1160
 
        { to avoid infinite loops }
1161
 
        stab_state := stab_state_writing;
1162
 
        stab_str := allstabstring;
1163
 
        asmList.concat(Tai_stabs.Create(stab_str));
1164
 
        stab_state := stab_state_written;
1165
 
      end;
1166
 
{$endif GDB}
1167
 
 
1168
 
 
1169
 
    procedure tstoreddef.write_rtti_name;
1170
 
      var
1171
 
         str : string;
1172
 
      begin
1173
 
         { name }
1174
 
         if assigned(typesym) then
1175
 
           begin
1176
 
              str:=ttypesym(typesym).realname;
1177
 
              rttiList.concat(Tai_string.Create(chr(length(str))+str));
1178
 
           end
1179
 
         else
1180
 
           rttiList.concat(Tai_string.Create(#0))
1181
 
      end;
1182
 
 
1183
 
 
1184
 
    procedure tstoreddef.write_rtti_data(rt:trttitype);
1185
 
      begin
1186
 
        rttilist.concat(tai_const.create_8bit(tkUnknown));
1187
 
        write_rtti_name;
1188
 
      end;
1189
 
 
1190
 
 
1191
 
    procedure tstoreddef.write_child_rtti_data(rt:trttitype);
1192
 
      begin
1193
 
      end;
1194
 
 
1195
 
 
1196
 
    function tstoreddef.get_rtti_label(rt:trttitype) : tasmsymbol;
1197
 
      begin
1198
 
         { try to reuse persistent rtti data }
1199
 
         if (rt=fullrtti) and (df_has_rttitable in defoptions) then
1200
 
          get_rtti_label:=trttisym(rttitablesym).get_label
1201
 
         else
1202
 
          if (rt=initrtti) and (df_has_inittable in defoptions) then
1203
 
           get_rtti_label:=trttisym(inittablesym).get_label
1204
 
         else
1205
 
          begin
1206
 
            if not assigned(localrttilab[rt]) then
1207
 
             begin
1208
 
               objectlibrary.getdatalabel(localrttilab[rt]);
1209
 
               write_child_rtti_data(rt);
1210
 
               if (cs_create_smart in aktmoduleswitches) then
1211
 
                rttiList.concat(Tai_cut.Create);
1212
 
               rttiList.concat(Tai_align.create(const_align(pointer_size)));
1213
 
               if (cs_create_smart in aktmoduleswitches) then
1214
 
                 rttiList.concat(Tai_symbol.Create_global(localrttilab[rt],0))
1215
 
               else
1216
 
                 rttiList.concat(Tai_symbol.Create(localrttilab[rt],0));
1217
 
               write_rtti_data(rt);
1218
 
               rttiList.concat(Tai_symbol_end.Create(localrttilab[rt]));
1219
 
             end;
1220
 
            get_rtti_label:=localrttilab[rt];
1221
 
          end;
1222
 
      end;
1223
 
 
1224
 
 
1225
 
    { returns true, if the definition can be published }
1226
 
    function tstoreddef.is_publishable : boolean;
1227
 
      begin
1228
 
         is_publishable:=false;
1229
 
      end;
1230
 
 
1231
 
 
1232
 
    { needs an init table }
1233
 
    function tstoreddef.needs_inittable : boolean;
1234
 
      begin
1235
 
         needs_inittable:=false;
1236
 
      end;
1237
 
 
1238
 
 
1239
 
   function tstoreddef.is_intregable : boolean;
1240
 
     begin
1241
 
        is_intregable:=false;
1242
 
        case deftype of
1243
 
          pointerdef,
1244
 
          enumdef:
1245
 
            is_intregable:=true;
1246
 
          procvardef :
1247
 
            is_intregable:=not(po_methodpointer in tprocvardef(self).procoptions);
1248
 
          orddef :
1249
 
            case torddef(self).typ of
1250
 
              bool8bit,bool16bit,bool32bit,
1251
 
              u8bit,u16bit,u32bit,
1252
 
              s8bit,s16bit,s32bit,
1253
 
              uchar, uwidechar:
1254
 
                is_intregable:=true;
1255
 
            end;
1256
 
          objectdef:
1257
 
            is_intregable:=is_class(self) or is_interface(self);
1258
 
          setdef:
1259
 
            is_intregable:=(tsetdef(self).settype=smallset);
1260
 
        end;
1261
 
     end;
1262
 
 
1263
 
 
1264
 
   function tstoreddef.is_fpuregable : boolean;
1265
 
     begin
1266
 
        is_fpuregable:=(deftype=floatdef);
1267
 
     end;
1268
 
 
1269
 
 
1270
 
 
1271
 
{****************************************************************************
1272
 
                               Tstringdef
1273
 
****************************************************************************}
1274
 
 
1275
 
    constructor tstringdef.createshort(l : byte);
1276
 
      begin
1277
 
         inherited create;
1278
 
         string_typ:=st_shortstring;
1279
 
         deftype:=stringdef;
1280
 
         len:=l;
1281
 
         savesize:=len+1;
1282
 
      end;
1283
 
 
1284
 
 
1285
 
    constructor tstringdef.loadshort(ppufile:tcompilerppufile);
1286
 
      begin
1287
 
         inherited ppuloaddef(ppufile);
1288
 
         string_typ:=st_shortstring;
1289
 
         deftype:=stringdef;
1290
 
         len:=ppufile.getbyte;
1291
 
         savesize:=len+1;
1292
 
      end;
1293
 
 
1294
 
 
1295
 
    constructor tstringdef.createlong(l : longint);
1296
 
      begin
1297
 
         inherited create;
1298
 
         string_typ:=st_longstring;
1299
 
         deftype:=stringdef;
1300
 
         len:=l;
1301
 
         savesize:=POINTER_SIZE;
1302
 
      end;
1303
 
 
1304
 
 
1305
 
    constructor tstringdef.loadlong(ppufile:tcompilerppufile);
1306
 
      begin
1307
 
         inherited ppuloaddef(ppufile);
1308
 
         deftype:=stringdef;
1309
 
         string_typ:=st_longstring;
1310
 
         len:=ppufile.getlongint;
1311
 
         savesize:=POINTER_SIZE;
1312
 
      end;
1313
 
 
1314
 
{$ifdef ansistring_bits}
1315
 
    constructor tstringdef.createansi(l:longint;bits:Tstringbits);
1316
 
      begin
1317
 
         inherited create;
1318
 
         case bits of
1319
 
           sb_16:
1320
 
             string_typ:=st_ansistring16;
1321
 
           sb_32:
1322
 
             string_typ:=st_ansistring32;
1323
 
           sb_64:
1324
 
             string_typ:=st_ansistring64;
1325
 
         end;
1326
 
         deftype:=stringdef;
1327
 
         len:=l;
1328
 
         savesize:=POINTER_SIZE;
1329
 
      end;
1330
 
 
1331
 
    constructor tstringdef.loadansi(ppufile:tcompilerppufile;bits:Tstringbits);
1332
 
      begin
1333
 
         inherited ppuloaddef(ppufile);
1334
 
         deftype:=stringdef;
1335
 
         case bits of
1336
 
           sb_16:
1337
 
             string_typ:=st_ansistring16;
1338
 
           sb_32:
1339
 
             string_typ:=st_ansistring32;
1340
 
           sb_64:
1341
 
             string_typ:=st_ansistring64;
1342
 
         end;
1343
 
         len:=ppufile.getlongint;
1344
 
         savesize:=POINTER_SIZE;
1345
 
      end;
1346
 
{$else}
1347
 
    constructor tstringdef.createansi(l:longint);
1348
 
      begin
1349
 
         inherited create;
1350
 
         string_typ:=st_ansistring;
1351
 
         deftype:=stringdef;
1352
 
         len:=l;
1353
 
         savesize:=POINTER_SIZE;
1354
 
      end;
1355
 
 
1356
 
    constructor tstringdef.loadansi(ppufile:tcompilerppufile);
1357
 
 
1358
 
      begin
1359
 
         inherited ppuloaddef(ppufile);
1360
 
         deftype:=stringdef;
1361
 
         string_typ:=st_ansistring;
1362
 
         len:=ppufile.getlongint;
1363
 
         savesize:=POINTER_SIZE;
1364
 
      end;
1365
 
{$endif}
1366
 
 
1367
 
    constructor tstringdef.createwide(l : longint);
1368
 
      begin
1369
 
         inherited create;
1370
 
         string_typ:=st_widestring;
1371
 
         deftype:=stringdef;
1372
 
         len:=l;
1373
 
         savesize:=POINTER_SIZE;
1374
 
      end;
1375
 
 
1376
 
 
1377
 
    constructor tstringdef.loadwide(ppufile:tcompilerppufile);
1378
 
      begin
1379
 
         inherited ppuloaddef(ppufile);
1380
 
         deftype:=stringdef;
1381
 
         string_typ:=st_widestring;
1382
 
         len:=ppufile.getlongint;
1383
 
         savesize:=POINTER_SIZE;
1384
 
      end;
1385
 
 
1386
 
 
1387
 
    function tstringdef.getcopy : tstoreddef;
1388
 
      begin
1389
 
         result:=tstringdef.create;
1390
 
         result.deftype:=stringdef;
1391
 
         tstringdef(result).string_typ:=string_typ;
1392
 
         tstringdef(result).len:=len;
1393
 
         tstringdef(result).savesize:=savesize;
1394
 
      end;
1395
 
 
1396
 
 
1397
 
    function tstringdef.stringtypname:string;
1398
 
{$ifdef ansistring_bits}
1399
 
      const
1400
 
        typname:array[tstringtype] of string[9]=('',
1401
 
          'shortstr','longstr','ansistr16','ansistr32','ansistr64','widestr'
1402
 
        );
1403
 
{$else}
1404
 
      const
1405
 
        typname:array[tstringtype] of string[8]=('',
1406
 
          'shortstr','longstr','ansistr','widestr'
1407
 
        );
1408
 
{$endif}
1409
 
      begin
1410
 
        stringtypname:=typname[string_typ];
1411
 
      end;
1412
 
 
1413
 
 
1414
 
    function tstringdef.size : longint;
1415
 
      begin
1416
 
        size:=savesize;
1417
 
      end;
1418
 
 
1419
 
 
1420
 
    procedure tstringdef.ppuwrite(ppufile:tcompilerppufile);
1421
 
      begin
1422
 
         inherited ppuwritedef(ppufile);
1423
 
         if string_typ=st_shortstring then
1424
 
           begin
1425
 
{$ifdef extdebug}
1426
 
            if len > 255 then internalerror(12122002);
1427
 
{$endif}
1428
 
            ppufile.putbyte(byte(len))
1429
 
           end
1430
 
         else
1431
 
           ppufile.putlongint(len);
1432
 
         case string_typ of
1433
 
            st_shortstring : ppufile.writeentry(ibshortstringdef);
1434
 
            st_longstring : ppufile.writeentry(iblongstringdef);
1435
 
         {$ifdef ansistring_bits}
1436
 
            st_ansistring16 : ppufile.writeentry(ibansistring16def);
1437
 
            st_ansistring32 : ppufile.writeentry(ibansistring32def);
1438
 
            st_ansistring64 : ppufile.writeentry(ibansistring64def);
1439
 
         {$else}
1440
 
            st_ansistring : ppufile.writeentry(ibansistringdef);
1441
 
         {$endif}
1442
 
            st_widestring : ppufile.writeentry(ibwidestringdef);
1443
 
         end;
1444
 
      end;
1445
 
 
1446
 
 
1447
 
{$ifdef GDB}
1448
 
    function tstringdef.stabstring : pchar;
1449
 
      var
1450
 
        bytest,charst,longst : string;
1451
 
      begin
1452
 
        case string_typ of
1453
 
           st_shortstring:
1454
 
             begin
1455
 
               charst:=tstoreddef(cchartype.def).numberstring;
1456
 
               { this is what I found in stabs.texinfo but
1457
 
                 gdb 4.12 for go32 doesn't understand that !! }
1458
 
             {$IfDef GDBknowsstrings}
1459
 
                stabstring:=stabstr_evaluate('n$1;$2',[charst,tostr(len)]);
1460
 
             {$else}
1461
 
               bytest:=tstoreddef(u8inttype.def).numberstring;
1462
 
               stabstring:=stabstr_evaluate('s$1length:$2,0,8;st:ar$2;1;$3;$4,8,$5;;',
1463
 
                           [tostr(len+1),bytest,tostr(len),charst,tostr(len*8)]);
1464
 
             {$EndIf}
1465
 
             end;
1466
 
           st_longstring:
1467
 
             begin
1468
 
               charst:=tstoreddef(cchartype.def).numberstring;
1469
 
               { this is what I found in stabs.texinfo but
1470
 
                 gdb 4.12 for go32 doesn't understand that !! }
1471
 
             {$IfDef GDBknowsstrings}
1472
 
               stabstring:=stabstr_evaluate('n$1;$2',[charst,tostr(len)]);
1473
 
             {$else}
1474
 
               bytest:=tstoreddef(u8inttype.def).numberstring;
1475
 
               longst:=tstoreddef(u32inttype.def).numberstring;
1476
 
               stabstring:=stabstr_evaluate('s$1length:$2,0,32;dummy:$6,32,8;st:ar$2;1;$3;$4,40,$5;;',
1477
 
                            [tostr(len+5),longst,tostr(len),charst,tostr(len*8),bytest]);
1478
 
              {$EndIf}
1479
 
             end;
1480
 
         {$ifdef ansistring_bits}
1481
 
           st_ansistring16,st_ansistring32,st_ansistring64:
1482
 
         {$else}
1483
 
           st_ansistring:
1484
 
         {$endif}
1485
 
             begin
1486
 
               { an ansi string looks like a pchar easy !! }
1487
 
               charst:=tstoreddef(cchartype.def).numberstring;
1488
 
               stabstring:=strpnew('*'+charst);
1489
 
             end;
1490
 
           st_widestring:
1491
 
             begin
1492
 
               { an ansi string looks like a pwidechar easy !! }
1493
 
               charst:=tstoreddef(cwidechartype.def).numberstring;
1494
 
               stabstring:=strpnew('*'+charst);
1495
 
             end;
1496
 
        end;
1497
 
      end;
1498
 
 
1499
 
 
1500
 
    procedure tstringdef.concatstabto(asmlist:taasmoutput);
1501
 
      begin
1502
 
        if (stab_state in [stab_state_writing,stab_state_written]) then
1503
 
          exit;
1504
 
        case string_typ of
1505
 
           st_shortstring:
1506
 
             begin
1507
 
               tstoreddef(cchartype.def).concatstabto(asmlist);
1508
 
             {$IfNDef GDBknowsstrings}
1509
 
               tstoreddef(u8inttype.def).concatstabto(asmlist);
1510
 
             {$EndIf}
1511
 
             end;
1512
 
           st_longstring:
1513
 
             begin
1514
 
               tstoreddef(cchartype.def).concatstabto(asmlist);
1515
 
             {$IfNDef GDBknowsstrings}
1516
 
               tstoreddef(u8inttype.def).concatstabto(asmlist);
1517
 
               tstoreddef(u32inttype.def).concatstabto(asmlist);
1518
 
             {$EndIf}
1519
 
             end;
1520
 
         {$ifdef ansistring_bits}
1521
 
           st_ansistring16,st_ansistring32,st_ansistring64:
1522
 
         {$else}
1523
 
           st_ansistring:
1524
 
         {$endif}
1525
 
             tstoreddef(cchartype.def).concatstabto(asmlist);
1526
 
           st_widestring:
1527
 
             tstoreddef(cwidechartype.def).concatstabto(asmlist);
1528
 
        end;
1529
 
        inherited concatstabto(asmlist);
1530
 
      end;
1531
 
{$endif GDB}
1532
 
 
1533
 
 
1534
 
    function tstringdef.needs_inittable : boolean;
1535
 
      begin
1536
 
      {$ifdef ansistring_bits}
1537
 
         needs_inittable:=string_typ in [st_ansistring16,st_ansistring32,st_ansistring64,st_widestring];
1538
 
      {$else}
1539
 
         needs_inittable:=string_typ in [st_ansistring,st_widestring];
1540
 
      {$endif}
1541
 
      end;
1542
 
 
1543
 
 
1544
 
    function tstringdef.gettypename : string;
1545
 
{$ifdef ansistring_bits}
1546
 
      const
1547
 
         names : array[tstringtype] of string[20] = ('',
1548
 
           'shortstring','longstring','ansistring16','ansistring32','ansistring64','widestring');
1549
 
{$else}
1550
 
      const
1551
 
         names : array[tstringtype] of string[20] = ('',
1552
 
           'ShortString','LongString','AnsiString','WideString');
1553
 
{$endif}
1554
 
      begin
1555
 
         gettypename:=names[string_typ];
1556
 
      end;
1557
 
 
1558
 
 
1559
 
    procedure tstringdef.write_rtti_data(rt:trttitype);
1560
 
      begin
1561
 
         case string_typ of
1562
 
          {$ifdef ansistring_bits}
1563
 
            st_ansistring16:
1564
 
              begin
1565
 
                 rttiList.concat(Tai_const.Create_8bit(tkA16String));
1566
 
                 write_rtti_name;
1567
 
              end;
1568
 
            st_ansistring32:
1569
 
              begin
1570
 
                 rttiList.concat(Tai_const.Create_8bit(tkA32String));
1571
 
                 write_rtti_name;
1572
 
              end;
1573
 
            st_ansistring64:
1574
 
              begin
1575
 
                 rttiList.concat(Tai_const.Create_8bit(tkA64String));
1576
 
                 write_rtti_name;
1577
 
              end;
1578
 
          {$else}
1579
 
            st_ansistring:
1580
 
              begin
1581
 
                 rttiList.concat(Tai_const.Create_8bit(tkAString));
1582
 
                 write_rtti_name;
1583
 
              end;
1584
 
          {$endif}
1585
 
            st_widestring:
1586
 
              begin
1587
 
                 rttiList.concat(Tai_const.Create_8bit(tkWString));
1588
 
                 write_rtti_name;
1589
 
              end;
1590
 
            st_longstring:
1591
 
              begin
1592
 
                 rttiList.concat(Tai_const.Create_8bit(tkLString));
1593
 
                 write_rtti_name;
1594
 
              end;
1595
 
            st_shortstring:
1596
 
              begin
1597
 
                 rttiList.concat(Tai_const.Create_8bit(tkSString));
1598
 
                 write_rtti_name;
1599
 
                 rttiList.concat(Tai_const.Create_8bit(len));
1600
 
              end;
1601
 
         end;
1602
 
      end;
1603
 
 
1604
 
 
1605
 
    function tstringdef.getmangledparaname : string;
1606
 
      begin
1607
 
        getmangledparaname:='STRING';
1608
 
      end;
1609
 
 
1610
 
 
1611
 
    function tstringdef.is_publishable : boolean;
1612
 
      begin
1613
 
         is_publishable:=true;
1614
 
      end;
1615
 
 
1616
 
 
1617
 
{****************************************************************************
1618
 
                                 TENUMDEF
1619
 
****************************************************************************}
1620
 
 
1621
 
    constructor tenumdef.create;
1622
 
      begin
1623
 
         inherited create;
1624
 
         deftype:=enumdef;
1625
 
         minval:=0;
1626
 
         maxval:=0;
1627
 
         calcsavesize;
1628
 
         has_jumps:=false;
1629
 
         basedef:=nil;
1630
 
         firstenum:=nil;
1631
 
         correct_owner_symtable;
1632
 
      end;
1633
 
 
1634
 
    constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:longint);
1635
 
      begin
1636
 
         inherited create;
1637
 
         deftype:=enumdef;
1638
 
         minval:=_min;
1639
 
         maxval:=_max;
1640
 
         basedef:=_basedef;
1641
 
         calcsavesize;
1642
 
         has_jumps:=false;
1643
 
         firstenum:=basedef.firstenum;
1644
 
         while assigned(firstenum) and (tenumsym(firstenum).value<>minval) do
1645
 
          firstenum:=tenumsym(firstenum).nextenum;
1646
 
         correct_owner_symtable;
1647
 
      end;
1648
 
 
1649
 
 
1650
 
    constructor tenumdef.ppuload(ppufile:tcompilerppufile);
1651
 
      begin
1652
 
         inherited ppuloaddef(ppufile);
1653
 
         deftype:=enumdef;
1654
 
         ppufile.getderef(basedefderef);
1655
 
         minval:=ppufile.getlongint;
1656
 
         maxval:=ppufile.getlongint;
1657
 
         savesize:=ppufile.getlongint;
1658
 
         has_jumps:=false;
1659
 
         firstenum:=Nil;
1660
 
      end;
1661
 
 
1662
 
 
1663
 
    procedure tenumdef.calcsavesize;
1664
 
      begin
1665
 
        if (aktpackenum=4) or (min<0) or (max>65535) then
1666
 
         savesize:=4
1667
 
        else
1668
 
         if (aktpackenum=2) or (min<0) or (max>255) then
1669
 
          savesize:=2
1670
 
        else
1671
 
         savesize:=1;
1672
 
      end;
1673
 
 
1674
 
 
1675
 
    procedure tenumdef.setmax(_max:longint);
1676
 
      begin
1677
 
        maxval:=_max;
1678
 
        calcsavesize;
1679
 
      end;
1680
 
 
1681
 
 
1682
 
    procedure tenumdef.setmin(_min:longint);
1683
 
      begin
1684
 
        minval:=_min;
1685
 
        calcsavesize;
1686
 
      end;
1687
 
 
1688
 
 
1689
 
    function tenumdef.min:longint;
1690
 
      begin
1691
 
        min:=minval;
1692
 
      end;
1693
 
 
1694
 
 
1695
 
    function tenumdef.max:longint;
1696
 
      begin
1697
 
        max:=maxval;
1698
 
      end;
1699
 
 
1700
 
 
1701
 
    procedure tenumdef.buildderef;
1702
 
      begin
1703
 
        inherited buildderef;
1704
 
        basedefderef.build(basedef);
1705
 
      end;
1706
 
 
1707
 
 
1708
 
    procedure tenumdef.deref;
1709
 
      begin
1710
 
        inherited deref;
1711
 
        basedef:=tenumdef(basedefderef.resolve);
1712
 
      end;
1713
 
 
1714
 
 
1715
 
    destructor tenumdef.destroy;
1716
 
      begin
1717
 
        inherited destroy;
1718
 
      end;
1719
 
 
1720
 
 
1721
 
    procedure tenumdef.ppuwrite(ppufile:tcompilerppufile);
1722
 
      begin
1723
 
         inherited ppuwritedef(ppufile);
1724
 
         ppufile.putderef(basedefderef);
1725
 
         ppufile.putlongint(min);
1726
 
         ppufile.putlongint(max);
1727
 
         ppufile.putlongint(savesize);
1728
 
         ppufile.writeentry(ibenumdef);
1729
 
      end;
1730
 
 
1731
 
 
1732
 
    { used for enumdef because the symbols are
1733
 
      inserted in the owner symtable }
1734
 
    procedure tenumdef.correct_owner_symtable;
1735
 
      var
1736
 
         st : tsymtable;
1737
 
      begin
1738
 
         if assigned(owner) and
1739
 
            (owner.symtabletype in [recordsymtable,objectsymtable]) then
1740
 
           begin
1741
 
              owner.defindex.deleteindex(self);
1742
 
              st:=owner;
1743
 
              while (st.symtabletype in [recordsymtable,objectsymtable]) do
1744
 
                st:=st.next;
1745
 
              st.registerdef(self);
1746
 
           end;
1747
 
      end;
1748
 
 
1749
 
 
1750
 
 
1751
 
{$ifdef GDB}
1752
 
    function tenumdef.stabstring : pchar;
1753
 
 
1754
 
    var st:Pchar;
1755
 
        p:Tenumsym;
1756
 
        s:string;
1757
 
        memsize,stl:cardinal;
1758
 
 
1759
 
    begin
1760
 
      memsize:=memsizeinc;
1761
 
      getmem(st,memsize);
1762
 
      { we can specify the size with @s<size>; prefix PM }
1763
 
      if savesize <> std_param_align then
1764
 
        strpcopy(st,'@s'+tostr(savesize*8)+';e')
1765
 
      else
1766
 
        strpcopy(st,'e');
1767
 
      p := tenumsym(firstenum);
1768
 
      stl:=strlen(st);
1769
 
      while assigned(p) do
1770
 
        begin
1771
 
          s :=p.name+':'+tostr(p.value)+',';
1772
 
          { place for the ending ';' also }
1773
 
          if (stl+length(s)+1>=memsize) then
1774
 
            begin
1775
 
              inc(memsize,memsizeinc);
1776
 
              reallocmem(st,memsize);
1777
 
            end;
1778
 
          strpcopy(st+stl,s);
1779
 
          inc(stl,length(s));
1780
 
          p:=p.nextenum;
1781
 
        end;
1782
 
      st[stl]:=';';
1783
 
      st[stl+1]:=#0;
1784
 
      reallocmem(st,stl+2);
1785
 
      stabstring:=st;
1786
 
    end;
1787
 
{$endif GDB}
1788
 
 
1789
 
 
1790
 
    procedure tenumdef.write_child_rtti_data(rt:trttitype);
1791
 
      begin
1792
 
         if assigned(basedef) then
1793
 
           basedef.get_rtti_label(rt);
1794
 
      end;
1795
 
 
1796
 
 
1797
 
    procedure tenumdef.write_rtti_data(rt:trttitype);
1798
 
      var
1799
 
         hp : tenumsym;
1800
 
      begin
1801
 
         rttiList.concat(Tai_const.Create_8bit(tkEnumeration));
1802
 
         write_rtti_name;
1803
 
         case savesize of
1804
 
            1:
1805
 
              rttiList.concat(Tai_const.Create_8bit(otUByte));
1806
 
            2:
1807
 
              rttiList.concat(Tai_const.Create_8bit(otUWord));
1808
 
            4:
1809
 
              rttiList.concat(Tai_const.Create_8bit(otULong));
1810
 
         end;
1811
 
         rttiList.concat(Tai_const.Create_32bit(Cardinal(min)));
1812
 
         rttiList.concat(Tai_const.Create_32bit(Cardinal(max)));
1813
 
         if assigned(basedef) then
1814
 
           rttiList.concat(Tai_const_symbol.Create(basedef.get_rtti_label(rt)))
1815
 
         else
1816
 
           rttiList.concat(Tai_const.Create_ptr(0));
1817
 
         hp:=tenumsym(firstenum);
1818
 
         while assigned(hp) do
1819
 
           begin
1820
 
              rttiList.concat(Tai_const.Create_8bit(length(hp.realname)));
1821
 
              rttiList.concat(Tai_string.Create(hp.realname));
1822
 
              hp:=hp.nextenum;
1823
 
           end;
1824
 
         rttiList.concat(Tai_const.Create_8bit(0));
1825
 
      end;
1826
 
 
1827
 
 
1828
 
    function tenumdef.is_publishable : boolean;
1829
 
      begin
1830
 
         is_publishable:=true;
1831
 
      end;
1832
 
 
1833
 
    function tenumdef.gettypename : string;
1834
 
 
1835
 
      begin
1836
 
         gettypename:='<enumeration type>';
1837
 
      end;
1838
 
 
1839
 
{****************************************************************************
1840
 
                                 TORDDEF
1841
 
****************************************************************************}
1842
 
 
1843
 
    constructor torddef.create(t : tbasetype;v,b : TConstExprInt);
1844
 
      begin
1845
 
         inherited create;
1846
 
         deftype:=orddef;
1847
 
         low:=v;
1848
 
         high:=b;
1849
 
         typ:=t;
1850
 
         setsize;
1851
 
      end;
1852
 
 
1853
 
 
1854
 
    constructor torddef.ppuload(ppufile:tcompilerppufile);
1855
 
      begin
1856
 
         inherited ppuloaddef(ppufile);
1857
 
         deftype:=orddef;
1858
 
         typ:=tbasetype(ppufile.getbyte);
1859
 
         if sizeof(TConstExprInt)=8 then
1860
 
           begin
1861
 
             low:=ppufile.getint64;
1862
 
             high:=ppufile.getint64;
1863
 
           end
1864
 
         else
1865
 
           begin
1866
 
             low:=ppufile.getlongint;
1867
 
             high:=ppufile.getlongint;
1868
 
           end;
1869
 
         setsize;
1870
 
      end;
1871
 
 
1872
 
 
1873
 
    function torddef.getcopy : tstoreddef;
1874
 
      begin
1875
 
         result:=torddef.create(typ,low,high);
1876
 
         result.deftype:=orddef;
1877
 
         torddef(result).low:=low;
1878
 
         torddef(result).high:=high;
1879
 
         torddef(result).typ:=typ;
1880
 
         torddef(result).savesize:=savesize;
1881
 
      end;
1882
 
 
1883
 
 
1884
 
    procedure torddef.setsize;
1885
 
      const
1886
 
        sizetbl : array[tbasetype] of longint = (
1887
 
          0,
1888
 
          1,2,4,8,
1889
 
          1,2,4,8,
1890
 
          1,2,4,
1891
 
          1,2,8
1892
 
        );
1893
 
      begin
1894
 
        savesize:=sizetbl[typ];
1895
 
      end;
1896
 
 
1897
 
 
1898
 
    procedure torddef.ppuwrite(ppufile:tcompilerppufile);
1899
 
      begin
1900
 
         inherited ppuwritedef(ppufile);
1901
 
         ppufile.putbyte(byte(typ));
1902
 
         if sizeof(TConstExprInt)=8 then
1903
 
          begin
1904
 
            ppufile.putint64(low);
1905
 
            ppufile.putint64(high);
1906
 
          end
1907
 
         else
1908
 
          begin
1909
 
            ppufile.putlongint(low);
1910
 
            ppufile.putlongint(high);
1911
 
          end;
1912
 
         ppufile.writeentry(iborddef);
1913
 
      end;
1914
 
 
1915
 
 
1916
 
{$ifdef GDB}
1917
 
    function torddef.stabstring : pchar;
1918
 
      begin
1919
 
        if cs_gdb_valgrind in aktglobalswitches then
1920
 
          begin
1921
 
            case typ of
1922
 
              uvoid :
1923
 
                stabstring := strpnew(numberstring);
1924
 
              bool8bit,
1925
 
              bool16bit,
1926
 
              bool32bit :
1927
 
                stabstring := stabstr_evaluate('r${numberstring};0;255;',[]);
1928
 
              u32bit,
1929
 
              s64bit,
1930
 
              u64bit :
1931
 
                stabstring:=stabstr_evaluate('r${numberstring};0;-1;',[]);
1932
 
              else
1933
 
                stabstring:=stabstr_evaluate('r${numberstring};$1;$2;',[tostr(longint(low)),tostr(longint(high))]);
1934
 
            end;
1935
 
          end
1936
 
        else
1937
 
          begin
1938
 
            case typ of
1939
 
              uvoid :
1940
 
                stabstring := strpnew(numberstring);
1941
 
              uchar :
1942
 
                stabstring := strpnew('-20;');
1943
 
              uwidechar :
1944
 
                stabstring := strpnew('-30;');
1945
 
              bool8bit :
1946
 
                stabstring := strpnew('-21;');
1947
 
              bool16bit :
1948
 
                stabstring := strpnew('-22;');
1949
 
              bool32bit :
1950
 
                stabstring := strpnew('-23;');
1951
 
              u64bit :
1952
 
                stabstring := strpnew('-32;');
1953
 
              s64bit :
1954
 
                stabstring := strpnew('-31;');
1955
 
              {u32bit : stabstring := tstoreddef(s32inttype.def).numberstring+';0;-1;'); }
1956
 
              else
1957
 
                stabstring:=stabstr_evaluate('r${numberstring};$1;$2;',[tostr(longint(low)),tostr(longint(high))]);
1958
 
            end;
1959
 
         end;
1960
 
      end;
1961
 
{$endif GDB}
1962
 
 
1963
 
 
1964
 
    procedure torddef.write_rtti_data(rt:trttitype);
1965
 
 
1966
 
        procedure dointeger;
1967
 
        const
1968
 
          trans : array[tbasetype] of byte =
1969
 
            (otUByte{otNone},
1970
 
             otUByte,otUWord,otULong,otUByte{otNone},
1971
 
             otSByte,otSWord,otSLong,otUByte{otNone},
1972
 
             otUByte,otUWord,otULong,
1973
 
             otUByte,otUWord,otUByte);
1974
 
        begin
1975
 
          write_rtti_name;
1976
 
          rttiList.concat(Tai_const.Create_8bit(byte(trans[typ])));
1977
 
          rttiList.concat(Tai_const.Create_32bit(Cardinal(low)));
1978
 
          rttiList.concat(Tai_const.Create_32bit(Cardinal(high)));
1979
 
        end;
1980
 
 
1981
 
      begin
1982
 
        case typ of
1983
 
          s64bit :
1984
 
            begin
1985
 
              rttiList.concat(Tai_const.Create_8bit(tkInt64));
1986
 
              write_rtti_name;
1987
 
{$warning maybe change to create_64bit}
1988
 
              if target_info.endian=endian_little then
1989
 
                begin
1990
 
                  { low }
1991
 
                  rttiList.concat(Tai_const.Create_32bit($0));
1992
 
                  rttiList.concat(Tai_const.Create_32bit(cardinal($80000000)));
1993
 
                  { high }
1994
 
                  rttiList.concat(Tai_const.Create_32bit(cardinal($ffffffff)));
1995
 
                  rttiList.concat(Tai_const.Create_32bit(cardinal($7fffffff)));
1996
 
                end
1997
 
              else
1998
 
                begin
1999
 
                  { low }
2000
 
                  rttiList.concat(Tai_const.Create_32bit(cardinal($80000000)));
2001
 
                  rttiList.concat(Tai_const.Create_32bit($0));
2002
 
                  { high }
2003
 
                  rttiList.concat(Tai_const.Create_32bit(cardinal($7fffffff)));
2004
 
                  rttiList.concat(Tai_const.Create_32bit(cardinal($ffffffff)));
2005
 
                end;
2006
 
            end;
2007
 
          u64bit :
2008
 
            begin
2009
 
              rttiList.concat(Tai_const.Create_8bit(tkQWord));
2010
 
              write_rtti_name;
2011
 
              { low }
2012
 
              rttiList.concat(Tai_const.Create_32bit($0));
2013
 
              rttiList.concat(Tai_const.Create_32bit($0));
2014
 
              { high }
2015
 
              rttiList.concat(Tai_const.Create_32bit(cardinal($ffffffff)));
2016
 
              rttiList.concat(Tai_const.Create_32bit(cardinal($ffffffff)));
2017
 
            end;
2018
 
          bool8bit:
2019
 
            begin
2020
 
              rttiList.concat(Tai_const.Create_8bit(tkBool));
2021
 
              dointeger;
2022
 
            end;
2023
 
          uchar:
2024
 
            begin
2025
 
              rttiList.concat(Tai_const.Create_8bit(tkChar));
2026
 
              dointeger;
2027
 
            end;
2028
 
          uwidechar:
2029
 
            begin
2030
 
              rttiList.concat(Tai_const.Create_8bit(tkWChar));
2031
 
              dointeger;
2032
 
            end;
2033
 
          else
2034
 
            begin
2035
 
              rttiList.concat(Tai_const.Create_8bit(tkInteger));
2036
 
              dointeger;
2037
 
            end;
2038
 
        end;
2039
 
      end;
2040
 
 
2041
 
 
2042
 
    function torddef.is_publishable : boolean;
2043
 
      begin
2044
 
         is_publishable:=(typ<>uvoid);
2045
 
      end;
2046
 
 
2047
 
 
2048
 
    function torddef.gettypename : string;
2049
 
 
2050
 
      const
2051
 
        names : array[tbasetype] of string[20] = (
2052
 
          'untyped',
2053
 
          'Byte','Word','DWord','QWord',
2054
 
          'ShortInt','SmallInt','LongInt','Int64',
2055
 
          'Boolean','WordBool','LongBool',
2056
 
          'Char','WideChar','Currency');
2057
 
 
2058
 
      begin
2059
 
         gettypename:=names[typ];
2060
 
      end;
2061
 
 
2062
 
{****************************************************************************
2063
 
                                TFLOATDEF
2064
 
****************************************************************************}
2065
 
 
2066
 
    constructor tfloatdef.create(t : tfloattype);
2067
 
      begin
2068
 
         inherited create;
2069
 
         deftype:=floatdef;
2070
 
         typ:=t;
2071
 
         setsize;
2072
 
      end;
2073
 
 
2074
 
 
2075
 
    constructor tfloatdef.ppuload(ppufile:tcompilerppufile);
2076
 
      begin
2077
 
         inherited ppuloaddef(ppufile);
2078
 
         deftype:=floatdef;
2079
 
         typ:=tfloattype(ppufile.getbyte);
2080
 
         setsize;
2081
 
      end;
2082
 
 
2083
 
 
2084
 
    function tfloatdef.getcopy : tstoreddef;
2085
 
      begin
2086
 
         result:=tfloatdef.create(typ);
2087
 
         result.deftype:=floatdef;
2088
 
         tfloatdef(result).savesize:=savesize;
2089
 
      end;
2090
 
 
2091
 
 
2092
 
    procedure tfloatdef.setsize;
2093
 
      begin
2094
 
         case typ of
2095
 
           s32real : savesize:=4;
2096
 
           s80real : savesize:=extended_size;
2097
 
           s64real,
2098
 
           s64currency,
2099
 
           s64comp : savesize:=8;
2100
 
         else
2101
 
           savesize:=0;
2102
 
         end;
2103
 
      end;
2104
 
 
2105
 
 
2106
 
    procedure tfloatdef.ppuwrite(ppufile:tcompilerppufile);
2107
 
      begin
2108
 
         inherited ppuwritedef(ppufile);
2109
 
         ppufile.putbyte(byte(typ));
2110
 
         ppufile.writeentry(ibfloatdef);
2111
 
      end;
2112
 
 
2113
 
 
2114
 
{$ifdef GDB}
2115
 
    function Tfloatdef.stabstring:Pchar;
2116
 
      begin
2117
 
        case typ of
2118
 
          s32real,s64real:
2119
 
            { found this solution in stabsread.c from GDB v4.16 }
2120
 
            stabstring:=stabstr_evaluate('r$1;${savesize};0;',[tstoreddef(s32inttype.def).numberstring]);
2121
 
          s64currency,s64comp:
2122
 
            stabstring:=stabstr_evaluate('r$1;-${savesize};0;',[tstoreddef(s32inttype.def).numberstring]);
2123
 
          s80real:
2124
 
           { under dos at least you must give a size of twelve instead of 10 !! }
2125
 
           { this is probably do to the fact that in gcc all is pushed in 4 bytes size }
2126
 
            stabstring:=stabstr_evaluate('r$1;12;0;',[tstoreddef(s32inttype.def).numberstring]);
2127
 
          else
2128
 
            internalerror(10005);
2129
 
        end;
2130
 
      end;
2131
 
 
2132
 
 
2133
 
    procedure tfloatdef.concatstabto(asmlist:taasmoutput);
2134
 
      begin
2135
 
        if (stab_state in [stab_state_writing,stab_state_written]) then
2136
 
          exit;
2137
 
        tstoreddef(s32inttype.def).concatstabto(asmlist);
2138
 
        inherited concatstabto(asmlist);
2139
 
      end;
2140
 
{$endif GDB}
2141
 
 
2142
 
 
2143
 
    procedure tfloatdef.write_rtti_data(rt:trttitype);
2144
 
      const
2145
 
         {tfloattype = (s32real,s64real,s80real,s64bit,s128bit);}
2146
 
         translate : array[tfloattype] of byte =
2147
 
           (ftSingle,ftDouble,ftExtended,ftComp,ftCurr,ftFloat128);
2148
 
      begin
2149
 
         rttiList.concat(Tai_const.Create_8bit(tkFloat));
2150
 
         write_rtti_name;
2151
 
         rttiList.concat(Tai_const.Create_8bit(translate[typ]));
2152
 
      end;
2153
 
 
2154
 
 
2155
 
    function tfloatdef.is_publishable : boolean;
2156
 
      begin
2157
 
         is_publishable:=true;
2158
 
      end;
2159
 
 
2160
 
    function tfloatdef.gettypename : string;
2161
 
 
2162
 
      const
2163
 
        names : array[tfloattype] of string[20] = (
2164
 
          'Single','Double','Extended','Comp','Currency','Float128');
2165
 
 
2166
 
      begin
2167
 
         gettypename:=names[typ];
2168
 
      end;
2169
 
 
2170
 
{****************************************************************************
2171
 
                                TFILEDEF
2172
 
****************************************************************************}
2173
 
 
2174
 
    constructor tfiledef.createtext;
2175
 
      begin
2176
 
         inherited create;
2177
 
         deftype:=filedef;
2178
 
         filetyp:=ft_text;
2179
 
         typedfiletype.reset;
2180
 
         setsize;
2181
 
      end;
2182
 
 
2183
 
 
2184
 
    constructor tfiledef.createuntyped;
2185
 
      begin
2186
 
         inherited create;
2187
 
         deftype:=filedef;
2188
 
         filetyp:=ft_untyped;
2189
 
         typedfiletype.reset;
2190
 
         setsize;
2191
 
      end;
2192
 
 
2193
 
 
2194
 
    constructor tfiledef.createtyped(const tt : ttype);
2195
 
      begin
2196
 
         inherited create;
2197
 
         deftype:=filedef;
2198
 
         filetyp:=ft_typed;
2199
 
         typedfiletype:=tt;
2200
 
         setsize;
2201
 
      end;
2202
 
 
2203
 
 
2204
 
    constructor tfiledef.ppuload(ppufile:tcompilerppufile);
2205
 
      begin
2206
 
         inherited ppuloaddef(ppufile);
2207
 
         deftype:=filedef;
2208
 
         filetyp:=tfiletyp(ppufile.getbyte);
2209
 
         if filetyp=ft_typed then
2210
 
           ppufile.gettype(typedfiletype)
2211
 
         else
2212
 
           typedfiletype.reset;
2213
 
         setsize;
2214
 
      end;
2215
 
 
2216
 
 
2217
 
    procedure tfiledef.buildderef;
2218
 
      begin
2219
 
        inherited buildderef;
2220
 
        if filetyp=ft_typed then
2221
 
          typedfiletype.buildderef;
2222
 
      end;
2223
 
 
2224
 
 
2225
 
    procedure tfiledef.deref;
2226
 
      begin
2227
 
        inherited deref;
2228
 
        if filetyp=ft_typed then
2229
 
          typedfiletype.resolve;
2230
 
      end;
2231
 
 
2232
 
 
2233
 
    procedure tfiledef.setsize;
2234
 
      begin
2235
 
{$ifdef cpu64bit}
2236
 
        case filetyp of
2237
 
          ft_text :
2238
 
            savesize:=616;
2239
 
          ft_typed,
2240
 
          ft_untyped :
2241
 
            savesize:=324;
2242
 
        end;
2243
 
{$else cpu64bit}
2244
 
        case filetyp of
2245
 
          ft_text :
2246
 
            savesize:=572;
2247
 
          ft_typed,
2248
 
          ft_untyped :
2249
 
            savesize:=316;
2250
 
        end;
2251
 
{$endif cpu64bit}
2252
 
      end;
2253
 
 
2254
 
 
2255
 
    procedure tfiledef.ppuwrite(ppufile:tcompilerppufile);
2256
 
      begin
2257
 
         inherited ppuwritedef(ppufile);
2258
 
         ppufile.putbyte(byte(filetyp));
2259
 
         if filetyp=ft_typed then
2260
 
           ppufile.puttype(typedfiletype);
2261
 
         ppufile.writeentry(ibfiledef);
2262
 
      end;
2263
 
 
2264
 
 
2265
 
{$ifdef GDB}
2266
 
    function tfiledef.stabstring : pchar;
2267
 
      begin
2268
 
   {$IfDef GDBknowsfiles}
2269
 
      case filetyp of
2270
 
        ft_typed :
2271
 
          stabstring := strpnew('d'+typedfiletype.def.numberstring{+';'});
2272
 
        ft_untyped :
2273
 
          stabstring := strpnew('d'+voiddef.numberstring{+';'});
2274
 
        ft_text :
2275
 
          stabstring := strpnew('d'+cchartype^.numberstring{+';'});
2276
 
      end;
2277
 
   {$Else}
2278
 
      {based on
2279
 
        FileRec = Packed Record
2280
 
          Handle,
2281
 
          Mode,
2282
 
          RecSize   : longint;
2283
 
          _private  : array[1..32] of byte;
2284
 
          UserData  : array[1..16] of byte;
2285
 
          name      : array[0..255] of char;
2286
 
        End; }
2287
 
      { the buffer part is still missing !! (PM) }
2288
 
      { but the string could become too long !! }
2289
 
      stabstring:=stabstr_evaluate('s${savesize}HANDLE:$1,0,32;MODE:$1,32,32;RECSIZE:$1,64,32;'+
2290
 
                                   '_PRIVATE:ar$2;1;32;$3,96,256;USERDATA:ar$2;1;16;$3,352,128;'+
2291
 
                                   'NAME:ar$2;0;255;$4,480,2048;;',[tstoreddef(u32inttype.def).numberstring,
2292
 
                                   tstoreddef(u16inttype.def).numberstring,tstoreddef(u8inttype.def).numberstring,
2293
 
                                   tstoreddef(cchartype.def).numberstring]);
2294
 
   {$EndIf}
2295
 
      end;
2296
 
 
2297
 
 
2298
 
    procedure tfiledef.concatstabto(asmlist:taasmoutput);
2299
 
      begin
2300
 
        if (stab_state in [stab_state_writing,stab_state_written]) then
2301
 
          exit;
2302
 
  {$IfDef GDBknowsfiles}
2303
 
        case filetyp of
2304
 
          ft_typed :
2305
 
            tstoreddef(typedfiletype.def).concatstabto(asmlist);
2306
 
          ft_untyped :
2307
 
            tstoreddef(voidtype.def).concatstabto(asmlist);
2308
 
          ft_text :
2309
 
            tstoreddef(cchartype.def).concatstabto(asmlist);
2310
 
        end;
2311
 
  {$Else}
2312
 
        tstoreddef(u32inttype.def).concatstabto(asmlist);
2313
 
        tstoreddef(u16inttype.def).concatstabto(asmlist);
2314
 
        tstoreddef(u8inttype.def).concatstabto(asmlist);
2315
 
        tstoreddef(cchartype.def).concatstabto(asmlist);
2316
 
  {$EndIf}
2317
 
        inherited concatstabto(asmlist);
2318
 
      end;
2319
 
{$endif GDB}
2320
 
 
2321
 
 
2322
 
    function tfiledef.gettypename : string;
2323
 
      begin
2324
 
         case filetyp of
2325
 
           ft_untyped:
2326
 
             gettypename:='File';
2327
 
           ft_typed:
2328
 
             gettypename:='File Of '+typedfiletype.def.typename;
2329
 
           ft_text:
2330
 
             gettypename:='Text'
2331
 
         end;
2332
 
      end;
2333
 
 
2334
 
 
2335
 
    function tfiledef.getmangledparaname : string;
2336
 
      begin
2337
 
         case filetyp of
2338
 
           ft_untyped:
2339
 
             getmangledparaname:='FILE';
2340
 
           ft_typed:
2341
 
             getmangledparaname:='FILE$OF$'+typedfiletype.def.mangledparaname;
2342
 
           ft_text:
2343
 
             getmangledparaname:='TEXT'
2344
 
         end;
2345
 
      end;
2346
 
 
2347
 
 
2348
 
{****************************************************************************
2349
 
                               TVARIANTDEF
2350
 
****************************************************************************}
2351
 
 
2352
 
    constructor tvariantdef.create(v : tvarianttype);
2353
 
      begin
2354
 
         inherited create;
2355
 
         varianttype:=v;
2356
 
         deftype:=variantdef;
2357
 
         setsize;
2358
 
      end;
2359
 
 
2360
 
 
2361
 
    constructor tvariantdef.ppuload(ppufile:tcompilerppufile);
2362
 
      begin
2363
 
         inherited ppuloaddef(ppufile);
2364
 
         varianttype:=tvarianttype(ppufile.getbyte);
2365
 
         deftype:=variantdef;
2366
 
         setsize;
2367
 
      end;
2368
 
 
2369
 
 
2370
 
    procedure tvariantdef.ppuwrite(ppufile:tcompilerppufile);
2371
 
      begin
2372
 
         inherited ppuwritedef(ppufile);
2373
 
         ppufile.putbyte(byte(varianttype));
2374
 
         ppufile.writeentry(ibvariantdef);
2375
 
      end;
2376
 
 
2377
 
 
2378
 
    procedure tvariantdef.setsize;
2379
 
      begin
2380
 
         savesize:=16;
2381
 
      end;
2382
 
 
2383
 
 
2384
 
    function tvariantdef.gettypename : string;
2385
 
      begin
2386
 
         case varianttype of
2387
 
           vt_normalvariant:
2388
 
             gettypename:='Variant';
2389
 
           vt_olevariant:
2390
 
             gettypename:='OleVariant';
2391
 
         end;
2392
 
      end;
2393
 
 
2394
 
 
2395
 
    procedure tvariantdef.write_rtti_data(rt:trttitype);
2396
 
      begin
2397
 
         rttiList.concat(Tai_const.Create_8bit(tkVariant));
2398
 
      end;
2399
 
 
2400
 
 
2401
 
    function tvariantdef.needs_inittable : boolean;
2402
 
      begin
2403
 
         needs_inittable:=true;
2404
 
      end;
2405
 
 
2406
 
{$ifdef GDB}
2407
 
    function tvariantdef.stabstring : pchar;
2408
 
      begin
2409
 
        stabstring:=stabstr_evaluate('formal${numberstring};',[]);
2410
 
      end;
2411
 
 
2412
 
 
2413
 
    function tvariantdef.numberstring:string;
2414
 
      begin
2415
 
        result:=tstoreddef(voidtype.def).numberstring;
2416
 
      end;
2417
 
 
2418
 
 
2419
 
    procedure tvariantdef.concatstabto(asmlist : taasmoutput);
2420
 
      begin
2421
 
        { don't know how to handle this }
2422
 
      end;
2423
 
{$endif GDB}
2424
 
 
2425
 
{****************************************************************************
2426
 
                               TPOINTERDEF
2427
 
****************************************************************************}
2428
 
 
2429
 
    constructor tpointerdef.create(const tt : ttype);
2430
 
      begin
2431
 
        inherited create;
2432
 
        deftype:=pointerdef;
2433
 
        pointertype:=tt;
2434
 
        is_far:=false;
2435
 
        savesize:=POINTER_SIZE;
2436
 
      end;
2437
 
 
2438
 
 
2439
 
    constructor tpointerdef.createfar(const tt : ttype);
2440
 
      begin
2441
 
        inherited create;
2442
 
        deftype:=pointerdef;
2443
 
        pointertype:=tt;
2444
 
        is_far:=true;
2445
 
        savesize:=POINTER_SIZE;
2446
 
      end;
2447
 
 
2448
 
 
2449
 
    constructor tpointerdef.ppuload(ppufile:tcompilerppufile);
2450
 
      begin
2451
 
         inherited ppuloaddef(ppufile);
2452
 
         deftype:=pointerdef;
2453
 
         ppufile.gettype(pointertype);
2454
 
         is_far:=(ppufile.getbyte<>0);
2455
 
         savesize:=POINTER_SIZE;
2456
 
      end;
2457
 
 
2458
 
 
2459
 
    procedure tpointerdef.buildderef;
2460
 
      begin
2461
 
        inherited buildderef;
2462
 
        pointertype.buildderef;
2463
 
      end;
2464
 
 
2465
 
 
2466
 
    procedure tpointerdef.deref;
2467
 
      begin
2468
 
        inherited deref;
2469
 
        pointertype.resolve;
2470
 
      end;
2471
 
 
2472
 
 
2473
 
    procedure tpointerdef.ppuwrite(ppufile:tcompilerppufile);
2474
 
      begin
2475
 
         inherited ppuwritedef(ppufile);
2476
 
         ppufile.puttype(pointertype);
2477
 
         ppufile.putbyte(byte(is_far));
2478
 
         ppufile.writeentry(ibpointerdef);
2479
 
      end;
2480
 
 
2481
 
 
2482
 
{$ifdef GDB}
2483
 
    function tpointerdef.stabstring : pchar;
2484
 
      begin
2485
 
        stabstring := strpnew('*'+tstoreddef(pointertype.def).numberstring);
2486
 
      end;
2487
 
 
2488
 
 
2489
 
    procedure tpointerdef.concatstabto(asmlist : taasmoutput);
2490
 
      var st,nb : string;
2491
 
 
2492
 
      begin
2493
 
        if (stab_state in [stab_state_writing,stab_state_written]) then
2494
 
          exit;
2495
 
        stab_state:=stab_state_writing;
2496
 
 
2497
 
        tstoreddef(pointertype.def).concatstabto(asmlist);
2498
 
 
2499
 
        if (pointertype.def.deftype in [recorddef,objectdef]) then
2500
 
          begin
2501
 
            if pointertype.def.deftype=objectdef then
2502
 
              nb:=tobjectdef(pointertype.def).classnumberstring
2503
 
            else
2504
 
              nb:=tstoreddef(pointertype.def).numberstring;
2505
 
            {to avoid infinite recursion in record with next-like fields }
2506
 
            if tstoreddef(pointertype.def).stab_state=stab_state_writing then
2507
 
              begin
2508
 
                if assigned(pointertype.def.typesym) then
2509
 
                  begin
2510
 
                    if assigned(typesym) then
2511
 
                      st := ttypesym(typesym).name
2512
 
                    else
2513
 
                      st := ' ';
2514
 
                    asmlist.concat(Tai_stabs.create(stabstr_evaluate(
2515
 
                            '"$1:t${numberstring}=*$2=xs$3:",${N_LSYM},0,0,0',
2516
 
                            [st,nb,pointertype.def.typesym.name])));
2517
 
                  end;
2518
 
                stab_state:=stab_state_written;
2519
 
              end
2520
 
            else
2521
 
              begin
2522
 
                stab_state:=stab_state_used;
2523
 
                inherited concatstabto(asmlist);
2524
 
              end;
2525
 
          end
2526
 
        else
2527
 
          begin
2528
 
            stab_state:=stab_state_used;
2529
 
            inherited concatstabto(asmlist);
2530
 
          end;
2531
 
      end;
2532
 
{$endif GDB}
2533
 
 
2534
 
 
2535
 
    function tpointerdef.gettypename : string;
2536
 
      begin
2537
 
         if is_far then
2538
 
          gettypename:='^'+pointertype.def.typename+';far'
2539
 
         else
2540
 
          gettypename:='^'+pointertype.def.typename;
2541
 
      end;
2542
 
 
2543
 
 
2544
 
{****************************************************************************
2545
 
                              TCLASSREFDEF
2546
 
****************************************************************************}
2547
 
 
2548
 
    constructor tclassrefdef.create(const t:ttype);
2549
 
      begin
2550
 
         inherited create(t);
2551
 
         deftype:=classrefdef;
2552
 
      end;
2553
 
 
2554
 
 
2555
 
    constructor tclassrefdef.ppuload(ppufile:tcompilerppufile);
2556
 
      begin
2557
 
         { be careful, tclassdefref inherits from tpointerdef }
2558
 
         inherited ppuloaddef(ppufile);
2559
 
         deftype:=classrefdef;
2560
 
         ppufile.gettype(pointertype);
2561
 
         is_far:=false;
2562
 
         savesize:=POINTER_SIZE;
2563
 
      end;
2564
 
 
2565
 
 
2566
 
    procedure tclassrefdef.ppuwrite(ppufile:tcompilerppufile);
2567
 
      begin
2568
 
         { be careful, tclassdefref inherits from tpointerdef }
2569
 
         inherited ppuwritedef(ppufile);
2570
 
         ppufile.puttype(pointertype);
2571
 
         ppufile.writeentry(ibclassrefdef);
2572
 
      end;
2573
 
 
2574
 
 
2575
 
{$ifdef GDB}
2576
 
    function tclassrefdef.stabstring : pchar;
2577
 
      begin
2578
 
         stabstring:=strpnew(tstoreddef(pvmttype.def).numberstring);
2579
 
      end;
2580
 
{$endif GDB}
2581
 
 
2582
 
 
2583
 
    function tclassrefdef.gettypename : string;
2584
 
      begin
2585
 
         gettypename:='Class Of '+pointertype.def.typename;
2586
 
      end;
2587
 
 
2588
 
 
2589
 
{***************************************************************************
2590
 
                                   TSETDEF
2591
 
***************************************************************************}
2592
 
 
2593
 
    constructor tsetdef.create(const t:ttype;high : longint);
2594
 
      begin
2595
 
         inherited create;
2596
 
         deftype:=setdef;
2597
 
         elementtype:=t;
2598
 
         if high<32 then
2599
 
           begin
2600
 
            settype:=smallset;
2601
 
           {$ifdef testvarsets}
2602
 
            if aktsetalloc=0 THEN      { $PACKSET Fixed?}
2603
 
           {$endif}
2604
 
            savesize:=Sizeof(longint)
2605
 
           {$ifdef testvarsets}
2606
 
           else                       {No, use $PACKSET VALUE for rounding}
2607
 
            savesize:=aktsetalloc*((high+aktsetalloc*8-1) DIV (aktsetalloc*8))
2608
 
           {$endif}
2609
 
              ;
2610
 
          end
2611
 
         else
2612
 
          if high<256 then
2613
 
           begin
2614
 
              settype:=normset;
2615
 
              savesize:=32;
2616
 
           end
2617
 
         else
2618
 
{$ifdef testvarsets}
2619
 
         if high<$10000 then
2620
 
           begin
2621
 
              settype:=varset;
2622
 
              savesize:=4*((high+31) div 32);
2623
 
           end
2624
 
         else
2625
 
{$endif testvarsets}
2626
 
          Message(sym_e_ill_type_decl_set);
2627
 
      end;
2628
 
 
2629
 
 
2630
 
    constructor tsetdef.ppuload(ppufile:tcompilerppufile);
2631
 
      begin
2632
 
         inherited ppuloaddef(ppufile);
2633
 
         deftype:=setdef;
2634
 
         ppufile.gettype(elementtype);
2635
 
         settype:=tsettype(ppufile.getbyte);
2636
 
         case settype of
2637
 
            normset : savesize:=32;
2638
 
            varset : savesize:=ppufile.getlongint;
2639
 
            smallset : savesize:=Sizeof(longint);
2640
 
         end;
2641
 
      end;
2642
 
 
2643
 
 
2644
 
    destructor tsetdef.destroy;
2645
 
      begin
2646
 
        inherited destroy;
2647
 
      end;
2648
 
 
2649
 
 
2650
 
    procedure tsetdef.ppuwrite(ppufile:tcompilerppufile);
2651
 
      begin
2652
 
         inherited ppuwritedef(ppufile);
2653
 
         ppufile.puttype(elementtype);
2654
 
         ppufile.putbyte(byte(settype));
2655
 
         if settype=varset then
2656
 
           ppufile.putlongint(savesize);
2657
 
         ppufile.writeentry(ibsetdef);
2658
 
      end;
2659
 
 
2660
 
 
2661
 
{$ifdef GDB}
2662
 
    function tsetdef.stabstring : pchar;
2663
 
      begin
2664
 
        stabstring:=stabstr_evaluate('@s$1;S$2',[tostr(savesize*8),tstoreddef(elementtype.def).numberstring]);
2665
 
      end;
2666
 
 
2667
 
 
2668
 
    procedure tsetdef.concatstabto(asmlist:taasmoutput);
2669
 
      begin
2670
 
        if (stab_state in [stab_state_writing,stab_state_written]) then
2671
 
          exit;
2672
 
        tstoreddef(elementtype.def).concatstabto(asmlist);
2673
 
        inherited concatstabto(asmlist);
2674
 
      end;
2675
 
{$endif GDB}
2676
 
 
2677
 
 
2678
 
    procedure tsetdef.buildderef;
2679
 
      begin
2680
 
        inherited buildderef;
2681
 
        elementtype.buildderef;
2682
 
      end;
2683
 
 
2684
 
 
2685
 
    procedure tsetdef.deref;
2686
 
      begin
2687
 
        inherited deref;
2688
 
        elementtype.resolve;
2689
 
      end;
2690
 
 
2691
 
 
2692
 
    procedure tsetdef.write_child_rtti_data(rt:trttitype);
2693
 
      begin
2694
 
        tstoreddef(elementtype.def).get_rtti_label(rt);
2695
 
      end;
2696
 
 
2697
 
 
2698
 
    procedure tsetdef.write_rtti_data(rt:trttitype);
2699
 
      begin
2700
 
         rttiList.concat(Tai_const.Create_8bit(tkSet));
2701
 
         write_rtti_name;
2702
 
         rttiList.concat(Tai_const.Create_8bit(otULong));
2703
 
         rttiList.concat(Tai_const_symbol.Create(tstoreddef(elementtype.def).get_rtti_label(rt)));
2704
 
      end;
2705
 
 
2706
 
 
2707
 
    function tsetdef.is_publishable : boolean;
2708
 
      begin
2709
 
         is_publishable:=(settype=smallset);
2710
 
      end;
2711
 
 
2712
 
 
2713
 
    function tsetdef.gettypename : string;
2714
 
      begin
2715
 
         if assigned(elementtype.def) then
2716
 
          gettypename:='Set Of '+elementtype.def.typename
2717
 
         else
2718
 
          gettypename:='Empty Set';
2719
 
      end;
2720
 
 
2721
 
 
2722
 
{***************************************************************************
2723
 
                                 TFORMALDEF
2724
 
***************************************************************************}
2725
 
 
2726
 
    constructor tformaldef.create;
2727
 
      var
2728
 
         stregdef : boolean;
2729
 
      begin
2730
 
         stregdef:=registerdef;
2731
 
         registerdef:=false;
2732
 
         inherited create;
2733
 
         deftype:=formaldef;
2734
 
         registerdef:=stregdef;
2735
 
         { formaldef must be registered at unit level !! }
2736
 
         if registerdef and assigned(current_module) then
2737
 
            if assigned(current_module.localsymtable) then
2738
 
              tsymtable(current_module.localsymtable).registerdef(self)
2739
 
            else if assigned(current_module.globalsymtable) then
2740
 
              tsymtable(current_module.globalsymtable).registerdef(self);
2741
 
         savesize:=0;
2742
 
      end;
2743
 
 
2744
 
 
2745
 
    constructor tformaldef.ppuload(ppufile:tcompilerppufile);
2746
 
      begin
2747
 
         inherited ppuloaddef(ppufile);
2748
 
         deftype:=formaldef;
2749
 
         savesize:=0;
2750
 
      end;
2751
 
 
2752
 
 
2753
 
    procedure tformaldef.ppuwrite(ppufile:tcompilerppufile);
2754
 
      begin
2755
 
         inherited ppuwritedef(ppufile);
2756
 
         ppufile.writeentry(ibformaldef);
2757
 
      end;
2758
 
 
2759
 
 
2760
 
{$ifdef GDB}
2761
 
    function tformaldef.stabstring : pchar;
2762
 
      begin
2763
 
        stabstring:=stabstr_evaluate('formal${numberstring};',[]);
2764
 
      end;
2765
 
 
2766
 
 
2767
 
    function tformaldef.numberstring:string;
2768
 
      begin
2769
 
        result:=tstoreddef(voidtype.def).numberstring;
2770
 
      end;
2771
 
 
2772
 
 
2773
 
    procedure tformaldef.concatstabto(asmlist : taasmoutput);
2774
 
      begin
2775
 
        { formaldef can't be stab'ed !}
2776
 
      end;
2777
 
{$endif GDB}
2778
 
 
2779
 
 
2780
 
    function tformaldef.gettypename : string;
2781
 
      begin
2782
 
         gettypename:='<Formal type>';
2783
 
      end;
2784
 
 
2785
 
 
2786
 
{***************************************************************************
2787
 
                           TARRAYDEF
2788
 
***************************************************************************}
2789
 
 
2790
 
    constructor tarraydef.create(l,h : longint;const t : ttype);
2791
 
      begin
2792
 
         inherited create;
2793
 
         deftype:=arraydef;
2794
 
         lowrange:=l;
2795
 
         highrange:=h;
2796
 
         rangetype:=t;
2797
 
         elementtype.reset;
2798
 
         IsVariant:=false;
2799
 
         IsConstructor:=false;
2800
 
         IsArrayOfConst:=false;
2801
 
         IsDynamicArray:=false;
2802
 
         IsConvertedPointer:=false;
2803
 
      end;
2804
 
 
2805
 
 
2806
 
    constructor tarraydef.create_from_pointer(const elemt : ttype);
2807
 
      begin
2808
 
         self.create(0,$7fffffff,s32inttype);
2809
 
         IsConvertedPointer:=true;
2810
 
         setelementtype(elemt);
2811
 
      end;
2812
 
 
2813
 
 
2814
 
    constructor tarraydef.ppuload(ppufile:tcompilerppufile);
2815
 
      begin
2816
 
         inherited ppuloaddef(ppufile);
2817
 
         deftype:=arraydef;
2818
 
         { the addresses are calculated later }
2819
 
         ppufile.gettype(_elementtype);
2820
 
         ppufile.gettype(rangetype);
2821
 
         lowrange:=ppufile.getlongint;
2822
 
         highrange:=ppufile.getlongint;
2823
 
         IsArrayOfConst:=boolean(ppufile.getbyte);
2824
 
         IsDynamicArray:=boolean(ppufile.getbyte);
2825
 
         IsVariant:=false;
2826
 
         IsConstructor:=false;
2827
 
      end;
2828
 
 
2829
 
 
2830
 
    procedure tarraydef.buildderef;
2831
 
      begin
2832
 
        inherited buildderef;
2833
 
        _elementtype.buildderef;
2834
 
        rangetype.buildderef;
2835
 
      end;
2836
 
 
2837
 
 
2838
 
    procedure tarraydef.deref;
2839
 
      begin
2840
 
        inherited deref;
2841
 
        _elementtype.resolve;
2842
 
        rangetype.resolve;
2843
 
      end;
2844
 
 
2845
 
 
2846
 
    procedure tarraydef.ppuwrite(ppufile:tcompilerppufile);
2847
 
      begin
2848
 
         inherited ppuwritedef(ppufile);
2849
 
         ppufile.puttype(_elementtype);
2850
 
         ppufile.puttype(rangetype);
2851
 
         ppufile.putlongint(lowrange);
2852
 
         ppufile.putlongint(highrange);
2853
 
         ppufile.putbyte(byte(IsArrayOfConst));
2854
 
         ppufile.putbyte(byte(IsDynamicArray));
2855
 
         ppufile.writeentry(ibarraydef);
2856
 
      end;
2857
 
 
2858
 
 
2859
 
{$ifdef GDB}
2860
 
    function tarraydef.stabstring : pchar;
2861
 
      begin
2862
 
        stabstring:=stabstr_evaluate('ar$1;$2;$3;$4',[Tstoreddef(rangetype.def).numberstring,
2863
 
                    tostr(lowrange),tostr(highrange),Tstoreddef(_elementtype.def).numberstring]);
2864
 
      end;
2865
 
 
2866
 
 
2867
 
    procedure tarraydef.concatstabto(asmlist:taasmoutput);
2868
 
      begin
2869
 
        if (stab_state in [stab_state_writing,stab_state_written]) then
2870
 
          exit;
2871
 
        tstoreddef(rangetype.def).concatstabto(asmlist);
2872
 
        tstoreddef(_elementtype.def).concatstabto(asmlist);
2873
 
        inherited concatstabto(asmlist);
2874
 
      end;
2875
 
{$endif GDB}
2876
 
 
2877
 
 
2878
 
    function tarraydef.elesize : longint;
2879
 
      begin
2880
 
        elesize:=_elementtype.def.size;
2881
 
      end;
2882
 
 
2883
 
 
2884
 
    function tarraydef.size : longint;
2885
 
      var
2886
 
        newsize : TConstExprInt;
2887
 
      begin
2888
 
        if IsDynamicArray then
2889
 
          begin
2890
 
            size:=POINTER_SIZE;
2891
 
            exit;
2892
 
          end;
2893
 
        {Tarraydef.size may never be called for an open array!}
2894
 
        if highrange<lowrange then
2895
 
            internalerror(99080501);
2896
 
        newsize:=(int64(highrange)-int64(lowrange)+1)*elesize;
2897
 
        { prevent an overflow }
2898
 
        if newsize>high(longint) then
2899
 
          result:=high(longint)
2900
 
        else
2901
 
          result:=newsize;
2902
 
      end;
2903
 
 
2904
 
 
2905
 
    procedure tarraydef.setelementtype(t: ttype);
2906
 
      var
2907
 
        cachedsize : TConstExprInt;
2908
 
      begin
2909
 
        _elementtype:=t;
2910
 
       if not(IsDynamicArray or
2911
 
              IsConvertedPointer or
2912
 
              (highrange<lowrange)) then
2913
 
         begin
2914
 
           { cache element size for performance on multidimensional arrays }
2915
 
           cachedsize := elesize;
2916
 
           if (cachedsize>0) and
2917
 
               (
2918
 
{$ifdef cpu64bit}
2919
 
{$ifdef VER1_0}
2920
 
                { 1.0.x can't handle this and while bootstrapping with 1.0.x we can forget about it }
2921
 
                false
2922
 
{$else}
2923
 
                (TConstExprInt(highrange)-TConstExprInt(lowrange) > $7fffffffffffffff) or
2924
 
 
2925
 
                { () are needed around cachedsize-1 to avoid a possible
2926
 
                  integer overflow for cachedsize=1 !! PM }
2927
 
                (($7fffffffffffffff div cachedsize + (cachedsize -1)) < (int64(highrange) - int64(lowrange)))
2928
 
{$endif VER1_0}
2929
 
{$else cpu64bit}
2930
 
                (TConstExprInt(highrange)-TConstExprInt(lowrange) > $7fffffff) or
2931
 
 
2932
 
                { () are needed around cachedsize-1 to avoid a possible
2933
 
                  integer overflow for cachedsize=1 !! PM }
2934
 
                (($7fffffff div cachedsize + (cachedsize -1)) < (int64(highrange) - int64(lowrange)))
2935
 
{$endif cpu64bit}
2936
 
               ) Then
2937
 
             Message(sym_e_segment_too_large);
2938
 
         end;
2939
 
      end;
2940
 
 
2941
 
 
2942
 
    function tarraydef.alignment : longint;
2943
 
      begin
2944
 
         { alignment is the size of the elements }
2945
 
         if elementtype.def.deftype=recorddef then
2946
 
          alignment:=elementtype.def.alignment
2947
 
         else
2948
 
          alignment:=elesize;
2949
 
      end;
2950
 
 
2951
 
 
2952
 
    function tarraydef.needs_inittable : boolean;
2953
 
      begin
2954
 
         needs_inittable:=IsDynamicArray or elementtype.def.needs_inittable;
2955
 
      end;
2956
 
 
2957
 
 
2958
 
    procedure tarraydef.write_child_rtti_data(rt:trttitype);
2959
 
      begin
2960
 
        tstoreddef(elementtype.def).get_rtti_label(rt);
2961
 
      end;
2962
 
 
2963
 
 
2964
 
    procedure tarraydef.write_rtti_data(rt:trttitype);
2965
 
      begin
2966
 
         if IsDynamicArray then
2967
 
           rttiList.concat(Tai_const.Create_8bit(tkdynarray))
2968
 
         else
2969
 
           rttiList.concat(Tai_const.Create_8bit(tkarray));
2970
 
         write_rtti_name;
2971
 
         { size of elements }
2972
 
         rttiList.concat(Tai_const.Create_32bit(elesize));
2973
 
         { count of elements, prevent overflow for 0..maxlongint }
2974
 
         if not(IsDynamicArray) then
2975
 
           rttiList.concat(Tai_const.Create_32bit(min(int64(highrange)-lowrange+1,maxlongint)));
2976
 
         { element type }
2977
 
         rttiList.concat(Tai_const_symbol.Create(tstoreddef(elementtype.def).get_rtti_label(rt)));
2978
 
         { variant type }
2979
 
         // !!!!!!!!!!!!!!!!
2980
 
      end;
2981
 
 
2982
 
 
2983
 
    function tarraydef.gettypename : string;
2984
 
      begin
2985
 
         if isarrayofconst or isConstructor then
2986
 
           begin
2987
 
             if isvariant or ((highrange=-1) and (lowrange=0)) then
2988
 
               gettypename:='Array Of Const'
2989
 
             else
2990
 
               gettypename:='Array Of '+elementtype.def.typename;
2991
 
           end
2992
 
         else if ((highrange=-1) and (lowrange=0)) or IsDynamicArray then
2993
 
           gettypename:='Array Of '+elementtype.def.typename
2994
 
         else
2995
 
           begin
2996
 
              if rangetype.def.deftype=enumdef then
2997
 
                gettypename:='Array['+rangetype.def.typename+'] Of '+elementtype.def.typename
2998
 
              else
2999
 
                gettypename:='Array['+tostr(lowrange)+'..'+
3000
 
                  tostr(highrange)+'] Of '+elementtype.def.typename
3001
 
           end;
3002
 
      end;
3003
 
 
3004
 
 
3005
 
    function tarraydef.getmangledparaname : string;
3006
 
      begin
3007
 
         if isarrayofconst then
3008
 
          getmangledparaname:='array_of_const'
3009
 
         else
3010
 
          if ((highrange=-1) and (lowrange=0)) then
3011
 
           getmangledparaname:='array_of_'+elementtype.def.mangledparaname
3012
 
         else
3013
 
          internalerror(200204176);
3014
 
      end;
3015
 
 
3016
 
 
3017
 
{***************************************************************************
3018
 
                              tabstractrecorddef
3019
 
***************************************************************************}
3020
 
 
3021
 
    function tabstractrecorddef.getsymtable(t:tgetsymtable):tsymtable;
3022
 
      begin
3023
 
         if t=gs_record then
3024
 
         getsymtable:=symtable
3025
 
        else
3026
 
         getsymtable:=nil;
3027
 
      end;
3028
 
 
3029
 
 
3030
 
{$ifdef GDB}
3031
 
    procedure tabstractrecorddef.field_addname(p:Tnamedindexitem;arg:pointer);
3032
 
      var
3033
 
        newrec:Pchar;
3034
 
        spec:string[3];
3035
 
        varsize:longint;
3036
 
        state:^Trecord_stabgen_state;
3037
 
      begin
3038
 
        state:=arg;
3039
 
        { static variables from objects are like global objects }
3040
 
        if (Tsym(p).typ=varsym) and not (sp_static in Tsym(p).symoptions) then
3041
 
          begin
3042
 
            if (sp_protected in tsym(p).symoptions) then
3043
 
              spec:='/1'
3044
 
            else if (sp_private in tsym(p).symoptions) then
3045
 
              spec:='/0'
3046
 
            else
3047
 
              spec:='';
3048
 
            varsize:=tvarsym(p).vartype.def.size;
3049
 
            { open arrays made overflows !! }
3050
 
            if varsize>$fffffff then
3051
 
              varsize:=$fffffff;
3052
 
            newrec:=stabstr_evaluate('$1:$2,$3,$4;',[p.name,
3053
 
                                     spec+tstoreddef(tvarsym(p).vartype.def).numberstring,
3054
 
                                     tostr(tvarsym(p).fieldoffset*8),tostr(varsize*8)]);
3055
 
            if state^.stabsize+strlen(newrec)>=state^.staballoc-256 then
3056
 
              begin
3057
 
                inc(state^.staballoc,memsizeinc);
3058
 
                reallocmem(state^.stabstring,state^.staballoc);
3059
 
              end;
3060
 
            strcopy(state^.stabstring+state^.stabsize,newrec);
3061
 
            inc(state^.stabsize,strlen(newrec));
3062
 
            strdispose(newrec);
3063
 
            {This should be used for case !!}
3064
 
            inc(state^.recoffset,Tvarsym(p).vartype.def.size);
3065
 
          end;
3066
 
      end;
3067
 
 
3068
 
 
3069
 
    procedure tabstractrecorddef.field_concatstabto(p:Tnamedindexitem;arg:pointer);
3070
 
      begin
3071
 
        if (Tsym(p).typ=varsym) and not (sp_static in Tsym(p).symoptions) then
3072
 
          tstoreddef(tvarsym(p).vartype.def).concatstabto(taasmoutput(arg));
3073
 
      end;
3074
 
 
3075
 
 
3076
 
{$endif GDB}
3077
 
 
3078
 
 
3079
 
    procedure tabstractrecorddef.count_field_rtti(sym : tnamedindexitem;arg:pointer);
3080
 
      begin
3081
 
         if (FRTTIType=fullrtti) or
3082
 
            ((tsym(sym).typ=varsym) and
3083
 
             tvarsym(sym).vartype.def.needs_inittable) then
3084
 
           inc(Count);
3085
 
      end;
3086
 
 
3087
 
 
3088
 
    procedure tabstractrecorddef.generate_field_rtti(sym:tnamedindexitem;arg:pointer);
3089
 
      begin
3090
 
         if (FRTTIType=fullrtti) or
3091
 
            ((tsym(sym).typ=varsym) and
3092
 
             tvarsym(sym).vartype.def.needs_inittable) then
3093
 
           tstoreddef(tvarsym(sym).vartype.def).get_rtti_label(FRTTIType);
3094
 
      end;
3095
 
 
3096
 
 
3097
 
    procedure tabstractrecorddef.write_field_rtti(sym : tnamedindexitem;arg:pointer);
3098
 
      begin
3099
 
         if (FRTTIType=fullrtti) or
3100
 
            ((tsym(sym).typ=varsym) and
3101
 
             tvarsym(sym).vartype.def.needs_inittable) then
3102
 
          begin
3103
 
            rttiList.concat(Tai_const_symbol.Create(tstoreddef(tvarsym(sym).vartype.def).get_rtti_label(FRTTIType)));
3104
 
            rttiList.concat(Tai_const.Create_32bit(tvarsym(sym).fieldoffset));
3105
 
          end;
3106
 
      end;
3107
 
 
3108
 
 
3109
 
 
3110
 
{***************************************************************************
3111
 
                                  trecorddef
3112
 
***************************************************************************}
3113
 
 
3114
 
    constructor trecorddef.create(p : tsymtable);
3115
 
      begin
3116
 
         inherited create;
3117
 
         deftype:=recorddef;
3118
 
         symtable:=p;
3119
 
         symtable.defowner:=self;
3120
 
         isunion:=false;
3121
 
      end;
3122
 
 
3123
 
 
3124
 
    constructor trecorddef.ppuload(ppufile:tcompilerppufile);
3125
 
      begin
3126
 
         inherited ppuloaddef(ppufile);
3127
 
         deftype:=recorddef;
3128
 
         savesize:=ppufile.getlongint;
3129
 
         symtable:=trecordsymtable.create(0);
3130
 
         trecordsymtable(symtable).datasize:=ppufile.getlongint;
3131
 
         trecordsymtable(symtable).fieldalignment:=ppufile.getbyte;
3132
 
         trecordsymtable(symtable).recordalignment:=ppufile.getbyte;
3133
 
         trecordsymtable(symtable).ppuload(ppufile);
3134
 
         symtable.defowner:=self;
3135
 
         isunion:=false;
3136
 
      end;
3137
 
 
3138
 
 
3139
 
    destructor trecorddef.destroy;
3140
 
      begin
3141
 
         if assigned(symtable) then
3142
 
           symtable.free;
3143
 
         inherited destroy;
3144
 
      end;
3145
 
 
3146
 
 
3147
 
    function trecorddef.needs_inittable : boolean;
3148
 
      begin
3149
 
        needs_inittable:=trecordsymtable(symtable).needs_init_final
3150
 
      end;
3151
 
 
3152
 
 
3153
 
    procedure trecorddef.buildderef;
3154
 
      var
3155
 
         oldrecsyms : tsymtable;
3156
 
      begin
3157
 
         inherited buildderef;
3158
 
         oldrecsyms:=aktrecordsymtable;
3159
 
         aktrecordsymtable:=symtable;
3160
 
         { now build the definitions }
3161
 
         tstoredsymtable(symtable).buildderef;
3162
 
         aktrecordsymtable:=oldrecsyms;
3163
 
      end;
3164
 
 
3165
 
 
3166
 
    procedure trecorddef.deref;
3167
 
      var
3168
 
         oldrecsyms : tsymtable;
3169
 
      begin
3170
 
         inherited deref;
3171
 
         oldrecsyms:=aktrecordsymtable;
3172
 
         aktrecordsymtable:=symtable;
3173
 
         { now dereference the definitions }
3174
 
         tstoredsymtable(symtable).deref;
3175
 
         aktrecordsymtable:=oldrecsyms;
3176
 
         { assign TGUID? load only from system unit (unitid=1) }
3177
 
         if not(assigned(rec_tguid)) and
3178
 
            (upper(typename)='TGUID') and
3179
 
            assigned(owner) and
3180
 
            assigned(owner.name) and
3181
 
            (owner.name^='SYSTEM') then
3182
 
           rec_tguid:=self;
3183
 
      end;
3184
 
 
3185
 
 
3186
 
    procedure trecorddef.ppuwrite(ppufile:tcompilerppufile);
3187
 
      begin
3188
 
         inherited ppuwritedef(ppufile);
3189
 
         ppufile.putlongint(savesize);
3190
 
         ppufile.putlongint(trecordsymtable(symtable).datasize);
3191
 
         ppufile.putbyte(trecordsymtable(symtable).fieldalignment);
3192
 
         ppufile.putbyte(trecordsymtable(symtable).recordalignment);
3193
 
         ppufile.writeentry(ibrecorddef);
3194
 
         trecordsymtable(symtable).ppuwrite(ppufile);
3195
 
      end;
3196
 
 
3197
 
 
3198
 
    function trecorddef.size:longint;
3199
 
      begin
3200
 
        result:=trecordsymtable(symtable).datasize;
3201
 
      end;
3202
 
 
3203
 
 
3204
 
    function trecorddef.alignment:longint;
3205
 
      begin
3206
 
        alignment:=trecordsymtable(symtable).recordalignment;
3207
 
      end;
3208
 
 
3209
 
 
3210
 
{$ifdef GDB}
3211
 
    function trecorddef.stabstring : pchar;
3212
 
      var
3213
 
        state:Trecord_stabgen_state;
3214
 
      begin
3215
 
        getmem(state.stabstring,memsizeinc);
3216
 
        state.staballoc:=memsizeinc;
3217
 
        strpcopy(state.stabstring,'s'+tostr(size));
3218
 
        state.recoffset:=0;
3219
 
        state.stabsize:=strlen(state.stabstring);
3220
 
        symtable.foreach({$ifdef FPCPROCVAR}@{$endif}field_addname,@state);
3221
 
        state.stabstring[state.stabsize]:=';';
3222
 
        state.stabstring[state.stabsize+1]:=#0;
3223
 
        reallocmem(state.stabstring,state.stabsize+2);
3224
 
        stabstring:=state.stabstring;
3225
 
      end;
3226
 
 
3227
 
 
3228
 
    procedure trecorddef.concatstabto(asmlist:taasmoutput);
3229
 
      begin
3230
 
        if (stab_state in [stab_state_writing,stab_state_written]) then
3231
 
          exit;
3232
 
        symtable.foreach({$ifdef FPCPROCVAR}@{$endif}field_concatstabto,asmlist);
3233
 
        inherited concatstabto(asmlist);
3234
 
      end;
3235
 
{$endif GDB}
3236
 
 
3237
 
 
3238
 
    procedure trecorddef.write_child_rtti_data(rt:trttitype);
3239
 
      begin
3240
 
         FRTTIType:=rt;
3241
 
         symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_field_rtti,nil);
3242
 
      end;
3243
 
 
3244
 
 
3245
 
    procedure trecorddef.write_rtti_data(rt:trttitype);
3246
 
      begin
3247
 
         rttiList.concat(Tai_const.Create_8bit(tkrecord));
3248
 
         write_rtti_name;
3249
 
         rttiList.concat(Tai_const.Create_32bit(size));
3250
 
         Count:=0;
3251
 
         FRTTIType:=rt;
3252
 
         symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_field_rtti,nil);
3253
 
         rttiList.concat(Tai_const.Create_32bit(Count));
3254
 
         symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_rtti,nil);
3255
 
      end;
3256
 
 
3257
 
 
3258
 
    function trecorddef.gettypename : string;
3259
 
      begin
3260
 
         gettypename:='<record type>'
3261
 
      end;
3262
 
 
3263
 
 
3264
 
{***************************************************************************
3265
 
                       TABSTRACTPROCDEF
3266
 
***************************************************************************}
3267
 
 
3268
 
    constructor tabstractprocdef.create(level:byte);
3269
 
      begin
3270
 
         inherited create;
3271
 
         parast:=tparasymtable.create(level);
3272
 
         parast.defowner:=self;
3273
 
         parast.next:=owner;
3274
 
         para:=TLinkedList.Create;
3275
 
         minparacount:=0;
3276
 
         maxparacount:=0;
3277
 
         proctypeoption:=potype_none;
3278
 
         proccalloption:=pocall_none;
3279
 
         procoptions:=[];
3280
 
         rettype:=voidtype;
3281
 
{$ifdef i386}
3282
 
         fpu_used:=0;
3283
 
{$endif i386}
3284
 
         savesize:=POINTER_SIZE;
3285
 
         has_paraloc_info:=false;
3286
 
      end;
3287
 
 
3288
 
 
3289
 
    destructor tabstractprocdef.destroy;
3290
 
      begin
3291
 
         if assigned(para) then
3292
 
           begin
3293
 
{$ifdef MEMDEBUG}
3294
 
             memprocpara.start;
3295
 
{$endif MEMDEBUG}
3296
 
             para.free;
3297
 
{$ifdef MEMDEBUG}
3298
 
             memprocpara.stop;
3299
 
{$endif MEMDEBUG}
3300
 
          end;
3301
 
         if assigned(parast) then
3302
 
          begin
3303
 
{$ifdef MEMDEBUG}
3304
 
            memprocparast.start;
3305
 
{$endif MEMDEBUG}
3306
 
            parast.free;
3307
 
{$ifdef MEMDEBUG}
3308
 
            memprocparast.stop;
3309
 
{$endif MEMDEBUG}
3310
 
          end;
3311
 
         inherited destroy;
3312
 
      end;
3313
 
 
3314
 
 
3315
 
    procedure tabstractprocdef.releasemem;
3316
 
      begin
3317
 
        para.free;
3318
 
        para:=nil;
3319
 
        parast.free;
3320
 
        parast:=nil;
3321
 
      end;
3322
 
 
3323
 
 
3324
 
    function tabstractprocdef.concatpara(afterpara:tparaitem;const tt:ttype;sym : tsym;defval:tsym;vhidden:boolean):tparaitem;
3325
 
      var
3326
 
        hp : TParaItem;
3327
 
      begin
3328
 
        hp:=TParaItem.Create;
3329
 
        hp.paratyp:=tvarsym(sym).varspez;
3330
 
        hp.parasym:=sym;
3331
 
        hp.paratype:=tt;
3332
 
        hp.is_hidden:=vhidden;
3333
 
        hp.defaultvalue:=defval;
3334
 
        { Parameters are stored from left to right }
3335
 
        if assigned(afterpara) then
3336
 
          Para.insertafter(hp,afterpara)
3337
 
        else
3338
 
          Para.concat(hp);
3339
 
        { Don't count hidden parameters }
3340
 
        if not vhidden then
3341
 
         begin
3342
 
           if not assigned(defval) then
3343
 
            inc(minparacount);
3344
 
           inc(maxparacount);
3345
 
         end;
3346
 
        concatpara:=hp;
3347
 
      end;
3348
 
 
3349
 
 
3350
 
    function tabstractprocdef.insertpara(const tt:ttype;sym : tsym;defval:tsym;vhidden:boolean):tparaitem;
3351
 
      var
3352
 
        hp : TParaItem;
3353
 
      begin
3354
 
        hp:=TParaItem.Create;
3355
 
        hp.paratyp:=tvarsym(sym).varspez;
3356
 
        hp.parasym:=sym;
3357
 
        hp.paratype:=tt;
3358
 
        hp.is_hidden:=vhidden;
3359
 
        hp.defaultvalue:=defval;
3360
 
        { Parameters are stored from left to right }
3361
 
        Para.insert(hp);
3362
 
        { Don't count hidden parameters }
3363
 
        if (not vhidden) then
3364
 
         begin
3365
 
           if not assigned(defval) then
3366
 
            inc(minparacount);
3367
 
           inc(maxparacount);
3368
 
         end;
3369
 
        insertpara:=hp;
3370
 
      end;
3371
 
 
3372
 
 
3373
 
    procedure tabstractprocdef.removepara(currpara:tparaitem);
3374
 
      begin
3375
 
        { Don't count hidden parameters }
3376
 
        if (not currpara.is_hidden) then
3377
 
         begin
3378
 
           if not assigned(currpara.defaultvalue) then
3379
 
            dec(minparacount);
3380
 
           dec(maxparacount);
3381
 
         end;
3382
 
        Para.Remove(currpara);
3383
 
        currpara.free;
3384
 
      end;
3385
 
 
3386
 
 
3387
 
    { all functions returning in FPU are
3388
 
      assume to use 2 FPU registers
3389
 
      until the function implementation
3390
 
      is processed   PM }
3391
 
    procedure tabstractprocdef.test_if_fpu_result;
3392
 
      begin
3393
 
{$ifdef i386}
3394
 
         if assigned(rettype.def) and
3395
 
            (rettype.def.deftype=floatdef) then
3396
 
           fpu_used:=maxfpuregs;
3397
 
{$endif i386}
3398
 
      end;
3399
 
 
3400
 
 
3401
 
    procedure tabstractprocdef.buildderef;
3402
 
      var
3403
 
         hp : TParaItem;
3404
 
      begin
3405
 
         { released procdef? }
3406
 
         if not assigned(parast) then
3407
 
           exit;
3408
 
         inherited buildderef;
3409
 
         rettype.buildderef;
3410
 
         { parast }
3411
 
         tparasymtable(parast).buildderef;
3412
 
         { paraitems }
3413
 
         hp:=TParaItem(Para.first);
3414
 
         while assigned(hp) do
3415
 
          begin
3416
 
            hp.paratype.buildderef;
3417
 
            hp.defaultvaluederef.build(hp.defaultvalue);
3418
 
            hp.parasymderef.build(hp.parasym);
3419
 
            hp:=TParaItem(hp.next);
3420
 
          end;
3421
 
      end;
3422
 
 
3423
 
 
3424
 
    procedure tabstractprocdef.deref;
3425
 
      var
3426
 
         hp : TParaItem;
3427
 
      begin
3428
 
         inherited deref;
3429
 
         rettype.resolve;
3430
 
         { parast }
3431
 
         tparasymtable(parast).deref;
3432
 
         { paraitems }
3433
 
         minparacount:=0;
3434
 
         maxparacount:=0;
3435
 
         hp:=TParaItem(Para.first);
3436
 
         while assigned(hp) do
3437
 
          begin
3438
 
            hp.paratype.resolve;
3439
 
            hp.defaultvalue:=tsym(hp.defaultvaluederef.resolve);
3440
 
            hp.parasym:=tvarsym(hp.parasymderef.resolve);
3441
 
            { connect parasym to paraitem }
3442
 
            tvarsym(hp.parasym).paraitem:=hp;
3443
 
            { Don't count hidden parameters }
3444
 
            if (not hp.is_hidden) then
3445
 
             begin
3446
 
               if not assigned(hp.defaultvalue) then
3447
 
                 inc(minparacount);
3448
 
               inc(maxparacount);
3449
 
             end;
3450
 
            hp:=TParaItem(hp.next);
3451
 
          end;
3452
 
      end;
3453
 
 
3454
 
 
3455
 
    constructor tabstractprocdef.ppuload(ppufile:tcompilerppufile);
3456
 
      var
3457
 
         hp : TParaItem;
3458
 
         count,i : word;
3459
 
      begin
3460
 
         inherited ppuloaddef(ppufile);
3461
 
         parast:=nil;
3462
 
         Para:=TLinkedList.Create;
3463
 
         minparacount:=0;
3464
 
         maxparacount:=0;
3465
 
         ppufile.gettype(rettype);
3466
 
{$ifdef i386}
3467
 
         fpu_used:=ppufile.getbyte;
3468
 
{$else}
3469
 
         ppufile.getbyte;
3470
 
{$endif i386}
3471
 
         proctypeoption:=tproctypeoption(ppufile.getbyte);
3472
 
         proccalloption:=tproccalloption(ppufile.getbyte);
3473
 
         ppufile.getsmallset(procoptions);
3474
 
         { get the number of parameters }
3475
 
         count:=ppufile.getbyte;
3476
 
         savesize:=POINTER_SIZE;
3477
 
         has_paraloc_info:=false;
3478
 
         for i:=1 to count do
3479
 
          begin
3480
 
            hp:=TParaItem.Create;
3481
 
            hp.paratyp:=tvarspez(ppufile.getbyte);
3482
 
            ppufile.gettype(hp.paratype);
3483
 
            ppufile.getderef(hp.defaultvaluederef);
3484
 
            hp.defaultvalue:=nil;
3485
 
            ppufile.getderef(hp.parasymderef);
3486
 
            hp.parasym:=nil;
3487
 
            hp.is_hidden:=boolean(ppufile.getbyte);
3488
 
            if po_explicitparaloc in procoptions then
3489
 
              begin
3490
 
                if po_explicitparaloc in procoptions then
3491
 
                  ppufile.getdata(hp.paraloc,sizeof(hp.paraloc));
3492
 
                has_paraloc_info:=true;
3493
 
              end;
3494
 
            { Parameters are stored left to right in both ppu and memory }
3495
 
            Para.concat(hp);
3496
 
          end;
3497
 
      end;
3498
 
 
3499
 
 
3500
 
    procedure tabstractprocdef.ppuwrite(ppufile:tcompilerppufile);
3501
 
      var
3502
 
        hp : TParaItem;
3503
 
        oldintfcrc : boolean;
3504
 
      begin
3505
 
         { released procdef? }
3506
 
         if not assigned(parast) then
3507
 
           exit;
3508
 
         inherited ppuwritedef(ppufile);
3509
 
         ppufile.puttype(rettype);
3510
 
         oldintfcrc:=ppufile.do_interface_crc;
3511
 
         ppufile.do_interface_crc:=false;
3512
 
{$ifdef i386}
3513
 
         if simplify_ppu then
3514
 
          fpu_used:=0;
3515
 
         ppufile.putbyte(fpu_used);
3516
 
{$else}
3517
 
         ppufile.putbyte(0);
3518
 
{$endif}
3519
 
         ppufile.putbyte(ord(proctypeoption));
3520
 
         ppufile.putbyte(ord(proccalloption));
3521
 
         ppufile.putsmallset(procoptions);
3522
 
         ppufile.do_interface_crc:=oldintfcrc;
3523
 
         { we need to store the count including vs_hidden }
3524
 
         ppufile.putbyte(para.count);
3525
 
         hp:=TParaItem(Para.first);
3526
 
         while assigned(hp) do
3527
 
          begin
3528
 
            ppufile.putbyte(byte(hp.paratyp));
3529
 
            ppufile.puttype(hp.paratype);
3530
 
            ppufile.putderef(hp.defaultvaluederef);
3531
 
            ppufile.putderef(hp.parasymderef);
3532
 
            ppufile.putbyte(byte(hp.is_hidden));
3533
 
            if po_explicitparaloc in procoptions then
3534
 
              ppufile.putdata(hp.paraloc,sizeof(hp.paraloc));
3535
 
 
3536
 
            hp:=TParaItem(hp.next);
3537
 
          end;
3538
 
      end;
3539
 
 
3540
 
 
3541
 
 
3542
 
    function tabstractprocdef.typename_paras(showhidden:boolean) : string;
3543
 
      var
3544
 
        hs,s : string;
3545
 
        hp : TParaItem;
3546
 
        hpc : tconstsym;
3547
 
        first : boolean;
3548
 
      begin
3549
 
        hp:=TParaItem(Para.first);
3550
 
        s:='';
3551
 
        first:=true;
3552
 
        while assigned(hp) do
3553
 
         begin
3554
 
           if (not hp.is_hidden) or
3555
 
              (showhidden) then
3556
 
            begin
3557
 
               if first then
3558
 
                begin
3559
 
                  s:=s+'(';
3560
 
                  first:=false;
3561
 
                end
3562
 
               else
3563
 
                s:=s+',';
3564
 
               case hp.paratyp of
3565
 
                 vs_var :
3566
 
                   s:=s+'var';
3567
 
                 vs_const :
3568
 
                   s:=s+'const';
3569
 
                 vs_out :
3570
 
                   s:=s+'out';
3571
 
               end;
3572
 
               if assigned(hp.paratype.def.typesym) then
3573
 
                 begin
3574
 
                   if s<>'(' then
3575
 
                    s:=s+' ';
3576
 
                   hs:=hp.paratype.def.typesym.realname;
3577
 
                   if hs[1]<>'$' then
3578
 
                     s:=s+hp.paratype.def.typesym.realname
3579
 
                   else
3580
 
                     s:=s+hp.paratype.def.gettypename;
3581
 
                 end
3582
 
               else
3583
 
                 s:=s+hp.paratype.def.gettypename;
3584
 
               { default value }
3585
 
               if assigned(hp.defaultvalue) then
3586
 
                begin
3587
 
                  hpc:=tconstsym(hp.defaultvalue);
3588
 
                  hs:='';
3589
 
                  case hpc.consttyp of
3590
 
                    conststring,
3591
 
                    constresourcestring :
3592
 
                      hs:=strpas(pchar(hpc.value.valueptr));
3593
 
                    constreal :
3594
 
                      str(pbestreal(hpc.value.valueptr)^,hs);
3595
 
                    constpointer :
3596
 
                      hs:=tostr(hpc.value.valueordptr);
3597
 
                    constord :
3598
 
                      begin
3599
 
                        if is_boolean(hpc.consttype.def) then
3600
 
                          begin
3601
 
                            if hpc.value.valueord<>0 then
3602
 
                             hs:='TRUE'
3603
 
                            else
3604
 
                             hs:='FALSE';
3605
 
                          end
3606
 
                        else
3607
 
                          hs:=tostr(hpc.value.valueord);
3608
 
                      end;
3609
 
                    constnil :
3610
 
                      hs:='nil';
3611
 
                    constset :
3612
 
                      hs:='<set>';
3613
 
                  end;
3614
 
                  if hs<>'' then
3615
 
                   s:=s+'="'+hs+'"';
3616
 
                end;
3617
 
             end;
3618
 
           hp:=TParaItem(hp.next);
3619
 
         end;
3620
 
        if not first then
3621
 
         s:=s+')';
3622
 
        if (po_varargs in procoptions) then
3623
 
         s:=s+';VarArgs';
3624
 
        typename_paras:=s;
3625
 
      end;
3626
 
 
3627
 
 
3628
 
    function tabstractprocdef.is_methodpointer:boolean;
3629
 
      begin
3630
 
        result:=false;
3631
 
      end;
3632
 
 
3633
 
 
3634
 
    function tabstractprocdef.is_addressonly:boolean;
3635
 
      begin
3636
 
        result:=true;
3637
 
      end;
3638
 
 
3639
 
 
3640
 
{$ifdef GDB}
3641
 
    function tabstractprocdef.stabstring : pchar;
3642
 
      begin
3643
 
        stabstring := strpnew('abstractproc'+numberstring+';');
3644
 
      end;
3645
 
{$endif GDB}
3646
 
 
3647
 
 
3648
 
{***************************************************************************
3649
 
                                  TPROCDEF
3650
 
***************************************************************************}
3651
 
 
3652
 
    constructor tprocdef.create(level:byte);
3653
 
      begin
3654
 
         inherited create(level);
3655
 
         deftype:=procdef;
3656
 
         has_mangledname:=false;
3657
 
         _mangledname:=nil;
3658
 
         fileinfo:=aktfilepos;
3659
 
         extnumber:=$ffff;
3660
 
         aliasnames:=tstringlist.create;
3661
 
         funcretsym:=nil;
3662
 
         localst := nil;
3663
 
         defref:=nil;
3664
 
         lastwritten:=nil;
3665
 
         refcount:=0;
3666
 
         if (cs_browser in aktmoduleswitches) and make_ref then
3667
 
          begin
3668
 
            defref:=tref.create(defref,@akttokenpos);
3669
 
            inc(refcount);
3670
 
          end;
3671
 
         lastref:=defref;
3672
 
         forwarddef:=true;
3673
 
         interfacedef:=false;
3674
 
         hasforward:=false;
3675
 
         _class := nil;
3676
 
 
3677
 
         new(inlininginfo);
3678
 
         fillchar(inlininginfo^,sizeof(tinlininginfo),0);
3679
 
         overloadnumber:=0;
3680
 
{$ifdef GDB}
3681
 
         isstabwritten := false;
3682
 
{$endif GDB}
3683
 
      end;
3684
 
 
3685
 
 
3686
 
    constructor tprocdef.ppuload(ppufile:tcompilerppufile);
3687
 
      var
3688
 
        level : byte;
3689
 
      begin
3690
 
         inherited ppuload(ppufile);
3691
 
         deftype:=procdef;
3692
 
 
3693
 
         has_mangledname:=boolean(ppufile.getbyte);
3694
 
         if has_mangledname then
3695
 
          _mangledname:=stringdup(ppufile.getstring)
3696
 
         else
3697
 
          _mangledname:=nil;
3698
 
         overloadnumber:=ppufile.getword;
3699
 
         extnumber:=ppufile.getword;
3700
 
         level:=ppufile.getbyte;
3701
 
         ppufile.getderef(_classderef);
3702
 
         ppufile.getderef(procsymderef);
3703
 
         ppufile.getposinfo(fileinfo);
3704
 
         ppufile.getsmallset(symoptions);
3705
 
{$ifdef powerpc}
3706
 
         { library symbol for AmigaOS/MorphOS }
3707
 
         ppufile.getderef(libsymderef);
3708
 
{$endif powerpc}
3709
 
         { inline stuff }
3710
 
         if proccalloption=pocall_inline then
3711
 
           begin
3712
 
             ppufile.getderef(funcretsymderef);
3713
 
             new(inlininginfo);
3714
 
             ppufile.getsmallset(inlininginfo^.flags);
3715
 
           end
3716
 
         else
3717
 
           funcretsym:=nil;
3718
 
 
3719
 
         { load para symtable }
3720
 
         parast:=tparasymtable.create(level);
3721
 
         tparasymtable(parast).ppuload(ppufile);
3722
 
         parast.defowner:=self;
3723
 
         { load local symtable }
3724
 
         if (proccalloption=pocall_inline) or
3725
 
            ((current_module.flags and uf_local_browser)<>0) then
3726
 
          begin
3727
 
            localst:=tlocalsymtable.create(level);
3728
 
            tlocalsymtable(localst).ppuload(ppufile);
3729
 
            localst.defowner:=self;
3730
 
          end
3731
 
         else
3732
 
          localst:=nil;
3733
 
 
3734
 
         { inline stuff }
3735
 
         if proccalloption=pocall_inline then
3736
 
           inlininginfo^.code:=ppuloadnodetree(ppufile)
3737
 
         else
3738
 
           inlininginfo := nil;
3739
 
 
3740
 
         { default values for no persistent data }
3741
 
         if (cs_link_deffile in aktglobalswitches) and
3742
 
            (tf_need_export in target_info.flags) and
3743
 
            (po_exports in procoptions) then
3744
 
           deffile.AddExport(mangledname);
3745
 
         aliasnames:=tstringlist.create;
3746
 
         forwarddef:=false;
3747
 
         interfacedef:=false;
3748
 
         hasforward:=false;
3749
 
         lastref:=nil;
3750
 
         lastwritten:=nil;
3751
 
         defref:=nil;
3752
 
         refcount:=0;
3753
 
{$ifdef GDB}
3754
 
         isstabwritten := false;
3755
 
{$endif GDB}
3756
 
      end;
3757
 
 
3758
 
 
3759
 
    destructor tprocdef.destroy;
3760
 
      begin
3761
 
         if assigned(defref) then
3762
 
           begin
3763
 
             defref.freechain;
3764
 
             defref.free;
3765
 
           end;
3766
 
         aliasnames.free;
3767
 
         if assigned(localst) and (localst.symtabletype<>staticsymtable) then
3768
 
          begin
3769
 
{$ifdef MEMDEBUG}
3770
 
            memproclocalst.start;
3771
 
{$endif MEMDEBUG}
3772
 
            localst.free;
3773
 
{$ifdef MEMDEBUG}
3774
 
            memproclocalst.start;
3775
 
{$endif MEMDEBUG}
3776
 
          end;
3777
 
         if (proccalloption=pocall_inline) and assigned(inlininginfo) then
3778
 
          begin
3779
 
{$ifdef MEMDEBUG}
3780
 
            memprocnodetree.start;
3781
 
{$endif MEMDEBUG}
3782
 
            tnode(inlininginfo^.code).free;
3783
 
{$ifdef MEMDEBUG}
3784
 
            memprocnodetree.start;
3785
 
{$endif MEMDEBUG}
3786
 
          end;
3787
 
         if assigned(inlininginfo) then
3788
 
           dispose(inlininginfo);
3789
 
         if (po_msgstr in procoptions) then
3790
 
           strdispose(messageinf.str);
3791
 
         if assigned(_mangledname) then
3792
 
          begin
3793
 
{$ifdef MEMDEBUG}
3794
 
            memmanglednames.start;
3795
 
{$endif MEMDEBUG}
3796
 
            stringdispose(_mangledname);
3797
 
{$ifdef MEMDEBUG}
3798
 
            memmanglednames.stop;
3799
 
{$endif MEMDEBUG}
3800
 
          end;
3801
 
         inherited destroy;
3802
 
      end;
3803
 
 
3804
 
 
3805
 
    procedure tprocdef.ppuwrite(ppufile:tcompilerppufile);
3806
 
      var
3807
 
        oldintfcrc : boolean;
3808
 
        oldparasymtable,
3809
 
        oldlocalsymtable : tsymtable;
3810
 
      begin
3811
 
         { released procdef? }
3812
 
         if not assigned(parast) then
3813
 
           exit;
3814
 
 
3815
 
         oldparasymtable:=aktparasymtable;
3816
 
         oldlocalsymtable:=aktlocalsymtable;
3817
 
         aktparasymtable:=parast;
3818
 
         aktlocalsymtable:=localst;
3819
 
 
3820
 
         inherited ppuwrite(ppufile);
3821
 
         oldintfcrc:=ppufile.do_interface_crc;
3822
 
         ppufile.do_interface_crc:=false;
3823
 
         ppufile.do_interface_crc:=oldintfcrc;
3824
 
         ppufile.putbyte(byte(has_mangledname));
3825
 
         if has_mangledname then
3826
 
          ppufile.putstring(_mangledname^);
3827
 
         ppufile.putword(overloadnumber);
3828
 
         ppufile.putword(extnumber);
3829
 
         ppufile.putbyte(parast.symtablelevel);
3830
 
         ppufile.putderef(_classderef);
3831
 
         ppufile.putderef(procsymderef);
3832
 
         ppufile.putposinfo(fileinfo);
3833
 
         ppufile.putsmallset(symoptions);
3834
 
{$ifdef powerpc}
3835
 
         { library symbol for AmigaOS/MorphOS }
3836
 
         ppufile.putderef(libsymderef);
3837
 
{$endif powerpc}
3838
 
         { inline stuff }
3839
 
         oldintfcrc:=ppufile.do_crc;
3840
 
         ppufile.do_crc:=false;
3841
 
         if proccalloption=pocall_inline then
3842
 
           begin
3843
 
             ppufile.putderef(funcretsymderef);
3844
 
             ppufile.putsmallset(inlininginfo^.flags);
3845
 
           end;
3846
 
 
3847
 
         ppufile.do_crc:=oldintfcrc;
3848
 
 
3849
 
         { write this entry }
3850
 
         ppufile.writeentry(ibprocdef);
3851
 
 
3852
 
         { Save the para symtable, this is taken from the interface }
3853
 
         tparasymtable(parast).ppuwrite(ppufile);
3854
 
 
3855
 
         { save localsymtable for inline procedures or when local
3856
 
           browser info is requested, this has no influence on the crc }
3857
 
         if (proccalloption=pocall_inline) or
3858
 
            ((current_module.flags and uf_local_browser)<>0) then
3859
 
          begin
3860
 
            oldintfcrc:=ppufile.do_crc;
3861
 
            ppufile.do_crc:=false;
3862
 
            if not assigned(localst) then
3863
 
              insert_localst;
3864
 
            tlocalsymtable(localst).ppuwrite(ppufile);
3865
 
            ppufile.do_crc:=oldintfcrc;
3866
 
          end;
3867
 
 
3868
 
         { node tree for inlining }
3869
 
         oldintfcrc:=ppufile.do_crc;
3870
 
         ppufile.do_crc:=false;
3871
 
         if proccalloption=pocall_inline then
3872
 
           ppuwritenodetree(ppufile,inlininginfo^.code);
3873
 
 
3874
 
         ppufile.do_crc:=oldintfcrc;
3875
 
 
3876
 
         aktparasymtable:=oldparasymtable;
3877
 
         aktlocalsymtable:=oldlocalsymtable;
3878
 
      end;
3879
 
 
3880
 
 
3881
 
    procedure tprocdef.insert_localst;
3882
 
     begin
3883
 
         localst:=tlocalsymtable.create(parast.symtablelevel);
3884
 
         localst.defowner:=self;
3885
 
         { this is used by insert
3886
 
           to check same names in parast and localst }
3887
 
         localst.next:=parast;
3888
 
     end;
3889
 
 
3890
 
 
3891
 
    function tprocdef.fullprocname(showhidden:boolean):string;
3892
 
      var
3893
 
        s : string;
3894
 
        t : ttoken;
3895
 
      begin
3896
 
{$ifdef EXTDEBUG}
3897
 
        showhidden:=true;
3898
 
{$endif EXTDEBUG}
3899
 
        s:='';
3900
 
        if assigned(_class) then
3901
 
         begin
3902
 
           if po_classmethod in procoptions then
3903
 
            s:=s+'class ';
3904
 
           s:=s+_class.objrealname^+'.';
3905
 
         end;
3906
 
        if proctypeoption=potype_operator then
3907
 
          begin
3908
 
            for t:=NOTOKEN to last_overloaded do
3909
 
              if procsym.realname='$'+overloaded_names[t] then
3910
 
                begin
3911
 
                  s:='operator '+arraytokeninfo[t].str+typename_paras(showhidden);
3912
 
                  break;
3913
 
                end;
3914
 
          end
3915
 
        else
3916
 
          s:=s+procsym.realname+typename_paras(showhidden);
3917
 
        case proctypeoption of
3918
 
          potype_constructor:
3919
 
            s:='constructor '+s;
3920
 
          potype_destructor:
3921
 
            s:='destructor '+s;
3922
 
          else
3923
 
            if assigned(rettype.def) and
3924
 
              not(is_void(rettype.def)) then
3925
 
              s:=s+':'+rettype.def.gettypename;
3926
 
        end;
3927
 
        { forced calling convention? }
3928
 
        if (po_hascallingconvention in procoptions) then
3929
 
          s:=s+';'+ProcCallOptionStr[proccalloption];
3930
 
        fullprocname:=s;
3931
 
      end;
3932
 
 
3933
 
 
3934
 
    function tprocdef.is_methodpointer:boolean;
3935
 
      begin
3936
 
        result:=assigned(_class);
3937
 
      end;
3938
 
 
3939
 
 
3940
 
    function tprocdef.is_addressonly:boolean;
3941
 
      begin
3942
 
        result:=assigned(owner) and
3943
 
                (owner.symtabletype<>objectsymtable);
3944
 
      end;
3945
 
 
3946
 
 
3947
 
    function tprocdef.is_visible_for_object(currobjdef:tobjectdef):boolean;
3948
 
      begin
3949
 
        is_visible_for_object:=false;
3950
 
 
3951
 
        { private symbols are allowed when we are in the same
3952
 
          module as they are defined }
3953
 
        if (sp_private in symoptions) and
3954
 
           (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
3955
 
           (owner.defowner.owner.unitid<>0) then
3956
 
          exit;
3957
 
 
3958
 
        { protected symbols are vissible in the module that defines them and
3959
 
          also visible to related objects. The related object must be defined
3960
 
          in the current module }
3961
 
        if (sp_protected in symoptions) and
3962
 
           (
3963
 
            (
3964
 
             (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
3965
 
             (owner.defowner.owner.unitid<>0)
3966
 
            ) and
3967
 
            not(
3968
 
                assigned(currobjdef) and
3969
 
                (currobjdef.owner.unitid=0) and
3970
 
                currobjdef.is_related(tobjectdef(owner.defowner))
3971
 
               )
3972
 
           ) then
3973
 
          exit;
3974
 
 
3975
 
        is_visible_for_object:=true;
3976
 
      end;
3977
 
 
3978
 
 
3979
 
    function tprocdef.getsymtable(t:tgetsymtable):tsymtable;
3980
 
      begin
3981
 
        case t of
3982
 
          gs_local :
3983
 
            getsymtable:=localst;
3984
 
          gs_para :
3985
 
            getsymtable:=parast;
3986
 
          else
3987
 
            getsymtable:=nil;
3988
 
        end;
3989
 
      end;
3990
 
 
3991
 
 
3992
 
    procedure tprocdef.load_references(ppufile:tcompilerppufile;locals:boolean);
3993
 
      var
3994
 
        pos : tfileposinfo;
3995
 
        move_last : boolean;
3996
 
        oldparasymtable,
3997
 
        oldlocalsymtable : tsymtable;
3998
 
      begin
3999
 
        oldparasymtable:=aktparasymtable;
4000
 
        oldlocalsymtable:=aktlocalsymtable;
4001
 
        aktparasymtable:=parast;
4002
 
        aktlocalsymtable:=localst;
4003
 
 
4004
 
        move_last:=lastwritten=lastref;
4005
 
        while (not ppufile.endofentry) do
4006
 
         begin
4007
 
           ppufile.getposinfo(pos);
4008
 
           inc(refcount);
4009
 
           lastref:=tref.create(lastref,@pos);
4010
 
           lastref.is_written:=true;
4011
 
           if refcount=1 then
4012
 
            defref:=lastref;
4013
 
         end;
4014
 
        if move_last then
4015
 
          lastwritten:=lastref;
4016
 
        if ((current_module.flags and uf_local_browser)<>0) and
4017
 
           locals then
4018
 
          begin
4019
 
             tparasymtable(parast).load_references(ppufile,locals);
4020
 
             tlocalsymtable(localst).load_references(ppufile,locals);
4021
 
          end;
4022
 
 
4023
 
        aktparasymtable:=oldparasymtable;
4024
 
        aktlocalsymtable:=oldlocalsymtable;
4025
 
      end;
4026
 
 
4027
 
 
4028
 
    Const
4029
 
      local_symtable_index : word = $8001;
4030
 
 
4031
 
    function tprocdef.write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
4032
 
      var
4033
 
        ref : tref;
4034
 
        pdo : tobjectdef;
4035
 
        move_last : boolean;
4036
 
        d : tderef;
4037
 
        oldparasymtable,
4038
 
        oldlocalsymtable : tsymtable;
4039
 
      begin
4040
 
        d.reset;
4041
 
        move_last:=lastwritten=lastref;
4042
 
        if move_last and
4043
 
           (((current_module.flags and uf_local_browser)=0) or
4044
 
            not locals) then
4045
 
          exit;
4046
 
        oldparasymtable:=aktparasymtable;
4047
 
        oldlocalsymtable:=aktlocalsymtable;
4048
 
        aktparasymtable:=parast;
4049
 
        aktlocalsymtable:=localst;
4050
 
        { write address of this symbol }
4051
 
        d.build(self);
4052
 
        ppufile.putderef(d);
4053
 
        { write refs }
4054
 
        if assigned(lastwritten) then
4055
 
          ref:=lastwritten
4056
 
        else
4057
 
          ref:=defref;
4058
 
        while assigned(ref) do
4059
 
         begin
4060
 
           if ref.moduleindex=current_module.unit_index then
4061
 
             begin
4062
 
                ppufile.putposinfo(ref.posinfo);
4063
 
                ref.is_written:=true;
4064
 
                if move_last then
4065
 
                  lastwritten:=ref;
4066
 
             end
4067
 
           else if not ref.is_written then
4068
 
             move_last:=false
4069
 
           else if move_last then
4070
 
             lastwritten:=ref;
4071
 
           ref:=ref.nextref;
4072
 
         end;
4073
 
        ppufile.writeentry(ibdefref);
4074
 
        write_references:=true;
4075
 
        if ((current_module.flags and uf_local_browser)<>0) and
4076
 
           locals then
4077
 
          begin
4078
 
             pdo:=_class;
4079
 
             if (owner.symtabletype<>localsymtable) then
4080
 
               while assigned(pdo) do
4081
 
                 begin
4082
 
                    if pdo.symtable<>aktrecordsymtable then
4083
 
                      begin
4084
 
                         pdo.symtable.unitid:=local_symtable_index;
4085
 
                         inc(local_symtable_index);
4086
 
                      end;
4087
 
                    pdo:=pdo.childof;
4088
 
                 end;
4089
 
             parast.unitid:=local_symtable_index;
4090
 
             inc(local_symtable_index);
4091
 
             localst.unitid:=local_symtable_index;
4092
 
             inc(local_symtable_index);
4093
 
             tstoredsymtable(parast).write_references(ppufile,locals);
4094
 
             tstoredsymtable(localst).write_references(ppufile,locals);
4095
 
             { decrement for }
4096
 
             local_symtable_index:=local_symtable_index-2;
4097
 
             pdo:=_class;
4098
 
             if (owner.symtabletype<>localsymtable) then
4099
 
               while assigned(pdo) do
4100
 
                 begin
4101
 
                    if pdo.symtable<>aktrecordsymtable then
4102
 
                      dec(local_symtable_index);
4103
 
                    pdo:=pdo.childof;
4104
 
                 end;
4105
 
          end;
4106
 
        aktparasymtable:=oldparasymtable;
4107
 
        aktlocalsymtable:=oldlocalsymtable;
4108
 
      end;
4109
 
 
4110
 
{$ifdef GDB}
4111
 
    function tprocdef.numberstring : string;
4112
 
      begin
4113
 
        { procdefs are always available }
4114
 
        stab_state:=stab_state_written;
4115
 
        result:=inherited numberstring;
4116
 
      end;
4117
 
 
4118
 
 
4119
 
    function tprocdef.stabstring: pchar;
4120
 
      Var
4121
 
        RType : Char;
4122
 
        Obj,Info : String;
4123
 
        stabsstr : string;
4124
 
        p : pchar;
4125
 
      begin
4126
 
        obj := procsym.name;
4127
 
        info := '';
4128
 
        if tprocsym(procsym).is_global then
4129
 
          RType := 'F'
4130
 
        else
4131
 
          RType := 'f';
4132
 
        if assigned(owner) then
4133
 
         begin
4134
 
           if (owner.symtabletype = objectsymtable) then
4135
 
             obj := owner.name^+'__'+procsym.name;
4136
 
           if not(cs_gdb_valgrind in aktglobalswitches) and
4137
 
              (owner.symtabletype=localsymtable) and
4138
 
              assigned(owner.defowner) and
4139
 
              assigned(tprocdef(owner.defowner).procsym) then
4140
 
             info := ','+procsym.name+','+tprocdef(owner.defowner).procsym.name;
4141
 
         end;
4142
 
        stabsstr:=mangledname;
4143
 
        getmem(p,length(stabsstr)+255);
4144
 
        strpcopy(p,'"'+obj+':'+RType
4145
 
              +tstoreddef(rettype.def).numberstring+info+'",'+tostr(n_function)
4146
 
              +',0,'+
4147
 
              tostr(fileinfo.line)
4148
 
              +',');
4149
 
        strpcopy(strend(p),stabsstr);
4150
 
        stabstring:=strnew(p);
4151
 
        freemem(p,length(stabsstr)+255);
4152
 
      end;
4153
 
 
4154
 
 
4155
 
    procedure tprocdef.concatstabto(asmlist : taasmoutput);
4156
 
      begin
4157
 
        { released procdef? }
4158
 
        if not assigned(parast) then
4159
 
          exit;
4160
 
        if (proccalloption=pocall_internproc) then
4161
 
          exit;
4162
 
        { be sure to have a number assigned for this def }
4163
 
        numberstring;
4164
 
        { write stabs }
4165
 
        stab_state:=stab_state_writing;
4166
 
        asmList.concat(Tai_stabs.Create(stabstring));
4167
 
        if not(po_external in procoptions) then
4168
 
          begin
4169
 
            tstoredsymtable(parast).concatstabto(asmlist);
4170
 
            { local type defs and vars should not be written
4171
 
              inside the main proc stab }
4172
 
            if assigned(localst) and
4173
 
               (localst.symtablelevel>main_program_level) then
4174
 
              tstoredsymtable(localst).concatstabto(asmlist);
4175
 
          end;
4176
 
        stab_state:=stab_state_written;
4177
 
      end;
4178
 
{$endif GDB}
4179
 
 
4180
 
 
4181
 
    procedure tprocdef.buildderef;
4182
 
      var
4183
 
        oldparasymtable,
4184
 
        oldlocalsymtable : tsymtable;
4185
 
      begin
4186
 
         oldparasymtable:=aktparasymtable;
4187
 
         oldlocalsymtable:=aktlocalsymtable;
4188
 
         aktparasymtable:=parast;
4189
 
         aktlocalsymtable:=localst;
4190
 
 
4191
 
         inherited buildderef;
4192
 
         _classderef.build(_class);
4193
 
         { procsym that originaly defined this definition, should be in the
4194
 
           same symtable }
4195
 
         procsymderef.build(procsym);
4196
 
{$ifdef powerpc}
4197
 
         { library symbol for AmigaOS/MorphOS }
4198
 
         libsymderef.build(libsym);
4199
 
{$endif powerpc}
4200
 
 
4201
 
         aktparasymtable:=oldparasymtable;
4202
 
         aktlocalsymtable:=oldlocalsymtable;
4203
 
      end;
4204
 
 
4205
 
 
4206
 
    procedure tprocdef.buildderefimpl;
4207
 
      var
4208
 
        oldparasymtable,
4209
 
        oldlocalsymtable : tsymtable;
4210
 
      begin
4211
 
         { released procdef? }
4212
 
         if not assigned(parast) then
4213
 
           exit;
4214
 
 
4215
 
         oldparasymtable:=aktparasymtable;
4216
 
         oldlocalsymtable:=aktlocalsymtable;
4217
 
         aktparasymtable:=parast;
4218
 
         aktlocalsymtable:=localst;
4219
 
 
4220
 
         inherited buildderefimpl;
4221
 
 
4222
 
         { locals }
4223
 
         if assigned(localst) then
4224
 
          begin
4225
 
            tlocalsymtable(localst).buildderef;
4226
 
            tlocalsymtable(localst).buildderefimpl;
4227
 
            funcretsymderef.build(funcretsym);
4228
 
          end;
4229
 
 
4230
 
         { inline tree }
4231
 
         if (proccalloption=pocall_inline) then
4232
 
           inlininginfo^.code.buildderefimpl;
4233
 
 
4234
 
         aktparasymtable:=oldparasymtable;
4235
 
         aktlocalsymtable:=oldlocalsymtable;
4236
 
      end;
4237
 
 
4238
 
 
4239
 
    procedure tprocdef.deref;
4240
 
      var
4241
 
        oldparasymtable,
4242
 
        oldlocalsymtable : tsymtable;
4243
 
      begin
4244
 
         { released procdef? }
4245
 
         if not assigned(parast) then
4246
 
           exit;
4247
 
 
4248
 
         oldparasymtable:=aktparasymtable;
4249
 
         oldlocalsymtable:=aktlocalsymtable;
4250
 
         aktparasymtable:=parast;
4251
 
         aktlocalsymtable:=localst;
4252
 
 
4253
 
         inherited deref;
4254
 
         _class:=tobjectdef(_classderef.resolve);
4255
 
         { procsym that originaly defined this definition, should be in the
4256
 
           same symtable }
4257
 
         procsym:=tprocsym(procsymderef.resolve);
4258
 
{$ifdef powerpc}
4259
 
         { library symbol for AmigaOS/MorphOS }
4260
 
         libsym:=tvarsym(libsymderef.resolve);
4261
 
{$endif powerpc}
4262
 
 
4263
 
         aktparasymtable:=oldparasymtable;
4264
 
         aktlocalsymtable:=oldlocalsymtable;
4265
 
      end;
4266
 
 
4267
 
 
4268
 
    procedure tprocdef.derefimpl;
4269
 
      var
4270
 
        oldparasymtable,
4271
 
        oldlocalsymtable : tsymtable;
4272
 
      begin
4273
 
         oldparasymtable:=aktparasymtable;
4274
 
         oldlocalsymtable:=aktlocalsymtable;
4275
 
         aktparasymtable:=parast;
4276
 
         aktlocalsymtable:=localst;
4277
 
 
4278
 
         { locals }
4279
 
         if assigned(localst) then
4280
 
          begin
4281
 
            { localst }
4282
 
            { we can deref both interface and implementation parts }
4283
 
            tlocalsymtable(localst).deref;
4284
 
            tlocalsymtable(localst).derefimpl;
4285
 
            { funcretsym, this is always located in the localst }
4286
 
            funcretsym:=tsym(funcretsymderef.resolve);
4287
 
          end
4288
 
         else
4289
 
          begin
4290
 
            { safety }
4291
 
            funcretsym:=nil;
4292
 
          end;
4293
 
 
4294
 
        { inline tree }
4295
 
        if (proccalloption=pocall_inline) then
4296
 
          inlininginfo^.code.derefimpl;
4297
 
 
4298
 
        aktparasymtable:=oldparasymtable;
4299
 
        aktlocalsymtable:=oldlocalsymtable;
4300
 
      end;
4301
 
 
4302
 
 
4303
 
    function tprocdef.gettypename : string;
4304
 
      begin
4305
 
         gettypename := FullProcName(false);
4306
 
      end;
4307
 
 
4308
 
 
4309
 
    function tprocdef.mangledname : string;
4310
 
      var
4311
 
        hp : TParaItem;
4312
 
      begin
4313
 
        if assigned(_mangledname) then
4314
 
         begin
4315
 
         {$ifdef compress}
4316
 
           mangledname:=minilzw_decode(_mangledname^);
4317
 
         {$else}
4318
 
           mangledname:=_mangledname^;
4319
 
         {$endif}
4320
 
           exit;
4321
 
         end;
4322
 
        { we need to use the symtable where the procsym is inserted,
4323
 
          because that is visible to the world }
4324
 
        mangledname:=make_mangledname('',procsym.owner,procsym.name);
4325
 
        if overloadnumber>0 then
4326
 
         mangledname:=mangledname+'$'+tostr(overloadnumber);
4327
 
        { add parameter types }
4328
 
        hp:=TParaItem(Para.first);
4329
 
        while assigned(hp) do
4330
 
         begin
4331
 
           if not hp.is_hidden then
4332
 
             mangledname:=mangledname+'$'+hp.paratype.def.mangledparaname;
4333
 
           hp:=TParaItem(hp.next);
4334
 
         end;
4335
 
       {$ifdef compress}
4336
 
        _mangledname:=stringdup(minilzw_encode(mangledname));
4337
 
       {$else}
4338
 
        _mangledname:=stringdup(mangledname);
4339
 
       {$endif}
4340
 
      end;
4341
 
 
4342
 
 
4343
 
    function tprocdef.cplusplusmangledname : string;
4344
 
 
4345
 
      function getcppparaname(p : tdef) : string;
4346
 
 
4347
 
        const
4348
 
           ordtype2str : array[tbasetype] of string[2] = (
4349
 
             '',
4350
 
             'Uc','Us','Ui','Us',
4351
 
             'Sc','s','i','x',
4352
 
             'b','b','b',
4353
 
             'c','w','x');
4354
 
 
4355
 
        var
4356
 
           s : string;
4357
 
 
4358
 
        begin
4359
 
           case p.deftype of
4360
 
              orddef:
4361
 
                s:=ordtype2str[torddef(p).typ];
4362
 
              pointerdef:
4363
 
                s:='P'+getcppparaname(tpointerdef(p).pointertype.def);
4364
 
              else
4365
 
                internalerror(2103001);
4366
 
           end;
4367
 
           getcppparaname:=s;
4368
 
        end;
4369
 
 
4370
 
      var
4371
 
         s,s2 : string;
4372
 
         param : TParaItem;
4373
 
 
4374
 
      begin
4375
 
         s := procsym.realname;
4376
 
         if procsym.owner.symtabletype=objectsymtable then
4377
 
           begin
4378
 
              s2:=upper(tobjectdef(procsym.owner.defowner).typesym.realname);
4379
 
              case proctypeoption of
4380
 
                 potype_destructor:
4381
 
                   s:='_$_'+tostr(length(s2))+s2;
4382
 
                 potype_constructor:
4383
 
                   s:='___'+tostr(length(s2))+s2;
4384
 
                 else
4385
 
                   s:='_'+s+'__'+tostr(length(s2))+s2;
4386
 
              end;
4387
 
 
4388
 
           end
4389
 
         else s:=s+'__';
4390
 
 
4391
 
         s:=s+'F';
4392
 
 
4393
 
         { concat modifiers }
4394
 
         { !!!!! }
4395
 
 
4396
 
         { now we handle the parameters }
4397
 
         param := TParaItem(Para.first);
4398
 
         if assigned(param) then
4399
 
           while assigned(param) do
4400
 
             begin
4401
 
                s2:=getcppparaname(param.paratype.def);
4402
 
                if param.paratyp in [vs_var,vs_out] then
4403
 
                  s2:='R'+s2;
4404
 
                s:=s+s2;
4405
 
                param:=TParaItem(param.next);
4406
 
             end
4407
 
         else
4408
 
           s:=s+'v';
4409
 
         cplusplusmangledname:=s;
4410
 
      end;
4411
 
 
4412
 
 
4413
 
    procedure tprocdef.setmangledname(const s : string);
4414
 
      begin
4415
 
        stringdispose(_mangledname);
4416
 
      {$ifdef compress}
4417
 
        _mangledname:=stringdup(minilzw_encode(s));
4418
 
      {$else}
4419
 
        _mangledname:=stringdup(s);
4420
 
      {$endif}
4421
 
        has_mangledname:=true;
4422
 
      end;
4423
 
 
4424
 
 
4425
 
{***************************************************************************
4426
 
                                 TPROCVARDEF
4427
 
***************************************************************************}
4428
 
 
4429
 
    constructor tprocvardef.create(level:byte);
4430
 
      begin
4431
 
         inherited create(level);
4432
 
         deftype:=procvardef;
4433
 
      end;
4434
 
 
4435
 
 
4436
 
    constructor tprocvardef.ppuload(ppufile:tcompilerppufile);
4437
 
      begin
4438
 
         inherited ppuload(ppufile);
4439
 
         deftype:=procvardef;
4440
 
         { load para symtable }
4441
 
         parast:=tparasymtable.create(unknown_level);
4442
 
         tparasymtable(parast).ppuload(ppufile);
4443
 
         parast.defowner:=self;
4444
 
      end;
4445
 
 
4446
 
 
4447
 
    procedure tprocvardef.ppuwrite(ppufile:tcompilerppufile);
4448
 
      var
4449
 
        oldparasymtable,
4450
 
        oldlocalsymtable : tsymtable;
4451
 
      begin
4452
 
        oldparasymtable:=aktparasymtable;
4453
 
        oldlocalsymtable:=aktlocalsymtable;
4454
 
        aktparasymtable:=parast;
4455
 
        aktlocalsymtable:=nil;
4456
 
 
4457
 
        { here we cannot get a real good value so just give something }
4458
 
        { plausible (PM) }
4459
 
        { a more secure way would be
4460
 
          to allways store in a temp }
4461
 
{$ifdef i386}
4462
 
        if is_fpu(rettype.def) then
4463
 
          fpu_used:={2}maxfpuregs
4464
 
        else
4465
 
          fpu_used:=0;
4466
 
{$endif i386}
4467
 
        inherited ppuwrite(ppufile);
4468
 
 
4469
 
        { Write this entry }
4470
 
        ppufile.writeentry(ibprocvardef);
4471
 
 
4472
 
        { Save the para symtable, this is taken from the interface }
4473
 
        tparasymtable(parast).ppuwrite(ppufile);
4474
 
 
4475
 
        aktparasymtable:=oldparasymtable;
4476
 
        aktlocalsymtable:=oldlocalsymtable;
4477
 
      end;
4478
 
 
4479
 
 
4480
 
    procedure tprocvardef.buildderef;
4481
 
      var
4482
 
        oldparasymtable,
4483
 
        oldlocalsymtable : tsymtable;
4484
 
      begin
4485
 
        oldparasymtable:=aktparasymtable;
4486
 
        oldlocalsymtable:=aktlocalsymtable;
4487
 
        aktparasymtable:=parast;
4488
 
        aktlocalsymtable:=nil;
4489
 
 
4490
 
        inherited buildderef;
4491
 
 
4492
 
        aktparasymtable:=oldparasymtable;
4493
 
        aktlocalsymtable:=oldlocalsymtable;
4494
 
      end;
4495
 
 
4496
 
 
4497
 
    procedure tprocvardef.deref;
4498
 
      var
4499
 
        oldparasymtable,
4500
 
        oldlocalsymtable : tsymtable;
4501
 
      begin
4502
 
        oldparasymtable:=aktparasymtable;
4503
 
        oldlocalsymtable:=aktlocalsymtable;
4504
 
        aktparasymtable:=parast;
4505
 
        aktlocalsymtable:=nil;
4506
 
 
4507
 
        inherited deref;
4508
 
 
4509
 
        aktparasymtable:=oldparasymtable;
4510
 
        aktlocalsymtable:=oldlocalsymtable;
4511
 
      end;
4512
 
 
4513
 
 
4514
 
    function tprocvardef.getsymtable(t:tgetsymtable):tsymtable;
4515
 
      begin
4516
 
        case t of
4517
 
          gs_para :
4518
 
            getsymtable:=parast;
4519
 
          else
4520
 
            getsymtable:=nil;
4521
 
        end;
4522
 
      end;
4523
 
 
4524
 
 
4525
 
    function tprocvardef.size : longint;
4526
 
      begin
4527
 
         if (po_methodpointer in procoptions) and
4528
 
            not(po_addressonly in procoptions) then
4529
 
           size:=2*POINTER_SIZE
4530
 
         else
4531
 
           size:=POINTER_SIZE;
4532
 
      end;
4533
 
 
4534
 
 
4535
 
    function tprocvardef.is_methodpointer:boolean;
4536
 
      begin
4537
 
        result:=(po_methodpointer in procoptions);
4538
 
      end;
4539
 
 
4540
 
 
4541
 
    function tprocvardef.is_addressonly:boolean;
4542
 
      begin
4543
 
        result:=not(po_methodpointer in procoptions) or
4544
 
                (po_addressonly in procoptions);
4545
 
      end;
4546
 
 
4547
 
 
4548
 
{$ifdef GDB}
4549
 
    function tprocvardef.stabstring : pchar;
4550
 
      var
4551
 
         nss : pchar;
4552
 
        { i   : longint; }
4553
 
      begin
4554
 
        { i := maxparacount; }
4555
 
        getmem(nss,1024);
4556
 
        { it is not a function but a function pointer !! (PM) }
4557
 
 
4558
 
        strpcopy(nss,'*f'+tstoreddef(rettype.def).numberstring{+','+tostr(i)});
4559
 
        { this confuses gdb !!
4560
 
          we should use 'F' instead of 'f' but
4561
 
          as we use c++ language mode
4562
 
          it does not like that either
4563
 
          Please do not remove this part
4564
 
          might be used once
4565
 
          gdb for pascal is ready PM }
4566
 
      {$ifdef disabled}
4567
 
        param := para1;
4568
 
        i := 0;
4569
 
        while assigned(param) do
4570
 
          begin
4571
 
            inc(i);
4572
 
            if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
4573
 
            {Here we have lost the parameter names !!}
4574
 
            pst := strpnew('p'+tostr(i)+':'+param^.paratype.def.numberstring+','+vartyp+';');
4575
 
            strcat(nss,pst);
4576
 
            strdispose(pst);
4577
 
            param := param^.next;
4578
 
          end;
4579
 
      {$endif}
4580
 
        {strpcopy(strend(nss),';');}
4581
 
        stabstring := strnew(nss);
4582
 
        freemem(nss,1024);
4583
 
      end;
4584
 
 
4585
 
 
4586
 
    procedure tprocvardef.concatstabto(asmlist : taasmoutput);
4587
 
      begin
4588
 
        if (stab_state in [stab_state_writing,stab_state_written]) then
4589
 
          exit;
4590
 
        tstoreddef(rettype.def).concatstabto(asmlist);
4591
 
        inherited concatstabto(asmlist);
4592
 
      end;
4593
 
{$endif GDB}
4594
 
 
4595
 
 
4596
 
    procedure tprocvardef.write_rtti_data(rt:trttitype);
4597
 
      var
4598
 
         pdc : TParaItem;
4599
 
         methodkind, paraspec : byte;
4600
 
      begin
4601
 
        if po_methodpointer in procoptions then
4602
 
          begin
4603
 
             { write method id and name }
4604
 
             rttiList.concat(Tai_const.Create_8bit(tkmethod));
4605
 
             write_rtti_name;
4606
 
 
4607
 
             { write kind of method (can only be function or procedure)}
4608
 
             if rettype.def = voidtype.def then
4609
 
               methodkind := mkProcedure
4610
 
             else
4611
 
               methodkind := mkFunction;
4612
 
             rttiList.concat(Tai_const.Create_8bit(methodkind));
4613
 
 
4614
 
             { get # of parameters }
4615
 
             rttiList.concat(Tai_const.Create_8bit(maxparacount));
4616
 
 
4617
 
             { write parameter info. The parameters must be written in reverse order
4618
 
               if this method uses right to left parameter pushing! }
4619
 
             if proccalloption in pushleftright_pocalls then
4620
 
              pdc:=TParaItem(Para.first)
4621
 
             else
4622
 
              pdc:=TParaItem(Para.last);
4623
 
             while assigned(pdc) do
4624
 
               begin
4625
 
                 { only store user visible parameters }
4626
 
                 if not pdc.is_hidden then
4627
 
                   begin
4628
 
                     case pdc.paratyp of
4629
 
                       vs_value: paraspec := 0;
4630
 
                       vs_const: paraspec := pfConst;
4631
 
                       vs_var  : paraspec := pfVar;
4632
 
                       vs_out  : paraspec := pfOut;
4633
 
                     end;
4634
 
                     { write flags for current parameter }
4635
 
                     rttiList.concat(Tai_const.Create_8bit(paraspec));
4636
 
                     { write name of current parameter }
4637
 
                     if assigned(pdc.parasym) then
4638
 
                       begin
4639
 
                         rttiList.concat(Tai_const.Create_8bit(length(pdc.parasym.realname)));
4640
 
                         rttiList.concat(Tai_string.Create(pdc.parasym.realname));
4641
 
                       end
4642
 
                     else
4643
 
                       rttiList.concat(Tai_const.Create_8bit(0));
4644
 
 
4645
 
                     { write name of type of current parameter }
4646
 
                     tstoreddef(pdc.paratype.def).write_rtti_name;
4647
 
                   end;
4648
 
                 if proccalloption in pushleftright_pocalls then
4649
 
                  pdc:=TParaItem(pdc.next)
4650
 
                 else
4651
 
                  pdc:=TParaItem(pdc.previous);
4652
 
               end;
4653
 
 
4654
 
             { write name of result type }
4655
 
             tstoreddef(rettype.def).write_rtti_name;
4656
 
          end;
4657
 
      end;
4658
 
 
4659
 
 
4660
 
    function tprocvardef.is_publishable : boolean;
4661
 
      begin
4662
 
         is_publishable:=(po_methodpointer in procoptions);
4663
 
      end;
4664
 
 
4665
 
 
4666
 
    function tprocvardef.gettypename : string;
4667
 
      var
4668
 
        s: string;
4669
 
        showhidden : boolean;
4670
 
      begin
4671
 
{$ifdef EXTDEBUG}
4672
 
         showhidden:=true;
4673
 
{$else EXTDEBUG}
4674
 
         showhidden:=false;
4675
 
{$endif EXTDEBUG}
4676
 
         s:='<';
4677
 
         if po_classmethod in procoptions then
4678
 
           s := s+'class method type of'
4679
 
         else
4680
 
           if po_addressonly in procoptions then
4681
 
             s := s+'address of'
4682
 
           else
4683
 
             s := s+'procedure variable type of';
4684
 
         if assigned(rettype.def) and
4685
 
            (rettype.def<>voidtype.def) then
4686
 
           s:=s+' function'+typename_paras(showhidden)+':'+rettype.def.gettypename
4687
 
         else
4688
 
           s:=s+' procedure'+typename_paras(showhidden);
4689
 
         if po_methodpointer in procoptions then
4690
 
           s := s+' of object';
4691
 
         gettypename := s+';'+ProcCallOptionStr[proccalloption]+'>';
4692
 
      end;
4693
 
 
4694
 
 
4695
 
{***************************************************************************
4696
 
                              TOBJECTDEF
4697
 
***************************************************************************}
4698
 
 
4699
 
 
4700
 
   constructor tobjectdef.create(ot : tobjectdeftype;const n : string;c : tobjectdef);
4701
 
     begin
4702
 
        inherited create;
4703
 
        objecttype:=ot;
4704
 
        deftype:=objectdef;
4705
 
        objectoptions:=[];
4706
 
        childof:=nil;
4707
 
        symtable:=tobjectsymtable.create(n,aktpackrecords);
4708
 
        { create space for vmt !! }
4709
 
        vmt_offset:=0;
4710
 
        symtable.defowner:=self;
4711
 
        lastvtableindex:=0;
4712
 
        set_parent(c);
4713
 
        objname:=stringdup(upper(n));
4714
 
        objrealname:=stringdup(n);
4715
 
        if objecttype in [odt_interfacecorba,odt_interfacecom] then
4716
 
          prepareguid;
4717
 
        { setup implemented interfaces }
4718
 
        if objecttype in [odt_class,odt_interfacecorba] then
4719
 
          implementedinterfaces:=timplementedinterfaces.create
4720
 
        else
4721
 
          implementedinterfaces:=nil;
4722
 
 
4723
 
{$ifdef GDB}
4724
 
        writing_class_record_stab:=false;
4725
 
{$endif GDB}
4726
 
     end;
4727
 
 
4728
 
 
4729
 
    constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
4730
 
      var
4731
 
         i,implintfcount: longint;
4732
 
         d : tderef;
4733
 
      begin
4734
 
         inherited ppuloaddef(ppufile);
4735
 
         deftype:=objectdef;
4736
 
         objecttype:=tobjectdeftype(ppufile.getbyte);
4737
 
         savesize:=ppufile.getlongint;
4738
 
         vmt_offset:=ppufile.getlongint;
4739
 
         objrealname:=stringdup(ppufile.getstring);
4740
 
         objname:=stringdup(upper(objrealname^));
4741
 
         ppufile.getderef(childofderef);
4742
 
         ppufile.getsmallset(objectoptions);
4743
 
 
4744
 
         { load guid }
4745
 
         iidstr:=nil;
4746
 
         if objecttype in [odt_interfacecom,odt_interfacecorba] then
4747
 
           begin
4748
 
              new(iidguid);
4749
 
              ppufile.getguid(iidguid^);
4750
 
              iidstr:=stringdup(ppufile.getstring);
4751
 
              lastvtableindex:=ppufile.getlongint;
4752
 
           end;
4753
 
 
4754
 
         { load implemented interfaces }
4755
 
         if objecttype in [odt_class,odt_interfacecorba] then
4756
 
           begin
4757
 
             implementedinterfaces:=timplementedinterfaces.create;
4758
 
             implintfcount:=ppufile.getlongint;
4759
 
             for i:=1 to implintfcount do
4760
 
               begin
4761
 
                  ppufile.getderef(d);
4762
 
                  implementedinterfaces.addintf_deref(d);
4763
 
                  implementedinterfaces.ioffsets(i)^:=ppufile.getlongint;
4764
 
               end;
4765
 
           end
4766
 
         else
4767
 
           implementedinterfaces:=nil;
4768
 
 
4769
 
         symtable:=tobjectsymtable.create(objrealname^,aktpackrecords);
4770
 
         tobjectsymtable(symtable).datasize:=ppufile.getlongint;
4771
 
         tobjectsymtable(symtable).fieldalignment:=ppufile.getbyte;
4772
 
         tobjectsymtable(symtable).recordalignment:=ppufile.getbyte;
4773
 
         tobjectsymtable(symtable).ppuload(ppufile);
4774
 
 
4775
 
         symtable.defowner:=self;
4776
 
 
4777
 
         { handles the predefined class tobject  }
4778
 
         { the last TOBJECT which is loaded gets }
4779
 
         { it !                                  }
4780
 
         if (childof=nil) and
4781
 
            (objecttype=odt_class) and
4782
 
            (objname^='TOBJECT') then
4783
 
           class_tobject:=self;
4784
 
         if (childof=nil) and
4785
 
            (objecttype=odt_interfacecom) and
4786
 
            (objname^='IUNKNOWN') then
4787
 
           interface_iunknown:=self;
4788
 
{$ifdef GDB}
4789
 
         writing_class_record_stab:=false;
4790
 
{$endif GDB}
4791
 
       end;
4792
 
 
4793
 
 
4794
 
   destructor tobjectdef.destroy;
4795
 
     begin
4796
 
        if assigned(symtable) then
4797
 
          symtable.free;
4798
 
        stringdispose(objname);
4799
 
        stringdispose(objrealname);
4800
 
        if assigned(iidstr) then
4801
 
          stringdispose(iidstr);
4802
 
        if assigned(implementedinterfaces) then
4803
 
          implementedinterfaces.free;
4804
 
        if assigned(iidguid) then
4805
 
          dispose(iidguid);
4806
 
        inherited destroy;
4807
 
     end;
4808
 
 
4809
 
 
4810
 
    procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
4811
 
      var
4812
 
         implintfcount : longint;
4813
 
         i : longint;
4814
 
      begin
4815
 
         inherited ppuwritedef(ppufile);
4816
 
         ppufile.putbyte(byte(objecttype));
4817
 
         ppufile.putlongint(size);
4818
 
         ppufile.putlongint(vmt_offset);
4819
 
         ppufile.putstring(objrealname^);
4820
 
         ppufile.putderef(childofderef);
4821
 
         ppufile.putsmallset(objectoptions);
4822
 
         if objecttype in [odt_interfacecom,odt_interfacecorba] then
4823
 
           begin
4824
 
              ppufile.putguid(iidguid^);
4825
 
              ppufile.putstring(iidstr^);
4826
 
              ppufile.putlongint(lastvtableindex);
4827
 
           end;
4828
 
 
4829
 
         if objecttype in [odt_class,odt_interfacecorba] then
4830
 
           begin
4831
 
              implintfcount:=implementedinterfaces.count;
4832
 
              ppufile.putlongint(implintfcount);
4833
 
              for i:=1 to implintfcount do
4834
 
                begin
4835
 
                   ppufile.putderef(implementedinterfaces.interfacesderef(i));
4836
 
                   ppufile.putlongint(implementedinterfaces.ioffsets(i)^);
4837
 
                end;
4838
 
           end;
4839
 
 
4840
 
         ppufile.putlongint(tobjectsymtable(symtable).datasize);
4841
 
         ppufile.putbyte(tobjectsymtable(symtable).fieldalignment);
4842
 
         ppufile.putbyte(tobjectsymtable(symtable).recordalignment);
4843
 
         ppufile.writeentry(ibobjectdef);
4844
 
 
4845
 
         tobjectsymtable(symtable).ppuwrite(ppufile);
4846
 
      end;
4847
 
 
4848
 
 
4849
 
    function tobjectdef.gettypename:string;
4850
 
      begin
4851
 
        gettypename:=typename;
4852
 
      end;
4853
 
 
4854
 
 
4855
 
    procedure tobjectdef.buildderef;
4856
 
      var
4857
 
         oldrecsyms : tsymtable;
4858
 
      begin
4859
 
         inherited buildderef;
4860
 
         childofderef.build(childof);
4861
 
         oldrecsyms:=aktrecordsymtable;
4862
 
         aktrecordsymtable:=symtable;
4863
 
         tstoredsymtable(symtable).buildderef;
4864
 
         aktrecordsymtable:=oldrecsyms;
4865
 
         if objecttype in [odt_class,odt_interfacecorba] then
4866
 
           implementedinterfaces.buildderef;
4867
 
      end;
4868
 
 
4869
 
 
4870
 
    procedure tobjectdef.deref;
4871
 
      var
4872
 
         oldrecsyms : tsymtable;
4873
 
      begin
4874
 
         inherited deref;
4875
 
         childof:=tobjectdef(childofderef.resolve);
4876
 
         oldrecsyms:=aktrecordsymtable;
4877
 
         aktrecordsymtable:=symtable;
4878
 
         tstoredsymtable(symtable).deref;
4879
 
         aktrecordsymtable:=oldrecsyms;
4880
 
         if objecttype in [odt_class,odt_interfacecorba] then
4881
 
           implementedinterfaces.deref;
4882
 
      end;
4883
 
 
4884
 
 
4885
 
    function tobjectdef.getparentdef:tdef;
4886
 
      begin
4887
 
        result:=childof;
4888
 
      end;
4889
 
 
4890
 
 
4891
 
    procedure tobjectdef.prepareguid;
4892
 
      begin
4893
 
        { set up guid }
4894
 
        if not assigned(iidguid) then
4895
 
         begin
4896
 
            new(iidguid);
4897
 
            fillchar(iidguid^,sizeof(iidguid^),0); { default null guid }
4898
 
         end;
4899
 
        { setup iidstring }
4900
 
        if not assigned(iidstr) then
4901
 
          iidstr:=stringdup(''); { default is empty string }
4902
 
      end;
4903
 
 
4904
 
 
4905
 
    procedure tobjectdef.set_parent( c : tobjectdef);
4906
 
      begin
4907
 
        { nothing to do if the parent was not forward !}
4908
 
        if assigned(childof) then
4909
 
          exit;
4910
 
        childof:=c;
4911
 
        { some options are inherited !! }
4912
 
        if assigned(c) then
4913
 
          begin
4914
 
             { only important for classes }
4915
 
             lastvtableindex:=c.lastvtableindex;
4916
 
             objectoptions:=objectoptions+(c.objectoptions*
4917
 
               [oo_has_virtual,oo_has_private,oo_has_protected,
4918
 
                oo_has_constructor,oo_has_destructor]);
4919
 
             if not (objecttype in [odt_interfacecom,odt_interfacecorba]) then
4920
 
               begin
4921
 
                  { add the data of the anchestor class }
4922
 
                  inc(tobjectsymtable(symtable).datasize,tobjectsymtable(c.symtable).datasize);
4923
 
                  if (oo_has_vmt in objectoptions) and
4924
 
                     (oo_has_vmt in c.objectoptions) then
4925
 
                    dec(tobjectsymtable(symtable).datasize,POINTER_SIZE);
4926
 
                  { if parent has a vmt field then
4927
 
                    the offset is the same for the child PM }
4928
 
                  if (oo_has_vmt in c.objectoptions) or is_class(self) then
4929
 
                    begin
4930
 
                       vmt_offset:=c.vmt_offset;
4931
 
                       include(objectoptions,oo_has_vmt);
4932
 
                    end;
4933
 
               end;
4934
 
          end;
4935
 
        savesize := tobjectsymtable(symtable).datasize;
4936
 
      end;
4937
 
 
4938
 
 
4939
 
   procedure tobjectdef.insertvmt;
4940
 
     begin
4941
 
        if objecttype in [odt_interfacecom,odt_interfacecorba] then
4942
 
          exit;
4943
 
        if (oo_has_vmt in objectoptions) then
4944
 
          internalerror(12345)
4945
 
        else
4946
 
          begin
4947
 
             tobjectsymtable(symtable).datasize:=align(tobjectsymtable(symtable).datasize,
4948
 
                 tobjectsymtable(symtable).fieldalignment);
4949
 
             vmt_offset:=tobjectsymtable(symtable).datasize;
4950
 
             inc(tobjectsymtable(symtable).datasize,POINTER_SIZE);
4951
 
             include(objectoptions,oo_has_vmt);
4952
 
          end;
4953
 
     end;
4954
 
 
4955
 
 
4956
 
 
4957
 
   procedure tobjectdef.check_forwards;
4958
 
     begin
4959
 
        if not(objecttype in [odt_interfacecom,odt_interfacecorba]) then
4960
 
          tstoredsymtable(symtable).check_forwards;
4961
 
        if (oo_is_forward in objectoptions) then
4962
 
          begin
4963
 
             { ok, in future, the forward can be resolved }
4964
 
             Message1(sym_e_class_forward_not_resolved,objrealname^);
4965
 
             exclude(objectoptions,oo_is_forward);
4966
 
          end;
4967
 
     end;
4968
 
 
4969
 
 
4970
 
   { true, if self inherits from d (or if they are equal) }
4971
 
   function tobjectdef.is_related(d : tobjectdef) : boolean;
4972
 
     var
4973
 
        hp : tobjectdef;
4974
 
     begin
4975
 
        hp:=self;
4976
 
        while assigned(hp) do
4977
 
          begin
4978
 
             if hp=d then
4979
 
               begin
4980
 
                  is_related:=true;
4981
 
                  exit;
4982
 
               end;
4983
 
             hp:=hp.childof;
4984
 
          end;
4985
 
        is_related:=false;
4986
 
     end;
4987
 
 
4988
 
 
4989
 
(*   procedure tobjectdef._searchdestructor(sym : tnamedindexitem;arg:pointer);
4990
 
 
4991
 
     var
4992
 
        p : pprocdeflist;
4993
 
 
4994
 
     begin
4995
 
        { if we found already a destructor, then we exit }
4996
 
        if assigned(sd) then
4997
 
          exit;
4998
 
        if tsym(sym).typ=procsym then
4999
 
          begin
5000
 
             p:=tprocsym(sym).defs;
5001
 
             while assigned(p) do
5002
 
               begin
5003
 
                  if p^.def.proctypeoption=potype_destructor then
5004
 
                    begin
5005
 
                       sd:=p^.def;
5006
 
                       exit;
5007
 
                    end;
5008
 
                  p:=p^.next;
5009
 
               end;
5010
 
          end;
5011
 
     end;*)
5012
 
 
5013
 
    procedure _searchdestructor(sym:Tnamedindexitem;sd:pointer);
5014
 
 
5015
 
    begin
5016
 
        { if we found already a destructor, then we exit }
5017
 
        if (ppointer(sd)^=nil) and
5018
 
           (Tsym(sym).typ=procsym) then
5019
 
          ppointer(sd)^:=Tprocsym(sym).search_procdef_bytype(potype_destructor);
5020
 
    end;
5021
 
 
5022
 
   function tobjectdef.searchdestructor : tprocdef;
5023
 
 
5024
 
     var
5025
 
        o : tobjectdef;
5026
 
        sd : tprocdef;
5027
 
     begin
5028
 
        searchdestructor:=nil;
5029
 
        o:=self;
5030
 
        sd:=nil;
5031
 
        while assigned(o) do
5032
 
          begin
5033
 
             o.symtable.foreach_static({$ifdef FPCPROCVAR}@{$endif}_searchdestructor,@sd);
5034
 
             if assigned(sd) then
5035
 
               begin
5036
 
                  searchdestructor:=sd;
5037
 
                  exit;
5038
 
               end;
5039
 
             o:=o.childof;
5040
 
          end;
5041
 
     end;
5042
 
 
5043
 
 
5044
 
    function tobjectdef.size : longint;
5045
 
      begin
5046
 
        if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba] then
5047
 
          result:=POINTER_SIZE
5048
 
        else
5049
 
          result:=tobjectsymtable(symtable).datasize;
5050
 
      end;
5051
 
 
5052
 
 
5053
 
    function tobjectdef.alignment:longint;
5054
 
      begin
5055
 
        if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba] then
5056
 
          alignment:=POINTER_SIZE
5057
 
        else
5058
 
          alignment:=tobjectsymtable(symtable).recordalignment;
5059
 
      end;
5060
 
 
5061
 
 
5062
 
    function tobjectdef.vmtmethodoffset(index:longint):longint;
5063
 
      begin
5064
 
        { for offset of methods for classes, see rtl/inc/objpash.inc }
5065
 
        case objecttype of
5066
 
        odt_class:
5067
 
          vmtmethodoffset:=(index+12)*POINTER_SIZE;
5068
 
        odt_interfacecom,odt_interfacecorba:
5069
 
          vmtmethodoffset:=index*POINTER_SIZE;
5070
 
        else
5071
 
{$ifdef WITHDMT}
5072
 
          vmtmethodoffset:=(index+4)*POINTER_SIZE;
5073
 
{$else WITHDMT}
5074
 
          vmtmethodoffset:=(index+3)*POINTER_SIZE;
5075
 
{$endif WITHDMT}
5076
 
        end;
5077
 
      end;
5078
 
 
5079
 
 
5080
 
    function tobjectdef.vmt_mangledname : string;
5081
 
    begin
5082
 
      if not(oo_has_vmt in objectoptions) then
5083
 
        Message1(parser_n_object_has_no_vmt,objrealname^);
5084
 
      vmt_mangledname:=make_mangledname('VMT',owner,objname^);
5085
 
    end;
5086
 
 
5087
 
 
5088
 
    function tobjectdef.rtti_name : string;
5089
 
    begin
5090
 
      rtti_name:=make_mangledname('RTTI',owner,objname^);
5091
 
    end;
5092
 
 
5093
 
 
5094
 
{$ifdef GDB}
5095
 
    procedure tobjectdef.proc_addname(p :tnamedindexitem;arg:pointer);
5096
 
      var virtualind,argnames : string;
5097
 
          newrec : pchar;
5098
 
          pd     : tprocdef;
5099
 
          lindex : longint;
5100
 
          para : TParaItem;
5101
 
          arglength : byte;
5102
 
          sp : char;
5103
 
          state:^Trecord_stabgen_state;
5104
 
          olds:integer;
5105
 
      begin
5106
 
        state:=arg;
5107
 
        if tsym(p).typ = procsym then
5108
 
         begin
5109
 
           pd := tprocsym(p).first_procdef;
5110
 
           if (po_virtualmethod in pd.procoptions) then
5111
 
             begin
5112
 
               lindex := pd.extnumber;
5113
 
               {doesnt seem to be necessary
5114
 
               lindex := lindex or $80000000;}
5115
 
               virtualind := '*'+tostr(lindex)+';'+pd._class.classnumberstring+';'
5116
 
             end
5117
 
            else
5118
 
             virtualind := '.';
5119
 
 
5120
 
            { used by gdbpas to recognize constructor and destructors }
5121
 
            if (pd.proctypeoption=potype_constructor) then
5122
 
              argnames:='__ct__'
5123
 
            else if (pd.proctypeoption=potype_destructor) then
5124
 
              argnames:='__dt__'
5125
 
            else
5126
 
              argnames := '';
5127
 
 
5128
 
           { arguments are not listed here }
5129
 
           {we don't need another definition}
5130
 
            para := TParaItem(pd.Para.first);
5131
 
            while assigned(para) do
5132
 
              begin
5133
 
                if Para.paratype.def.deftype = formaldef then
5134
 
                  begin
5135
 
                    case Para.paratyp of
5136
 
                      vs_var :
5137
 
                        argnames := argnames+'3var';
5138
 
                      vs_const :
5139
 
                        argnames:=argnames+'5const';
5140
 
                      vs_out :
5141
 
                        argnames:=argnames+'3out';
5142
 
                    end;
5143
 
                  end
5144
 
                else
5145
 
                  begin
5146
 
                    { if the arg definition is like (v: ^byte;..
5147
 
                    there is no sym attached to data !!! }
5148
 
                    if assigned(Para.paratype.def.typesym) then
5149
 
                      begin
5150
 
                        arglength := length(Para.paratype.def.typesym.name);
5151
 
                        argnames := argnames + tostr(arglength)+Para.paratype.def.typesym.name;
5152
 
                      end
5153
 
                    else
5154
 
                      argnames:=argnames+'11unnamedtype';
5155
 
                  end;
5156
 
                para := TParaItem(Para.next);
5157
 
              end;
5158
 
           { here 2A must be changed for private and protected }
5159
 
           { 0 is private 1 protected and 2 public }
5160
 
           if (sp_private in tsym(p).symoptions) then
5161
 
             sp:='0'
5162
 
           else if (sp_protected in tsym(p).symoptions) then
5163
 
             sp:='1'
5164
 
           else
5165
 
             sp:='2';
5166
 
           newrec:=stabstr_evaluate('$1::$2=##$3;:$4;$5A$6;',[p.name,pd.numberstring,
5167
 
                                    Tstoreddef(pd.rettype.def).numberstring,argnames,sp,
5168
 
                                    virtualind]);
5169
 
           { get spare place for a string at the end }
5170
 
           olds:=state^.stabsize;
5171
 
           inc(state^.stabsize,strlen(newrec));
5172
 
           if state^.stabsize>=state^.staballoc-256 then
5173
 
             begin
5174
 
                inc(state^.staballoc,memsizeinc);
5175
 
                reallocmem(state^.stabstring,state^.staballoc);
5176
 
             end;
5177
 
           strcopy(state^.stabstring+olds,newrec);
5178
 
           strdispose(newrec);
5179
 
           {This should be used for case !!
5180
 
           RecOffset := RecOffset + pd.size;}
5181
 
         end;
5182
 
      end;
5183
 
 
5184
 
 
5185
 
    procedure tobjectdef.proc_concatstabto(p :tnamedindexitem;arg:pointer);
5186
 
      var
5187
 
        pd : tprocdef;
5188
 
      begin
5189
 
        if tsym(p).typ = procsym then
5190
 
          begin
5191
 
            pd := tprocsym(p).first_procdef;
5192
 
            tstoreddef(pd.rettype.def).concatstabto(taasmoutput(arg));
5193
 
          end;
5194
 
      end;
5195
 
 
5196
 
 
5197
 
    function tobjectdef.stabstring : pchar;
5198
 
      var anc : tobjectdef;
5199
 
          state:Trecord_stabgen_state;
5200
 
          ts : string;
5201
 
      begin
5202
 
        if not (objecttype=odt_class) or writing_class_record_stab then
5203
 
          begin
5204
 
            state.staballoc:=memsizeinc;
5205
 
            getmem(state.stabstring,state.staballoc);
5206
 
            strpcopy(state.stabstring,'s'+tostr(tobjectsymtable(symtable).datasize));
5207
 
            if assigned(childof) then
5208
 
              begin
5209
 
                {only one ancestor not virtual, public, at base offset 0 }
5210
 
                {       !1           ,    0       2         0    ,       }
5211
 
                strpcopy(strend(state.stabstring),'!1,020,'+childof.classnumberstring+';');
5212
 
              end;
5213
 
            {virtual table to implement yet}
5214
 
            state.recoffset:=0;
5215
 
            state.stabsize:=strlen(state.stabstring);
5216
 
            symtable.foreach({$ifdef FPCPROCVAR}@{$endif}field_addname,@state);
5217
 
            if (oo_has_vmt in objectoptions) then
5218
 
              if not assigned(childof) or not(oo_has_vmt in childof.objectoptions) then
5219
 
                 begin
5220
 
                    ts:='$vf'+classnumberstring+':'+tstoreddef(vmtarraytype.def).numberstring+','+tostr(vmt_offset*8)+';';
5221
 
                    strpcopy(state.stabstring+state.stabsize,ts);
5222
 
                    inc(state.stabsize,length(ts));
5223
 
                 end;
5224
 
            symtable.foreach({$ifdef FPCPROCVAR}@{$endif}proc_addname,@state);
5225
 
            if (oo_has_vmt in objectoptions) then
5226
 
              begin
5227
 
                 anc := self;
5228
 
                 while assigned(anc.childof) and (oo_has_vmt in anc.childof.objectoptions) do
5229
 
                   anc := anc.childof;
5230
 
                 { just in case anc = self }
5231
 
                 ts:=';~%'+anc.classnumberstring+';';
5232
 
              end
5233
 
            else
5234
 
              ts:=';';
5235
 
            strpcopy(state.stabstring+state.stabsize,ts);
5236
 
            inc(state.stabsize,length(ts));
5237
 
            reallocmem(state.stabstring,state.stabsize+1);
5238
 
            stabstring:=state.stabstring;
5239
 
          end
5240
 
        else
5241
 
          begin
5242
 
            stabstring:=strpnew('*'+classnumberstring);
5243
 
          end;
5244
 
      end;
5245
 
 
5246
 
   procedure tobjectdef.set_globalnb;
5247
 
     begin
5248
 
         globalnb:=PglobalTypeCount^;
5249
 
         inc(PglobalTypeCount^);
5250
 
         { classes need two type numbers, the globalnb is set to the ptr }
5251
 
         if objecttype=odt_class then
5252
 
           begin
5253
 
             globalnb:=PGlobalTypeCount^;
5254
 
             inc(PglobalTypeCount^);
5255
 
           end;
5256
 
     end;
5257
 
 
5258
 
 
5259
 
   function tobjectdef.classnumberstring : string;
5260
 
     begin
5261
 
       if objecttype=odt_class then
5262
 
         begin
5263
 
           if globalnb=0 then
5264
 
             numberstring;
5265
 
           dec(globalnb);
5266
 
           classnumberstring:=numberstring;
5267
 
           inc(globalnb);
5268
 
         end
5269
 
       else
5270
 
         classnumberstring:=numberstring;
5271
 
     end;
5272
 
 
5273
 
 
5274
 
    function tobjectdef.allstabstring : pchar;
5275
 
      var
5276
 
        stabchar : string[2];
5277
 
        ss,st : pchar;
5278
 
        sname : string;
5279
 
      begin
5280
 
        ss := stabstring;
5281
 
        getmem(st,strlen(ss)+512);
5282
 
        stabchar := 't';
5283
 
        if deftype in tagtypes then
5284
 
          stabchar := 'Tt';
5285
 
        if assigned(typesym) then
5286
 
          sname := typesym.name
5287
 
        else
5288
 
          sname := ' ';
5289
 
        if writing_class_record_stab then
5290
 
          strpcopy(st,'"'+sname+':'+stabchar+classnumberstring+'=')
5291
 
        else
5292
 
          strpcopy(st,'"'+sname+':'+stabchar+numberstring+'=');
5293
 
        strpcopy(strecopy(strend(st),ss),'",'+tostr(N_LSYM)+',0,0,0');
5294
 
        allstabstring := strnew(st);
5295
 
        freemem(st,strlen(ss)+512);
5296
 
        strdispose(ss);
5297
 
      end;
5298
 
 
5299
 
 
5300
 
    procedure tobjectdef.concatstabto(asmlist : taasmoutput);
5301
 
      var
5302
 
        oldtypesym : tsym;
5303
 
        stab_str   : pchar;
5304
 
        anc        : tobjectdef;
5305
 
      begin
5306
 
        if (stab_state in [stab_state_writing,stab_state_written]) then
5307
 
          exit;
5308
 
        stab_state:=stab_state_writing;
5309
 
        tstoreddef(vmtarraytype.def).concatstabto(asmlist);
5310
 
        { first the parents }
5311
 
        anc:=self;
5312
 
        while assigned(anc.childof) do
5313
 
          begin
5314
 
            anc:=anc.childof;
5315
 
            anc.concatstabto(asmlist);
5316
 
          end;
5317
 
        symtable.foreach({$ifdef FPCPROCVAR}@{$endif}field_concatstabto,asmlist);
5318
 
        symtable.foreach({$ifdef FPCPROCVAR}@{$endif}proc_concatstabto,asmlist);
5319
 
        stab_state:=stab_state_used;
5320
 
        if objecttype=odt_class then
5321
 
          begin
5322
 
            { Write the record class itself }
5323
 
            writing_class_record_stab:=true;
5324
 
            inherited concatstabto(asmlist);
5325
 
            writing_class_record_stab:=false;
5326
 
            { Write the invisible pointer class }
5327
 
            oldtypesym:=typesym;
5328
 
            typesym:=nil;
5329
 
            stab_str := allstabstring;
5330
 
            asmList.concat(Tai_stabs.Create(stab_str));
5331
 
            typesym:=oldtypesym;
5332
 
          end
5333
 
        else
5334
 
          inherited concatstabto(asmlist);
5335
 
      end;
5336
 
{$endif GDB}
5337
 
 
5338
 
 
5339
 
    function tobjectdef.needs_inittable : boolean;
5340
 
      begin
5341
 
         case objecttype of
5342
 
            odt_class :
5343
 
              needs_inittable:=false;
5344
 
            odt_interfacecom:
5345
 
              needs_inittable:=true;
5346
 
            odt_interfacecorba:
5347
 
              needs_inittable:=is_related(interface_iunknown);
5348
 
            odt_object:
5349
 
              needs_inittable:=tobjectsymtable(symtable).needs_init_final;
5350
 
            else
5351
 
              internalerror(200108267);
5352
 
         end;
5353
 
      end;
5354
 
 
5355
 
 
5356
 
    function tobjectdef.members_need_inittable : boolean;
5357
 
      begin
5358
 
        members_need_inittable:=tobjectsymtable(symtable).needs_init_final;
5359
 
      end;
5360
 
 
5361
 
 
5362
 
    procedure tobjectdef.count_published_properties(sym:tnamedindexitem;arg:pointer);
5363
 
      begin
5364
 
         if needs_prop_entry(tsym(sym)) and
5365
 
          (tsym(sym).typ<>varsym) then
5366
 
           inc(count);
5367
 
      end;
5368
 
 
5369
 
 
5370
 
    procedure tobjectdef.write_property_info(sym : tnamedindexitem;arg:pointer);
5371
 
      var
5372
 
         proctypesinfo : byte;
5373
 
 
5374
 
      procedure writeproc(proc : tsymlist; shiftvalue : byte);
5375
 
 
5376
 
        var
5377
 
           typvalue : byte;
5378
 
           hp : psymlistitem;
5379
 
           address : longint;
5380
 
           def : tdef;
5381
 
        begin
5382
 
           if not(assigned(proc) and assigned(proc.firstsym))  then
5383
 
             begin
5384
 
                rttiList.concat(Tai_const.Create_32bit(1));
5385
 
                typvalue:=3;
5386
 
             end
5387
 
           else if proc.firstsym^.sym.typ=varsym then
5388
 
             begin
5389
 
                address:=0;
5390
 
                hp:=proc.firstsym;
5391
 
                def:=nil;
5392
 
                while assigned(hp) do
5393
 
                  begin
5394
 
                     case hp^.sltype of
5395
 
                       sl_load :
5396
 
                         begin
5397
 
                           def:=tvarsym(hp^.sym).vartype.def;
5398
 
                           inc(address,tvarsym(hp^.sym).fieldoffset);
5399
 
                         end;
5400
 
                       sl_subscript :
5401
 
                         begin
5402
 
                           if not(assigned(def) and (def.deftype=recorddef)) then
5403
 
                             internalerror(200402171);
5404
 
                           inc(address,tvarsym(hp^.sym).fieldoffset);
5405
 
                           def:=tvarsym(hp^.sym).vartype.def;
5406
 
                         end;
5407
 
                       sl_vec :
5408
 
                         begin
5409
 
                           if not(assigned(def) and (def.deftype=arraydef)) then
5410
 
                             internalerror(200402172);
5411
 
                           def:=tarraydef(def).elementtype.def;
5412
 
                           inc(address,def.size*hp^.value);
5413
 
                         end;
5414
 
                     end;
5415
 
                     hp:=hp^.next;
5416
 
                  end;
5417
 
                rttiList.concat(Tai_const.Create_32bit(address));
5418
 
                typvalue:=0;
5419
 
             end
5420
 
           else
5421
 
             begin
5422
 
                { When there was an error then procdef is not assigned }
5423
 
                if not assigned(proc.procdef) then
5424
 
                  exit;
5425
 
                if not(po_virtualmethod in tprocdef(proc.procdef).procoptions) then
5426
 
                  begin
5427
 
                     rttiList.concat(Tai_const_symbol.Createname(tprocdef(proc.procdef).mangledname,AT_FUNCTION,0));
5428
 
                     typvalue:=1;
5429
 
                  end
5430
 
                else
5431
 
                  begin
5432
 
                     { virtual method, write vmt offset }
5433
 
                     rttiList.concat(Tai_const.Create_32bit(
5434
 
                       tprocdef(proc.procdef)._class.vmtmethodoffset(tprocdef(proc.procdef).extnumber)));
5435
 
                     typvalue:=2;
5436
 
                  end;
5437
 
             end;
5438
 
           proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
5439
 
        end;
5440
 
 
5441
 
      begin
5442
 
         if needs_prop_entry(tsym(sym)) then
5443
 
           case tsym(sym).typ of
5444
 
              varsym:
5445
 
                begin
5446
 
{$ifdef dummy}
5447
 
                   if not(tvarsym(sym).vartype.def.deftype=objectdef) or
5448
 
                     not(tobjectdef(tvarsym(sym).vartype.def).is_class) then
5449
 
                     internalerror(1509992);
5450
 
                   { access to implicit class property as field }
5451
 
                   proctypesinfo:=(0 shl 0) or (0 shl 2) or (0 shl 4);
5452
 
                   rttiList.concat(Tai_const_symbol.Createname(tvarsym(sym.vartype.def.get_rtti_label),AT_DATA,0));
5453
 
                   rttiList.concat(Tai_const.Create_32bit(tvarsym(sym.address)));
5454
 
                   rttiList.concat(Tai_const.Create_32bit(tvarsym(sym.address)));
5455
 
                   { per default stored }
5456
 
                   rttiList.concat(Tai_const.Create_32bit(1));
5457
 
                   { index as well as ... }
5458
 
                   rttiList.concat(Tai_const.Create_32bit(0));
5459
 
                   { default value are zero }
5460
 
                   rttiList.concat(Tai_const.Create_32bit(0));
5461
 
                   rttiList.concat(Tai_const.Create_16bit(count));
5462
 
                   inc(count);
5463
 
                   rttiList.concat(Tai_const.Create_8bit(proctypesinfo));
5464
 
                   rttiList.concat(Tai_const.Create_8bit(length(tvarsym(sym.realname))));
5465
 
                   rttiList.concat(Tai_string.Create(tvarsym(sym.realname)));
5466
 
{$endif dummy}
5467
 
                end;
5468
 
              propertysym:
5469
 
                begin
5470
 
                   if ppo_indexed in tpropertysym(sym).propoptions then
5471
 
                     proctypesinfo:=$40
5472
 
                   else
5473
 
                     proctypesinfo:=0;
5474
 
                   rttiList.concat(Tai_const_symbol.Create(tstoreddef(tpropertysym(sym).proptype.def).get_rtti_label(fullrtti)));
5475
 
                   writeproc(tpropertysym(sym).readaccess,0);
5476
 
                   writeproc(tpropertysym(sym).writeaccess,2);
5477
 
                   { isn't it stored ? }
5478
 
                   if not(ppo_stored in tpropertysym(sym).propoptions) then
5479
 
                     begin
5480
 
                        rttiList.concat(Tai_const.Create_ptr(0));
5481
 
                        proctypesinfo:=proctypesinfo or (3 shl 4);
5482
 
                     end
5483
 
                   else
5484
 
                     writeproc(tpropertysym(sym).storedaccess,4);
5485
 
                   rttiList.concat(Tai_const.Create_32bit(tpropertysym(sym).index));
5486
 
                   rttiList.concat(Tai_const.Create_32bit(cardinal(tpropertysym(sym).default)));
5487
 
                   rttiList.concat(Tai_const.Create_16bit(count));
5488
 
                   inc(count);
5489
 
                   rttiList.concat(Tai_const.Create_8bit(proctypesinfo));
5490
 
                   rttiList.concat(Tai_const.Create_8bit(length(tpropertysym(sym).realname)));
5491
 
                   rttiList.concat(Tai_string.Create(tpropertysym(sym).realname));
5492
 
                end;
5493
 
              else internalerror(1509992);
5494
 
           end;
5495
 
      end;
5496
 
 
5497
 
 
5498
 
    procedure tobjectdef.generate_published_child_rtti(sym : tnamedindexitem;arg:pointer);
5499
 
      begin
5500
 
         if needs_prop_entry(tsym(sym)) then
5501
 
          begin
5502
 
            case tsym(sym).typ of
5503
 
              propertysym:
5504
 
                tstoreddef(tpropertysym(sym).proptype.def).get_rtti_label(fullrtti);
5505
 
              varsym:
5506
 
                tstoreddef(tvarsym(sym).vartype.def).get_rtti_label(fullrtti);
5507
 
              else
5508
 
                internalerror(1509991);
5509
 
            end;
5510
 
          end;
5511
 
      end;
5512
 
 
5513
 
 
5514
 
    procedure tobjectdef.write_child_rtti_data(rt:trttitype);
5515
 
      begin
5516
 
         FRTTIType:=rt;
5517
 
         case rt of
5518
 
           initrtti :
5519
 
             symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_field_rtti,nil);
5520
 
           fullrtti :
5521
 
             symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_published_child_rtti,nil);
5522
 
           else
5523
 
             internalerror(200108301);
5524
 
         end;
5525
 
      end;
5526
 
 
5527
 
 
5528
 
    type
5529
 
       tclasslistitem = class(TLinkedListItem)
5530
 
          index : longint;
5531
 
          p : tobjectdef;
5532
 
       end;
5533
 
 
5534
 
    var
5535
 
       classtablelist : tlinkedlist;
5536
 
       tablecount : longint;
5537
 
 
5538
 
    function searchclasstablelist(p : tobjectdef) : tclasslistitem;
5539
 
 
5540
 
      var
5541
 
         hp : tclasslistitem;
5542
 
 
5543
 
      begin
5544
 
         hp:=tclasslistitem(classtablelist.first);
5545
 
         while assigned(hp) do
5546
 
           if hp.p=p then
5547
 
             begin
5548
 
                searchclasstablelist:=hp;
5549
 
                exit;
5550
 
             end
5551
 
           else
5552
 
             hp:=tclasslistitem(hp.next);
5553
 
         searchclasstablelist:=nil;
5554
 
      end;
5555
 
 
5556
 
 
5557
 
    procedure tobjectdef.count_published_fields(sym:tnamedindexitem;arg:pointer);
5558
 
      var
5559
 
         hp : tclasslistitem;
5560
 
      begin
5561
 
         if needs_prop_entry(tsym(sym)) and
5562
 
          (tsym(sym).typ=varsym) then
5563
 
          begin
5564
 
             if tvarsym(sym).vartype.def.deftype<>objectdef then
5565
 
               internalerror(0206001);
5566
 
             hp:=searchclasstablelist(tobjectdef(tvarsym(sym).vartype.def));
5567
 
             if not(assigned(hp)) then
5568
 
               begin
5569
 
                  hp:=tclasslistitem.create;
5570
 
                  hp.p:=tobjectdef(tvarsym(sym).vartype.def);
5571
 
                  hp.index:=tablecount;
5572
 
                  classtablelist.concat(hp);
5573
 
                  inc(tablecount);
5574
 
               end;
5575
 
             inc(count);
5576
 
          end;
5577
 
      end;
5578
 
 
5579
 
 
5580
 
    procedure tobjectdef.writefields(sym:tnamedindexitem;arg:pointer);
5581
 
      var
5582
 
         hp : tclasslistitem;
5583
 
      begin
5584
 
         if needs_prop_entry(tsym(sym)) and
5585
 
          (tsym(sym).typ=varsym) then
5586
 
          begin
5587
 
             rttiList.concat(Tai_const.Create_32bit(tvarsym(sym).fieldoffset));
5588
 
             hp:=searchclasstablelist(tobjectdef(tvarsym(sym).vartype.def));
5589
 
             if not(assigned(hp)) then
5590
 
               internalerror(0206002);
5591
 
             rttiList.concat(Tai_const.Create_16bit(hp.index));
5592
 
             rttiList.concat(Tai_const.Create_8bit(length(tvarsym(sym).realname)));
5593
 
             rttiList.concat(Tai_string.Create(tvarsym(sym).realname));
5594
 
          end;
5595
 
      end;
5596
 
 
5597
 
 
5598
 
    function tobjectdef.generate_field_table : tasmlabel;
5599
 
      var
5600
 
         fieldtable,
5601
 
         classtable : tasmlabel;
5602
 
         hp : tclasslistitem;
5603
 
 
5604
 
      begin
5605
 
         classtablelist:=TLinkedList.Create;
5606
 
         objectlibrary.getdatalabel(fieldtable);
5607
 
         objectlibrary.getdatalabel(classtable);
5608
 
         count:=0;
5609
 
         tablecount:=0;
5610
 
         symtable.foreach({$ifdef FPC}@{$endif}count_published_fields,nil);
5611
 
         if (cs_create_smart in aktmoduleswitches) then
5612
 
          rttiList.concat(Tai_cut.Create);
5613
 
         rttilist.concat(tai_align.create(const_align(pointer_size)));
5614
 
         rttiList.concat(Tai_label.Create(fieldtable));
5615
 
         rttiList.concat(Tai_const.Create_16bit(count));
5616
 
         rttiList.concat(Tai_const_symbol.Create(classtable));
5617
 
         symtable.foreach({$ifdef FPC}@{$endif}writefields,nil);
5618
 
 
5619
 
         { generate the class table }
5620
 
         rttilist.concat(tai_align.create(const_align(pointer_size)));
5621
 
         rttiList.concat(Tai_label.Create(classtable));
5622
 
         rttiList.concat(Tai_const.Create_16bit(tablecount));
5623
 
         hp:=tclasslistitem(classtablelist.first);
5624
 
         while assigned(hp) do
5625
 
           begin
5626
 
              rttiList.concat(Tai_const_symbol.Createname(tobjectdef(hp.p).vmt_mangledname,AT_DATA,0));
5627
 
              hp:=tclasslistitem(hp.next);
5628
 
           end;
5629
 
 
5630
 
         generate_field_table:=fieldtable;
5631
 
         classtablelist.free;
5632
 
      end;
5633
 
 
5634
 
 
5635
 
    function tobjectdef.next_free_name_index : longint;
5636
 
      var
5637
 
         i : longint;
5638
 
      begin
5639
 
         if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
5640
 
           i:=childof.next_free_name_index
5641
 
         else
5642
 
           i:=0;
5643
 
         count:=0;
5644
 
         symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties,nil);
5645
 
         next_free_name_index:=i+count;
5646
 
      end;
5647
 
 
5648
 
 
5649
 
    procedure tobjectdef.write_rtti_data(rt:trttitype);
5650
 
      begin
5651
 
         case objecttype of
5652
 
            odt_class:
5653
 
              rttiList.concat(Tai_const.Create_8bit(tkclass));
5654
 
            odt_object:
5655
 
              rttiList.concat(Tai_const.Create_8bit(tkobject));
5656
 
            odt_interfacecom:
5657
 
              rttiList.concat(Tai_const.Create_8bit(tkinterface));
5658
 
            odt_interfacecorba:
5659
 
              rttiList.concat(Tai_const.Create_8bit(tkinterfaceCorba));
5660
 
          else
5661
 
            exit;
5662
 
          end;
5663
 
 
5664
 
         { generate the name }
5665
 
         rttiList.concat(Tai_const.Create_8bit(length(objrealname^)));
5666
 
         rttiList.concat(Tai_string.Create(objrealname^));
5667
 
 
5668
 
         case rt of
5669
 
           initrtti :
5670
 
             begin
5671
 
               rttiList.concat(Tai_const.Create_32bit(size));
5672
 
               if objecttype in [odt_class,odt_object] then
5673
 
                begin
5674
 
                  count:=0;
5675
 
                  FRTTIType:=rt;
5676
 
                  symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_field_rtti,nil);
5677
 
                  rttiList.concat(Tai_const.Create_32bit(count));
5678
 
                  symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_rtti,nil);
5679
 
                end;
5680
 
             end;
5681
 
           fullrtti :
5682
 
             begin
5683
 
               if (oo_has_vmt in objectoptions) and
5684
 
                  not(objecttype in [odt_interfacecom,odt_interfacecorba]) then
5685
 
                 rttiList.concat(Tai_const_symbol.Createname(vmt_mangledname,AT_DATA,0))
5686
 
               else
5687
 
                 rttiList.concat(Tai_const.Create_ptr(0));
5688
 
 
5689
 
               { write owner typeinfo }
5690
 
               if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
5691
 
                 rttiList.concat(Tai_const_symbol.Create(childof.get_rtti_label(fullrtti)))
5692
 
               else
5693
 
                 rttiList.concat(Tai_const.Create_ptr(0));
5694
 
 
5695
 
               { count total number of properties }
5696
 
               if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
5697
 
                 count:=childof.next_free_name_index
5698
 
               else
5699
 
                 count:=0;
5700
 
 
5701
 
               { write it }
5702
 
               symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties,nil);
5703
 
               rttiList.concat(Tai_const.Create_16bit(count));
5704
 
 
5705
 
               { write unit name }
5706
 
               rttiList.concat(Tai_const.Create_8bit(length(current_module.realmodulename^)));
5707
 
               rttiList.concat(Tai_string.Create(current_module.realmodulename^));
5708
 
 
5709
 
               { write published properties count }
5710
 
               count:=0;
5711
 
               symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties,nil);
5712
 
               rttiList.concat(Tai_const.Create_16bit(count));
5713
 
 
5714
 
               { count is used to write nameindex   }
5715
 
 
5716
 
               { but we need an offset of the owner }
5717
 
               { to give each property an own slot  }
5718
 
               if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
5719
 
                 count:=childof.next_free_name_index
5720
 
               else
5721
 
                 count:=0;
5722
 
 
5723
 
               symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_property_info,nil);
5724
 
             end;
5725
 
         end;
5726
 
      end;
5727
 
 
5728
 
 
5729
 
    function tobjectdef.is_publishable : boolean;
5730
 
      begin
5731
 
         is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba];
5732
 
      end;
5733
 
 
5734
 
 
5735
 
{****************************************************************************
5736
 
                             TIMPLEMENTEDINTERFACES
5737
 
****************************************************************************}
5738
 
    type
5739
 
      tnamemap = class(TNamedIndexItem)
5740
 
        newname: pstring;
5741
 
        constructor create(const aname, anewname: string);
5742
 
        destructor  destroy; override;
5743
 
      end;
5744
 
 
5745
 
    constructor tnamemap.create(const aname, anewname: string);
5746
 
      begin
5747
 
        inherited createname(name);
5748
 
        newname:=stringdup(anewname);
5749
 
      end;
5750
 
 
5751
 
    destructor  tnamemap.destroy;
5752
 
      begin
5753
 
        stringdispose(newname);
5754
 
        inherited destroy;
5755
 
      end;
5756
 
 
5757
 
 
5758
 
    type
5759
 
      tprocdefstore = class(TNamedIndexItem)
5760
 
        procdef: tprocdef;
5761
 
        constructor create(aprocdef: tprocdef);
5762
 
      end;
5763
 
 
5764
 
    constructor tprocdefstore.create(aprocdef: tprocdef);
5765
 
      begin
5766
 
        inherited create;
5767
 
        procdef:=aprocdef;
5768
 
      end;
5769
 
 
5770
 
 
5771
 
    type
5772
 
      timplintfentry = class(TNamedIndexItem)
5773
 
        intf: tobjectdef;
5774
 
        intfderef : tderef;
5775
 
        ioffs: longint;
5776
 
        namemappings: tdictionary;
5777
 
        procdefs: TIndexArray;
5778
 
        constructor create(aintf: tobjectdef);
5779
 
        constructor create_deref(const d:tderef);
5780
 
        destructor  destroy; override;
5781
 
      end;
5782
 
 
5783
 
    constructor timplintfentry.create(aintf: tobjectdef);
5784
 
      begin
5785
 
        inherited create;
5786
 
        intf:=aintf;
5787
 
        ioffs:=-1;
5788
 
        namemappings:=nil;
5789
 
        procdefs:=nil;
5790
 
      end;
5791
 
 
5792
 
 
5793
 
    constructor timplintfentry.create_deref(const d:tderef);
5794
 
      begin
5795
 
        inherited create;
5796
 
        intf:=nil;
5797
 
        intfderef:=d;
5798
 
        ioffs:=-1;
5799
 
        namemappings:=nil;
5800
 
        procdefs:=nil;
5801
 
      end;
5802
 
 
5803
 
 
5804
 
    destructor  timplintfentry.destroy;
5805
 
      begin
5806
 
        if assigned(namemappings) then
5807
 
          namemappings.free;
5808
 
        if assigned(procdefs) then
5809
 
          procdefs.free;
5810
 
        inherited destroy;
5811
 
      end;
5812
 
 
5813
 
 
5814
 
    constructor timplementedinterfaces.create;
5815
 
      begin
5816
 
        finterfaces:=tindexarray.create(1);
5817
 
      end;
5818
 
 
5819
 
    destructor  timplementedinterfaces.destroy;
5820
 
      begin
5821
 
        finterfaces.destroy;
5822
 
      end;
5823
 
 
5824
 
    function  timplementedinterfaces.count: longint;
5825
 
      begin
5826
 
        count:=finterfaces.count;
5827
 
      end;
5828
 
 
5829
 
    procedure timplementedinterfaces.checkindex(intfindex: longint);
5830
 
      begin
5831
 
        if (intfindex<1) or (intfindex>count) then
5832
 
          InternalError(200006123);
5833
 
      end;
5834
 
 
5835
 
    function  timplementedinterfaces.interfaces(intfindex: longint): tobjectdef;
5836
 
      begin
5837
 
        checkindex(intfindex);
5838
 
        interfaces:=timplintfentry(finterfaces.search(intfindex)).intf;
5839
 
      end;
5840
 
 
5841
 
    function  timplementedinterfaces.interfacesderef(intfindex: longint): tderef;
5842
 
      begin
5843
 
        checkindex(intfindex);
5844
 
        interfacesderef:=timplintfentry(finterfaces.search(intfindex)).intfderef;
5845
 
      end;
5846
 
 
5847
 
    function  timplementedinterfaces.ioffsets(intfindex: longint): plongint;
5848
 
      begin
5849
 
        checkindex(intfindex);
5850
 
        ioffsets:=@timplintfentry(finterfaces.search(intfindex)).ioffs;
5851
 
      end;
5852
 
 
5853
 
    function  timplementedinterfaces.searchintf(def: tdef): longint;
5854
 
      var
5855
 
        i: longint;
5856
 
      begin
5857
 
        i:=1;
5858
 
        while (i<=count) and (tdef(interfaces(i))<>def) do inc(i);
5859
 
        if i<=count then
5860
 
          searchintf:=i
5861
 
        else
5862
 
          searchintf:=-1;
5863
 
      end;
5864
 
 
5865
 
 
5866
 
    procedure timplementedinterfaces.buildderef;
5867
 
      var
5868
 
        i: longint;
5869
 
      begin
5870
 
        for i:=1 to count do
5871
 
          with timplintfentry(finterfaces.search(i)) do
5872
 
            intfderef.build(intf);
5873
 
      end;
5874
 
 
5875
 
 
5876
 
    procedure timplementedinterfaces.deref;
5877
 
      var
5878
 
        i: longint;
5879
 
      begin
5880
 
        for i:=1 to count do
5881
 
          with timplintfentry(finterfaces.search(i)) do
5882
 
            intf:=tobjectdef(intfderef.resolve);
5883
 
      end;
5884
 
 
5885
 
    procedure timplementedinterfaces.addintf_deref(const d:tderef);
5886
 
      begin
5887
 
        finterfaces.insert(timplintfentry.create_deref(d));
5888
 
      end;
5889
 
 
5890
 
    procedure timplementedinterfaces.addintf(def: tdef);
5891
 
      begin
5892
 
        if not assigned(def) or (searchintf(def)<>-1) or (def.deftype<>objectdef) or
5893
 
           not (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]) then
5894
 
          internalerror(200006124);
5895
 
        finterfaces.insert(timplintfentry.create(tobjectdef(def)));
5896
 
      end;
5897
 
 
5898
 
    procedure timplementedinterfaces.clearmappings;
5899
 
      var
5900
 
        i: longint;
5901
 
      begin
5902
 
        for i:=1 to count do
5903
 
          with timplintfentry(finterfaces.search(i)) do
5904
 
            begin
5905
 
              if assigned(namemappings) then
5906
 
                namemappings.free;
5907
 
              namemappings:=nil;
5908
 
            end;
5909
 
      end;
5910
 
 
5911
 
    procedure timplementedinterfaces.addmappings(intfindex: longint; const name, newname: string);
5912
 
      begin
5913
 
        checkindex(intfindex);
5914
 
        with timplintfentry(finterfaces.search(intfindex)) do
5915
 
          begin
5916
 
            if not assigned(namemappings) then
5917
 
              namemappings:=tdictionary.create;
5918
 
            namemappings.insert(tnamemap.create(name,newname));
5919
 
          end;
5920
 
      end;
5921
 
 
5922
 
    function  timplementedinterfaces.getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
5923
 
      begin
5924
 
        checkindex(intfindex);
5925
 
        if not assigned(nextexist) then
5926
 
          with timplintfentry(finterfaces.search(intfindex)) do
5927
 
            begin
5928
 
              if assigned(namemappings) then
5929
 
                nextexist:=namemappings.search(name)
5930
 
              else
5931
 
                nextexist:=nil;
5932
 
            end;
5933
 
        if assigned(nextexist) then
5934
 
          begin
5935
 
            getmappings:=tnamemap(nextexist).newname^;
5936
 
            nextexist:=tnamemap(nextexist).listnext;
5937
 
          end
5938
 
        else
5939
 
          getmappings:='';
5940
 
      end;
5941
 
 
5942
 
    procedure timplementedinterfaces.clearimplprocs;
5943
 
      var
5944
 
        i: longint;
5945
 
      begin
5946
 
        for i:=1 to count do
5947
 
          with timplintfentry(finterfaces.search(i)) do
5948
 
            begin
5949
 
              if assigned(procdefs) then
5950
 
                procdefs.free;
5951
 
              procdefs:=nil;
5952
 
            end;
5953
 
      end;
5954
 
 
5955
 
    procedure timplementedinterfaces.addimplproc(intfindex: longint; procdef: tprocdef);
5956
 
      begin
5957
 
        checkindex(intfindex);
5958
 
        with timplintfentry(finterfaces.search(intfindex)) do
5959
 
          begin
5960
 
            if not assigned(procdefs) then
5961
 
              procdefs:=tindexarray.create(4);
5962
 
            procdefs.insert(tprocdefstore.create(procdef));
5963
 
          end;
5964
 
      end;
5965
 
 
5966
 
    function  timplementedinterfaces.implproccount(intfindex: longint): longint;
5967
 
      begin
5968
 
        checkindex(intfindex);
5969
 
        with timplintfentry(finterfaces.search(intfindex)) do
5970
 
          if assigned(procdefs) then
5971
 
            implproccount:=procdefs.count
5972
 
          else
5973
 
            implproccount:=0;
5974
 
      end;
5975
 
 
5976
 
    function  timplementedinterfaces.implprocs(intfindex: longint; procindex: longint): tprocdef;
5977
 
      begin
5978
 
        checkindex(intfindex);
5979
 
        with timplintfentry(finterfaces.search(intfindex)) do
5980
 
          if assigned(procdefs) then
5981
 
            implprocs:=tprocdefstore(procdefs.search(procindex)).procdef
5982
 
          else
5983
 
            internalerror(200006131);
5984
 
      end;
5985
 
 
5986
 
    function  timplementedinterfaces.isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
5987
 
      var
5988
 
        possible: boolean;
5989
 
        i: longint;
5990
 
        iiep1: TIndexArray;
5991
 
        iiep2: TIndexArray;
5992
 
      begin
5993
 
        checkindex(intfindex);
5994
 
        checkindex(remainindex);
5995
 
        iiep1:=timplintfentry(finterfaces.search(intfindex)).procdefs;
5996
 
        iiep2:=timplintfentry(finterfaces.search(remainindex)).procdefs;
5997
 
        if not assigned(iiep1) then { empty interface is mergeable :-) }
5998
 
          begin
5999
 
            possible:=true;
6000
 
            weight:=0;
6001
 
          end
6002
 
        else
6003
 
          begin
6004
 
            possible:=assigned(iiep2) and (iiep1.count<=iiep2.count);
6005
 
            i:=1;
6006
 
            while (possible) and (i<=iiep1.count) do
6007
 
              begin
6008
 
                possible:=
6009
 
                  (tprocdefstore(iiep1.search(i)).procdef=tprocdefstore(iiep2.search(i)).procdef);
6010
 
                inc(i);
6011
 
              end;
6012
 
            if possible then
6013
 
              weight:=iiep1.count;
6014
 
          end;
6015
 
        isimplmergepossible:=possible;
6016
 
      end;
6017
 
 
6018
 
 
6019
 
{****************************************************************************
6020
 
                                TFORWARDDEF
6021
 
****************************************************************************}
6022
 
 
6023
 
   constructor tforwarddef.create(const s:string;const pos : tfileposinfo);
6024
 
     var
6025
 
       oldregisterdef : boolean;
6026
 
     begin
6027
 
        { never register the forwarddefs, they are disposed at the
6028
 
          end of the type declaration block }
6029
 
        oldregisterdef:=registerdef;
6030
 
        registerdef:=false;
6031
 
        inherited create;
6032
 
        registerdef:=oldregisterdef;
6033
 
        deftype:=forwarddef;
6034
 
        tosymname:=stringdup(s);
6035
 
        forwardpos:=pos;
6036
 
     end;
6037
 
 
6038
 
 
6039
 
    function tforwarddef.gettypename:string;
6040
 
      begin
6041
 
        gettypename:='unresolved forward to '+tosymname^;
6042
 
      end;
6043
 
 
6044
 
     destructor tforwarddef.destroy;
6045
 
      begin
6046
 
        if assigned(tosymname) then
6047
 
          stringdispose(tosymname);
6048
 
        inherited destroy;
6049
 
      end;
6050
 
 
6051
 
 
6052
 
{****************************************************************************
6053
 
                                  TERRORDEF
6054
 
****************************************************************************}
6055
 
 
6056
 
   constructor terrordef.create;
6057
 
     begin
6058
 
        inherited create;
6059
 
        deftype:=errordef;
6060
 
     end;
6061
 
 
6062
 
 
6063
 
{$ifdef GDB}
6064
 
    function terrordef.stabstring : pchar;
6065
 
      begin
6066
 
         stabstring:=strpnew('error'+numberstring);
6067
 
      end;
6068
 
 
6069
 
    procedure terrordef.concatstabto(asmlist : taasmoutput);
6070
 
      begin
6071
 
        { No internal error needed, an normal error is already
6072
 
          thrown }
6073
 
      end;
6074
 
{$endif GDB}
6075
 
 
6076
 
    function terrordef.gettypename:string;
6077
 
 
6078
 
      begin
6079
 
         gettypename:='<erroneous type>';
6080
 
      end;
6081
 
 
6082
 
    function terrordef.getmangledparaname:string;
6083
 
 
6084
 
      begin
6085
 
         getmangledparaname:='error';
6086
 
      end;
6087
 
 
6088
 
 
6089
 
{****************************************************************************
6090
 
                           Definition Helpers
6091
 
****************************************************************************}
6092
 
 
6093
 
    function is_interfacecom(def: tdef): boolean;
6094
 
      begin
6095
 
        is_interfacecom:=
6096
 
          assigned(def) and
6097
 
          (def.deftype=objectdef) and
6098
 
          (tobjectdef(def).objecttype=odt_interfacecom);
6099
 
      end;
6100
 
 
6101
 
    function is_interfacecorba(def: tdef): boolean;
6102
 
      begin
6103
 
        is_interfacecorba:=
6104
 
          assigned(def) and
6105
 
          (def.deftype=objectdef) and
6106
 
          (tobjectdef(def).objecttype=odt_interfacecorba);
6107
 
      end;
6108
 
 
6109
 
    function is_interface(def: tdef): boolean;
6110
 
      begin
6111
 
        is_interface:=
6112
 
          assigned(def) and
6113
 
          (def.deftype=objectdef) and
6114
 
          (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]);
6115
 
      end;
6116
 
 
6117
 
 
6118
 
    function is_class(def: tdef): boolean;
6119
 
      begin
6120
 
        is_class:=
6121
 
          assigned(def) and
6122
 
          (def.deftype=objectdef) and
6123
 
          (tobjectdef(def).objecttype=odt_class);
6124
 
      end;
6125
 
 
6126
 
    function is_object(def: tdef): boolean;
6127
 
      begin
6128
 
        is_object:=
6129
 
          assigned(def) and
6130
 
          (def.deftype=objectdef) and
6131
 
          (tobjectdef(def).objecttype=odt_object);
6132
 
      end;
6133
 
 
6134
 
    function is_cppclass(def: tdef): boolean;
6135
 
      begin
6136
 
        is_cppclass:=
6137
 
          assigned(def) and
6138
 
          (def.deftype=objectdef) and
6139
 
          (tobjectdef(def).objecttype=odt_cppclass);
6140
 
      end;
6141
 
 
6142
 
    function is_class_or_interface(def: tdef): boolean;
6143
 
      begin
6144
 
        is_class_or_interface:=
6145
 
          assigned(def) and
6146
 
          (def.deftype=objectdef) and
6147
 
          (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
6148
 
      end;
6149
 
 
6150
 
end.
6151
 
{
6152
 
  $Log: symdef.pas,v $
6153
 
  Revision 1.240  2004/05/25 18:51:14  peter
6154
 
    * range check error
6155
 
 
6156
 
  Revision 1.239  2004/05/23 20:57:10  peter
6157
 
    * removed unused voidprocdef
6158
 
 
6159
 
  Revision 1.238  2004/05/23 15:23:30  peter
6160
 
    * fixed qword(longint) that removed sign from the number
6161
 
    * removed code in the compiler that relied on wrong qword(longint)
6162
 
      code generation
6163
 
 
6164
 
  Revision 1.237  2004/05/22 23:33:18  peter
6165
 
  fix range check error when array size > maxlongint
6166
 
 
6167
 
  Revision 1.236  2004/05/01 22:05:01  florian
6168
 
    + added lib support for Amiga/MorphOS syscalls
6169
 
 
6170
 
  Revision 1.235  2004/04/29 19:56:37  daniel
6171
 
    * Prepare compiler infrastructure for multiple ansistring types
6172
 
 
6173
 
  Revision 1.234  2004/04/18 15:22:24  florian
6174
 
    + location support for arguments, currently PowerPC/MorphOS only
6175
 
 
6176
 
  Revision 1.233  2004/03/23 22:34:49  peter
6177
 
    * constants ordinals now always have a type assigned
6178
 
    * integer constants have the smallest type, unsigned prefered over
6179
 
      signed
6180
 
 
6181
 
  Revision 1.232  2004/03/18 11:43:57  olle
6182
 
    * change AT_FUNCTION to AT_DATA where appropriate
6183
 
 
6184
 
  Revision 1.231  2004/03/14 22:51:46  peter
6185
 
    * valgrind doesn't like nested procedure info in stabs
6186
 
 
6187
 
  Revision 1.230  2004/03/14 20:06:40  peter
6188
 
    * don't write line numbers in stabs for defs
6189
 
 
6190
 
  Revision 1.229  2004/03/10 22:52:57  peter
6191
 
    * more stabs fixes
6192
 
    * special mode -gv for valgrind compatible stabs
6193
 
 
6194
 
  Revision 1.228  2004/03/09 22:18:22  peter
6195
 
    * first write parent classes
6196
 
 
6197
 
  Revision 1.227  2004/03/09 20:45:04  peter
6198
 
    * more stabs updates
6199
 
 
6200
 
  Revision 1.226  2004/03/08 22:07:47  peter
6201
 
    * stabs updates to write stabs for def for all implictly used
6202
 
      units
6203
 
 
6204
 
  Revision 1.225  2004/03/03 22:01:44  peter
6205
 
    * fix hidden pointer for stabs
6206
 
 
6207
 
  Revision 1.224  2004/03/02 00:36:33  olle
6208
 
    * big transformation of Tai_[const_]Symbol.Create[data]name*
6209
 
 
6210
 
  Revision 1.223  2004/02/26 16:16:38  peter
6211
 
    * tai_const.create_ptr added
6212
 
 
6213
 
  Revision 1.222  2004/02/22 19:55:25  daniel
6214
 
    * Revert my latest change
6215
 
 
6216
 
  Revision 1.221  2004/02/22 18:49:03  daniel
6217
 
    * Fixed minor bug in Tenumdef.stabstring
6218
 
 
6219
 
  Revision 1.220  2004/02/19 17:07:42  florian
6220
 
    * fixed arg. area calculation
6221
 
 
6222
 
  Revision 1.219  2004/02/17 15:57:49  peter
6223
 
  - fix rtti generation for properties containing sl_vec
6224
 
  - fix crash when overloaded operator is not available
6225
 
  - fix record alignment for C style variant records
6226
 
 
6227
 
  Revision 1.218  2004/02/12 15:54:03  peter
6228
 
    * make extcycle is working again
6229
 
 
6230
 
  Revision 1.217  2004/02/08 18:08:59  jonas
6231
 
    * fixed regvars support. Needs -doldregvars to activate. Only tested with
6232
 
      ppc, other processors should however only require maxregvars and
6233
 
      maxfpuregvars constants in cpubase.pas. Remember to take scratch-
6234
 
      registers into account when defining that value.
6235
 
 
6236
 
  Revision 1.216  2004/02/06 22:37:00  daniel
6237
 
    * Removed not very usefull nextglobal & previousglobal fields from
6238
 
      Tstoreddef, saving 78 kb of memory
6239
 
 
6240
 
  Revision 1.215  2004/02/05 01:24:08  florian
6241
 
    * several fixes to compile x86-64 system
6242
 
 
6243
 
  Revision 1.214  2004/02/03 22:32:54  peter
6244
 
    * renamed xNNbittype to xNNinttype
6245
 
    * renamed registers32 to registersint
6246
 
    * replace some s32bit,u32bit with torddef([su]inttype).def.typ
6247
 
 
6248
 
  Revision 1.213  2004/01/28 22:16:31  peter
6249
 
    * more record alignment fixes
6250
 
 
6251
 
  Revision 1.212  2004/01/28 21:05:56  florian
6252
 
    * fixed alignment of classes
6253
 
 
6254
 
  Revision 1.211  2004/01/28 20:30:18  peter
6255
 
    * record alignment splitted in fieldalignment and recordalignment,
6256
 
      the latter is used when this record is inserted in another record.
6257
 
 
6258
 
  Revision 1.210  2004/01/27 10:29:32  daniel
6259
 
    * Fix string type stab generation. String constant still unsupported.
6260
 
 
6261
 
  Revision 1.209  2004/01/26 19:54:42  daniel
6262
 
    * Typo
6263
 
 
6264
 
  Revision 1.208  2004/01/26 19:43:49  daniel
6265
 
    * Try to recude stack usage of Tpointerdef.concatstabsto
6266
 
 
6267
 
  Revision 1.207  2004/01/26 16:12:28  daniel
6268
 
    * reginfo now also only allocated during register allocation
6269
 
    * third round of gdb cleanups: kick out most of concatstabto
6270
 
 
6271
 
  Revision 1.206  2004/01/25 20:23:28  daniel
6272
 
    * More gdb cleanup: make record & object stab generation linear instead
6273
 
      of quadratic.
6274
 
 
6275
 
  Revision 1.205  2004/01/25 13:18:59  daniel
6276
 
    * Made varags parameter constant
6277
 
 
6278
 
  Revision 1.204  2004/01/25 12:37:15  daniel
6279
 
    * Last commit broke debug info for records. Fixed.
6280
 
 
6281
 
  Revision 1.203  2004/01/25 11:33:48  daniel
6282
 
    * 2nd round of gdb cleanup
6283
 
 
6284
 
  Revision 1.202  2004/01/22 21:33:54  peter
6285
 
    * procvardef rtti fixed
6286
 
 
6287
 
  Revision 1.201  2004/01/22 16:33:22  peter
6288
 
    * enum value rtti is now in orginal case
6289
 
 
6290
 
  Revision 1.200  2004/01/20 12:59:37  florian
6291
 
    * common addnode code for x86-64 and i386
6292
 
 
6293
 
  Revision 1.199  2004/01/15 15:16:18  daniel
6294
 
    * Some minor stuff
6295
 
    * Managed to eliminate speed effects of string compression
6296
 
 
6297
 
  Revision 1.198  2004/01/11 23:56:20  daniel
6298
 
    * Experiment: Compress strings to save memory
6299
 
      Did not save a single byte of mem; clearly the core size is boosted by
6300
 
      temporary memory usage...
6301
 
 
6302
 
  Revision 1.197  2004/01/04 21:10:04  jonas
6303
 
    * Darwin's assembler assumes that all labels starting with 'L' are local
6304
 
      -> rename symbols starting with 'L'
6305
 
 
6306
 
  Revision 1.196  2003/12/24 20:51:11  peter
6307
 
    * don't lowercase enumnames
6308
 
 
6309
 
  Revision 1.195  2003/12/24 01:47:22  florian
6310
 
    * first fixes to compile the x86-64 system unit
6311
 
 
6312
 
  Revision 1.194  2003/12/21 19:42:43  florian
6313
 
    * fixed ppc inlining stuff
6314
 
    * fixed wrong unit writing
6315
 
    + added some sse stuff
6316
 
 
6317
 
  Revision 1.193  2003/12/16 21:29:24  florian
6318
 
    + inlined procedures inherit procinfo flags
6319
 
 
6320
 
  Revision 1.192  2003/12/12 12:09:40  marco
6321
 
   * always generate RTTI patch from peter
6322
 
 
6323
 
  Revision 1.191  2003/12/08 22:34:24  peter
6324
 
    * tai_const.create_32bit changed to cardinal
6325
 
 
6326
 
  Revision 1.190  2003/11/10 22:02:52  peter
6327
 
    * cross unit inlining fixed
6328
 
 
6329
 
  Revision 1.189  2003/11/08 23:31:27  florian
6330
 
    * tstoreddef.getcopy returns now an errordef instead of nil; this
6331
 
      allows easier error recovery
6332
 
 
6333
 
  Revision 1.188  2003/11/05 14:18:03  marco
6334
 
   * fix from Peter arraysize warning (nav Newsgroup msg)
6335
 
 
6336
 
  Revision 1.187  2003/11/01 15:50:03  peter
6337
 
    * fix check for valid procdef in property rtti
6338
 
 
6339
 
  Revision 1.186  2003/10/29 21:56:28  peter
6340
 
    * procsym.deref derefs only own procdefs
6341
 
    * reset paracount in procdef.deref so a second deref doesn't increase
6342
 
      the paracounts to invalid values
6343
 
 
6344
 
  Revision 1.185  2003/10/29 19:48:51  peter
6345
 
    * renamed mangeldname_prefix to make_mangledname and made it more
6346
 
      generic
6347
 
    * make_mangledname is now also used for internal threadvar/resstring
6348
 
      lists
6349
 
    * Add P$ in front of program modulename to prevent duplicated symbols
6350
 
      at assembler level, because the main program can have the same name
6351
 
      as a unit, see webtbs/tw1251b
6352
 
 
6353
 
  Revision 1.184  2003/10/23 14:44:07  peter
6354
 
    * splitted buildderef and buildderefimpl to fix interface crc
6355
 
      calculation
6356
 
 
6357
 
  Revision 1.183  2003/10/22 20:40:00  peter
6358
 
    * write derefdata in a separate ppu entry
6359
 
 
6360
 
  Revision 1.182  2003/10/21 18:14:49  peter
6361
 
    * fix counting of parameters when loading ppu
6362
 
 
6363
 
  Revision 1.181  2003/10/17 15:08:34  peter
6364
 
    * commented out more obsolete constants
6365
 
 
6366
 
  Revision 1.180  2003/10/17 14:52:07  peter
6367
 
    * fixed ppc build
6368
 
 
6369
 
  Revision 1.179  2003/10/17 14:38:32  peter
6370
 
    * 64k registers supported
6371
 
    * fixed some memory leaks
6372
 
 
6373
 
  Revision 1.178  2003/10/13 14:05:12  peter
6374
 
    * removed is_visible_for_proc
6375
 
    * search also for class overloads when finding interface
6376
 
      implementations
6377
 
 
6378
 
  Revision 1.177  2003/10/11 16:06:42  florian
6379
 
    * fixed some MMX<->SSE
6380
 
    * started to fix ppc, needs an overhaul
6381
 
    + stabs info improve for spilling, not sure if it works correctly/completly
6382
 
    - MMX_SUPPORT removed from Makefile.fpc
6383
 
 
6384
 
  Revision 1.176  2003/10/10 17:48:14  peter
6385
 
    * old trgobj moved to x86/rgcpu and renamed to trgx86fpu
6386
 
    * tregisteralloctor renamed to trgobj
6387
 
    * removed rgobj from a lot of units
6388
 
    * moved location_* and reference_* to cgobj
6389
 
    * first things for mmx register allocation
6390
 
 
6391
 
  Revision 1.175  2003/10/07 20:43:49  peter
6392
 
    * Add calling convention in fullprocname when it is specified
6393
 
 
6394
 
  Revision 1.174  2003/10/07 16:06:30  peter
6395
 
    * tsymlist.def renamed to tsymlist.procdef
6396
 
    * tsymlist.procdef is now only used to store the procdef
6397
 
 
6398
 
  Revision 1.173  2003/10/06 22:23:41  florian
6399
 
    + added basic olevariant support
6400
 
 
6401
 
  Revision 1.172  2003/10/05 21:21:52  peter
6402
 
    * c style array of const generates callparanodes
6403
 
    * varargs paraloc fixes
6404
 
 
6405
 
  Revision 1.171  2003/10/05 12:56:35  peter
6406
 
    * don't write procdefs that are released to ppu
6407
 
 
6408
 
  Revision 1.170  2003/10/03 22:00:33  peter
6409
 
    * parameter alignment fixes
6410
 
 
6411
 
  Revision 1.169  2003/10/02 21:19:42  peter
6412
 
    * protected visibility fixes
6413
 
 
6414
 
  Revision 1.168  2003/10/01 20:34:49  peter
6415
 
    * procinfo unit contains tprocinfo
6416
 
    * cginfo renamed to cgbase
6417
 
    * moved cgmessage to verbose
6418
 
    * fixed ppc and sparc compiles
6419
 
 
6420
 
  Revision 1.167  2003/10/01 16:49:05  florian
6421
 
    * para items are now reversed for pascal calling conventions
6422
 
 
6423
 
  Revision 1.166  2003/10/01 15:32:58  florian
6424
 
    * fixed FullProcName to handle constructors, destructors and operators correctly
6425
 
 
6426
 
  Revision 1.165  2003/10/01 15:00:02  peter
6427
 
    * don't write parast,localst debug info for externals
6428
 
 
6429
 
  Revision 1.164  2003/09/23 21:03:35  peter
6430
 
    * connect parasym to paraitem
6431
 
 
6432
 
  Revision 1.163  2003/09/23 17:56:06  peter
6433
 
    * locals and paras are allocated in the code generation
6434
 
    * tvarsym.localloc contains the location of para/local when
6435
 
      generating code for the current procedure
6436
 
 
6437
 
  Revision 1.162  2003/09/07 22:09:35  peter
6438
 
    * preparations for different default calling conventions
6439
 
    * various RA fixes
6440
 
 
6441
 
  Revision 1.161  2003/09/06 22:27:09  florian
6442
 
    * fixed web bug 2669
6443
 
    * cosmetic fix in printnode
6444
 
    * tobjectdef.gettypename implemented
6445
 
 
6446
 
  Revision 1.160  2003/09/03 15:55:01  peter
6447
 
    * NEWRA branch merged
6448
 
 
6449
 
  Revision 1.159  2003/09/03 11:18:37  florian
6450
 
    * fixed arm concatcopy
6451
 
    + arm support in the common compiler sources added
6452
 
    * moved some generic cg code around
6453
 
    + tfputype added
6454
 
    * ...
6455
 
 
6456
 
  Revision 1.158.2.2  2003/08/29 17:28:59  peter
6457
 
    * next batch of updates
6458
 
 
6459
 
  Revision 1.158.2.1  2003/08/27 19:55:54  peter
6460
 
    * first tregister patch
6461
 
 
6462
 
  Revision 1.158  2003/08/11 21:18:20  peter
6463
 
    * start of sparc support for newra
6464
 
 
6465
 
  Revision 1.157  2003/07/08 15:20:56  peter
6466
 
    * don't allow add/assignments for formaldef
6467
 
    * formaldef size changed to 0
6468
 
 
6469
 
  Revision 1.156  2003/07/06 21:50:33  jonas
6470
 
    * fixed ppc compilation problems and changed VOLATILE_REGISTERS for x86
6471
 
      so that it doesn't include ebp and esp anymore
6472
 
 
6473
 
  Revision 1.155  2003/07/06 15:31:21  daniel
6474
 
    * Fixed register allocator. *Lots* of fixes.
6475
 
 
6476
 
  Revision 1.154  2003/07/02 22:18:04  peter
6477
 
    * paraloc splitted in callerparaloc,calleeparaloc
6478
 
    * sparc calling convention updates
6479
 
 
6480
 
  Revision 1.153  2003/06/25 18:31:23  peter
6481
 
    * sym,def resolving partly rewritten to support also parent objects
6482
 
      not directly available through the uses clause
6483
 
 
6484
 
  Revision 1.152  2003/06/17 16:34:44  jonas
6485
 
    * lots of newra fixes (need getfuncretparaloc implementation for i386)!
6486
 
    * renamed all_intregisters to paramanager.get_volatile_registers_int(pocall_default) and made it
6487
 
      processor dependent
6488
 
 
6489
 
  Revision 1.151  2003/06/08 11:41:21  peter
6490
 
    * set parast.next to the owner of the procdef
6491
 
 
6492
 
  Revision 1.150  2003/06/07 20:26:32  peter
6493
 
    * re-resolving added instead of reloading from ppu
6494
 
    * tderef object added to store deref info for resolving
6495
 
 
6496
 
  Revision 1.149  2003/06/05 20:05:55  peter
6497
 
    * removed changesettype because that will change the definition
6498
 
      of the setdef forever and can result in a different between
6499
 
      original interface and current implementation definition
6500
 
 
6501
 
  Revision 1.148  2003/06/03 13:01:59  daniel
6502
 
    * Register allocator finished
6503
 
 
6504
 
  Revision 1.147  2003/06/02 22:55:28  florian
6505
 
    * classes and interfaces can be stored in integer registers
6506
 
 
6507
 
  Revision 1.146  2003/05/26 21:17:18  peter
6508
 
    * procinlinenode removed
6509
 
    * aktexit2label removed, fast exit removed
6510
 
    + tcallnode.inlined_pass_2 added
6511
 
 
6512
 
  Revision 1.145  2003/05/25 11:34:17  peter
6513
 
    * methodpointer self pushing fixed
6514
 
 
6515
 
  Revision 1.144  2003/05/15 18:58:53  peter
6516
 
    * removed selfpointer_offset, vmtpointer_offset
6517
 
    * tvarsym.adjusted_address
6518
 
    * address in localsymtable is now in the real direction
6519
 
    * removed some obsolete globals
6520
 
 
6521
 
  Revision 1.143  2003/05/13 08:13:16  jonas
6522
 
    * patch from Peter for rtti symbols
6523
 
 
6524
 
  Revision 1.142  2003/05/11 21:37:03  peter
6525
 
    * moved implicit exception frame from ncgutil to psub
6526
 
    * constructor/destructor helpers moved from cobj/ncgutil to psub
6527
 
 
6528
 
  Revision 1.141  2003/05/09 17:47:03  peter
6529
 
    * self moved to hidden parameter
6530
 
    * removed hdisposen,hnewn,selfn
6531
 
 
6532
 
  Revision 1.140  2003/05/05 14:53:16  peter
6533
 
    * vs_hidden replaced by is_hidden boolean
6534
 
 
6535
 
  Revision 1.139  2003/05/01 07:59:43  florian
6536
 
    * introduced defaultordconsttype to decribe the default size of ordinal constants
6537
 
      on 64 bit CPUs it's equal to cs64bitdef while on 32 bit CPUs it's equal to s32bitdef
6538
 
    + added defines CPU32 and CPU64 for 32 bit and 64 bit CPUs
6539
 
    * int64s/qwords are allowed as for loop counter on 64 bit CPUs
6540
 
 
6541
 
  Revision 1.138  2003/04/27 11:21:34  peter
6542
 
    * aktprocdef renamed to current_procdef
6543
 
    * procinfo renamed to current_procinfo
6544
 
    * procinfo will now be stored in current_module so it can be
6545
 
      cleaned up properly
6546
 
    * gen_main_procsym changed to create_main_proc and release_main_proc
6547
 
      to also generate a tprocinfo structure
6548
 
    * fixed unit implicit initfinal
6549
 
 
6550
 
  Revision 1.137  2003/04/27 07:29:51  peter
6551
 
    * current_procdef cleanup, current_procdef is now always nil when parsing
6552
 
      a new procdef declaration
6553
 
    * aktprocsym removed
6554
 
    * lexlevel removed, use symtable.symtablelevel instead
6555
 
    * implicit init/final code uses the normal genentry/genexit
6556
 
    * funcret state checking updated for new funcret handling
6557
 
 
6558
 
  Revision 1.136  2003/04/25 20:59:35  peter
6559
 
    * removed funcretn,funcretsym, function result is now in varsym
6560
 
      and aliases for result and function name are added using absolutesym
6561
 
    * vs_hidden parameter for funcret passed in parameter
6562
 
    * vs_hidden fixes
6563
 
    * writenode changed to printnode and released from extdebug
6564
 
    * -vp option added to generate a tree.log with the nodetree
6565
 
    * nicer printnode for statements, callnode
6566
 
 
6567
 
  Revision 1.135  2003/04/23 20:16:04  peter
6568
 
    + added currency support based on int64
6569
 
    + is_64bit for use in cg units instead of is_64bitint
6570
 
    * removed cgmessage from n386add, replace with internalerrors
6571
 
 
6572
 
  Revision 1.134  2003/04/23 12:35:34  florian
6573
 
    * fixed several issues with powerpc
6574
 
    + applied a patch from Jonas for nested function calls (PowerPC only)
6575
 
    * ...
6576
 
 
6577
 
  Revision 1.133  2003/04/10 17:57:53  peter
6578
 
    * vs_hidden released
6579
 
 
6580
 
  Revision 1.132  2003/03/18 16:25:50  peter
6581
 
    * no itnernalerror for errordef.concatstabto()
6582
 
 
6583
 
  Revision 1.131  2003/03/17 16:54:41  peter
6584
 
    * support DefaultHandler and anonymous inheritance fixed
6585
 
      for message methods
6586
 
 
6587
 
  Revision 1.130  2003/03/17 15:54:22  peter
6588
 
    * store symoptions also for procdef
6589
 
    * check symoptions (private,public) when calculating possible
6590
 
      overload candidates
6591
 
 
6592
 
  Revision 1.129  2003/02/19 22:00:14  daniel
6593
 
    * Code generator converted to new register notation
6594
 
    - Horribily outdated todo.txt removed
6595
 
 
6596
 
  Revision 1.128  2003/02/02 19:25:54  carl
6597
 
    * Several bugfixes for m68k target (register alloc., opcode emission)
6598
 
    + VIS target
6599
 
    + Generic add more complete (still not verified)
6600
 
 
6601
 
  Revision 1.127  2003/01/21 14:36:44  pierre
6602
 
   * set sizes needs to be passes in bits not bytes to stabs info
6603
 
 
6604
 
  Revision 1.126  2003/01/16 22:11:33  peter
6605
 
    * fixed tprocdef.is_addressonly
6606
 
 
6607
 
  Revision 1.125  2003/01/15 01:44:33  peter
6608
 
    * merged methodpointer fixes from 1.0.x
6609
 
 
6610
 
  Revision 1.124  2003/01/09 21:52:37  peter
6611
 
    * merged some verbosity options.
6612
 
    * V_LineInfo is a verbosity flag to include line info
6613
 
 
6614
 
  Revision 1.123  2003/01/06 21:16:52  peter
6615
 
    * po_addressonly added to retrieve the address of a methodpointer
6616
 
      only, this is used for @tclass.method which has no self pointer
6617
 
 
6618
 
  Revision 1.122  2003/01/05 15:54:15  florian
6619
 
    + added proper support of type = type <type>; for simple types
6620
 
 
6621
 
  Revision 1.121  2003/01/05 13:36:53  florian
6622
 
    * x86-64 compiles
6623
 
    + very basic support for float128 type (x86-64 only)
6624
 
 
6625
 
  Revision 1.120  2003/01/02 19:49:00  peter
6626
 
    * update self parameter only for methodpointer and methods
6627
 
 
6628
 
  Revision 1.119  2002/12/29 18:25:59  peter
6629
 
    * tprocdef.gettypename implemented
6630
 
 
6631
 
  Revision 1.118  2002/12/27 15:23:09  peter
6632
 
    * write class methods in fullname
6633
 
 
6634
 
  Revision 1.117  2002/12/15 19:34:31  florian
6635
 
    + some front end stuff for vs_hidden added
6636
 
 
6637
 
  Revision 1.116  2002/12/15 11:26:02  peter
6638
 
    * ignore vs_hidden parameters when choosing overloaded proc
6639
 
 
6640
 
  Revision 1.115  2002/12/07 14:27:09  carl
6641
 
    * 3% memory optimization
6642
 
    * changed some types
6643
 
    + added type checking with different size for call node and for
6644
 
       parameters
6645
 
 
6646
 
  Revision 1.114  2002/12/01 22:05:27  carl
6647
 
    * no more warnings for structures over 32K since this is
6648
 
      handled correctly in this version of the compiler.
6649
 
 
6650
 
  Revision 1.113  2002/11/27 20:04:09  peter
6651
 
    * tvarsym.get_push_size replaced by paramanager.push_size
6652
 
 
6653
 
  Revision 1.112  2002/11/25 21:05:53  carl
6654
 
   * several mistakes fixed in message files
6655
 
 
6656
 
  Revision 1.111  2002/11/25 18:43:33  carl
6657
 
   - removed the invalid if <> checking (Delphi is strange on this)
6658
 
   + implemented abstract warning on instance creation of class with
6659
 
      abstract methods.
6660
 
   * some error message cleanups
6661
 
 
6662
 
  Revision 1.110  2002/11/25 17:43:24  peter
6663
 
    * splitted defbase in defutil,symutil,defcmp
6664
 
    * merged isconvertable and is_equal into compare_defs(_ext)
6665
 
    * made operator search faster by walking the list only once
6666
 
 
6667
 
  Revision 1.109  2002/11/23 22:50:06  carl
6668
 
    * some small speed optimizations
6669
 
    + added several new warnings/hints
6670
 
 
6671
 
  Revision 1.108  2002/11/22 22:48:10  carl
6672
 
  * memory optimization with tconstsym (1.5%)
6673
 
 
6674
 
  Revision 1.107  2002/11/19 16:21:29  pierre
6675
 
   * correct several stabs generation problems
6676
 
 
6677
 
  Revision 1.106  2002/11/18 17:31:59  peter
6678
 
    * pass proccalloption to ret_in_xxx and push_xxx functions
6679
 
 
6680
 
  Revision 1.105  2002/11/17 16:31:57  carl
6681
 
    * memory optimization (3-4%) : cleanup of tai fields,
6682
 
       cleanup of tdef and tsym fields.
6683
 
    * make it work for m68k
6684
 
 
6685
 
  Revision 1.104  2002/11/16 19:53:18  carl
6686
 
    * avoid Range check errors
6687
 
 
6688
 
  Revision 1.103  2002/11/15 16:29:09  peter
6689
 
    * fixed rtti for int64 (merged)
6690
 
 
6691
 
  Revision 1.102  2002/11/15 01:58:54  peter
6692
 
    * merged changes from 1.0.7 up to 04-11
6693
 
      - -V option for generating bug report tracing
6694
 
      - more tracing for option parsing
6695
 
      - errors for cdecl and high()
6696
 
      - win32 import stabs
6697
 
      - win32 records<=8 are returned in eax:edx (turned off by default)
6698
 
      - heaptrc update
6699
 
      - more info for temp management in .s file with EXTDEBUG
6700
 
 
6701
 
  Revision 1.101  2002/11/09 15:31:02  carl
6702
 
    + align RTTI tables
6703
 
 
6704
 
  Revision 1.100  2002/10/19 15:09:25  peter
6705
 
    + tobjectdef.members_need_inittable that is used to generate only the
6706
 
      inittable when it is really used. This saves a lot of useless calls
6707
 
      to fpc_finalize when destroying classes
6708
 
 
6709
 
  Revision 1.99  2002/10/07 21:30:27  peter
6710
 
    * removed obsolete rangecheck stuff
6711
 
 
6712
 
  Revision 1.98  2002/10/05 15:14:26  peter
6713
 
    * getparamangeldname for errordef
6714
 
 
6715
 
  Revision 1.97  2002/10/05 12:43:28  carl
6716
 
    * fixes for Delphi 6 compilation
6717
 
     (warning : Some features do not work under Delphi)
6718
 
 
6719
 
  Revision 1.96  2002/09/27 21:13:29  carl
6720
 
    * low-highval always checked if limit ober 2GB is reached (to avoid overflow)
6721
 
 
6722
 
  Revision 1.95  2002/09/16 09:31:10  florian
6723
 
    * fixed  currency size
6724
 
 
6725
 
  Revision 1.94  2002/09/09 17:34:15  peter
6726
 
    * tdicationary.replace added to replace and item in a dictionary. This
6727
 
      is only allowed for the same name
6728
 
    * varsyms are inserted in symtable before the types are parsed. This
6729
 
      fixes the long standing "var longint : longint" bug
6730
 
    - consume_idlist and idstringlist removed. The loops are inserted
6731
 
      at the callers place and uses the symtable for duplicate id checking
6732
 
 
6733
 
  Revision 1.93  2002/09/07 15:25:07  peter
6734
 
    * old logs removed and tabs fixed
6735
 
 
6736
 
  Revision 1.92  2002/09/05 19:29:42  peter
6737
 
    * memdebug enhancements
6738
 
 
6739
 
  Revision 1.91  2002/08/25 19:25:20  peter
6740
 
    * sym.insert_in_data removed
6741
 
    * symtable.insertvardata/insertconstdata added
6742
 
    * removed insert_in_data call from symtable.insert, it needs to be
6743
 
      called separatly. This allows to deref the address calculation
6744
 
    * procedures now calculate the parast addresses after the procedure
6745
 
      directives are parsed. This fixes the cdecl parast problem
6746
 
    * push_addr_param has an extra argument that specifies if cdecl is used
6747
 
      or not
6748
 
 
6749
 
  Revision 1.90  2002/08/18 20:06:25  peter
6750
 
    * inlining is now also allowed in interface
6751
 
    * renamed write/load to ppuwrite/ppuload
6752
 
    * tnode storing in ppu
6753
 
    * nld,ncon,nbas are already updated for storing in ppu
6754
 
 
6755
 
  Revision 1.89  2002/08/11 15:28:00  florian
6756
 
    + support of explicit type case <any ordinal type>->pointer
6757
 
      (delphi mode only)
6758
 
 
6759
 
  Revision 1.88  2002/08/11 14:32:28  peter
6760
 
    * renamed current_library to objectlibrary
6761
 
 
6762
 
  Revision 1.87  2002/08/11 13:24:13  peter
6763
 
    * saving of asmsymbols in ppu supported
6764
 
    * asmsymbollist global is removed and moved into a new class
6765
 
      tasmlibrarydata that will hold the info of a .a file which
6766
 
      corresponds with a single module. Added librarydata to tmodule
6767
 
      to keep the library info stored for the module. In the future the
6768
 
      objectfiles will also be stored to the tasmlibrarydata class
6769
 
    * all getlabel/newasmsymbol and friends are moved to the new class
6770
 
 
6771
 
  Revision 1.86  2002/08/09 07:33:03  florian
6772
 
    * a couple of interface related fixes
6773
 
 
6774
 
  Revision 1.85  2002/07/23 09:51:24  daniel
6775
 
  * Tried to make Tprocsym.defs protected. I didn't succeed but the cleanups
6776
 
    are worth comitting.
6777
 
 
6778
 
  Revision 1.84  2002/07/20 11:57:57  florian
6779
 
    * types.pas renamed to defbase.pas because D6 contains a types
6780
 
      unit so this would conflicts if D6 programms are compiled
6781
 
    + Willamette/SSE2 instructions to assembler added
6782
 
 
6783
 
  Revision 1.83  2002/07/11 14:41:30  florian
6784
 
    * start of the new generic parameter handling
6785
 
 
6786
 
  Revision 1.82  2002/07/07 09:52:32  florian
6787
 
    * powerpc target fixed, very simple units can be compiled
6788
 
    * some basic stuff for better callparanode handling, far from being finished
6789
 
 
6790
 
  Revision 1.81  2002/07/01 18:46:26  peter
6791
 
    * internal linker
6792
 
    * reorganized aasm layer
6793
 
 
6794
 
  Revision 1.80  2002/07/01 16:23:54  peter
6795
 
    * cg64 patch
6796
 
    * basics for currency
6797
 
    * asnode updates for class and interface (not finished)
6798
 
 
6799
 
  Revision 1.79  2002/05/18 13:34:18  peter
6800
 
    * readded missing revisions
6801
 
 
6802
 
  Revision 1.78  2002/05/16 19:46:44  carl
6803
 
  + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
6804
 
  + try to fix temp allocation (still in ifdef)
6805
 
  + generic constructor calls
6806
 
  + start of tassembler / tmodulebase class cleanup
6807
 
 
6808
 
  Revision 1.76  2002/05/12 16:53:10  peter
6809
 
    * moved entry and exitcode to ncgutil and cgobj
6810
 
    * foreach gets extra argument for passing local data to the
6811
 
      iterator function
6812
 
    * -CR checks also class typecasts at runtime by changing them
6813
 
      into as
6814
 
    * fixed compiler to cycle with the -CR option
6815
 
    * fixed stabs with elf writer, finally the global variables can
6816
 
      be watched
6817
 
    * removed a lot of routines from cga unit and replaced them by
6818
 
      calls to cgobj
6819
 
    * u32bit-s32bit updates for and,or,xor nodes. When one element is
6820
 
      u32bit then the other is typecasted also to u32bit without giving
6821
 
      a rangecheck warning/error.
6822
 
    * fixed pascal calling method with reversing also the high tree in
6823
 
      the parast, detected by tcalcst3 test
6824
 
 
6825
 
  Revision 1.75  2002/04/25 20:16:39  peter
6826
 
    * moved more routines from cga/n386util
6827
 
 
6828
 
  Revision 1.74  2002/04/23 19:16:35  peter
6829
 
    * add pinline unit that inserts compiler supported functions using
6830
 
      one or more statements
6831
 
    * moved finalize and setlength from ninl to pinline
6832
 
 
6833
 
  Revision 1.73  2002/04/21 19:02:05  peter
6834
 
    * removed newn and disposen nodes, the code is now directly
6835
 
      inlined from pexpr
6836
 
    * -an option that will write the secondpass nodes to the .s file, this
6837
 
      requires EXTDEBUG define to actually write the info
6838
 
    * fixed various internal errors and crashes due recent code changes
6839
 
 
6840
 
  Revision 1.72  2002/04/20 21:32:25  carl
6841
 
  + generic FPC_CHECKPOINTER
6842
 
  + first parameter offset in stack now portable
6843
 
  * rename some constants
6844
 
  + move some cpu stuff to other units
6845
 
  - remove unused constents
6846
 
  * fix stacksize for some targets
6847
 
  * fix generic size problems which depend now on EXTEND_SIZE constant
6848
 
 
6849
 
}