1: \ growable buffers/array
2:
3: \ Copyright (C) 2000 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 2
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, write to the Free Software
19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20:
21: struct
22: cell% field growable-address1
23: cell% field growable-size
24: end-struct growable%
25:
26: : init-growable ( growable -- )
27: 0 over growable-address1 !
28: 1 cells swap growable-size ! ;
29:
30: : grow-to ( u growable -- )
31: \ grow growable to at least u aus
32: dup >r growable-size @ begin
33: 2dup u> while
34: 2* repeat
35: nip r@ growable-address1 @ over resize throw
36: \ !! assumptions: resize with current address 0 is allocate;
37: \ resizing to the current size is cheap
38: r@ growable-address1 !
39: r> growable-size ! ;
40:
41: : growable-addr ( offset growable -- address )
42: \ address at offset within growable
43: growable-address1 @ + ;
44:
45: : fit-growable ( offset usize growable -- address )
46: \ address is at offset within growable; growable becomes large
47: \ enough to have an object of size usize there
48: >r over + r@ grow-to
49: r> growable-addr ;
50:
51: false [if] \ test code
52:
53: growable% %allot constant x
54: x init-growable
55: x growable-size ?
56: 10 x grow-to
57: x growable-size ?
58: 4 x growable-addr hex.
59: 12 8 x fit-growable hex.
60: x growable-size ?
61: .s
62:
63: [then]
64:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>