Annotation of gforth/growable.fs, revision 1.1
1.1 ! anton 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>