Return to objects.fs CVS log

Up to [gforth] / gforth

added primitive K
the Makefile now works with Digital Unix make
renamed the gforth-makeimage variable GFORTH into GFORTHD
fixed bug in comp-image (can now generate data-relocatable images).
gforth-makeimage uses a new option --no-offset-im to avoid differences
	from the command line
Documentation changes
fixed another bug involving relocatablility of code addresses.
my_alloc now works on machines without MAP_FILE and MAP_PRIVATE

    1: \ yet another Forth objects extension
    2: 
    3: \ written by Anton Ertl 1996
    4: \ public domain
    5: 
    6: \ 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: 
   10: \ 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: 
   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]