r1641 - in forth: kernel lib
by svn＠openfirmware.info
Author: wmb
Date: 2009-12-29 01:26:19 +0100 (Tue, 29 Dec 2009)
New Revision: 1641
Modified:
forth/kernel/kernel.fth
forth/lib/tofile.fth
Log:
OLPC trac 9932 - better fix for to-file .
Modified: forth/kernel/kernel.fth
===================================================================
--- forth/kernel/kernel.fth 2009-12-28 23:41:31 UTC (rev 1640)
+++ forth/kernel/kernel.fth 2009-12-29 00:26:19 UTC (rev 1641)
@@ -1062,7 +1062,6 @@
defer ?permitted ' noop is ?permitted
-defer end-line ' noop is end-line
defer interpret
: (interpret (s -- )
begin
@@ -1073,7 +1072,6 @@
$compile
repeat
2drop
- end-line
;
' (interpret is interpret
Modified: forth/lib/tofile.fth
===================================================================
--- forth/lib/tofile.fth 2009-12-28 23:41:31 UTC (rev 1640)
+++ forth/lib/tofile.fth 2009-12-29 00:26:19 UTC (rev 1641)
@@ -14,37 +14,29 @@
\ keep a stack of output streams.
only forth also hidden also definitions
-variable old-end-line ' noop old-end-line token!
variable old-(emit ' noop old-(emit token!
variable old-(type ' noop old-(type token!
variable old-cr ' noop old-cr token!
variable old-exit? ' noop old-exit? token!
variable old-#out 0 old-#out !
variable old-#line 0 old-#line !
-variable saved-output-valid saved-output-valid off
forth definitions
: save-output ( -- )
- ['] end-line behavior old-end-line token!
['] (emit behavior old-(emit token!
['] (type behavior old-(type token!
['] cr behavior old-cr token!
['] exit? behavior old-exit? token!
#out @ old-#out !
#line @ old-#line !
- saved-output-valid on
;
: unsave-output ( -- )
- saved-output-valid @ if
- old-(emit token@ is (emit
- old-(type token@ is (type
- old-end-line token@ is end-line
- old-cr token@ is cr
- old-exit? token@ is exit?
- old-#out @ #out !
- old-#line @ #line !
- saved-output-valid off
- then
+ old-(emit token@ is (emit
+ old-(type token@ is (type
+ old-cr token@ is cr
+ old-exit? token@ is exit?
+ old-#out @ #out !
+ old-#line @ #line !
;
hidden definitions
: undo-file-output ( -- ) unsave-output ofd @ fclose ;
@@ -55,20 +47,25 @@
;
forth definitions
: file-output ( -- )
- save-output
- ['] undo-file-output is end-line
['] file-(emit is (emit
['] file-(type is (type
['] file-cr is cr
['] false is exit?
#out off #line off
;
+: evaluate-to-file ( adr len -- ??? )
+ save-output file-output ( adr len )
+ ['] evaluate catch ( ??? error? )
+ undo-file-output
+ throw
+;
+: cmdline-to-file ( -- ) 0 parse evaluate-to-file ;
: to-file \ filename ( -- )
- writing file-output
+ writing cmdline-to-file
;
: append-to-file \ filename ( -- )
- appending file-output
+ appending cmdline-to-file
;
only forth also definitions
9 years, 4 months
r1640 - in forth: kernel lib
by svn＠openfirmware.info
Author: wmb
Date: 2009-12-29 00:41:31 +0100 (Tue, 29 Dec 2009)
New Revision: 1640
Modified:
forth/kernel/kernel.fth
forth/lib/tofile.fth
Log:
OLPC trac 9932 - fixed to-file so it works inside scripts.
Modified: forth/kernel/kernel.fth
===================================================================
--- forth/kernel/kernel.fth 2009-12-28 23:34:14 UTC (rev 1639)
+++ forth/kernel/kernel.fth 2009-12-28 23:41:31 UTC (rev 1640)
@@ -1062,6 +1062,7 @@
defer ?permitted ' noop is ?permitted
+defer end-line ' noop is end-line
defer interpret
: (interpret (s -- )
begin
@@ -1072,6 +1073,7 @@
$compile
repeat
2drop
+ end-line
;
' (interpret is interpret
Modified: forth/lib/tofile.fth
===================================================================
--- forth/lib/tofile.fth 2009-12-28 23:34:14 UTC (rev 1639)
+++ forth/lib/tofile.fth 2009-12-28 23:41:31 UTC (rev 1640)
@@ -14,7 +14,7 @@
\ keep a stack of output streams.
only forth also hidden also definitions
-variable old-status ' noop old-status token!
+variable old-end-line ' noop old-end-line token!
variable old-(emit ' noop old-(emit token!
variable old-(type ' noop old-(type token!
variable old-cr ' noop old-cr token!
@@ -25,7 +25,7 @@
forth definitions
: save-output ( -- )
- ['] status behavior old-status token!
+ ['] end-line behavior old-end-line token!
['] (emit behavior old-(emit token!
['] (type behavior old-(type token!
['] cr behavior old-cr token!
@@ -38,7 +38,7 @@
saved-output-valid @ if
old-(emit token@ is (emit
old-(type token@ is (type
- old-status token@ is status
+ old-end-line token@ is end-line
old-cr token@ is cr
old-exit? token@ is exit?
old-#out @ #out !
@@ -56,7 +56,7 @@
forth definitions
: file-output ( -- )
save-output
- ['] undo-file-output is status
+ ['] undo-file-output is end-line
['] file-(emit is (emit
['] file-(type is (type
['] file-cr is cr
9 years, 4 months
r1639 - ofw/fs/cifs
by svn＠openfirmware.info
Author: wmb
Date: 2009-12-29 00:34:14 +0100 (Tue, 29 Dec 2009)
New Revision: 1639
Modified:
ofw/fs/cifs/smb.fth
Log:
Removed trailing whitespace in smb.fth. No functional change.
Modified: ofw/fs/cifs/smb.fth
===================================================================
--- ofw/fs/cifs/smb.fth 2009-12-28 23:21:06 UTC (rev 1638)
+++ ofw/fs/cifs/smb.fth 2009-12-28 23:34:14 UTC (rev 1639)
@@ -276,7 +276,7 @@
loop ( adr )
drop ( )
buf8 8
-;
+;
0 instance value password-buf
d# 16 buffer: p21-buf
@@ -386,7 +386,7 @@
--bytes-- ( path$ )
+path ( )
}smb ( true | rem$ false )
-;
+;
0 instance value fid
0 instance value attributes \ 01:RO 02:Hidden 04:System 08:Volume 10:Directory 20:Archive
@@ -658,12 +658,12 @@
dup h# 1f and 2* swap ( secs packed )
dup h# 07e0 and 5 >> swap ( secs mins packed )
h# f800 and d# 11 >> ( secs mins hours )
-;
+;
: >dmy ( dos-packed-date -- day month year )
dup h# 1f and swap ( day packed )
dup h# 01e0 and 5 >> swap ( day month packed )
h# fe00 and 9 >> d# 1980 + ( day month year )
-;
+;
\ Convert DOS file attributes to the firmware encoding
\ see showdir.fth for a description of the firmware encoding
: >canonical-attrs ( dos-attrs -- canon-attrs )
@@ -755,7 +755,7 @@
third 1+ 2* +xw ( path$ access flags ) \ Byte count for string + terminator
+xw ( path$ access ) \ Create flage
0 +xw ( path$ access ) \ Root FID
-
+
--bytes--
0 +xb \ Null share password
( path$ ) +unicode$
@@ -813,14 +813,14 @@
\ It's a file, so open it - first try to open read/write.
pathname$ 2 do-open if ( )
- \ Failing that, try to open read-only
+ \ Failing that, try to open read-only
pathname$ 0 do-open if ( )
free-buffers false exit
then ( )
then ( )
\ If any arguments remain, assume we are dealing with a ZIP
- \ archive and interpose the ZIP handler
+ \ archive and interpose the ZIP handler
tail$ dup if ( tail$ )
" zip-file-system" $interpose ( okay? )
else ( tail$ )
9 years, 4 months
r1638 - cpu/x86/pc/olpc/via ofw/fs/cifs
by svn＠openfirmware.info
Author: wmb
Date: 2009-12-29 00:21:06 +0100 (Tue, 29 Dec 2009)
New Revision: 1638
Modified:
cpu/x86/pc/olpc/via/factory.fth
ofw/fs/cifs/smb.fth
Log:
OLPC trac 9931 - Fixed bug in factory.fth related to calling open-file
Forth word instead of similarly-named method in CIFS driver. Renamed
CIFS methods "open-file" and "close-file" to "do-open" and "do-close"
to avoid the name collision.
Modified: cpu/x86/pc/olpc/via/factory.fth
===================================================================
--- cpu/x86/pc/olpc/via/factory.fth 2009-12-21 15:54:00 UTC (rev 1637)
+++ cpu/x86/pc/olpc/via/factory.fth 2009-12-28 23:21:06 UTC (rev 1638)
@@ -68,12 +68,12 @@
: put-key+value ( value$ key$ -- ) cifs-write put-key-line ;
: submit-file ( subdir$ -- )
" flush" $call-cifs abort" CIFS flush failed"
- " close-file" $call-cifs abort" CIFS close-file failed"
+ " do-close" $call-cifs abort" CIFS do-close failed"
tempname$ 2swap " %s\\%s" sprintf ( new-name$ )
\ Check for preexisting destination file
- 2dup 0 open-file 0= if ( new-name$ )
- close-file drop ( new-name$ )
+ 2dup 0 " do-open" $call-cifs 0= if ( new-name$ )
+ " do-close" $call-cifs drop ( new-name$ )
." Error: " type ." already exists on the server" cr ( )
tempname$ $delete drop ( )
abort
@@ -85,7 +85,7 @@
tempname$ 2swap " %s\\%s" sprintf ( response-name$ )
d# 10 0 do ( response-name$ )
d# 1000 ms ( response-name$ )
- 2dup 0 " open-file" $call-cifs 0= if ( response-name$ )
+ 2dup 0 " do-open" $call-cifs 0= if ( response-name$ )
2drop ( )
" size" $call-cifs ( d.size )
abort" Size is > 4 GB" ( size )
Modified: ofw/fs/cifs/smb.fth
===================================================================
--- ofw/fs/cifs/smb.fth 2009-12-21 15:54:00 UTC (rev 1637)
+++ ofw/fs/cifs/smb.fth 2009-12-28 23:21:06 UTC (rev 1638)
@@ -105,10 +105,10 @@
: -xb ( adr len -- adr' len' byte )
1 needed over c@ >r 1 /string r>
;
-: -xw ( adr len -- adr' len' byte )
+: -xw ( adr len -- adr' len' word )
2 needed over le-w@ >r 2 /string r>
;
-: -xl ( adr len -- adr' len' byte )
+: -xl ( adr len -- adr' len' long )
4 needed over le-l@ >r 4 /string r>
;
: drop-b ( rem$ -- rem$' ) -xb drop ;
@@ -410,7 +410,7 @@
\ Good value for access: h# 0002
\ Bits: 4000: WriteThrough 1000:DontCache 700:LocalityOfReference
\ 70: SharingMode 7: Access-0:RO,1:WO,2:RW,3:Exec
-: open-file ( path$ access -- error? )
+: do-open ( path$ access -- error? )
h# 02 smb{ ( path$ access )
+xw ( path$ )
attributes +xw ( path$ )
@@ -434,7 +434,7 @@
1 smb{ +path}smb empty-response
;
-: close-file ( -- error? )
+: do-close ( -- error? )
4 smb{
fid +xw
0 +xl \ Time
@@ -490,16 +490,17 @@
position nip +xl ( adr )
--bytes-- ( adr )
}smb if drop -1 exit then ( adr rem$ )
- d# 12 expect-wcnt ( adr rem$' )
- drop-andx ( adr rem$' )
- drop-w \ Reserved ( adr rem$' )
- drop-w \ Data compaction mode ( adr rem$' )
- drop-w \ Reserved ( adr rem$' )
- -xw >r \ Actual length ( adr rem$' r: actual )
- drop-w \ Offset to data ( adr rem$' r: actual )
- drop-w drop-w drop-w drop-w drop-w ( adr rem$' r: actual )
- -xw if drop-b then ( adr rem$' r: actual ) \ Byte count and pad
- drop swap r@ move r> ( actual )
+ over d# 32 - -rot \ SMB address ( adr smb-adr rem$ )
+ d# 12 expect-wcnt ( adr smb-adr rem$' )
+ drop-andx ( adr smb-adr rem$' )
+ drop-w \ Remaining ( adr smb-adr rem$' )
+ drop-w \ Data compaction mode ( adr smb-adr rem$' )
+ drop-w \ Reserved ( adr smb-adr rem$' )
+ -xw >r \ Actual length ( adr smb-adr rem$' r: actual )
+ -xw \ Offset to data ( adr smb-adr rem$' data-offset r: actual )
+ nip nip ( adr smb-adr data-offset r: actual )
+ + ( adr data-adr r: actual )
+ swap r@ move r> ( actual )
dup 0 position d+ to position ( actual )
;
: read ( adr len -- actual )
@@ -537,7 +538,7 @@
6 expect-wcnt ( rem$' )
drop-andx ( rem$' )
-xw >r \ Actual length ( rem$' r: actual )
-\ We don't anything following
+\ We don't need anything following
\ drop-w \ Remaining ( rem$' )
\ drop-l \ Reserved ( rem$' )
2drop r> ( actual )
@@ -811,9 +812,9 @@
h# 10 and if true exit then ( )
\ It's a file, so open it - first try to open read/write.
- pathname$ 2 open-file if ( )
+ pathname$ 2 do-open if ( )
\ Failing that, try to open read-only
- pathname$ 0 open-file if ( )
+ pathname$ 0 do-open if ( )
free-buffers false exit
then ( )
then ( )
@@ -827,7 +828,7 @@
then ( okay? )
;
: close ( -- )
- fid if close-file drop then
+ fid if do-close drop then
tree-disconnect drop
free-buffers
;
9 years, 4 months
r1637 - cpu/x86/pc/olpc/via
by svn＠openfirmware.info
Author: pgf
Date: 2009-12-21 16:54:00 +0100 (Mon, 21 Dec 2009)
New Revision: 1637
Modified:
cpu/x86/pc/olpc/via/mfgtests.txt
Log:
update with answers to a few of the questions re: the post-selftest stage.
Modified: cpu/x86/pc/olpc/via/mfgtests.txt
===================================================================
--- cpu/x86/pc/olpc/via/mfgtests.txt 2009-12-18 19:25:35 UTC (rev 1636)
+++ cpu/x86/pc/olpc/via/mfgtests.txt 2009-12-21 15:54:00 UTC (rev 1637)
@@ -111,13 +111,17 @@
wait-scanner
tag exchange with server
barcode scan of serial number to verify that the board and case are still paired
- ??? Is the filename the MB (B#) or the case serial number (SN) ?
- ??? If the filename is the SN, why is the SN in the request file?
- The server can't verify if it only has the SN and not the board#
+ the filename used in the tag exchange is based on the SN, despite
+ the additional cross-checking that would be available if it were
+ based on the MB number (B#).
delete MS and BD tags, insert tags from server
??? what is the format of the WP:N and AK:N info from the server? Is it WP:0 / WP:1, or presence/absence ?
TS should be SHIP at this point
??? Does the server send TS:SHIP or does the script inject it verbatim?
+ the TS tag as sent from the server is "FINAL". the script changes
+ it to "SHIP".
+ the final result report is submitted to the "Handshake" directory
+ on the server. (not "Result")
# If selftest failed, red screen and stop. State of machine (BD tag,
\runin\olpc.fth) left the same as at the start of this phase so
9 years, 5 months
r1636 - cpu/x86/pc/olpc/via dev
by svn＠openfirmware.info
Author: wmb
Date: 2009-12-18 20:25:35 +0100 (Fri, 18 Dec 2009)
New Revision: 1636
Added:
dev/logdev.fth
Modified:
cpu/x86/pc/olpc/via/fw.bth
Log:
OLPC trac 9903 - Added console logging facility.
Modified: cpu/x86/pc/olpc/via/fw.bth
===================================================================
--- cpu/x86/pc/olpc/via/fw.bth 2009-12-18 16:47:33 UTC (rev 1635)
+++ cpu/x86/pc/olpc/via/fw.bth 2009-12-18 19:25:35 UTC (rev 1636)
@@ -505,6 +505,8 @@
fload ${BP}/cpu/x86/pc/olpc/via/fsverify.fth
devalias fsdisk int:0
+fload ${BP}/dev/logdev.fth
+
fload ${BP}/ofw/inet/sntp.fth
: olpc-ntp-servers ( -- )
" DHCP time 172.18.0.1 0.pool.ntp.org 1.pool.ntp.org 2.pool.ntp.org"
@@ -558,6 +560,7 @@
install-mux-io
cursor-off
true to text-on?
+ start-logging
" //null" open-dev to null-ih \ For text-off state
Added: dev/logdev.fth
===================================================================
--- dev/logdev.fth (rev 0)
+++ dev/logdev.fth 2009-12-18 19:25:35 UTC (rev 1636)
@@ -0,0 +1,145 @@
+\ See license at end of file
+purpose: Device to log console output to memory
+
+dev /
+new-device
+
+" log" device-name
+
+0 value open-count
+0 value log-buf
+0 value log-size
+0 value log-wptr
+0 value log-rptr
+h# 1000 value log-increment
+
+: open ( -- flag )
+ open-count 0= if
+ log-size log-increment + to log-size
+ log-size alloc-mem to log-buf
+ 0 to log-wptr
+ then
+ open-count 1+ to open-count
+ true
+;
+: close ( -- )
+ open-count 1 = if
+ log-buf log-size free-mem
+ 0 to log-size
+ 0 to log-buf
+ 0 to log-wptr
+ then
+ 0 to log-rptr
+ open-count 1- to open-count
+;
+
+: size ( -- ud ) log-wptr u>d ;
+: seek ( ud -- error? )
+ 0<> if drop true exit then ( low ) \ High word must be 0
+ dup log-size > if drop true exit then ( low )
+ to log-rptr
+;
+: write ( adr len -- actual )
+ dup log-wptr + log-size - ( adr len needed )
+ dup 0> if ( adr len needed )
+ log-increment round-up ( adr len needed' )
+ log-size + dup to log-size ( adr len new-size )
+ log-buf over resize if ( adr len new-size buf-adr )
+ 4drop 0 exit ( -- 0 )
+ then ( adr len new-size buf-adr )
+ to log-buf to log-size ( adr len )
+ else ( adr len needed )
+ drop ( adr len )
+ then ( adr len )
+ tuck log-buf log-wptr + swap move ( len )
+ dup log-wptr + to log-wptr ( len )
+;
+: read ( adr len -- actual )
+ log-wptr log-rptr - ( adr len avail )
+ min tuck ( actual adr actual )
+ log-rptr log-buf + -rot move ( actual )
+ dup log-rptr + to log-rptr ( actual )
+;
+: load ( adr -- len )
+ log-buf swap log-wptr move
+ log-wptr
+;
+
+finish-device
+device-end
+
+0 value log-ih
+: start-logging ( -- )
+ log-ih 0= if
+ " /log" open-dev to log-ih
+ log-ih add-output
+ then
+;
+: stop-logging ( -- )
+ log-ih if
+ log-ih remove-output
+ log-ih close-dev
+ 0 to log-ih
+ then
+;
+: save-log ( "filename" -- )
+ " /log" safe-parse-word $copy1
+;
+: no-esc-list ( adr len -- )
+ bounds ?do ( -- )
+ i c@ bl >= i c@ h# 9b <> and if
+ i c@ emit
+ else
+ i c@ case
+ newline of newline emit exit? ?leave endof
+ carret of carret emit endof
+ tab of tab emit endof
+\ bs of bs emit endof
+ h# 9b of ." ^[" endof
+ ( default )
+ ." ^" dup h# 1f and [char] @ or emit
+ endcase
+ then
+ loop
+;
+: show-log-no-ctl ( -- )
+ log-ih remove-output
+ ." <OFW_Console_Log>" cr
+ ['] no-esc-list ['] list ['] more (patch
+ " more /log" evaluate
+ ['] list ['] no-esc-list ['] more (patch
+ ." </OFW_Console_Log>" cr
+ log-ih add-output
+;
+
+: show-log ( -- )
+ log-ih remove-output
+ ." <OFW_Console_Log>" cr
+ " more /log" evaluate
+ ." </OFW_Console_Log>" cr
+ log-ih add-output
+;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2009 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
9 years, 5 months
r1635 - cpu/x86/pc/olpc/via
by svn＠openfirmware.info
Author: wmb
Date: 2009-12-18 17:47:33 +0100 (Fri, 18 Dec 2009)
New Revision: 1635
Modified:
cpu/x86/pc/olpc/via/cstate.fth
Log:
OLPC trac 9917 - Added warning to lid power off and lid-off / lid-on commands
to disable / enable the lid shutdown function.
Modified: cpu/x86/pc/olpc/via/cstate.fth
===================================================================
--- cpu/x86/pc/olpc/via/cstate.fth 2009-12-18 16:34:29 UTC (rev 1634)
+++ cpu/x86/pc/olpc/via/cstate.fth 2009-12-18 16:47:33 UTC (rev 1635)
@@ -32,11 +32,20 @@
false value lid-already-down?
0 value lid-down-time
d# 10000 constant lid-shutdown-ms
+d# 2000 constant lid-warning-ms
+0 value lid-warned?
: ?lid-shutdown ( -- )
lid-down? if
lid-already-down? if
acpi-timer@ lid-down-time - d# 3580 / ( ms )
+
+ dup lid-warning-ms >= lid-warned? 0= and if
+ ." Lid switch is active - Powering off in 8 seconds" cr
+ ." Type lid-off to disable this function" cr
+ true to lid-warned?
+ then ( ms )
+
lid-shutdown-ms >= if
." Powering off after 10 seconds of lid down" cr
power-off
@@ -47,12 +56,18 @@
then
else
false to lid-already-down?
+ false to lid-warned?
then
;
+defer do-lid
+: lid-on ( -- ) ['] ?lid-shutdown to do-lid ;
+: lid-off ( -- ) ['] noop to do-lid ;
+lid-on
+
defer do-idle ' noop to do-idle
-: safe-idle ( -- ) can-idle? if do-idle then ?lid-shutdown ;
+: safe-idle ( -- ) can-idle? if do-idle then do-lid ;
' safe-idle to stdin-idle
alias c1-idle halt
9 years, 5 months
r1634 - cpu/x86/pc/olpc/via
by svn＠openfirmware.info
Author: wmb
Date: 2009-12-18 17:34:29 +0100 (Fri, 18 Dec 2009)
New Revision: 1634
Modified:
cpu/x86/pc/olpc/via/cstate.fth
Log:
OLPC trac 9917 - OFW powers off the machine after 10 seconds with the lid closed.
Modified: cpu/x86/pc/olpc/via/cstate.fth
===================================================================
--- cpu/x86/pc/olpc/via/cstate.fth 2009-12-18 16:26:09 UTC (rev 1633)
+++ cpu/x86/pc/olpc/via/cstate.fth 2009-12-18 16:34:29 UTC (rev 1634)
@@ -28,9 +28,31 @@
then
;
+: lid-down? ( -- flag ) h# 48 acpi-l@ h# 80 and 0= ;
+false value lid-already-down?
+0 value lid-down-time
+d# 10000 constant lid-shutdown-ms
+
+: ?lid-shutdown ( -- )
+ lid-down? if
+ lid-already-down? if
+ acpi-timer@ lid-down-time - d# 3580 / ( ms )
+ lid-shutdown-ms >= if
+ ." Powering off after 10 seconds of lid down" cr
+ power-off
+ then
+ else
+ acpi-timer@ to lid-down-time
+ true to lid-already-down?
+ then
+ else
+ false to lid-already-down?
+ then
+;
+
defer do-idle ' noop to do-idle
-: safe-idle ( -- ) can-idle? if do-idle then ;
+: safe-idle ( -- ) can-idle? if do-idle then ?lid-shutdown ;
' safe-idle to stdin-idle
alias c1-idle halt
9 years, 5 months
r1633 - cpu/x86/pc/olpc/via dev/usb2/hcd/ehci
by svn＠openfirmware.info
Author: wmb
Date: 2009-12-18 17:26:09 +0100 (Fri, 18 Dec 2009)
New Revision: 1633
Modified:
cpu/x86/pc/olpc/via/usb.fth
dev/usb2/hcd/ehci/ehci.fth
dev/usb2/hcd/ehci/probe.fth
Log:
OLPC trac 9902 - USB selftest in diagnostic mode now waits for a
device to be connected to each port.
Modified: cpu/x86/pc/olpc/via/usb.fth
===================================================================
--- cpu/x86/pc/olpc/via/usb.fth 2009-12-18 06:54:56 UTC (rev 1632)
+++ cpu/x86/pc/olpc/via/usb.fth 2009-12-18 16:26:09 UTC (rev 1633)
@@ -13,7 +13,7 @@
;
\ Restrict selftest to external USB ports 1,2,3
-dev / 2 " usb-max-test-port" integer-property dend
+dev / 3 " usb-test-ports" integer-property dend
: (probe-usb2) ( -- )
" device_type" get-property if exit then
Modified: dev/usb2/hcd/ehci/ehci.fth
===================================================================
--- dev/usb2/hcd/ehci/ehci.fth 2009-12-18 06:54:56 UTC (rev 1632)
+++ dev/usb2/hcd/ehci/ehci.fth 2009-12-18 16:26:09 UTC (rev 1633)
@@ -196,39 +196,6 @@
then
;
-external
-
-: selftest ( -- error? )
- ehci-reg dup 0= if map-regs then
-
- " 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
- i test-port-end
- 0 i portsc! i reset-port i power-port
- then
- loop
- 0= if unmap-regs then
- false
-;
-
-headers
-
\ LICENSE_BEGIN
\ Copyright (c) 2006 FirmWorks
\
Modified: dev/usb2/hcd/ehci/probe.fth
===================================================================
--- dev/usb2/hcd/ehci/probe.fth 2009-12-18 06:54:56 UTC (rev 1632)
+++ dev/usb2/hcd/ehci/probe.fth 2009-12-18 16:26:09 UTC (rev 1633)
@@ -30,7 +30,10 @@
make-device-node ( )
;
+0 instance value probe-error? \ Back channel to selftest
+
: probe-root-hub-port ( port -- )
+ false to probe-error?
dup portsc@ 1 and 0= if drop exit then \ No device detected
dup portsc@ h# c00 and h# 400 = if \ A low speed device detected
dup disown-port \ Disown the port
@@ -41,9 +44,11 @@
else \ A high speed device detected
dup ['] make-root-hub-node catch if \ Process high speed device
drop ." Failed to probe root port " dup .d cr
+ true to probe-error?
then
then
- then drop
+ then ( port# )
+ dup portsc@ swap portsc! ( ) \ Clear connection change bit
;
: grab-controller ( -- error? )
@@ -69,7 +74,44 @@
false
;
+: probe-setup ( -- )
+ \ Set active-package so device nodes can be added and removed
+ my-self ihandle>phandle push-package
+
+ alloc-pkt-buf
+;
+: probe-teardown ( -- )
+ free-pkt-buf
+ pop-package
+;
+
+: #testable-ports ( -- n )
+ #ports ( #hardware-ports )
+ " usb-test-ports" get-inherited-property 0= if ( #hardware-ports adr len )
+ decode-int nip nip min ( #testable-ports )
+ then ( #testable-ports )
+;
+
+: wait-connect ( port# -- error? )
+ begin ( port# )
+ dup portsc@ h# 2001 and 0= ( port# unconnected? )
+ while ( port# )
+ key? if ( port# )
+ key h# 1b = if ( port# ) \ ESC aborts
+ drop true exit ( -- true )
+ then ( port# )
+ then ( port# )
+ repeat ( port# )
+ ." Device connected - probing ... "
+ probe-setup ( port# )
+ dup probe-root-hub-port ( port# )
+ probe-teardown ( port# )
+ probe-error? ( error? )
+ dup if ." Failed" else ." Done" then cr ( error? )
+;
+
external
+
: power-usb-ports ( -- ) ;
: ports-changed? ( -- flag )
@@ -80,20 +122,16 @@
;
: probe-root-hub ( -- )
- \ Set active-package so device nodes can be added and removed
- my-self ihandle>phandle push-package
+ probe-setup
- alloc-pkt-buf
#ports 0 ?do \ For each port
i portsc@ 2 and if \ Connection changed
i rm-obsolete-children \ Remove obsolete device nodes
i probe-root-hub-port \ Probe it
- i portsc@ i portsc! \ Clear connection change bit
then
loop
- free-pkt-buf
- pop-package
+ probe-teardown
;
: open ( -- flag )
@@ -135,6 +173,29 @@
open-count 0= if free-dma-buf unmap-regs then
;
+: selftest ( -- error? )
+ ehci-reg dup 0= if map-regs then
+
+ #testable-ports 0 ?do
+ i portsc@ h# 2001 and if \ Port owned by usb 1.1 controller (2000) or device is present (1)
+ ." USB 2.0 port " i u. ." in use" cr
+ else
+ diagnostic-mode? if
+ ." Please connect a device to USB port " i u. " !" cr
+ i wait-connect if true unloop exit then
+ else
+ ." Fisheye pattern out to USB 2.0 port " i u. cr
+ i test-port-begin
+ d# 2,000 ms
+ i test-port-end
+ 0 i portsc! i reset-port i power-port
+ then
+ then
+ loop
+ 0= if unmap-regs then
+ false
+;
+
headers
\ LICENSE_BEGIN
9 years, 5 months
r1632 - ofw/fs/ext2fs
by svn＠openfirmware.info
Author: wmb
Date: 2009-12-18 07:54:56 +0100 (Fri, 18 Dec 2009)
New Revision: 1632
Modified:
ofw/fs/ext2fs/dir.fth
ofw/fs/ext2fs/inode.fth
ofw/fs/ext2fs/methods.fth
Log:
OLPC trac 6210 - improvements to ext2 filesystem driver, particularly
to implement $rename. In the process I checked several other functions
carefully.
Modified: ofw/fs/ext2fs/dir.fth
===================================================================
--- ofw/fs/ext2fs/dir.fth 2009-12-18 03:44:13 UTC (rev 1631)
+++ ofw/fs/ext2fs/dir.fth 2009-12-18 06:54:56 UTC (rev 1632)
@@ -10,6 +10,13 @@
variable diroff
variable totoff
+\ Information that we need about the working file/directory
+\ The working file changes at each level of a path search
+
+0 instance value wd-inum \ Inumber of directory to search
+0 instance value wf-inum \ Inumber of file or directory found
+0 instance value wf-type \ Type - 4 for directory, d# 10 for symlink, etc
+
: get-dirblk ( -- end? )
lblk# bsize * file-size >= if true exit then
lblk# >pblk# to dir-block#
@@ -28,14 +35,14 @@
: >reclen ( name-length -- record-length ) 8 + 4 round-up ;
: dirent-inode@ ( -- n ) dirent int@ ;
-: dirent-inode! ( n -- ) dirent int! ;
+: dirent-inode! ( n -- ) dirent int! update ;
: dirent-len@ ( -- n ) dirent la1+ short@ ;
-: dirent-len! ( n -- ) dirent la1+ short! ;
+: dirent-len! ( n -- ) dirent la1+ short! update ;
: dirent-nameadr ( -- adr ) dirent la1+ 2 wa+ ;
: dirent-namelen@ ( -- b ) dirent la1+ wa1+ c@ ;
-: dirent-namelen! ( b -- ) dirent la1+ wa1+ c! ;
+: dirent-namelen! ( b -- ) dirent la1+ wa1+ c! update ;
: dirent-type@ ( -- b ) dirent la1+ wa1+ ca1+ c@ ;
-: dirent-type! ( b -- ) dirent la1+ wa1+ ca1+ c! ;
+: dirent-type! ( b -- ) dirent la1+ wa1+ ca1+ c! update ;
: dirent-reclen ( -- n ) dirent-namelen@ >reclen ;
: lblk#++ ( -- ) lblk# 1+ to lblk# ;
@@ -44,7 +51,7 @@
diroff @ totoff @ lblk# inode#
;
: restore-dirent ( diroff totoff lblk# inode# -- )
- to inode# to lblk# totoff ! diroff !
+ set-inode to lblk# totoff ! diroff !
get-dirblk drop
;
@@ -59,35 +66,28 @@
false
;
-\ **** From directory, get handle of the file or subdir that it references
-\ For Unix, file handle is the inode #
-: file-handle ( -- i# ) dirent-inode@ ;
-
\ **** From directory, get name of file
: file-name ( -- adr len )
dirent la1+ wa1+ dup wa1+ ( len-adr name-adr )
swap c@ ( adr len )
;
-\
-\ high-level routines
-\
-\ After this point, the code should be independent of the disk format!
+: +link-count ( increment -- ) link-count + link-count! ;
-: init-inode ( mode inode# -- )
- inode >r ( mode r: inode-adr )
- r@ /inode erase ( mode r: inode-adr )
- r@ short! ( r: inode-adr )
- time&date >unix-seconds ( time r: inode-adr )
- dup r@ 2 la+ int! ( time r: inode-adr ) \ set access time
- dup r@ 3 la+ int! ( time r: inode-adr ) \ set creation time
- r@ 4 la+ int! ( r: inode-adr ) \ set modification time
- 1 r@ d# 13 wa+ short! ( r: inode-adr ) \ set links_count to 1
- update ( r: inode-adr )
- r> drop ( )
+: new-inode ( mode -- inode# )
+ alloc-inode set-inode
+ 0 +i /inode erase ( mode )
+ file-attr! ( )
+ time&date >unix-seconds ( time )
+ dup atime! ( time ) \ set access time
+ dup ctime! ( time ) \ set creation time
+ mtime! ( ) \ set modification time
+ 1 link-count! ( ) \ set links_count to 1
+ inode# ( inode# )
;
\ On entry:
+\ inode# refers to the directory block's inode
\ dir-block# is the physical block number of the first directory block
\ diroff @ is 0
\ On successful exit:
@@ -136,14 +136,46 @@
(last-dirent) drop
dirent-len@ dirent-reclen -
;
-: set-dirent ( name$ type rec-len file-type inode# -- )
- dirent int! ( name$ rec-len )
+0 constant unknown-type
+1 constant regular-type
+2 constant dir-type
+3 constant chrdev-type
+4 constant blkdev-type
+5 constant fifo-type
+6 constant sock-type
+7 constant symlink-type
+
+create dir-types
+ unknown-type c, \ 0
+ fifo-type c, \ 1
+ chrdev-type c, \ 2
+ unknown-type c, \ 3
+ dir-type c, \ 4
+ unknown-type c, \ 5
+ blkdev-type c, \ 6
+ unknown-type c, \ 7
+ regular-type c, \ 8
+ unknown-type c, \ 9
+ symlink-type c, \ 10
+ unknown-type c, \ 11
+ sock-type c, \ 12
+ unknown-type c, \ 13
+ unknown-type c, \ 14
+ unknown-type c, \ 15
+
+: inode>dir-type ( -- dir-type )
+ filetype d# 12 rshift ( index )
+ dir-types + c@
+;
+
+: fill-dirent ( name$ rec-len inode# -- )
+ dup set-inode 1 +link-count ( name$ rec-len inode# dir-type )
\ XXX this should be contingent upon EXT2_FEATURE_INCOMPAT_FILETYPE
- dirent-type! ( name$ )
- dirent-len! ( name$ )
- dup dirent-namelen! ( name$ )
- dirent-nameadr swap move ( )
- update
+ inode>dir-type dirent-type! ( name$ rec-len inode# )
+ dirent-inode! ( name$ rec-len )
+ dirent-len! ( name$ )
+ dup dirent-namelen! ( name$ )
+ dirent-nameadr swap move ( )
;
: to-previous-dirent ( -- )
@@ -157,8 +189,24 @@
diroff @ swap - totoff +! ( )
;
+\ Delete the currently selected inode. Does not affect the directory entry, if any.
+: idelete ( -- )
+ delete-blocks
+ \ clear #blks-held, link-count, etc.
+ 0 +i /inode 6 /l* /string erase
+
+ \ delete inode, and set its deletion time.
+ time&date >unix-seconds dtime!
+ inode# free-inode
+;
+
\ delete directory entry at diroff
-: del-dirent ( -- error? )
+: dirent-unlink ( -- )
+ dirent-inode@ set-inode -1 +link-count
+
+ \ Release the inode if it has no more links
+ link-count 0<= if idelete then
+
diroff @ if
\ Not first dirent in block; coalesce with previous
dirent-len@ ( deleted-len )
@@ -170,31 +218,40 @@
\ First dirent in block; zap its inode
0 dirent-inode!
then
- update
- false
;
-1 constant regular-type
-2 constant dir-type
-7 constant symlink-type
+\ The argument inode# means the inode to which the new directory entry
+\ will refer. The inode of the containing directory is in the *value*
+\ named inode#
-: ($create) ( name$ mode -- error? )
- >r ( name$ r: mode )
+: new-dirent ( name$ inode# -- error? )
+ >r ( name$ r: inode# )
\ check for room in the directory, and expand it if necessary
- dup >reclen no-dir-space? if ( name$ new-reclen r: mode )
+ dup >reclen no-dir-space? if ( name$ new-reclen r: inode# )
\ doesn't fit, allocate more room
- bsize ( name$ bsize r: mode )
- append-block
- lblk#++ get-dirblk drop
- then ( name$ rec-len r: mode )
+ bsize ( name$ bsize r: inode# )
+ append-block ( name$ bsize r: inode# )
+ lblk#++ get-dirblk if ( name$ bsize r: inode# )
+ r> 4drop ( )
+ true exit ( -- true )
+ then ( name$ bsize r: inode# )
+ then ( name$ rec-len r: inode# )
\ At this point dirent points to the place for the new dirent
- \ XXX handle symlinks!
- r@ h# f000 and h# 4000 = if dir-type else regular-type then ( name$ rec-len type r: mode )
- alloc-inode set-dirent false ( error? r: mode )
- r> dirent-inode@ init-inode
+ r> fill-dirent ( )
+ false ( error? )
;
+: ($create) ( name$ mode -- error? )
+ new-inode ( name$ inode# )
+
+ \ new-inode changed the value of inode#; we must restore it so
+ \ new-dirent can find info about the containing diretory
+ wd-inum set-inode ( name$ inode# )
+
+ new-dirent ( error? )
+;
+
: linkpath ( -- a )
file-acl if bsize 9 rshift else 0 then ( #acl-blocks )
#blks-held <> if \ long symbolic link path
@@ -204,15 +261,6 @@
then
;
-\ --
-
-\ Information that we need about the working file/directory
-\ The working file changes at each level of a path search
-
-0 instance value wd-inum \ Inumber of directory to search
-0 instance value wf-inum \ Inumber of file or directory found
-0 instance value wf-type \ Type - 4 for directory, d# 10 for symlink, etc
-
char \ instance value delimiter
defer $resolve-path
@@ -231,13 +279,9 @@
then ( name$ )
;
-: set-inode ( inode# -- )
- to inode#
- 0 to lblk#
-;
-
: first-dirent ( dir-inode# -- end? ) \ Adapted from (init-dir)
set-inode
+ 0 to lblk#
get-dirblk if true exit then
diroff off totoff off ( )
false ( )
@@ -273,7 +317,7 @@
;
: symlink-resolution$ ( inum -- data$ )
- to inode#
+ set-inode
linkpath dup cstrlen
;
@@ -352,59 +396,24 @@
\ Returns true if inode# refers to a directory that is empty
\ Side effect - changes dirent context
-: empty-dir? ( -- empty-dir? )
+: empty-dir? ( inode# -- empty-dir? )
+ set-inode
+
dir? 0= if false exit then
- file-handle first-dirent if false exit then \ Should be pointing to "." entry
+ inode# first-dirent if false exit then \ Should be pointing to "." entry
next-dirent if false exit then \ Should be point to ".." entry
next-dirent ( end? ) \ The rest should be empty
;
-\ Delete a file, given its inode. Does not affect the directory entry, if any.
-: idelete ( inode# -- )
- to inode#
- delete-blocks
- \ clear #blks-held, link-count, etc.
- inode# inode /inode 6 /l* /string erase
-
- \ delete inode, and set its deletion time.
- time&date >unix-seconds ( time )
- inode# inode 5 la+ int! update
- inode# free-inode
-;
-
-\ Delete the file at dirent
-: (delete-file) ( -- error? )
- file-handle 0= if true exit then
-
- inode# >r
- file-handle set-inode
- file? 0= if r> drop true exit then \ XXX handle symlinks
-
- \ is this the only link?
- link-count dup 2 u< if
- drop
- inode# idelete
- else
- 1- link-count!
- then
-
- r> to inode#
- \ delete directory entry
- del-dirent ( error? )
-;
-: (delete-files) ( -- ) \ from current directory. used by rmdir
- begin (delete-file) until
-;
-
external
\ directory information
: file-info ( id -- false | id' s m h d m y len attributes name$ true )
- inode# >r file-handle to inode# ( id )
- 1+ file-sec unix-seconds> file-size file-attr file-name true
- r> to inode#
+ inode# >r dirent-inode@ set-inode ( id )
+ 1+ mtime unix-seconds> file-size file-attr file-name true
+ r> set-inode
;
\ Deleted files at the beginning of a directory block have inode=0
@@ -412,7 +421,7 @@
dup if
begin
next-dirent 0= while
- file-handle if file-info exit then
+ dirent-inode@ if file-info exit then
repeat
drop false
Modified: ofw/fs/ext2fs/inode.fth
===================================================================
--- ofw/fs/ext2fs/inode.fth 2009-12-18 03:44:13 UTC (rev 1631)
+++ ofw/fs/ext2fs/inode.fth 2009-12-18 06:54:56 UTC (rev 1632)
@@ -4,6 +4,7 @@
decimal
0 instance value inode#
+: set-inode ( inode# -- ) to inode# ;
: ipb ( -- n ) bsize /inode / ;
: itob ( i# -- offset block# )
@@ -18,10 +19,22 @@
: ind ( n -- ) inode /inode dump ;
: +i ( n -- ) inode# inode + ;
: file-attr ( -- attributes ) 0 +i short@ ;
+: file-attr! ( attributes -- ) 0 +i short! update ;
+: uid ( -- uid ) 2 +i short@ ;
+: uid! ( uid -- ) 2 +i short! update ;
: filetype ( -- type ) file-attr h# f000 and ;
: file-size ( -- n ) 4 +i int@ ;
: file-size! ( n -- ) 4 +i int! update ;
-: file-sec ( -- seconds ) 16 +i int@ ; \ mtime -- is that what we want?
+: atime ( -- seconds ) 8 +i int@ ;
+: atime! ( seconds -- ) 8 +i int! update ;
+: ctime ( -- seconds ) 12 +i int@ ;
+: ctime! ( seconds -- ) 12 +i int! update ;
+: mtime ( -- seconds ) 16 +i int@ ;
+: mtime! ( seconds -- ) 16 +i int! update ;
+: dtime ( -- seconds ) 20 +i int@ ;
+: dtime! ( seconds -- ) 20 +i int! update ;
+: gid ( -- gid ) 24 +i short@ ;
+: gid! ( gid -- ) 24 +i short! update ;
: link-count ( -- n ) 26 +i short@ ;
: link-count! ( n -- ) 26 +i short! update ;
: #blks-held ( -- n ) 28 +i int@ ;
Modified: ofw/fs/ext2fs/methods.fth
===================================================================
--- ofw/fs/ext2fs/methods.fth 2009-12-18 03:44:13 UTC (rev 1631)
+++ ofw/fs/ext2fs/methods.fth 2009-12-18 06:54:56 UTC (rev 1632)
@@ -15,50 +15,97 @@
: $mkdir ( name$ -- error? )
o# 40777 ($create) if true exit then
- link-count 1+ link-count! \ The ".." entry is another link to parent
- file-handle to inode#
- link-count 1+ link-count! \ The "." entry is another link to the new directory
+ dirent-inode@ set-inode
- add-block ( block# )
+ add-block ( block# )
file-size h# 400 + file-size!
- dup direct0 int! update ( block# )
- block bsize erase update \ flush
- wd-inum >r
- inode# first-dirent if r> drop true exit then
- " ." d# 12 dir-type inode# set-dirent
- d# 12 diroff !
- " .." bsize d# 12 - dir-type r> set-dirent
- false ( error? )
+ dup direct0 int! update ( block# )
+ block bsize erase update \ flush ( )
+ inode# first-dirent if true exit then ( )
+ " ." bsize inode# fill-dirent ( )
+ " .." wd-inum new-dirent ( error? )
diroff off
;
: $delete ( name$ -- error? )
$find-file if true exit then ( )
-
- (delete-file)
+
+ wf-type dir-type = if true exit then
+
+ dirent-unlink
+ false
;
: $delete! $delete ; \ XXX should these be different?
+: $hardlink ( old-name$ new-name$ -- error? )
+ \ Save the current search context. The path part of the new name
+ \ has already been parsed out and resolved. Resolving old-name$ changes
+ \ the directory context, so we will need to restore the context for the
+ \ new name to create its dirent.
+ dirent-vars 2>r 2>r ( new-name$ r: 4xVars )
+
+ 2swap $find-file if ( new-name$ r: 4xVars )
+ 2drop 2r> 2r> 4drop true exit
+ then ( new-name$ r: 4xVars )
+
+ \ Hard links to directories mess up the filesystem tree
+ wf-type dir-type = if 2drop true exit then ( new-name$ r: 4xVars)
+
+ 2r> 2r> restore-dirent ( new-name$ )
+ wf-inum new-dirent ( error? )
+;
+
+: $rename ( old-name$ new-name$ -- error? )
+ \ If new-name$ is null, the destination is a directory (which has
+ \ already been located), so we set the destination filename to be
+ \ the same as the filename component of the old path.
+ dup 0= if ( old-path$ new-name$ )
+ 2drop ( old-path$ )
+ 2dup [char] \ right-split-string ( old-path$ name$ dir$ )
+ 2drop ( old-path$ new-name$ )
+ then ( old-path$ new-name$ )
+
+ 2over 2swap $hardlink if 2drop true exit then ( old-name$ )
+ $delete
+;
+
: $rmdir ( name$ -- error? )
$find-file if true exit then ( )
wf-type dir-type <> if true exit then ( )
+
\ Now the dirent is the one for the directory to delete and the
\ inode is for the parent directory
-
- dirent-vars 2>r 2>r \ save lookup state in parent directory
- file-handle set-inode \ Switch the inode to the directory to delete
- empty-dir? 0= if 2r> 2r> 4drop true exit then
+ dirent-inode@ >r ( r: dir-i# )
- \ The directory is empty so it's okay to remove it
- delete-blocks \ Release the data blocks used for dirent storage
- inode# free-inode \ Release the inode number
+ \ First verify that the directory to delete is empty
+ dirent-vars ( 4xVars r: dir-i# )
+ r@ empty-dir? 0= if r> drop 4drop true exit then
+ restore-dirent ( r: dir-i# )
+
+ \ Remove the dirent from the parent directory; the inode will not
+ \ be freed yet because its link count is still nonzero due to the
+ \ directory's "." entry.
+ dirent-unlink ( r: dir-i# )
+
+ \ First delete the ".." entry
+ " .." r@ $find-name if ( r: dir-i# )
+ ." Corrupt filesystem - directory does not have .. entry" cr
+ r> drop true exit
+ then ( r: dir-i# )
+ dirent-unlink ( r: dir-i# )
+
+ \ Then delete the "." entry
+ \ The link count should go to 0, freeing the directory blocks
+ " ." r@ $find-name if ( r: dir-i# )
+ ." Corrupt filesystem - directory does not have . entry" cr
+ r> drop true exit
+ then ( r: dir-i# )
+ dirent-unlink ( r: dir-i# )
+
+ r> drop ( )
- 2r> 2r> restore-dirent \ restore lookup state in parent directory
-
- del-dirent if true exit then \ Remove the dirent from the parent directory
- link-count 1- link-count! \ Decrement parent link count
false
;
@@ -76,7 +123,7 @@
drop bfbase @ bsize free-mem \ Registered with initbuf
modified? if
false to modified?
- time&date >unix-seconds file-handle inode 4 la+ int! update
+ time&date >unix-seconds dirent-inode@ set-inode ctime!
then
;
@@ -115,12 +162,12 @@
-rot $find-file if drop false exit then ( mode )
wf-type regular-type <> if drop false exit then ( mode )
- file-handle set-inode ( mode )
+ dirent-inode@ set-inode ( mode )
false to modified?
>r
bsize alloc-mem bsize initbuf
- file-handle r@ ['] ext2fsdflen ['] ext2fsdfalign ['] ext2fsfclose ['] ext2fsdfseek
+ dirent-inode@ r@ ['] ext2fsdflen ['] ext2fsdfalign ['] ext2fsfclose ['] ext2fsdfseek
r@ read = unknown-extensions? or if ['] nullwrite else ['] ext2fsfwrite then
r> write = if ['] nullread else ['] ext2fsfread then
true
9 years, 5 months