![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to other.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / device|
Return to other.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / device |
1.1 root 1: \ tag: Other FCode functions
2: \
3: \ this code implements IEEE 1275-1994 ch. 5.3.7
4: \
5: \ Copyright (C) 2003 Stefan Reinauer
6: \
7: \ See the file "COPYING" for further information about
8: \ the copyright and warranty status of this work.
9: \
10:
11: \ The current diagnostic setting
12: defer _diag-switch?
13:
14:
15: \
16: \ 5.3.7 Other FCode functions
17: \
18:
19: hex
20:
21: \ 5.3.7.1 Peek/poke
22:
23: : cpeek ( addr -- false | byte true )
24: c@ true
25: ;
26:
27: : wpeek ( waddr -- false | w true )
28: w@ true
29: ;
30:
31: : lpeek ( qaddr -- false | quad true )
32: l@ true
33: ;
34:
35: : cpoke ( byte addr -- okay? )
36: c! true
37: ;
38:
39: : wpoke ( w waddr -- okay? )
40: w! true
41: ;
42:
43: : lpoke ( quad qaddr -- okay? )
44: l! true
45: ;
46:
47:
48: \ 5.3.7.2 Device-register access
49:
50: : rb@ ( addr -- byte )
51: ;
52:
53: : rw@ ( waddr -- w )
54: ;
55:
56: : rl@ ( qaddr -- quad )
57: ;
58:
59: : rb! ( byte addr -- )
60: ;
61:
62: : rw! ( w waddr -- )
63: ;
64:
65: : rl! ( quad qaddr -- )
66: ;
67:
68: : rx@ ( oaddr - o )
69: state @ if
70: h# 22e get-token if , else execute then
71: else
72: h# 22e get-token drop execute
73: then
74: ; immediate
75:
76: : rx! ( o oaddr -- )
77: state @ if
78: h# 22f get-token if , else execute then
79: else
80: h# 22f get-token drop execute
81: then
82: ; immediate
83:
84: \ 5.3.7.3 Time
85:
86: 0 value dummy-msecs
87:
88: : get-msecs ( -- n )
89: dummy-msecs dup 1+ to dummy-msecs
90: ;
91:
92: : ms ( n -- )
93: get-msecs +
94: begin dup get-msecs < until
95: drop
96: ;
97:
98: : alarm ( xt n -- )
99: 2drop
100: ;
101:
102: : user-abort ( ... -- ) ( R: ... -- )
103: ;
104:
105:
106: \ 5.3.7.4 System information
107: 0003.0000 value fcode-revision ( -- n )
108:
109: : mac-address ( -- mac-str mac-len )
110: ;
111:
112:
113: \ 5.3.7.5 FCode self-test
114: : display-status ( n -- )
115: ;
116:
117: : memory-test-suite ( addr len -- fail? )
118: ;
119:
120: : mask ( -- a-addr )
121: ;
122:
123: : diagnostic-mode? ( -- diag? )
124: \ Return the NVRAM diag-switch? setting
125: _diag-switch?
126: ;
127:
128: \ 5.3.7.6 Start and end.
129:
130: \ Begin program with spread 0 followed by FCode-header.
131: : start0 ( -- )
132: 0 fcode-spread !
133: offset16
134: fcode-header
135: ;
136:
137: \ Begin program with spread 1 followed by FCode-header.
138: : start1 ( -- )
139: 1 to fcode-spread
140: offset16
141: fcode-header
142: ;
143:
144: \ Begin program with spread 2 followed by FCode-header.
145: : start2 ( -- )
146: 2 to fcode-spread
147: offset16
148: fcode-header
149: ;
150:
151: \ Begin program with spread 4 followed by FCode-header.
152: : start4 ( -- )
153: 4 to fcode-spread
154: offset16
155: fcode-header
156: ;
157:
158: \ Begin program with spread 1 followed by FCode-header.
159: : version1 ( -- )
160: 1 to fcode-spread
161: fcode-header
162: ;
163:
164: \ Cease evaluating this FCode program.
165: : end0 ( -- )
166: true fcode-end !
167: ;
168:
169: \ Cease evaluating this FCode program.
170: : end1 ( -- )
171: end0
172: ;
173:
174: \ Standard FCode number for undefined FCode functions.
175: : ferror ( -- )
176: ." undefined fcode# encountered." cr
177: true fcode-end !
178: ;
179:
180: \ Pause FCode evaluation if desired; can resume later.
181: : suspend-fcode ( -- )
182: \ NOT YET IMPLEMENTED.
183: ;
184:
185:
186: \ Evaluate FCode beginning at location addr.
187:
188: \ : byte-load ( addr xt -- )
189: \ \ this word is implemented in feval.fs
190: \ ;
191:
192: \ Set address and arguments of new device node.
193: : set-args ( arg-str arg-len unit-str unit-len -- )
194: ?my-self drop
195:
196: depth 1- >r
197: " decode-unit" ['] $call-parent catch if
198: 2drop 2drop
199: then
200:
201: my-self ihandle>phandle >dn.probe-addr \ offset
202: begin depth r@ > while
203: dup na1+ >r ! r>
204: repeat
205: r> 2drop
206:
207: my-self >in.arguments 2@ free-mem
208: strdup my-self >in.arguments 2!
209: ;
210:
211: : dma-alloc
212: s" dma-alloc" $call-parent
213: ;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.