Annotation of gforth/objects.fs, revision 1.1
1.1 ! anton 1: \ yet another Forth objects extension
! 2:
! 3: \ written by Anton Ertl 1996
! 4: \ public domain
! 5:
! 6: \ This is in ANS Forth (with an environmental dependence on case
! 7: \ insensitivity; convert everything to upper case for state sensitive
! 8: \ systems). It needs some non-core words (in particular, it uses the
! 9: \ memory allocation wordset), but I have not made a complete list.
! 10:
! 11: \ Manual:
! 12:
! 13: \ A class is defined like this:
! 14:
! 15: \ <parent> class
! 16: \ ... field <name>
! 17: \ ...
! 18:
! 19: \ ... inst-var <name>
! 20: \ ...
! 21:
! 22: \ selector <name>
! 23:
! 24: \ :noname ( ... object -- ... )
! 25: \ ... ;
! 26: \ method <name> \ new method
! 27: \ ...
! 28:
! 29: \ :noname ( ... object -- ... )
! 30: \ ... ;
! 31: \ overrides <name> \ existing method
! 32: \ ...
! 33:
! 34: \ end-class <name>
! 35:
! 36: \ you can write fields, inst-vars, selectors, methods and overrides in
! 37: \ any order.
! 38:
! 39: \ A call of a method looks like this:
! 40:
! 41: \ ... <object> <method>
! 42:
! 43: \ (<object> just needs to reside on the stack, there's no need to name it).
! 44:
! 45: \ Instead of defining a method with ':noname ... ;', you can define it
! 46: \ also with 'm: ... ;m'. The difference is that with ':noname' the
! 47: \ "self" object is on the top of stack; with 'm:' you can get it with
! 48: \ 'this'. You should use 'this' only in an 'm:' method even though the
! 49: \ sample implementation does not enforce this.
! 50:
! 51: \ The difference between a field and and inst-var is that the field
! 52: \ refers to an object at the top of data stack (i.e. a field has the
! 53: \ stack effect (object -- addr), whereas the inst-var refers to this
! 54: \ (i.e., it has the stack effect ( -- addr )); obviously, an inst-var
! 55: \ can only be used in an 'm:' method.
! 56:
! 57: \ 'method' defines a new method selector and binds a method to it.
! 58:
! 59: \ 'selector' defines a new method selector without binding a method to
! 60: \ it (you can use this to define abstract classes)
! 61:
! 62: \ 'overrides' binds a different method (than the parent class) to an
! 63: \ existing method selector.
! 64:
! 65: \ If you want to perform early binding, you can do it like this:
! 66:
! 67: \ ... <object> [bind] <class> <method> \ compilation
! 68: \ ... <object> bind <class> <method> \ interpretation
! 69:
! 70: \ You can get at the method from the method selector and the class like
! 71: \ this:
! 72:
! 73: \ bind' <class> <method>
! 74: \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
! 75:
! 76: \ needs struct.fs
! 77:
! 78: \ helper words
! 79:
! 80: : -rot ( a b c -- c a b )
! 81: rot rot ;
! 82:
! 83: : perform ( ... addr -- ... )
! 84: @ execute ;
! 85:
! 86: : save-mem ( addr1 u -- addr2 u ) \ gforth
! 87: \ copy a memory block into a newly allocated region in the heap
! 88: swap >r
! 89: dup allocate throw
! 90: swap 2dup r> -rot move ;
! 91:
! 92: : extend-mem ( addr1 u1 u -- addr addr2 u2 )
! 93: \ extend memory block allocated from the heap by u aus
! 94: \ the (possibly reallocated piece is addr2 u2, the extension is at addr )
! 95: over >r + dup >r resize throw
! 96: r> over r> + -rot ;
! 97:
! 98: : 2, ( w1 w2 -- ) \ gforth
! 99: here 2 cells allot 2! ;
! 100:
! 101: : const-field ( size1 align1 -- size2 align2 )
! 102: 1 cells: field
! 103: does> ( addr -- w )
! 104: @ + @ ;
! 105:
! 106: struct
! 107: 1 cells: field object-map
! 108: end-struct object-struct
! 109:
! 110: struct
! 111: 2 cells: field class-map
! 112: const-field class-instance-size \ aus
! 113: const-field class-instance-align \ aus
! 114: end-struct class-struct
! 115:
! 116: 2variable current-map \ address and size (in aus) of the current map
! 117:
! 118: : class ( class -- size align )
! 119: dup class-map 2@ save-mem current-map 2!
! 120: dup class-instance-size
! 121: swap class-instance-align ;
! 122:
! 123: : end-class ( size align "name" -- )
! 124: create
! 125: current-map 2@ 2,
! 126: swap , , ;
! 127:
! 128: : no-method ( -- )
! 129: abort" no method defined" ;
! 130:
! 131: : method ( xt "name" -- )
! 132: \ define method and selector
! 133: current-map 2@ ( xt map-addr map-size )
! 134: create dup ,
! 135: 1 cells extend-mem current-map 2!
! 136: !
! 137: does> ( ... object -- ... )
! 138: ( object addr )
! 139: @ over ( object-map ) @ + ( object xtp ) perform ;
! 140:
! 141: : selector ( "name" -- )
! 142: \ define a method selector for later overriding in subclasses
! 143: ['] no-method method ;
! 144:
! 145: : override! ( xt method-xt -- )
! 146: >body @ current-map 2@ drop + ! ;
! 147:
! 148: : overrides ( xt "selector" -- )
! 149: \ replace default method "method" with xt
! 150: ' override! ;
! 151:
! 152: : alloc-instance ( class -- object )
! 153: \ make a new, (almost) uninitialized instance of a class
! 154: dup class-instance-size allocate throw
! 155: swap class-map 2@ drop over ( object-map ) ! ;
! 156:
! 157: \ this/self, instance variables etc.
! 158:
! 159: variable thisp
! 160: : this ( -- object )
! 161: \ rename this into self if you are a Smalltalk fiend
! 162: thisp @ ;
! 163:
! 164: : m: ( -- xt colon-sys ) ( run-time: object -- )
! 165: :noname
! 166: POSTPONE this
! 167: POSTPONE >r
! 168: POSTPONE thisp
! 169: POSTPONE ! ;
! 170:
! 171: : ;m ( colon-sys -- ) ( run-time: -- )
! 172: POSTPONE r>
! 173: POSTPONE thisp
! 174: POSTPONE !
! 175: POSTPONE ; ; immediate
! 176:
! 177: : catch ( ... xt -- ... n )
! 178: \ make it safe to call CATCH within a method.
! 179: \ should also be done with all words containing CATCH.
! 180: this >r catch r> thisp ! ;
! 181:
! 182: : inst-var ( size1 align1 size align -- size2 align2 )
! 183: field
! 184: does> ( -- addr )
! 185: ( addr1 ) @ this + ;
! 186:
! 187: \ early binding stuff
! 188:
! 189: \ this is not generally used, only where you want to do something like
! 190: \ superclass method invocation (so that you don't have to name your methods)
! 191:
! 192: : (bind) ( class method-xt -- xt )
! 193: >body @ swap class-map 2@ drop + @ ;
! 194:
! 195: : bind' ( "class" "method" -- xt )
! 196: ' >body ' (bind) ;
! 197:
! 198: : bind ( ... object "class" "method" -- ... )
! 199: bind' execute ;
! 200:
! 201: : [bind] ( compile-time: "class" "method" -- ; run-time: ... object -- ... )
! 202: bind' compile, ; immediate
! 203:
! 204: \ the object class
! 205:
! 206: 0 0 save-mem current-map 2!
! 207: object-struct \ no class to inherit from, so we have to do this manually
! 208: :noname ( object -- )
! 209: ." object:" dup . ." class:" object-map @ . ;
! 210: method print
! 211: end-class object
! 212:
! 213: \ examples
! 214: true [if]
! 215: cr object alloc-instance print
! 216:
! 217: object class
! 218: :noname ( object -- )
! 219: drop ." undefined" ;
! 220: overrides print
! 221: end-class nothing
! 222:
! 223: nothing alloc-instance constant undefined
! 224:
! 225: cr undefined print
! 226:
! 227: \ instance variables and this
! 228: object class
! 229: 1 cells: inst-var count-n
! 230: m: ( object -- )
! 231: count-n @ . ;m
! 232: overrides print
! 233: m: ( object -- )
! 234: 0 count-n ! ;m
! 235: method init
! 236: m: ( object -- )
! 237: 1 count-n +! ;m
! 238: method inc
! 239: end-class counter
! 240:
! 241: counter alloc-instance constant counter1
! 242:
! 243: cr
! 244: counter1 init
! 245: counter1 print
! 246: counter1 inc
! 247: counter1 print
! 248: counter1 inc
! 249: counter1 inc
! 250: counter1 inc
! 251: counter1 print
! 252: counter1 print
! 253:
! 254: \ examples of static binding
! 255:
! 256: cr undefined bind object print
! 257: : object-print ( object -- )
! 258: [bind] object print ;
! 259:
! 260: cr undefined object-print
! 261: [then]
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