Author: wmb
Date: 2009-12-05 15:30:06 +0100 (Sat, 05 Dec 2009)
New Revision: 1537
Added:
cpu/x86/memtest.fth
Modified:
cpu/x86/basefw.bth
cpu/x86/k6cputest.fth
cpu/x86/pc/olpc/disptest.fth
cpu/x86/pc/olpc/gamekeys.fth
cpu/x86/pc/olpc/gui.fth
cpu/x86/pc/olpc/images/README
cpu/x86/pc/olpc/via/fw.bth
cpu/x86/pc/olpc/via/mfgtest.fth
cpu/x86/pc/olpc/via/olpc.bth
cpu/x86/pc/olpc/via/usb.fth
dev/hdaudio/test.fth
dev/olpc/kb3700/battery.fth
dev/olpc/keyboard/selftest.fth
dev/olpc/spiflash/spiui.fth
dev/olpc/touchpad/touchpad.fth
dev/olpc/viacamera/camera.fth
dev/ps2mouse.fth
dev/usb2/hcd/ehci/ehci.fth
dev/video/common/rectangle16.fth
ofw/fs/cifs/smb.fth
Log:
OLPC trac 9804 - Omnibus checkin of changes for manufacturing diagnostics.
Modified: cpu/x86/basefw.bth
===================================================================
--- cpu/x86/basefw.bth 2009-12-05 14:27:39 UTC (rev 1536)
+++ cpu/x86/basefw.bth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -83,6 +83,7 @@
fload ${BP}/cpu/x86/regacc.fth \ Register access words
\ [ifndef] no-tools
+fload ${BP}/cpu/x86/memtest.fth \ Memory-test-suite optimizations
fload ${BP}/ofw/fcode/loadfcod.fth \ S Fcode interpreter
fload ${BP}/ofw/fcode/regcodes.fth \ Register access words
Modified: cpu/x86/k6cputest.fth
===================================================================
--- cpu/x86/k6cputest.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ cpu/x86/k6cputest.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -21,7 +21,7 @@
dev /cpu
-d# 60 constant default#passes
+d# 10 constant default#passes
d# 10,000,000 constant spins/pass
0 value #cnt
7fff.ffff value #half
Added: cpu/x86/memtest.fth
===================================================================
--- cpu/x86/memtest.fth (rev 0)
+++ cpu/x86/memtest.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -0,0 +1,54 @@
+: bits-run ( adr len pattern -- fail? )
+ dup .x ." pattern ... "
+ 3dup lfill ( adr len pattern )
+ 3dup lskip ( adr len pattern residue )
+ dup if ( adr len pattern residue )
+ ." FAILED - got " ( adr len pattern residue )
+ nip >r - + ( adr' )
+ dup l@ .x ." at " .x cr ( )
+ true
+ else ( adr len pattern residue )
+ ." passed" cr ( adr len pattern residue )
+ 4drop false
+ then
+;
+: mem-bits-test ( membase memsize -- fail-status )
+ 2dup h# aaaaaaaa bits-run if true exit then
+ h# 55555555 bits-run
+;
+
+code inc-fill ( adr len -- )
+ cx pop 2 # cx shr
+ ax pop
+ begin
+ ax 0 [ax] mov
+ 4 [ax] ax lea
+ loopa
+c;
+
+code inc-check ( adr len -- false | adr data true )
+ cx pop 2 # cx shr
+ ax pop
+ begin
+ 0 [ax] bx mov
+ bx ax cmp <> if
+ ax push bx push -1 # push
+ next
+ then
+ 4 [ax] ax lea
+ loopa
+ ax ax xor ax push
+c;
+
+: address=data-test ( membase memsize -- fail-status )
+ ." Address=data test ..."
+ 2dup inc-fill ( membase memsize )
+ inc-check ( false | adr data true )
+ if
+ ." FAILED - got " .x ." at " .x cr
+ true
+ else
+ ." passed" cr
+ false
+ then
+;
Modified: cpu/x86/pc/olpc/disptest.fth
===================================================================
--- cpu/x86/pc/olpc/disptest.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ cpu/x86/pc/olpc/disptest.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -162,7 +162,7 @@
warning @ warning off
: selftest ( -- error? )
- depth d# 16 <> if false exit then
+ depth d# 16 < if false exit then
.horizontal-bars16 wait
.vertical-bars16 wait
gvsr wait
Modified: cpu/x86/pc/olpc/gamekeys.fth
===================================================================
--- cpu/x86/pc/olpc/gamekeys.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ cpu/x86/pc/olpc/gamekeys.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -45,6 +45,9 @@
: game-key? ( mask -- flag ) game-key-mask and 0<> ;
: (hold-message) ( ms -- )
+[ifdef] test-station
+ test-station if drop exit then
+[then]
d# 100 / ( decisecs )
begin dup while ( decisecs )
dup d# 10 /mod swap if drop else (cr .d then ( decisecs )
Modified: cpu/x86/pc/olpc/gui.fth
===================================================================
--- cpu/x86/pc/olpc/gui.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ cpu/x86/pc/olpc/gui.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -27,8 +27,10 @@
;
: image-base ( -- adr ) " graphmem" $call-screen ;
+: $image-name ( basename$ -- fullname$ ) " rom:%s.565" sprintf ;
: $get-image ( filename$ -- true | adr,len false )
+ $image-name ( fullname$ )
r/o open-file if drop true exit then >r ( r: fd )
image-base r@ fsize ( bmp-adr,len r: fd )
@@ -36,12 +38,25 @@
r> fclose ( bmp-adr,len )
if 2drop true else false then ( true | bmp-adr,len false )
;
+: $prep&draw ( image-adr,len -- )
+ prep-565 " draw-transparent-rectangle" $call-screen
+;
: $show ( filename$ -- )
screen-ih 0= if 2drop exit then
0 to image-width \ In case $show fails
$get-image if exit then
- prep-565 " draw-transparent-rectangle" $call-screen
+ $prep&draw
;
+: $show-centered ( filename$ -- )
+ screen-ih 0= if 2drop exit then
+ 0 to image-width \ In case $show fails
+ $get-image if exit then
+ prep-565 ( bits-adr x y w h )
+ 2nip ( bits-adr w h )
+ screen-wh 2over xy- ( bits-adr w h excess-x,y )
+ swap 2/ swap 2/ 2swap ( bits-adr x y w h )
+ " draw-transparent-rectangle" $call-screen
+;
: $show-opaque ( filename$ -- )
screen-ih 0= if 2drop exit then
$get-image if exit then
@@ -273,7 +288,7 @@
: error-banner ( -- )
error-shown? if exit then true to error-shown?
- " rom:error.565" $show&advance
+ " error" $show&advance
.sysinfo
;
@@ -317,7 +332,7 @@
\ The graphical boot sequence display at the top of the screen
\ has been superseded by the new secure pretty-boot scheme .
avoid-logo
- " rom:olpc.565" $show&advance
+ " olpc" $show&advance
[then]
icon-xy to first-icon-xy
@@ -331,11 +346,11 @@
[ifdef] resident-packages
dev /obp-tftp
-: (configured) ( -- ) " rom:netconfigured.565" $show ;
+: (configured) ( -- ) " netconfigured" $show ;
: show-timeout ( adr len -- )
2dup (.dhcp-msg) ( adr len )
" Timeout" $= screen-ih 0<> and if
- " rom:nettimeout.565" $show
+ " nettimeout" $show
.sysinfo
then
;
@@ -344,9 +359,9 @@
device-end
[then]
-: show-nand ( -- ) " rom:nandflash.565" $show&advance ;
-: show-disk ( -- ) " rom:disk.565" $show&advance ;
-: show-xo ( -- ) " rom:xo.565" $show&advance ;
+: show-nand ( -- ) " nandflash" $show&advance ;
+: show-disk ( -- ) " disk" $show&advance ;
+: show-xo ( -- ) " xo" $show&advance ;
: simple-load-started ( -- )
screen-ih if ['] show-xo to load-done then
@@ -356,17 +371,15 @@
h# 32 buffer: icon-name
: show-icon ( basename$ -- )
- [char] : left-parse-string 2nip ( basename$' )
- " rom:" icon-name pack $cat ( )
- " .565" icon-name $cat ( )
- icon-name count $show ( )
+ [char] : left-parse-string 2nip ( basename$' )
+ $show ( )
;
: ?show-package-icon ( adr len -- )
locate-device if exit then ( phandle )
" icon" 2 pick get-package-property 0= if ( phandle prop$ )
- $show&advance ( phandle )
+ $prep&draw advance ( phandle )
drop exit
then ( phandle )
@@ -416,14 +429,14 @@
: show-minus ( -- ) " minus" show-icon ;
: show-child ( -- )
" erase-screen" $call-screen
- d# 552 d# 384 to icon-xy " rom:xogray.565" $show-opaque
+ d# 552 d# 384 to icon-xy " xogray" $show-opaque
progress-xy to next-icon-xy \ For boot progress reports
;
0 [if]
: show-warnings ( -- )
" erase-screen" $call-screen
- d# 48 d# 32 to icon-xy " rom:warnings.565" $show-opaque
+ d# 48 d# 32 to icon-xy " warnings" $show-opaque
dcon-freeze
;
[then]
@@ -442,6 +455,15 @@
next-icon-xy image-width 0 d+ to next-icon-xy ( devname$ x y )
;
+: show-pass ( -- )
+ background 0 0 screen-wh fill-rectangle
+ " bigcheck" $show-centered
+;
+: show-fail ( -- )
+ color-red 0 0 screen-wh fill-rectangle
+ " bigx" $show-centered
+;
+
: linux-hook-unfreeze
[ ' linux-hook behavior compile, ]
;
Modified: cpu/x86/pc/olpc/images/README
===================================================================
--- cpu/x86/pc/olpc/images/README 2009-12-05 14:27:39 UTC (rev 1536)
+++ cpu/x86/pc/olpc/images/README 2009-12-05 14:30:06 UTC (rev 1537)
@@ -40,3 +40,14 @@
ofw/gui/bmp24rgb565.fth is a program to convert 24-bit RGB .bmp files to this format.
forth ofw/gui/bmp24rgb565.fth -s "bmp24rgb565 foo.bmp foo.565"
+
+Some of the files are checked in ".di" format, thus saving space in both the
+repository and the source tree, and reducing download time.
+
+The recipe for creating a ".di" file is, for example:
+
+ % build
+ ok writing big-x.di
+ ok " big-x.565" " big-x.565" $add-deflated-dropin
+ ok ofd @ fclose
+ ok bye
Modified: cpu/x86/pc/olpc/via/fw.bth
===================================================================
--- cpu/x86/pc/olpc/via/fw.bth 2009-12-05 14:27:39 UTC (rev 1536)
+++ cpu/x86/pc/olpc/via/fw.bth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -350,6 +350,18 @@
fload ${BP}/cpu/x86/pc/olpc/help.fth
fload ${BP}/cpu/x86/pc/olpc/gui.fth
fload ${BP}/cpu/x86/pc/olpc/via/suspend.fth \ Suspend/resume setup
+
+0 value test-station
+\ 0 - not in diag mode
+\ 1 - smt
+\ 2 - assembly
+\ 3 - download
+\ 4 - runin
+\ 5 - final test
+\ 6 - ship image download
+: smt-test? ( -- ) test-station 1 = ;
+: final-test? ( -- ) test-station 5 = ;
+
fload ${BP}/dev/olpc/keyboard/selftest.fth \ Keyboard diagnostic
fload ${BP}/dev/olpc/touchpad/touchpad.fth \ Touchpad diagnostic
fload ${BP}/cpu/x86/pc/olpc/gridmap.fth \ Gridded display tools
Modified: cpu/x86/pc/olpc/via/mfgtest.fth
===================================================================
--- cpu/x86/pc/olpc/via/mfgtest.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ cpu/x86/pc/olpc/via/mfgtest.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -8,8 +8,8 @@
: sq-border! ( bg -- ) current-sq sq >border ! ;
-: red-screen ( -- ) h# ffff color-red " replace-color16" $call-screen ;
-: green-screen ( -- ) h# ffff color-green " replace-color16" $call-screen ;
+: red-screen ( -- ) h# ffff color-red " replace-color" $call-screen ;
+: green-screen ( -- ) h# ffff color-green " replace-color" $call-screen ;
0 value pass?
Modified: cpu/x86/pc/olpc/via/olpc.bth
===================================================================
--- cpu/x86/pc/olpc/via/olpc.bth 2009-12-05 14:27:39 UTC (rev 1536)
+++ cpu/x86/pc/olpc/via/olpc.bth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -32,6 +32,10 @@
in: ${BP}/dev/hdaudio/build/hdaudio.fc
in: sd8686.bin
in: testicons.bin
+in: ${BP}/cpu/x86/pc/olpc/images/bigx.di
+in: ${BP}/cpu/x86/pc/olpc/images/bigcheck.di
+in: ${BP}/cpu/x86/pc/olpc/images/leds.di
+in: ${BP}/cpu/x86/pc/olpc/images/ebook.di
build-now
@@ -179,12 +183,18 @@
" testicons/wifi.565" " wifi.565" $add-deflated-dropin
" testicons/clock.565" " clock.565" $add-deflated-dropin
" testicons/timer.565" " timer.565" $add-deflated-dropin
+ " ${BP}/cpu/x86/pc/olpc/images/bigx.di" $add-file
+ " ${BP}/cpu/x86/pc/olpc/images/bigcheck.di" $add-file
+ " ${BP}/cpu/x86/pc/olpc/images/leds.di" $add-file
+ " ${BP}/cpu/x86/pc/olpc/images/ebook.di" $add-file
[ifdef] Later
" ${BP}/cpu/x86/pc/olpc/via/build/nandblaster_rx.bin" " nb_rx" $add-deflated-dropin
" ${BP}/cpu/x86/pc/olpc/via/build/nandblaster_tx.bin" " nb_tx" $add-deflated-dropin
[then]
+.( Dropin top is ) ofd @ fsize .x cr
+
[ifdef] coreboot-loaded
/rom h# 10000 - pad-file \ coreboot init image must be in last FLASH block
" coreboot.img" $add-file
Modified: cpu/x86/pc/olpc/via/usb.fth
===================================================================
--- cpu/x86/pc/olpc/via/usb.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ cpu/x86/pc/olpc/via/usb.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -12,6 +12,9 @@
r> to exit?
;
+\ Restrict selftest to external USB ports 1,2,3
+dev / 2 " usb-max-test-port" integer-property dend
+
: (probe-usb2) ( -- )
" device_type" get-property if exit then
[ifdef] use-usb-debug-port
Modified: dev/hdaudio/test.fth
===================================================================
--- dev/hdaudio/test.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ dev/hdaudio/test.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -10,7 +10,17 @@
: jingle ( -- ) " play-wav rom:splash" evaluate wait-sound ;
+: ?key-abort ( -- )
+ key? if
+ key h# 1b = abort" Aborting"
+ then
+;
: speaker-test ( -- )
+ h# 19 to node
+ pin-sense? if
+ ." Disconnect headphones to continue.. "
+ begin ?key-abort pin-sense? 0= until cr
+ then
." Playing jingle on the left speaker.. "
true to right-mute?
jingle cr
@@ -25,7 +35,7 @@
h# 19 to node
pin-sense? 0= if
." Connect headphones to continue.. "
- begin pin-sense? until cr
+ begin ?key-abort pin-sense? until cr
then
." Press a key to play sound.. " key drop cr
h# 1f to node power-off \ turn off speaker
@@ -34,6 +44,11 @@
;
: builtin-mic-test ( -- )
+ h# 1a to node
+ pin-sense? if
+ ." Disconnect microphone to continue.. "
+ begin ?key-abort pin-sense? 0= until cr
+ then
." Press a key to test recording / playback on the built-in microphone.. "
key drop cr
mic-test
@@ -43,24 +58,34 @@
h# 1a to node
pin-sense? 0= if
." Connect microphone to continue.. "
- begin pin-sense? until cr
+ begin ?key-abort pin-sense? until cr
then
." Press a key to test recording / playback on the external microphone.. "
key drop cr
mic-test
;
+0 value saved-volume
: interactive-test ( -- error? )
alloc-buffer
+ headphones-test
+ external-mic-test
speaker-test
- headphones-test
builtin-mic-test
- external-mic-test
dealloc-buffer
" confirm-selftest?" eval
;
: selftest ( -- )
- diagnostic-mode? if interactive-test else selftest then
+ diagnostic-mode? if
+ open 0= if ." Failed to open /audio" cr true exit then
+ " playback-volume" evaluate to saved-volume
+ 0 " to playback-volume" evaluate
+ ['] interactive-test catch if true then
+ saved-volume " to playback-volume" evaluate
+ close
+ else
+ selftest
+ then
;
\ LICENSE_BEGIN
Modified: dev/olpc/kb3700/battery.fth
===================================================================
--- dev/olpc/kb3700/battery.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ dev/olpc/kb3700/battery.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -749,7 +749,7 @@
wait-ac if true exit then
then
." Test running from AC.. "
- d# 2000 ms
+ d# 4000 ms
bat-status@ h# 40 and 0= if
." ok: battery is not discharging" cr
false
Modified: dev/olpc/keyboard/selftest.fth
===================================================================
--- dev/olpc/keyboard/selftest.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ dev/olpc/keyboard/selftest.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -27,7 +27,8 @@
d# 10 constant key-gap
d# 12 constant row-gap
-d# 40 constant smulti-key-w
+d# 0 constant hidden-key-w
+d# 70 constant smulti-key-w
d# 70 constant single-key-w
d# 70 constant single-key-h
d# 105 constant shift-key-w
@@ -53,7 +54,13 @@
: make-key ( w -- ) dup key-x key-y rot single-key-h (make-key) ++key-x ;
: make-key&gap ( w -- ) make-key add-key-gap ;
: make-single-key ( -- ) single-key-w make-key&gap ;
-: make-smulti-key ( -- ) smulti-key-w make-key ;
+: make-smulti-key ( i -- )
+ 1 and if
+ hidden-key-w make-key
+ else
+ smulti-key-w make-key
+ then
+;
: make-double-key ( -- ) single-key-w 2* make-key&gap ;
: make-shift-key ( -- ) shift-key-w make-key&gap ;
: make-space-key ( -- ) space-key-w make-key&gap ;
@@ -68,9 +75,10 @@
0 to #keys
top-key-row
2 0 do make-single-key loop
- 7 0 do make-smulti-key loop add-key-gap
- 7 0 do make-smulti-key loop add-key-gap
- 7 0 do make-smulti-key loop add-key-gap
+ 7 0 do i make-smulti-key loop add-key-gap
+ 7 0 do i make-smulti-key loop add-key-gap
+ 7 0 do i make-smulti-key loop add-key-gap
+
2 0 do make-single-key loop
next-key-row
d# 13 0 do make-single-key loop
@@ -143,6 +151,33 @@
;
[then]
+d# 128 8 / constant #key-bytes
+#key-bytes buffer: key-bitmap
+: set-key-bit ( key# -- )
+ 8 /mod ( bit# byte# )
+ key-bitmap + ( bit# adr )
+ tuck c@ ( adr bit# old-byte )
+ 1 rot lshift or ( adr byte )
+ swap c!
+;
+-1 value last-1
+-1 value last-2
+: clear-key-bitmap ( -- )
+ key-bitmap #key-bytes erase
+ -1 to last-1 -1 to last-2
+;
+
+h# ffd5ab57 constant funny-map
+create all-keys-bitmap
+57 c, ab c, d5 c, ff c, ff c, ff c, ff c, ff c, \ Omits the intermediate slider keys
+\ ff c, ff c, ff c, ff c, ff c, ff c, ff c, ff c,
+ff c, ff c, ff c, ff c, 03 c, 00 c, 00 c, 00 c,
+
+: all-keys-tested? ( -- flag )
+ key-bitmap @ funny-map and key-bitmap !
+ key-bitmap all-keys-bitmap #key-bytes comp 0=
+;
+
\ This table is indexed by the (unescaped) scanset1 code, giving
\ an IBM physical key number.
@@ -362,9 +397,13 @@
: draw-key ( key# color -- )
swap
- key-adr >r
- r@ >key-x @ r@ >key-y @ r@ >key-w @ r> >key-h @
- " fill-rectangle" $call-screen
+ key-adr >r ( color# r: key-adr )
+ r@ >key-w @ hidden-key-w = if
+ r> 2drop
+ else
+ r@ >key-x @ r@ >key-y @ r@ >key-w @ r> >key-h @
+ " fill-rectangle" $call-screen
+ then
;
: key-down ( key# -- ) pressed-key-color draw-key ;
: key-up ( key# -- ) idle-key-color draw-key ;
@@ -389,10 +428,22 @@
dup h# 7f and scan1->key# if ( scan )
drop ( )
else ( scan key# )
- swap h# 80 and if ( key# )
- dup key-up ( key# )
- 0= if true exit then ( )
+ swap h# 80 and if \ Up ( key# )
+ final-test? if ( key# )
+ dup 0= last-1 0= and last-2 0= and if ( key# )
+ drop true ( exit? )
+ else ( key# )
+ last-1 to last-2 to last-1 ( )
+ all-keys-tested? ( exit? )
+ then
+ else ( key# )
+ dup key-up ( key# )
+ \ 0 is the ESC key
+ 0= ( exit? )
+ then ( exit? )
+ if true exit then ( )
else ( key# )
+ dup set-key-bit ( key# )
key-down ( )
then ( )
then ( )
@@ -404,15 +455,21 @@
0 value last-timestamp
: selftest-keys ( -- )
false to esc?
+ clear-key-bitmap
get-msecs to last-timestamp
begin
get-data? if
process-raw
get-msecs to last-timestamp
else
- get-msecs last-timestamp - d# 20,000 >=
+ final-test? if
+ false \ Final test exit inside process-raw
+ else
+ get-msecs last-timestamp - d# 10,000 >=
+ then
then ( exit? )
until
+ begin get-data? while drop repeat
;
: toss-keys ( -- ) begin key? while key drop repeat ;
@@ -420,6 +477,10 @@
warning @ warning off
: selftest ( -- error? )
open 0= if true exit then
+
+ \ Being able to open the keyboard is good enough in SMT mode
+ smt-test? if close false exit then
+
make-keys
cursor-off draw-keyboard
true to locked? \ Disable the keyboard alarm handler; it steals our scancodes
@@ -429,7 +490,13 @@
screen-ih iselect erase-screen iunselect
page
close
- confirm-selftest?
+
+ final-test? if
+ all-keys-tested? 0=
+ dup if ." Some keys were not pressed" cr then
+ else
+ confirm-selftest?
+ then
;
warning !
Modified: dev/olpc/spiflash/spiui.fth
===================================================================
--- dev/olpc/spiflash/spiui.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ dev/olpc/spiflash/spiui.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -306,10 +306,10 @@
[ifdef] dev
dev /flash
: selftest ( -- error? )
- .mfg-data
+ .mfg-data cr
+ ." Checking SPI FLASH CRC ..."
slow-flash-read
-
\ Replace the manufacturing data block with all FF
flash-buf mfg-data-offset + /flash-block h# ff fill
@@ -318,6 +318,7 @@
-1 swap l!
flash-buf /flash crc <>
+ dup if ." FAILED" else ." passed" then cr
;
device-end
[then]
Modified: dev/olpc/touchpad/touchpad.fth
===================================================================
--- dev/olpc/touchpad/touchpad.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ dev/olpc/touchpad/touchpad.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -19,21 +19,20 @@
;
-h# f800.f800 constant red
-h# 07e0.07e0 constant green
-h# 001f.001f constant blue
-h# ffe0.ffe0 constant yellow
-h# f81f.f81f constant magenta
-h# 07ff.07ff constant cyan
-h# ffff.ffff constant white
-h# 0000.0000 constant black
+h# f800 constant red
+h# 07e0 constant green
+h# 001f constant blue
+h# ffe0 constant yellow
+h# f81f constant magenta
+h# 07ff constant cyan
+h# ffff constant white
+h# 0000 constant black
variable pixcolor
h# 4 value y-offset
-0 value fbadr
-0 value maxx
-0 value maxy
+0 value screen-w
+0 value screen-h
0 value /line
2 value /pixel
@@ -289,9 +288,11 @@
variable mouse-x
variable mouse-y
-: clipx ( delta -- x ) mouse-x @ + 0 max maxx min dup mouse-x ! ;
-: clipy ( delta -- y ) mouse-y @ + 0 max maxy min dup mouse-y ! ;
+: mouse-xy ( -- x y ) mouse-x @ mouse-y @ ;
+: clipx ( delta -- x ) mouse-x @ + 0 max screen-w 1- min dup mouse-x ! ;
+: clipy ( delta -- y ) mouse-y @ + 0 max screen-h 1- min dup mouse-y ! ;
+
\ Try to receive a GS-format packet. If one arrives within
\ 20 milliseconds, return true and the decoded information.
\ Otherwise return false.
@@ -346,20 +347,67 @@
;
: button ( color x -- )
- maxy d# 50 - d# 200 d# 30 " fill-rectangle" $call-screen
+ screen-h d# 50 - d# 200 d# 30 fill-rectangle-noff
;
-: background ( -- )
- fbadr maxy 2+ /line * erase
- 0 d# 27 at-xy ." Touchpad test. Both buttons clears screen. Type a key to exit" cr
- mode @ 3 <> if 0 d# 20 at-xy ." Pressure: " then
+d# 300 d# 300 2constant target-wh
+: left-target ( -- x y w h ) 0 0 target-wh ;
+: right-target ( -- x y w h ) screen-w screen-h target-wh xy- target-wh ;
+false value left-hit?
+false value right-hit?
+: inside? ( mouse-x,y x y w h -- flag )
+ >r >r ( mouse-x mouse-y x y r: h w )
+ xy- ( dx dy )
+ swap r> u< ( dy x-inside? )
+ swap r> u< ( x-inside? y-inside? )
+ and ( flag )
;
+
+: draw-left-target ( -- ) green left-target fill-rectangle-noff ;
+: draw-right-target ( -- ) red right-target fill-rectangle-noff ;
+: ?hit-target ( but -- but )
+ dup 1 and if \ Left ( but )
+ mouse-xy left-target inside? if ( but )
+ yellow left-target fill-rectangle-noff ( but )
+ true to left-hit? ( but )
+ exit
+ then ( but )
+ then ( but )
+ dup 2 and if \ Right ( but )
+ mouse-xy right-target inside? if ( but )
+ yellow right-target fill-rectangle-noff ( but )
+ true to right-hit? ( but )
+ exit
+ then ( but )
+ then ( but )
+;
+
: track-init ( -- )
- screen-ih package(
- frame-buffer-adr screen-width screen-height bytes/line
- )package to /line 2- to maxy 2- to maxx to fbadr
+ " dimensions" $call-screen to screen-h to screen-w
+ screen-w 2/ mouse-x ! screen-h 2/ mouse-y !
+ screen-ih package( bytes/line )package to /line
load-base ptr !
;
+: dot ( x y -- )
+ swap screen-w 3 - min swap y-offset + screen-h 3 - min ( x' y' )
+ pixcolor @ -rot 3 3 ( color x y w h )
+ fill-rectangle-noff ( )
+;
+
+: background ( -- )
+ black 0 0 screen-w screen-h fill-rectangle-noff
+ final-test? if
+ false to left-hit?
+ false to right-hit?
+ draw-left-target
+ draw-right-target
+ else
+ 0 d# 27 at-xy ." Touchpad test. Both buttons clears screen. Type a key to exit" cr
+ mode @ 3 <> if 0 d# 20 at-xy ." Pressure: " then
+ then
+ mouse-xy dot
+;
+
: show-up ( x y z -- ) 3drop d# 10 d# 20 at-xy ." UP " ;
: show-pressure ( z -- )
@@ -370,20 +418,12 @@
then
;
-: dot ( x y -- )
- y-offset + maxy min /line * ( x line-adr )
- swap ( line-adr x )
- maxx min /pixel * + ( pixel-offset )
- fbadr + ( pixel-adr )
- pixcolor @ swap 2dup l! ( pixcolor pixel-adr )
- /line + l!
-;
-
false value relative?
true value up?
d# 600 d# 512 2value last-rel
-0 0 2value last-abs
+d# 600 d# 512 2value last-abs
+\ This is only for the ALPS touchpad
: abs>rel ( x y -- x' y' )
up? if ( x y )
\ This is a touch
@@ -393,8 +433,8 @@
last-abs ( x y x0 y0 )
2over to last-abs ( x y x0 y0 )
xy- last-rel xy+ ( x' y' )
- swap 0 max maxx min
- swap 0 max maxy min ( x' y' )
+ swap 0 max screen-w 1- min
+ swap 0 max screen-h 1- min ( x' y' )
2dup to last-rel ( x y )
;
@@ -402,8 +442,12 @@
packet-type 2 = if yellow else cyan then pixcolor ! ( x y z but )
dup 3 and 3 = if background load-base ptr ! then
- dup 1 and if green else black then d# 100 button
- dup 2 and if red else black then d# 350 button ( x y z but )
+ final-test? if ( x y z but )
+ ?hit-target ( x y z but )
+ else ( x y z but )
+ dup 1 and if green else black then d# 100 button
+ dup 2 and if red else black then d# 350 button ( x y z but )
+ then ( x y z but )
\ Filter out events where the pen or finger in the current mode is not down
8 and 0= if show-up true to up? exit then ( x y z )
@@ -431,8 +475,50 @@
dot
;
+: handle-key ( -- exit? )
+ key upc case
+ [char] P of
+ cursor-on
+ cr last-10
+ key drop
+ background
+ false
+ endof
+
+ [char] S of suspend stream-on false endof
+
+ ( key ) true swap
+ endcase
+;
+
+false value selftest-failed? \ Success/failure flag for final test mode
+: exit-test? ( -- flag )
+ final-test? if ( )
+ \ If the targets have been hit, we exit with successa
+ left-hit? right-hit? and if ( )
+ false to selftest-failed? ( )
+ true ( flag )
+ exit
+ then ( )
+
+ \ Otherwise we give the tester a chance to bail out by typing a key,
+ \ thus indicating failure
+ key? 0= if false exit then ( )
+ key drop ( )
+ true to selftest-failed? ( )
+ true ( flag )
+ exit
+ then ( )
+
+ \ If not final test mode, we only exit via a key - no targets
+ key? if handle-key else false then ( exit ? )
+;
: selftest ( -- error? )
- open 0= if ." PS/2 Mouse (trackpad) open failed" 1 exit then
+ open 0= if ." PS/2 Mouse (trackpad) open failed" true exit then
+
+ \ Being able to open the touchpad is good enough in SMT mode
+ smt-test? if close false exit then
+
my-args " relative" $= to relative?
cursor-off track-init start
@@ -443,33 +529,16 @@
background
gs-only
begin
- begin
- ['] pad? catch ?dup if .error close true exit then
- if track then
- key? until
+ ['] pad? catch ?dup if .error close true exit then
+ if track then
+ exit-test? until
- key upc case
- [char] P of
- cursor-on
- cr last-10
- key drop
- background
- false
- endof
-
- [char] S of suspend stream-on false endof
-
- ( key ) true swap
- endcase
- until
-
close
cursor-on
page
- confirm-selftest?
+ final-test? if selftest-failed? else false then
;
-
\ We are finished adding code to the mouse driver.
\ Go back to the main forth context
device-end
Modified: dev/olpc/viacamera/camera.fth
===================================================================
--- dev/olpc/viacamera/camera.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ dev/olpc/viacamera/camera.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -476,7 +476,7 @@
: display-frame ( adr -- )
VGA_WIDTH 2* ( src-adr src-pitch )
0 0 d# 280 d# 210 VGA_WIDTH VGA_HEIGHT " copy16>32" $call-parent
- autobright
+ diagnostic-mode? if full-brightness else autobright then
;
: timeout-read ( adr len timeout -- actual )
Modified: dev/ps2mouse.fth
===================================================================
--- dev/ps2mouse.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ dev/ps2mouse.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -327,18 +327,18 @@
: open ( -- flag )
1 set-port
- open-count 0<> if true exit then
+ open-count 0= if
+ \ The "force" argument causes the open to succeed even if no mouse
+ \ is present
+ my-args [char] , left-parse-string 2swap 2drop " force" $= 0= if
- \ The "force" argument causes the open to succeed even if no mouse
- \ is present
- my-args [char] , left-parse-string 2swap 2drop " force" $= 0= if
+ find-mouse if false exit then
- find-mouse if false exit then
+ \ Reset the mouse and check the response codes
+ h# ff read2 0<> swap h# aa <> or if false exit then
- \ Reset the mouse and check the response codes
- h# ff read2 0<> swap h# aa <> or if false exit then
-
- remote-mode
+ remote-mode
+ then
then
open-count 1+ to open-count
Modified: dev/usb2/hcd/ehci/ehci.fth
===================================================================
--- dev/usb2/hcd/ehci/ehci.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ dev/usb2/hcd/ehci/ehci.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -200,11 +200,22 @@
: selftest ( -- error? )
ehci-reg dup 0= if map-regs then
- hcsparams@ h# f and 0 ?do
+
+ " usb-max-test-port" get-inherited-property if
+ h# 7fffffff
+ else ( adr len )
+ decode-int nip nip
+ then
+
+ hcsparams@ h# f and min 0 ?do
i portsc@ h# 2001 and if \ Port owned by usb 1.1 controller or device
\ is present.
." USB 2.0 port " i u. ." in use" cr
else
+ diagnostic-mode? if
+ ." Nothing connected to USB port " i u. " !" cr
+ true unloop exit
+ then
." Fisheye pattern out to USB 2.0 port " i u. cr
i test-port-begin
d# 2,000 ms
Modified: dev/video/common/rectangle16.fth
===================================================================
--- dev/video/common/rectangle16.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ dev/video/common/rectangle16.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -147,13 +147,19 @@
;
: dimensions ( -- width height ) width height ;
-: replace-color16 ( old new -- )
- frame-buffer-adr width height * 2* bounds do
- over i w@ = if
- dup i w!
- then
- 2 +loop
- 2drop
+: replace-color ( old new -- )
+ depth d# 32 = if
+ swap 565>argb-pixel swap 565>argb-pixel ( old' new' )
+ frame-buffer-adr width height * /l* bounds do
+ over i l@ xor h# ffffff and 0= if dup i l! then
+ /l +loop
+ 2drop
+ else
+ frame-buffer-adr width height * /w* bounds do
+ over i w@ = if dup i w! then
+ /w +loop
+ 2drop
+ then
;
\ LICENSE_BEGIN
Modified: ofw/fs/cifs/smb.fth
===================================================================
--- ofw/fs/cifs/smb.fth 2009-12-05 14:27:39 UTC (rev 1536)
+++ ofw/fs/cifs/smb.fth 2009-12-05 14:30:06 UTC (rev 1537)
@@ -390,6 +390,7 @@
0 instance value fid
0 instance value attributes \ 01:RO 02:Hidden 04:System 08:Volume 10:Directory 20:Archive
+0. instance 2value position
: $create ( path$ -- error? )
h# 03 smb{ ( path$ )
@@ -398,6 +399,7 @@
+path}smb if true exit then ( rem$ )
1 expect-wcnt ( rem$ )
-xw to fid ( rem$' )
+ 0. to position
\ The byte array is supposed to be empty
2drop false
;
@@ -420,6 +422,7 @@
drop-l \ Last write time ( rem$' )
-xl u>d to size ( rem$' )
drop-w \ Granted access ( rem$' )
+ 0. to position
\ The byte array is supposed to be empty
2drop false
;
@@ -467,7 +470,6 @@
5 smb{ fid +xw --bytes-- }smb empty-response
;
-0. instance 2value position
: seek ( d.offset -- error? )
size 2over d< if 2drop true exit then
to position
@@ -780,8 +782,12 @@
parse-server parse-share parse-pathname to tail$
server$ set-server
- d# 139 " connect" $call-parent 0= if false exit then
- " OFW " " *SMBSERVER " start-session if false exit then
+ \ First try the direct TCP connection method
+ d# 445 " connect" $call-parent 0= if
+ \ Failing that, try the NetBIOS session over TCP method
+ d# 139 " connect" $call-parent 0= if false exit then
+ " OFW " " *SMBSERVER " start-session if false exit then
+ then
negotiate if free-buffers false exit then ( )
password$ set-password compute-password ( )
session-setup if free-buffers false exit then ( )
