← Back to branch summary

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

« back to all changes in this revision

Viewing changes to rtl/inc/dynarr.inc

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

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

Show diffs side-by-side

added added

removed removed

Lines of Context:
rtl/inc/dynarr.inc
1
 
{
2
 
    $Id: dynarr.inc,v 1.26 2004/05/24 07:18:17 michael Exp $
3
 
    This file is part of the Free Pascal run time library.
4
 
    Copyright (c) 2000 by Florian Klaempfl
5
 
    member of the Free Pascal development team.
6
 
 
7
 
    This file implements the helper routines for dyn. Arrays in FPC
8
 
 
9
 
    See the file COPYING.FPC, included in this distribution,
10
 
    for details about the copyright.
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.
15
 
 
16
 
 **********************************************************************
17
 
}
18
 
 
19
 
type
20
 
   { don't add new fields, the size is used }
21
 
   { to calculate memory requirements       }
22
 
   pdynarray = ^tdynarray;
23
 
   tdynarray = packed record
24
 
      refcount : longint;
25
 
      high : tdynarrayindex;
26
 
   end;
27
 
 
28
 
   pdynarraytypeinfo = ^tdynarraytypeinfo;
29
 
   tdynarraytypeinfo = packed record
30
 
      kind : byte;
31
 
      namelen : byte;
32
 
      { here the chars follow, we've to skip them }
33
 
      elesize : t_size;
34
 
      eletype : pdynarraytypeinfo;
35
 
   end;
36
 
 
37
 
 
38
 
function fpc_dynarray_rangecheck(p : pointer;i : tdynarrayindex) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_RANGECHECK']; {$ifdef hascompilerproc} compilerproc; {$endif}
39
 
  begin
40
 
     if not(assigned(p)) or (i<0) or (i>pdynarray(p-sizeof(tdynarray))^.high) then
41
 
       HandleErrorFrame(201,get_frame);
42
 
  end;
43
 
 
44
 
 
45
 
function fpc_dynarray_length(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_LENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
46
 
  begin
47
 
     if assigned(p) then
48
 
       fpc_dynarray_length:=pdynarray(p-sizeof(tdynarray))^.high+1
49
 
     else
50
 
       fpc_dynarray_length:=0;
51
 
  end;
52
 
 
53
 
 
54
 
function fpc_dynarray_high(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_HIGH']; {$ifdef hascompilerproc} compilerproc; {$endif}
55
 
  begin
56
 
     if assigned(p) then
57
 
       fpc_dynarray_high:=pdynarray(p-sizeof(tdynarray))^.high
58
 
     else
59
 
       fpc_dynarray_high:=-1;
60
 
  end;
61
 
 
62
 
 
63
 
{ releases and finalizes the data of a dyn. array and sets p to nil }
64
 
procedure fpc_dynarray_clear_internal(p : pointer;ti : pointer);
65
 
  begin
66
 
     if p=nil then
67
 
       exit;
68
 
 
69
 
     { skip kind and name }
70
 
     inc(pointer(ti),ord(pdynarraytypeinfo(ti)^.namelen));
71
 
 
72
 
     { finalize all data }
73
 
     int_finalizearray(p+sizeof(tdynarray),pdynarraytypeinfo(ti)^.eletype,pdynarray(p)^.high+1,
74
 
                       pdynarraytypeinfo(ti)^.elesize);
75
 
 
76
 
     { release the data }
77
 
     freemem(p);
78
 
  end;
79
 
 
80
 
 
81
 
procedure fpc_dynarray_clear(var p : pointer;ti : pointer); [Public,Alias:'FPC_DYNARRAY_CLEAR']; {$ifdef hascompilerproc} compilerproc; {$endif}
82
 
  begin
83
 
    if (P=Nil) then 
84
 
      exit;
85
 
    fpc_dynarray_clear_internal(p-sizeof(tdynarray),ti);
86
 
    p:=nil;
87
 
  end;
88
 
 
89
 
{$ifdef hascompilerproc}
90
 
{ alias for internal use }
91
 
Procedure fpc_dynarray_clear (var p : pointer;ti : pointer);[external name 'FPC_DYNARRAY_CLEAR'];
92
 
{$endif hascompilerproc}
93
 
 
94
 
 
95
 
procedure fpc_dynarray_decr_ref(var p : pointer;ti : pointer);saveregisters;[Public,Alias:'FPC_DYNARRAY_DECR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
96
 
  var
97
 
     realp : pdynarray;
98
 
  begin
99
 
     if p=nil then
100
 
       exit;
101
 
 
102
 
     realp:=pdynarray(p-sizeof(tdynarray));
103
 
     if realp^.refcount=0 then
104
 
       HandleErrorFrame(204,get_frame);
105
 
 
106
 
     { decr. ref. count }
107
 
     { should we remove the array? }
108
 
     if declocked(realp^.refcount) then
109
 
       fpc_dynarray_clear_internal(realp,pdynarraytypeinfo(ti));
110
 
     p := nil;
111
 
  end;
112
 
 
113
 
{$ifdef hascompilerproc}
114
 
{ provide local access to dynarr_decr_ref for dynarr_setlength }
115
 
procedure fpc_dynarray_decr_ref(var p : pointer;ti : pointer);saveregisters; [external name 'FPC_DYNARRAY_DECR_REF'];
116
 
{$endif}
117
 
 
118
 
procedure fpc_dynarray_incr_ref(p : pointer);saveregisters;[Public,Alias:'FPC_DYNARRAY_INCR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
119
 
  var
120
 
     realp : pdynarray;
121
 
  begin
122
 
     if p=nil then
123
 
       exit;
124
 
 
125
 
     realp:=pdynarray(p-sizeof(tdynarray));
126
 
     if realp^.refcount=0 then
127
 
       HandleErrorFrame(204,get_frame);
128
 
 
129
 
     inclocked(realp^.refcount);
130
 
  end;
131
 
 
132
 
{$ifdef hascompilerproc}
133
 
{ provide local access to dynarr_decr_ref for dynarr_setlength }
134
 
procedure fpc_dynarray_incr_ref(p : pointer);saveregisters; [external name 'FPC_DYNARRAY_INCR_REF'];
135
 
{$endif}
136
 
 
137
 
{ provide local access to dynarr_setlength }
138
 
procedure int_dynarray_setlength(var p : pointer;pti : pointer;
139
 
  dimcount : dword;dims : pdynarrayindex);[external name 'FPC_DYNARR_SETLENGTH'];
140
 
 
141
 
procedure fpc_dynarray_setlength(var p : pointer;pti : pointer;
142
 
  dimcount : dword;dims : pdynarrayindex);[Public,Alias:'FPC_DYNARR_SETLENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
143
 
 
144
 
  var
145
 
     movelen: cardinal;
146
 
     i : tdynarrayindex;
147
 
     size : t_size;
148
 
     { contains the "fixed" pointers where the refcount }
149
 
     { and high are at positive offsets                 }
150
 
     realp,newp : pdynarray;
151
 
     ti : pdynarraytypeinfo;
152
 
     updatep: boolean;
153
 
 
154
 
  begin
155
 
     ti:=pdynarraytypeinfo(pti);
156
 
     { skip kind and name }
157
 
     inc(pointer(ti),ord(ti^.namelen));
158
 
 
159
 
     { determine new memory size }
160
 
     { dims[dimcount-1] because the dimensions are in reverse order! (JM) }
161
 
     size:=ti^.elesize*dims[dimcount-1]+sizeof(tdynarray);
162
 
     updatep := false;
163
 
 
164
 
     { not assigned yet? }
165
 
     if not(assigned(p)) then
166
 
       begin
167
 
          { do we have to allocate memory? }
168
 
          if dims[dimcount-1] = 0 then
169
 
            exit;
170
 
          getmem(newp,size);
171
 
          fillchar(newp^,size,0);
172
 
          updatep := true;
173
 
       end
174
 
     else
175
 
       begin
176
 
          realp:=pdynarray(p-sizeof(tdynarray));
177
 
 
178
 
          if dims[dimcount-1]<0 then
179
 
            HandleErrorFrame(201,get_frame);
180
 
 
181
 
          { if the new dimension is 0, we've to release all data }
182
 
          if dims[dimcount-1]=0 then
183
 
            begin
184
 
               fpc_dynarray_clear_internal(realp,pdynarraytypeinfo(pti));
185
 
               p:=nil;
186
 
               exit;
187
 
            end;
188
 
 
189
 
          if realp^.refcount<>1 then
190
 
            begin
191
 
               updatep := true;
192
 
               { make an unique copy }
193
 
               getmem(newp,size);
194
 
               fillchar(newp^,size,0);
195
 
               if realp^.high < dims[dimcount-1] then
196
 
                 movelen := realp^.high+1
197
 
               else
198
 
                 movelen := dims[dimcount-1];
199
 
               move(p^,(pointer(newp)+sizeof(tdynarray))^,ti^.elesize*movelen);
200
 
 
201
 
               { increment ref. count of members }
202
 
               for i:= 0 to movelen-1 do
203
 
                 int_addref(pointer(newp)+sizeof(tdynarray)+ti^.elesize*i,ti^.eletype);
204
 
 
205
 
               { a declock(ref. count) isn't enough here }
206
 
               { it could be that the in MT enviroments  }
207
 
               { in the mean time the refcount was       }
208
 
               { decremented                             }
209
 
 
210
 
               { it is, because it doesn't really matter }
211
 
               { if the array is now removed             }
212
 
               { fpc_dynarray_decr_ref(p,ti); }
213
 
               if declocked(realp^.refcount) then
214
 
                 fpc_dynarray_clear_internal(realp,pdynarraytypeinfo(ti));
215
 
            end
216
 
          else if dims[dimcount-1]<>realp^.high+1 then
217
 
            begin
218
 
 
219
 
               { range checking is quite difficult ...  }
220
 
               { if size overflows then it is less than }
221
 
               { the values it was calculated from      }
222
 
               if (size<sizeof(tdynarray)) or
223
 
                 ((ti^.elesize>0) and (size<ti^.elesize)) then
224
 
                 HandleErrorFrame(201,get_frame);
225
 
 
226
 
               { resize? }
227
 
               { here, realp^.refcount has to be one, otherwise the previous }
228
 
               { if-statement would have been taken. Or is this also for MT  }
229
 
               { code? (JM)                                                  }
230
 
               if realp^.refcount=1 then
231
 
                 begin
232
 
                    { shrink the array? }
233
 
                    if dims[dimcount-1]<realp^.high+1 then
234
 
                      begin
235
 
                          int_finalizearray(pointer(realp)+sizeof(tdynarray)+
236
 
                            ti^.elesize*dims[dimcount-1],
237
 
                            ti^.eletype,realp^.high-dims[dimcount-1]+1,ti^.elesize);
238
 
                         reallocmem(realp,size);
239
 
                      end
240
 
                    else if dims[dimcount-1]>realp^.high+1 then
241
 
                      begin
242
 
                         reallocmem(realp,size);
243
 
                         fillchar((pointer(realp)+sizeof(tdynarray)+ti^.elesize*(realp^.high+1))^,
244
 
                           (dims[dimcount-1]-realp^.high-1)*ti^.elesize,0);
245
 
                      end;
246
 
                    newp := realp;
247
 
                    updatep := true;
248
 
                 end;
249
 
            end;
250
 
       end;
251
 
    { handle nested arrays }
252
 
    if dimcount>1 then
253
 
      begin
254
 
         for i:=0 to dims[dimcount-1]-1 do
255
 
           int_dynarray_setlength(pointer((pointer(newp)+sizeof(tdynarray)+i*ti^.elesize)^),
256
 
             ti^.eletype,dimcount-1,dims);
257
 
      end;
258
 
     if updatep then
259
 
       begin
260
 
         p:=pointer(newp)+sizeof(tdynarray);
261
 
         newp^.refcount:=1;
262
 
         newp^.high:=dims[dimcount-1]-1;
263
 
       end;
264
 
  end;
265
 
 
266
 
 
267
 
{ provide local access to dynarr_copy }
268
 
procedure int_dynarray_copy(var pdest : pointer;psrc : pointer;ti : pointer;
269
 
    lowidx,count:tdynarrayindex);[external name 'FPC_DYNARR_COPY'];
270
 
 
271
 
procedure fpc_dynarray_copy(var pdest : pointer;psrc : pointer;ti : pointer;
272
 
    lowidx,count:tdynarrayindex);[Public,Alias:'FPC_DYNARR_COPY'];{$ifdef hascompilerproc} compilerproc; {$endif}
273
 
  var
274
 
    realpdest,
275
 
    realpsrc : pdynarray;
276
 
    cnt,
277
 
    i,size : longint;
278
 
    highidx : tdynarrayindex;
279
 
  begin
280
 
     highidx:=lowidx+count-1;
281
 
     pdest:=nil;
282
 
     if psrc=nil then
283
 
       exit;
284
 
     realpsrc:=pdynarray(psrc-sizeof(tdynarray));
285
 
     { skip kind and name }
286
 
     inc(pointer(ti),ord(pdynarraytypeinfo(ti)^.namelen));
287
 
     { -1, -1 (highidx=lowidx-1-1=-3) is used to copy the whole array like a:=copy(b);, so
288
 
       update the lowidx and highidx with the values from psrc }
289
 
     if (lowidx=-1) and (highidx=-3) then
290
 
      begin
291
 
        lowidx:=0;
292
 
        highidx:=realpsrc^.high;
293
 
      end;
294
 
     { get number of elements and check for invalid values }
295
 
     if (lowidx<0) or (highidx<0) then
296
 
       HandleErrorFrame(201,get_frame);
297
 
     cnt:=highidx-lowidx+1;
298
 
     { create new array }
299
 
     size:=pdynarraytypeinfo(ti)^.elesize*cnt;
300
 
     getmem(realpdest,size+sizeof(tdynarray));
301
 
     pdest:=pointer(realpdest)+sizeof(tdynarray);
302
 
     { copy data }
303
 
     move(pointer(psrc+pdynarraytypeinfo(ti)^.elesize*lowidx)^,pdest^,size);
304
 
     { fill new refcount }
305
 
     realpdest^.refcount:=1;
306
 
     realpdest^.high:=cnt-1;
307
 
     { increment ref. count of members }
308
 
     for i:= 0 to cnt-1 do
309
 
       int_addref(pointer(pdest+sizeof(tdynarray)+pdynarraytypeinfo(ti)^.elesize*i),pdynarraytypeinfo(ti)^.eletype);
310
 
  end;
311
 
 
312
 
 
313
 
{
314
 
  $Log: dynarr.inc,v $
315
 
  Revision 1.26  2004/05/24 07:18:17  michael
316
 
  + Patch from peter to fix crash
317
 
 
318
 
  Revision 1.25  2004/05/20 15:56:32  florian
319
 
    * fixed <dyn. array>:=nil;
320
 
 
321
 
  Revision 1.24  2004/05/02 15:15:58  peter
322
 
    * use freemem() without size
323
 
 
324
 
  Revision 1.23  2003/10/29 21:00:34  peter
325
 
    * fixed a:=copy(b)
326
 
 
327
 
  Revision 1.22  2003/10/25 22:52:07  florian
328
 
    * fixed copy(<dynarray>, ...)
329
 
 
330
 
  Revision 1.21  2002/11/26 23:02:07  peter
331
 
    * fixed dynarray copy
332
 
 
333
 
  Revision 1.20  2002/10/09 20:24:30  florian
334
 
    + range checking for dyn. arrays
335
 
 
336
 
  Revision 1.19  2002/10/02 18:21:51  peter
337
 
    * Copy() changed to internal function calling compilerprocs
338
 
    * FPC_SHORTSTR_COPY renamed to FPC_SHORTSTR_ASSIGN because of the
339
 
      new copy functions
340
 
 
341
 
  Revision 1.18  2002/09/07 15:07:45  peter
342
 
    * old logs removed and tabs fixed
343
 
 
344
 
  Revision 1.17  2002/04/26 15:19:05  peter
345
 
    * use saveregisters for incr routines, saves also problems with
346
 
      the optimizer
347
 
 
348
 
  Revision 1.16  2002/04/25 20:14:56  peter
349
 
    * updated compilerprocs
350
 
    * incr ref count has now a value argument instead of var
351
 
 
352
 
  Revision 1.15  2002/01/21 20:16:08  peter
353
 
    * updated for dynarr:=nil
354
 
}