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