sys/boot/ficl/softwords/forml.fr

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