| blob | 08fa1b155733429ff0f6eb724342966c44c36d8a |
1 {
2 $Id$
3 Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller
5 Symbol table implementation for the definitions
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.
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.
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 }
23 {****************************************************************************
24 TDEF (base class for definitions)
25 ****************************************************************************}
27 const
28 { if you change one of the following contants, }
29 { you have also to change the typinfo unit }
30 { and the rtl/i386,template/rttip.inc files }
31 tkUnknown = 0;
32 tkInteger = 1;
33 tkChar = 2;
34 tkEnumeration = 3;
35 tkFloat = 4;
36 tkSet = 5;
37 tkMethod = 6;
38 tkSString = 7;
39 tkString = tkSString;
40 tkLString = 8;
41 tkAString = 9;
42 tkWString = 10;
43 tkVariant = 11;
44 tkArray = 12;
45 tkRecord = 13;
46 tkInterface = 14;
47 tkClass = 15;
48 tkObject = 16;
49 tkWChar = 17;
50 tkBool = 18;
51 tkInt64 = 19;
52 tkQWord = 20;
54 otSByte = 0;
55 otUByte = 1;
56 otSWord = 2;
57 otUWord = 3;
58 otSLong = 4;
59 otULong = 5;
61 ftSingle = 0;
62 ftDouble = 1;
63 ftExtended = 2;
64 ftComp = 3;
65 ftCurr = 4;
66 ftFixed16 = 5;
67 ftFixed32 = 6;
69 mkProcedure = 0;
70 mkFunction = 1;
71 mkConstructor = 2;
72 mkDestructor = 3;
73 mkClassProcedure= 4;
74 mkClassFunction = 5;
76 pfvar = 1;
77 pfConst = 2;
78 pfArray = 4;
79 pfAddress = 8;
80 pfReference = 16;
81 pfOut = 32;
83 {$ifdef MEMDEBUG}
84 var
85 manglenamesize : longint;
86 {$endif}
88 constructor tdef.init;
89 begin
90 inherited init;
91 deftype:=abstractdef;
92 owner := nil;
93 typesym := nil;
94 savesize := 0;
95 if registerdef then
96 symtablestack^.registerdef(@self);
97 has_rtti:=false;
98 has_inittable:=false;
99 {$ifdef GDB}
100 is_def_stab_written := not_written;
101 globalnb := 0;
102 {$endif GDB}
103 if assigned(lastglobaldef) then
104 begin
105 lastglobaldef^.nextglobal := @self;
106 previousglobal:=lastglobaldef;
107 end
108 else
109 begin
110 firstglobaldef := @self;
111 previousglobal := nil;
112 end;
113 lastglobaldef := @self;
114 nextglobal := nil;
115 end;
118 constructor tdef.load;
119 begin
120 inherited init;
121 deftype:=abstractdef;
122 owner := nil;
123 has_rtti:=false;
124 has_inittable:=false;
125 {$ifdef GDB}
126 is_def_stab_written := not_written;
127 globalnb := 0;
128 {$endif GDB}
129 if assigned(lastglobaldef) then
130 begin
131 lastglobaldef^.nextglobal := @self;
132 previousglobal:=lastglobaldef;
133 end
134 else
135 begin
136 firstglobaldef := @self;
137 previousglobal:=nil;
138 end;
139 lastglobaldef := @self;
140 nextglobal := nil;
141 { load }
142 indexnr:=readword;
143 typesym:=ptypesym(readsymref);
144 end;
147 destructor tdef.done;
148 begin
149 { first element ? }
150 if not(assigned(previousglobal)) then
151 begin
152 firstglobaldef := nextglobal;
153 if assigned(firstglobaldef) then
154 firstglobaldef^.previousglobal:=nil;
155 end
156 else
157 begin
158 { remove reference in the element before }
159 previousglobal^.nextglobal:=nextglobal;
160 end;
161 { last element ? }
162 if not(assigned(nextglobal)) then
163 begin
164 lastglobaldef := previousglobal;
165 if assigned(lastglobaldef) then
166 lastglobaldef^.nextglobal:=nil;
167 end
168 else
169 nextglobal^.previousglobal:=previousglobal;
170 previousglobal:=nil;
171 nextglobal:=nil;
172 {$ifdef SYNONYM}
173 while assigned(typesym) do
174 begin
175 typesym^.restype.setdef(nil);
176 typesym:=typesym^.synonym;
177 end;
178 {$endif}
179 end;
181 { used for enumdef because the symbols are
182 inserted in the owner symtable }
183 procedure tdef.correct_owner_symtable;
184 var
185 st : psymtable;
186 begin
187 if assigned(owner) and
188 (owner^.symtabletype in [recordsymtable,objectsymtable]) then
189 begin
190 owner^.defindex^.deleteindex(@self);
191 st:=owner;
192 while (st^.symtabletype in [recordsymtable,objectsymtable]) do
193 st:=st^.next;
194 st^.registerdef(@self);
195 end;
196 end;
199 function tdef.typename:string;
200 begin
201 if assigned(typesym) and not(deftype=procvardef) then
202 typename:=Upper(typesym^.name)
203 else
204 typename:=gettypename;
205 end;
207 function tdef.gettypename : string;
209 begin
210 gettypename:='<unknown type>'
211 end;
213 function tdef.is_in_current : boolean;
214 var
215 p : psymtable;
216 begin
217 p:=owner;
218 is_in_current:=false;
219 while assigned(p) do
220 begin
221 if (p=current_module^.globalsymtable) or (p=current_module^.localsymtable)
222 or (p^.symtabletype in [globalsymtable,staticsymtable]) then
223 begin
224 is_in_current:=true;
225 exit;
226 end
227 else if p^.symtabletype in [localsymtable,parasymtable,objectsymtable] then
228 begin
229 if assigned(p^.defowner) then
230 p:=pobjectdef(p^.defowner)^.owner
231 else
232 exit;
233 end
234 else
235 exit;
236 end;
238 end;
240 procedure tdef.write;
241 begin
242 writeword(indexnr);
243 writesymref(typesym);
244 {$ifdef GDB}
245 if globalnb = 0 then
246 begin
247 if assigned(owner) then
248 globalnb := owner^.getnewtypecount
249 else
250 begin
251 globalnb := PGlobalTypeCount^;
252 Inc(PGlobalTypeCount^);
253 end;
254 end;
255 {$endif GDB}
256 end;
259 function tdef.size : longint;
260 begin
261 size:=savesize;
262 end;
265 function tdef.alignment : longint;
266 begin
267 { normal alignment by default }
268 alignment:=0;
269 end;
272 {$ifdef GDB}
273 procedure tdef.set_globalnb;
274 begin
275 globalnb :=PGlobalTypeCount^;
276 inc(PglobalTypeCount^);
277 end;
279 function tdef.stabstring : pchar;
280 begin
281 stabstring := strpnew('t'+numberstring+';');
282 end;
285 function tdef.numberstring : string;
286 var table : psymtable;
287 begin
288 {formal def have no type !}
289 if deftype = formaldef then
290 begin
291 numberstring := voiddef^.numberstring;
292 exit;
293 end;
294 if (not assigned(typesym)) or (not typesym^.isusedinstab) then
295 begin
296 {set even if debuglist is not defined}
297 if assigned(typesym) then
298 typesym^.isusedinstab := true;
299 if assigned(debuglist) and (is_def_stab_written = not_written) then
300 concatstabto(debuglist);
301 end;
302 if not (cs_gdb_dbx in aktglobalswitches) then
303 begin
304 if globalnb = 0 then
305 set_globalnb;
306 numberstring := tostr(globalnb);
307 end
308 else
309 begin
310 if globalnb = 0 then
311 begin
312 if assigned(owner) then
313 globalnb := owner^.getnewtypecount
314 else
315 begin
316 globalnb := PGlobalTypeCount^;
317 Inc(PGlobalTypeCount^);
318 end;
319 end;
320 if assigned(typesym) then
321 begin
322 table := typesym^.owner;
323 if table^.unitid > 0 then
324 numberstring := '('+tostr(table^.unitid)+','+tostr(typesym^.restype.def^.globalnb)+')'
325 else
326 numberstring := tostr(globalnb);
327 exit;
328 end;
329 numberstring := tostr(globalnb);
330 end;
331 end;
334 function tdef.allstabstring : pchar;
335 var stabchar : string[2];
336 ss,st : pchar;
337 sname : string;
338 sym_line_no : longint;
339 begin
340 ss := stabstring;
341 getmem(st,strlen(ss)+512);
342 stabchar := 't';
343 if deftype in tagtypes then
344 stabchar := 'Tt';
345 if assigned(typesym) then
346 begin
347 sname := typesym^.name;
348 sym_line_no:=typesym^.fileinfo.line;
349 end
350 else
351 begin
352 sname := ' ';
353 sym_line_no:=0;
354 end;
355 strpcopy(st,'"'+sname+':'+stabchar+numberstring+'=');
356 strpcopy(strecopy(strend(st),ss),'",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0');
357 allstabstring := strnew(st);
358 freemem(st,strlen(ss)+512);
359 strdispose(ss);
360 end;
363 procedure tdef.concatstabto(asmlist : paasmoutput);
364 var stab_str : pchar;
365 begin
366 if ((typesym = nil) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches))
367 and (is_def_stab_written = not_written) then
368 begin
369 If cs_gdb_dbx in aktglobalswitches then
370 begin
371 { otherwise you get two of each def }
372 If assigned(typesym) then
373 begin
374 if typesym^.typ=symconst.typesym then
375 typesym^.isusedinstab:=true;
376 if (typesym^.owner = nil) or
377 ((typesym^.owner^.symtabletype = unitsymtable) and
378 punitsymtable(typesym^.owner)^.dbx_count_ok) then
379 begin
380 {with DBX we get the definition from the other objects }
381 is_def_stab_written := written;
382 exit;
383 end;
384 end;
385 end;
386 { to avoid infinite loops }
387 is_def_stab_written := being_written;
388 stab_str := allstabstring;
389 asmlist^.concat(new(pai_stabs,init(stab_str)));
390 is_def_stab_written := written;
391 end;
392 end;
393 {$endif GDB}
396 procedure tdef.deref;
397 begin
398 resolvesym(psym(typesym));
399 end;
402 { rtti generation }
403 procedure tdef.generate_rtti;
404 begin
405 if not has_rtti then
406 begin
407 has_rtti:=true;
408 getdatalabel(rtti_label);
409 write_child_rtti_data;
410 rttilist^.concat(new(pai_symbol,init(rtti_label,0)));
411 write_rtti_data;
412 rttilist^.concat(new(pai_symbol_end,init(rtti_label)));
413 end;
414 end;
417 function tdef.get_rtti_label : string;
418 begin
419 generate_rtti;
420 get_rtti_label:=rtti_label^.name;
421 end;
424 { init table handling }
425 function tdef.needs_inittable : boolean;
426 begin
427 needs_inittable:=false;
428 end;
431 procedure tdef.generate_inittable;
432 begin
433 has_inittable:=true;
434 getdatalabel(inittable_label);
435 write_child_init_data;
436 rttilist^.concat(new(pai_label,init(inittable_label)));
437 write_init_data;
438 end;
441 procedure tdef.write_init_data;
442 begin
443 write_rtti_data;
444 end;
447 procedure tdef.write_child_init_data;
448 begin
449 write_child_rtti_data;
450 end;
453 function tdef.get_inittable_label : pasmlabel;
454 begin
455 if not(has_inittable) then
456 generate_inittable;
457 get_inittable_label:=inittable_label;
458 end;
461 procedure tdef.write_rtti_name;
462 var
463 str : string;
464 begin
465 { name }
466 if assigned(typesym) then
467 begin
468 str:=typesym^.name;
469 rttilist^.concat(new(pai_string,init(chr(length(str))+str)));
470 end
471 else
472 rttilist^.concat(new(pai_string,init(#0)))
473 end;
476 { returns true, if the definition can be published }
477 function tdef.is_publishable : boolean;
478 begin
479 is_publishable:=false;
480 end;
483 procedure tdef.write_rtti_data;
484 begin
485 end;
488 procedure tdef.write_child_rtti_data;
489 begin
490 end;
493 function tdef.is_intregable : boolean;
495 begin
496 is_intregable:=false;
497 case deftype of
498 pointerdef,
499 enumdef,
500 procvardef :
501 is_intregable:=true;
502 orddef :
503 case porddef(@self)^.typ of
504 bool8bit,bool16bit,bool32bit,
505 u8bit,u16bit,u32bit,
506 s8bit,s16bit,s32bit:
507 is_intregable:=true;
508 end;
509 setdef:
510 is_intregable:=is_smallset(@self);
511 end;
512 end;
514 function tdef.is_fpuregable : boolean;
516 begin
517 is_fpuregable:=(deftype=floatdef) and not(pfloatdef(@self)^.typ in [f32bit,f16bit]);
518 end;
520 {****************************************************************************
521 TSTRINGDEF
522 ****************************************************************************}
524 constructor tstringdef.shortinit(l : byte);
525 begin
526 tdef.init;
527 string_typ:=st_shortstring;
528 deftype:=stringdef;
529 len:=l;
530 savesize:=len+1;
531 end;
534 constructor tstringdef.shortload;
535 begin
536 tdef.load;
537 string_typ:=st_shortstring;
538 deftype:=stringdef;
539 len:=readbyte;
540 savesize:=len+1;
541 end;
544 constructor tstringdef.longinit(l : longint);
545 begin
546 tdef.init;
547 string_typ:=st_longstring;
548 deftype:=stringdef;
549 len:=l;
550 savesize:=target_os.size_of_pointer;
551 end;
554 constructor tstringdef.longload;
555 begin
556 tdef.load;
557 deftype:=stringdef;
558 string_typ:=st_longstring;
559 len:=readlong;
560 savesize:=target_os.size_of_pointer;
561 end;
564 constructor tstringdef.ansiinit(l : longint);
565 begin
566 tdef.init;
567 string_typ:=st_ansistring;
568 deftype:=stringdef;
569 len:=l;
570 savesize:=target_os.size_of_pointer;
571 end;
574 constructor tstringdef.ansiload;
575 begin
576 tdef.load;
577 deftype:=stringdef;
578 string_typ:=st_ansistring;
579 len:=readlong;
580 savesize:=target_os.size_of_pointer;
581 end;
584 constructor tstringdef.wideinit(l : longint);
585 begin
586 tdef.init;
587 string_typ:=st_widestring;
588 deftype:=stringdef;
589 len:=l;
590 savesize:=target_os.size_of_pointer;
591 end;
594 constructor tstringdef.wideload;
595 begin
596 tdef.load;
597 deftype:=stringdef;
598 string_typ:=st_widestring;
599 len:=readlong;
600 savesize:=target_os.size_of_pointer;
601 end;
604 function tstringdef.stringtypname:string;
605 const
606 typname:array[tstringtype] of string[8]=('',
607 'SHORTSTR','LONGSTR','ANSISTR','WIDESTR'
608 );
609 begin
610 stringtypname:=typname[string_typ];
611 end;
614 function tstringdef.size : longint;
615 begin
616 size:=savesize;
617 end;
620 procedure tstringdef.write;
621 begin
622 tdef.write;
623 if string_typ=st_shortstring then
624 writebyte(len)
625 else
626 writelong(len);
627 case string_typ of
628 st_shortstring : current_ppu^.writeentry(ibshortstringdef);
629 st_longstring : current_ppu^.writeentry(iblongstringdef);
630 st_ansistring : current_ppu^.writeentry(ibansistringdef);
631 st_widestring : current_ppu^.writeentry(ibwidestringdef);
632 end;
633 end;
636 {$ifdef GDB}
637 function tstringdef.stabstring : pchar;
638 var
639 bytest,charst,longst : string;
640 begin
641 case string_typ of
642 st_shortstring:
643 begin
644 charst := typeglobalnumber('char');
645 { this is what I found in stabs.texinfo but
646 gdb 4.12 for go32 doesn't understand that !! }
647 {$IfDef GDBknowsstrings}
648 stabstring := strpnew('n'+charst+';'+tostr(len));
649 {$else}
650 bytest := typeglobalnumber('byte');
651 stabstring := strpnew('s'+tostr(len+1)+'length:'+bytest
652 +',0,8;st:ar'+bytest
653 +';1;'+tostr(len)+';'+charst+',8,'+tostr(len*8)+';;');
654 {$EndIf}
655 end;
656 st_longstring:
657 begin
658 charst := typeglobalnumber('char');
659 { this is what I found in stabs.texinfo but
660 gdb 4.12 for go32 doesn't understand that !! }
661 {$IfDef GDBknowsstrings}
662 stabstring := strpnew('n'+charst+';'+tostr(len));
663 {$else}
664 bytest := typeglobalnumber('byte');
665 longst := typeglobalnumber('longint');
666 stabstring := strpnew('s'+tostr(len+5)+'length:'+longst
667 +',0,32;dummy:'+bytest+',32,8;st:ar'+bytest
668 +';1;'+tostr(len)+';'+charst+',40,'+tostr(len*8)+';;');
669 {$EndIf}
670 end;
671 st_ansistring:
672 begin
673 { an ansi string looks like a pchar easy !! }
674 stabstring:=strpnew('*'+typeglobalnumber('char'));
675 end;
676 st_widestring:
677 begin
678 { an ansi string looks like a pchar easy !! }
679 stabstring:=strpnew('*'+typeglobalnumber('char'));
680 end;
681 end;
682 end;
685 procedure tstringdef.concatstabto(asmlist : paasmoutput);
686 begin
687 inherited concatstabto(asmlist);
688 end;
689 {$endif GDB}
692 function tstringdef.needs_inittable : boolean;
693 begin
694 needs_inittable:=string_typ in [st_ansistring,st_widestring];
695 end;
697 function tstringdef.gettypename : string;
699 const
700 names : array[tstringtype] of string[20] = ('',
701 'ShortString','LongString','AnsiString','WideString');
703 begin
704 gettypename:=names[string_typ];
705 end;
707 procedure tstringdef.write_rtti_data;
708 begin
709 case string_typ of
710 st_ansistring:
711 begin
712 rttilist^.concat(new(pai_const,init_8bit(tkAString)));
713 write_rtti_name;
714 end;
715 st_widestring:
716 begin
717 rttilist^.concat(new(pai_const,init_8bit(tkWString)));
718 write_rtti_name;
719 end;
720 st_longstring:
721 begin
722 rttilist^.concat(new(pai_const,init_8bit(tkLString)));
723 write_rtti_name;
724 end;
725 st_shortstring:
726 begin
727 rttilist^.concat(new(pai_const,init_8bit(tkSString)));
728 write_rtti_name;
729 rttilist^.concat(new(pai_const,init_8bit(len)));
730 end;
731 end;
732 end;
735 function tstringdef.is_publishable : boolean;
736 begin
737 is_publishable:=true;
738 end;
741 {****************************************************************************
742 TENUMDEF
743 ****************************************************************************}
745 constructor tenumdef.init;
746 begin
747 tdef.init;
748 deftype:=enumdef;
749 minval:=0;
750 maxval:=0;
751 calcsavesize;
752 has_jumps:=false;
753 basedef:=nil;
754 rangenr:=0;
755 firstenum:=nil;
756 correct_owner_symtable;
757 end;
759 constructor tenumdef.init_subrange(_basedef:penumdef;_min,_max:longint);
760 begin
761 tdef.init;
762 deftype:=enumdef;
763 minval:=_min;
764 maxval:=_max;
765 basedef:=_basedef;
766 calcsavesize;
767 has_jumps:=false;
768 rangenr:=0;
769 firstenum:=basedef^.firstenum;
770 while assigned(firstenum) and (penumsym(firstenum)^.value<>minval) do
771 firstenum:=firstenum^.nextenum;
772 correct_owner_symtable;
773 end;
776 constructor tenumdef.load;
777 begin
778 tdef.load;
779 deftype:=enumdef;
780 basedef:=penumdef(readdefref);
781 minval:=readlong;
782 maxval:=readlong;
783 savesize:=readlong;
784 has_jumps:=false;
785 firstenum:=Nil;
786 end;
789 procedure tenumdef.calcsavesize;
790 begin
791 if (aktpackenum=4) or (min<0) or (max>65535) then
792 savesize:=4
793 else
794 if (aktpackenum=2) or (min<0) or (max>255) then
795 savesize:=2
796 else
797 savesize:=1;
798 end;
801 procedure tenumdef.setmax(_max:longint);
802 begin
803 maxval:=_max;
804 calcsavesize;
805 end;
808 procedure tenumdef.setmin(_min:longint);
809 begin
810 minval:=_min;
811 calcsavesize;
812 end;
815 function tenumdef.min:longint;
816 begin
817 min:=minval;
818 end;
821 function tenumdef.max:longint;
822 begin
823 max:=maxval;
824 end;
827 procedure tenumdef.deref;
828 begin
829 inherited deref;
830 resolvedef(pdef(basedef));
831 end;
834 destructor tenumdef.done;
835 begin
836 inherited done;
837 end;
840 procedure tenumdef.write;
841 begin
842 tdef.write;
843 writedefref(basedef);
844 writelong(min);
845 writelong(max);
846 writelong(savesize);
847 current_ppu^.writeentry(ibenumdef);
848 end;
851 function tenumdef.getrangecheckstring : string;
852 begin
853 if (cs_create_smart in aktmoduleswitches) then
854 getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
855 else
856 getrangecheckstring:='R_'+tostr(rangenr);
857 end;
860 procedure tenumdef.genrangecheck;
861 begin
862 if rangenr=0 then
863 begin
864 { generate two constant for bounds }
865 getlabelnr(rangenr);
866 if (cs_create_smart in aktmoduleswitches) then
867 datasegment^.concat(new(pai_symbol,initname_global(getrangecheckstring,8)))
868 else
869 datasegment^.concat(new(pai_symbol,initname(getrangecheckstring,8)));
870 datasegment^.concat(new(pai_const,init_32bit(min)));
871 datasegment^.concat(new(pai_const,init_32bit(max)));
872 end;
873 end;
876 {$ifdef GDB}
877 function tenumdef.stabstring : pchar;
878 var st,st2 : pchar;
879 p : penumsym;
880 s : string;
881 memsize : word;
882 begin
883 memsize := memsizeinc;
884 getmem(st,memsize);
885 { we can specify the size with @s<size>; prefix PM }
886 if savesize <> target_os.size_of_longint then
887 strpcopy(st,'@s'+tostr(savesize)+';e')
888 else
889 strpcopy(st,'e');
890 p := firstenum;
891 while assigned(p) do
892 begin
893 s :=p^.name+':'+tostr(p^.value)+',';
894 { place for the ending ';' also }
895 if (strlen(st)+length(s)+1<memsize) then
896 strpcopy(strend(st),s)
897 else
898 begin
899 getmem(st2,memsize+memsizeinc);
900 strcopy(st2,st);
901 freemem(st,memsize);
902 st := st2;
903 memsize := memsize+memsizeinc;
904 strpcopy(strend(st),s);
905 end;
906 p := p^.nextenum;
907 end;
908 strpcopy(strend(st),';');
909 stabstring := strnew(st);
910 freemem(st,memsize);
911 end;
912 {$endif GDB}
915 procedure tenumdef.write_child_rtti_data;
916 begin
917 if assigned(basedef) then
918 basedef^.get_rtti_label;
919 end;
922 procedure tenumdef.write_rtti_data;
924 var
925 hp : penumsym;
927 begin
928 rttilist^.concat(new(pai_const,init_8bit(tkEnumeration)));
929 write_rtti_name;
930 case savesize of
931 1:
932 rttilist^.concat(new(pai_const,init_8bit(otUByte)));
933 2:
934 rttilist^.concat(new(pai_const,init_8bit(otUWord)));
935 4:
936 rttilist^.concat(new(pai_const,init_8bit(otULong)));
937 end;
938 rttilist^.concat(new(pai_const,init_32bit(min)));
939 rttilist^.concat(new(pai_const,init_32bit(max)));
940 if assigned(basedef) then
941 rttilist^.concat(new(pai_const_symbol,initname(basedef^.get_rtti_label)))
942 else
943 rttilist^.concat(new(pai_const,init_32bit(0)));
944 hp:=firstenum;
945 while assigned(hp) do
946 begin
947 rttilist^.concat(new(pai_const,init_8bit(length(hp^.name))));
948 rttilist^.concat(new(pai_string,init(globals.lower(hp^.name))));
949 hp:=hp^.nextenum;
950 end;
951 rttilist^.concat(new(pai_const,init_8bit(0)));
952 end;
955 function tenumdef.is_publishable : boolean;
956 begin
957 is_publishable:=true;
958 end;
960 function tenumdef.gettypename : string;
962 begin
963 gettypename:='<enumeration type>';
964 end;
966 {****************************************************************************
967 TORDDEF
968 ****************************************************************************}
970 constructor torddef.init(t : tbasetype;v,b : longint);
971 begin
972 inherited init;
973 deftype:=orddef;
974 low:=v;
975 high:=b;
976 typ:=t;
977 rangenr:=0;
978 setsize;
979 end;
982 constructor torddef.load;
983 begin
984 inherited load;
985 deftype:=orddef;
986 typ:=tbasetype(readbyte);
987 low:=readlong;
988 high:=readlong;
989 rangenr:=0;
990 setsize;
991 end;
994 procedure torddef.setsize;
995 begin
996 if typ=uauto then
997 begin
998 { generate a unsigned range if high<0 and low>=0 }
999 if (low>=0) and (high<0) then
1000 begin
1001 savesize:=4;
1002 typ:=u32bit;
1003 end
1004 else if (low>=0) and (high<=255) then
1005 begin
1006 savesize:=1;
1007 typ:=u8bit;
1008 end
1009 else if (low>=-128) and (high<=127) then
1010 begin
1011 savesize:=1;
1012 typ:=s8bit;
1013 end
1014 else if (low>=0) and (high<=65536) then
1015 begin
1016 savesize:=2;
1017 typ:=u16bit;
1018 end
1019 else if (low>=-32768) and (high<=32767) then
1020 begin
1021 savesize:=2;
1022 typ:=s16bit;
1023 end
1024 else
1025 begin
1026 savesize:=4;
1027 typ:=s32bit;
1028 end;
1029 end
1030 else
1031 begin
1032 case typ of
1033 u8bit,s8bit,
1034 uchar,bool8bit:
1035 savesize:=1;
1037 u16bit,s16bit,
1038 bool16bit,uwidechar:
1039 savesize:=2;
1041 s32bit,u32bit,
1042 bool32bit:
1043 savesize:=4;
1045 u64bit,s64bit:
1046 savesize:=8;
1047 else
1048 savesize:=0;
1049 end;
1050 end;
1051 { there are no entrys for range checking }
1052 rangenr:=0;
1053 end;
1055 function torddef.getrangecheckstring : string;
1057 begin
1058 if (cs_create_smart in aktmoduleswitches) then
1059 getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
1060 else
1061 getrangecheckstring:='R_'+tostr(rangenr);
1062 end;
1064 procedure torddef.genrangecheck;
1065 var
1066 rangechecksize : longint;
1067 begin
1068 if rangenr=0 then
1069 begin
1070 if low<=high then
1071 rangechecksize:=8
1072 else
1073 rangechecksize:=16;
1074 { generate two constant for bounds }
1075 getlabelnr(rangenr);
1076 if (cs_create_smart in aktmoduleswitches) then
1077 datasegment^.concat(new(pai_symbol,initname_global(getrangecheckstring,rangechecksize)))
1078 else
1079 datasegment^.concat(new(pai_symbol,initname(getrangecheckstring,rangechecksize)));
1080 if low<=high then
1081 begin
1082 datasegment^.concat(new(pai_const,init_32bit(low)));
1083 datasegment^.concat(new(pai_const,init_32bit(high)));
1084 end
1085 { for u32bit we need two bounds }
1086 else
1087 begin
1088 datasegment^.concat(new(pai_const,init_32bit(low)));
1089 datasegment^.concat(new(pai_const,init_32bit($7fffffff)));
1090 datasegment^.concat(new(pai_const,init_32bit($80000000)));
1091 datasegment^.concat(new(pai_const,init_32bit(high)));
1092 end;
1093 end;
1094 end;
1097 procedure torddef.write;
1098 begin
1099 tdef.write;
1100 writebyte(byte(typ));
1101 writelong(low);
1102 writelong(high);
1103 current_ppu^.writeentry(iborddef);
1104 end;
1107 {$ifdef GDB}
1108 function torddef.stabstring : pchar;
1109 begin
1110 case typ of
1111 uvoid : stabstring := strpnew(numberstring+';');
1112 {GDB 4.12 for go32 doesn't like boolean as range for 0 to 1 !!!}
1113 {$ifdef Use_integer_types_for_boolean}
1114 bool8bit,
1115 bool16bit,
1116 bool32bit : stabstring := strpnew('r'+numberstring+';0;255;');
1117 {$else : not Use_integer_types_for_boolean}
1118 bool8bit : stabstring := strpnew('-21;');
1119 bool16bit : stabstring := strpnew('-22;');
1120 bool32bit : stabstring := strpnew('-23;');
1121 u64bit : stabstring := strpnew('-32;');
1122 s64bit : stabstring := strpnew('-31;');
1123 {$endif not Use_integer_types_for_boolean}
1124 { u32bit : stabstring := strpnew('r'+
1125 s32bitdef^.numberstring+';0;-1;'); }
1126 else
1127 stabstring := strpnew('r'+s32bitdef^.numberstring+';'+tostr(low)+';'+tostr(high)+';');
1128 end;
1129 end;
1130 {$endif GDB}
1133 procedure torddef.write_rtti_data;
1135 procedure dointeger;
1136 const
1137 trans : array[uchar..bool8bit] of byte =
1138 (otUByte,otUByte,otUWord,otULong,otSByte,otSWord,otSLong,otUByte);
1139 begin
1140 write_rtti_name;
1141 rttilist^.concat(new(pai_const,init_8bit(byte(trans[typ]))));
1142 rttilist^.concat(new(pai_const,init_32bit(low)));
1143 rttilist^.concat(new(pai_const,init_32bit(high)));
1144 end;
1146 begin
1147 case typ of
1148 s64bit :
1149 begin
1150 rttilist^.concat(new(pai_const,init_8bit(tkInt64)));
1151 write_rtti_name;
1152 { low }
1153 rttilist^.concat(new(pai_const,init_32bit($0)));
1154 rttilist^.concat(new(pai_const,init_32bit($8000)));
1155 { high }
1156 rttilist^.concat(new(pai_const,init_32bit($ffff)));
1157 rttilist^.concat(new(pai_const,init_32bit($7fff)));
1158 end;
1159 u64bit :
1160 begin
1161 rttilist^.concat(new(pai_const,init_8bit(tkQWord)));
1162 write_rtti_name;
1163 { low }
1164 rttilist^.concat(new(pai_const,init_32bit($0)));
1165 rttilist^.concat(new(pai_const,init_32bit($0)));
1166 { high }
1167 rttilist^.concat(new(pai_const,init_32bit($0)));
1168 rttilist^.concat(new(pai_const,init_32bit($8000)));
1169 end;
1170 bool8bit:
1171 begin
1172 rttilist^.concat(new(pai_const,init_8bit(tkBool)));
1173 dointeger;
1174 end;
1175 uchar:
1176 begin
1177 rttilist^.concat(new(pai_const,init_8bit(tkChar)));
1178 dointeger;
1179 end;
1180 uwidechar:
1181 begin
1182 rttilist^.concat(new(pai_const,init_8bit(tkWChar)));
1183 dointeger;
1184 end;
1185 else
1186 begin
1187 rttilist^.concat(new(pai_const,init_8bit(tkInteger)));
1188 dointeger;
1189 end;
1190 end;
1191 end;
1194 function torddef.is_publishable : boolean;
1195 begin
1196 is_publishable:=typ in [uchar..bool8bit];
1197 end;
1199 function torddef.gettypename : string;
1201 const
1202 names : array[tbasetype] of string[20] = ('<unknown type>',
1203 'untyped','Char','Byte','Word','DWord','ShortInt',
1204 'SmallInt','LongInt','Boolean','WordBool',
1205 'LongBool','QWord','Int64','WideChar');
1207 begin
1208 gettypename:=names[typ];
1209 end;
1211 {****************************************************************************
1212 TFLOATDEF
1213 ****************************************************************************}
1215 constructor tfloatdef.init(t : tfloattype);
1216 begin
1217 inherited init;
1218 deftype:=floatdef;
1219 typ:=t;
1220 setsize;
1221 end;
1224 constructor tfloatdef.load;
1225 begin
1226 inherited load;
1227 deftype:=floatdef;
1228 typ:=tfloattype(readbyte);
1229 setsize;
1230 end;
1233 procedure tfloatdef.setsize;
1234 begin
1235 case typ of
1236 f16bit : savesize:=2;
1237 f32bit,
1238 s32real : savesize:=4;
1239 s64real : savesize:=8;
1240 s80real : savesize:=extended_size;
1241 s64comp : savesize:=8;
1242 else
1243 savesize:=0;
1244 end;
1245 end;
1248 procedure tfloatdef.write;
1249 begin
1250 inherited write;
1251 writebyte(byte(typ));
1252 current_ppu^.writeentry(ibfloatdef);
1253 end;
1256 {$ifdef GDB}
1257 function tfloatdef.stabstring : pchar;
1258 begin
1259 case typ of
1260 s32real,
1261 s64real : stabstring := strpnew('r'+
1262 s32bitdef^.numberstring+';'+tostr(savesize)+';0;');
1263 { for fixed real use longint instead to be able to }
1264 { debug something at least }
1265 f32bit:
1266 stabstring := s32bitdef^.stabstring;
1267 f16bit:
1268 stabstring := strpnew('r'+s32bitdef^.numberstring+';0;'+
1269 tostr($ffff)+';');
1270 { found this solution in stabsread.c from GDB v4.16 }
1271 s64comp : stabstring := strpnew('r'+
1272 s32bitdef^.numberstring+';-'+tostr(savesize)+';0;');
1273 {$ifdef i386}
1274 { under dos at least you must give a size of twelve instead of 10 !! }
1275 { this is probably do to the fact that in gcc all is pushed in 4 bytes size }
1276 s80real : stabstring := strpnew('r'+s32bitdef^.numberstring+';12;0;');
1277 {$endif i386}
1278 else
1279 internalerror(10005);
1280 end;
1281 end;
1282 {$endif GDB}
1285 procedure tfloatdef.write_rtti_data;
1286 const
1287 {tfloattype = (s32real,s64real,s80real,s64bit,f16bit,f32bit);}
1288 translate : array[tfloattype] of byte =
1289 (ftSingle,ftDouble,ftExtended,ftComp,ftFixed16,ftFixed32);
1290 begin
1291 rttilist^.concat(new(pai_const,init_8bit(tkFloat)));
1292 write_rtti_name;
1293 rttilist^.concat(new(pai_const,init_8bit(translate[typ])));
1294 end;
1297 function tfloatdef.is_publishable : boolean;
1298 begin
1299 is_publishable:=true;
1300 end;
1302 function tfloatdef.gettypename : string;
1304 const
1305 names : array[tfloattype] of string[20] = (
1306 'Single','Double','Extended','Comp','Fixed','Fixed16');
1308 begin
1309 gettypename:=names[typ];
1310 end;
1312 {****************************************************************************
1313 TFILEDEF
1314 ****************************************************************************}
1316 constructor tfiledef.inittext;
1317 begin
1318 inherited init;
1319 deftype:=filedef;
1320 filetyp:=ft_text;
1321 typedfiletype.reset;
1322 setsize;
1323 end;
1326 constructor tfiledef.inituntyped;
1327 begin
1328 inherited init;
1329 deftype:=filedef;
1330 filetyp:=ft_untyped;
1331 typedfiletype.reset;
1332 setsize;
1333 end;
1336 constructor tfiledef.inittyped(const tt : ttype);
1337 begin
1338 inherited init;
1339 deftype:=filedef;
1340 filetyp:=ft_typed;
1341 typedfiletype:=tt;
1342 setsize;
1343 end;
1346 constructor tfiledef.inittypeddef(p : pdef);
1347 begin
1348 inherited init;
1349 deftype:=filedef;
1350 filetyp:=ft_typed;
1351 typedfiletype.setdef(p);
1352 setsize;
1353 end;
1356 constructor tfiledef.load;
1357 begin
1358 inherited load;
1359 deftype:=filedef;
1360 filetyp:=tfiletyp(readbyte);
1361 if filetyp=ft_typed then
1362 typedfiletype.load
1363 else
1364 typedfiletype.reset;
1365 setsize;
1366 end;
1369 procedure tfiledef.deref;
1370 begin
1371 inherited deref;
1372 if filetyp=ft_typed then
1373 typedfiletype.resolve;
1374 end;
1377 procedure tfiledef.setsize;
1378 begin
1379 case filetyp of
1380 ft_text :
1381 savesize:=572;
1382 ft_typed,
1383 ft_untyped :
1384 savesize:=316;
1385 end;
1386 end;
1389 procedure tfiledef.write;
1390 begin
1391 inherited write;
1392 writebyte(byte(filetyp));
1393 if filetyp=ft_typed then
1394 typedfiletype.write;
1395 current_ppu^.writeentry(ibfiledef);
1396 end;
1399 {$ifdef GDB}
1400 function tfiledef.stabstring : pchar;
1401 begin
1402 {$IfDef GDBknowsfiles}
1403 case filetyp of
1404 ft_typed :
1405 stabstring := strpnew('d'+typedfiletype.def^.numberstring{+';'});
1406 ft_untyped :
1407 stabstring := strpnew('d'+voiddef^.numberstring{+';'});
1408 ft_text :
1409 stabstring := strpnew('d'+cchardef^.numberstring{+';'});
1410 end;
1411 {$Else}
1412 {based on
1413 FileRec = Packed Record
1414 Handle,
1415 Mode,
1416 RecSize : longint;
1417 _private : array[1..32] of byte;
1418 UserData : array[1..16] of byte;
1419 name : array[0..255] of char;
1420 End; }
1421 { the buffer part is still missing !! (PM) }
1422 { but the string could become too long !! }
1423 stabstring := strpnew('s'+tostr(savesize)+
1424 'HANDLE:'+typeglobalnumber('longint')+',0,32;'+
1425 'MODE:'+typeglobalnumber('longint')+',32,32;'+
1426 'RECSIZE:'+typeglobalnumber('longint')+',64,32;'+
1427 '_PRIVATE:ar'+typeglobalnumber('word')+';1;32;'+typeglobalnumber('byte')
1428 +',96,256;'+
1429 'USERDATA:ar'+typeglobalnumber('word')+';1;16;'+typeglobalnumber('byte')
1430 +',352,128;'+
1431 'NAME:ar'+typeglobalnumber('word')+';0;255;'+typeglobalnumber('char')
1432 +',480,2048;;');
1433 {$EndIf}
1434 end;
1437 procedure tfiledef.concatstabto(asmlist : paasmoutput);
1438 begin
1439 { most file defs are unnamed !!! }
1440 if ((typesym = nil) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
1441 (is_def_stab_written = not_written) then
1442 begin
1443 if assigned(typedfiletype.def) then forcestabto(asmlist,typedfiletype.def);
1444 inherited concatstabto(asmlist);
1445 end;
1446 end;
1447 {$endif GDB}
1449 function tfiledef.gettypename : string;
1451 begin
1452 case filetyp of
1453 ft_untyped:
1454 gettypename:='File';
1455 ft_typed:
1456 gettypename:='File Of '+typedfiletype.def^.typename;
1457 ft_text:
1458 gettypename:='Text'
1459 end;
1460 end;
1464 {****************************************************************************
1465 TPOINTERDEF
1466 ****************************************************************************}
1468 constructor tpointerdef.init(const tt : ttype);
1469 begin
1470 tdef.init;
1471 deftype:=pointerdef;
1472 pointertype:=tt;
1473 is_far:=false;
1474 savesize:=target_os.size_of_pointer;
1475 end;
1478 constructor tpointerdef.initfar(const tt : ttype);
1479 begin
1480 tdef.init;
1481 deftype:=pointerdef;
1482 pointertype:=tt;
1483 is_far:=true;
1484 savesize:=target_os.size_of_pointer;
1485 end;
1488 constructor tpointerdef.initdef(p : pdef);
1489 var
1490 t : ttype;
1491 begin
1492 t.setdef(p);
1493 tpointerdef.init(t);
1494 end;
1497 constructor tpointerdef.initfardef(p : pdef);
1498 var
1499 t : ttype;
1500 begin
1501 t.setdef(p);
1502 tpointerdef.initfar(t);
1503 end;
1507 constructor tpointerdef.load;
1508 begin
1509 tdef.load;
1510 deftype:=pointerdef;
1511 pointertype.load;
1512 is_far:=(readbyte<>0);
1513 savesize:=target_os.size_of_pointer;
1514 end;
1517 destructor tpointerdef.done;
1518 begin
1519 if assigned(pointertype.def) and
1520 (pointertype.def^.deftype=forwarddef) then
1521 begin
1522 dispose(pointertype.def,done);
1523 pointertype.reset;
1524 end;
1525 inherited done;
1526 end;
1529 procedure tpointerdef.deref;
1530 begin
1531 inherited deref;
1532 pointertype.resolve;
1533 end;
1536 procedure tpointerdef.write;
1537 begin
1538 inherited write;
1539 pointertype.write;
1540 writebyte(byte(is_far));
1541 current_ppu^.writeentry(ibpointerdef);
1542 end;
1545 {$ifdef GDB}
1546 function tpointerdef.stabstring : pchar;
1547 begin
1548 stabstring := strpnew('*'+pointertype.def^.numberstring);
1549 end;
1552 procedure tpointerdef.concatstabto(asmlist : paasmoutput);
1553 var st,nb : string;
1554 sym_line_no : longint;
1555 begin
1556 if assigned(pointertype.def) and
1557 (pointertype.def^.deftype=forwarddef) then
1558 exit;
1560 if ( (typesym=nil) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
1561 (is_def_stab_written = not_written) then
1562 begin
1563 is_def_stab_written := being_written;
1564 if assigned(pointertype.def) and
1565 (pointertype.def^.deftype in [recorddef,objectdef]) then
1566 begin
1567 nb:=pointertype.def^.numberstring;
1568 {to avoid infinite recursion in record with next-like fields }
1569 if pointertype.def^.is_def_stab_written = being_written then
1570 begin
1571 if assigned(pointertype.def^.typesym) then
1572 begin
1573 if assigned(typesym) then
1574 begin
1575 st := typesym^.name;
1576 sym_line_no:=typesym^.fileinfo.line;
1577 end
1578 else
1579 begin
1580 st := ' ';
1581 sym_line_no:=0;
1582 end;
1583 st := '"'+st+':t'+numberstring+'=*'+nb
1584 +'=xs'+pointertype.def^.typesym^.name+':",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0';
1585 asmlist^.concat(new(pai_stabs,init(strpnew(st))));
1586 end;
1587 end
1588 else
1589 begin
1590 is_def_stab_written := not_written;
1591 inherited concatstabto(asmlist);
1592 end;
1593 is_def_stab_written := written;
1594 end
1595 else
1596 begin
1597 if assigned(pointertype.def) then
1598 forcestabto(asmlist,pointertype.def);
1599 is_def_stab_written := not_written;
1600 inherited concatstabto(asmlist);
1601 end;
1602 end;
1603 end;
1604 {$endif GDB}
1606 function tpointerdef.gettypename : string;
1608 begin
1609 gettypename:='^'+pointertype.def^.typename;
1610 end;
1612 {****************************************************************************
1613 TCLASSREFDEF
1614 ****************************************************************************}
1616 constructor tclassrefdef.init(def : pdef);
1617 begin
1618 inherited initdef(def);
1619 deftype:=classrefdef;
1620 end;
1623 constructor tclassrefdef.load;
1624 begin
1625 { be careful, tclassdefref inherits from tpointerdef }
1626 tdef.load;
1627 deftype:=classrefdef;
1628 pointertype.load;
1629 is_far:=false;
1630 savesize:=target_os.size_of_pointer;
1631 end;
1634 procedure tclassrefdef.write;
1635 begin
1636 { be careful, tclassdefref inherits from tpointerdef }
1637 tdef.write;
1638 pointertype.write;
1639 current_ppu^.writeentry(ibclassrefdef);
1640 end;
1643 {$ifdef GDB}
1644 function tclassrefdef.stabstring : pchar;
1645 begin
1646 stabstring:=strpnew(pvmtdef^.numberstring+';');
1647 end;
1650 procedure tclassrefdef.concatstabto(asmlist : paasmoutput);
1651 begin
1652 inherited concatstabto(asmlist);
1653 end;
1654 {$endif GDB}
1656 function tclassrefdef.gettypename : string;
1658 begin
1659 gettypename:='Class Of '+pointertype.def^.typename;
1660 end;
1663 {***************************************************************************
1664 TSETDEF
1665 ***************************************************************************}
1667 { For i386 smallsets work,
1668 for m68k there are problems
1669 can be test by compiling with -dusesmallset PM }
1670 {$ifdef i386}
1671 {$define usesmallset}
1672 {$endif i386}
1674 constructor tsetdef.init(s : pdef;high : longint);
1675 begin
1676 inherited init;
1677 deftype:=setdef;
1678 elementtype.setdef(s);
1679 {$ifdef usesmallset}
1680 { small sets only working for i386 PM }
1681 if high<32 then
1682 begin
1683 settype:=smallset;
1684 {$ifdef testvarsets}
1685 if aktsetalloc=0 THEN { $PACKSET Fixed?}
1686 {$endif}
1687 savesize:=Sizeof(longint)
1688 {$ifdef testvarsets}
1689 else {No, use $PACKSET VALUE for rounding}
1690 savesize:=aktsetalloc*((high+aktsetalloc*8-1) DIV (aktsetalloc*8))
1691 {$endif}
1692 ;
1693 end
1694 else
1695 {$endif usesmallset}
1696 if high<256 then
1697 begin
1698 settype:=normset;
1699 savesize:=32;
1700 end
1701 else
1702 {$ifdef testvarsets}
1703 if high<$10000 then
1704 begin
1705 settype:=varset;
1706 savesize:=4*((high+31) div 32);
1707 end
1708 else
1709 {$endif testvarsets}
1710 Message(sym_e_ill_type_decl_set);
1711 end;
1714 constructor tsetdef.load;
1715 begin
1716 inherited load;
1717 deftype:=setdef;
1718 elementtype.load;
1719 settype:=tsettype(readbyte);
1720 case settype of
1721 normset : savesize:=32;
1722 varset : savesize:=readlong;
1723 smallset : savesize:=Sizeof(longint);
1724 end;
1725 end;
1728 destructor tsetdef.done;
1729 begin
1730 inherited done;
1731 end;
1734 procedure tsetdef.write;
1735 begin
1736 inherited write;
1737 elementtype.write;
1738 writebyte(byte(settype));
1739 if settype=varset then
1740 writelong(savesize);
1741 current_ppu^.writeentry(ibsetdef);
1742 end;
1745 {$ifdef GDB}
1746 function tsetdef.stabstring : pchar;
1747 begin
1748 { For small sets write a longint, which can at least be seen
1749 in the current GDB's (PFV)
1750 this is obsolete with GDBPAS !!
1751 and anyhow creates problems with version 4.18!! PM
1752 if settype=smallset then
1753 stabstring := strpnew('r'+s32bitdef^.numberstring+';0;0xffffffff;')
1754 else }
1755 stabstring := strpnew('@s'+tostr(savesize)+';S'+elementtype.def^.numberstring);
1756 end;
1759 procedure tsetdef.concatstabto(asmlist : paasmoutput);
1760 begin
1761 if ( not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
1762 (is_def_stab_written = not_written) then
1763 begin
1764 if assigned(elementtype.def) then
1765 forcestabto(asmlist,elementtype.def);
1766 inherited concatstabto(asmlist);
1767 end;
1768 end;
1769 {$endif GDB}
1772 procedure tsetdef.deref;
1773 begin
1774 inherited deref;
1775 elementtype.resolve;
1776 end;
1779 procedure tsetdef.write_rtti_data;
1780 begin
1781 rttilist^.concat(new(pai_const,init_8bit(tkSet)));
1782 write_rtti_name;
1783 rttilist^.concat(new(pai_const,init_8bit(otULong)));
1784 rttilist^.concat(new(pai_const_symbol,initname(elementtype.def^.get_rtti_label)));
1785 end;
1788 procedure tsetdef.write_child_rtti_data;
1789 begin
1790 elementtype.def^.get_rtti_label;
1791 end;
1794 function tsetdef.is_publishable : boolean;
1795 begin
1796 is_publishable:=settype=smallset;
1797 end;
1799 function tsetdef.gettypename : string;
1801 begin
1802 if assigned(elementtype.def) then
1803 gettypename:='Set Of '+elementtype.def^.typename
1804 else
1805 gettypename:='Empty Set';
1806 end;
1809 {***************************************************************************
1810 TFORMALDEF
1811 ***************************************************************************}
1813 constructor tformaldef.init;
1814 var
1815 stregdef : boolean;
1816 begin
1817 stregdef:=registerdef;
1818 registerdef:=false;
1819 inherited init;
1820 deftype:=formaldef;
1821 registerdef:=stregdef;
1822 { formaldef must be registered at unit level !! }
1823 if registerdef and assigned(current_module) then
1824 if assigned(current_module^.localsymtable) then
1825 psymtable(current_module^.localsymtable)^.registerdef(@self)
1826 else if assigned(current_module^.globalsymtable) then
1827 psymtable(current_module^.globalsymtable)^.registerdef(@self);
1828 savesize:=target_os.size_of_pointer;
1829 end;
1832 constructor tformaldef.load;
1833 begin
1834 inherited load;
1835 deftype:=formaldef;
1836 savesize:=target_os.size_of_pointer;
1837 end;
1840 procedure tformaldef.write;
1841 begin
1842 inherited write;
1843 current_ppu^.writeentry(ibformaldef);
1844 end;
1847 {$ifdef GDB}
1848 function tformaldef.stabstring : pchar;
1849 begin
1850 stabstring := strpnew('formal'+numberstring+';');
1851 end;
1854 procedure tformaldef.concatstabto(asmlist : paasmoutput);
1855 begin
1856 { formaldef can't be stab'ed !}
1857 end;
1858 {$endif GDB}
1860 function tformaldef.gettypename : string;
1862 begin
1863 gettypename:='Var';
1864 end;
1866 {***************************************************************************
1867 TARRAYDEF
1868 ***************************************************************************}
1870 constructor tarraydef.init(l,h : longint;rd : pdef);
1871 begin
1872 inherited init;
1873 deftype:=arraydef;
1874 lowrange:=l;
1875 highrange:=h;
1876 rangetype.setdef(rd);
1877 elementtype.reset;
1878 IsVariant:=false;
1879 IsConstructor:=false;
1880 IsArrayOfConst:=false;
1881 rangenr:=0;
1882 end;
1885 constructor tarraydef.load;
1886 begin
1887 inherited load;
1888 deftype:=arraydef;
1889 { the addresses are calculated later }
1890 elementtype.load;
1891 rangetype.load;
1892 lowrange:=readlong;
1893 highrange:=readlong;
1894 IsArrayOfConst:=boolean(readbyte);
1895 IsVariant:=false;
1896 IsConstructor:=false;
1897 rangenr:=0;
1898 end;
1901 function tarraydef.getrangecheckstring : string;
1902 begin
1903 if (cs_create_smart in aktmoduleswitches) then
1904 getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
1905 else
1906 getrangecheckstring:='R_'+tostr(rangenr);
1907 end;
1910 procedure tarraydef.genrangecheck;
1911 begin
1912 if rangenr=0 then
1913 begin
1914 { generates the data for range checking }
1915 getlabelnr(rangenr);
1916 if (cs_create_smart in aktmoduleswitches) then
1917 datasegment^.concat(new(pai_symbol,initname_global(getrangecheckstring,8)))
1918 else
1919 datasegment^.concat(new(pai_symbol,initname(getrangecheckstring,8)));
1920 if lowrange<=highrange then
1921 begin
1922 datasegment^.concat(new(pai_const,init_32bit(lowrange)));
1923 datasegment^.concat(new(pai_const,init_32bit(highrange)));
1924 end
1925 { for big arrays we need two bounds }
1926 else
1927 begin
1928 datasegment^.concat(new(pai_const,init_32bit(lowrange)));
1929 datasegment^.concat(new(pai_const,init_32bit($7fffffff)));
1930 datasegment^.concat(new(pai_const,init_32bit($80000000)));
1931 datasegment^.concat(new(pai_const,init_32bit(highrange)));
1932 end;
1933 end;
1934 end;
1937 procedure tarraydef.deref;
1938 begin
1939 inherited deref;
1940 elementtype.resolve;
1941 rangetype.resolve;
1942 end;
1945 procedure tarraydef.write;
1946 begin
1947 inherited write;
1948 elementtype.write;
1949 rangetype.write;
1950 writelong(lowrange);
1951 writelong(highrange);
1952 writebyte(byte(IsArrayOfConst));
1953 current_ppu^.writeentry(ibarraydef);
1954 end;
1957 {$ifdef GDB}
1958 function tarraydef.stabstring : pchar;
1959 begin
1960 stabstring := strpnew('ar'+rangetype.def^.numberstring+';'
1961 +tostr(lowrange)+';'+tostr(highrange)+';'+elementtype.def^.numberstring);
1962 end;
1965 procedure tarraydef.concatstabto(asmlist : paasmoutput);
1966 begin
1967 if (not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches))
1968 and (is_def_stab_written = not_written) then
1969 begin
1970 {when array are inserted they have no definition yet !!}
1971 if assigned(elementtype.def) then
1972 inherited concatstabto(asmlist);
1973 end;
1974 end;
1975 {$endif GDB}
1978 function tarraydef.elesize : longint;
1979 begin
1980 if isconstructor or is_open_array(@self) then
1981 begin
1982 { strings are stored by address only }
1983 case elementtype.def^.deftype of
1984 stringdef :
1985 elesize:=4;
1986 else
1987 elesize:=elementtype.def^.size;
1988 end;
1989 end
1990 else
1991 elesize:=elementtype.def^.size;
1992 end;
1995 function tarraydef.size : longint;
1996 begin
1997 {Tarraydef.size may never be called for an open array!}
1998 if highrange<lowrange then
1999 internalerror(99080501);
2000 If (elesize>0) and
2001 (
2002 (highrange-lowrange = $7fffffff) or
2003 { () are needed around elesize-1 to avoid a possible
2004 integer overflow for elesize=1 !! PM }
2005 (($7fffffff div elesize + (elesize -1)) < (highrange - lowrange))
2006 ) Then
2007 Begin
2008 Message(sym_e_segment_too_large);
2009 size := 4
2010 End
2011 Else size:=(highrange-lowrange+1)*elesize;
2012 end;
2015 function tarraydef.alignment : longint;
2016 begin
2017 { alignment is the size of the elements }
2018 if elementtype.def^.deftype=recorddef then
2019 alignment:=elementtype.def^.alignment
2020 else
2021 alignment:=elesize;
2022 end;
2025 function tarraydef.needs_inittable : boolean;
2026 begin
2027 needs_inittable:=elementtype.def^.needs_inittable;
2028 end;
2031 procedure tarraydef.write_child_rtti_data;
2032 begin
2033 elementtype.def^.get_rtti_label;
2034 end;
2037 procedure tarraydef.write_rtti_data;
2038 begin
2039 rttilist^.concat(new(pai_const,init_8bit(tkarray)));
2040 write_rtti_name;
2041 { size of elements }
2042 rttilist^.concat(new(pai_const,init_32bit(elesize)));
2043 { count of elements }
2044 rttilist^.concat(new(pai_const,init_32bit(highrange-lowrange+1)));
2045 { element type }
2046 rttilist^.concat(new(pai_const_symbol,initname(elementtype.def^.get_rtti_label)));
2047 end;
2049 function tarraydef.gettypename : string;
2051 begin
2052 if isarrayofconst or isConstructor then
2053 begin
2054 if isvariant or ((highrange=-1) and (lowrange=0)) then
2055 gettypename:='Array Of Const'
2056 else
2057 gettypename:='Array Of '+elementtype.def^.typename;
2058 end
2059 else if is_open_array(@self) then
2060 gettypename:='Array Of '+elementtype.def^.typename
2061 else
2062 begin
2063 if rangetype.def^.deftype=enumdef then
2064 gettypename:='Array['+rangetype.def^.typename+'] Of '+elementtype.def^.typename
2065 else
2066 gettypename:='Array['+tostr(lowrange)+'..'+
2067 tostr(highrange)+'] Of '+elementtype.def^.typename
2068 end;
2069 end;
2071 {***************************************************************************
2072 trecorddef
2073 ***************************************************************************}
2075 constructor trecorddef.init(p : psymtable);
2076 begin
2077 inherited init;
2078 deftype:=recorddef;
2079 symtable:=p;
2080 symtable^.defowner := @self;
2081 symtable^.dataalignment:=packrecordalignment[aktpackrecords];
2082 end;
2085 constructor trecorddef.load;
2086 var
2087 oldread_member : boolean;
2088 begin
2089 inherited load;
2090 deftype:=recorddef;
2091 savesize:=readlong;
2092 oldread_member:=read_member;
2093 read_member:=true;
2094 symtable:=new(psymtable,loadas(recordsymtable));
2095 read_member:=oldread_member;
2096 symtable^.defowner := @self;
2097 end;
2100 destructor trecorddef.done;
2101 begin
2102 if assigned(symtable) then
2103 dispose(symtable,done);
2104 inherited done;
2105 end;
2108 var
2109 binittable : boolean;
2111 procedure check_rec_inittable(s : pnamedindexobject);
2113 begin
2114 if (not binittable) and
2115 (psym(s)^.typ=varsym) and
2116 assigned(pvarsym(s)^.vartype.def) then
2117 begin
2118 if ((pvarsym(s)^.vartype.def^.deftype<>objectdef) or
2119 not(pobjectdef(pvarsym(s)^.vartype.def)^.is_class)) then
2120 binittable:=pvarsym(s)^.vartype.def^.needs_inittable;
2121 end;
2122 end;
2125 function trecorddef.needs_inittable : boolean;
2126 var
2127 oldb : boolean;
2128 begin
2129 { there are recursive calls to needs_rtti possible, }
2130 { so we have to change to old value how else should }
2131 { we do that ? check_rec_rtti can't be a nested }
2132 { procedure of needs_rtti ! }
2133 oldb:=binittable;
2134 binittable:=false;
2135 symtable^.foreach({$ifndef TP}@{$endif}check_rec_inittable);
2136 needs_inittable:=binittable;
2137 binittable:=oldb;
2138 end;
2141 procedure trecorddef.deref;
2142 var
2143 oldrecsyms : psymtable;
2144 begin
2145 inherited deref;
2146 oldrecsyms:=aktrecordsymtable;
2147 aktrecordsymtable:=symtable;
2148 { now dereference the definitions }
2149 symtable^.deref;
2150 aktrecordsymtable:=oldrecsyms;
2151 end;
2154 procedure trecorddef.write;
2155 var
2156 oldread_member : boolean;
2157 begin
2158 oldread_member:=read_member;
2159 read_member:=true;
2160 inherited write;
2161 writelong(savesize);
2162 current_ppu^.writeentry(ibrecorddef);
2163 self.symtable^.writeas;
2164 read_member:=oldread_member;
2165 end;
2167 function trecorddef.size:longint;
2168 begin
2169 size:=symtable^.datasize;
2170 end;
2173 function trecorddef.alignment:longint;
2174 var
2175 l : longint;
2176 hp : pvarsym;
2177 begin
2178 { also check the first symbol for it's size, because a
2179 packed record has dataalignment of 1, but the first
2180 sym could be a longint which should be aligned on 4 bytes,
2181 this is compatible with C record packing (PFV) }
2182 hp:=pvarsym(symtable^.symindex^.first);
2183 if assigned(hp) then
2184 begin
2185 l:=hp^.vartype.def^.size;
2186 if l>symtable^.dataalignment then
2187 begin
2188 if l>=4 then
2189 alignment:=4
2190 else
2191 if l>=2 then
2192 alignment:=2
2193 else
2194 alignment:=1;
2195 end
2196 else
2197 alignment:=symtable^.dataalignment;
2198 end
2199 else
2200 alignment:=symtable^.dataalignment;
2201 end;
2203 {$ifdef GDB}
2204 Const StabRecString : pchar = Nil;
2205 StabRecSize : longint = 0;
2206 RecOffset : Longint = 0;
2208 procedure addname(p : pnamedindexobject);
2209 var
2210 news, newrec : pchar;
2211 spec : string[3];
2212 size : longint;
2213 begin
2214 { static variables from objects are like global objects }
2215 if (sp_static in psym(p)^.symoptions) then
2216 exit;
2217 If psym(p)^.typ = varsym then
2218 begin
2219 if (sp_protected in psym(p)^.symoptions) then
2220 spec:='/1'
2221 else if (sp_private in psym(p)^.symoptions) then
2222 spec:='/0'
2223 else
2224 spec:='';
2225 if not assigned(pvarsym(p)^.vartype.def) then
2226 writeln(pvarsym(p)^.name);
2227 { class fields are pointers PM, obsolete now PM }
2228 {if (pvarsym(p)^.vartype.def^.deftype=objectdef) and
2229 pobjectdef(pvarsym(p)^.vartype.def)^.is_class then
2230 spec:=spec+'*'; }
2231 size:=pvarsym(p)^.vartype.def^.size;
2232 { open arrays made overflows !! }
2233 if size>$fffffff then
2234 size:=$fffffff;
2235 newrec := strpnew(p^.name+':'+spec+pvarsym(p)^.vartype.def^.numberstring
2236 +','+tostr(pvarsym(p)^.address*8)+','
2237 +tostr(size*8)+';');
2238 if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then
2239 begin
2240 getmem(news,stabrecsize+memsizeinc);
2241 strcopy(news,stabrecstring);
2242 freemem(stabrecstring,stabrecsize);
2243 stabrecsize:=stabrecsize+memsizeinc;
2244 stabrecstring:=news;
2245 end;
2246 strcat(StabRecstring,newrec);
2247 strdispose(newrec);
2248 {This should be used for case !!}
2249 RecOffset := RecOffset + pvarsym(p)^.vartype.def^.size;
2250 end;
2251 end;
2254 function trecorddef.stabstring : pchar;
2255 Var oldrec : pchar;
2256 oldsize,oldrecoffset : longint;
2257 begin
2258 oldrec := stabrecstring;
2259 oldsize:=stabrecsize;
2260 GetMem(stabrecstring,memsizeinc);
2261 stabrecsize:=memsizeinc;
2262 strpcopy(stabRecString,'s'+tostr(size));
2263 OldRecOffset:=RecOffset;
2264 RecOffset := 0;
2265 symtable^.foreach({$ifndef TP}@{$endif}addname);
2266 { FPC doesn't want to convert a char to a pchar}
2267 { is this a bug ? }
2268 strpcopy(strend(StabRecString),';');
2269 stabstring := strnew(StabRecString);
2270 Freemem(stabrecstring,stabrecsize);
2271 stabrecstring := oldrec;
2272 stabrecsize:=oldsize;
2273 RecOffset:=OldRecOffset;
2274 end;
2277 procedure trecorddef.concatstabto(asmlist : paasmoutput);
2278 begin
2279 if (not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
2280 (is_def_stab_written = not_written) then
2281 inherited concatstabto(asmlist);
2282 end;
2284 {$endif GDB}
2286 var
2287 count : longint;
2289 procedure count_inittable_fields(sym : pnamedindexobject);{$ifndef fpc}far;{$endif}
2290 begin
2291 if ((psym(sym)^.typ=varsym) and
2292 pvarsym(sym)^.vartype.def^.needs_inittable)
2293 and ((pvarsym(sym)^.vartype.def^.deftype<>objectdef) or
2294 (not pobjectdef(pvarsym(sym)^.vartype.def)^.is_class)) then
2295 inc(count);
2296 end;
2299 procedure count_fields(sym : pnamedindexobject);{$ifndef fpc}far;{$endif}
2300 begin
2301 inc(count);
2302 end;
2305 procedure write_field_inittable(sym : pnamedindexobject);{$ifndef fpc}far;{$endif}
2306 begin
2307 if ((psym(sym)^.typ=varsym) and
2308 pvarsym(sym)^.vartype.def^.needs_inittable) and
2309 ((pvarsym(sym)^.vartype.def^.deftype<>objectdef) or
2310 (not pobjectdef(pvarsym(sym)^.vartype.def)^.is_class)) then
2311 begin
2312 rttilist^.concat(new(pai_const_symbol,init(pvarsym(sym)^.vartype.def^.get_inittable_label)));
2313 rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
2314 end;
2315 end;
2318 procedure write_field_rtti(sym : pnamedindexobject);{$ifndef fpc}far;{$endif}
2319 begin
2320 rttilist^.concat(new(pai_const_symbol,initname(pvarsym(sym)^.vartype.def^.get_rtti_label)));
2321 rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
2322 end;
2325 procedure generate_child_inittable(sym:pnamedindexobject);{$ifndef fpc}far;{$endif}
2326 begin
2327 if (psym(sym)^.typ=varsym) and
2328 pvarsym(sym)^.vartype.def^.needs_inittable then
2329 { force inittable generation }
2330 pvarsym(sym)^.vartype.def^.get_inittable_label;
2331 end;
2334 procedure generate_child_rtti(sym : pnamedindexobject);{$ifndef fpc}far;{$endif}
2335 begin
2336 pvarsym(sym)^.vartype.def^.get_rtti_label;
2337 end;
2340 procedure trecorddef.write_child_rtti_data;
2341 begin
2342 symtable^.foreach({$ifndef TP}@{$endif}generate_child_rtti);
2343 end;
2346 procedure trecorddef.write_child_init_data;
2347 begin
2348 symtable^.foreach({$ifndef TP}@{$endif}generate_child_inittable);
2349 end;
2352 procedure trecorddef.write_rtti_data;
2353 begin
2354 rttilist^.concat(new(pai_const,init_8bit(tkrecord)));
2355 write_rtti_name;
2356 rttilist^.concat(new(pai_const,init_32bit(size)));
2357 count:=0;
2358 symtable^.foreach({$ifndef TP}@{$endif}count_fields);
2359 rttilist^.concat(new(pai_const,init_32bit(count)));
2360 symtable^.foreach({$ifndef TP}@{$endif}write_field_rtti);
2361 end;
2364 procedure trecorddef.write_init_data;
2365 begin
2366 rttilist^.concat(new(pai_const,init_8bit(tkrecord)));
2367 write_rtti_name;
2368 rttilist^.concat(new(pai_const,init_32bit(size)));
2369 count:=0;
2370 symtable^.foreach({$ifndef TP}@{$endif}count_inittable_fields);
2371 rttilist^.concat(new(pai_const,init_32bit(count)));
2372 symtable^.foreach({$ifndef TP}@{$endif}write_field_inittable);
2373 end;
2375 function trecorddef.gettypename : string;
2377 begin
2378 gettypename:='<record type>'
2379 end;
2382 {***************************************************************************
2383 TABSTRACTPROCDEF
2384 ***************************************************************************}
2386 constructor tabstractprocdef.init;
2387 begin
2388 inherited init;
2389 new(para,init);
2390 fpu_used:=0;
2391 proctypeoption:=potype_none;
2392 proccalloptions:=[];
2393 procoptions:=[];
2394 rettype.setdef(voiddef);
2395 symtablelevel:=0;
2396 savesize:=target_os.size_of_pointer;
2397 end;
2400 destructor tabstractprocdef.done;
2401 begin
2402 dispose(para,done);
2403 inherited done;
2404 end;
2407 procedure tabstractprocdef.concatpara(tt:ttype;vsp : tvarspez);
2408 var
2409 hp : pparaitem;
2410 begin
2411 new(hp,init);
2412 hp^.paratyp:=vsp;
2413 hp^.paratype:=tt;
2414 hp^.register:=R_NO;
2415 para^.insert(hp);
2416 end;
2419 { all functions returning in FPU are
2420 assume to use 2 FPU registers
2421 until the function implementation
2422 is processed PM }
2423 procedure tabstractprocdef.test_if_fpu_result;
2424 begin
2425 if assigned(rettype.def) and is_fpu(rettype.def) then
2426 fpu_used:=2;
2427 end;
2430 procedure tabstractprocdef.deref;
2431 var
2432 hp : pparaitem;
2433 begin
2434 inherited deref;
2435 rettype.resolve;
2436 hp:=pparaitem(para^.first);
2437 while assigned(hp) do
2438 begin
2439 hp^.paratype.resolve;
2440 hp:=pparaitem(hp^.next);
2441 end;
2442 end;
2445 constructor tabstractprocdef.load;
2446 var
2447 hp : pparaitem;
2448 count,i : word;
2449 begin
2450 inherited load;
2451 new(para,init);
2452 rettype.load;
2453 fpu_used:=readbyte;
2454 proctypeoption:=tproctypeoption(readlong);
2455 readsmallset(proccalloptions);
2456 readsmallset(procoptions);
2457 count:=readword;
2458 savesize:=target_os.size_of_pointer;
2459 for i:=1 to count do
2460 begin
2461 new(hp,init);
2462 hp^.paratyp:=tvarspez(readbyte);
2463 { hp^.register:=tregister(readbyte); }
2464 hp^.register:=R_NO;
2465 hp^.paratype.load;
2466 para^.concat(hp);
2467 end;
2468 end;
2471 procedure tabstractprocdef.write;
2472 var
2473 hp : pparaitem;
2474 begin
2475 inherited write;
2476 rettype.write;
2477 current_ppu^.do_interface_crc:=false;
2478 writebyte(fpu_used);
2479 writelong(ord(proctypeoption));
2480 writesmallset(proccalloptions);
2481 writesmallset(procoptions);
2482 writeword(para^.count);
2483 hp:=pparaitem(para^.first);
2484 while assigned(hp) do
2485 begin
2486 writebyte(byte(hp^.paratyp));
2487 { writebyte(byte(hp^.register)); }
2488 hp^.paratype.write;
2489 hp:=pparaitem(hp^.next);
2490 end;
2491 end;
2494 function tabstractprocdef.para_size(alignsize:longint) : longint;
2495 var
2496 pdc : pparaitem;
2497 l : longint;
2498 begin
2499 l:=0;
2500 pdc:=pparaitem(para^.first);
2501 while assigned(pdc) do
2502 begin
2503 case pdc^.paratyp of
2504 vs_var : inc(l,target_os.size_of_pointer);
2505 vs_value,
2506 vs_const : if push_addr_param(pdc^.paratype.def) then
2507 inc(l,target_os.size_of_pointer)
2508 else
2509 inc(l,pdc^.paratype.def^.size);
2510 end;
2511 l:=align(l,alignsize);
2512 pdc:=pparaitem(pdc^.next);
2513 end;
2514 para_size:=l;
2515 end;
2518 function tabstractprocdef.demangled_paras : string;
2519 var
2520 s : string;
2521 hp : pparaitem;
2522 begin
2523 s:='(';
2524 hp:=pparaitem(para^.last);
2525 while assigned(hp) do
2526 begin
2527 if assigned(hp^.paratype.def^.typesym) then
2528 s:=s+hp^.paratype.def^.typesym^.name
2529 else if hp^.paratyp=vs_var then
2530 s:=s+'var'
2531 else if hp^.paratyp=vs_const then
2532 s:=s+'const';
2533 hp:=pparaitem(hp^.previous);
2534 if assigned(hp) then
2535 s:=s+',';
2536 end;
2537 s:=s+')';
2538 demangled_paras:=s;
2539 end;
2542 function tabstractprocdef.proccalloption2str : string;
2543 type
2544 tproccallopt=record
2545 mask : tproccalloption;
2546 str : string[30];
2547 end;
2548 const
2549 proccallopts=12;
2550 proccallopt : array[1..proccallopts] of tproccallopt=(
2551 (mask:pocall_none; str:''),
2552 (mask:pocall_clearstack; str:'ClearStack'),
2553 (mask:pocall_leftright; str:'LeftRight'),
2554 (mask:pocall_cdecl; str:'Cdecl'),
2555 (mask:pocall_register; str:'Register'),
2556 (mask:pocall_stdcall; str:'StdCall'),
2557 (mask:pocall_safecall; str:'SafeCall'),
2558 (mask:pocall_palmossyscall;str:'PalmOSSysCall'),
2559 (mask:pocall_system; str:'System'),
2560 (mask:pocall_inline; str:'Inline'),
2561 (mask:pocall_internproc; str:'InternProc'),
2562 (mask:pocall_internconst; str:'InternConst')
2563 );
2564 var
2565 s : string;
2566 i : longint;
2567 first : boolean;
2568 begin
2569 s:='';
2570 first:=true;
2571 for i:=1to proccallopts do
2572 if (proccallopt[i].mask in proccalloptions) then
2573 begin
2574 if first then
2575 first:=false
2576 else
2577 s:=s+';';
2578 s:=s+proccallopt[i].str;
2579 end;
2580 proccalloption2str:=s;
2581 end;
2584 {$ifdef GDB}
2585 function tabstractprocdef.stabstring : pchar;
2586 begin
2587 stabstring := strpnew('abstractproc'+numberstring+';');
2588 end;
2591 procedure tabstractprocdef.concatstabto(asmlist : paasmoutput);
2592 begin
2593 if (not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches))
2594 and (is_def_stab_written = not_written) then
2595 begin
2596 if assigned(rettype.def) then forcestabto(asmlist,rettype.def);
2597 inherited concatstabto(asmlist);
2598 end;
2599 end;
2600 {$endif GDB}
2603 {***************************************************************************
2604 TPROCDEF
2605 ***************************************************************************}
2607 constructor tprocdef.init;
2608 begin
2609 inherited init;
2610 deftype:=procdef;
2611 _mangledname:=nil;
2612 nextoverloaded:=nil;
2613 fileinfo:=aktfilepos;
2614 extnumber:=-1;
2615 localst:=new(psymtable,init(localsymtable));
2616 parast:=new(psymtable,init(parasymtable));
2617 localst^.defowner:=@self;
2618 parast^.defowner:=@self;
2619 { this is used by insert
2620 to check same names in parast and localst }
2621 localst^.next:=parast;
2622 defref:=nil;
2623 crossref:=nil;
2624 lastwritten:=nil;
2625 refcount:=0;
2626 if (cs_browser in aktmoduleswitches) and make_ref then
2627 begin
2628 defref:=new(pref,init(defref,@tokenpos));
2629 inc(refcount);
2630 end;
2631 lastref:=defref;
2632 { first, we assume that all registers are used }
2633 {$ifdef newcg}
2634 usedregisters:=[firstreg..lastreg];
2635 {$else newcg}
2636 {$ifdef i386}
2637 usedregisters:=$ff;
2638 {$endif i386}
2639 {$ifdef m68k}
2640 usedregisters:=$FFFF;
2641 {$endif}
2642 {$endif newcg}
2643 forwarddef:=true;
2644 interfacedef:=false;
2645 hasforward:=false;
2646 _class := nil;
2647 code:=nil;
2648 count:=false;
2649 is_used:=false;
2650 end;
2653 constructor tprocdef.load;
2654 var
2655 s : string;
2656 begin
2657 inherited load;
2658 deftype:=procdef;
2660 {$ifdef newcg}
2661 readnormalset(usedregisters);
2662 {$else newcg}
2663 {$ifdef i386}
2664 usedregisters:=readbyte;
2665 {$endif i386}
2666 {$ifdef m68k}
2667 usedregisters:=readword;
2668 {$endif}
2669 {$endif newcg}
2670 s:=readstring;
2671 setstring(_mangledname,s);
2673 extnumber:=readlong;
2674 nextoverloaded:=pprocdef(readdefref);
2675 _class := pobjectdef(readdefref);
2676 readposinfo(fileinfo);
2678 if (cs_link_deffile in aktglobalswitches) and
2679 (tf_need_export in target_info.flags) and
2680 (po_exports in procoptions) then
2681 deffile.AddExport(mangledname);
2683 parast:=nil;
2684 localst:=nil;
2685 forwarddef:=false;
2686 interfacedef:=false;
2687 hasforward:=false;
2688 lastref:=nil;
2689 lastwritten:=nil;
2690 defref:=nil;
2691 refcount:=0;
2692 count:=true;
2693 is_used:=false;
2694 end;
2697 Const local_symtable_index : longint = $8001;
2699 procedure tprocdef.load_references;
2700 var
2701 pos : tfileposinfo;
2702 {$ifndef NOLOCALBROWSER}
2703 oldsymtablestack,
2704 st : psymtable;
2705 {$endif ndef NOLOCALBROWSER}
2706 move_last : boolean;
2707 begin
2708 move_last:=lastwritten=lastref;
2709 while (not current_ppu^.endofentry) do
2710 begin
2711 readposinfo(pos);
2712 inc(refcount);
2713 lastref:=new(pref,init(lastref,@pos));
2714 lastref^.is_written:=true;
2715 if refcount=1 then
2716 defref:=lastref;
2717 end;
2718 if move_last then
2719 lastwritten:=lastref;
2720 if ((current_module^.flags and uf_local_browser)<>0)
2721 and is_in_current then
2722 begin
2723 {$ifndef NOLOCALBROWSER}
2724 oldsymtablestack:=symtablestack;
2725 st:=aktlocalsymtable;
2726 new(parast,loadas(parasymtable));
2727 parast^.defowner:=@self;
2728 aktlocalsymtable:=parast;
2729 parast^.deref;
2730 parast^.next:=owner;
2731 parast^.load_browser;
2732 aktlocalsymtable:=st;
2733 new(localst,loadas(localsymtable));
2734 localst^.defowner:=@self;
2735 aktlocalsymtable:=localst;
2736 symtablestack:=parast;
2737 localst^.deref;
2738 localst^.next:=parast;
2739 localst^.load_browser;
2740 aktlocalsymtable:=st;
2741 symtablestack:=oldsymtablestack;
2742 {$endif ndef NOLOCALBROWSER}
2743 end;
2744 end;
2747 function tprocdef.write_references : boolean;
2748 var
2749 ref : pref;
2750 {$ifndef NOLOCALBROWSER}
2751 st : psymtable;
2752 pdo : pobjectdef;
2753 {$endif ndef NOLOCALBROWSER}
2754 move_last : boolean;
2755 begin
2756 move_last:=lastwritten=lastref;
2757 if move_last and (((current_module^.flags and uf_local_browser)=0)
2758 or not is_in_current) then
2759 exit;
2760 { write address of this symbol }
2761 writedefref(@self);
2762 { write refs }
2763 if assigned(lastwritten) then
2764 ref:=lastwritten
2765 else
2766 ref:=defref;
2767 while assigned(ref) do
2768 begin
2769 if ref^.moduleindex=current_module^.unit_index then
2770 begin
2771 writeposinfo(ref^.posinfo);
2772 ref^.is_written:=true;
2773 if move_last then
2774 lastwritten:=ref;
2775 end
2776 else if not ref^.is_written then
2777 move_last:=false
2778 else if move_last then
2779 lastwritten:=ref;
2780 ref:=ref^.nextref;
2781 end;
2782 current_ppu^.writeentry(ibdefref);
2783 write_references:=true;
2784 if ((current_module^.flags and uf_local_browser)<>0)
2785 and is_in_current then
2786 begin
2787 {$ifndef NOLOCALBROWSER}
2788 pdo:=_class;
2789 if (owner^.symtabletype<>localsymtable) then
2790 while assigned(pdo) do
2791 begin
2792 if pdo^.symtable<>aktrecordsymtable then
2793 begin
2794 pdo^.symtable^.unitid:=local_symtable_index;
2795 inc(local_symtable_index);
2796 end;
2797 pdo:=pdo^.childof;
2798 end;
2800 { we need TESTLOCALBROWSER para and local symtables
2801 PPU files are then easier to read PM }
2802 if not assigned(parast) then
2803 parast:=new(psymtable,init(parasymtable));
2804 parast^.defowner:=@self;
2805 st:=aktlocalsymtable;
2806 aktlocalsymtable:=parast;
2807 parast^.writeas;
2808 parast^.unitid:=local_symtable_index;
2809 inc(local_symtable_index);
2810 parast^.write_browser;
2811 if not assigned(localst) then
2812 localst:=new(psymtable,init(localsymtable));
2813 localst^.defowner:=@self;
2814 aktlocalsymtable:=localst;
2815 localst^.writeas;
2816 localst^.unitid:=local_symtable_index;
2817 inc(local_symtable_index);
2818 localst^.write_browser;
2819 aktlocalsymtable:=st;
2820 { decrement for }
2821 local_symtable_index:=local_symtable_index-2;
2822 pdo:=_class;
2823 if (owner^.symtabletype<>localsymtable) then
2824 while assigned(pdo) do
2825 begin
2826 if pdo^.symtable<>aktrecordsymtable then
2827 dec(local_symtable_index);
2828 pdo:=pdo^.childof;
2829 end;
2830 {$endif ndef NOLOCALBROWSER}
2831 end;
2832 end;
2835 {$ifdef BrowserLog}
2836 procedure tprocdef.add_to_browserlog;
2837 begin
2838 if assigned(defref) then
2839 begin
2840 browserlog.AddLog('***'+mangledname);
2841 browserlog.AddLogRefs(defref);
2842 if (current_module^.flags and uf_local_browser)<>0 then
2843 begin
2844 if assigned(parast) then
2845 parast^.writebrowserlog;
2846 if assigned(localst) then
2847 localst^.writebrowserlog;
2848 end;
2849 end;
2850 end;
2851 {$endif BrowserLog}
2854 destructor tprocdef.done;
2855 begin
2856 if assigned(defref) then
2857 begin
2858 defref^.freechain;
2859 dispose(defref,done);
2860 end;
2861 if assigned(parast) then
2862 dispose(parast,done);
2863 if assigned(localst) and (localst^.symtabletype<>staticsymtable) then
2864 dispose(localst,done);
2865 if (pocall_inline in proccalloptions) and assigned(code) then
2866 disposetree(ptree(code));
2867 if (po_msgstr in procoptions) then
2868 strdispose(messageinf.str);
2869 if
2870 {$ifdef tp}
2871 not(use_big) and
2872 {$endif}
2873 assigned(_mangledname) then
2874 strdispose(_mangledname);
2875 inherited done;
2876 end;
2879 procedure tprocdef.write;
2880 begin
2881 inherited write;
2882 current_ppu^.do_interface_crc:=false;
2883 { set all registers to used for simplified compilation PM }
2884 if simplify_ppu then
2885 begin
2886 {$ifdef newcg}
2887 usedregisters:=[firstreg..lastreg];
2888 {$else newcg}
2889 {$ifdef i386}
2890 usedregisters:=$ff;
2891 {$endif i386}
2892 {$ifdef m68k}
2893 usedregisters:=$ffff;
2894 {$endif}
2895 {$endif newcg}
2896 end;
2898 {$ifdef newcg}
2899 writenormalset(usedregisters);
2900 {$else newcg}
2901 {$ifdef i386}
2902 writebyte(usedregisters);
2903 {$endif i386}
2904 {$ifdef m68k}
2905 writeword(usedregisters);
2906 {$endif}
2907 {$endif newcg}
2908 current_ppu^.do_interface_crc:=true;
2909 writestring(mangledname);
2910 writelong(extnumber);
2911 if (proctypeoption<>potype_operator) then
2912 writedefref(nextoverloaded)
2913 else
2914 begin
2915 { only write the overloads from the same unit }
2916 if assigned(nextoverloaded) and
2917 (nextoverloaded^.owner=owner) then
2918 writedefref(nextoverloaded)
2919 else
2920 writedefref(nil);
2921 end;
2922 writedefref(_class);
2923 writeposinfo(fileinfo);
2924 if (pocall_inline in proccalloptions) then
2925 begin
2926 { we need to save
2927 - the para and the local symtable
2928 - the code ptree !! PM
2929 writesymtable(parast);
2930 writesymtable(localst);
2931 writeptree(ptree(code));
2932 }
2933 end;
2934 current_ppu^.writeentry(ibprocdef);
2935 end;
2938 function tprocdef.haspara:boolean;
2939 begin
2940 haspara:=assigned(aktprocsym^.definition^.parast^.symindex^.first);
2941 end;
2944 {$ifdef GDB}
2945 procedure addparaname(p : psym);
2946 var vs : char;
2947 begin
2948 if pvarsym(p)^.varspez = vs_value then vs := '1'
2949 else vs := '0';
2950 strpcopy(strend(StabRecString),p^.name+':'+pvarsym(p)^.vartype.def^.numberstring+','+vs+';');
2951 end;
2954 function tprocdef.stabstring : pchar;
2955 var
2956 i : longint;
2957 oldrec : pchar;
2958 begin
2959 oldrec := stabrecstring;
2960 getmem(StabRecString,1024);
2961 strpcopy(StabRecString,'f'+rettype.def^.numberstring);
2962 i:=para^.count;
2963 if i>0 then
2964 begin
2965 strpcopy(strend(StabRecString),','+tostr(i)+';');
2966 (* confuse gdb !! PM
2967 if assigned(parast) then
2968 parast^.foreach({$ifndef TP}@{$endif}addparaname)
2969 else
2970 begin
2971 param := para1;
2972 i := 0;
2973 while assigned(param) do
2974 begin
2975 inc(i);
2976 if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
2977 {Here we have lost the parameter names !!}
2978 {using lower case parameters }
2979 strpcopy(strend(stabrecstring),'p'+tostr(i)
2980 +':'+param^.paratype.def^.numberstring+','+vartyp+';');
2981 param := param^.next;
2982 end;
2983 end; *)
2984 {strpcopy(strend(StabRecString),';');}
2985 end;
2986 stabstring := strnew(stabrecstring);
2987 freemem(stabrecstring,1024);
2988 stabrecstring := oldrec;
2989 end;
2992 procedure tprocdef.concatstabto(asmlist : paasmoutput);
2993 begin
2994 end;
2995 {$endif GDB}
2998 procedure tprocdef.deref;
2999 begin
3000 inherited deref;
3001 resolvedef(pdef(nextoverloaded));
3002 resolvedef(pdef(_class));
3003 end;
3006 function tprocdef.mangledname : string;
3007 {$ifdef tp}
3008 var
3009 oldpos : longint;
3010 s : string;
3011 b : byte;
3012 {$endif tp}
3013 begin
3014 {$ifndef Delphi}
3015 {$ifdef tp}
3016 if use_big then
3017 begin
3018 symbolstream.seek(longint(_mangledname));
3019 symbolstream.read(b,1);
3020 symbolstream.read(s[1],b);
3021 s[0]:=chr(b);
3022 mangledname:=s;
3023 end
3024 else
3025 {$endif}
3026 {$endif Delphi}
3027 mangledname:=strpas(_mangledname);
3028 if count then
3029 is_used:=true;
3030 end;
3033 function tprocdef.procname: string;
3034 var
3035 s : string;
3036 l : longint;
3037 begin
3038 s:=mangledname;
3039 { delete leading $$'s }
3040 l:=pos('$$',s);
3041 while l<>0 do
3042 begin
3043 delete(s,1,l+1);
3044 l:=pos('$$',s);
3045 end;
3046 { delete leading _$'s }
3047 l:=pos('_$',s);
3048 while l<>0 do
3049 begin
3050 delete(s,1,l+1);
3051 l:=pos('_$',s);
3052 end;
3053 l:=pos('$',s);
3054 if l=0 then
3055 procname:=s
3056 else
3057 procname:=Copy(s,1,l-1);
3058 end;
3060 {$IfDef GDB}
3061 function tprocdef.cplusplusmangledname : string;
3062 var
3063 s,s2 : string;
3064 param : pparaitem;
3065 begin
3066 s := typesym^.name;
3067 if _class <> nil then
3068 begin
3069 s2 := _class^.objname^;
3070 s := s+'__'+tostr(length(s2))+s2;
3071 end else s := s + '_';
3072 param := pparaitem(para^.first);
3073 while assigned(param) do
3074 begin
3075 s2 := param^.paratype.def^.typesym^.name;
3076 s := s+tostr(length(s2))+s2;
3077 param := pparaitem(param^.next);
3078 end;
3079 cplusplusmangledname:=s;
3080 end;
3081 {$EndIf GDB}
3084 procedure tprocdef.setmangledname(const s : string);
3085 begin
3086 if {$ifdef tp}not(use_big) and{$endif} (assigned(_mangledname)) then
3087 begin
3088 {$ifdef MEMDEBUG}
3089 dec(manglenamesize,length(_mangledname^));
3090 {$endif}
3091 strdispose(_mangledname);
3092 end;
3093 setstring(_mangledname,s);
3094 {$ifdef MEMDEBUG}
3095 inc(manglenamesize,length(s));
3096 {$endif}
3097 {$ifdef EXTDEBUG}
3098 if assigned(parast) then
3099 begin
3100 stringdispose(parast^.name);
3101 parast^.name:=stringdup('args of '+s);
3102 end;
3103 if assigned(localst) then
3104 begin
3105 stringdispose(localst^.name);
3106 localst^.name:=stringdup('locals of '+s);
3107 end;
3108 {$endif}
3109 end;
3112 {***************************************************************************
3113 TPROCVARDEF
3114 ***************************************************************************}
3116 constructor tprocvardef.init;
3117 begin
3118 inherited init;
3119 deftype:=procvardef;
3120 end;
3123 constructor tprocvardef.load;
3124 begin
3125 inherited load;
3126 deftype:=procvardef;
3127 end;
3130 procedure tprocvardef.write;
3131 begin
3132 { here we cannot get a real good value so just give something }
3133 { plausible (PM) }
3134 { a more secure way would be
3135 to allways store in a temp }
3136 if is_fpu(rettype.def) then
3137 fpu_used:=2
3138 else
3139 fpu_used:=0;
3140 inherited write;
3141 current_ppu^.writeentry(ibprocvardef);
3142 end;
3145 function tprocvardef.size : longint;
3146 begin
3147 if (po_methodpointer in procoptions) then
3148 size:=2*target_os.size_of_pointer
3149 else
3150 size:=target_os.size_of_pointer;
3151 end;
3154 {$ifdef GDB}
3155 function tprocvardef.stabstring : pchar;
3156 var
3157 nss : pchar;
3158 { i : longint; }
3159 begin
3160 { i := para^.count; }
3161 getmem(nss,1024);
3162 { it is not a function but a function pointer !! (PM) }
3164 strpcopy(nss,'*f'+rettype.def^.numberstring{+','+tostr(i)}+';');
3165 { this confuses gdb !!
3166 we should use 'F' instead of 'f' but
3167 as we use c++ language mode
3168 it does not like that either
3169 Please do not remove this part
3170 might be used once
3171 gdb for pascal is ready PM }
3172 (*
3173 param := para1;
3174 i := 0;
3175 while assigned(param) do
3176 begin
3177 inc(i);
3178 if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
3179 {Here we have lost the parameter names !!}
3180 pst := strpnew('p'+tostr(i)+':'+param^.paratype.def^.numberstring+','+vartyp+';');
3181 strcat(nss,pst);
3182 strdispose(pst);
3183 param := param^.next;
3184 end; *)
3185 {strpcopy(strend(nss),';');}
3186 stabstring := strnew(nss);
3187 freemem(nss,1024);
3188 end;
3191 procedure tprocvardef.concatstabto(asmlist : paasmoutput);
3192 begin
3193 if ( not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches))
3194 and (is_def_stab_written = not_written) then
3195 inherited concatstabto(asmlist);
3196 is_def_stab_written:=written;
3197 end;
3198 {$endif GDB}
3201 procedure tprocvardef.write_rtti_data;
3202 var
3203 pdc : pparaitem;
3204 methodkind, paraspec : byte;
3205 begin
3206 if po_methodpointer in procoptions then
3207 begin
3208 { write method id and name }
3209 rttilist^.concat(new(pai_const,init_8bit(tkmethod)));
3210 write_rtti_name;
3212 { write kind of method (can only be function or procedure)}
3213 if rettype.def = pdef(voiddef) then { ### typecast shoudln't be necessary! (sg) }
3214 methodkind := mkProcedure
3215 else
3216 methodkind := mkFunction;
3217 rttilist^.concat(new(pai_const,init_8bit(methodkind)));
3219 { get # of parameters }
3220 rttilist^.concat(new(pai_const,init_8bit(para^.count)));
3222 { write parameter info. The parameters must be written in reverse order
3223 if this method uses right to left parameter pushing! }
3224 if (pocall_leftright in proccalloptions) then
3225 pdc:=pparaitem(para^.last)
3226 else
3227 pdc:=pparaitem(para^.first);
3228 while assigned(pdc) do
3229 begin
3230 case pdc^.paratyp of
3231 vs_value: paraspec := 0;
3232 vs_const: paraspec := pfConst;
3233 vs_var : paraspec := pfVar;
3234 end;
3235 { write flags for current parameter }
3236 rttilist^.concat(new(pai_const,init_8bit(paraspec)));
3237 { write name of current parameter ### how can I get this??? (sg)}
3238 rttilist^.concat(new(pai_const,init_8bit(0)));
3240 { write name of type of current parameter }
3241 pdc^.paratype.def^.write_rtti_name;
3243 if (pocall_leftright in proccalloptions) then
3244 pdc:=pparaitem(pdc^.previous)
3245 else
3246 pdc:=pparaitem(pdc^.next);
3247 end;
3249 { write name of result type }
3250 rettype.def^.write_rtti_name;
3251 end;
3252 end;
3255 procedure tprocvardef.write_child_rtti_data;
3256 begin
3257 {!!!!!!!!}
3258 end;
3261 function tprocvardef.is_publishable : boolean;
3262 begin
3263 is_publishable:=(po_methodpointer in procoptions);
3264 end;
3267 function tprocvardef.gettypename : string;
3268 begin
3269 if assigned(rettype.def) and
3270 (rettype.def<>pdef(voiddef)) then
3271 gettypename:='<procedure variable type of function'+demangled_paras+
3272 ':'+rettype.def^.gettypename+';'+proccalloption2str+'>'
3273 else
3274 gettypename:='<procedure variable type of procedure'+demangled_paras+
3275 ';'+proccalloption2str+'>';
3276 end;
3279 {***************************************************************************
3280 TOBJECTDEF
3281 ***************************************************************************}
3283 {$ifdef GDB}
3284 const
3285 vtabletype : word = 0;
3286 vtableassigned : boolean = false;
3287 {$endif GDB}
3289 constructor tobjectdef.init(const n : string;c : pobjectdef);
3290 begin
3291 tdef.init;
3292 deftype:=objectdef;
3293 objectoptions:=[];
3294 childof:=nil;
3295 symtable:=new(psymtable,init(objectsymtable));
3296 symtable^.name := stringdup(n);
3297 { create space for vmt !! }
3298 vmt_offset:=0;
3299 symtable^.datasize:=0;
3300 symtable^.defowner:=@self;
3301 symtable^.dataalignment:=packrecordalignment[aktpackrecords];
3302 set_parent(c);
3303 objname:=stringdup(n);
3304 {$ifdef GDB}
3305 writing_class_record_stab:=false;
3306 {$endif GDB}
3307 end;
3310 constructor tobjectdef.load;
3311 var
3312 oldread_member : boolean;
3313 begin
3314 tdef.load;
3315 deftype:=objectdef;
3316 savesize:=readlong;
3317 vmt_offset:=readlong;
3318 objname:=stringdup(readstring);
3319 childof:=pobjectdef(readdefref);
3320 readsmallset(objectoptions);
3321 has_rtti:=boolean(readbyte);
3323 oldread_member:=read_member;
3324 read_member:=true;
3325 symtable:=new(psymtable,loadas(objectsymtable));
3326 read_member:=oldread_member;
3328 symtable^.defowner:=@self;
3329 symtable^.name := stringdup(objname^);
3331 { handles the predefined class tobject }
3332 { the last TOBJECT which is loaded gets }
3333 { it ! }
3334 if (childof=nil) and
3335 is_class and
3336 (objname^='TOBJECT') then
3337 class_tobject:=@self;
3338 {$ifdef GDB}
3339 writing_class_record_stab:=false;
3340 {$endif GDB}
3341 end;
3344 destructor tobjectdef.done;
3345 begin
3346 if assigned(symtable) then
3347 dispose(symtable,done);
3348 if (oo_is_forward in objectoptions) then
3349 Message1(sym_e_class_forward_not_resolved,objname^);
3350 stringdispose(objname);
3351 tdef.done;
3352 end;
3355 procedure tobjectdef.write;
3356 var
3357 oldread_member : boolean;
3358 begin
3359 tdef.write;
3360 writelong(size);
3361 writelong(vmt_offset);
3362 writestring(objname^);
3363 writedefref(childof);
3364 writesmallset(objectoptions);
3365 writebyte(byte(has_rtti));
3366 current_ppu^.writeentry(ibobjectdef);
3368 oldread_member:=read_member;
3369 read_member:=true;
3370 symtable^.writeas;
3371 read_member:=oldread_member;
3372 end;
3375 procedure tobjectdef.deref;
3376 var
3377 oldrecsyms : psymtable;
3378 begin
3379 inherited deref;
3380 resolvedef(pdef(childof));
3381 oldrecsyms:=aktrecordsymtable;
3382 aktrecordsymtable:=symtable;
3383 symtable^.deref;
3384 aktrecordsymtable:=oldrecsyms;
3385 end;
3388 procedure tobjectdef.set_parent( c : pobjectdef);
3389 begin
3390 { nothing to do if the parent was not forward !}
3391 if assigned(childof) then
3392 exit;
3393 childof:=c;
3394 { some options are inherited !! }
3395 if assigned(c) then
3396 begin
3397 objectoptions:=objectoptions+(c^.objectoptions*
3398 [oo_has_virtual,oo_has_private,oo_has_protected,oo_has_constructor,oo_has_destructor]);
3399 { add the data of the anchestor class }
3400 inc(symtable^.datasize,c^.symtable^.datasize);
3401 if (oo_has_vmt in objectoptions) and
3402 (oo_has_vmt in c^.objectoptions) then
3403 dec(symtable^.datasize,target_os.size_of_pointer);
3404 { if parent has a vmt field then
3405 the offset is the same for the child PM }
3406 if (oo_has_vmt in c^.objectoptions) or is_class then
3407 begin
3408 vmt_offset:=c^.vmt_offset;
3409 {$ifdef INCLUDEOK}
3410 include(objectoptions,oo_has_vmt);
3411 {$else}
3412 objectoptions:=objectoptions+[oo_has_vmt];
3413 {$endif}
3414 end;
3415 end;
3416 savesize := symtable^.datasize;
3417 end;
3420 procedure tobjectdef.insertvmt;
3421 begin
3422 if (oo_has_vmt in objectoptions) then
3423 internalerror(12345)
3424 else
3425 begin
3426 { first round up to multiple of 4 }
3427 if (symtable^.dataalignment=2) then
3428 begin
3429 if (symtable^.datasize and 1)<>0 then
3430 inc(symtable^.datasize);
3431 end
3432 else
3433 if (symtable^.dataalignment>=4) then
3434 begin
3435 if (symtable^.datasize mod 4) <> 0 then
3436 inc(symtable^.datasize,4-(symtable^.datasize mod 4));
3437 end;
3438 vmt_offset:=symtable^.datasize;
3439 inc(symtable^.datasize,target_os.size_of_pointer);
3440 include(objectoptions,oo_has_vmt);
3441 end;
3442 end;
3445 procedure tobjectdef.check_forwards;
3446 begin
3447 symtable^.check_forwards;
3448 if (oo_is_forward in objectoptions) then
3449 begin
3450 { ok, in future, the forward can be resolved }
3451 Message1(sym_e_class_forward_not_resolved,objname^);
3452 {$ifdef INCLUDEOK}
3453 exclude(objectoptions,oo_is_forward);
3454 {$else}
3455 objectoptions:=objectoptions-[oo_is_forward];
3456 {$endif}
3457 end;
3458 end;
3461 { true, if self inherits from d (or if they are equal) }
3462 function tobjectdef.is_related(d : pobjectdef) : boolean;
3463 var
3464 hp : pobjectdef;
3465 begin
3466 hp:=@self;
3467 while assigned(hp) do
3468 begin
3469 if hp=d then
3470 begin
3471 is_related:=true;
3472 exit;
3473 end;
3474 hp:=hp^.childof;
3475 end;
3476 is_related:=false;
3477 end;
3479 var
3480 sd : pprocdef;
3482 procedure _searchdestructor(sym : pnamedindexobject);{$ifndef fpc}far;{$endif}
3484 var
3485 p : pprocdef;
3487 begin
3488 { if we found already a destructor, then we exit }
3489 if assigned(sd) then
3490 exit;
3491 if psym(sym)^.typ=procsym then
3492 begin
3493 p:=pprocsym(sym)^.definition;
3494 while assigned(p) do
3495 begin
3496 if p^.proctypeoption=potype_destructor then
3497 begin
3498 sd:=p;
3499 exit;
3500 end;
3501 p:=p^.nextoverloaded;
3502 end;
3503 end;
3504 end;
3506 function tobjectdef.searchdestructor : pprocdef;
3508 var
3509 o : pobjectdef;
3511 begin
3512 searchdestructor:=nil;
3513 o:=@self;
3514 sd:=nil;
3515 while assigned(o) do
3516 begin
3517 symtable^.foreach({$ifndef TP}@{$endif}_searchdestructor);
3518 if assigned(sd) then
3519 begin
3520 searchdestructor:=sd;
3521 exit;
3522 end;
3523 o:=o^.childof;
3524 end;
3525 end;
3527 function tobjectdef.size : longint;
3528 begin
3529 if (oo_is_class in objectoptions) then
3530 size:=target_os.size_of_pointer
3531 else
3532 size:=symtable^.datasize;
3533 end;
3536 function tobjectdef.alignment:longint;
3537 begin
3538 alignment:=symtable^.dataalignment;
3539 end;
3542 function tobjectdef.vmtmethodoffset(index:longint):longint;
3543 begin
3544 { for offset of methods for classes, see rtl/inc/objpash.inc }
3545 if is_class then
3546 vmtmethodoffset:=(index+12)*target_os.size_of_pointer
3547 else
3548 {$ifdef WITHDMT}
3549 vmtmethodoffset:=(index+4)*target_os.size_of_pointer;
3550 {$else WITHDMT}
3551 vmtmethodoffset:=(index+3)*target_os.size_of_pointer;
3552 {$endif WITHDMT}
3553 end;
3556 function tobjectdef.vmt_mangledname : string;
3557 {DM: I get a nil pointer on the owner name. I don't know if this
3558 mayhappen, and I have therefore fixed the problem by doing nil pointer
3559 checks.}
3560 var
3561 s1,s2:string;
3562 begin
3563 if not(oo_has_vmt in objectoptions) then
3564 Message1(parser_object_has_no_vmt,objname^);
3565 if owner^.name=nil then
3566 s1:=''
3567 else
3568 s1:=owner^.name^;
3569 if objname=nil then
3570 s2:=''
3571 else
3572 s2:=objname^;
3573 vmt_mangledname:='VMT_'+s1+'$_'+s2;
3574 end;
3577 function tobjectdef.rtti_name : string;
3578 var
3579 s1,s2:string;
3580 begin
3581 if owner^.name=nil then
3582 s1:=''
3583 else
3584 s1:=owner^.name^;
3585 if objname=nil then
3586 s2:=''
3587 else
3588 s2:=objname^;
3589 rtti_name:='RTTI_'+s1+'$_'+s2;
3590 end;
3593 function tobjectdef.is_class : boolean;
3594 begin
3595 is_class:=(oo_is_class in objectoptions);
3596 end;
3599 {$ifdef GDB}
3600 procedure addprocname(p :pnamedindexobject);
3601 var virtualind,argnames : string;
3602 news, newrec : pchar;
3603 pd,ipd : pprocdef;
3604 lindex : longint;
3605 para : pparaitem;
3606 arglength : byte;
3607 sp : char;
3609 begin
3610 If psym(p)^.typ = procsym then
3611 begin
3612 pd := pprocsym(p)^.definition;
3613 { this will be used for full implementation of object stabs
3614 not yet done }
3615 ipd := pd;
3616 while assigned(ipd^.nextoverloaded) do ipd := ipd^.nextoverloaded;
3617 if (po_virtualmethod in pd^.procoptions) then
3618 begin
3619 lindex := pd^.extnumber;
3620 {doesnt seem to be necessary
3621 lindex := lindex or $80000000;}
3622 virtualind := '*'+tostr(lindex)+';'+ipd^._class^.classnumberstring+';'
3623 end
3624 else
3625 virtualind := '.';
3627 { used by gdbpas to recognize constructor and destructors }
3628 if (pd^.proctypeoption=potype_constructor) then
3629 argnames:='__ct__'
3630 else if (pd^.proctypeoption=potype_destructor) then
3631 argnames:='__dt__'
3632 else
3633 argnames := '';
3635 { arguments are not listed here }
3636 {we don't need another definition}
3637 para := pparaitem(pd^.para^.first);
3638 while assigned(para) do
3639 begin
3640 if para^.paratype.def^.deftype = formaldef then
3641 begin
3642 if para^.paratyp=vs_var then
3643 argnames := argnames+'3var'
3644 else if para^.paratyp=vs_const then
3645 argnames:=argnames+'5const';
3646 end
3647 else
3648 begin
3649 { if the arg definition is like (v: ^byte;..
3650 there is no sym attached to data !!! }
3651 if assigned(para^.paratype.def^.typesym) then
3652 begin
3653 arglength := length(para^.paratype.def^.typesym^.name);
3654 argnames := argnames + tostr(arglength)+para^.paratype.def^.typesym^.name;
3655 end
3656 else
3657 begin
3658 argnames:=argnames+'11unnamedtype';
3659 end;
3660 end;
3661 para := pparaitem(para^.next);
3662 end;
3663 ipd^.is_def_stab_written := written;
3664 { here 2A must be changed for private and protected }
3665 { 0 is private 1 protected and 2 public }
3666 if (sp_private in psym(p)^.symoptions) then sp:='0'
3667 else if (sp_protected in psym(p)^.symoptions) then sp:='1'
3668 else sp:='2';
3669 newrec := strpnew(p^.name+'::'+ipd^.numberstring
3670 +'=##'+pd^.rettype.def^.numberstring+';:'+argnames+';'+sp+'A'
3671 +virtualind+';');
3672 { get spare place for a string at the end }
3673 if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then
3674 begin
3675 getmem(news,stabrecsize+memsizeinc);
3676 strcopy(news,stabrecstring);
3677 freemem(stabrecstring,stabrecsize);
3678 stabrecsize:=stabrecsize+memsizeinc;
3679 stabrecstring:=news;
3680 end;
3681 strcat(StabRecstring,newrec);
3682 {freemem(newrec,memsizeinc); }
3683 strdispose(newrec);
3684 end;
3685 end;
3688 function tobjectdef.stabstring : pchar;
3689 var anc : pobjectdef;
3690 oldrec : pchar;
3691 oldrecsize,oldrecoffset : longint;
3692 str_end : string;
3693 begin
3694 if not (is_class) or writing_class_record_stab then
3695 begin
3696 oldrec := stabrecstring;
3697 oldrecsize:=stabrecsize;
3698 stabrecsize:=memsizeinc;
3699 GetMem(stabrecstring,stabrecsize);
3700 strpcopy(stabRecString,'s'+tostr(symtable^.datasize));
3701 if assigned(childof) then
3702 begin
3703 {only one ancestor not virtual, public, at base offset 0 }
3704 { !1 , 0 2 0 , }
3705 strpcopy(strend(stabrecstring),'!1,020,'+childof^.classnumberstring+';');
3706 end;
3707 OldRecOffset:=RecOffset;
3708 RecOffset := 0;
3709 symtable^.foreach({$ifndef TP}@{$endif}addname);
3710 RecOffset:=OldRecOffset;
3711 if (oo_has_vmt in objectoptions) then
3712 if not assigned(childof) or not(oo_has_vmt in childof^.objectoptions) then
3713 begin
3714 strpcopy(strend(stabrecstring),'$vf'+classnumberstring+':'+typeglobalnumber('vtblarray')
3715 +','+tostr(vmt_offset*8)+';');
3716 end;
3717 symtable^.foreach({$ifndef TP}@{$endif}addprocname);
3718 if (oo_has_vmt in objectoptions) then
3719 begin
3720 anc := @self;
3721 while assigned(anc^.childof) and (oo_has_vmt in anc^.childof^.objectoptions) do
3722 anc := anc^.childof;
3723 { just in case anc = self }
3724 str_end:=';~%'+anc^.classnumberstring+';';
3725 end
3726 else
3727 str_end:=';';
3728 strpcopy(strend(stabrecstring),str_end);
3729 stabstring := strnew(StabRecString);
3730 freemem(stabrecstring,stabrecsize);
3731 stabrecstring := oldrec;
3732 stabrecsize:=oldrecsize;
3733 end
3734 else
3735 begin
3736 stabstring:=strpnew('*'+classnumberstring);
3737 end;
3738 end;
3740 procedure tobjectdef.set_globalnb;
3741 begin
3742 globalnb:=PglobalTypeCount^;
3743 inc(PglobalTypeCount^);
3744 { classes need two type numbers, the globalnb is set to the ptr }
3745 if is_class then
3746 begin
3747 globalnb:=PGlobalTypeCount^;
3748 inc(PglobalTypeCount^);
3749 end;
3750 end;
3752 function tobjectdef.classnumberstring : string;
3753 begin
3754 { write stabs again if needed }
3755 numberstring;
3756 if is_class then
3757 begin
3758 dec(globalnb);
3759 classnumberstring:=numberstring;
3760 inc(globalnb);
3761 end
3762 else
3763 classnumberstring:=numberstring;
3764 end;
3766 function tobjectdef.allstabstring : pchar;
3767 var stabchar : string[2];
3768 ss,st : pchar;
3769 sname : string;
3770 sym_line_no : longint;
3771 begin
3772 ss := stabstring;
3773 getmem(st,strlen(ss)+512);
3774 stabchar := 't';
3775 if deftype in tagtypes then
3776 stabchar := 'Tt';
3777 if assigned(typesym) then
3778 begin
3779 sname := typesym^.name;
3780 sym_line_no:=typesym^.fileinfo.line;
3781 end
3782 else
3783 begin
3784 sname := ' ';
3785 sym_line_no:=0;
3786 end;
3787 if writing_class_record_stab then
3788 strpcopy(st,'"'+sname+':'+stabchar+classnumberstring+'=')
3789 else
3790 strpcopy(st,'"'+sname+':'+stabchar+numberstring+'=');
3791 strpcopy(strecopy(strend(st),ss),'",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0');
3792 allstabstring := strnew(st);
3793 freemem(st,strlen(ss)+512);
3794 strdispose(ss);
3795 end;
3797 procedure tobjectdef.concatstabto(asmlist : paasmoutput);
3798 var st : pstring;
3799 begin
3800 if not(is_class) then
3801 begin
3802 inherited concatstabto(asmlist);
3803 exit;
3804 end;
3806 if ((typesym=nil) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
3807 (is_def_stab_written = not_written) then
3808 begin
3809 if globalnb=0 then
3810 set_globalnb;
3811 { Write the record class itself }
3812 writing_class_record_stab:=true;
3813 inherited concatstabto(asmlist);
3814 writing_class_record_stab:=false;
3815 { Write the invisible pointer class }
3816 is_def_stab_written:=not_written;
3817 if assigned(typesym) then
3818 begin
3819 st:=typesym^._name;
3820 typesym^._name:=stringdup(' ');
3821 end;
3822 inherited concatstabto(asmlist);
3823 if assigned(typesym) then
3824 begin
3825 stringdispose(typesym^._name);
3826 typesym^._name:=st;
3827 end;
3828 end;
3829 end;
3830 {$endif GDB}
3833 procedure tobjectdef.write_child_init_data;
3834 begin
3835 symtable^.foreach({$ifndef TP}@{$endif}generate_child_inittable);
3836 end;
3839 procedure tobjectdef.write_init_data;
3840 begin
3841 if is_class then
3842 rttilist^.concat(new(pai_const,init_8bit(tkclass)))
3843 else
3844 rttilist^.concat(new(pai_const,init_8bit(tkobject)));
3846 { generate the name }
3847 rttilist^.concat(new(pai_const,init_8bit(length(objname^))));
3848 rttilist^.concat(new(pai_string,init(objname^)));
3850 rttilist^.concat(new(pai_const,init_32bit(size)));
3851 count:=0;
3852 symtable^.foreach({$ifndef TP}@{$endif}count_inittable_fields);
3853 rttilist^.concat(new(pai_const,init_32bit(count)));
3854 symtable^.foreach({$ifndef TP}@{$endif}write_field_inittable);
3855 end;
3858 function tobjectdef.needs_inittable : boolean;
3859 var
3860 oldb : boolean;
3861 begin
3862 if is_class then
3863 needs_inittable:=false
3864 else
3865 begin
3866 { there are recursive calls to needs_inittable possible, }
3867 { so we have to change to old value how else should }
3868 { we do that ? check_rec_rtti can't be a nested }
3869 { procedure of needs_rtti ! }
3870 oldb:=binittable;
3871 binittable:=false;
3872 symtable^.foreach({$ifndef TP}@{$endif}check_rec_inittable);
3873 needs_inittable:=binittable;
3874 binittable:=oldb;
3875 end;
3876 end;
3879 procedure count_published_properties(sym:pnamedindexobject);
3880 {$ifndef fpc}far;{$endif}
3881 begin
3882 if needs_prop_entry(psym(sym)) and
3883 (psym(sym)^.typ<>varsym) then
3884 inc(count);
3885 end;
3888 procedure write_property_info(sym : pnamedindexobject);{$ifndef fpc}far;{$endif}
3889 var
3890 proctypesinfo : byte;
3892 procedure writeproc(proc : psymlist; shiftvalue : byte);
3894 var
3895 typvalue : byte;
3896 hp : psymlistitem;
3897 address : longint;
3899 begin
3900 if not(assigned(proc) and assigned(proc^.firstsym)) then
3901 begin
3902 rttilist^.concat(new(pai_const,init_32bit(1)));
3903 typvalue:=3;
3904 end
3905 else if proc^.firstsym^.sym^.typ=varsym then
3906 begin
3907 address:=0;
3908 hp:=proc^.firstsym;
3909 while assigned(hp) do
3910 begin
3911 inc(address,pvarsym(hp^.sym)^.address);
3912 hp:=hp^.next;
3913 end;
3914 rttilist^.concat(new(pai_const,init_32bit(address)));
3915 typvalue:=0;
3916 end
3917 else
3918 begin
3919 if not(po_virtualmethod in pprocdef(proc^.def)^.procoptions) then
3920 begin
3921 rttilist^.concat(new(pai_const_symbol,initname(pprocdef(proc^.def)^.mangledname)));
3922 typvalue:=1;
3923 end
3924 else
3925 begin
3926 { virtual method, write vmt offset }
3927 rttilist^.concat(new(pai_const,init_32bit(
3928 pprocdef(proc^.def)^._class^.vmtmethodoffset(pprocdef(proc^.def)^.extnumber))));
3929 typvalue:=2;
3930 end;
3931 end;
3932 proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
3933 end;
3935 begin
3936 if needs_prop_entry(psym(sym)) then
3937 case psym(sym)^.typ of
3938 varsym:
3939 begin
3940 {$ifdef dummy}
3941 if not(pvarsym(sym)^.vartype.def^.deftype=objectdef) or
3942 not(pobjectdef(pvarsym(sym)^.vartype.def)^.is_class) then
3943 internalerror(1509992);
3944 { access to implicit class property as field }
3945 proctypesinfo:=(0 shl 0) or (0 shl 2) or (0 shl 4);
3946 rttilist^.concat(new(pai_const_symbol,initname(pvarsym(sym)^.vartype.def^.get_rtti_label)));
3947 rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
3948 rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
3949 { per default stored }
3950 rttilist^.concat(new(pai_const,init_32bit(1)));
3951 { index as well as ... }
3952 rttilist^.concat(new(pai_const,init_32bit(0)));
3953 { default value are zero }
3954 rttilist^.concat(new(pai_const,init_32bit(0)));
3955 rttilist^.concat(new(pai_const,init_16bit(count)));
3956 inc(count);
3957 rttilist^.concat(new(pai_const,init_8bit(proctypesinfo)));
3958 rttilist^.concat(new(pai_const,init_8bit(length(pvarsym(sym)^.name))));
3959 rttilist^.concat(new(pai_string,init(pvarsym(sym)^.name)));
3960 {$endif dummy}
3961 end;
3962 propertysym:
3963 begin
3964 if ppo_indexed in ppropertysym(sym)^.propoptions then
3965 proctypesinfo:=$40
3966 else
3967 proctypesinfo:=0;
3968 rttilist^.concat(new(pai_const_symbol,initname(ppropertysym(sym)^.proptype.def^.get_rtti_label)));
3969 writeproc(ppropertysym(sym)^.readaccess,0);
3970 writeproc(ppropertysym(sym)^.writeaccess,2);
3971 { isn't it stored ? }
3972 if not(ppo_stored in ppropertysym(sym)^.propoptions) then
3973 begin
3974 rttilist^.concat(new(pai_const,init_32bit(0)));
3975 proctypesinfo:=proctypesinfo or (3 shl 4);
3976 end
3977 else
3978 writeproc(ppropertysym(sym)^.storedaccess,4);
3979 rttilist^.concat(new(pai_const,init_32bit(ppropertysym(sym)^.index)));
3980 rttilist^.concat(new(pai_const,init_32bit(ppropertysym(sym)^.default)));
3981 rttilist^.concat(new(pai_const,init_16bit(count)));
3982 inc(count);
3983 rttilist^.concat(new(pai_const,init_8bit(proctypesinfo)));
3984 rttilist^.concat(new(pai_const,init_8bit(length(ppropertysym(sym)^.name))));
3985 rttilist^.concat(new(pai_string,init(ppropertysym(sym)^.name)));
3986 end;
3987 else internalerror(1509992);
3988 end;
3989 end;
3992 procedure generate_published_child_rtti(sym : pnamedindexobject);{$ifndef fpc}far;{$endif}
3993 begin
3994 if needs_prop_entry(psym(sym)) then
3995 case psym(sym)^.typ of
3996 varsym:
3997 ;
3998 { now ignored:
3999 pvarsym(sym)^.vartype.def^.get_rtti_label;
4000 }
4001 propertysym:
4002 ppropertysym(sym)^.proptype.def^.get_rtti_label;
4003 else
4004 internalerror(1509991);
4005 end;
4006 end;
4009 procedure tobjectdef.write_child_rtti_data;
4010 begin
4011 symtable^.foreach({$ifndef TP}@{$endif}generate_published_child_rtti);
4012 end;
4015 procedure tobjectdef.generate_rtti;
4016 begin
4017 if not has_rtti then
4018 begin
4019 has_rtti:=true;
4020 getdatalabel(rtti_label);
4021 write_child_rtti_data;
4022 rttilist^.concat(new(pai_symbol,initname_global(rtti_name,0)));
4023 rttilist^.concat(new(pai_label,init(rtti_label)));
4024 write_rtti_data;
4025 rttilist^.concat(new(pai_symbol_end,initname(rtti_name)));
4026 end;
4027 end;
4029 type
4030 tclasslistitem = object(tlinkedlist_item)
4031 index : longint;
4032 p : pobjectdef;
4033 end;
4034 pclasslistitem = ^tclasslistitem;
4036 var
4037 classtablelist : tlinkedlist;
4038 tablecount : longint;
4040 function searchclasstablelist(p : pobjectdef) : pclasslistitem;
4042 var
4043 hp : pclasslistitem;
4045 begin
4046 hp:=pclasslistitem(classtablelist.first);
4047 while assigned(hp) do
4048 if hp^.p=p then
4049 begin
4050 searchclasstablelist:=hp;
4051 exit;
4052 end
4053 else
4054 hp:=pclasslistitem(hp^.next);
4055 searchclasstablelist:=nil;
4056 end;
4058 procedure count_published_fields(sym:pnamedindexobject);
4059 {$ifndef fpc}far;{$endif}
4061 var
4062 hp : pclasslistitem;
4064 begin
4065 if needs_prop_entry(psym(sym)) and
4066 (psym(sym)^.typ=varsym) then
4067 begin
4068 if pvarsym(sym)^.vartype.def^.deftype<>objectdef then
4069 internalerror(0206001);
4070 hp:=searchclasstablelist(pobjectdef(pvarsym(sym)^.vartype.def));
4071 if not(assigned(hp)) then
4072 begin
4073 hp:=new(pclasslistitem,init);
4074 hp^.p:=pobjectdef(pvarsym(sym)^.vartype.def);
4075 hp^.index:=tablecount;
4076 classtablelist.concat(hp);
4077 inc(tablecount);
4078 end;
4079 inc(count);
4080 end;
4081 end;
4083 procedure writefields(sym:pnamedindexobject);
4084 {$ifndef fpc}far;{$endif}
4086 var
4087 hp : pclasslistitem;
4089 begin
4090 if needs_prop_entry(psym(sym)) and
4091 (psym(sym)^.typ=varsym) then
4092 begin
4093 rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
4094 hp:=searchclasstablelist(pobjectdef(pvarsym(sym)^.vartype.def));
4095 if not(assigned(hp)) then
4096 internalerror(0206002);
4097 rttilist^.concat(new(pai_const,init_16bit(hp^.index)));
4098 rttilist^.concat(new(pai_const,init_8bit(length(pvarsym(sym)^.name))));
4099 rttilist^.concat(new(pai_string,init(pvarsym(sym)^.name)));
4100 end;
4101 end;
4103 function tobjectdef.generate_field_table : pasmlabel;
4105 var
4106 fieldtable,
4107 classtable : pasmlabel;
4108 hp : pclasslistitem;
4110 begin
4111 classtablelist.init;
4112 getdatalabel(fieldtable);
4113 getdatalabel(classtable);
4114 count:=0;
4115 tablecount:=0;
4116 symtable^.foreach({$ifdef FPC}@{$endif}count_published_fields);
4117 rttilist^.concat(new(pai_label,init(fieldtable)));
4118 rttilist^.concat(new(pai_const,init_16bit(count)));
4119 rttilist^.concat(new(pai_const_symbol,init(classtable)));
4120 symtable^.foreach({$ifdef FPC}@{$endif}writefields);
4122 { generate the class table }
4123 rttilist^.concat(new(pai_label,init(classtable)));
4124 rttilist^.concat(new(pai_const,init_16bit(tablecount)));
4125 hp:=pclasslistitem(classtablelist.first);
4126 while assigned(hp) do
4127 begin
4128 rttilist^.concat(new(pai_const_symbol,initname(pobjectdef(hp^.p)^.vmt_mangledname)));
4129 hp:=pclasslistitem(hp^.next);
4130 end;
4132 generate_field_table:=fieldtable;
4133 classtablelist.done;
4134 end;
4136 function tobjectdef.next_free_name_index : longint;
4137 var
4138 i : longint;
4139 begin
4140 if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then
4141 i:=childof^.next_free_name_index
4142 else
4143 i:=0;
4144 count:=0;
4145 symtable^.foreach({$ifndef TP}@{$endif}count_published_properties);
4146 next_free_name_index:=i+count;
4147 end;
4150 procedure tobjectdef.write_rtti_data;
4151 begin
4152 if is_class then
4153 rttilist^.concat(new(pai_const,init_8bit(tkclass)))
4154 else
4155 rttilist^.concat(new(pai_const,init_8bit(tkobject)));
4157 { generate the name }
4158 rttilist^.concat(new(pai_const,init_8bit(length(objname^))));
4159 rttilist^.concat(new(pai_string,init(objname^)));
4161 { write class type }
4162 rttilist^.concat(new(pai_const_symbol,initname(vmt_mangledname)));
4164 { write owner typeinfo }
4165 if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then
4166 rttilist^.concat(new(pai_const_symbol,initname(childof^.get_rtti_label)))
4167 else
4168 rttilist^.concat(new(pai_const,init_32bit(0)));
4170 { count total number of properties }
4171 if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then
4172 count:=childof^.next_free_name_index
4173 else
4174 count:=0;
4176 { write it }
4177 symtable^.foreach({$ifndef TP}@{$endif}count_published_properties);
4178 rttilist^.concat(new(pai_const,init_16bit(count)));
4180 { write unit name }
4181 if assigned(owner^.name) then
4182 begin
4183 rttilist^.concat(new(pai_const,init_8bit(length(owner^.name^))));
4184 rttilist^.concat(new(pai_string,init(owner^.name^)));
4185 end
4186 else
4187 rttilist^.concat(new(pai_const,init_8bit(0)));
4189 { write published properties count }
4190 count:=0;
4191 symtable^.foreach({$ifndef TP}@{$endif}count_published_properties);
4192 rttilist^.concat(new(pai_const,init_16bit(count)));
4194 { count is used to write nameindex }
4195 { but we need an offset of the owner }
4196 { to give each property an own slot }
4197 if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then
4198 count:=childof^.next_free_name_index
4199 else
4200 count:=0;
4202 symtable^.foreach({$ifndef TP}@{$endif}write_property_info);
4203 end;
4206 function tobjectdef.is_publishable : boolean;
4207 begin
4208 is_publishable:=is_class;
4209 end;
4211 function tobjectdef.get_rtti_label : string;
4213 begin
4214 generate_rtti;
4215 get_rtti_label:=rtti_name;
4216 end;
4218 {****************************************************************************
4219 TFORWARDDEF
4220 ****************************************************************************}
4222 constructor tforwarddef.init(const s:string;const pos : tfileposinfo);
4223 var
4224 oldregisterdef : boolean;
4225 begin
4226 { never register the forwarddefs, they are disposed at the
4227 end of the type declaration block }
4228 oldregisterdef:=registerdef;
4229 registerdef:=false;
4230 inherited init;
4231 registerdef:=oldregisterdef;
4232 deftype:=forwarddef;
4233 tosymname:=s;
4234 forwardpos:=pos;
4235 end;
4238 function tforwarddef.gettypename:string;
4239 begin
4240 gettypename:='unresolved forward to '+tosymname;
4241 end;
4244 {****************************************************************************
4245 TERRORDEF
4246 ****************************************************************************}
4248 constructor terrordef.init;
4249 begin
4250 inherited init;
4251 deftype:=errordef;
4252 end;
4255 {$ifdef GDB}
4256 function terrordef.stabstring : pchar;
4257 begin
4258 stabstring:=strpnew('error'+numberstring);
4259 end;
4260 {$endif GDB}
4262 function terrordef.gettypename:string;
4264 begin
4265 gettypename:='<erroneous type>';
4266 end;
4268 {
4269 $Log$
4270 Revision 1.1 2002/02/19 08:23:51 sasu
4271 Initial revision
4273 Revision 1.1.2.17 2000/12/18 17:59:54 peter
4274 * removed unused var
4276 Revision 1.1.2.16 2000/11/26 18:13:47 florian
4277 * rtti for chars fixed
4279 Revision 1.1.2.15 2000/11/20 16:20:48 pierre
4280 + add size specifer for stabs of enums and sets
4282 Revision 1.1.2.14 2000/11/17 23:14:44 pierre
4283 * class stabs fix try
4285 Revision 1.1.2.13 2000/10/16 19:43:03 pierre
4286 * trying to correct class stabss once more
4288 Revision 1.1.2.12 2000/10/14 00:40:46 pierre
4289 * fixes for class debugging
4291 Revision 1.1.2.11 2000/10/13 12:08:42 peter
4292 * class stabsnumbering fixed partly
4294 Revision 1.1.2.10 2000/10/12 23:06:21 florian
4295 * type mismatch with procedure variables gives a more descriptive message now
4297 Revision 1.1.2.9 2000/10/04 22:55:42 pierre
4298 * fix object stabs
4300 Revision 1.1.2.8 2000/09/19 22:26:27 pierre
4301 * fix for the local class debugging problem
4303 Revision 1.1.2.7 2000/09/10 20:12:26 peter
4304 * fixed array of const writing instead of array of tvarrec
4306 Revision 1.1.2.6 2000/09/09 18:39:46 peter
4307 * fixed C alignment of array of record
4309 Revision 1.1.2.5 2000/08/21 08:09:47 pierre
4310 * fix stabs problems
4312 Revision 1.1.2.4 2000/08/18 12:56:31 pierre
4313 * avoid infinite recursion in stabs generation
4315 Revision 1.1.2.3 2000/08/16 18:26:01 peter
4316 * splitted namedobjectitem.next into indexnext and listnext so it
4317 can be used in both lists
4318 * don't allow "word = word" type definitions
4320 Revision 1.1.2.2 2000/08/08 19:20:06 peter
4321 * setmangledname doesn't set parast,localst anymore (only in extdebug)
4323 Revision 1.1.2.1 2000/08/06 14:14:09 peter
4324 * hasforward added to check if a proc had a forward decl
4326 Revision 1.1 2000/07/13 06:29:56 michael
4327 + Initial import
4329 Revision 1.205 2000/06/30 22:11:29 peter
4330 * fixed some getlabel to getdatalabel
4332 Revision 1.204 2000/06/29 08:42:47 sg
4333 * Fix for class field table writing
4335 Revision 1.203 2000/06/25 09:25:29 peter
4336 * setdef.typename, show Empty Set if elementtype is not set
4338 Revision 1.202 2000/06/22 20:01:57 peter
4339 * int64,qword rtti support
4341 Revision 1.201 2000/06/18 18:11:32 peter
4342 * C record packing fixed to also check first entry of the record
4343 if bigger than the recordalignment itself
4344 * variant record alignment uses alignment per variant and saves the
4345 highest alignment value
4347 Revision 1.200 2000/06/02 18:48:47 florian
4348 + fieldtable support for classes
4350 Revision 1.199 2000/04/01 14:17:08 peter
4351 * arraydef.elesize returns 4 when strings are found in an openarray,
4352 arrayconstructor. Since only the pointers to the strings are stored
4354 Revision 1.198 2000/04/01 11:44:56 peter
4355 * fixed rtti info for record
4357 Revision 1.197 2000/03/01 12:35:45 pierre
4358 * fix for bug 855
4360 Revision 1.196 2000/02/14 20:58:43 marco
4361 * Basic structures for new sethandling implemented.
4363 Revision 1.195 2000/02/11 13:53:49 pierre
4364 * avoid stack overflow in tref.done (bug 846)
4366 Revision 1.194 2000/02/09 13:23:04 peter
4367 * log truncated
4369 Revision 1.193 2000/02/05 14:33:32 florian
4370 * fixed init table generation for classes and arrays
4372 Revision 1.192 2000/02/04 20:00:22 florian
4373 * an exception in a construcor calls now the destructor (this applies only
4374 to classes)
4376 Revision 1.191 2000/01/30 23:29:06 peter
4377 * fixed dup rtti writing for classes
4379 Revision 1.190 2000/01/28 23:17:53 florian
4380 * virtual XXXX; support for objects, only if -dWITHDMT is defined
4382 Revision 1.189 2000/01/26 12:02:29 peter
4383 * abstractprocdef.para_size needs alignment parameter
4384 * secondcallparan gets para_alignment size instead of dword_align
4386 Revision 1.188 2000/01/23 16:35:31 peter
4387 * localbrowser loading of absolute fixed. It needed a symtablestack
4388 which was not setup correctly
4390 Revision 1.187 2000/01/09 23:16:06 peter
4391 * added st_default stringtype
4392 * genstringconstnode extended with stringtype parameter using st_default
4393 will do the old behaviour
4395 Revision 1.186 2000/01/07 01:14:39 peter
4396 * updated copyright to 2000
4398 Revision 1.185 2000/01/03 19:26:03 peter
4399 * fixed resolving of ttypesym which are reference from object/record
4400 fields.
4402 Revision 1.184 1999/12/31 14:24:34 peter
4403 * fixed rtti generation for classes with no published section
4405 Revision 1.183 1999/12/23 12:19:42 peter
4406 * check_rec_inittable fix from sg
4408 Revision 1.182 1999/12/19 17:00:27 peter
4409 * has_rtti should be saved in the ppu for objects
4411 Revision 1.181 1999/12/18 14:55:21 florian
4412 * very basic widestring support
4414 Revision 1.180 1999/12/06 18:21:03 peter
4415 * support !ENVVAR for long commandlines
4416 * win32/go32v2 write short pathnames to link.res so c:\Program Files\ is
4417 finally supported as installdir.
4419 Revision 1.179 1999/12/01 12:42:33 peter
4420 * fixed bug 698
4421 * removed some notes about unused vars
4423 Revision 1.178 1999/12/01 10:26:38 pierre
4424 * restore the correct way for stabs of forward defs
4426 Revision 1.177 1999/11/30 10:40:54 peter
4427 + ttype, tsymlist
4429 Revision 1.176 1999/11/09 23:35:49 pierre
4430 + better reference pos for forward defs
4432 Revision 1.175 1999/11/07 23:57:36 pierre
4433 + higher level browser
4435 Revision 1.174 1999/11/06 14:34:26 peter
4436 * truncated log to 20 revs
4438 }