[gforth] / gforth / struct.fs  

gforth: gforth/struct.fs

1 : anton 1.8 \ data structures (like C structs)
2 :    
3 : anton 1.11 \ Copyright (C) 1995, 1997 Free Software Foundation, Inc.
4 : anton 1.8
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 : anton 1.1
22 :     \ Usage example:
23 :     \
24 :     \ struct
25 :     \ 1 cells: field search-method
26 :     \ 1 cells: field reveal-method
27 :     \ end-struct wordlist-map
28 :     \
29 :     \ The structure can then be extended in the following way
30 :     \ wordlist-map
31 :     \ 1 cells: field enum-method
32 :     \ end-struct ext-wordlist-map \ with the fields search-method,...,enum-method
33 :    
34 :     : nalign ( addr1 n -- addr2 )
35 :     \ addr2 is the aligned version of addr1 wrt the alignment size n
36 :     1- tuck + swap invert and ;
37 :    
38 : anton 1.11 : dozerofield ( -- )
39 :     \ a field that makes no change
40 :     \ to enable accessing the offset with "['] <field> >body @" this
41 :     \ is not implemented with "['] noop alias"
42 :     last @
43 :     if
44 :     immediate
45 :     then
46 :     does> ( -- )
47 :     drop ;
48 :    
49 :     : field ( offset1 align1 size align "name" -- offset2 align2 ) \ gforth
50 :     \G name execution: ( addr1 -- addr2 )
51 :     >r rot r@ nalign dup
52 :     if \ field offset <> 0
53 :     [IFDEF] (Field)
54 :     (Field)
55 :     [ELSE]
56 :     Header reveal dofield: cfa,
57 :     [THEN]
58 :     else
59 :     create dozerofield
60 :     then ( align1 size offset )
61 :     dup , + swap r> nalign ;
62 : anton 1.1
63 :     : end-struct ( size align -- )
64 :     2constant ;
65 :    
66 :     0 1 chars end-struct struct
67 :    
68 : pazsan 1.3 \ : field ( offset1 align1 size align -- offset2 align2 )
69 :     \ create-field
70 :     \ does> ( addr1 -- addr2 )
71 :     \ @ + ;
72 : anton 1.1
73 :     \ I don't really like the "type:" syntax. Any other ideas? - anton
74 :     \ Also, this seems to be somewhat general. It probably belongs to some
75 :     \ other place
76 :     : cells: ( n -- size align )
77 :     cells cell ;
78 :    
79 :     : doubles: ( n -- size align )
80 :     2* cells cell ;
81 :    
82 :     : chars: ( n -- size align )
83 :     chars 1 chars ;
84 :    
85 :     : floats: ( n -- size align )
86 :     floats 1 floats ;
87 :    
88 : pazsan 1.5 : dfloats: ( n -- size align )
89 :     dfloats 1 dfloats ;
90 : anton 1.2
91 : pazsan 1.5 : sfloats: ( n -- size align )
92 :     sfloats 1 sfloats ;
93 :    
94 : anton 1.2 : struct-align ( size align -- )
95 :     dp @ swap nalign dp !
96 :     drop ;
97 :    
98 :     : struct-allot ( size align -- addr )
99 :     over swap struct-align
100 :     here swap allot ;
101 :    
102 : pazsan 1.5 : struct-allocate ( size align -- addr ior )
103 : anton 1.2 drop allocate ;
104 : anton 1.11
105 :     : struct-alloc ( size align -- addr )
106 :     struct-allocate throw ;
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help