[gforth] / gforth / oofsampl.fs  

gforth: gforth/oofsampl.fs

1 : pazsan 1.1 \ oof.fs Object Oriented FORTH
2 :     \ This file is (c) 1996 by Bernd Paysan
3 :     \ e-mail: paysan@informatik.tu-muenchen.de
4 :     \
5 :     \ Please copy and share this program, modify it for your system
6 :     \ and improve it as you like. But don't remove this notice.
7 :     \
8 :     \ Thank you.
9 :     \
10 :    
11 :     \ Data structures: data 28nov93py
12 :    
13 :     : place ( addr1 n addr2 -- )
14 :     over >r rot over 1+ r> move c! ;
15 :    
16 :     : i! postpone ! ; immediate
17 :     : i@ postpone @ ; immediate
18 :    
19 :     object class data \ abstract data class
20 :     cell var ref \ reference counter
21 :     method ! method @ method .
22 :     method null method atom? method #
23 :     how: : atom? ( -- flag ) true ;
24 :     : # ( -- n ) 0 ;
25 :     : null ( -- addr ) new ;
26 :     class;
27 :    
28 :     \ Data structures: int 30apr93py
29 :    
30 :     data class int
31 :     cell var value
32 :     how: : ! value i! ;
33 :     : @ value i@ ;
34 :     : . @ 0 .r ;
35 :     : init ( data -- ) ! ;
36 :     : dispose -1 ref +!
37 :     ref i@ 0> 0= IF super dispose THEN ;
38 :     : null 0 new ;
39 :     class;
40 :    
41 :    
42 :    
43 :     \ Data structures: list 17nov93py
44 :    
45 :     0 Value nil
46 :    
47 :     data class lists
48 :     data ptr first data ptr next
49 :     method empty? method ?
50 :     how: : null nil ;
51 :     : atom? false ;
52 :     class;
53 :    
54 :     lists class nil-class
55 :    
56 :     how: : empty? true ;
57 :     : dispose ;
58 :     : . ." ()" ;
59 :     class;
60 :    
61 :     nil-class : (nil (nil self TO nil
62 :     nil (nil bind first nil (nil bind next
63 :    
64 :    
65 :     \ Data structures: list 12mar94py
66 :    
67 :     lists class linked
68 :     how: : empty? false ;
69 :     : # next # 1+ ;
70 :     : ? first . ;
71 :     : @ first @ ;
72 :     : ! first ! ;
73 :     : init ( first next -- )
74 :     dup >o 1 ref +! o> bind next
75 :     dup >o 1 ref +! o> bind first ;
76 :     : . self >o [char] (
77 :     BEGIN emit ? next atom? next self o> >o
78 :     IF ." . " data . o> ." )" EXIT THEN bl
79 :     empty? UNTIL o> drop ." )" ;
80 :     : dispose -1 ref +! ref i@ 0> 0=
81 :     IF first dispose next dispose super dispose THEN ;
82 :     class;
83 :    
84 :     \ Data structures: string 04dec93py
85 :    
86 :     int class string
87 :     how: : ! ( addr count -- )
88 :     value i@ over 1+ resize throw value i!
89 :     value i@ place ;
90 :     : @ ( -- addr count ) value i@ count ;
91 :     : . @ type ;
92 :     : init ( addr count -- )
93 :     dup 1+ allocate throw value i! value i@ place ;
94 :     : null S" " new ;
95 :     : dispose ref i@ 1- 0> 0=
96 :     IF value i@ free throw THEN super dispose ;
97 :     class;
98 :    
99 :     \ Data sturctures: pointer 17nov93py
100 :    
101 :     data class pointer
102 :     data ptr container
103 :     method ptr!
104 :     how: : ! container ! ;
105 :     : @ container @ ;
106 :     : . container . ;
107 :     : # container # ;
108 :     : init ( data -- ) dup >o 1 ref +! o> bind container ;
109 :     : ptr! ( data -- ) container dispose init ;
110 :     : dispose -1 ref +! ref i@ 0> 0=
111 :     IF container dispose super dispose THEN ;
112 :     : null nil new ;
113 :     class;
114 :    
115 :     \ Data sturctures: array 30apr93py
116 :    
117 :     data class array
118 :     data [] container
119 :     cell var range
120 :     how: : ! container ! ;
121 :     : @ container @ ;
122 :     : . [char] [
123 :     # 0 ?DO emit I container . [char] , LOOP drop ." ]" ;
124 :     : init ( data n -- ) range i! bind container ;
125 :     : dispose -1 ref +! ref i@ 0> 0=
126 :     IF # 0 ?DO I container dispose LOOP
127 :     super dispose THEN ;
128 :     : null nil 0 new ;
129 :     : # range i@ ;
130 :     : atom? false ;
131 :     class;
132 :    
133 :     \ Data structure utilities 17nov93py
134 :    
135 :     : cons linked new ;
136 :     : list nil cons ;
137 :     : car >o lists first self o> ;
138 :     : cdr >o lists next self o> ;
139 :     : print >o data . o> ;
140 :     : ddrop >o data dispose o> ;
141 :     : make-string string new ;
142 :     : $" state @ IF postpone S" postpone make-string exit THEN
143 :     [char] " parse make-string ; immediate
144 :    
145 :     \ Examples
146 :    
147 :     $" This" $" is" $" a" list cons $" example" $" list" list cons list cons cons
148 :     cr dup print
149 :     cr dup car print
150 :     cr dup cdr cdr car print
151 :     pointer : list1
152 :     cr list1 .
153 :    
154 :     1 2 3 3 int new[] 3 array : lotus
155 :     cr lotus .
156 :     cr 2 lotus @ .
157 :     cr 0 lotus @ .
158 :     cr 5 1 lotus ! lotus .
159 :    
160 :     \ Interface test
161 :    
162 :     interface bla
163 :     method fasel
164 :     method blubber
165 :     method Hu
166 :     how:
167 :     : fasel ." Bla Fasel" Hu ;
168 :     : blubber ." urps urps" Hu fasel ;
169 :     interface;
170 :    
171 :     object class test
172 :     bla
173 :     method .
174 :     how:
175 :     : Hu ." ! " ;
176 :     : . fasel ;
177 :     class;
178 :    
179 :     test : test1
180 :     cr test1 fasel
181 :     cr test1 blubber
182 :     cr test1 .
183 :     cr test1 self >o bla blubber o>
184 :    
185 :     \ This should output the following lines:
186 :     \
187 :     \ (This (is a) (example list))
188 :     \ This
189 :     \ (example list)
190 :     \ (This (is a) (example list))
191 :     \ [1,2,3]
192 :     \ 3
193 :     \ 1
194 :     \ [1,5,3]
195 :     \ Bla Fasel!
196 :     \ urps urps! Bla Fasel!
197 :     \ Bla Fasel!
198 :     \ urps urps! Bla Fasel!
199 :    
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help