Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ examples and tests for objects.fs |
| 2 : | |||
| 3 : | \ written by Anton Ertl 1996, 1997 | ||
| 4 : | \ public domain | ||
| 5 : | |||
| 6 : | cr object heap-new print | ||
| 7 : | |||
| 8 : | object class | ||
| 9 : | |||
| 10 : | :noname ( object -- ) | ||
| 11 : | drop ." undefined" ; | ||
| 12 : | overrides print | ||
| 13 : | end-class nothing | ||
| 14 : | |||
| 15 : | nothing heap-new constant undefined | ||
| 16 : | |||
| 17 : | cr undefined print | ||
| 18 : | |||
| 19 : | \ instance variables and this | ||
| 20 : | object class | ||
| 21 : | cell% inst-var n | ||
| 22 : | m: ( object -- ) | ||
| 23 : | 0 n ! ;m | ||
| 24 : | overrides construct | ||
| 25 : | m: ( object -- ) | ||
| 26 : | n @ . ;m | ||
| 27 : | overrides print | ||
| 28 : | m: ( object -- ) | ||
| 29 : | 1 n +! ;m | ||
| 30 : | method inc | ||
| 31 : | end-class counter | ||
| 32 : | |||
| 33 : | counter heap-new constant counter1 | ||
| 34 : | |||
| 35 : | cr | ||
| 36 : | counter1 print | ||
| 37 : | counter1 inc | ||
| 38 : | counter1 print | ||
| 39 : | counter1 inc | ||
| 40 : | counter1 inc | ||
| 41 : | counter1 inc | ||
| 42 : | counter1 print | ||
| 43 : | counter1 print | ||
| 44 : | |||
| 45 : | \ examples of static binding | ||
| 46 : | |||
| 47 : | cr undefined bind object print | ||
| 48 : | : object-print ( object -- ) | ||
| 49 : | [bind] object print ; | ||
| 50 : | |||
| 51 : | cr undefined object-print | ||
| 52 : | |||
| 53 : | \ interface | ||
| 54 : | |||
| 55 : | \ sorry, a meaningful example would be too long | ||
| 56 : | |||
| 57 : | interface | ||
| 58 : | selector add ( n object -- ) | ||
| 59 : | selector val ( object -- n ) | ||
| 60 : | end-interface foobar | ||
| 61 : | |||
| 62 : | counter class | ||
| 63 : | foobar implementation | ||
| 64 : | |||
| 65 : | m: ( object -- ) | ||
| 66 : | this [parent] inc | ||
| 67 : | n @ 10 mod 0= | ||
| 68 : | if | ||
| 69 : | ." xcounter " this object-print ." made another ten" cr | ||
| 70 : | then | ||
| 71 : | ;m overrides inc | ||
| 72 : | |||
| 73 : | m: ( n object -- ) | ||
| 74 : | 0 do | ||
| 75 : | this inc | ||
| 76 : | loop | ||
| 77 : | ;m overrides add | ||
| 78 : | |||
| 79 : | m: ( object -- n ) | ||
| 80 : | n @ | ||
| 81 : | ;m overrides val | ||
| 82 : | |||
| 83 : | end-class xcounter | ||
| 84 : | |||
| 85 : | anton | 1.2 | |
| 86 : | anton | 1.1 | object class |
| 87 : | foobar implementation | ||
| 88 : | |||
| 89 : | cell% inst-var n | ||
| 90 : | |||
| 91 : | m: ( n object -- ) | ||
| 92 : | n ! | ||
| 93 : | ;m overrides construct | ||
| 94 : | |||
| 95 : | m: ( object -- ) | ||
| 96 : | n @ . | ||
| 97 : | ;m overrides print | ||
| 98 : | |||
| 99 : | m: ( n object -- ) | ||
| 100 : | n +! | ||
| 101 : | ;m overrides add | ||
| 102 : | |||
| 103 : | protected | ||
| 104 : | |||
| 105 : | create protected1 | ||
| 106 : | |||
| 107 : | protected | ||
| 108 : | |||
| 109 : | create protected2 | ||
| 110 : | |||
| 111 : | cr order | ||
| 112 : | |||
| 113 : | public | ||
| 114 : | |||
| 115 : | create public1 | ||
| 116 : | |||
| 117 : | cr order | ||
| 118 : | |||
| 119 : | \ we leave val undefined | ||
| 120 : | end-class int | ||
| 121 : | |||
| 122 : | \ a perhaps more sensible class structure would be to have int as | ||
| 123 : | \ superclass of counter, but that would not exercise interfaces | ||
| 124 : | |||
| 125 : | xcounter dict-new constant x | ||
| 126 : | create y 3 int dict-new drop \ same as "3 int dict-new constant y" | ||
| 127 : | |||
| 128 : | cr | ||
| 129 : | y print cr | ||
| 130 : | 20 x add | ||
| 131 : | 20 y add | ||
| 132 : | x val . | ||
| 133 : | \ y val . \ undefined | ||
| 134 : | y print | ||
| 135 : | cr | ||
| 136 : | int push-order | ||
| 137 : | order cr | ||
| 138 : | words cr | ||
| 139 : | int drop-order | ||
| 140 : | order | ||
| 141 : | cr | ||
| 142 : | |||
| 143 : | anton | 1.2 | \ test override of inherited interface selector |
| 144 : | xcounter class | ||
| 145 : | |||
| 146 : | m: ( object -- n ) | ||
| 147 : | this [parent] val 2* | ||
| 148 : | ;m overrides val | ||
| 149 : | |||
| 150 : | end-class ycounter | ||
| 151 : | |||
| 152 : | ycounter dict-new constant z | ||
| 153 : | cr | ||
| 154 : | z print cr | ||
| 155 : | z val . cr | ||
| 156 : | z inc | ||
| 157 : | z val . cr | ||
| 158 : | anton | 1.3 | 1 z add |
| 159 : | z val . cr | ||
| 160 : | anton | 1.2 | |
| 161 : | \ test inst-value | ||
| 162 : | anton | 1.1 | object class |
| 163 : | foobar implementation | ||
| 164 : | |||
| 165 : | inst-value N | ||
| 166 : | |||
| 167 : | m: ( n object -- ) | ||
| 168 : | this [parent] construct \ currently does nothing, but who knows | ||
| 169 : | [to-inst] N | ||
| 170 : | ;m overrides construct | ||
| 171 : | |||
| 172 : | m: ( object -- ) | ||
| 173 : | N . | ||
| 174 : | ;m overrides print | ||
| 175 : | |||
| 176 : | m: ( object -- n ) | ||
| 177 : | N | ||
| 178 : | ;m overrides val | ||
| 179 : | end-class const-int | ||
| 180 : | |||
| 181 : | 5 const-int heap-new constant five | ||
| 182 : | five print | ||
| 183 : | five val 1+ . cr | ||
| 184 : | .s cr | ||
| 185 : |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |