1: \ yet another Forth objects extension
2:
3: \ written by Anton Ertl 1996, 1997
4: \ public domain; NO WARRANTY
5:
6: \ This (in combination with compat/struct.fs) is in ANS Forth (with an
7: \ environmental dependence on case insensitivity; convert everything
8: \ to upper case for state sensitive systems).
9:
10: \ compat/struct.fs and this file together use the following words:
11:
12: \ from CORE :
13: \ : 1- + swap invert and ; DOES> @ immediate drop Create rot dup , >r
14: \ r> IF ELSE THEN over chars aligned cells 2* here - allot execute
15: \ POSTPONE ?dup 2dup move Variable 2@ 2! ! ['] >body = 2drop ' r@ +!
16: \ Constant recurse 1+ BEGIN 0= UNTIL negate Literal ." .
17: \ from CORE-EXT :
18: \ tuck pick nip true <> 0> erase Value :noname compile,
19: \ from BLOCK-EXT :
20: \ \
21: \ from DOUBLE :
22: \ 2Constant
23: \ from EXCEPTION :
24: \ throw catch
25: \ from EXCEPTION-EXT :
26: \ abort"
27: \ from FILE :
28: \ (
29: \ from FLOAT :
30: \ faligned floats
31: \ from FLOAT-EXT :
32: \ dfaligned dfloats sfaligned sfloats
33: \ from LOCAL :
34: \ TO
35: \ from MEMORY :
36: \ allocate resize free
37: \ from SEARCH :
38: \ get-order set-order wordlist get-current set-current
39:
40: \ needs struct.fs
41:
42: \ helper words
43:
44: s" gforth" environment? [if]
45: 2drop
46: [else]
47:
48: : -rot ( a b c -- c a b )
49: rot rot ;
50:
51: : perform ( ... addr -- ... )
52: @ execute ;
53:
54: : ?dup-if ( compilation: -- orig ; run-time: n -- n| )
55: POSTPONE ?dup POSTPONE if ; immediate
56:
57: : save-mem ( addr1 u -- addr2 u ) \ gforth
58: \ copy a memory block into a newly allocated region in the heap
59: swap >r
60: dup allocate throw
61: swap 2dup r> -rot move ;
62:
63: : resize ( a-addr1 u -- a-addr2 ior ) \ gforth
64: over
65: if
66: resize
67: else
68: nip allocate
69: then ;
70:
71: : extend-mem ( addr1 u1 u -- addr addr2 u2 )
72: \ extend memory block allocated from the heap by u aus
73: \ the (possibly reallocated) piece is addr2 u2, the extension is at addr
74: over >r + dup >r resize throw
75: r> over r> + -rot ;
76:
77: : \g ( -- )
78: postpone \ ; immediate
79: [then]
80:
81: \ data structures
82:
83: struct
84: cell% field object-map
85: end-struct object%
86:
87: struct
88: cell% 2* field interface-map
89: cell% field interface-map-offset \ aus
90: \ difference between where interface-map points and where
91: \ object-map points (0 for non-classes)
92: cell% field interface-offset \ aus
93: \ offset of interface map-pointer in class-map (0 for classes)
94: end-struct interface%
95:
96: interface%
97: cell% field class-parent
98: cell% field class-wordlist \ inst-vars and other protected words
99: cell% 2* field class-inst-size ( class -- addr ) \ objects
100: \g used as @code{class-inst-size 2@ ( class -- align size )},
101: \g gives the size specification for an instance (i.e. an object)
102: \g of @code{class}.
103: end-struct class%
104:
105: struct
106: cell% field selector-offset \ the offset within the (interface) map
107: cell% field selector-interface \ the interface offset
108: end-struct selector%
109:
110: \ maps are not defined explicitly; they have the following structure:
111:
112: \ pointers to interface maps (for classes) <- interface-map points here
113: \ interface%/class% pointer <- (object-)map points here
114: \ xts of methods
115:
116:
117: \ code
118:
119: \ selectors and methods
120:
121: variable current-interface ( -- addr ) \ objects
122: \g this variable contains the class or interface currently being
123: \g defined.
124:
125:
126:
127: : no-method ( -- )
128: true abort" no method defined for this object/selector combination" ;
129:
130: : do-class-method ( -- )
131: does> ( ... object -- ... )
132: ( object selector-body )
133: selector-offset @ over object-map @ + ( object xtp ) perform ;
134:
135: : do-interface-method ( -- )
136: does> ( ... object -- ... )
137: ( object selector-body )
138: 2dup selector-interface @ ( object selector-body object interface-offset )
139: swap object-map @ + @ ( object selector-body map )
140: swap selector-offset @ + perform ;
141:
142: : method ( xt "name" -- ) \ objects
143: \g @code{name} execution: @code{... object -- ...}@*
144: \g creates selector @code{name} and makes @code{xt} its method in
145: \g the current class.
146: create
147: current-interface @ interface-map 2@ ( xt map-addr map-size )
148: dup current-interface @ interface-map-offset @ - ,
149: 1 cells extend-mem current-interface @ interface-map 2! ! ( )
150: current-interface @ interface-offset @ dup ,
151: ( 0<> ) if
152: do-interface-method
153: else
154: do-class-method
155: then ;
156:
157: : selector ( "name" -- ) \ objects
158: \g @code{name} execution: @code{... object -- ...}@*
159: \g creates selector @code{name} for the current class and its
160: \g descendents; you can set a method for the selector in the
161: \g current class with @code{overrides}.
162: ['] no-method method ;
163:
164: : interface-override! ( xt sel-xt interface-map -- )
165: \ xt is the new method for the selector sel-xt in interface-map
166: swap >body ( xt map selector-body )
167: selector-offset @ + ! ;
168:
169: : class->map ( class -- map ) \ objects
170: \g @code{map} is the pointer to @code{class}'s method map; it
171: \g points to the place in the map to which the selector offsets
172: \g refer (i.e., where @code{object-map}s point to).
173: dup interface-map 2@ drop swap interface-map-offset @ + ;
174:
175: : unique-interface-map ( class-map offset -- )
176: \ if the interface at offset in class map is the same as its parent,
177: \ copy it to make it unique; used for implementing a copy-on-write policy
178: over @ class-parent @ class->map ( class-map offset parent-map )
179: over + @ >r \ the map for the interface for the parent
180: + dup @ ( mapp map )
181: dup r> =
182: if
183: @ interface-map 2@ save-mem drop
184: swap !
185: else
186: 2drop
187: then ;
188:
189: : class-override! ( xt sel-xt class-map -- ) \ objects
190: \g @code{xt} is the new method for the selector @code{sel-xt} in
191: \g @code{class-map}.
192: over >body ( xt sel-xt class-map selector-body )
193: selector-interface @ ( xt sel-xt class-map offset )
194: ?dup-if \ the selector is for an interface
195: 2dup unique-interface-map
196: + @
197: then
198: interface-override! ;
199:
200: : overrides ( xt "selector" -- ) \ objects
201: \g replace default method for @code{selector} in the current class
202: \g with @code{xt}. @code{overrides} must not be used during an
203: \g interface definition.
204: ' current-interface @ class->map class-override! ;
205:
206: \ interfaces
207:
208: \ every interface gets a different offset; the latest one is stored here
209: variable last-interface-offset 0 last-interface-offset !
210:
211: : interface ( -- ) \ objects
212: \g starts an interface definition.
213: interface% %allot >r
214: 0 0 r@ interface-map 2!
215: -1 cells last-interface-offset +!
216: last-interface-offset @ r@ interface-offset !
217: 0 r@ interface-map-offset !
218: r> current-interface ! ;
219:
220: : end-interface-noname ( -- interface ) \ objects
221: \g ends an interface definition. The resulting interface is
222: \g @code{interface}.
223: current-interface @ ;
224:
225: : end-interface ( "name" -- ) \ objects
226: \g @code{name} execution: @code{-- interface}@*
227: \g ends an interface definition. The resulting interface is
228: \g @code{interface}.
229: end-interface-noname constant ;
230:
231: \ classes
232:
233: : add-class-order ( n1 class -- wid1 ... widn n+n1 )
234: dup >r class-parent @
235: ?dup-if
236: recurse \ first add the search order for the parent class
237: then
238: r> class-wordlist @ swap 1+ ;
239:
240: : push-order ( class -- ) \ objects
241: \g add @code{class}'s wordlists to the search-order (in front)
242: >r get-order r> add-class-order set-order ;
243:
244: : class ( parent-class -- align offset ) \ objects
245: \g start a new class definition as a child of
246: \g @code{parent-class}. @code{align offset} are for use by
247: \g @code{field} etc.
248: class% %allot >r
249: dup interface-map 2@ save-mem r@ interface-map 2!
250: dup interface-map-offset @ r@ interface-map-offset !
251: r@ dup class->map !
252: 0 r@ interface-offset !
253: dup r@ class-parent !
254: wordlist r@ class-wordlist !
255: r@ current-interface !
256: r> push-order
257: class-inst-size 2@ ;
258:
259: : remove-class-order ( wid1 ... widn n+n1 class -- n1 )
260: \ note: no checks, whether the wordlists are correct
261: begin
262: >r nip 1-
263: r> class-parent @ dup 0=
264: until
265: drop ;
266:
267: : drop-order ( class -- ) \ objects
268: \g drops @code{class}'s wordlists from the search order. No
269: \g checking is made whether @code{class}'s wordlists are actually
270: \g on the search order.
271: >r get-order r> remove-class-order set-order ;
272:
273: : end-class-noname ( align offset -- class ) \ objects
274: \g ends a class definition. The resulting class is @code{class}.
275: current-interface @ dup drop-order class-inst-size 2!
276: end-interface-noname ;
277:
278: : end-class ( align offset "name" -- ) \ objects
279: \g @code{name} execution: @code{-- class}@*
280: \g ends a class definition. The resulting class is @code{class}.
281: \ name execution: ( -- class )
282: end-class-noname constant ;
283:
284: \ visibility control
285:
286: variable public-wordlist
287:
288: : protected ( -- ) \ objects
289: \g set the compilation wordlist to the current class's wordlist
290: current-interface @ class-wordlist @
291: dup get-current <>
292: if \ we are not protected already
293: get-current public-wordlist !
294: then
295: set-current ;
296:
297: : public ( -- ) \ objects
298: \g restore the compilation wordlist that was in effect before the
299: \g last @code{protected} that actually changed the compilation
300: \g wordlist.
301: public-wordlist @ set-current ;
302:
303: \ classes that implement interfaces
304:
305: : front-extend-mem ( addr1 u1 u -- addr addr2 u2 )
306: \ extend memory block allocated from the heap by u aus, with the
307: \ old stuff coming at the end
308: 2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 )
309: dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 )
310: free throw
311: r> dup r> ;
312:
313: : implementation ( interface -- ) \ objects
314: \g the current class implements @code{interface}. I.e., you can
315: \g use all selectors of the interface in the current class and its
316: \g descendents.
317: dup interface-offset @ ( interface offset )
318: current-interface @ interface-map-offset @ negate over - dup 0>
319: if \ the interface does not fit in the present class-map
320: >r current-interface @ interface-map 2@
321: r@ front-extend-mem
322: current-interface @ interface-map 2!
323: r@ erase
324: dup negate current-interface @ interface-map-offset !
325: r>
326: then ( interface offset n )
327: drop >r
328: interface-map 2@ save-mem drop ( map )
329: current-interface @ dup interface-map 2@ drop
330: swap interface-map-offset @ + r> + ! ;
331:
332: \ this/self, instance variables etc.
333:
334: \ rename "this" into "self" if you are a Smalltalk fiend
335: 0 value this ( -- object ) \ objects
336: \g the receiving object of the current method (aka active object).
337: : to-this ( object -- ) \ objects
338: \g sets @code{this} (used internally, but useful when debugging).
339: TO this ;
340:
341: \ another implementation, if you don't have (fast) values
342: \ variable thisp
343: \ : this ( -- object )
344: \ thisp @ ;
345: \ : to-this ( object -- )
346: \ thisp ! ;
347:
348: : m: ( -- xt colon-sys; run-time: object -- ) \ objects
349: \g start a method definition; @code{object} becomes new @code{this}.
350: :noname
351: POSTPONE this
352: POSTPONE >r
353: POSTPONE to-this ;
354:
355: : exitm ( -- ) \ objects
356: \g @code{exit} from a method; restore old @code{this}.
357: POSTPONE r>
358: POSTPONE to-this
359: POSTPONE exit ; immediate
360:
361: : ;m ( colon-sys --; run-time: -- ) \ objects
362: \g end a method definition; restore old @code{this}.
363: POSTPONE r>
364: POSTPONE to-this
365: POSTPONE ; ; immediate
366:
367: : catch ( ... xt -- ... n ) \ exception
368: \ make it safe to call CATCH within a method.
369: \ should also be done with all words containing CATCH.
370: this >r catch r> to-this ;
371:
372: \ the following is a bit roundabout; this is caused by the standard
373: \ disallowing to change the compilation wordlist between CREATE and
374: \ DOES> (see RFI 3)
375:
376: : inst-something ( align1 size1 align size xt "name" -- align2 size2 )
377: \ xt ( -- ) typically is for a DOES>-word
378: get-current >r
379: current-interface @ class-wordlist @ set-current
380: >r create-field r> execute
381: r> set-current ;
382:
383: : do-inst-var ( -- )
384: does> \ name execution: ( -- addr )
385: ( addr1 ) @ this + ;
386:
387: : inst-var ( align1 offset1 align size "name" -- align2 offset2 ) \ objects
388: \g @code{name} execution: @code{-- addr}@*
389: \g @code{addr} is the address of the field @code{name} in
390: \g @code{this} object.
391: ['] do-inst-var inst-something ;
392:
393: : do-inst-value ( -- )
394: does> \ name execution: ( -- w )
395: ( addr1 ) @ this + @ ;
396:
397: : inst-value ( align1 offset1 "name" -- align2 offset2 ) \ objects
398: \g @code{name} execution: @code{-- w}@*
399: \g @code{w} is the value of the field @code{name} in @code{this}
400: \g object.
401: cell% ['] do-inst-value inst-something ;
402:
403: : <to-inst> ( w xt -- ) \ objects
404: \g store @code{w} into the field @code{xt} in @code{this} object.
405: >body @ this + ! ;
406:
407: : [to-inst] ( compile-time: "name" -- ; run-time: w -- ) \ objects
408: \g store @code{w} into field @code{name} in @code{this} object.
409: ' >body @ POSTPONE literal
410: POSTPONE this
411: POSTPONE +
412: POSTPONE ! ; immediate
413:
414: \ class binding stuff
415:
416: : <bind> ( class selector-xt -- xt ) \ objects
417: \g @code{xt} is the method for the selector @code{selector-xt} in
418: \g @code{class}.
419: >body swap class->map over selector-interface @
420: ?dup-if
421: + @
422: then
423: swap selector-offset @ + @ ;
424:
425: : bind' ( "class" "selector" -- xt ) \ objects
426: \g @code{xt} is the method for @code{selector} in @code{class}.
427: ' execute ' <bind> ;
428:
429: : bind ( ... "class" "selector" -- ... ) \ objects
430: \g execute the method for @code{selector} in @code{class}.
431: bind' execute ;
432:
433: : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) \ objects
434: \g compile the method for @code{selector} in @code{class}.
435: bind' compile, ; immediate
436:
437: : current' ( "selector" -- xt ) \ objects
438: \g @code{xt} is the method for @code{selector} in the current class.
439: current-interface @ ' <bind> ;
440:
441: : [current] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects
442: \g compile the method for @code{selector} in the current class.
443: current' compile, ; immediate
444:
445: : [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects
446: \g compile the method for @code{selector} in the parent of the
447: \g current class.
448: current-interface @ class-parent @ ' <bind> compile, ; immediate
449:
450: \ the object class
451:
452: \ because OBJECT has no parent class, we have to build it by hand
453: \ (instead of with class)
454:
455: class% %allot current-interface !
456: current-interface 1 cells save-mem current-interface @ interface-map 2!
457: 0 current-interface @ interface-map-offset !
458: 0 current-interface @ interface-offset !
459: 0 current-interface @ class-parent !
460: wordlist current-interface @ class-wordlist !
461: object%
462: current-interface @ push-order
463:
464: ' drop ( object -- )
465: method construct ( ... object -- ) \ objects
466: \g initializes the data fields of @code{object}. The method for the
467: \g class @code{object} just does nothing @code{( object -- )}.
468:
469: :noname ( object -- )
470: ." object:" dup . ." class:" object-map @ @ . ;
471: method print ( object -- ) \ objects
472: \g prints the object. The method for the class @code{object} prints
473: \g the address of the object and the address of its class.
474:
475: end-class object ( -- class ) \ objects
476: \g the ancestor of all classes.
477:
478: \ constructing objects
479:
480: : init-object ( ... class object -- ) \ objects
481: \g initializes a chunk of memory (@code{object}) to an object of
482: \g class @code{class}; then performs @code{construct}.
483: swap class->map over object-map ! ( ... object )
484: construct ;
485:
486: : xt-new ( ... class xt -- object ) \ objects
487: \g makes a new object, using @code{xt ( align size -- addr )} to
488: \g get memory.
489: over class-inst-size 2@ rot execute
490: dup >r init-object r> ;
491:
492: : dict-new ( ... class -- object ) \ objects
493: \g @code{allot} and initialize an object of class @code{class} in
494: \g the dictionary.
495: ['] %allot xt-new ;
496:
497: : heap-new ( ... class -- object ) \ objects
498: \g @code{allocate} and initialize an object of class @code{class}.
499: ['] %alloc xt-new ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>