initial commit
[freebsd-arm:freebsd-arm.git] / boot / ficl / softwords / ficlclass.fr
1 \ #if (FICL_WANT_OOP)
2 \ ** ficl/softwords/ficlclass.fr
3 \ Classes to model ficl data structures in objects
4 \ This is a demo!
5 \ John Sadler 14 Sep 1998
6 \
7 \ ** C - W O R D
8 \ Models a FICL_WORD
9 \
10 \ $FreeBSD$
11
12 object subclass c-word
13     c-word     ref: .link
14     c-2byte    obj: .hashcode
15     c-byte     obj: .flags
16     c-byte     obj: .nName
17     c-bytePtr  obj: .pName
18     c-cellPtr  obj: .pCode
19     c-4byte    obj: .param0
20
21     \ Push word's name...
22     : get-name   ( inst class -- c-addr u )
23         2dup
24         my=[ .pName get-ptr ] -rot
25         my=[ .nName get ]
26     ;
27
28     : next   ( inst class -- link-inst class )
29         my=> .link ;
30         
31     : ?
32         ." c-word: " 
33         2dup --> get-name type cr
34     ;
35
36 end-class
37
38 \ ** C - W O R D L I S T
39 \ Models a FICL_HASH
40 \ Example of use:
41 \ get-current c-wordlist --> ref current
42 \ current --> ?
43 \ current --> .hash --> ?
44 \ current --> .hash --> next --> ?
45
46 object subclass c-wordlist
47     c-wordlist ref: .parent
48     c-ptr      obj: .name
49     c-cell     obj: .size
50     c-word     ref: .hash   ( first entry in hash table )
51
52     : ?
53         --> get-name ." ficl wordlist "  type cr ;
54     : push  drop  >search ;
55     : pop   2drop previous ;
56     : set-current   drop set-current ;
57     : get-name   drop wid-get-name ;
58     : words   { 2:this -- }
59         this my=[ .size get ] 0 do 
60             i this my=[ .hash index ]  ( 2list-head )
61             begin
62                 2dup --> get-name type space
63                 --> next over
64             0= until 2drop cr
65         loop
66     ;
67 end-class
68
69 \ : named-wid  wordlist postpone c-wordlist  metaclass => ref ;
70
71
72 \ ** C - F I C L S T A C K
73 object subclass c-ficlstack
74     c-4byte    obj: .nCells
75     c-cellPtr  obj: .link
76     c-cellPtr  obj: .sp
77     c-4byte    obj: .stackBase
78
79     : init   2drop ;
80     : ?      2drop
81         ." ficl stack " cr ;
82     : top
83         --> .sp --> .addr --> prev --> get ;
84 end-class
85
86 \ #endif