← Back to branch summary

~ubuntu-branches/ubuntu/dapper/fpc/dapper

« back to all changes in this revision

Viewing changes to compiler/tcmem.pas

  • Committer: Bazaar Package Importer
  • Author(s): Carlos Laviola
  • Date: 2004-08-12 16:29:37 UTC
  • mfrom: (1.2.1 upstream) (2.1.1 warty)
  • Revision ID: james.westby@ubuntu.com-20040812162937-moo8ulvysp1ln771
Tags: 1.9.4-5
http://bugs.debian.org/265265
fp-compiler: needs ld, adding dependency on binutils.  (Closes: #265265)

Show diffs side-by-side

added added

removed removed

Lines of Context:
compiler/tcmem.pas
1
 
{
2
 
    $Id: tcmem.pas,v 1.1.2.3 2000/12/05 15:12:21 jonas Exp $
3
 
    Copyright (c) 1998-2000 by Florian Klaempfl
4
 
 
5
 
    Type checking and register allocation for memory related nodes
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 tcmem;
24
 
interface
25
 
 
26
 
    uses
27
 
      tree;
28
 
 
29
 
    procedure firstloadvmt(var p : ptree);
30
 
    procedure firsthnew(var p : ptree);
31
 
    procedure firstnew(var p : ptree);
32
 
    procedure firsthdispose(var p : ptree);
33
 
    procedure firstsimplenewdispose(var p : ptree);
34
 
    procedure firstaddr(var p : ptree);
35
 
    procedure firstdoubleaddr(var p : ptree);
36
 
    procedure firstderef(var p : ptree);
37
 
    procedure firstsubscript(var p : ptree);
38
 
    procedure firstvec(var p : ptree);
39
 
    procedure firstself(var p : ptree);
40
 
    procedure firstwith(var p : ptree);
41
 
 
42
 
 
43
 
implementation
44
 
 
45
 
    uses
46
 
      globtype,systems,
47
 
      cobjects,verbose,globals,
48
 
      symconst,symtable,aasm,types,
49
 
      htypechk,pass_1,cpubase
50
 
{$ifdef newcg}
51
 
      ,cgbase
52
 
{$else newcg}
53
 
      ,hcodegen
54
 
{$endif newcg}
55
 
      ;
56
 
{*****************************************************************************
57
 
                            FirstLoadVMT
58
 
*****************************************************************************}
59
 
 
60
 
    procedure firstloadvmt(var p : ptree);
61
 
      begin
62
 
         p^.registers32:=1;
63
 
         p^.location.loc:=LOC_REGISTER;
64
 
      end;
65
 
 
66
 
 
67
 
{*****************************************************************************
68
 
                             FirstHNew
69
 
*****************************************************************************}
70
 
 
71
 
    procedure firsthnew(var p : ptree);
72
 
      begin
73
 
      end;
74
 
 
75
 
 
76
 
{*****************************************************************************
77
 
                             FirstNewN
78
 
*****************************************************************************}
79
 
 
80
 
    procedure firstnew(var p : ptree);
81
 
      begin
82
 
         { Standardeinleitung }
83
 
         if assigned(p^.left) then
84
 
           firstpass(p^.left);
85
 
 
86
 
         if codegenerror then
87
 
           exit;
88
 
         if assigned(p^.left) then
89
 
           begin
90
 
              p^.registers32:=p^.left^.registers32;
91
 
              p^.registersfpu:=p^.left^.registersfpu;
92
 
{$ifdef SUPPORT_MMX}
93
 
              p^.registersmmx:=p^.left^.registersmmx;
94
 
{$endif SUPPORT_MMX}
95
 
           end;
96
 
         { result type is already set }
97
 
         procinfo^.flags:=procinfo^.flags or pi_do_call;
98
 
         if assigned(p^.left) then
99
 
           p^.location.loc:=LOC_REGISTER
100
 
         else
101
 
           p^.location.loc:=LOC_REFERENCE;
102
 
      end;
103
 
 
104
 
 
105
 
{*****************************************************************************
106
 
                            FirstDispose
107
 
*****************************************************************************}
108
 
 
109
 
    procedure firsthdispose(var p : ptree);
110
 
      begin
111
 
         firstpass(p^.left);
112
 
 
113
 
         if codegenerror then
114
 
           exit;
115
 
 
116
 
         p^.registers32:=p^.left^.registers32;
117
 
         p^.registersfpu:=p^.left^.registersfpu;
118
 
{$ifdef SUPPORT_MMX}
119
 
         p^.registersmmx:=p^.left^.registersmmx;
120
 
{$endif SUPPORT_MMX}
121
 
         if p^.registers32<1 then
122
 
           p^.registers32:=1;
123
 
         {
124
 
         if p^.left^.location.loc<>LOC_REFERENCE then
125
 
           CGMessage(cg_e_illegal_expression);
126
 
         }
127
 
         if p^.left^.location.loc=LOC_CREGISTER then
128
 
           inc(p^.registers32);
129
 
         p^.location.loc:=LOC_REFERENCE;
130
 
         p^.resulttype:=ppointerdef(p^.left^.resulttype)^.pointertype.def;
131
 
      end;
132
 
 
133
 
 
134
 
{*****************************************************************************
135
 
                        FirstSimpleNewDispose
136
 
*****************************************************************************}
137
 
 
138
 
    procedure firstsimplenewdispose(var p : ptree);
139
 
      begin
140
 
         { this cannot be in a register !! }
141
 
         make_not_regable(p^.left);
142
 
 
143
 
         firstpass(p^.left);
144
 
         if codegenerror then
145
 
          exit;
146
 
 
147
 
         { check the type }
148
 
         if p^.left^.resulttype=nil then
149
 
          p^.left^.resulttype:=generrordef;
150
 
         if (p^.left^.resulttype^.deftype<>pointerdef) then
151
 
           CGMessage1(type_e_pointer_type_expected,p^.left^.resulttype^.typename);
152
 
 
153
 
         if (p^.left^.location.loc<>LOC_REFERENCE) {and
154
 
            (p^.left^.location.loc<>LOC_CREGISTER)} then
155
 
           CGMessage(cg_e_illegal_expression);
156
 
 
157
 
         p^.registers32:=p^.left^.registers32;
158
 
         p^.registersfpu:=p^.left^.registersfpu;
159
 
{$ifdef SUPPORT_MMX}
160
 
         p^.registersmmx:=p^.left^.registersmmx;
161
 
{$endif SUPPORT_MMX}
162
 
         p^.resulttype:=voiddef;
163
 
         procinfo^.flags:=procinfo^.flags or pi_do_call;
164
 
      end;
165
 
 
166
 
 
167
 
{*****************************************************************************
168
 
                             FirstAddr
169
 
*****************************************************************************}
170
 
 
171
 
    procedure firstaddr(var p : ptree);
172
 
      var
173
 
         hp  : ptree;
174
 
         hp2 : pparaitem;
175
 
         hp3 : pabstractprocdef;
176
 
      begin
177
 
         make_not_regable(p^.left);
178
 
         if not(assigned(p^.resulttype)) then
179
 
           begin
180
 
              { tp @procvar support (type of @procvar is a void pointer)
181
 
                Note: we need to leave the addrn in the tree,
182
 
                else we can't see the difference between @procvar and procvar.
183
 
                we set the procvarload flag so a secondpass does nothing for
184
 
                this node (PFV) }
185
 
              if (m_tp_procvar in aktmodeswitches) then
186
 
               begin
187
 
                 hp:=p^.left;
188
 
                 case hp^.treetype of
189
 
                   calln :
190
 
                     begin
191
 
                       { is it a procvar? }
192
 
                       hp:=hp^.right;
193
 
                       if assigned(hp) then
194
 
                         begin
195
 
                           { remove calln node }
196
 
                           putnode(p^.left);
197
 
                           { first do firstpass, then assignment in case hp }
198
 
                           { gets changed by firstpass (JM)                 }
199
 
                           firstpass(hp);
200
 
                           p^.left:=hp;
201
 
                           p^.procvarload:=true;
202
 
                         end;
203
 
                     end;
204
 
                   loadn,
205
 
                   subscriptn,
206
 
                   typeconvn,
207
 
                   vecn,
208
 
                   derefn :
209
 
                     begin
210
 
                       firstpass(hp);
211
 
                       { in case hp gets changed by firstpass (JM) }
212
 
                       p^.left := hp;
213
 
                       if codegenerror then
214
 
                        exit;
215
 
                       if hp^.resulttype^.deftype=procvardef then
216
 
                        begin
217
 
                          p^.procvarload:=true;
218
 
                        end;
219
 
                     end;
220
 
                 end;
221
 
               end;
222
 
              if p^.procvarload then
223
 
               begin
224
 
                 p^.registers32:=p^.left^.registers32;
225
 
                 p^.registersfpu:=p^.left^.registersfpu;
226
 
{$ifdef SUPPORT_MMX}
227
 
                 p^.registersmmx:=p^.left^.registersmmx;
228
 
{$endif SUPPORT_MMX}
229
 
                 if p^.registers32<1 then
230
 
                   p^.registers32:=1;
231
 
                 p^.location.loc:=p^.left^.location.loc;
232
 
                 p^.resulttype:=voidpointerdef;
233
 
                 exit;
234
 
               end;
235
 
 
236
 
              { proc 2 procvar ? }
237
 
              if p^.left^.treetype=calln then
238
 
                begin
239
 
                  { generate a methodcallnode or proccallnode }
240
 
                  { we shouldn't convert things like @tcollection.load }
241
 
                  if (p^.left^.symtableprocentry^.owner^.symtabletype=objectsymtable) and
242
 
                    not(assigned(p^.left^.methodpointer) and (p^.left^.methodpointer^.treetype=typen)) then
243
 
                   begin
244
 
                     hp:=genloadmethodcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc,
245
 
                       getcopy(p^.left^.methodpointer));
246
 
                     disposetree(p);
247
 
                     firstpass(hp);
248
 
                     p:=hp;
249
 
                     exit;
250
 
                   end
251
 
                  else
252
 
                   hp:=genloadcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc);
253
 
 
254
 
                  { result is a procedure variable }
255
 
                  { No, to be TP compatible, you must return a pointer to
256
 
                    the procedure that is stored in the procvar.}
257
 
                  if not(m_tp_procvar in aktmodeswitches) then
258
 
                    begin
259
 
                       p^.resulttype:=new(pprocvardef,init);
260
 
 
261
 
                    { it could also be a procvar, not only pprocsym ! }
262
 
                       if p^.left^.symtableprocentry^.typ=varsym then
263
 
                        hp3:=pabstractprocdef(pvarsym(p^.left^.symtableentry)^.vartype.def)
264
 
                       else
265
 
                        hp3:=pabstractprocdef(pprocsym(p^.left^.symtableprocentry)^.definition);
266
 
 
267
 
                       pprocvardef(p^.resulttype)^.proctypeoption:=hp3^.proctypeoption;
268
 
                       pprocvardef(p^.resulttype)^.proccalloptions:=hp3^.proccalloptions;
269
 
                       pprocvardef(p^.resulttype)^.procoptions:=hp3^.procoptions;
270
 
                       pprocvardef(p^.resulttype)^.rettype:=hp3^.rettype;
271
 
                       pprocvardef(p^.resulttype)^.symtablelevel:=hp3^.symtablelevel;
272
 
 
273
 
                     { method ? then set the methodpointer flag }
274
 
                       if (hp3^.owner^.symtabletype=objectsymtable) and
275
 
                          (pobjectdef(hp3^.owner^.defowner)^.is_class) then
276
 
{$ifdef INCLUDEOK}
277
 
                         include(pprocvardef(p^.resulttype)^.procoptions,po_methodpointer);
278
 
{$else}
279
 
                         pprocvardef(p^.resulttype)^.procoptions:=pprocvardef(p^.resulttype)^.procoptions+[po_methodpointer];
280
 
{$endif}
281
 
                       { we need to process the parameters reverse so they are inserted
282
 
                         in the correct right2left order (PFV) }
283
 
                       hp2:=pparaitem(hp3^.para^.last);
284
 
                       while assigned(hp2) do
285
 
                         begin
286
 
                            pprocvardef(p^.resulttype)^.concatpara(hp2^.paratype,hp2^.paratyp);
287
 
                            hp2:=pparaitem(hp2^.previous);
288
 
                         end;
289
 
                    end
290
 
                  else
291
 
                    p^.resulttype:=voidpointerdef;
292
 
 
293
 
                  disposetree(p^.left);
294
 
                  p^.left:=hp;
295
 
                end
296
 
              else
297
 
                begin
298
 
                  firstpass(p^.left);
299
 
                  { what are we getting the address from an absolute sym? }
300
 
                  hp:=p^.left;
301
 
                  while assigned(hp) and (hp^.treetype in [vecn,derefn,subscriptn]) do
302
 
                   hp:=hp^.left;
303
 
                  if assigned(hp) and (hp^.treetype=loadn) and
304
 
                     ((hp^.symtableentry^.typ=absolutesym) and
305
 
                      pabsolutesym(hp^.symtableentry)^.absseg) then
306
 
                   begin
307
 
                     if not(cs_typed_addresses in aktlocalswitches) then
308
 
                       p^.resulttype:=voidfarpointerdef
309
 
                     else
310
 
                       p^.resulttype:=new(ppointerdef,initfardef(p^.left^.resulttype));
311
 
                   end
312
 
                  else
313
 
                   begin
314
 
                     if not(cs_typed_addresses in aktlocalswitches) then
315
 
                       p^.resulttype:=voidpointerdef
316
 
                     else
317
 
                       p^.resulttype:=new(ppointerdef,initdef(p^.left^.resulttype));
318
 
                   end;
319
 
                end;
320
 
           end;
321
 
         firstpass(p^.left);
322
 
         { this is like the function addr }
323
 
         inc(parsing_para_level);
324
 
         set_varstate(p^.left,false);
325
 
         dec(parsing_para_level);
326
 
         if codegenerror then
327
 
           exit;
328
 
 
329
 
         { don't allow constants }
330
 
         if is_constnode(p^.left) then
331
 
          begin
332
 
            aktfilepos:=p^.left^.fileinfo;
333
 
            CGMessage(type_e_no_addr_of_constant);
334
 
          end
335
 
         else
336
 
           begin
337
 
             { we should allow loc_mem for @string }
338
 
             if not(p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
339
 
               begin
340
 
                 aktfilepos:=p^.left^.fileinfo;
341
 
                 CGMessage(cg_e_illegal_expression);
342
 
               end;
343
 
           end;
344
 
 
345
 
         p^.registers32:=p^.left^.registers32;
346
 
         p^.registersfpu:=p^.left^.registersfpu;
347
 
{$ifdef SUPPORT_MMX}
348
 
         p^.registersmmx:=p^.left^.registersmmx;
349
 
{$endif SUPPORT_MMX}
350
 
         if p^.registers32<1 then
351
 
           p^.registers32:=1;
352
 
         { is this right for object of methods ?? }
353
 
         p^.location.loc:=LOC_REGISTER;
354
 
      end;
355
 
 
356
 
 
357
 
{*****************************************************************************
358
 
                           FirstDoubleAddr
359
 
*****************************************************************************}
360
 
 
361
 
    procedure firstdoubleaddr(var p : ptree);
362
 
      begin
363
 
         make_not_regable(p^.left);
364
 
         firstpass(p^.left);
365
 
         inc(parsing_para_level);
366
 
         set_varstate(p^.left,false);
367
 
         dec(parsing_para_level);
368
 
         if p^.resulttype=nil then
369
 
           p^.resulttype:=voidpointerdef;
370
 
         if codegenerror then
371
 
           exit;
372
 
 
373
 
         if (p^.left^.resulttype^.deftype)<>procvardef then
374
 
           CGMessage(cg_e_illegal_expression);
375
 
 
376
 
         if (p^.left^.location.loc<>LOC_REFERENCE) then
377
 
           CGMessage(cg_e_illegal_expression);
378
 
 
379
 
         p^.registers32:=p^.left^.registers32;
380
 
         p^.registersfpu:=p^.left^.registersfpu;
381
 
{$ifdef SUPPORT_MMX}
382
 
         p^.registersmmx:=p^.left^.registersmmx;
383
 
{$endif SUPPORT_MMX}
384
 
         if p^.registers32<1 then
385
 
           p^.registers32:=1;
386
 
         p^.location.loc:=LOC_REGISTER;
387
 
      end;
388
 
 
389
 
 
390
 
{*****************************************************************************
391
 
                             FirstDeRef
392
 
*****************************************************************************}
393
 
 
394
 
    procedure firstderef(var p : ptree);
395
 
      begin
396
 
         firstpass(p^.left);
397
 
         set_varstate(p^.left,true);
398
 
         if codegenerror then
399
 
           begin
400
 
             p^.resulttype:=generrordef;
401
 
             exit;
402
 
           end;
403
 
 
404
 
         p^.registers32:=max(p^.left^.registers32,1);
405
 
         p^.registersfpu:=p^.left^.registersfpu;
406
 
{$ifdef SUPPORT_MMX}
407
 
         p^.registersmmx:=p^.left^.registersmmx;
408
 
{$endif SUPPORT_MMX}
409
 
 
410
 
         if p^.left^.resulttype^.deftype<>pointerdef then
411
 
          CGMessage(cg_e_invalid_qualifier);
412
 
 
413
 
         p^.resulttype:=ppointerdef(p^.left^.resulttype)^.pointertype.def;
414
 
         p^.location.loc:=LOC_REFERENCE;
415
 
      end;
416
 
 
417
 
 
418
 
{*****************************************************************************
419
 
                            FirstSubScript
420
 
*****************************************************************************}
421
 
 
422
 
    procedure firstsubscript(var p : ptree);
423
 
      begin
424
 
         firstpass(p^.left);
425
 
         if codegenerror then
426
 
           begin
427
 
             p^.resulttype:=generrordef;
428
 
             exit;
429
 
           end;
430
 
         p^.resulttype:=p^.vs^.vartype.def;
431
 
 
432
 
         p^.registers32:=p^.left^.registers32;
433
 
         p^.registersfpu:=p^.left^.registersfpu;
434
 
{$ifdef SUPPORT_MMX}
435
 
         p^.registersmmx:=p^.left^.registersmmx;
436
 
{$endif SUPPORT_MMX}
437
 
         { classes must be dereferenced implicit }
438
 
         if (p^.left^.resulttype^.deftype=objectdef) and
439
 
           pobjectdef(p^.left^.resulttype)^.is_class then
440
 
           begin
441
 
              if p^.registers32=0 then
442
 
                p^.registers32:=1;
443
 
              p^.location.loc:=LOC_REFERENCE;
444
 
           end
445
 
         else
446
 
           begin
447
 
              if (p^.left^.location.loc<>LOC_MEM) and
448
 
                (p^.left^.location.loc<>LOC_REFERENCE) then
449
 
                CGMessage(cg_e_illegal_expression);
450
 
              set_location(p^.location,p^.left^.location);
451
 
           end;
452
 
      end;
453
 
 
454
 
 
455
 
{*****************************************************************************
456
 
                               FirstVec
457
 
*****************************************************************************}
458
 
 
459
 
    procedure firstvec(var p : ptree);
460
 
      var
461
 
         harr : pdef;
462
 
         ct : tconverttype;
463
 
{$ifdef consteval}
464
 
         tcsym : ptypedconstsym;
465
 
{$endif}
466
 
      begin
467
 
         firstpass(p^.left);
468
 
         firstpass(p^.right);
469
 
         if codegenerror then
470
 
           exit;
471
 
 
472
 
         { range check only for arrays }
473
 
         if (p^.left^.resulttype^.deftype=arraydef) then
474
 
           begin
475
 
              if (isconvertable(p^.right^.resulttype,parraydef(p^.left^.resulttype)^.rangetype.def,
476
 
                    ct,ordconstn,false)=0) and
477
 
                 not(is_equal(p^.right^.resulttype,parraydef(p^.left^.resulttype)^.rangetype.def)) then
478
 
                CGMessage(type_e_mismatch);
479
 
           end;
480
 
         { Never convert a boolean or a char !}
481
 
         { maybe type conversion }
482
 
         if (p^.right^.resulttype^.deftype<>enumdef) and
483
 
            not(is_char(p^.right^.resulttype)) and
484
 
            not(is_boolean(p^.right^.resulttype)) then
485
 
           begin
486
 
             p^.right:=gentypeconvnode(p^.right,s32bitdef);
487
 
             firstpass(p^.right);
488
 
             if codegenerror then
489
 
              exit;
490
 
           end;
491
 
 
492
 
         { are we accessing a pointer[], then convert the pointer to
493
 
           an array first, in FPC this is allowed for all pointers in
494
 
           delphi/tp7 it's only allowed for pchars }
495
 
         if (p^.left^.resulttype^.deftype=pointerdef) and
496
 
            ((m_fpc in aktmodeswitches) or
497
 
             is_pchar(p^.left^.resulttype)) then
498
 
          begin
499
 
            { convert pointer to array }
500
 
            harr:=new(parraydef,init(0,$7fffffff,s32bitdef));
501
 
            parraydef(harr)^.elementtype.def:=ppointerdef(p^.left^.resulttype)^.pointertype.def;
502
 
            p^.left:=gentypeconvnode(p^.left,harr);
503
 
            firstpass(p^.left);
504
 
            if codegenerror then
505
 
             exit;
506
 
            p^.resulttype:=parraydef(harr)^.elementtype.def
507
 
          end;
508
 
 
509
 
         { determine return type }
510
 
         if not assigned(p^.resulttype) then
511
 
           if p^.left^.resulttype^.deftype=arraydef then
512
 
             p^.resulttype:=parraydef(p^.left^.resulttype)^.elementtype.def
513
 
           else if p^.left^.resulttype^.deftype=stringdef then
514
 
             begin
515
 
                { indexed access to strings }
516
 
                case pstringdef(p^.left^.resulttype)^.string_typ of
517
 
                   {
518
 
                   st_widestring : p^.resulttype:=cwchardef;
519
 
                   }
520
 
                   st_ansistring : p^.resulttype:=cchardef;
521
 
                   st_longstring : p^.resulttype:=cchardef;
522
 
                   st_shortstring : p^.resulttype:=cchardef;
523
 
                end;
524
 
             end
525
 
           else
526
 
             CGMessage(type_e_array_required);
527
 
 
528
 
         { the register calculation is easy if a const index is used }
529
 
         if p^.right^.treetype=ordconstn then
530
 
           begin
531
 
{$ifdef consteval}
532
 
              { constant evaluation }
533
 
              if (p^.left^.treetype=loadn) and
534
 
                 (p^.left^.symtableentry^.typ=typedconstsym) then
535
 
               begin
536
 
                 tcsym:=ptypedconstsym(p^.left^.symtableentry);
537
 
                 if tcsym^.defintion^.typ=stringdef then
538
 
                  begin
539
 
 
540
 
                  end;
541
 
               end;
542
 
{$endif}
543
 
              p^.registers32:=p^.left^.registers32;
544
 
 
545
 
              { for ansi/wide strings, we need at least one register }
546
 
              if is_ansistring(p^.left^.resulttype) or
547
 
                is_widestring(p^.left^.resulttype) then
548
 
                p^.registers32:=max(p^.registers32,1);
549
 
           end
550
 
         else
551
 
           begin
552
 
              { this rules are suboptimal, but they should give }
553
 
              { good results                                }
554
 
              p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
555
 
 
556
 
              { for ansi/wide strings, we need at least one register }
557
 
              if is_ansistring(p^.left^.resulttype) or
558
 
                is_widestring(p^.left^.resulttype) then
559
 
                p^.registers32:=max(p^.registers32,1);
560
 
 
561
 
              { need we an extra register when doing the restore ? }
562
 
              if (p^.left^.registers32<=p^.right^.registers32) and
563
 
              { only if the node needs less than 3 registers }
564
 
              { two for the right node and one for the       }
565
 
              { left address                             }
566
 
                (p^.registers32<3) then
567
 
                inc(p^.registers32);
568
 
 
569
 
              { need we an extra register for the index ? }
570
 
              if (p^.right^.location.loc<>LOC_REGISTER)
571
 
              { only if the right node doesn't need a register }
572
 
                and (p^.right^.registers32<1) then
573
 
                inc(p^.registers32);
574
 
 
575
 
              { not correct, but what works better ?
576
 
              if p^.left^.registers32>0 then
577
 
                p^.registers32:=max(p^.registers32,2)
578
 
              else
579
 
                 min. one register
580
 
                p^.registers32:=max(p^.registers32,1);
581
 
              }
582
 
           end;
583
 
         p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
584
 
{$ifdef SUPPORT_MMX}
585
 
         p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
586
 
{$endif SUPPORT_MMX}
587
 
         if p^.left^.location.loc in [LOC_CREGISTER,LOC_REFERENCE] then
588
 
           p^.location.loc:=LOC_REFERENCE
589
 
         else
590
 
           p^.location.loc:=LOC_MEM;
591
 
      end;
592
 
 
593
 
 
594
 
{*****************************************************************************
595
 
                               FirstSelf
596
 
*****************************************************************************}
597
 
 
598
 
    procedure firstself(var p : ptree);
599
 
      begin
600
 
         if (p^.resulttype^.deftype=classrefdef) or
601
 
           ((p^.resulttype^.deftype=objectdef)
602
 
             and pobjectdef(p^.resulttype)^.is_class
603
 
           ) then
604
 
           p^.location.loc:=LOC_CREGISTER
605
 
         else
606
 
           p^.location.loc:=LOC_REFERENCE;
607
 
      end;
608
 
 
609
 
 
610
 
{*****************************************************************************
611
 
                               FirstWithN
612
 
*****************************************************************************}
613
 
 
614
 
    procedure firstwith(var p : ptree);
615
 
      var
616
 
         symtable : pwithsymtable;
617
 
         i : longint;
618
 
      begin
619
 
         if assigned(p^.left) and assigned(p^.right) then
620
 
            begin
621
 
               firstpass(p^.left);
622
 
               unset_varstate(p^.left);
623
 
               set_varstate(p^.left,true);
624
 
               if codegenerror then
625
 
                 exit;
626
 
               symtable:=p^.withsymtable;
627
 
               for i:=1 to p^.tablecount do
628
 
                 begin
629
 
                    if (p^.left^.treetype=loadn) and
630
 
                       (p^.left^.symtable=aktprocsym^.definition^.localst) then
631
 
                      symtable^.direct_with:=true;
632
 
                    symtable^.withnode:=p;
633
 
                    symtable:=pwithsymtable(symtable^.next);
634
 
                  end;
635
 
               firstpass(p^.right);
636
 
               if codegenerror then
637
 
                 exit;
638
 
 
639
 
               left_right_max(p);
640
 
               p^.resulttype:=voiddef;
641
 
            end
642
 
         else
643
 
           begin
644
 
              { optimization }
645
 
              disposetree(p);
646
 
              p:=nil;
647
 
           end;
648
 
      end;
649
 
 
650
 
 
651
 
end.
652
 
{
653
 
  $Log: tcmem.pas,v $
654
 
  Revision 1.1.2.3  2000/12/05 15:12:21  jonas
655
 
    * fixed webbug 1268
656
 
 
657
 
  Revision 1.1.2.2  2000/08/20 15:03:54  peter
658
 
    * don't allow pointer indexing in non-fpc modes
659
 
    * array type required message instead of type mismatch
660
 
 
661
 
  Revision 1.1.2.1  2000/08/02 19:37:52  peter
662
 
    * unset_varstate function to reset varstateset variable, fixes bug 1034
663
 
 
664
 
  Revision 1.1  2000/07/13 06:30:00  michael
665
 
  + Initial import
666
 
 
667
 
  Revision 1.45  2000/04/08 09:30:01  peter
668
 
     * fixed pointer->array conversion when resulttype was already set
669
 
 
670
 
  Revision 1.44  2000/03/23 16:29:32  jonas
671
 
    * real fix for web bug882
672
 
 
673
 
  Revision 1.43  2000/03/22 15:41:10  jonas
674
 
    * fixed webbug 882
675
 
 
676
 
  Revision 1.42  2000/02/17 14:53:43  florian
677
 
    * some updates for the newcg
678
 
 
679
 
  Revision 1.41  2000/02/09 13:23:08  peter
680
 
    * log truncated
681
 
 
682
 
  Revision 1.40  2000/01/10 16:38:43  pierre
683
 
   * suppress wrong warning for with vars
684
 
 
685
 
  Revision 1.39  2000/01/10 00:42:44  pierre
686
 
   * fix for bug 776
687
 
 
688
 
  Revision 1.38  2000/01/07 09:36:24  pierre
689
 
   * With argument is set as used to avoid unnecessary warnings
690
 
 
691
 
  Revision 1.37  2000/01/07 01:14:46  peter
692
 
    * updated copyright to 2000
693
 
 
694
 
  Revision 1.36  1999/11/30 10:40:58  peter
695
 
    + ttype, tsymlist
696
 
 
697
 
  Revision 1.35  1999/11/29 22:36:48  florian
698
 
    * problem with taking the address of abstract procedures fixed
699
 
 
700
 
  Revision 1.34  1999/11/18 15:34:51  pierre
701
 
    * Notes/Hints for local syms changed to
702
 
      Set_varstate function
703
 
 
704
 
  Revision 1.33  1999/11/17 17:05:07  pierre
705
 
   * Notes/hints changes
706
 
 
707
 
  Revision 1.32  1999/11/06 14:34:30  peter
708
 
    * truncated log to 20 revs
709
 
 
710
 
  Revision 1.31  1999/10/26 12:30:46  peter
711
 
    * const parameter is now checked
712
 
    * better and generic check if a node can be used for assigning
713
 
    * export fixes
714
 
    * procvar equal works now (it never had worked at least from 0.99.8)
715
 
    * defcoll changed to linkedlist with pparaitem so it can easily be
716
 
      walked both directions
717
 
 
718
 
  Revision 1.30  1999/10/13 10:40:55  peter
719
 
    * subscript support for tp_procvar
720
 
 
721
 
  Revision 1.29  1999/09/27 23:45:02  peter
722
 
    * procinfo is now a pointer
723
 
    * support for result setting in sub procedure
724
 
 
725
 
  Revision 1.28  1999/09/17 17:14:12  peter
726
 
    * @procvar fixes for tp mode
727
 
    * @<id>:= gives now an error
728
 
 
729
 
  Revision 1.27  1999/09/11 11:10:39  florian
730
 
    * fix of my previous commit, make cycle was broken
731
 
 
732
 
  Revision 1.26  1999/09/11 09:08:34  florian
733
 
    * fixed bug 596
734
 
    * fixed some problems with procedure variables and procedures of object,
735
 
      especially in TP mode. Procedure of object doesn't apply only to classes,
736
 
      it is also allowed for objects !!
737
 
 
738
 
  Revision 1.25  1999/08/23 23:34:15  pierre
739
 
   * one more register needed if hnewn with CREGISTER
740
 
 
741
 
  Revision 1.24  1999/08/05 16:53:25  peter
742
 
    * V_Fatal=1, all other V_ are also increased
743
 
    * Check for local procedure when assigning procvar
744
 
    * fixed comment parsing because directives
745
 
    * oldtp mode directives better supported
746
 
    * added some messages to errore.msg
747
 
 
748
 
  Revision 1.23  1999/08/04 00:23:44  florian
749
 
    * renamed i386asm and i386base to cpuasm and cpubase
750
 
 
751
 
  Revision 1.22  1999/08/03 22:03:35  peter
752
 
    * moved bitmask constants to sets
753
 
    * some other type/const renamings
754
 
 
755
 
}