Re: OBJECTS.FS Question

On 7 mayo, 15:20, ragof...@[EMAIL PROTECTED]
 wrote:
> I finally made it work.  I attach the source code. There is no need to
> modify objects.fs although I'd love to see it included in the
> "official" release by Anton. Just include this after objects.fs.
>

Corrected a bug where FREE was invoked on ALLOTed memory in some
cases.

\ Persistant.fs
\ Adding persistance to objects.fs
\ Include this file after objects.fs
\ to use it, add "persistant" after each end-interface and
\ end-methods (if you declare methods outside the class)
\ or end-class (if you declare all methods within the class)
\
\ Rafael Gonzalez Fuentetaja, May, 10th 2008
\ Public Domain. No Warranty

: allot&move				  \ addr1 u1 -- addr2
\ +G Copy a chunk of memory to the dictionary memory,
\ +* Return the new address.
   here dup >r over allot
   swap move
   r>
;

: heap>dict				  \ addr1 u1 -- addr2
\ +G Transfer a chunk of memory from the heap to the dictionary
memory,
\ +* releasing old heap memory.
   over >r  allot&move  r> free throw
;

: persist-interface-map		  \ old-ifce-map -- new-ifce-map
\ +G Persist a single interface map into the dictionary memory.
\ Memory leaks and dupplication occur here, but it is of no relevance
\ in the saved system.
   dup
   @[EMAIL PROTECTED]
 interface-map 2@[EMAIL PROTECTED]
 nip		\ get the interface map size
   allot&move				\ and reallocate
;

: persist-interface-maps		  \ class --
\ +G Persist all interface maps for *\i{class} that implement
interfaces.
\ +* Does nothing if *\i{class} do not implement interfaces.
   dup interface-map-offset @[EMAIL PROTECTED]
 swap interface-map 2@[EMAIL PROTECTED]
 drop
   swap bounds ?do
      i @[EMAIL PROTECTED]
 ?dup if persist-interface-map i ! then
   1 cells +loop
;

: persistant				  \ --
\ *G Copy the last defined interface map from the heap
\ ** back to the dictionary so that it can be safely saved in turnkey
\ ** applications.
   current-interface @[EMAIL PROTECTED]
 interface-map 2@[EMAIL PROTECTED]
 dup >R
   heap>dict
   R> current-interface @[EMAIL PROTECTED]
 interface-map 2!
   current-interface @[EMAIL PROTECTED]
 persist-interface-maps
;

persistant             \ make the root 'object' class persistant

0 [if]

interface
   selector sel1
   selector sel2
end-interface i-test1 persistant

interface
   selector sel3
   selector sel4
end-interface i-test2 persistant

object class
   i-test2 implementation

   Cell% inst-var m-count

   selector foo

end-class per1

per1 methods
public

  m:
     m-count off
  ;m  overrides construct

  m:
     ." count is " m-count ? cr
     1 m-count +!
  ;m  overrides print

  m:
     ." I'm foo selector" cr
  ;m overrides foo

  :m bar
     ." I'm bar method"
  ;m

  m:
     ." I'm selector sel4" cr
  ;m overrides sel4

end-methods persistant

per1 dict-new constant p1

p1 print
p1 print

save persis.elf cr
bye


[then]