File:  [gforth] / gforth / objexamp.fs
Revision 1.2: download - view: text, annotated - select for diffs
Wed Oct 7 18:29:38 1998 UTC (21 years ago) by anton
Branches: MAIN
CVS tags: HEAD
fixed bug in objects.fs (override of inherited interface methods)
added fpick (primitive), suggested by Julian Noble

    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: 
   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: 
  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
  158: 
  159: \ test inst-value
  160: object class
  161:     foobar implementation
  162: 
  163:     inst-value N
  164: 
  165:     m: ( n object -- )
  166:         this [parent] construct \ currently does nothing, but who knows
  167:         [to-inst] N
  168:     ;m overrides construct
  169: 
  170:     m: ( object -- )
  171:         N .
  172:     ;m overrides print
  173: 
  174:     m: ( object -- n )
  175:         N
  176:     ;m overrides val
  177: end-class const-int
  178: 
  179: 5 const-int heap-new constant five
  180: five print
  181: five val 1+ . cr
  182: .s cr
  183: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>