1\  Test scope of "aliased" name in device-node
2\     along w/ excess of  "finish-device"
3
4\   Updated Mon, 31 Oct 2005 at 13:19 PST by David L. Paktor
5\
6
7[flag] Local-Values
8show-flags
9
10fcode-version2
11
12fload LocalValuesSupport.fth
13
14headers
15
16\  Should an alias to a core-function be local to the device-node
17\      in which it was made, or global to the whole tokenization?
18\  After talking w/ Jim L., answer is:  Global.
19\      An alias to a core-function goes into the core vocab.
20
21\  But!   When  new-device  or  finish-device  is used inside a
22\      colon-definition, it should not change the tok'z'n-time vocab...
23
24alias foop dup          \  Here's a classic case
25alias pelf my-self      \  Here's another
26
27\  And here are two just to screw you up!
28alias  >>  lshift
29alias  <<  rshift
30
31: troop ." Dup to my-self" foop to pelf ;
32
33alias snoop troop
34
35: croup  foop snoop ;
36
37: make-rope-name ( slip-number -- )
38                 { _slip }
39   " roper_" encode-string
40   _slip (.)  encode-string  encode+  name
41;
42
43: slip-prop ( slip-number -- )
44                 { _slip }
45     _slip not d# 24 >>
46     _slip     d# 16 >>  +
47     _slip not    1  <<  h# 0ff and  8 >> +
48     _slip     +
49        encode-int  " slipknot" property
50;
51
52hex
53create achin  \  Table of slip-numbers for each device
54      12 c, 13 c, 14 c,
55      56 c, 43 c, 50 c, 54 c,
560 c,   \  0-byte is list-terminator
57
58: make-name-and-prop ( slip-number -- )
59    foop
60    make-rope-name
61    slip-prop
62;
63
64: tie-one-on ( slip-number -- )
65     new-device make-name-and-prop
66;
67
68[message]  Define a method that creates subsidiaries...
69: spawn-offspring ( -- )
70   achin
71   begin                   ( addr )
72      dup c@  ?dup while   ( addr  slip )
73          tie-one-on
74	  finish-device
75      1+   \  Bump to next entry
76   repeat drop
77;
78
79: more-offs ( -- addr count )
80   " "(   \  Another table of offsprings' slip-numbers
81      )YUMA"(  \  Some of them are letters
82      85  92  13   \  Some are not
83   )"   \  That is all
84;
85
86: tap-it-out ( n -- n+1 )
87   finish-device
88   1+
89;
90
91: spawn-more
92     0 more-offs  bounds do
93        new-device i c@
94	  make-name-and-prop
95        tap-it-out
96     loop
97     encode-int  " num-offs" property
98;
99
100[message]  Subsidiary (child) device-node
101new-device
102create eek!  18 c, 17 c, 80 c, 79 c,
103: freek  eek! 4 bounds ?do i c@ . 1 +loop ;
104: greek  -1 if  freek then ;
105[message]  About to access method from parent node
106: hierareek
107       eek!
108           freek
109	       achin
110	           greek
111;
112: ikey  hierareek  freek  greek ;
113\  Does (Should) the new device know about its parent's aliases?
114: bad-refs
115    croup
116      foop
117         snoop
118      foop
119    to pelf
120;
121
122[message]  end child node
123finish-device
124
125[message]  Access methods from the root node again
126: refs-good-again
127    croup
128      foop
129         snoop
130      foop
131    to pelf
132;
133
134[message]  An extra finish-device
135finish-device
136[message]  Are we still here?
137
138: spoof
139    bad-refs
140      foop
141    refs-good-again
142;
143
144\  That is all...
145
146fcode-end
147
148