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