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 ( )