blob: 20c0c963bd9a83adf3e76082f205db8bfc0c921a (
plain)
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
|
\ tag: self-test
\
\ this code implements IEEE 1275-1994 ch. 7.4.8
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\
\ 7.4.8 Self-test
\
: $test ( devname-addr devname-len -- )
2dup ." Testing device " type ." : "
find-dev if
s" self-test" rot find-method if
execute
else
." no self-test method."
then
else
." no such device."
then
cr
;
: test ( "device-specifier<cr>"-- )
linefeed parse cr $test
;
: test-sub-devs
>dn.child @
begin dup while
dup get-package-path $test
dup recurse
>dn.peer @
repeat
drop
;
: test-all ( "{device-specifier}<cr>" -- )
active-package
cr " /" find-device
linefeed parse find-device
?active-package test-sub-devs
active-package!
;
|
