Return to objexamp.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/objexamp.fs, revision 1.4

1.1       anton       1: \ examples and tests for objects.fs
                      2: 
1.4     ! anton       3: \ written by Anton Ertl 1996-1998
1.1       anton       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: 
1.2       anton      85: 
1.1       anton      86: 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: 
1.2       anton     143: \ 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
1.3       anton     158: 1 z add
                    159: z val . cr
1.2       anton     160: 
                    161: \ test inst-value
1.1       anton     162: 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: