1*afc2ba1dSToomas Soome\ examples from FORML conference paper Nov 98 2*afc2ba1dSToomas Soome\ sadler 3*afc2ba1dSToomas Soome.( loading FORML examples ) cr 4*afc2ba1dSToomas Soomeobject --> sub c-example 5*afc2ba1dSToomas Soome cell: .cell0 6*afc2ba1dSToomas Soome c-4byte obj: .nCells 7*afc2ba1dSToomas Soome 4 c-4byte array: .quad 8*afc2ba1dSToomas Soome c-byte obj: .length 9*afc2ba1dSToomas Soome 79 chars: .name 10*afc2ba1dSToomas Soome 11*afc2ba1dSToomas Soome : init ( inst class -- ) 12*afc2ba1dSToomas Soome 2dup object => init 13*afc2ba1dSToomas Soome s" aardvark" 2swap --> set-name 14*afc2ba1dSToomas Soome ; 15*afc2ba1dSToomas Soome 16*afc2ba1dSToomas Soome : get-name ( inst class -- c-addr u ) 17*afc2ba1dSToomas Soome 2dup 18*afc2ba1dSToomas Soome --> .name -rot ( c-addr inst class ) 19*afc2ba1dSToomas Soome --> .length --> get 20*afc2ba1dSToomas Soome ; 21*afc2ba1dSToomas Soome 22*afc2ba1dSToomas Soome : set-name { c-addr u 2:this -- } 23*afc2ba1dSToomas Soome u this --> .length --> set 24*afc2ba1dSToomas Soome c-addr this --> .name u move 25*afc2ba1dSToomas Soome ; 26*afc2ba1dSToomas Soome 27*afc2ba1dSToomas Soome : ? ( inst class ) c-example => get-name type cr ; 28*afc2ba1dSToomas Soomeend-class 29*afc2ba1dSToomas Soome 30*afc2ba1dSToomas Soome 31*afc2ba1dSToomas Soome: test ." this is a test" cr ; 32*afc2ba1dSToomas Soome' test 33*afc2ba1dSToomas Soomec-word --> ref testref 34*afc2ba1dSToomas Soome 35*afc2ba1dSToomas Soome\ add a method to c-word... 36*afc2ba1dSToomas Soomec-word --> get-wid ficl-set-current 37*afc2ba1dSToomas Soome\ list dictionary thread 38*afc2ba1dSToomas Soome: list ( inst class ) 39*afc2ba1dSToomas Soome begin 40*afc2ba1dSToomas Soome 2dup --> get-name type cr 41*afc2ba1dSToomas Soome --> next over 42*afc2ba1dSToomas Soome 0= until 43*afc2ba1dSToomas Soome 2drop 44*afc2ba1dSToomas Soome; 45*afc2ba1dSToomas Soomeset-current 46*afc2ba1dSToomas Soome 47*afc2ba1dSToomas Soomeobject subclass c-led 48*afc2ba1dSToomas Soome c-byte obj: .state 49*afc2ba1dSToomas Soome 50*afc2ba1dSToomas Soome : on { led# 2:this -- } 51*afc2ba1dSToomas Soome this --> .state --> get 52*afc2ba1dSToomas Soome 1 led# lshift or dup !oreg 53*afc2ba1dSToomas Soome this --> .state --> set 54*afc2ba1dSToomas Soome ; 55*afc2ba1dSToomas Soome 56*afc2ba1dSToomas Soome : off { led# 2:this -- } 57*afc2ba1dSToomas Soome this --> .state --> get 58*afc2ba1dSToomas Soome 1 led# lshift invert and dup !oreg 59*afc2ba1dSToomas Soome this --> .state --> set 60*afc2ba1dSToomas Soome ; 61*afc2ba1dSToomas Soome 62*afc2ba1dSToomas Soomeend-class 63*afc2ba1dSToomas Soome 64*afc2ba1dSToomas Soome 65*afc2ba1dSToomas Soomeobject subclass c-switch 66*afc2ba1dSToomas Soome 67*afc2ba1dSToomas Soome : ?on { bit# 2:this -- flag } 68*afc2ba1dSToomas Soome 69*afc2ba1dSToomas Soome 1 bit# lshift 70*afc2ba1dSToomas Soome ; 71*afc2ba1dSToomas Soomeend-class 72