1: \ yet another Forth objects extension
2:
3: \ written by Anton Ertl 1996
4: \ public domain
5:
6: \ This is in ANS Forth (with an environmental dependence on case
7: \ insensitivity; convert everything to upper case for state sensitive
8: \ systems). It needs some non-core words (in particular, it uses the
9: \ memory allocation wordset), but I have not made a complete list.
10:
11: \ Manual:
12:
13: \ A class is defined like this:
14:
15: \ <parent> class
16: \ ... field <name>
17: \ ...
18:
19: \ ... inst-var <name>
20: \ ...
21:
22: \ selector <name>
23:
24: \ :noname ( ... object -- ... )
25: \ ... ;
26: \ method <name> \ new method
27: \ ...
28:
29: \ :noname ( ... object -- ... )
30: \ ... ;
31: \ overrides <name> \ existing method
32: \ ...
33:
34: \ end-class <name>
35:
36: \ you can write fields, inst-vars, selectors, methods and overrides in
37: \ any order.
38:
39: \ A call of a method looks like this:
40:
41: \ ... <object> <method>
42:
43: \ (<object> just needs to reside on the stack, there's no need to name it).
44:
45: \ Instead of defining a method with ':noname ... ;', you can define it
46: \ also with 'm: ... ;m'. The difference is that with ':noname' the
47: \ "self" object is on the top of stack; with 'm:' you can get it with
48: \ 'this'. You should use 'this' only in an 'm:' method even though the
49: \ sample implementation does not enforce this.
50:
51: \ The difference between a field and and inst-var is that the field
52: \ refers to an object at the top of data stack (i.e. a field has the
53: \ stack effect (object -- addr), whereas the inst-var refers to this
54: \ (i.e., it has the stack effect ( -- addr )); obviously, an inst-var
55: \ can only be used in an 'm:' method.
56:
57: \ 'method' defines a new method selector and binds a method to it.
58:
59: \ 'selector' defines a new method selector without binding a method to
60: \ it (you can use this to define abstract classes)
61:
62: \ 'overrides' binds a different method (than the parent class) to an
63: \ existing method selector.
64:
65: \ If you want to perform early binding, you can do it like this:
66:
67: \ ... <object> [bind] <class> <method> \ compilation
68: \ ... <object> bind <class> <method> \ interpretation
69:
70: \ You can get at the method from the method selector and the class like
71: \ this:
72:
73: \ bind' <class> <method>
74: \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
75:
76: \ needs struct.fs
77:
78: \ helper words
79:
80: : -rot ( a b c -- c a b )
81: rot rot ;
82:
83: : perform ( ... addr -- ... )
84: @ execute ;
85:
86: : save-mem ( addr1 u -- addr2 u ) \ gforth
87: \ copy a memory block into a newly allocated region in the heap
88: swap >r
89: dup allocate throw
90: swap 2dup r> -rot move ;
91:
92: : extend-mem ( addr1 u1 u -- addr addr2 u2 )
93: \ extend memory block allocated from the heap by u aus
94: \ the (possibly reallocated piece is addr2 u2, the extension is at addr )
95: over >r + dup >r resize throw
96: r> over r> + -rot ;
97:
98: : 2, ( w1 w2 -- ) \ gforth
99: here 2 cells allot 2! ;
100:
101: : const-field ( size1 align1 -- size2 align2 )
102: 1 cells: field
103: does> ( addr -- w )
104: @ + @ ;
105:
106: struct
107: 1 cells: field object-map
108: end-struct object-struct
109:
110: struct
111: 2 cells: field class-map
112: const-field class-instance-size \ aus
113: const-field class-instance-align \ aus
114: end-struct class-struct
115:
116: 2variable current-map \ address and size (in aus) of the current map
117:
118: : class ( class -- size align )
119: dup class-map 2@ save-mem current-map 2!
120: dup class-instance-size
121: swap class-instance-align ;
122:
123: : end-class ( size align "name" -- )
124: create
125: current-map 2@ 2,
126: swap , , ;
127:
128: : no-method ( -- )
129: abort" no method defined" ;
130:
131: : method ( xt "name" -- )
132: \ define method and selector
133: current-map 2@ ( xt map-addr map-size )
134: create dup ,
135: 1 cells extend-mem current-map 2!
136: !
137: does> ( ... object -- ... )
138: ( object addr )
139: @ over ( object-map ) @ + ( object xtp ) perform ;
140:
141: : selector ( "name" -- )
142: \ define a method selector for later overriding in subclasses
143: ['] no-method method ;
144:
145: : override! ( xt method-xt -- )
146: >body @ current-map 2@ drop + ! ;
147:
148: : overrides ( xt "selector" -- )
149: \ replace default method "method" with xt
150: ' override! ;
151:
152: : alloc-instance ( class -- object )
153: \ make a new, (almost) uninitialized instance of a class
154: dup class-instance-size allocate throw
155: swap class-map 2@ drop over ( object-map ) ! ;
156:
157: \ this/self, instance variables etc.
158:
159: variable thisp
160: : this ( -- object )
161: \ rename this into self if you are a Smalltalk fiend
162: thisp @ ;
163:
164: : m: ( -- xt colon-sys ) ( run-time: object -- )
165: :noname
166: POSTPONE this
167: POSTPONE >r
168: POSTPONE thisp
169: POSTPONE ! ;
170:
171: : ;m ( colon-sys -- ) ( run-time: -- )
172: POSTPONE r>
173: POSTPONE thisp
174: POSTPONE !
175: POSTPONE ; ; immediate
176:
177: : catch ( ... xt -- ... n )
178: \ make it safe to call CATCH within a method.
179: \ should also be done with all words containing CATCH.
180: this >r catch r> thisp ! ;
181:
182: : inst-var ( size1 align1 size align -- size2 align2 )
183: field
184: does> ( -- addr )
185: ( addr1 ) @ this + ;
186:
187: \ early binding stuff
188:
189: \ this is not generally used, only where you want to do something like
190: \ superclass method invocation (so that you don't have to name your methods)
191:
192: : (bind) ( class method-xt -- xt )
193: >body @ swap class-map 2@ drop + @ ;
194:
195: : bind' ( "class" "method" -- xt )
196: ' >body ' (bind) ;
197:
198: : bind ( ... object "class" "method" -- ... )
199: bind' execute ;
200:
201: : [bind] ( compile-time: "class" "method" -- ; run-time: ... object -- ... )
202: bind' compile, ; immediate
203:
204: \ the object class
205:
206: 0 0 save-mem current-map 2!
207: object-struct \ no class to inherit from, so we have to do this manually
208: :noname ( object -- )
209: ." object:" dup . ." class:" object-map @ . ;
210: method print
211: end-class object
212:
213: \ examples
214: true [if]
215: cr object alloc-instance print
216:
217: object class
218: :noname ( object -- )
219: drop ." undefined" ;
220: overrides print
221: end-class nothing
222:
223: nothing alloc-instance constant undefined
224:
225: cr undefined print
226:
227: \ instance variables and this
228: object class
229: 1 cells: inst-var count-n
230: m: ( object -- )
231: count-n @ . ;m
232: overrides print
233: m: ( object -- )
234: 0 count-n ! ;m
235: method init
236: m: ( object -- )
237: 1 count-n +! ;m
238: method inc
239: end-class counter
240:
241: counter alloc-instance constant counter1
242:
243: cr
244: counter1 init
245: counter1 print
246: counter1 inc
247: counter1 print
248: counter1 inc
249: counter1 inc
250: counter1 inc
251: counter1 print
252: counter1 print
253:
254: \ examples of static binding
255:
256: cr undefined bind object print
257: : object-print ( object -- )
258: [bind] object print ;
259:
260: cr undefined object-print
261: [then]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>