File:
[gforth] /
gforth /
objects.fs
Revision
1.4:
download - view:
text,
annotated -
select for diffs
Mon Jun 23 15:53:53 1997 UTC (26 years, 9 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
changed compat/struct.fs and objects.fs for <align size> representation
refixed -trainling (in prim)
gforth.ds bug fixes
fixed/worked around declarations in forth.h
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: : -rot ( a b c -- c a b )
45: rot rot ;
46:
47: : under+ ( a b c -- a+c b )
48: rot + swap ;
49:
50: : perform ( ... addr -- ... )
51: @ execute ;
52:
53: : ?dup-if ( compilation: -- orig ; run-time: n -- n| )
54: POSTPONE ?dup POSTPONE if ; immediate
55:
56: : save-mem ( addr1 u -- addr2 u ) \ gforth
57: \ copy a memory block into a newly allocated region in the heap
58: swap >r
59: dup allocate throw
60: swap 2dup r> -rot move ;
61:
62: : resize ( a-addr1 u -- a-addr2 ior ) \ gforth
63: over
64: if
65: resize
66: else
67: nip allocate
68: then ;
69:
70: : extend-mem ( addr1 u1 u -- addr addr2 u2 )
71: \ extend memory block allocated from the heap by u aus
72: \ the (possibly reallocated) piece is addr2 u2, the extension is at addr
73: over >r + dup >r resize throw
74: r> over r> + -rot ;
75:
76: \ data structures
77:
78: struct
79: cell% field object-map
80: end-struct object%
81:
82: struct
83: cell% 2* field interface-map
84: cell% field interface-map-offset \ aus
85: \ difference between where interface-map points and where
86: \ object-map points (0 for non-classes)
87: cell% field interface-offset \ aus
88: \ offset of interface map-pointer in class-map (0 for classes)
89: end-struct interface%
90:
91: interface%
92: cell% field class-parent
93: cell% field class-wordlist \ instance variables and other private words
94: cell% 2* field class-inst-size \ size and alignment
95: end-struct class%
96:
97: struct
98: cell% field selector-offset \ the offset within the (interface) map
99: cell% field selector-interface \ the interface offset
100: end-struct selector%
101:
102: \ maps are not defined explicitly; they have the following structure:
103:
104: \ pointers to interface maps (for classes) <- interface-map points here
105: \ interface%/class% pointer <- (object-)map points here
106: \ xts of methods
107:
108:
109: \ code
110:
111: \ selectors and methods
112:
113: variable current-interface
114:
115: : no-method ( -- )
116: true abort" no method defined for this object/selector combination" ;
117:
118: : do-class-method ( -- )
119: does> ( ... object -- ... )
120: ( object )
121: selector-offset @ over object-map @ + ( object xtp ) perform ;
122:
123: : do-interface-method ( -- )
124: does> ( ... object -- ... )
125: ( object selector-body )
126: 2dup selector-interface @ ( object selector-body object interface-offset )
127: swap object-map @ + @ ( object selector-body map )
128: swap selector-offset @ + perform ;
129:
130: : method ( xt "name" -- )
131: \ define selector with method xt
132: create
133: current-interface @ interface-map 2@ ( xt map-addr map-size )
134: dup current-interface @ interface-map-offset @ - ,
135: 1 cells extend-mem current-interface @ interface-map 2! ! ( )
136: current-interface @ interface-offset @ dup ,
137: ( 0<> ) if
138: do-interface-method
139: else
140: do-class-method
141: then ;
142:
143: : selector ( "name" -- )
144: \ define a method selector for later overriding in subclasses
145: ['] no-method method ;
146:
147: : interface-override! ( xt sel-xt interface-map -- )
148: \ xt is the new method for the selector sel-xt in interface-map
149: swap >body ( xt map selector-body )
150: selector-offset @ + ! ;
151:
152: : class->map ( class -- map )
153: \ compute the (object-)map for the class
154: dup interface-map 2@ drop swap interface-map-offset @ + ;
155:
156: : unique-interface-map ( class-map offset -- )
157: \ if the interface at offset in class map is the same as its parent,
158: \ copy it to make it unique; used for implementing a copy-on-write policy
159: over @ class-parent @ class->map ( class-map offset parent-map )
160: over + @ >r \ the map for the interface for the parent
161: + dup @ ( mapp map )
162: dup r> =
163: if
164: @ interface-map 2@ save-mem drop
165: swap !
166: else
167: 2drop
168: then ;
169:
170: : class-override! ( xt sel-xt class-map -- )
171: \ xt is the new method for the selector sel-xt in class-map
172: over >body ( xt sel-xt class-map selector-body )
173: selector-interface @ ( xt sel-xt class-map offset )
174: ?dup-if \ the selector is for an interface
175: 2dup unique-interface-map
176: + @
177: then
178: interface-override! ;
179:
180: : overrides ( xt "selector" -- )
181: \ replace default method "method" in the current class with xt
182: \ must not be used during an interface definition
183: ' current-interface @ class->map class-override! ;
184:
185: \ interfaces
186:
187: \ every interface gets a different offset; the latest one is stored here
188: variable last-interface-offset 0 last-interface-offset !
189:
190: : interface ( -- )
191: interface% %allot >r
192: 0 0 r@ interface-map 2!
193: -1 cells last-interface-offset +!
194: last-interface-offset @ r@ interface-offset !
195: 0 r@ interface-map-offset !
196: r> current-interface ! ;
197:
198: : end-interface-noname ( -- interface )
199: current-interface @ ;
200:
201: : end-interface ( "name" -- )
202: \ name execution: ( -- interface )
203: end-interface-noname constant ;
204:
205: \ classes
206:
207: : add-class-order ( n1 class -- wid1 ... widn n+n1 )
208: dup >r class-parent @
209: ?dup-if
210: recurse \ first add the search order for the parent class
211: then
212: r> class-wordlist @ swap 1+ ;
213:
214: : push-order ( class -- )
215: \ add the class's wordlist to the search-order (in front)
216: >r get-order r> add-class-order set-order ;
217:
218: : class ( parent-class -- align size )
219: class% %allot >r
220: dup interface-map 2@ save-mem r@ interface-map 2!
221: dup interface-map-offset @ r@ interface-map-offset !
222: r@ dup class->map !
223: 0 r@ interface-offset !
224: dup r@ class-parent !
225: wordlist r@ class-wordlist !
226: r@ current-interface !
227: r> push-order
228: class-inst-size 2@ ;
229:
230: : remove-class-order ( wid1 ... widn n+n1 class -- n1 )
231: \ note: no checks, whether the wordlists are correct
232: begin
233: >r nip 1-
234: r> class-parent @ dup 0=
235: until
236: drop ;
237:
238: : drop-order ( class -- )
239: \ note: no checks, whether the wordlists are correct
240: >r get-order r> remove-class-order set-order ;
241:
242: : end-class-noname ( align size -- class )
243: current-interface @ dup drop-order class-inst-size 2!
244: end-interface-noname ;
245:
246: : end-class ( align size "name" -- )
247: \ name execution: ( -- class )
248: end-class-noname constant ;
249:
250: \ visibility control
251:
252: variable public-wordlist
253:
254: : protected ( -- )
255: current-interface @ class-wordlist @
256: dup get-current <>
257: if \ we are not protected already
258: get-current public-wordlist !
259: then
260: set-current ;
261:
262: : public ( -- )
263: public-wordlist @ set-current ;
264:
265: \ classes that implement interfaces
266:
267: : front-extend-mem ( addr1 u1 u -- addr addr2 u2 )
268: \ extend memory block allocated from the heap by u aus, with the
269: \ old stuff coming at the end
270: 2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 )
271: dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 )
272: free throw
273: r> dup r> ;
274:
275: : implementation ( interface -- )
276: dup interface-offset @ ( interface offset )
277: current-interface @ interface-map-offset @ negate over - dup 0>
278: if \ the interface does not fit in the present class-map
279: >r current-interface @ interface-map 2@
280: r@ front-extend-mem
281: current-interface @ interface-map 2!
282: r@ erase
283: dup negate current-interface @ interface-map-offset !
284: r>
285: then ( interface offset n )
286: drop >r
287: interface-map 2@ save-mem drop ( map )
288: current-interface @ dup interface-map 2@ drop
289: swap interface-map-offset @ + r> + ! ;
290:
291: \ this/self, instance variables etc.
292:
293: \ rename "this" into "self" if you are a Smalltalk fiend
294: 0 value this ( -- object )
295: : to-this ( object -- )
296: TO this ;
297:
298: \ another implementation, if you don't have (fast) values
299: \ variable thisp
300: \ : this ( -- object )
301: \ thisp @ ;
302: \ : to-this ( object -- )
303: \ thisp ! ;
304:
305: : m: ( -- xt colon-sys ) ( run-time: object -- )
306: :noname
307: POSTPONE this
308: POSTPONE >r
309: POSTPONE to-this ;
310:
311: : ;m ( colon-sys -- ) ( run-time: -- )
312: POSTPONE r>
313: POSTPONE to-this
314: POSTPONE ; ; immediate
315:
316: : catch ( ... xt -- ... n )
317: \ make it safe to call CATCH within a method.
318: \ should also be done with all words containing CATCH.
319: this >r catch r> to-this ;
320:
321: \ the following is a bit roundabout; this is caused by the standard
322: \ disallowing to change the compilation wordlist between CREATE and
323: \ DOES> (see RFI 3)
324:
325: : inst-something ( align1 size1 align size xt "name" -- align2 size2 )
326: \ xt ( -- ) typically is for a DOES>-word
327: get-current >r
328: current-interface @ class-wordlist @ set-current
329: >r create-field r> execute
330: r> set-current ;
331:
332: : do-inst-var ( -- )
333: does> \ name execution: ( -- addr )
334: ( addr1 ) @ this + ;
335:
336: : inst-var ( align1 offset1 align size "name" -- align2 offset2 )
337: \ name execution: ( -- addr )
338: ['] do-inst-var inst-something ;
339:
340: : do-inst-value ( -- )
341: does> \ name execution: ( -- w )
342: ( addr1 ) @ this + @ ;
343:
344: : inst-value ( align1 offset1 "name" -- align2 offset2 )
345: \ name execution: ( -- w )
346: \ a cell-sized value-flavoured instance field
347: cell% ['] do-inst-value inst-something ;
348:
349: : <to-inst> ( w xt -- )
350: >body @ this + ! ;
351:
352: : [to-inst] ( compile-time: "name" -- ; run-time: w -- )
353: ' >body @ POSTPONE literal
354: POSTPONE this
355: POSTPONE +
356: POSTPONE ! ; immediate
357:
358: \ class binding stuff
359:
360: : <bind> ( class selector-xt -- xt )
361: >body swap class->map over selector-interface @
362: ?dup-if
363: + @
364: then
365: swap selector-offset @ + @ ;
366:
367: : bind' ( "class" "selector" -- xt )
368: ' execute ' <bind> ;
369:
370: : bind ( ... object "class" "selector" -- ... )
371: bind' execute ;
372:
373: : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... )
374: bind' compile, ; immediate
375:
376: : current' ( "selector" -- xt )
377: current-interface @ ' <bind> ;
378:
379: : [current] ( compile-time: "selector" -- ; run-time: ... object -- ... )
380: current' compile, ; immediate
381:
382: : [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... )
383: \ same as `[bind] "parent" "selector"', where "parent" is the
384: \ parent class of the current class
385: current-interface @ class-parent @ ' <bind> compile, ; immediate
386:
387: \ the object class
388:
389: \ because OBJECT has no parent class, we have to build it by hand
390: \ (instead of with class)
391:
392: class% %allot current-interface !
393: current-interface 1 cells save-mem current-interface @ interface-map 2!
394: 0 current-interface @ interface-map-offset !
395: 0 current-interface @ interface-offset !
396: 0 current-interface @ class-parent !
397: wordlist current-interface @ class-wordlist !
398: object%
399: current-interface @ push-order
400:
401: :noname ( object -- )
402: drop ;
403: method construct ( ... object -- )
404:
405: :noname ( object -- )
406: ." object:" dup . ." class:" object-map @ @ . ;
407: method print
408:
409: end-class object
410:
411: \ constructing objects
412:
413: : init-object ( ... class object -- )
414: swap class->map over object-map ! ( ... object )
415: construct ;
416:
417: : xt-new ( ... class xt -- object )
418: \ makes a new object, using XT ( align size -- addr ) to allocate memory
419: over class-inst-size 2@ rot execute
420: dup >r init-object r> ;
421:
422: : dict-new ( ... class -- object )
423: \ makes a new object HERE in dictionary
424: ['] %allot xt-new ;
425:
426: : heap-new ( ... class -- object )
427: \ makes a new object in ALLOCATEd memory
428: ['] %alloc xt-new ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>