?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Initial revision
[AROS-Contrib.git] / development / compilers / freepascal / compiler / ptconst.pas
blobbb43ce694f98194f0d9c5e83d7c87f21e8dbfdcb
1 {
2 $Id$
3 Copyright (c) 1998-2000 by Florian Klaempfl
4
5 Reads typed constants
6
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
11
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20
21 ****************************************************************************
22 }
23 unit ptconst;
24
25 interface
26
27 uses symtable;
28
29 { this procedure reads typed constants }
30 { sym is only needed for ansi strings }
31 { the assembler label is in the middle (PM) }
32 procedure readtypedconst(def : pdef;sym : ptypedconstsym;no_change_allowed : boolean);
33
34 implementation
35
36 uses
37 {$ifdef Delphi}
38 sysutils,
39 {$else}
40 strings,
41 {$endif Delphi}
42 globtype,systems,tokens,
43 cobjects,globals,scanner,
44 symconst,aasm,types,verbose,
45 tree,pass_1,
46 { parser specific stuff }
47 pbase,pexpr,
48 { processor specific stuff }
49 cpubase,
50 { codegen }
51 {$ifdef newcg}
52 cgbase,
53 {$else}
54 hcodegen,
55 {$endif}
56 hcgdata;
57
58
59 {$ifdef fpc}
60 {$maxfpuregisters 0}
61 {$endif fpc}
62 { this procedure reads typed constants }
63 procedure readtypedconst(def : pdef;sym : ptypedconstsym;no_change_allowed : boolean);
64
65 var
66 {$ifdef m68k}
67 j : longint;
68 {$endif m68k}
69 len,base : longint;
70 p,hp : ptree;
71 i,l,offset,
72 strlength : longint;
73 curconstsegment : paasmoutput;
74 ll : pasmlabel;
75 s : string;
76 ca : pchar;
77 aktpos : longint;
78 obj : pobjectdef;
79 symt : psymtable;
80 value : bestreal;
81 strval : pchar;
82
83 procedure check_range;
84 begin
85 if ((p^.value>porddef(def)^.high) or
86 (p^.value<porddef(def)^.low)) then
87 begin
88 if (cs_check_range in aktlocalswitches) then
89 Message(parser_e_range_check_error)
90 else
91 Message(parser_w_range_check_error);
92 end;
93 end;
94
95 (* function is_po_equal(o1,o2:longint):boolean;
96 begin
97 { assembler does not affect }
98 is_po_equal:=(o1 and not(poassembler))=
99 (o2 and not(poassembler));
100 end; *)
101
102 {$R-} {Range check creates problem with init_8bit(-1) !!}
103 begin
104 if no_change_allowed then
105 curconstsegment:=consts
106 else
107 curconstsegment:=datasegment;
108 case def^.deftype of
109 orddef:
110 begin
111 p:=comp_expr(true);
112 do_firstpass(p);
113 case porddef(def)^.typ of
114 s8bit,
115 u8bit : begin
116 if not is_constintnode(p) then
117 { is't an int expected }
118 Message(cg_e_illegal_expression)
119 else
120 begin
121 curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
122 check_range;
123 end;
124 end;
125 s32bit : begin
126 if not is_constintnode(p) then
127 Message(cg_e_illegal_expression)
128 else
129 begin
130 curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
131 check_range;
132 end;
133 end;
134 u32bit : begin
135 if not is_constintnode(p) then
136 Message(cg_e_illegal_expression)
137 else
138 curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
139 end;
140 bool8bit : begin
141 if not is_constboolnode(p) then
142 Message(cg_e_illegal_expression);
143 curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
144 end;
145 bool16bit : begin
146 if not is_constboolnode(p) then
147 Message(cg_e_illegal_expression);
148 curconstsegment^.concat(new(pai_const,init_16bit(p^.value)));
149 end;
150 bool32bit : begin
151 if not is_constboolnode(p) then
152 Message(cg_e_illegal_expression);
153 curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
154 end;
155 uchar : begin
156 if not is_constcharnode(p) then
157 Message(cg_e_illegal_expression);
158 curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
159 end;
160 uwidechar : begin
161 if not is_constcharnode(p) then
162 Message(cg_e_illegal_expression);
163 curconstsegment^.concat(new(pai_const,init_16bit(p^.value)));
164 end;
165 u16bit,
166 s16bit : begin
167 if not is_constintnode(p) then
168 Message(cg_e_illegal_expression);
169 curconstsegment^.concat(new(pai_const,init_16bit(p^.value)));
170 check_range;
171 end;
172 s64bit,
173 u64bit:
174 begin
175 if not is_constintnode(p) then
176 Message(cg_e_illegal_expression)
177 else
178 begin
179 {!!!!! hmmm, we can write yet only consts til 2^32-1 :( (FK) }
180 curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
181 curconstsegment^.concat(new(pai_const,init_32bit(0)));
182 end;
183 end;
184 else
185 internalerror(3799);
186 end;
187 disposetree(p);
188 end;
189 floatdef:
190 begin
191 p:=comp_expr(true);
192 do_firstpass(p);
193 if is_constrealnode(p) then
194 value:=p^.value_real
195 else if is_constintnode(p) then
196 value:=p^.value
197 else
198 Message(cg_e_illegal_expression);
199
200 case pfloatdef(def)^.typ of
201 s32real : curconstsegment^.concat(new(pai_real_32bit,init(value)));
202 s64real : curconstsegment^.concat(new(pai_real_64bit,init(value)));
203 s80real : curconstsegment^.concat(new(pai_real_80bit,init(value)));
204 s64comp : curconstsegment^.concat(new(pai_comp_64bit,init(value)));
205 f32bit : curconstsegment^.concat(new(pai_const,init_32bit(trunc(value*65536))));
206 else internalerror(18);
207 end;
208 disposetree(p);
209 end;
210 classrefdef:
211 begin
212 p:=comp_expr(true);
213 do_firstpass(p);
214 case p^.treetype of
215 loadvmtn:
216 begin
217 if not(pobjectdef(pclassrefdef(p^.resulttype)^.pointertype.def)^.is_related(
218 pobjectdef(pclassrefdef(def)^.pointertype.def))) then
219 Message(cg_e_illegal_expression);
220 curconstsegment^.concat(new(pai_const_symbol,init(newasmsymbol(pobjectdef(
221 pclassrefdef(p^.resulttype)^.pointertype.def)^.vmt_mangledname))));
222 end;
223 niln:
224 curconstsegment^.concat(new(pai_const,init_32bit(0)));
225 else Message(cg_e_illegal_expression);
226 end;
227 disposetree(p);
228 end;
229 pointerdef:
230 begin
231 p:=comp_expr(true);
232 do_firstpass(p);
233 if (p^.treetype=typeconvn) and
234 ((p^.left^.treetype=addrn) or (p^.left^.treetype=niln)) and
235 is_equal(def,p^.resulttype) then
236 begin
237 hp:=p^.left;
238 putnode(p);
239 p:=hp;
240 end;
241 { allows horrible ofs(typeof(TButton)^) code !! }
242 if (p^.treetype=addrn) and (p^.left^.treetype=derefn) then
243 begin
244 hp:=p^.left^.left;
245 p^.left^.left:=nil;
246 disposetree(p);
247 p:=hp;
248 end;
249 { nil pointer ? }
250 if p^.treetype=niln then
251 curconstsegment^.concat(new(pai_const,init_32bit(0)))
252 { maybe pchar ? }
253 else
254 if is_char(ppointerdef(def)^.pointertype.def) and
255 (p^.treetype<>addrn) then
256 begin
257 getdatalabel(ll);
258 curconstsegment^.concat(new(pai_const_symbol,init(ll)));
259 consts^.concat(new(pai_label,init(ll)));
260 if p^.treetype=stringconstn then
261 begin
262 len:=p^.length;
263 { For tp7 the maximum lentgh can be 255 }
264 if (m_tp in aktmodeswitches) and
265 (len>255) then
266 len:=255;
267 getmem(ca,len+2);
268 move(p^.value_str^,ca^,len+1);
269 consts^.concat(new(pai_string,init_length_pchar(ca,len+1)));
270 end
271 else
272 if is_constcharnode(p) then
273 consts^.concat(new(pai_string,init(char(byte(p^.value))+#0)))
274 else
275 Message(cg_e_illegal_expression);
276 end
277 else
278 if p^.treetype=addrn then
279 begin
280 hp:=p^.left;
281 while assigned(hp) and (hp^.treetype in [subscriptn,vecn]) do
282 hp:=hp^.left;
283 if (is_equal(ppointerdef(p^.resulttype)^.pointertype.def,ppointerdef(def)^.pointertype.def) or
284 (is_equal(ppointerdef(p^.resulttype)^.pointertype.def,voiddef)) or
285 (is_equal(ppointerdef(def)^.pointertype.def,voiddef))) and
286 (hp^.treetype=loadn) then
287 begin
288 do_firstpass(p^.left);
289 hp:=p^.left;
290 offset:=0;
291 while assigned(hp) and (hp^.treetype<>loadn) do
292 begin
293 case hp^.treetype of
294 vecn :
295 begin
296 if (hp^.left^.resulttype^.deftype=stringdef) then
297 begin
298 { this seems OK for shortstring and ansistrings PM }
299 { it is wrong for widestrings !! }
300 len:=1;
301 base:=0;
302 end
303 else if (hp^.left^.resulttype^.deftype=arraydef) then
304 begin
305 len:=parraydef(hp^.left^.resulttype)^.elesize;
306 base:=parraydef(hp^.left^.resulttype)^.lowrange;
307 end
308 else
309 Message(cg_e_illegal_expression);
310 if is_constintnode(hp^.right) then
311 inc(offset,len*(get_ordinal_value(hp^.right)-base))
312 else
313 Message(cg_e_illegal_expression);
314 {internalerror(9779);}
315 end;
316
317 subscriptn : inc(offset,hp^.vs^.address)
318 else
319 Message(cg_e_illegal_expression);
320 end;
321 hp:=hp^.left;
322 end;
323 if hp^.symtableentry^.typ=constsym then
324 Message(type_e_variable_id_expected);
325 curconstsegment^.concat(new(pai_const_symbol,initname_offset(hp^.symtableentry^.mangledname,offset)));
326 (*if token=POINT then
327 begin
328 offset:=0;
329 while token=_POINT do
330 begin
331 consume(_POINT);
332 lsym:=pvarsym(precdef(
333 ppointerdef(p^.resulttype)^.pointertype.def)^.symtable^.search(pattern));
334 if assigned(sym) then
335 offset:=offset+lsym^.address
336 else
337 begin
338 Message1(sym_e_illegal_field,pattern);
339 end;
340 consume(_ID);
341 end;
342 curconstsegment^.concat(new(pai_const_symbol_offset,init(
343 strpnew(p^.left^.symtableentry^.mangledname),offset)));
344 end
345 else
346 begin
347 curconstsegment^.concat(new(pai_const,init_symbol(
348 strpnew(p^.left^.symtableentry^.mangledname))));
349 end; *)
350 end
351 else
352 Message(cg_e_illegal_expression);
353 end
354 else
355 { allow typeof(Object type)}
356 if (p^.treetype=inlinen) and
357 (p^.inlinenumber=in_typeof_x) then
358 begin
359 if (p^.left^.treetype=typen) then
360 begin
361 curconstsegment^.concat(new(pai_const_symbol,
362 initname(pobjectdef(p^.left^.resulttype)^.vmt_mangledname)));
363 end
364 else
365 Message(cg_e_illegal_expression);
366 end
367 else
368 Message(cg_e_illegal_expression);
369 disposetree(p);
370 end;
371 setdef:
372 begin
373 p:=comp_expr(true);
374 do_firstpass(p);
375 if p^.treetype=setconstn then
376 begin
377 { we only allow const sets }
378 if assigned(p^.left) then
379 Message(cg_e_illegal_expression)
380 else
381 begin
382 {$ifdef i386}
383 for l:=0 to def^.size-1 do
384 curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[l])));
385 {$endif}
386 {$ifdef m68k}
387 j:=0;
388 for l:=0 to ((def^.size-1) div 4) do
389 { HORRIBLE HACK because of endian }
390 { now use intel endian for constant sets }
391 begin
392 curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+3])));
393 curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+2])));
394 curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+1])));
395 curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j])));
396 Inc(j,4);
397 end;
398 {$endif}
399 end;
400 end
401 else
402 Message(cg_e_illegal_expression);
403 disposetree(p);
404 end;
405 enumdef:
406 begin
407 p:=comp_expr(true);
408 do_firstpass(p);
409 if p^.treetype=ordconstn then
410 begin
411 if is_equal(p^.resulttype,def) or
412 is_subequal(p^.resulttype,def) then
413 begin
414 case p^.resulttype^.size of
415 1 : curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
416 2 : curconstsegment^.concat(new(pai_const,init_16bit(p^.value)));
417 4 : curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
418 end;
419 end
420 else
421 Message2(type_e_incompatible_types,def^.typename,p^.resulttype^.typename);
422 end
423 else
424 Message(cg_e_illegal_expression);
425 disposetree(p);
426 end;
427 stringdef:
428 begin
429 p:=comp_expr(true);
430 do_firstpass(p);
431 { load strval and strlength of the constant tree }
432 if p^.treetype=stringconstn then
433 begin
434 strlength:=p^.length;
435 strval:=p^.value_str;
436 end
437 else if is_constcharnode(p) then
438 begin
439 strval:=pchar(@p^.value);
440 strlength:=1
441 end
442 else if is_constresourcestringnode(p) then
443 begin
444 strval:=pchar(pconstsym(p^.symtableentry)^.value);
445 strlength:=pconstsym(p^.symtableentry)^.len;
446 end
447 else
448 begin
449 Message(cg_e_illegal_expression);
450 strlength:=-1;
451 end;
452 if strlength>=0 then
453 begin
454 case pstringdef(def)^.string_typ of
455 st_shortstring:
456 begin
457 if strlength>=def^.size then
458 begin
459 message2(parser_w_string_too_long,strpas(strval),tostr(def^.size-1));
460 strlength:=def^.size-1;
461 end;
462 curconstsegment^.concat(new(pai_const,init_8bit(strlength)));
463 { this can also handle longer strings }
464 getmem(ca,strlength+1);
465 move(strval^,ca^,strlength);
466 ca[strlength]:=#0;
467 curconstsegment^.concat(new(pai_string,init_length_pchar(ca,strlength)));
468 { fillup with spaces if size is shorter }
469 if def^.size>strlength then
470 begin
471 getmem(ca,def^.size-strlength);
472 { def^.size contains also the leading length, so we }
473 { we have to subtract one }
474 fillchar(ca[0],def^.size-strlength-1,' ');
475 ca[def^.size-strlength-1]:=#0;
476 { this can also handle longer strings }
477 curconstsegment^.concat(new(pai_string,init_length_pchar(ca,def^.size-strlength-1)));
478 end;
479 end;
480 {$ifdef UseLongString}
481 st_longstring:
482 begin
483 { first write the maximum size }
484 curconstsegment^.concat(new(pai_const,init_32bit(strlength)))));
485 { fill byte }
486 curconstsegment^.concat(new(pai_const,init_8bit(0)));
487 getmem(ca,strlength+1);
488 move(strval^,ca^,strlength);
489 ca[strlength]:=#0;
490 generate_pascii(consts,ca,strlength);
491 curconstsegment^.concat(new(pai_const,init_8bit(0)));
492 end;
493 {$endif UseLongString}
494 st_ansistring:
495 begin
496 { an empty ansi string is nil! }
497 if (strlength=0) then
498 curconstsegment^.concat(new(pai_const,init_32bit(0)))
499 else
500 begin
501 getdatalabel(ll);
502 curconstsegment^.concat(new(pai_const_symbol,init(ll)));
503 { first write the maximum size }
504 consts^.concat(new(pai_const,init_32bit(strlength)));
505 { second write the real length }
506 consts^.concat(new(pai_const,init_32bit(strlength)));
507 { redondent with maxlength but who knows ... (PM) }
508 { third write use count (set to -1 for safety ) }
509 consts^.concat(new(pai_const,init_32bit(-1)));
510 consts^.concat(new(pai_label,init(ll)));
511 getmem(ca,strlength+2);
512 move(strval^,ca^,strlength);
513 { The terminating #0 to be stored in the .data section (JM) }
514 ca[strlength]:=#0;
515 { End of the PChar. The memory has to be allocated because in }
516 { tai_string.done, there is a freemem(len+1) (JM) }
517 ca[strlength+1]:=#0;
518 consts^.concat(new(pai_string,init_length_pchar(ca,strlength+1)));
519 end;
520 end;
521 end;
522 end;
523 disposetree(p);
524 end;
525 arraydef:
526 begin
527 if token=_LKLAMMER then
528 begin
529 consume(_LKLAMMER);
530 for l:=parraydef(def)^.lowrange to parraydef(def)^.highrange-1 do
531 begin
532 readtypedconst(parraydef(def)^.elementtype.def,nil,no_change_allowed);
533 consume(_COMMA);
534 end;
535 readtypedconst(parraydef(def)^.elementtype.def,nil,no_change_allowed);
536 consume(_RKLAMMER);
537 end
538 else
539 { if array of char then we allow also a string }
540 if is_char(parraydef(def)^.elementtype.def) then
541 begin
542 p:=comp_expr(true);
543 do_firstpass(p);
544 if p^.treetype=stringconstn then
545 begin
546 len:=p^.length;
547 { For tp7 the maximum lentgh can be 255 }
548 if (m_tp in aktmodeswitches) and
549 (len>255) then
550 len:=255;
551 ca:=p^.value_str;
552 end
553 else
554 if is_constcharnode(p) then
555 begin
556 ca:=pchar(@p^.value);
557 len:=1;
558 end
559 else
560 begin
561 Message(cg_e_illegal_expression);
562 len:=0;
563 end;
564 if len>(Parraydef(def)^.highrange-Parraydef(def)^.lowrange+1) then
565 Message(parser_e_string_larger_array);
566 for i:=Parraydef(def)^.lowrange to Parraydef(def)^.highrange do
567 begin
568 if i+1-Parraydef(def)^.lowrange<=len then
569 begin
570 curconstsegment^.concat(new(pai_const,init_8bit(byte(ca^))));
571 inc(ca);
572 end
573 else
574 {Fill the remaining positions with #0.}
575 curconstsegment^.concat(new(pai_const,init_8bit(0)));
576 end;
577 disposetree(p);
578 end
579 else
580 begin
581 { we want the ( }
582 consume(_LKLAMMER);
583 end;
584 end;
585 procvardef:
586 begin
587 { Procvars and pointers are no longer compatible. }
588 { under tp: =nil or =var under fpc: =nil or =@var }
589 if token=_NIL then
590 begin
591 curconstsegment^.concat(new(pai_const,init_32bit(0)));
592 consume(_NIL);
593 exit;
594 end
595 else
596 if not(m_tp_procvar in aktmodeswitches) then
597 if token=_KLAMMERAFFE then
598 consume(_KLAMMERAFFE);
599 getprocvar:=true;
600 getprocvardef:=pprocvardef(def);
601 p:=comp_expr(true);
602 getprocvar:=false;
603 do_firstpass(p);
604 if codegenerror then
605 begin
606 disposetree(p);
607 exit;
608 end;
609 { convert calln to loadn }
610 if p^.treetype=calln then
611 begin
612 if (p^.symtableprocentry^.owner^.symtabletype=objectsymtable) and
613 (pobjectdef(p^.symtableprocentry^.owner^.defowner)^.is_class) then
614 hp:=genloadmethodcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc,
615 getcopy(p^.methodpointer))
616 else
617 hp:=genloadcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc);
618 disposetree(p);
619 do_firstpass(hp);
620 p:=hp;
621 if codegenerror then
622 begin
623 disposetree(p);
624 exit;
625 end;
626 end
627 else if (p^.treetype=addrn) and assigned(p^.left) and
628 (p^.left^.treetype=calln) then
629 begin
630 if (p^.left^.symtableprocentry^.owner^.symtabletype=objectsymtable) and
631 (pobjectdef(p^.left^.symtableprocentry^.owner^.defowner)^.is_class) then
632 hp:=genloadmethodcallnode(pprocsym(p^.left^.symtableprocentry),
633 p^.left^.symtableproc,getcopy(p^.left^.methodpointer))
634 else
635 hp:=genloadcallnode(pprocsym(p^.left^.symtableprocentry),
636 p^.left^.symtableproc);
637 disposetree(p);
638 do_firstpass(hp);
639 p:=hp;
640 if codegenerror then
641 begin
642 disposetree(p);
643 exit;
644 end;
645 end;
646 { let type conversion check everything needed }
647 p:=gentypeconvnode(p,def);
648 do_firstpass(p);
649 if codegenerror then
650 begin
651 disposetree(p);
652 exit;
653 end;
654 { remove typeconvn, that will normally insert a lea
655 instruction which is not necessary for us }
656 if p^.treetype=typeconvn then
657 begin
658 hp:=p^.left;
659 putnode(p);
660 p:=hp;
661 end;
662 { remove addrn which we also don't need here }
663 if p^.treetype=addrn then
664 begin
665 hp:=p^.left;
666 putnode(p);
667 p:=hp;
668 end;
669 { we now need to have a loadn with a procsym }
670 if (p^.treetype=loadn) and
671 (p^.symtableentry^.typ=procsym) then
672 begin
673 curconstsegment^.concat(new(pai_const_symbol,
674 initname(pprocsym(p^.symtableentry)^.definition^.mangledname)));
675 end
676 else
677 Message(cg_e_illegal_expression);
678 disposetree(p);
679 end;
680 { reads a typed constant record }
681 recorddef:
682 begin
683 consume(_LKLAMMER);
684 aktpos:=0;
685 while token<>_RKLAMMER do
686 begin
687 s:=pattern;
688 consume(_ID);
689 consume(_COLON);
690 srsym:=precorddef(def)^.symtable^.search(s);
691 if srsym=nil then
692 begin
693 Message1(sym_e_id_not_found,s);
694 consume_all_until(_SEMICOLON);
695 end
696 else
697 begin
698 { check position }
699 if pvarsym(srsym)^.address<aktpos then
700 Message(parser_e_invalid_record_const);
701
702 { if needed fill }
703 if pvarsym(srsym)^.address>aktpos then
704 for i:=1 to pvarsym(srsym)^.address-aktpos do
705 curconstsegment^.concat(new(pai_const,init_8bit(0)));
706
707 { new position }
708 aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.vartype.def^.size;
709
710 { read the data }
711 readtypedconst(pvarsym(srsym)^.vartype.def,nil,no_change_allowed);
712
713 if token=_SEMICOLON then
714 consume(_SEMICOLON)
715 else break;
716 end;
717 end;
718 for i:=1 to def^.size-aktpos do
719 curconstsegment^.concat(new(pai_const,init_8bit(0)));
720 consume(_RKLAMMER);
721 end;
722 { reads a typed object }
723 objectdef:
724 begin
725 if ([oo_has_vmt,oo_is_class]*pobjectdef(def)^.objectoptions)<>[] then
726 begin
727 { support nil assignment for classes }
728 if pobjectdef(def)^.is_class and
729 try_to_consume(_NIL) then
730 begin
731 curconstsegment^.concat(new(pai_const,init_32bit(0)));
732 end
733 else
734 begin
735 Message(parser_e_type_const_not_possible);
736 consume_all_until(_RKLAMMER);
737 end;
738 end
739 else
740 begin
741 consume(_LKLAMMER);
742 aktpos:=0;
743 while token<>_RKLAMMER do
744 begin
745 s:=pattern;
746 consume(_ID);
747 consume(_COLON);
748 srsym:=nil;
749 obj:=pobjectdef(def);
750 symt:=obj^.symtable;
751 while (srsym=nil) and assigned(symt) do
752 begin
753 srsym:=symt^.search(s);
754 if assigned(obj) then
755 obj:=obj^.childof;
756 if assigned(obj) then
757 symt:=obj^.symtable
758 else
759 symt:=nil;
760 end;
761
762 if srsym=nil then
763 begin
764 Message1(sym_e_id_not_found,s);
765 consume_all_until(_SEMICOLON);
766 end
767 else
768 begin
769 { check position }
770 if pvarsym(srsym)^.address<aktpos then
771 Message(parser_e_invalid_record_const);
772
773 { if needed fill }
774 if pvarsym(srsym)^.address>aktpos then
775 for i:=1 to pvarsym(srsym)^.address-aktpos do
776 curconstsegment^.concat(new(pai_const,init_8bit(0)));
777
778 { new position }
779 aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.vartype.def^.size;
780
781 { read the data }
782 readtypedconst(pvarsym(srsym)^.vartype.def,nil,no_change_allowed);
783
784 if token=_SEMICOLON then
785 consume(_SEMICOLON)
786 else break;
787 end;
788 end;
789 for i:=1 to def^.size-aktpos do
790 curconstsegment^.concat(new(pai_const,init_8bit(0)));
791 consume(_RKLAMMER);
792 end;
793 end;
794 errordef:
795 begin
796 { try to consume something useful }
797 if token=_LKLAMMER then
798 consume_all_until(_RKLAMMER)
799 else
800 consume_all_until(_SEMICOLON);
801 end;
802 else Message(parser_e_type_const_not_possible);
803 end;
804 end;
805 {$ifdef fpc}
806 {$maxfpuregisters default}
807 {$endif fpc}
808
809 end.
810 {
811 $Log$
812 Revision 1.1 2002/02/19 08:23:37 sasu
813 Initial revision
814
815 Revision 1.1.2.4 2000/12/10 20:15:59 peter
816 * also check for subtypes for enumerations
817
818 Revision 1.1.2.3 2000/09/30 13:12:32 peter
819 * const array of char and pchar length fixed
820
821 Revision 1.1.2.2 2000/08/24 19:10:51 peter
822 * allow nil for class typed consts
823
824 Revision 1.1.2.1 2000/08/05 13:21:52 peter
825 * fixed enumwriting with enumsize <> 4
826
827 Revision 1.1 2000/07/13 06:29:55 michael
828 + Initial import
829
830 Revision 1.68 2000/06/06 13:06:17 jonas
831 * ansistring constants now also get a trailing #0 (bug reported by
832 Thomas Schatzl)
833
834 Revision 1.67 2000/05/17 17:10:06 peter
835 * add support for loading of typed const strings with resourcestrings,
836 made the loading also a bit more generic
837
838 Revision 1.66 2000/05/12 06:02:01 pierre
839 * * get it to compile with Delphi by Kovacs Attila Zoltan
840
841 Revision 1.65 2000/05/11 09:15:15 pierre
842 + add a warning if a const string is longer than the
843 length of the string type
844
845 Revision 1.64 2000/04/02 09:12:51 florian
846 + constant procedure variables can have a @ in front:
847 const p : procedure = @p;
848 til now only
849 const p : procedure = p;
850 was allowed
851
852 Revision 1.63 2000/02/13 14:21:51 jonas
853 * modifications to make the compiler functional when compiled with
854 -Or
855
856 Revision 1.62 2000/02/09 13:23:01 peter
857 * log truncated
858
859 Revision 1.61 2000/01/07 01:14:33 peter
860 * updated copyright to 2000
861
862 Revision 1.60 1999/12/18 14:55:21 florian
863 * very basic widestring support
864
865 Revision 1.59 1999/11/30 10:40:51 peter
866 + ttype, tsymlist
867
868 Revision 1.58 1999/11/08 18:50:11 florian
869 * disposetree for classrefdef added
870
871 Revision 1.57 1999/11/08 16:24:28 pierre
872 * missing disposetree added to avoid memory loss
873
874 Revision 1.56 1999/11/08 14:02:16 florian
875 * problem with "index X"-properties solved
876 * typed constants of class references are now allowed
877
878 Revision 1.55 1999/11/06 14:34:23 peter
879 * truncated log to 20 revs
880
881 Revision 1.54 1999/10/14 14:57:54 florian
882 - removed the hcodegen use in the new cg, use cgbase instead
883
884 Revision 1.53 1999/09/26 21:30:20 peter
885 + constant pointer support which can happend with typecasting like
886 const p=pointer(1)
887 * better procvar parsing in typed consts
888
889 Revision 1.52 1999/08/10 12:30:02 pierre
890 * avoid unused locals
891
892 Revision 1.51 1999/08/04 13:03:02 jonas
893 * all tokens now start with an underscore
894 * PowerPC compiles!!
895
896 Revision 1.50 1999/08/04 00:23:21 florian
897 * renamed i386asm and i386base to cpuasm and cpubase
898
899 Revision 1.49 1999/08/03 22:03:08 peter
900 * moved bitmask constants to sets
901 * some other type/const renamings
902
903 Revision 1.48 1999/07/23 16:05:26 peter
904 * alignment is now saved in the symtable
905 * C alignment added for records
906 * PPU version increased to solve .12 <-> .13 probs
907
908 }
Mirror of AROS' Contrib svn.