Lines Matching +full:resume +full:- +full:offset
3 \ ** F I C L O - O E X T E N S I O N S
7 17 ficl-vocabulary oop
14 \ 2. Object aggregation (has-a relationship)
18 \ 4. Separate name-spaces for methods - methods are
30 \ object ( -- instance class )
44 \ on the stack. This is by convention - ficl has no way to
51 \ Revised Apr 2001 - Added Guy Carver's vtable extensions. Class now
55 \ Revised Nov 2001 - metaclass debug method now finds only metaclass methods
59 \ END-CLASS allocates and clears the vtable - then it walks class's method
65 \ - header
66 \ - vtable index
67 \ - xt
74 \ --> compiles code to fetch vtable address, offset by index, and execute
79 user current-class
80 0 current-class !
85 \ execute it at run-time...
88 \ p a r s e - m e t h o d
90 \ the string base address and count at run-time.
92 : parse-method \ name run: ( -- c-addr u )
93 parse-word
95 ; compile-only
99 : (lookup-method) { class 2:name -- class 0 | class xt 1 | class xt -1 }
100 class name class cell+ @ ( class c-addr u wid )
101 search-wordlist
104 \ l o o k u p - m e t h o d
106 \ by parse-method) and attempts to look this method up in the method list of
110 : lookup-method { class 2:name -- class xt }
111 class name (lookup-method) ( 0 | xt 1 | xt -1 )
119 : find-method-xt \ name ( class -- class xt )
120 parse-word lookup-method
123 : catch-method ( instance class c-addr u -- <method-signature> exc-flag )
124 lookup-method catch
127 : exec-method ( instance class c-addr u -- <method-signature> )
128 lookup-method execute
131 \ Method lookup operator takes a class-addr and instance-addr
135 : --> ( instance class -- ??? )
137 find-method-xt execute
139 parse-method postpone exec-method
144 : c-> ( instance class -- ?? exc-flag )
146 find-method-xt catch
148 parse-method postpone catch-method
153 \ in case you prefer this style (no --> in your code)
157 \ my-instance next ( does whatever next does to my-instance by late binding )
159 : method create does> body> >name lookup-method execute ;
166 \ so they leave their cell-pair on the stack when compiling.
168 \ : get-wid metaclass => .wid @ ;
170 \ my-class get-wid ( -- wid-of-my-class )
172 1 ficl-named-wordlist instance-vars
173 instance-vars dup >search ficl-set-current
175 : => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method
176 drop find-method-xt compile, drop
177 ; immediate compile-only
179 : my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class
180 current-class @ dup postpone =>
181 ; immediate compile-only
185 \ detects non-obect members and assumes the class does not change in this case.
189 current-class @
191 parse-word 2dup ( class c-addr u c-addr u )
192 s" ]" compare while ( class c-addr u )
193 lookup-method ( class xt )
196 nip >body cell+ @ ( new-class )
201 ; immediate compile-only
207 \ private wordlist. Each IV word contains the offset
208 \ of the IV it represents, and runs code to add that offset
211 \ of the new class's offset field and its initial size on the
213 \ complete, END-CLASS saves the final size in the class's size
216 \ wordlist to prevent accidental use outside a SUB END-CLASS pair.
218 : do-instance-var
219 does> ( instance class addr[offset] -- addr[field] )
223 : addr-units: ( offset size "name" -- offset' )
225 do-instance-var
228 : chars: \ ( offset nCells "name" -- offset' ) Create n char member.
229 chars addr-units: ;
231 : char: \ ( offset nCells "name" -- offset' ) Create 1 char member.
234 : cells: ( offset nCells "name" -- offset' )
235 cells >r aligned r> addr-units:
238 : cell: ( offset nCells "name" -- offset' )
245 : do-aggregate
247 does> ( instance class pfa -- a-instance a-class )
248 2@ ( inst class a-class a-offset )
249 2swap drop ( a-class a-offset inst )
250 + swap ( a-inst a-class )
253 : obj: { offset class meta -- offset' } \ "name"
254 create offset , class ,
255 class meta --> get-size offset +
256 do-aggregate
261 \ 3 my-class array: my-array
262 \ Makes an instance variable array of 3 instances of my-class
263 \ named my-array.
265 : array: ( offset n class meta "name" -- offset' )
266 locals| meta class nobjs offset |
267 create offset , class ,
268 class meta --> get-size nobjs * offset +
269 do-aggregate
276 \ in classes.fr. REF is only useful for pre-initialized structures,
278 : ref: ( offset class meta "name" -- offset' )
279 locals| meta class offset |
280 create offset , class ,
281 offset cell+
282 does> ( inst class pfa -- ptr-inst ptr-class )
283 2@ ( inst class ptr-class ptr-offset )
289 : vcall: ( paramcnt "name" -- )
290 current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined.
291 create , , \ ( paramcnt index -- )
292 does> \ ( inst class pfa -- ptr-inst ptr-class )
293 nip 2@ vcall \ ( params offset inst class offset -- )
299 : vcallf: \ ( paramcnt -<name>- f: r )
301 current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined.
302 create , , \ ( paramcnt index -- )
303 does> \ ( inst class pfa -- ptr-inst ptr-class )
304 nip 2@ vcall f> \ ( params offset inst class offset -- f: r )
309 \ END-CLASS terminates construction of a class by storing
311 \ ( -- old-wid addr[size] 0 )
313 : end-class ( old-wid addr[size] size -- )
314 swap ! set-current
318 \ See resume-class (a metaclass method) below for usage
319 \ This is equivalent to end-class for now, but that will change
321 : suspend-class ( old-wid addr[size] size -- ) end-class ;
323 set-current previous
328 \ D O - D O - I N S T A N C E
332 \ PRECONDITION: current-class contains the class address
334 \ >> Stack state is not well-defined during compilation (there are
336 \ >> easiest way around this is use of this thread-local variable
338 : do-do-instance ( -- )
339 s" : .do-instance does> [ current-class @ ] literal ;"
362 ficl-set-current
366 metaclass drop cell+ @ brand-wordlist
368 metaclass drop current-class !
369 do-do-instance
374 instance-vars >search
376 create .super ( class metaclass -- parent-class )
377 0 cells , do-instance-var
379 create .wid ( class metaclass -- wid ) \ return wid of class
380 1 cells , do-instance-var
384 2 cells , do-instance-var
386 create .size ( class metaclass -- size ) \ return class's payload size
387 3 cells , do-instance-var
389 create .size ( class metaclass -- size ) \ return class's payload size
390 2 cells , do-instance-var
393 : get-size metaclass => .size @ ;
394 : get-wid metaclass => .wid @ ;
395 : get-super metaclass => .super @ ;
397 : get-vtCount metaclass => .vtCount @ ;
398 : get-vtAdd metaclass => .vtCount ;
404 : instance ( class metaclass "name" -- instance class )
407 here parent --> .do-instance \ ( inst class )
408 parent meta metaclass => get-size
413 : array ( n class metaclass "name" -- n instance class )
416 here parent --> .do-instance \ ( nobj inst class )
417 parent meta metaclass => get-size
423 : new \ ( class metaclass "name" -- )
424 metaclass => instance --> init
428 : new-array ( n class metaclass "name" -- )
430 --> array-init
434 : alloc \ ( class metaclass -- instance class )
436 class meta metaclass => get-size allocate ( -- addr fail-flag )
437 abort" allocate failed " ( -- addr )
438 class 2dup --> init
442 : alloc-array \ ( n class metaclass -- instance class )
444 class meta metaclass => get-size
445 nobj * allocate ( -- addr fail-flag )
446 abort" allocate failed " ( -- addr )
447 nobj over class --> array-init
452 : allot { 2:this -- 2:instance }
453 here ( instance-address )
454 this my=> get-size allot
455 this drop 2dup --> init
459 : allot-array { nobj 2:this -- 2:instance }
460 here ( instance-address )
461 this my=> get-size nobj * allot
463 nobj -rot --> array-init
467 : ref ( instance-addr class metaclass "name" -- )
472 \ suspend-class and resume-class help to build mutually referent classes.
474 \ object subclass c-akbar
475 \ suspend-class ( put akbar on hold while we define jeff )
476 \ object subclass c-jeff
477 \ c-akbar ref: .akbar
479 \ end-class ( done with c-jeff )
480 \ c-akbar --> resume-class
481 \ c-jeff ref: .jeff
482 \ ( and whatever else goes in c-akbar )
483 \ end-class ( done with c-akbar )
485 : resume-class { 2:this -- old-wid addr[size] size }
486 this --> .wid @ ficl-set-current ( old-wid )
487 this --> .size dup @ ( old-wid addr[size] size )
488 instance-vars >search
493 \ building. Pushes the instance-vars wordlist onto the search order,
495 \ new class. The class's wordlist is deliberately NOT in the search order -
497 \ Postcondition: leaves the address of the new class in current-class
498 : sub ( class metaclass "name" -- old-wid addr[size] size )
501 parent meta metaclass => get-wid
502 wid wid-set-super \ set superclass
504 wid brand-wordlist \ label the subclass wordlist
505 here current-class ! \ prep for do-do-instance
509 parent meta --> get-vtCount ,
511 here parent meta --> get-size dup , ( addr[size] size )
512 metaclass => .do-instance
513 wid ficl-set-current -rot
514 do-do-instance
515 instance-vars >search \ push struct builder wordlist
518 \ OFFSET-OF returns the offset of an instance variable
521 \ results -- there is no way at present to check for this error.
522 : offset-of ( class metaclass "name" -- offset )
523 drop find-method-xt nip >body @ ;
525 \ ID returns the string name cell-pair of its class
526 : id ( class metaclass -- c-addr u )
530 : methods \ ( class meta -- )
534 class meta --> get-wid >search words cr previous
535 class meta metaclass => get-super
541 : pedigree ( class meta -- )
545 class meta metaclass => get-super
551 : see ( class meta -- )
552 metaclass => get-wid >search see previous ;
555 \ Eg: my-class --> debug my-method
556 : debug ( class meta -- )
557 find-method-xt debug-xt ;
559 previous set-current
567 \ Subclass compilation ends when you invoke end-class
569 : subclass --> sub ;
573 \ object --> sub mine hasvtable
587 ficl-set-current
591 object drop cell+ @ brand-wordlist
593 object drop current-class !
594 do-do-instance
595 instance-vars >search
598 \ Convert instance cell-pair to class cell-pair
600 : class ( instance class -- class metaclass )
604 : init ( instance class -- )
606 metaclass => get-size ( inst size )
611 : array-init ( nobj inst class -- )
616 class s" init" lookup-method to &init
617 s" next" lookup-method to &next
626 \ free storage allocated to a heap instance by alloc or alloc-array
629 : free \ ( instance class -- )
636 : super ( instance class -- instance parent-class )
637 meta metaclass => get-super ;
639 : pedigree ( instance class -- )
643 : size ( instance class -- sizeof-instance )
645 metaclass => get-size ;
647 : methods ( instance class -- )
653 \ 10 object-array --> index
654 \ obj --> next
656 : index ( n instance class -- instance[n] class )
660 metaclass => get-size * ( n*size )
663 : next ( instance[n] class -- instance[n+1] class )
667 metaclass => get-size
671 : prev ( instance[n] class -- instance[n-1] class )
675 metaclass => get-size
676 inst swap -
679 : debug ( 2this -- ?? )
680 find-method-xt debug-xt ;
682 previous set-current