Annotation of gforth/objects.fs, revision 1.19
1.1 anton 1: \ yet another Forth objects extension
2:
1.19 ! anton 3: \ written by Anton Ertl 1996-2000
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:
1.6 anton 44: s" gforth" environment? [if]
45: 2drop
46: [else]
47:
1.1 anton 48: : -rot ( a b c -- c a b )
49: rot rot ;
50:
51: : perform ( ... addr -- ... )
52: @ execute ;
53:
1.3 anton 54: : ?dup-if ( compilation: -- orig ; run-time: n -- n| )
55: POSTPONE ?dup POSTPONE if ; immediate
56:
1.1 anton 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:
1.3 anton 63: : resize ( a-addr1 u -- a-addr2 ior ) \ gforth
64: over
65: if
66: resize
67: else
68: nip allocate
69: then ;
70:
1.1 anton 71: : extend-mem ( addr1 u1 u -- addr addr2 u2 )
72: \ extend memory block allocated from the heap by u aus
1.4 anton 73: \ the (possibly reallocated) piece is addr2 u2, the extension is at addr
1.1 anton 74: over >r + dup >r resize throw
75: r> over r> + -rot ;
76:
1.6 anton 77: : \g ( -- )
78: postpone \ ; immediate
79: [then]
80:
1.3 anton 81: \ data structures
1.1 anton 82:
83: struct
1.4 anton 84: cell% field object-map
85: end-struct object%
1.1 anton 86:
87: struct
1.4 anton 88: cell% 2* field interface-map
89: cell% field interface-map-offset \ aus
1.3 anton 90: \ difference between where interface-map points and where
91: \ object-map points (0 for non-classes)
1.4 anton 92: cell% field interface-offset \ aus
1.3 anton 93: \ offset of interface map-pointer in class-map (0 for classes)
1.4 anton 94: end-struct interface%
1.3 anton 95:
1.4 anton 96: interface%
97: cell% field class-parent
1.5 anton 98: cell% field class-wordlist \ inst-vars and other protected words
1.10 anton 99: cell% 2* field class-inst-size ( class -- addr ) \ objects- objects
1.12 crook 100: \g Give the size specification for an instance (i.e. an object)
101: \g of @var{class};
102: \g used as @code{class-inst-size 2@ ( class -- align size )}.
1.4 anton 103: end-struct class%
1.1 anton 104:
1.3 anton 105: struct
1.4 anton 106: cell% field selector-offset \ the offset within the (interface) map
107: cell% field selector-interface \ the interface offset
108: end-struct selector%
1.3 anton 109:
110: \ maps are not defined explicitly; they have the following structure:
111:
112: \ pointers to interface maps (for classes) <- interface-map points here
1.4 anton 113: \ interface%/class% pointer <- (object-)map points here
1.3 anton 114: \ xts of methods
115:
1.1 anton 116:
1.3 anton 117: \ code
1.1 anton 118:
1.3 anton 119: \ selectors and methods
120:
1.10 anton 121: variable current-interface ( -- addr ) \ objects- objects
1.12 crook 122: \g Variable: contains the class or interface currently being
1.6 anton 123: \g defined.
124:
125:
1.1 anton 126:
127: : no-method ( -- )
1.3 anton 128: true abort" no method defined for this object/selector combination" ;
129:
130: : do-class-method ( -- )
131: does> ( ... object -- ... )
1.5 anton 132: ( object selector-body )
1.3 anton 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 ;
1.1 anton 141:
1.10 anton 142: : method ( xt "name" -- ) \ objects- objects
1.6 anton 143: \g @code{name} execution: @code{... object -- ...}@*
1.12 crook 144: \g Create selector @var{name} and makes @var{xt} its method in
1.6 anton 145: \g the current class.
1.3 anton 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 ;
1.1 anton 156:
1.10 anton 157: : selector ( "name" -- ) \ objects- objects
1.12 crook 158: \g @var{name} execution: @code{... object -- ...}@*
159: \g Create selector @var{name} for the current class and its
1.6 anton 160: \g descendents; you can set a method for the selector in the
161: \g current class with @code{overrides}.
1.1 anton 162: ['] no-method method ;
163:
1.3 anton 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:
1.10 anton 169: : class->map ( class -- map ) \ objects- objects
1.12 crook 170: \g @var{map} is the pointer to @var{class}'s method map; it
1.6 anton 171: \g points to the place in the map to which the selector offsets
1.12 crook 172: \g refer (i.e., where @var{object-map}s point to).
1.3 anton 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
1.9 anton 180: + dup @ ( interface-mapp interface-map )
1.3 anton 181: dup r> =
182: if
1.9 anton 183: dup @ interface-map 2@ nip save-mem drop
1.3 anton 184: swap !
185: else
186: 2drop
187: then ;
188:
1.10 anton 189: : class-override! ( xt sel-xt class-map -- ) \ objects- objects
1.12 crook 190: \g @var{xt} is the new method for the selector @var{sel-xt} in
191: \g @var{class-map}.
1.3 anton 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! ;
1.1 anton 199:
1.10 anton 200: : overrides ( xt "selector" -- ) \ objects- objects
1.12 crook 201: \g replace default method for @var{selector} in the current class
202: \g with @var{xt}. @code{overrides} must not be used during an
1.6 anton 203: \g interface definition.
1.3 anton 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:
1.10 anton 211: : interface ( -- ) \ objects- objects
1.12 crook 212: \g Start an interface definition.
1.4 anton 213: interface% %allot >r
1.8 anton 214: r@ current-interface !
215: current-interface 1 cells save-mem r@ interface-map 2!
1.3 anton 216: -1 cells last-interface-offset +!
217: last-interface-offset @ r@ interface-offset !
1.8 anton 218: 0 r> interface-map-offset ! ;
1.3 anton 219:
1.10 anton 220: : end-interface-noname ( -- interface ) \ objects- objects
1.12 crook 221: \g End an interface definition. The resulting interface is
222: \g @var{interface}.
1.3 anton 223: current-interface @ ;
224:
1.10 anton 225: : end-interface ( "name" -- ) \ objects- objects
1.6 anton 226: \g @code{name} execution: @code{-- interface}@*
1.12 crook 227: \g End an interface definition. The resulting interface is
228: \g @var{interface}.
1.3 anton 229: end-interface-noname constant ;
230:
1.13 anton 231: \ visibility control
232:
233: variable public-wordlist
234:
235: : protected ( -- ) \ objects- objects
236: \g Set the compilation wordlist to the current class's wordlist
237: current-interface @ class-wordlist @
238: dup get-current <>
239: if \ we are not protected already
240: get-current public-wordlist !
241: then
242: set-current ;
243:
244: : public ( -- ) \ objects- objects
245: \g Restore the compilation wordlist that was in effect before the
246: \g last @code{protected} that actually changed the compilation
247: \g wordlist.
248: current-interface @ class-wordlist @ get-current =
249: if \ we are protected
250: public-wordlist @ set-current
251: then ;
252:
1.3 anton 253: \ classes
254:
255: : add-class-order ( n1 class -- wid1 ... widn n+n1 )
256: dup >r class-parent @
257: ?dup-if
258: recurse \ first add the search order for the parent class
259: then
260: r> class-wordlist @ swap 1+ ;
261:
1.18 anton 262: : class>order ( class -- ) \ objects- objects
1.12 crook 263: \g Add @var{class}'s wordlists to the head of the search-order.
1.3 anton 264: >r get-order r> add-class-order set-order ;
265:
1.18 anton 266: : push-order class>order ; \ old name
267:
1.15 anton 268: : methods ( class -- ) \ objects- objects
1.14 anton 269: \g Makes @var{class} the current class. This is intended to be
270: \g used for defining methods to override selectors; you cannot
271: \g define new fields or selectors.
1.18 anton 272: dup current-interface ! class>order ;
1.14 anton 273:
1.10 anton 274: : class ( parent-class -- align offset ) \ objects- objects
1.12 crook 275: \g Start a new class definition as a child of
276: \g @var{parent-class}. @var{align offset} are for use by
277: \g @var{field} etc.
1.4 anton 278: class% %allot >r
1.3 anton 279: dup interface-map 2@ save-mem r@ interface-map 2!
280: dup interface-map-offset @ r@ interface-map-offset !
281: r@ dup class->map !
282: 0 r@ interface-offset !
283: dup r@ class-parent !
284: wordlist r@ class-wordlist !
1.14 anton 285: r> methods
1.3 anton 286: class-inst-size 2@ ;
287:
288: : remove-class-order ( wid1 ... widn n+n1 class -- n1 )
289: \ note: no checks, whether the wordlists are correct
290: begin
291: >r nip 1-
292: r> class-parent @ dup 0=
293: until
294: drop ;
295:
1.18 anton 296: : class-previous ( class -- ) \ objects- objects
1.12 crook 297: \g Drop @var{class}'s wordlists from the search order. No
298: \g checking is made whether @var{class}'s wordlists are actually
1.6 anton 299: \g on the search order.
1.3 anton 300: >r get-order r> remove-class-order set-order ;
301:
1.18 anton 302: : drop-order class-previous ; \ old name
303:
1.15 anton 304: : end-methods ( -- ) \ objects- objects
1.14 anton 305: \g Switch back from defining methods of a class to normal mode
306: \g (currently this just restores the old search order).
1.18 anton 307: current-interface @ class-previous ;
1.14 anton 308:
1.10 anton 309: : end-class-noname ( align offset -- class ) \ objects- objects
1.12 crook 310: \g End a class definition. The resulting class is @var{class}.
1.14 anton 311: public end-methods
312: current-interface @ class-inst-size 2!
1.3 anton 313: end-interface-noname ;
314:
1.10 anton 315: : end-class ( align offset "name" -- ) \ objects- objects
1.12 crook 316: \g @var{name} execution: @code{-- class}@*
317: \g End a class definition. The resulting class is @var{class}.
1.3 anton 318: \ name execution: ( -- class )
319: end-class-noname constant ;
320:
321: \ classes that implement interfaces
322:
323: : front-extend-mem ( addr1 u1 u -- addr addr2 u2 )
1.12 crook 324: \ Extend memory block allocated from the heap by u aus, with the
1.3 anton 325: \ old stuff coming at the end
326: 2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 )
327: dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 )
328: free throw
329: r> dup r> ;
330:
1.10 anton 331: : implementation ( interface -- ) \ objects- objects
1.12 crook 332: \g The current class implements @var{interface}. I.e., you can
1.6 anton 333: \g use all selectors of the interface in the current class and its
334: \g descendents.
1.3 anton 335: dup interface-offset @ ( interface offset )
336: current-interface @ interface-map-offset @ negate over - dup 0>
337: if \ the interface does not fit in the present class-map
338: >r current-interface @ interface-map 2@
339: r@ front-extend-mem
340: current-interface @ interface-map 2!
341: r@ erase
342: dup negate current-interface @ interface-map-offset !
343: r>
344: then ( interface offset n )
345: drop >r
346: interface-map 2@ save-mem drop ( map )
347: current-interface @ dup interface-map 2@ drop
348: swap interface-map-offset @ + r> + ! ;
1.1 anton 349:
350: \ this/self, instance variables etc.
351:
1.3 anton 352: \ rename "this" into "self" if you are a Smalltalk fiend
1.10 anton 353: 0 value this ( -- object ) \ objects- objects
1.6 anton 354: \g the receiving object of the current method (aka active object).
1.10 anton 355: : to-this ( object -- ) \ objects- objects
1.12 crook 356: \g Set @code{this} (used internally, but useful when debugging).
1.3 anton 357: TO this ;
358:
359: \ another implementation, if you don't have (fast) values
360: \ variable thisp
361: \ : this ( -- object )
362: \ thisp @ ;
363: \ : to-this ( object -- )
364: \ thisp ! ;
1.1 anton 365:
1.16 anton 366: : enterm ( -- ; run-time: object -- )
367: \g method prologue; @var{object} becomes new @code{this}.
1.1 anton 368: POSTPONE this
369: POSTPONE >r
1.3 anton 370: POSTPONE to-this ;
1.16 anton 371:
372: : m: ( -- xt colon-sys; run-time: object -- ) \ objects- objects
373: \g Start a method definition; @var{object} becomes new @code{this}.
374: :noname enterm ;
375:
376: : :m ( "name" -- xt; run-time: object -- ) \ objects- objects
377: \g Start a named method definition; @var{object} becomes new
378: \g @code{this}. Has to be ended with @code{;m}.
379: : enterm ;
1.1 anton 380:
1.10 anton 381: : exitm ( -- ) \ objects- objects
1.6 anton 382: \g @code{exit} from a method; restore old @code{this}.
1.5 anton 383: POSTPONE r>
384: POSTPONE to-this
385: POSTPONE exit ; immediate
386:
1.10 anton 387: : ;m ( colon-sys --; run-time: -- ) \ objects- objects
1.12 crook 388: \g End a method definition; restore old @code{this}.
1.1 anton 389: POSTPONE r>
1.3 anton 390: POSTPONE to-this
1.1 anton 391: POSTPONE ; ; immediate
392:
1.7 anton 393: : catch ( ... xt -- ... n ) \ exception
1.12 crook 394: \ Make it safe to call CATCH within a method.
1.1 anton 395: \ should also be done with all words containing CATCH.
1.3 anton 396: this >r catch r> to-this ;
397:
398: \ the following is a bit roundabout; this is caused by the standard
399: \ disallowing to change the compilation wordlist between CREATE and
400: \ DOES> (see RFI 3)
401:
1.4 anton 402: : inst-something ( align1 size1 align size xt "name" -- align2 size2 )
1.3 anton 403: \ xt ( -- ) typically is for a DOES>-word
404: get-current >r
405: current-interface @ class-wordlist @ set-current
406: >r create-field r> execute
407: r> set-current ;
1.1 anton 408:
1.3 anton 409: : do-inst-var ( -- )
410: does> \ name execution: ( -- addr )
1.1 anton 411: ( addr1 ) @ this + ;
412:
1.10 anton 413: : inst-var ( align1 offset1 align size "name" -- align2 offset2 ) \ objects- objects
1.12 crook 414: \g @var{name} execution: @code{-- addr}@*
415: \g @var{addr} is the address of the field @var{name} in
1.6 anton 416: \g @code{this} object.
1.3 anton 417: ['] do-inst-var inst-something ;
418:
419: : do-inst-value ( -- )
420: does> \ name execution: ( -- w )
421: ( addr1 ) @ this + @ ;
422:
1.10 anton 423: : inst-value ( align1 offset1 "name" -- align2 offset2 ) \ objects- objects
1.12 crook 424: \g @var{name} execution: @code{-- w}@*
425: \g @var{w} is the value of the field @var{name} in @code{this}
1.6 anton 426: \g object.
1.4 anton 427: cell% ['] do-inst-value inst-something ;
1.3 anton 428:
1.10 anton 429: : <to-inst> ( w xt -- ) \ objects- objects
1.12 crook 430: \g store @var{w} into the field @var{xt} in @code{this} object.
1.3 anton 431: >body @ this + ! ;
432:
1.10 anton 433: : [to-inst] ( compile-time: "name" -- ; run-time: w -- ) \ objects- objects
1.12 crook 434: \g store @var{w} into field @var{name} in @code{this} object.
1.3 anton 435: ' >body @ POSTPONE literal
436: POSTPONE this
437: POSTPONE +
438: POSTPONE ! ; immediate
439:
1.4 anton 440: \ class binding stuff
1.1 anton 441:
1.10 anton 442: : <bind> ( class selector-xt -- xt ) \ objects- objects
1.12 crook 443: \g @var{xt} is the method for the selector @var{selector-xt} in
444: \g @var{class}.
1.3 anton 445: >body swap class->map over selector-interface @
446: ?dup-if
447: + @
448: then
449: swap selector-offset @ + @ ;
1.1 anton 450:
1.10 anton 451: : bind' ( "class" "selector" -- xt ) \ objects- objects
1.12 crook 452: \g @var{xt} is the method for @var{selector} in @var{class}.
1.3 anton 453: ' execute ' <bind> ;
1.1 anton 454:
1.10 anton 455: : bind ( ... "class" "selector" -- ... ) \ objects- objects
1.12 crook 456: \g Execute the method for @var{selector} in @var{class}.
1.1 anton 457: bind' execute ;
458:
1.10 anton 459: : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) \ objects- objects
1.12 crook 460: \g Compile the method for @var{selector} in @var{class}.
1.1 anton 461: bind' compile, ; immediate
462:
1.10 anton 463: : current' ( "selector" -- xt ) \ objects- objects
1.12 crook 464: \g @var{xt} is the method for @var{selector} in the current class.
1.4 anton 465: current-interface @ ' <bind> ;
466:
1.10 anton 467: : [current] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects
1.12 crook 468: \g Compile the method for @var{selector} in the current class.
1.4 anton 469: current' compile, ; immediate
470:
1.10 anton 471: : [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects
1.12 crook 472: \g Compile the method for @var{selector} in the parent of the
1.6 anton 473: \g current class.
1.3 anton 474: current-interface @ class-parent @ ' <bind> compile, ; immediate
475:
1.1 anton 476: \ the object class
477:
1.3 anton 478: \ because OBJECT has no parent class, we have to build it by hand
479: \ (instead of with class)
480:
1.4 anton 481: class% %allot current-interface !
482: current-interface 1 cells save-mem current-interface @ interface-map 2!
483: 0 current-interface @ interface-map-offset !
484: 0 current-interface @ interface-offset !
485: 0 current-interface @ class-parent !
486: wordlist current-interface @ class-wordlist !
487: object%
1.18 anton 488: current-interface @ class>order
1.3 anton 489:
1.5 anton 490: ' drop ( object -- )
1.10 anton 491: method construct ( ... object -- ) \ objects- objects
1.12 crook 492: \g Initialize the data fields of @var{object}. The method for the
493: \g class @var{object} just does nothing: @code{( object -- )}.
1.3 anton 494:
495: :noname ( object -- )
496: ." object:" dup . ." class:" object-map @ @ . ;
1.10 anton 497: method print ( object -- ) \ objects- objects
1.12 crook 498: \g Print the object. The method for the class @var{object} prints
1.6 anton 499: \g the address of the object and the address of its class.
1.3 anton 500:
1.17 anton 501: selector equal ( object1 object2 -- flag )
502:
1.10 anton 503: end-class object ( -- class ) \ objects- objects
1.6 anton 504: \g the ancestor of all classes.
1.1 anton 505:
1.3 anton 506: \ constructing objects
1.1 anton 507:
1.10 anton 508: : init-object ( ... class object -- ) \ objects- objects
1.12 crook 509: \g Initialize a chunk of memory (@var{object}) to an object of
510: \g class @var{class}; then performs @code{construct}.
1.3 anton 511: swap class->map over object-map ! ( ... object )
512: construct ;
513:
1.10 anton 514: : xt-new ( ... class xt -- object ) \ objects- objects
1.12 crook 515: \g Make a new object, using @code{xt ( align size -- addr )} to
1.6 anton 516: \g get memory.
1.3 anton 517: over class-inst-size 2@ rot execute
518: dup >r init-object r> ;
519:
1.10 anton 520: : dict-new ( ... class -- object ) \ objects- objects
1.12 crook 521: \g @code{allot} and initialize an object of class @var{class} in
1.6 anton 522: \g the dictionary.
1.4 anton 523: ['] %allot xt-new ;
1.3 anton 524:
1.10 anton 525: : heap-new ( ... class -- object ) \ objects- objects
1.12 crook 526: \g @code{allocate} and initialize an object of class @var{class}.
1.4 anton 527: ['] %alloc xt-new ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>