File: dbf\array_handler.adb
1 --::::::::::
2 --arrahand.adb
3 --::::::::::
4 -- Developed by (C) Wasiliy W. Molostoff 1994, 1995.
5 -- Moscow, Russia,
6 -- Voice: 7 (095) 398-23-38
7 -- e-mail: edv@edv.msk.ru
8 -- This is free software; you can freely redistribute it and/or
9 -- modify it without any restrictions. Please report any errors.
10 -- All corrections will be made as soon as possible.
11 with choice, program_log;
12 package body array_handler is
13
14 function min is new choice (integer, "<=");
15 function max is new choice (integer, ">=");
16
17 package log is new program_log ("array_handler", toolname);
18 use log;
19
20 assfals: constant string := ": false assertion";
21 adachks: constant string := ": system checking";
22 on_elem: constant string := " on elem";
23 on_arry: constant string := " on array";
24 on_fild: constant string := " on field";
25
26 procedure info (vol: string; first, last: integer) is
27 begin
28 log.message (vol & " (" & integer'image(first) & ", " &
29 integer'image(last ) & ")");
30 end;
31
32 -----------------------------------------------------------------------
33
34 function length (item: object) return natural is
35 begin
36 return item.len;
37 end;
38
39 -----------------------------------------------------------------------
40
41 function value (item: object; position: positive) return elem_type is
42 begin
43 if extra_check then
44 assert (position in 1..item.len, "value" & on_elem & assfals);
45 end if;
46 return item.data (position);
47 end;
48
49 -----------------------------------------------------------------------
50
51 function value (item: object;
52 first, last: natural) return elem_array is
53 begin
54 return item.data(max (first, 1).. min (item.len, last));
55 end;
56
57 -----------------------------------------------------------------------
58
59 function value (item: object) return elem_array is
60 begin
61 return item.data (1..item.len);
62 end;
63
64 -----------------------------------------------------------------------
65
66 function empty (item: object) return boolean is
67 begin
68 return item.len = 0;
69 end;
70
71 -----------------------------------------------------------------------
72
73 function value (item: elem_array) return object is
74 begin
75 return (width => item'length,
76 len => item'length,
77 data => item);
78 end;
79
80 -----------------------------------------------------------------------
81
82 function value (item: elem_type) return object is
83 begin
84 return (width => 1,
85 len => 1,
86 data => (1..1 => item));
87 end;
88
89 -----------------------------------------------------------------------
90
91 function "&" (left: object; right: object) return object is
92 tmp: object (left.len + right.len);
93 begin
94 set (tmp, left); append (right, tmp);
95 return tmp;
96 end;
97
98 -----------------------------------------------------------------------
99
100 function "&" (left: object; right: elem_array) return object is
101 tmp: object(left.len + right'length);
102 begin
103 set (tmp, left); append (right, tmp);
104 return tmp;
105 end;
106
107 -----------------------------------------------------------------------
108
109 function "&" (left: elem_array; right: object) return object is
110 tmp: object(right.len + left'length);
111 begin
112 set (tmp, left); append (right, tmp);
113 return tmp;
114 end;
115
116 -----------------------------------------------------------------------
117
118 function "&" (left: object; right: elem_type ) return object is
119 tmp: object(left.len + 1);
120 begin
121 set (tmp, left); append (right, tmp);
122 return tmp;
123 end;
124
125 -----------------------------------------------------------------------
126
127 function "&" (left: elem_type; right: object) return object is
128 tmp: object(right.len + 1);
129 begin
130 set (tmp, left); append (right, tmp);
131 return tmp;
132 end;
133
134 -----------------------------------------------------------------------
135
136 procedure set (item: in out object; value: in object) is
137 begin
138 if extra_check then
139 assert (value.len <= item.width, "set" & on_fild & assfals);
140 end if;
141 item.len := min(item.width, value.len);
142 if item.len > 0
143 then
144 item.data(1..item.len) := value.data(1 .. item.len);
145 end if;
146 end;
147
148 -----------------------------------------------------------------------
149
150 procedure set (item: in out object; value: in elem_array) is
151 begin
152 if extra_check then
153 assert (value'length <= item.width, "set" & on_arry & assfals);
154 end if;
155 item.len := min(item.width, value'length);
156 if item.len > 0
157 then
158 item.data(1..item.len) := value(value'first..item.len + value'first - 1);
159 end if;
160 end;
161
162 -----------------------------------------------------------------------
163
164 procedure set (item: in out object; value: in elem_type) is
165 begin
166 item.data(1) := value;
167 item.len := 1;
168 end;
169
170 -----------------------------------------------------------------------
171
172 procedure set (item: in out object;
173 value: in elem_type;
174 times: in positive) is
175 begin
176 set_length (item, times);
177 for i in 1..length (item)
178 loop
179 item.data(i) := value;
180 end loop;
181 end;
182 -----------------------------------------------------------------------
183
184 procedure clear (item: in out object; from: in positive := 1) is
185 begin
186 set_length (item, from - 1);
187 end;
188
189 -----------------------------------------------------------------------
190
191 procedure set_length (item: in out object; len: in natural) is
192 begin
193 item.len := min (len, item.width);
194 end;
195
196 -----------------------------------------------------------------------
197
198 procedure append (tail: in object; to: in out object) is
199 len: natural;
200 begin
201 len := min(tail.len, to.width - to.len);
202 if extra_check then
203 assert (tail.len <= len, "append" & on_fild & assfals);
204 end if;
205 to.data(to.len + 1 .. to.len + len) := tail.data(1..len);
206 to.len := to.len + len;
207 end;
208
209 -----------------------------------------------------------------------
210
211 procedure append (tail: in elem_array; to: in out object) is
212 len: natural;
213 begin
214 len := min(tail'length, to.width - to.len);
215 if extra_check then
216 assert (tail'length <= len, "append" & on_arry & assfals);
217 end if;
218 to.data(to.len + 1 .. to.len + len) :=
219 tail(tail'first .. tail'first + len - 1);
220 to.len := to.len + len;
221 end;
222
223 -----------------------------------------------------------------------
224
225 procedure append (tail: in elem_type ; to: in out object) is
226 begin
227 if extra_check then
228 assert (to.width > to.len, "append" & on_elem & assfals);
229 end if;
230 if to.width > to.len then
231 to.len := to.len + 1;
232 to.data(to.len) := tail;
233 end if;
234 end;
235
236 -----------------------------------------------------------------------
237
238 procedure append (tail: in object; to: in out object;
239 len: in natural;
240 pos: in positive := 1) is
241 m: integer;
242 begin
243 m := min (min (tail.len - pos + 1, to.width - to.len), len);
244 if m > 0 then
245 to.data(to.len + 1 .. to.len + len) := tail.data(pos..m);
246 to.len := to.len + m;
247 end if;
248 end;
249
250 -----------------------------------------------------------------------
251
252 procedure amend (item: in out object; by: in object; position: in positive) is
253 len: natural;
254 begin
255 len := min(by.len, item.width - position);
256 if extra_check then
257 assert (by.len <= len, "amend" & on_fild & assfals);
258 end if;
259 item.data(position .. position + len - 1) := by.data(1 .. len);
260 item.len := max (item.len, len + position - 1);
261 end;
262
263 -----------------------------------------------------------------------
264
265 procedure amend (item: in out object; by: in elem_array; position: in positive) is
266 len: natural;
267 begin
268 len := min(by'length, item.width - position);
269 if extra_check then
270 assert (by'length <= len, "amend" & on_arry & assfals);
271 end if;
272 item.data(position .. position + len - 1) :=
273 by(by'first .. by'first + len - 1);
274 item.len := max (item.len, len + position - 1);
275 end;
276
277 -----------------------------------------------------------------------
278
279 procedure amend (item: in out object; by: in elem_type ; position: in positive) is
280 begin
281 if extra_check then
282 assert (1 <= item.len, "amend" & on_arry & assfals);
283 end if;
284 item.data(position) := by;
285 end;
286
287 -----------------------------------------------------------------------
288
289 function locate (frag: elem_array;
290 within: object;
291 from: positive := 1;
292 to: positive := positive'last) return natural is
293 last_try: constant integer := (min (within.len, to) - frag'length + 1);
294 begin
295
296 if frag'length = 0 or else from > last_try
297 then
298 return 0;
299 end if;
300
301 if frag'length = 1 then
302 return locate (frag(frag'first), within, from, to);
303 end if;
304
305 declare
306 pos: natural := from;
307 equ: natural := 0;
308 sub: array (frag'range) of positive;
309
310 procedure subseq_check is
311 o: integer;
312 begin
313
314 for i in sub'range
315 loop
316 sub (i) := i;
317 end loop;
318
319 for n in frag'first..(frag'last / 2)
320 loop
321 for m in n..(frag'last - n)
322 loop
323 o := m + n;
324 if frag(frag'first..n) = frag(m + 1..o) and then
325 sub (o) > m
326 then
327 sub (o) := m;
328 end if;
329 end loop;
330 end loop;
331 end subseq_check;
332
333 begin
334
335 pos := locate (frag(frag'first), within, from, last_try);
336 if pos < 1 -- not in from..last_try
337 then
338 return 0;
339 end if;
340
341 subseq_check;
342
343 loop
344
345 exit when pos > last_try;
346
347 for f in frag'range -- frag'first..frag'last
348 loop
349 exit when within.data (pos + equ) /= frag (f);
350 equ := equ + 1;
351 end loop;
352
353 if equ > 0 then
354 if equ = frag'length then
355 return pos;
356 end if;
357
358 pos := pos + sub (sub'first + equ - 1);
359 equ := 0;
360 else
361 pos := pos + 1;
362 pos := locate (frag(frag'first), within, pos, to);
363 exit when pos = 0;
364 end if;
365
366 end loop;
367 end;
368 return 0;
369 end locate;
370
371 -----------------------------------------------------------------------
372
373 function locate (frag: object;
374 within: object;
375 from: positive := 1;
376 to: positive := positive'last) return natural is
377 begin
378 return locate (frag.data (1 .. frag.len), within, from, to);
379 end;
380
381 -----------------------------------------------------------------------
382
383 function locate (frag: elem_type;
384 within: object;
385 from: positive := 1;
386 to: positive := positive'last) return natural is
387 begin
388 for n in from..min (within.len, to)
389 loop
390 if within.data(n) = frag
391 then
392 return natural(n);
393 end if;
394 end loop;
395 return 0;
396 end;
397
398 -----------------------------------------------------------------------
399
400 procedure delete (item: in out object; from, to: positive) is
401 begin
402 if item.len > 0 and then
403 from <= to
404 then
405 if to > item.len then
406 clear (item, from);
407 else
408 set (item, item.data (1 ..from - 1) &
409 item.data (to + 1..item.len));
410 end if;
411 end if;
412 exception
413 when others => error ("delete" & adachks); raise;
414 end;
415
416 -----------------------------------------------------------------------
417
418 procedure expand (item: in out object; from, to: positive) is
419 begin
420 set (item, item.data (1 ..to ) &
421 item.data (from ..item.len));
422 exception
423 when others => error ("expand" & adachks); raise;
424 end;
425
426 -----------------------------------------------------------------------
427
428 procedure exchange (item_a, item_b: in out object) is
429 begin
430 if extra_check then
431 assert (item_a.len <= item_b.width and
432 item_b.len <= item_a.width,
433 "exchange" & on_fild & assfals);
434 end if;
435 if item_a.len = 0
436 then
437 if item_b.len = 0
438 then
439 return;
440 end if;
441 set (item_a, item_b); item_b.len := 0; return;
442 end if;
443
444 if item_b.len = 0
445 then
446 set (item_b, item_a); item_a.len := 0; return;
447 end if;
448
449 if item_a.len > item_b.len
450 then
451 declare
452 elm: elem_type;
453 begin
454 for n in 1..item_b.len
455 loop
456 elm := item_a.data(n);
457 item_a.data(n) := item_b.data(n);
458 item_b.data(n) := elm;
459 end loop;
460 append (item_a.data(item_b.len + 1..item_a.len), item_b);
461 clear (item_a, item_b.len + 1);
462 end;
463 return;
464 elsif item_b.len > item_a.len
465 then
466 declare
467 elm: elem_type;
468 begin
469 for n in 1..item_a.len
470 loop
471 elm := item_b.data(n);
472 item_b.data(n) := item_a.data(n);
473 item_a.data(n) := elm;
474 end loop;
475 append (item_b.data(item_a.len + 1..item_b.len), item_b);
476 clear (item_b, item_a.len + 1);
477 end;
478 return;
479 else -- if item_a.len = item_b.len then
480 declare
481 elm: elem_type;
482 begin
483 for n in 1..item_a.len
484 loop
485 elm := item_a.data(n);
486 item_a.data(n) := item_b.data(n);
487 item_b.data(n) := elm;
488 end loop;
489 end;
490 return;
491 end if;
492
493 raise program_error;
494
495 end;
496
497 -----------------------------------------------------------------------
498
499 procedure insert (item: in out object;
500 frag: in object;
501 from: in positive;
502 replace: in natural := 0) is
503 begin
504 insert (item => item,
505 frag => value(frag),
506 from => from,
507 replace => replace);
508 end;
509
510 -----------------------------------------------------------------------
511
512 procedure insert (item: in out object;
513 frag: in elem_array;
514 from: in positive;
515 replace: in natural := 0) is
516
517 begin
518 if replace < frag'length then
519 expand (item, from + replace, from + frag'length - 1);
520 elsif replace > frag'length then
521 delete (item, from + frag'length, from + replace - 1);
522 end if;
523 amend (item, frag, from);
524 exception
525 when others => error ("insert" & on_arry & assfals); raise;
526 end;
527
528 -----------------------------------------------------------------------
529
530 procedure insert (item: in out object;
531 frag: in elem_type;
532 from: in positive;
533 replace: in natural := 0) is
534 begin
535 if replace < 1 then
536 expand (item, from, from);
537 elsif replace > 1 then
538 delete (item, from + 1, from + replace - 1);
539 end if;
540
541 amend (item, frag, from);
542 exception
543 when others => error ("insert" & on_elem & assfals); raise;
544 end;
545
546 -----------------------------------------------------------------------
547
548 function suffix (a, b: object) return natural is
549 m: natural := min(a.len, b.len);
550 begin
551 for i in 0..m - 1
552 loop
553 if a.data(a.len - i) /= b.data(b.len - i) then
554 return i;
555 end if;
556 end loop;
557 return m;
558 end;
559
560 -----------------------------------------------------------------------
561
562 function prefix (a, b: object) return natural is
563 m: natural := min(a.len, b.len);
564 begin
565 for i in 1..m
566 loop
567 if a.data(i) /= b.data(i) then
568 return i - 1;
569 end if;
570 end loop;
571 return m;
572 end;
573
574 -----------------------------------------------------------------------
575
576 function translating_poly_in (left: in object;
577 right: in operand;
578 from: in positive := 1;
579 to: in positive := positive'last) return result is
580 begin
581 return op (value (left, from, to), right);
582 end;
583
584 -----------------------------------------------------------------------
585
586 function translating_mono_in (right: in object;
587 from: in positive := 1;
588 to: in positive := positive'last) return result is
589 begin
590 return value (value (right, from, to));
591 end;
592
593 -----------------------------------------------------------------------
594
595 procedure transforming_poly_in_out (left: in out object;
596 right: in operand;
597 from: in positive := 1;
598 to: in positive := positive'last) is
599 tmp: elem_array (max (from, 1).. min (length(left), to));
600 begin
601 op (tmp, right);
602 set (left, tmp);
603 end;
604
605 -----------------------------------------------------------------------
606
607 procedure transforming_mono_in_out (right: in out object;
608 from: in positive := 1;
609 to: in positive := positive'last) is
610 tmp: elem_array (max (from, 1).. min (right.len, to));
611 begin
612 op (tmp);
613 set (right, tmp);
614 end;
615
616 -----------------------------------------------------------------------
617
618 procedure transfering_mono_in (item: in object;
619 from: in positive := 1;
620 to: in positive := positive'last) is
621 begin
622 op (value (item, from, to));
623 end;
624
625 -----------------------------------------------------------------------
626
627 procedure transfering_mono_out (item: in out object;
628 from: in positive := 1;
629 to: in positive := positive'last) is
630 tmp: elem_array (max (from, 1).. min (length(item), to));
631 begin
632 op (tmp);
633 amend (item, tmp, from);
634 end;
635
636 -----------------------------------------------------------------------
637
638 procedure transfering_mono_out_changes (item: in out object) is
639 tmp: elem_array (1..item.width);
640 len: natural := 0;
641 begin
642 op (tmp, len);
643 set (item, tmp (1..len));
644 end;
645
646 -----------------------------------------------------------------------
647
648 procedure transfering_poly_in (file: in control;
649 item: in object;
650 from: in positive := 1;
651 to: in positive := positive'last) is
652 begin
653 op (file, item.data(max (from, 1)..min (item.len, to)));
654 end;
655
656 -----------------------------------------------------------------------
657
658 procedure transfering_poly_in_out (file: in control;
659 item: in out object;
660 from: in positive := 1;
661 to: in positive := positive'last) is
662 begin
663 op (file, item.data(max (from, 1)..min (item.len, to)));
664 end;
665
666 -----------------------------------------------------------------------
667
668 procedure transfering_poly_out ( file: in control;
669 item: in out object;
670 from: in positive := 1;
671 to: in positive := positive'last) is
672 begin
673 op (file, item.data(max (from, 1)..min (item.len, to)));
674 end;
675
676 -----------------------------------------------------------------------
677
678 procedure transfering_poly_out_changes (file: in control;
679 item: in out object) is
680 begin
681 op (file, item.data, item.len);
682 item.len := min(item.len, item.width);
683 end;
684
685 end array_handler;
686