aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

September 2017 Update

Browse source
This commit is contained in:
Ingy döt Net 2017-09-23 10:01:46 +02:00
parent bba7bfd280
commit ba8067c3b7
14570 changed files with 153136 additions and 63871 deletions
Download patch file Download diff file Expand all files Collapse all files

35
Task/Delegates/Forth/delegates.fth
View file

@ -1,38 +1,5 @@
include FMS-SI.f
-1 [if] \ add optional introspection facility to FMS
: fm' ( selector-ID link -- xt | 0 ) \ find method, linked-list search
begin @ dup
while 2dup cell+ @ =
if [ 2 cells ] literal + nip @ exit then
repeat 2drop false ;
: has-meth-L ( obj addr -- xt | 0 )
swap >class over @ + fm' ;
: >xt' ( table-offset ^dispatch -- xt | 0 )
2dup @ > if 2drop false exit then
+ @ ;
: has-meth-D ( obj addr -- xt | 0 )
@ swap @ >xt' ;
: (has-meth) ( obj addr sel-type -- xt | 0 )
seltype-L =
if ( obj addr ) has-meth-L
else ( obj addr ) has-meth-D
then ;
: [has-meth] ( obj "messageName" -- xt | 0 ) \ compile time only, can use ex-meth on xt to execute the method
' >body dup postpone literal cell+ @ postpone literal postpone (has-meth) ; immediate
: has-meth ( obj "messageName" -- xt | 0 ) \ interpret time only, can use ex-meth on xt to execute the method
' >body dup cell+ @ (has-meth) ;
[then]
:class delegate
:m thing ." delegate implementation" ;m
;class
@ -46,7 +13,7 @@ delegate slave
:m default ." default implementation" ;m
:m operation
del @ 0= if self default exit then
del @ [has-meth] thing
del @ has-meth thing
if del @ thing
else self default
then ;m