File:  [gforth] / gforth / objects.fs
Revision 1.1: download - view: text, annotated - select for diffs
Mon Nov 11 16:59:17 1996 UTC (27 years, 4 months ago) by anton
Branches: MAIN
CVS tags: v0-2-1, v0-2-0, HEAD
Added ans-report.fs objects.fs

    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>