Constrained genericity: Difference between revisions

Line 362:

=={{header|Forth}}==

Works with any ANS Forth ~~with one dependency~~

Works with any ANS Forth

Needs the FMS-SI (single inheritance) library code located here:

Line 369:

include FMS-SILib.f

: (where) ( class-xt where-dfa -- flag )

\ This code uses an implementation dependent word dfa>xt

swap >body { where-dfa class-dfa }

\ which converts a data-field address to an executable token.

: dfa>xt ( a-addr -- xt ) \ implementation dependent for VFX Forth

5 - ;

: (where) { class-xt where-xt -- flag }

begin

class-xt ['] object <>

class-dfa ['] object >body <>

while

class-xt where-xt = if true exit then

class-dfa where-dfa = if true exit then

class-~~xt >body~~ sfa @ ~~dfa>xt~~ to class-xt

class-dfa sfa @ to class-dfa

repeat false ;

: where ( class-xt "classname" -- flag )

' state @

' >body state @

if postpone literal postpone (where)

else (where)

Line 401:

Line 396:

else ." not an eatable type "

then ;m

:m get ( -- obj ) eatable-types ;m

;class

: test ( obj -- )

: test ( obj -- ) \ send the eat message to each object in the object-list

begin dup each:

while eat

Line 410:

Line 405:

FoodBox fb

3 ' Eatable fb fill:

3 ' Eatable fb fill: \ fill the object-list with 3 objects of class Eatable

fb get test

successful eat