1: \ growable buffers/array
2:
3: \ Copyright (C) 2000,2007 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation, either version 3
10: \ of the License, or (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, see http://www.gnu.org/licenses/.
19:
20: struct
21: cell% field growable-address1
22: cell% field growable-size
23: end-struct growable%
24:
25: : init-growable ( growable -- )
26: 0 over growable-address1 !
27: 1 cells swap growable-size ! ;
28:
29: : grow-to ( u growable -- )
30: \ grow growable to at least u aus
31: dup >r growable-size @ begin
32: 2dup u> while
33: 2* repeat
34: nip r@ growable-address1 @ over resize throw
35: \ !! assumptions: resize with current address 0 is allocate;
36: \ resizing to the current size is cheap
37: r@ growable-address1 !
38: r> growable-size ! ;
39:
40: : growable-addr ( offset growable -- address )
41: \ address at offset within growable
42: growable-address1 @ + ;
43:
44: : fit-growable ( offset usize growable -- address )
45: \ address is at offset within growable; growable becomes large
46: \ enough to have an object of size usize there
47: >r over + r@ grow-to
48: r> growable-addr ;
49:
50: false [if] \ test code
51:
52: growable% %allot constant x
53: x init-growable
54: x growable-size ?
55: 10 x grow-to
56: x growable-size ?
57: 4 x growable-addr hex.
58: 12 8 x fit-growable hex.
59: x growable-size ?
60: .s
61:
62: [then]
63:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>