-
Notifications
You must be signed in to change notification settings - Fork 1
/
ORDER
149 lines (123 loc) · 4.67 KB
/
ORDER
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
\ Vocabulary search order specification
cr .( Loading Vocabulary support...)
\ provides WORDLIST
\ VOCABULARY name
\ ONLY
\ ALSO
\ PREVIOUS
\ ORDER
\ VOCS
\ FORTH
: #WORDLIST ( #threads -- wid )
1 16 0 do 2dup <= ?leave 2* loop nip
2 MAX DUP , VOC-LINK LINK,
HERE DUP>R OVER CELLS ALLOT
SWAP CELLS ERASE R> ;
: WORDLIST ( -- wid )
#THREADS #WORDLIST ;
warning off
: #VOCABULARY ( #threads -<name>- )
CREATE #WORDLIST DROP
DOES> BODY> VCFA>VOC CONTEXT ! VOC-ALSO ;
: VOCABULARY ( -- )
#THREADS #VOCABULARY ;
warning on
VOCABULARY ROOT
' ROOT call@ ' FORTH call! \ Patch the FORTH vocabulary to be like other vocabularies
: ALSO ( -- )
CONTEXT DUP CELL+ #VOCS 1- CELLS MOVE ;
: ONLY ( -- )
CONTEXT #VOCS CELLS ERASE ROOT ALSO VOC-ALSO ;
: PREVIOUS ( -- )
CONTEXT DUP CELL+ SWAP #VOCS 1- CELLS MOVE
CONTEXT @ 0=
IF ROOT
THEN VOC-ALSO ;
: FORTH-WORDLIST ( -- wid )
['] FORTH VCFA>VOC ;
: GET-CURRENT ( -- wid )
CURRENT @ ;
: SET-CURRENT ( wid -- )
CURRENT ! ;
: GET-ORDER ( -- widn .. wid1 n )
DEPTH >R
0 #VOCS 1-
DO CONTEXT I CELLS+ @
DUP 0=
IF DROP
THEN
-1 +LOOP DEPTH R> - ;
: SET-ORDER ( widn .. wid1 n -- )
DUP 0<
IF DROP ONLY
ELSE CONTEXT #VOCS CELLS ERASE
0
?DO CONTEXT I CELLS+ !
LOOP VOC-ALSO
THEN ;
: ORDER ( -- )
CR ." Context: " CONTEXT
#VOCS 0
DO DUP @ ?DUP
IF voc>vcfa >NAME .ID 14 ?CR
THEN CELL+
LOOP DROP
CR ." Current: " CURRENT @ voc>vcfa >NAME .ID ;
: VOCS ( -- )
cr ." Vocabularies #Threads #Words #Average"
cols 59 >
if ." #Headerbytes"
then
cr VOC-LINK @
BEGIN DUP VLINK>VOC
dup voc>vcfa call@
dup doClass =
swap do|Class = or 0=
IF dup voc>vcfa >NAME .ID 18 #tab
dup voc#threads dup>r 4 .r
0 to words-cnt
0 to header-cnt
count-voc words-cnt dup 9 .r
10 * r> / 8 .r.1
cols 59 >
if header-cnt 15 .r
then
cr
ELSE DROP
THEN @ DUP 0=
UNTIL DROP
." ----------------------------------------"
cols 59 >
if ." --------------"
then
cr ." Total System Words: " count-words 11 .r
cols 59 >
if ." Header bytes:" header-cnt 8 .r
then cr ;
ROOT DEFINITIONS
: FORTH FORTH ;
: FORTH-WORDLIST FORTH-WORDLIST ;
: SET-ORDER SET-ORDER ;
ONLY FORTH ALSO DEFINITIONS
: anyfind ( a1 -- a2 f1 ) \ find a word in any vocabulary
dup c@ 0=
if 0 exit
then
?uppercase find ?dup 0=
if context @ >r
voc-link
begin @ ?dup
while dup vlink>voc ( #threads cells - )
dup voc>vcfa @
dup doClass =
swap do|Class = or 0=
if context ! \ set voc
over find ?dup
if 2swap 2drop
r> context !
EXIT \ *** EXITS HERE ****
then
then drop
repeat 0
r> context !
then ;