Initial import of abandoned HQEMU version 2.5.2HEADmaster

1 files changed, 49 insertions, 0 deletions

diff --git a/src/roms/openbios/forth/admin/selftest.fs b/src/roms/openbios/forth/admin/selftest.fs
new file mode 100644
index 0000000..20c0c96
--- /dev/null
+++ b/src/roms/openbios/forth/admin/selftest.fs
@@ -0,0 +1,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!
+  ;