Annotation of gforth/objects.fs, revision 1.3
1.1 anton 1: \ yet another Forth objects extension
2:
1.3 ! anton 3: \ written by Anton Ertl 1996, 1997
1.1 anton 4: \ public domain
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: \ If you don't use Gforth, you have to load compat/struct.fs first.
11: \ compat/struct.fs and this file together use the following words:
12:
13: \ from CORE :
1.3 ! anton 14: \ : 1- + swap invert and ; DOES> @ immediate drop Create >r rot r@ dup
! 15: \ , IF ELSE THEN r> chars cells 2* here - allot over execute POSTPONE
! 16: \ ?dup 2dup move 2! Variable 2@ ! ['] >body = 2drop ' +! Constant
! 17: \ recurse 1+ BEGIN 0= UNTIL negate Literal ." .
1.2 anton 18: \ from CORE-EXT :
1.3 ! anton 19: \ tuck nip true <> 0> erase Value :noname compile,
1.2 anton 20: \ from BLOCK-EXT :
21: \ \
22: \ from DOUBLE :
1.3 ! anton 23: \ 2Constant
1.2 anton 24: \ from EXCEPTION :
25: \ throw catch
26: \ from EXCEPTION-EXT :
27: \ abort"
28: \ from FILE :
29: \ (
30: \ from FLOAT :
31: \ floats
32: \ from FLOAT-EXT :
33: \ dfloats sfloats
1.3 ! anton 34: \ from LOCAL :
! 35: \ TO
1.2 anton 36: \ from MEMORY :
1.3 ! anton 37: \ allocate resize free
! 38: \ from SEARCH :
! 39: \ get-order set-order wordlist get-current set-current
1.2 anton 40:
41: \ ---------------------------------------
42: \ MANUAL:
1.1 anton 43:
44: \ A class is defined like this:
45:
46: \ <parent> class
47: \ ... field <name>
48: \ ...
49:
50: \ ... inst-var <name>
51: \ ...
52:
53: \ selector <name>
54:
55: \ :noname ( ... object -- ... )
56: \ ... ;
57: \ method <name> \ new method
58: \ ...
59:
60: \ :noname ( ... object -- ... )
61: \ ... ;
62: \ overrides <name> \ existing method
63: \ ...
64:
65: \ end-class <name>
66:
67: \ you can write fields, inst-vars, selectors, methods and overrides in
68: \ any order.
69:
70: \ A call of a method looks like this:
71:
72: \ ... <object> <method>
73:
74: \ (<object> just needs to reside on the stack, there's no need to name it).
75:
76: \ Instead of defining a method with ':noname ... ;', you can define it
77: \ also with 'm: ... ;m'. The difference is that with ':noname' the
78: \ "self" object is on the top of stack; with 'm:' you can get it with
79: \ 'this'. You should use 'this' only in an 'm:' method even though the
80: \ sample implementation does not enforce this.
81:
82: \ The difference between a field and and inst-var is that the field
83: \ refers to an object at the top of data stack (i.e. a field has the
84: \ stack effect (object -- addr), whereas the inst-var refers to this
85: \ (i.e., it has the stack effect ( -- addr )); obviously, an inst-var
86: \ can only be used in an 'm:' method.
87:
88: \ 'method' defines a new method selector and binds a method to it.
89:
90: \ 'selector' defines a new method selector without binding a method to
91: \ it (you can use this to define abstract classes)
92:
93: \ 'overrides' binds a different method (than the parent class) to an
94: \ existing method selector.
95:
96: \ If you want to perform early binding, you can do it like this:
97:
98: \ ... <object> [bind] <class> <method> \ compilation
99: \ ... <object> bind <class> <method> \ interpretation
100:
101: \ You can get at the method from the method selector and the class like
102: \ this:
103:
104: \ bind' <class> <method>
1.3 ! anton 105:
! 106:
! 107: \ An interface is defined like this:
! 108:
! 109: \ interface
! 110: \ selector <name>
! 111: \ : noname ( ... object -- ... )
! 112: \ ... ;
! 113: \ method <name>
! 114: \ ...
! 115: \ end-interface <name>
! 116:
! 117: \ You can only define new selectors in an interface definition, no
! 118: \ fields or instance variables. If you define a selector with
! 119: \ 'method', the corresponding method becomes the default method for
! 120: \ this selector.
! 121:
! 122: \ An interface is used like this:
! 123:
! 124: \ <parent> class
! 125: \ <interface> implementation
! 126: \ <interface> implementation
! 127:
! 128: \ :noname ( ... -- ... )
! 129: \ ... ;
! 130: \ overrides <selector>
! 131:
! 132: \ end-class name
! 133:
! 134: \ a class inherits all interfaces of its parent. An 'implementation'
! 135: \ means that the class also implements the specified interface (If the
! 136: \ interface is already implemented by the parent class, an
! 137: \ 'implementation' phrase resets the methods to the defaults.
! 138:
! 139: \ 'overrides' can also be used to override interface methods. It has
! 140: \ to be used after announcing the 'implementation' of the
! 141: \ interface. Apart from this, 'implementation' can be freely mixed
! 142: \ with the other stuff (but I recommend to put all 'implementation'
! 143: \ phrases at the beginning of the class definition).
! 144:
1.1 anton 145: \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
146:
147: \ needs struct.fs
148:
149: \ helper words
150:
151: : -rot ( a b c -- c a b )
152: rot rot ;
153:
1.3 ! anton 154: : under+ ( a b c -- a+b c )
! 155: rot + swap ;
! 156:
1.1 anton 157: : perform ( ... addr -- ... )
158: @ execute ;
159:
1.3 ! anton 160: : ?dup-if ( compilation: -- orig ; run-time: n -- n| )
! 161: POSTPONE ?dup POSTPONE if ; immediate
! 162:
1.1 anton 163: : save-mem ( addr1 u -- addr2 u ) \ gforth
164: \ copy a memory block into a newly allocated region in the heap
165: swap >r
166: dup allocate throw
167: swap 2dup r> -rot move ;
168:
1.3 ! anton 169: : resize ( a-addr1 u -- a-addr2 ior ) \ gforth
! 170: over
! 171: if
! 172: resize
! 173: else
! 174: nip allocate
! 175: then ;
! 176:
1.1 anton 177: : extend-mem ( addr1 u1 u -- addr addr2 u2 )
178: \ extend memory block allocated from the heap by u aus
179: \ the (possibly reallocated piece is addr2 u2, the extension is at addr )
180: over >r + dup >r resize throw
181: r> over r> + -rot ;
182:
183: : 2, ( w1 w2 -- ) \ gforth
184: here 2 cells allot 2! ;
185:
1.3 ! anton 186: \ data structures
1.1 anton 187:
188: struct
189: 1 cells: field object-map
190: end-struct object-struct
191:
192: struct
1.3 ! anton 193: 2 cells: field interface-map
! 194: 1 cells: field interface-map-offset \ aus
! 195: \ difference between where interface-map points and where
! 196: \ object-map points (0 for non-classes)
! 197: 1 cells: field interface-offset \ aus
! 198: \ offset of interface map-pointer in class-map (0 for classes)
! 199: end-struct interface-struct
! 200:
! 201: interface-struct
! 202: 1 cells: field class-parent
! 203: 1 cells: field class-wordlist \ instance variables and other private words
! 204: 2 cells: field class-inst-size \ size and alignment
1.1 anton 205: end-struct class-struct
206:
1.3 ! anton 207: struct
! 208: 1 cells: field selector-offset \ the offset within the (interface) map
! 209: 1 cells: field selector-interface \ the interface offset
! 210: end-struct selector-struct
! 211:
! 212: \ maps are not defined explicitly; they have the following structure:
! 213:
! 214: \ pointers to interface maps (for classes) <- interface-map points here
! 215: \ interface/class-struct pointer <- (object-)map points here
! 216: \ xts of methods
! 217:
1.1 anton 218:
1.3 ! anton 219: \ code
1.1 anton 220:
1.3 ! anton 221: \ selectors and methods
! 222:
! 223: variable current-interface
1.1 anton 224:
225: : no-method ( -- )
1.3 ! anton 226: true abort" no method defined for this object/selector combination" ;
! 227:
! 228: : do-class-method ( -- )
! 229: does> ( ... object -- ... )
! 230: ( object )
! 231: selector-offset @ over object-map @ + ( object xtp ) perform ;
! 232:
! 233: : do-interface-method ( -- )
! 234: does> ( ... object -- ... )
! 235: ( object selector-body )
! 236: 2dup selector-interface @ ( object selector-body object interface-offset )
! 237: swap object-map @ + @ ( object selector-body map )
! 238: swap selector-offset @ + perform ;
1.1 anton 239:
240: : method ( xt "name" -- )
1.3 ! anton 241: \ define selector with method xt
! 242: create
! 243: current-interface @ interface-map 2@ ( xt map-addr map-size )
! 244: dup current-interface @ interface-map-offset @ - ,
! 245: 1 cells extend-mem current-interface @ interface-map 2! ! ( )
! 246: current-interface @ interface-offset @ dup ,
! 247: ( 0<> ) if
! 248: do-interface-method
! 249: else
! 250: do-class-method
! 251: then ;
1.1 anton 252:
253: : selector ( "name" -- )
254: \ define a method selector for later overriding in subclasses
255: ['] no-method method ;
256:
1.3 ! anton 257: : interface-override! ( xt sel-xt interface-map -- )
! 258: \ xt is the new method for the selector sel-xt in interface-map
! 259: swap >body ( xt map selector-body )
! 260: selector-offset @ + ! ;
! 261:
! 262: : class->map ( class -- map )
! 263: \ compute the (object-)map for the class
! 264: dup interface-map 2@ drop swap interface-map-offset @ + ;
! 265:
! 266: : unique-interface-map ( class-map offset -- )
! 267: \ if the interface at offset in class map is the same as its parent,
! 268: \ copy it to make it unique; used for implementing a copy-on-write policy
! 269: over @ class-parent @ class->map ( class-map offset parent-map )
! 270: over + @ >r \ the map for the interface for the parent
! 271: + dup @ ( mapp map )
! 272: dup r> =
! 273: if
! 274: @ interface-map 2@ save-mem drop
! 275: swap !
! 276: else
! 277: 2drop
! 278: then ;
! 279:
! 280: : class-override! ( xt sel-xt class-map -- )
! 281: \ xt is the new method for the selector sel-xt in class-map
! 282: over >body ( xt sel-xt class-map selector-body )
! 283: selector-interface @ ( xt sel-xt class-map offset )
! 284: ?dup-if \ the selector is for an interface
! 285: 2dup unique-interface-map
! 286: + @
! 287: then
! 288: interface-override! ;
1.1 anton 289:
290: : overrides ( xt "selector" -- )
1.3 ! anton 291: \ replace default method "method" in the current class with xt
! 292: \ must not be used during an interface definition
! 293: ' current-interface @ class->map class-override! ;
! 294:
! 295: \ interfaces
! 296:
! 297: \ every interface gets a different offset; the latest one is stored here
! 298: variable last-interface-offset 0 last-interface-offset !
! 299:
! 300: : interface ( -- )
! 301: interface-struct struct-allot >r
! 302: 0 0 r@ interface-map 2!
! 303: -1 cells last-interface-offset +!
! 304: last-interface-offset @ r@ interface-offset !
! 305: 0 r@ interface-map-offset !
! 306: r> current-interface ! ;
! 307:
! 308: : end-interface-noname ( -- interface )
! 309: current-interface @ ;
! 310:
! 311: : end-interface ( "name" -- )
! 312: \ name execution: ( -- interface )
! 313: end-interface-noname constant ;
! 314:
! 315: \ classes
! 316:
! 317: : add-class-order ( n1 class -- wid1 ... widn n+n1 )
! 318: dup >r class-parent @
! 319: ?dup-if
! 320: recurse \ first add the search order for the parent class
! 321: then
! 322: r> class-wordlist @ swap 1+ ;
! 323:
! 324: : push-order ( class -- )
! 325: \ add the class's wordlist to the search-order (in front)
! 326: >r get-order r> add-class-order set-order ;
! 327:
! 328: : class ( parent-class -- size align )
! 329: class-struct struct-allot >r
! 330: dup interface-map 2@ save-mem r@ interface-map 2!
! 331: dup interface-map-offset @ r@ interface-map-offset !
! 332: r@ dup class->map !
! 333: 0 r@ interface-offset !
! 334: dup r@ class-parent !
! 335: wordlist r@ class-wordlist !
! 336: r@ current-interface !
! 337: r> push-order
! 338: class-inst-size 2@ ;
! 339:
! 340: : remove-class-order ( wid1 ... widn n+n1 class -- n1 )
! 341: \ note: no checks, whether the wordlists are correct
! 342: begin
! 343: >r nip 1-
! 344: r> class-parent @ dup 0=
! 345: until
! 346: drop ;
! 347:
! 348: : drop-order ( class -- )
! 349: \ note: no checks, whether the wordlists are correct
! 350: >r get-order r> remove-class-order set-order ;
! 351:
! 352: : end-class-noname ( size align -- class )
! 353: current-interface @ dup drop-order class-inst-size 2!
! 354: end-interface-noname ;
! 355:
! 356: : end-class ( size align "name" -- )
! 357: \ name execution: ( -- class )
! 358: end-class-noname constant ;
1.1 anton 359:
1.3 ! anton 360: \ visibility control
! 361:
! 362: variable public-wordlist
! 363:
! 364: : private ( -- )
! 365: current-interface @ class-wordlist @
! 366: dup get-current <>
! 367: if \ we are not private already
! 368: get-current public-wordlist !
! 369: then
! 370: set-current ;
! 371:
! 372: : public ( -- )
! 373: public-wordlist @ set-current ;
! 374:
! 375: \ classes that implement interfaces
! 376:
! 377: : front-extend-mem ( addr1 u1 u -- addr addr2 u2 )
! 378: \ extend memory block allocated from the heap by u aus, with the
! 379: \ old stuff coming at the end
! 380: 2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 )
! 381: dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 )
! 382: free throw
! 383: r> dup r> ;
! 384:
! 385: : implementation ( interface -- )
! 386: dup interface-offset @ ( interface offset )
! 387: current-interface @ interface-map-offset @ negate over - dup 0>
! 388: if \ the interface does not fit in the present class-map
! 389: >r current-interface @ interface-map 2@
! 390: r@ front-extend-mem
! 391: current-interface @ interface-map 2!
! 392: r@ erase
! 393: dup negate current-interface @ interface-map-offset !
! 394: r>
! 395: then ( interface offset n )
! 396: drop >r
! 397: interface-map 2@ save-mem drop ( map )
! 398: current-interface @ dup interface-map 2@ drop
! 399: swap interface-map-offset @ + r> + ! ;
1.1 anton 400:
401: \ this/self, instance variables etc.
402:
1.3 ! anton 403: \ rename "this" into "self" if you are a Smalltalk fiend
! 404: 0 value this ( -- object )
! 405: : to-this ( object -- )
! 406: TO this ;
! 407:
! 408: \ another implementation, if you don't have (fast) values
! 409: \ variable thisp
! 410: \ : this ( -- object )
! 411: \ thisp @ ;
! 412: \ : to-this ( object -- )
! 413: \ thisp ! ;
1.1 anton 414:
415: : m: ( -- xt colon-sys ) ( run-time: object -- )
416: :noname
417: POSTPONE this
418: POSTPONE >r
1.3 ! anton 419: POSTPONE to-this ;
1.1 anton 420:
421: : ;m ( colon-sys -- ) ( run-time: -- )
422: POSTPONE r>
1.3 ! anton 423: POSTPONE to-this
1.1 anton 424: POSTPONE ; ; immediate
425:
426: : catch ( ... xt -- ... n )
427: \ make it safe to call CATCH within a method.
428: \ should also be done with all words containing CATCH.
1.3 ! anton 429: this >r catch r> to-this ;
! 430:
! 431: \ the following is a bit roundabout; this is caused by the standard
! 432: \ disallowing to change the compilation wordlist between CREATE and
! 433: \ DOES> (see RFI 3)
! 434:
! 435: : inst-something ( size1 align1 size align xt "name" -- size2 align2 )
! 436: \ xt ( -- ) typically is for a DOES>-word
! 437: get-current >r
! 438: current-interface @ class-wordlist @ set-current
! 439: >r create-field r> execute
! 440: r> set-current ;
1.1 anton 441:
1.3 ! anton 442: : do-inst-var ( -- )
! 443: does> \ name execution: ( -- addr )
1.1 anton 444: ( addr1 ) @ this + ;
445:
1.3 ! anton 446: : inst-var ( size1 align1 size align "name" -- size2 align2 )
! 447: \ name execution: ( -- addr )
! 448: ['] do-inst-var inst-something ;
! 449:
! 450: : do-inst-value ( -- )
! 451: does> \ name execution: ( -- w )
! 452: ( addr1 ) @ this + @ ;
! 453:
! 454: : inst-value ( size1 align1 "name" -- size2 align2 )
! 455: \ name execution: ( -- w )
! 456: \ a cell-sized value-flavoured instance field
! 457: 1 cells: ['] do-inst-value inst-something ;
! 458:
! 459: : <to-inst> ( w xt -- )
! 460: >body @ this + ! ;
! 461:
! 462: : to-inst ( w "name" -- )
! 463: ' <to-inst> ;
! 464:
! 465: : [to-inst] ( compile-time: "name" -- ; run-time: w -- )
! 466: ' >body @ POSTPONE literal
! 467: POSTPONE this
! 468: POSTPONE +
! 469: POSTPONE ! ; immediate
! 470:
1.1 anton 471: \ early binding stuff
472:
473: \ this is not generally used, only where you want to do something like
474: \ superclass method invocation (so that you don't have to name your methods)
475:
1.3 ! anton 476: : <bind> ( class selector-xt -- xt )
! 477: >body swap class->map over selector-interface @
! 478: ?dup-if
! 479: + @
! 480: then
! 481: swap selector-offset @ + @ ;
1.1 anton 482:
1.3 ! anton 483: : bind' ( "class" "selector" -- xt )
! 484: ' execute ' <bind> ;
1.1 anton 485:
1.3 ! anton 486: : bind ( ... object "class" "selector" -- ... )
1.1 anton 487: bind' execute ;
488:
1.3 ! anton 489: : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... )
1.1 anton 490: bind' compile, ; immediate
491:
1.3 ! anton 492: : [super] ( compile-time: "selector" -- ; run-time: ... object -- ... )
! 493: \ same as `[bind] "parent" "selector"', where "parent" is the
! 494: \ parent class of the current class
! 495: current-interface @ class-parent @ ' <bind> compile, ; immediate
! 496:
1.1 anton 497: \ the object class
498:
1.3 ! anton 499: \ because OBJECT has no parent class, we have to build it by hand
! 500: \ (instead of with class)
! 501:
! 502: wordlist
! 503: here current-interface !
! 504: current-interface 1 cells save-mem 2, \ map now contains a pointer to class
! 505: 0 ,
! 506: 0 ,
! 507: 0 , \ parent
! 508: , \ wordlist
! 509: object-struct 2, \ instance size
! 510: object-struct
! 511:
1.1 anton 512: :noname ( object -- )
1.3 ! anton 513: drop ;
! 514: method construct ( ... object -- )
! 515:
! 516: :noname ( object -- )
! 517: ." object:" dup . ." class:" object-map @ @ . ;
1.1 anton 518: method print
1.3 ! anton 519:
1.1 anton 520: end-class object
521:
1.3 ! anton 522: \ constructing objects
1.1 anton 523:
1.3 ! anton 524: : init-object ( ... class object -- )
! 525: swap class->map over object-map ! ( ... object )
! 526: construct ;
! 527:
! 528: : xt-new ( ... class xt -- object )
! 529: \ makes a new object, using XT ( size align -- addr ) to allocate memory
! 530: over class-inst-size 2@ rot execute
! 531: dup >r init-object r> ;
! 532:
! 533: : dict-new ( ... class -- object )
! 534: \ makes a new object HERE in dictionary
! 535: ['] struct-allot xt-new ;
! 536:
! 537: : heap-new ( ... class -- object )
! 538: \ makes a new object in ALLOCATEd memory
! 539: ['] struct-alloc xt-new ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to objects.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth