File:  [gforth] / gforth / objects.fs
Revision 1.3: download - view: text, annotated - select for diffs
Fri Jun 6 17:27:57 1997 UTC (26 years, 9 months ago) by anton
Branches: MAIN
CVS tags: HEAD
Environmental query "gforth" now returns the version-string
dictionary-end and unused moved into the kernel/basics.fs
Minor gforth.el bug fixes
Major rewrite of objects.fs (not yet done)
fixed -trailing bug (with test in test/other.fs)
optimization of fields with offset 0 in struct.fs and compat/struct.fs
other changes in compat/struct.fs (not yet done)
added ansreports to compat/*.fs
documentation changes
allot now checks for dict overflow
named [IS] (compilation semantics of IS).
minor changes

    1: \ yet another Forth objects extension
    2: 
    3: \ written by Anton Ertl 1996, 1997
    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 ; DOES> @ immediate drop Create >r rot r@ dup
   15: \ , IF ELSE THEN r> chars cells 2* here - allot over execute POSTPONE
   16: \ ?dup 2dup move 2! Variable 2@ ! ['] >body = 2drop ' +! Constant
   17: \ recurse 1+ BEGIN 0= UNTIL negate Literal ." .
   18: \ from CORE-EXT :
   19: \ tuck nip true <> 0> erase Value :noname compile, 
   20: \ from BLOCK-EXT :
   21: \ \ 
   22: \ from DOUBLE :
   23: \ 2Constant 
   24: \ from EXCEPTION :
   25: \ throw catch 
   26: \ from EXCEPTION-EXT :
   27: \ abort" 
   28: \ from FILE :
   29: \ ( 
   30: \ from FLOAT :
   31: \ floats 
   32: \ from FLOAT-EXT :
   33: \ dfloats sfloats 
   34: \ from LOCAL :
   35: \ TO 
   36: \ from MEMORY :
   37: \ allocate resize free 
   38: \ from SEARCH :
   39: \ get-order set-order wordlist get-current set-current 
   40: 
   41: \ ---------------------------------------
   42: \ MANUAL:
   43: 
   44: \ A class is defined like this:
   45: 
   46: \ <parent> class
   47: \   ... field <name>
   48: \   ...
   49: 
   50: \   ... inst-var <name>
   51: \   ...
   52: 
   53: \ selector <name>
   54: 
   55: \ :noname ( ... object -- ... )
   56: \   ... ;
   57: \ method <name> \ new method
   58: \ ...
   59: 
   60: \ :noname ( ... object -- ... )
   61: \   ... ;
   62: \ overrides <name> \ existing method
   63: \ ...
   64: 
   65: \ end-class <name>
   66: 
   67: \ you can write fields, inst-vars, selectors, methods and overrides in
   68: \ any order.
   69: 
   70: \ A call of a method looks like this:
   71: 
   72: \ ... <object> <method>
   73: 
   74: \ (<object> just needs to reside on the stack, there's no need to name it).
   75: 
   76: \ Instead of defining a method with ':noname ... ;', you can define it
   77: \ also with 'm: ... ;m'. The difference is that with ':noname' the
   78: \ "self" object is on the top of stack; with 'm:' you can get it with
   79: \ 'this'. You should use 'this' only in an 'm:' method even though the
   80: \ sample implementation does not enforce this.
   81: 
   82: \ The difference between a field and and inst-var is that the field
   83: \ refers to an object at the top of data stack (i.e. a field has the
   84: \ stack effect (object -- addr), whereas the inst-var refers to this
   85: \ (i.e., it has the stack effect ( -- addr )); obviously, an inst-var
   86: \ can only be used in an 'm:' method.
   87: 
   88: \ 'method' defines a new method selector and binds a method to it.
   89: 
   90: \ 'selector' defines a new method selector without binding a method to
   91: \ it (you can use this to define abstract classes)
   92: 
   93: \ 'overrides' binds a different method (than the parent class) to an
   94: \ existing method selector.
   95: 
   96: \ If you want to perform early binding, you can do it like this:
   97: 
   98: \ ... <object> [bind] <class> <method> \ compilation
   99: \ ... <object> bind  <class> <method> \ interpretation
  100: 
  101: \ You can get at the method from the method selector and the class like
  102: \ this:
  103: 
  104: \ bind' <class> <method>
  105: 
  106: 
  107: \ An interface is defined like this:
  108: 
  109: \ interface
  110: \   selector <name>
  111: \ : noname ( ... object -- ... )
  112: \     ... ;
  113: \ method <name>
  114: \   ...
  115: \ end-interface <name>
  116: 
  117: \ You can only define new selectors in an interface definition, no
  118: \ fields or instance variables. If you define a selector with
  119: \ 'method', the corresponding method becomes the default method for
  120: \ this selector.
  121: 
  122: \ An interface is used like this:
  123: 
  124: \ <parent> class
  125: \   <interface> implementation
  126: \   <interface> implementation
  127: 
  128: \ :noname ( ... -- ... )
  129: \     ... ;
  130: \ overrides <selector>
  131: 
  132: \ end-class name
  133: 
  134: \ a class inherits all interfaces of its parent. An 'implementation'
  135: \ means that the class also implements the specified interface (If the
  136: \ interface is already implemented by the parent class, an
  137: \ 'implementation' phrase resets the methods to the defaults.
  138: 
  139: \ 'overrides' can also be used to override interface methods. It has
  140: \ to be used after announcing the 'implementation' of the
  141: \ interface. Apart from this, 'implementation' can be freely mixed
  142: \ with the other stuff (but I recommend to put all 'implementation'
  143: \ phrases at the beginning of the class definition).
  144: 
  145: \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  146: 
  147: \ needs struct.fs
  148: 
  149: \ helper words
  150: 
  151: : -rot ( a b c -- c a b )
  152:     rot rot ;
  153: 
  154: : under+ ( a b c -- a+b c )
  155:     rot + swap ;
  156: 
  157: : perform ( ... addr -- ... )
  158:     @ execute ;
  159: 
  160: : ?dup-if ( compilation: -- orig ; run-time: n -- n|  )
  161:     POSTPONE ?dup POSTPONE if ; immediate
  162: 
  163: : save-mem	( addr1 u -- addr2 u ) \ gforth
  164:     \ copy a memory block into a newly allocated region in the heap
  165:     swap >r
  166:     dup allocate throw
  167:     swap 2dup r> -rot move ;
  168: 
  169: : resize ( a-addr1 u -- a-addr2 ior ) \ gforth
  170:     over
  171:     if
  172: 	resize
  173:     else
  174: 	nip allocate
  175:     then ;
  176: 
  177: : extend-mem	( addr1 u1 u -- addr addr2 u2 )
  178:     \ extend memory block allocated from the heap by u aus
  179:     \ the (possibly reallocated piece is addr2 u2, the extension is at addr )
  180:     over >r + dup >r resize throw
  181:     r> over r> + -rot ;
  182: 
  183: : 2,	( w1 w2 -- ) \ gforth
  184:     here 2 cells allot 2! ;
  185: 
  186: \ data structures
  187: 
  188: struct
  189:     1 cells: field object-map
  190: end-struct object-struct
  191: 
  192: struct
  193:     2 cells: field interface-map
  194:     1 cells: field interface-map-offset \ aus
  195:       \ difference between where interface-map points and where
  196:       \ object-map points (0 for non-classes)
  197:     1 cells: field interface-offset \ aus
  198:       \ offset of interface map-pointer in class-map (0 for classes)
  199: end-struct interface-struct
  200: 
  201: interface-struct
  202:     1 cells: field class-parent
  203:     1 cells: field class-wordlist \ instance variables and other private words
  204:     2 cells: field class-inst-size \ size and alignment
  205: end-struct class-struct
  206: 
  207: struct
  208:     1 cells: field selector-offset \ the offset within the (interface) map
  209:     1 cells: field selector-interface \ the interface offset
  210: end-struct selector-struct
  211: 
  212: \ maps are not defined explicitly; they have the following structure:
  213: 
  214: \ pointers to interface maps (for classes) <- interface-map points here
  215: \ interface/class-struct pointer           <- (object-)map  points here
  216: \ xts of methods 
  217: 
  218: 
  219: \ code
  220: 
  221: \ selectors and methods
  222: 
  223: variable current-interface
  224: 
  225: : no-method ( -- )
  226:     true abort" no method defined for this object/selector combination" ;
  227: 
  228: : do-class-method ( -- )
  229: does> ( ... object -- ... )
  230:     ( object )
  231:     selector-offset @ over object-map @ + ( object xtp ) perform ;
  232: 
  233: : do-interface-method ( -- )
  234: does> ( ... object -- ... )
  235:     ( object selector-body )
  236:     2dup selector-interface @ ( object selector-body object interface-offset )
  237:     swap object-map @ + @ ( object selector-body map )
  238:     swap selector-offset @ + perform ;
  239: 
  240: : method ( xt "name" -- )
  241:     \ define selector with method xt
  242:     create
  243:     current-interface @ interface-map 2@ ( xt map-addr map-size )
  244:     dup current-interface @ interface-map-offset @ - ,
  245:     1 cells extend-mem current-interface @ interface-map 2! ! ( )
  246:     current-interface @ interface-offset @ dup ,
  247:     ( 0<> ) if
  248: 	do-interface-method
  249:     else
  250: 	do-class-method
  251:     then ;
  252: 
  253: : selector ( "name" -- )
  254:     \ define a method selector for later overriding in subclasses
  255:     ['] no-method method ;
  256: 
  257: : interface-override! ( xt sel-xt interface-map -- )
  258:     \ xt is the new method for the selector sel-xt in interface-map
  259:     swap >body ( xt map selector-body )
  260:     selector-offset @ + ! ;
  261: 
  262: : class->map ( class -- map )
  263:     \ compute the (object-)map for the class
  264:     dup interface-map 2@ drop swap interface-map-offset @ + ;
  265: 
  266: : unique-interface-map ( class-map offset -- )
  267:     \ if the interface at offset in class map is the same as its parent,
  268:     \ copy it to make it unique; used for implementing a copy-on-write policy
  269:     over @ class-parent @ class->map ( class-map offset parent-map )
  270:     over + @ >r  \ the map for the interface for the parent
  271:     + dup @ ( mapp map )
  272:     dup r> =
  273:     if
  274: 	@ interface-map 2@ save-mem drop
  275: 	swap !
  276:     else
  277: 	2drop
  278:     then ;
  279: 
  280: : class-override! ( xt sel-xt class-map -- )
  281:     \ xt is the new method for the selector sel-xt in class-map
  282:     over >body ( xt sel-xt class-map selector-body )
  283:     selector-interface @ ( xt sel-xt class-map offset )
  284:     ?dup-if \ the selector is for an interface
  285: 	2dup unique-interface-map
  286: 	+ @
  287:     then
  288:     interface-override! ;
  289: 
  290: : overrides ( xt "selector" -- )
  291:     \ replace default method "method" in the current class with xt
  292:     \ must not be used during an interface definition
  293:     ' current-interface @ class->map class-override! ;
  294: 
  295: \ interfaces
  296: 
  297: \ every interface gets a different offset; the latest one is stored here
  298: variable last-interface-offset 0 last-interface-offset !
  299: 
  300: : interface ( -- )
  301:     interface-struct struct-allot >r
  302:     0 0 r@ interface-map 2!
  303:     -1 cells last-interface-offset +!
  304:     last-interface-offset @ r@ interface-offset !
  305:     0 r@ interface-map-offset !
  306:     r> current-interface ! ;
  307: 
  308: : end-interface-noname ( -- interface )
  309:     current-interface @ ;
  310: 
  311: : end-interface ( "name" -- )
  312:     \ name execution: ( -- interface )
  313:     end-interface-noname constant ;
  314: 
  315: \ classes
  316: 
  317: : add-class-order ( n1 class -- wid1 ... widn n+n1 )
  318:     dup >r class-parent @
  319:     ?dup-if
  320: 	recurse \ first add the search order for the parent class
  321:     then
  322:     r> class-wordlist @ swap 1+ ;
  323: 
  324: : push-order ( class -- )
  325:     \ add the class's wordlist to the search-order (in front)
  326:     >r get-order r> add-class-order set-order ;
  327: 
  328: : class ( parent-class -- size align )
  329:     class-struct struct-allot >r
  330:     dup interface-map 2@ save-mem r@ interface-map 2!
  331:     dup interface-map-offset @ r@ interface-map-offset !
  332:     r@ dup class->map !
  333:     0 r@ interface-offset !
  334:     dup r@ class-parent !
  335:     wordlist r@ class-wordlist !
  336:     r@ current-interface !
  337:     r> push-order
  338:     class-inst-size 2@ ;
  339: 
  340: : remove-class-order ( wid1 ... widn n+n1 class -- n1 )
  341:     \ note: no checks, whether the wordlists are correct
  342:     begin
  343: 	>r nip 1-
  344: 	r> class-parent @ dup 0=
  345:     until
  346:     drop ;
  347: 
  348: : drop-order ( class -- )
  349:     \ note: no checks, whether the wordlists are correct
  350:     >r get-order r> remove-class-order set-order ;
  351: 
  352: : end-class-noname ( size align -- class )
  353:     current-interface @ dup drop-order class-inst-size 2!
  354:     end-interface-noname ;
  355: 
  356: : end-class ( size align "name" -- )
  357:     \ name execution: ( -- class )
  358:     end-class-noname constant ;
  359: 
  360: \ visibility control
  361: 
  362: variable public-wordlist
  363: 
  364: : private ( -- )
  365:     current-interface @ class-wordlist @
  366:     dup get-current <>
  367:     if \ we are not private already
  368: 	get-current public-wordlist !
  369:     then
  370:     set-current ;
  371: 
  372: : public ( -- )
  373:     public-wordlist @ set-current ;
  374: 
  375: \ classes that implement interfaces
  376: 
  377: : front-extend-mem ( addr1 u1 u -- addr addr2 u2 )
  378:     \ extend memory block allocated from the heap by u aus, with the
  379:     \ old stuff coming at the end
  380:     2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 )
  381:     dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 )
  382:     free throw
  383:     r> dup r> ;
  384:     
  385: : implementation ( interface -- )
  386:     dup interface-offset @ ( interface offset )
  387:     current-interface @ interface-map-offset @ negate over - dup 0>
  388:     if \ the interface does not fit in the present class-map
  389: 	>r current-interface @ interface-map 2@
  390: 	r@ front-extend-mem
  391: 	current-interface @ interface-map 2!
  392: 	r@ erase
  393: 	dup negate current-interface @ interface-map-offset !
  394: 	r>
  395:     then ( interface offset n )
  396:     drop >r
  397:     interface-map 2@ save-mem drop ( map )
  398:     current-interface @ dup interface-map 2@ drop
  399:     swap interface-map-offset @ + r> + ! ;
  400: 
  401: \ this/self, instance variables etc.
  402: 
  403: \ rename "this" into "self" if you are a Smalltalk fiend
  404: 0 value this ( -- object )
  405: : to-this ( object -- )
  406:     TO this ;
  407: 
  408: \ another implementation, if you don't have (fast) values
  409: \ variable thisp
  410: \ : this ( -- object )
  411: \     thisp @ ;
  412: \ : to-this ( object -- )
  413: \     thisp ! ;
  414: 
  415: : m: ( -- xt colon-sys ) ( run-time: object -- )
  416:     :noname 
  417:     POSTPONE this
  418:     POSTPONE >r
  419:     POSTPONE to-this ;
  420: 
  421: : ;m ( colon-sys -- ) ( run-time: -- )
  422:     POSTPONE r>
  423:     POSTPONE to-this
  424:     POSTPONE ; ; immediate
  425: 
  426: : catch ( ... xt -- ... n )
  427:     \ make it safe to call CATCH within a method.
  428:     \ should also be done with all words containing CATCH.
  429:     this >r catch r> to-this ;
  430: 
  431: \ the following is a bit roundabout; this is caused by the standard
  432: \ disallowing to change the compilation wordlist between CREATE and
  433: \ DOES> (see RFI 3)
  434: 
  435: : inst-something ( size1 align1 size align xt "name" -- size2 align2 )
  436:     \ xt ( -- ) typically is for a DOES>-word
  437:     get-current >r
  438:     current-interface @ class-wordlist @ set-current
  439:     >r create-field r> execute
  440:     r> set-current ;
  441: 
  442: : do-inst-var ( -- )
  443: does> \ name execution: ( -- addr )
  444:     ( addr1 ) @ this + ;
  445: 
  446: : inst-var ( size1 align1 size align "name" -- size2 align2 )
  447:     \ name execution: ( -- addr )
  448:     ['] do-inst-var inst-something ;
  449: 
  450: : do-inst-value ( -- )
  451: does> \ name execution: ( -- w )
  452:     ( addr1 ) @ this + @ ;
  453: 
  454: : inst-value ( size1 align1 "name" -- size2 align2 )
  455:     \ name execution: ( -- w )
  456:     \ a cell-sized value-flavoured instance field
  457:     1 cells: ['] do-inst-value inst-something ;
  458: 
  459: : <to-inst> ( w xt -- )
  460:     >body @ this + ! ;
  461: 
  462: : to-inst ( w "name" -- )
  463:     ' <to-inst> ;
  464: 
  465: : [to-inst] ( compile-time: "name" -- ; run-time: w -- )
  466:     ' >body @ POSTPONE literal
  467:     POSTPONE this
  468:     POSTPONE +
  469:     POSTPONE ! ; immediate
  470: 
  471: \ early binding stuff
  472: 
  473: \ this is not generally used, only where you want to do something like
  474: \ superclass method invocation (so that you don't have to name your methods)
  475: 
  476: : <bind> ( class selector-xt -- xt )
  477:     >body swap class->map over selector-interface @
  478:     ?dup-if
  479: 	+ @
  480:     then
  481:     swap selector-offset @ + @ ;
  482: 
  483: : bind' ( "class" "selector" -- xt )
  484:     ' execute ' <bind> ;
  485: 
  486: : bind ( ... object "class" "selector" -- ... )
  487:     bind' execute ;
  488: 
  489: : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... )
  490:     bind' compile, ; immediate
  491: 
  492: : [super] ( compile-time: "selector" -- ; run-time: ... object -- ... )
  493:     \ same as `[bind] "parent" "selector"', where "parent" is the
  494:     \ parent class of the current class
  495:     current-interface @ class-parent @ ' <bind> compile, ; immediate
  496: 
  497: \ the object class
  498: 
  499: \ because OBJECT has no parent class, we have to build it by hand
  500: \ (instead of with class)
  501: 
  502: wordlist
  503: here current-interface !
  504: current-interface 1 cells save-mem 2, \ map now contains a pointer to class
  505: 0 ,
  506: 0 , 
  507: 0 , \ parent
  508: , \ wordlist
  509: object-struct 2, \ instance size
  510: object-struct
  511: 
  512: :noname ( object -- )
  513:     drop ;
  514: method construct ( ... object -- )
  515: 
  516: :noname ( object -- )
  517:     ." object:" dup . ." class:" object-map @ @ . ;
  518: method print
  519: 
  520: end-class object
  521: 
  522: \ constructing objects
  523: 
  524: : init-object ( ... class object -- )
  525:     swap class->map over object-map ! ( ... object )
  526:     construct ;
  527: 
  528: : xt-new ( ... class xt -- object )
  529:     \ makes a new object, using XT ( size align -- addr ) to allocate memory
  530:     over class-inst-size 2@ rot execute
  531:     dup >r init-object r> ;
  532: 
  533: : dict-new ( ... class -- object )
  534:     \ makes a new object HERE in dictionary
  535:     ['] struct-allot xt-new ;
  536: 
  537: : heap-new ( ... class -- object )
  538:     \ makes a new object in ALLOCATEd memory
  539:     ['] struct-alloc xt-new ;

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