Return to citrine-disk.fs CVS log

Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / board-js2x / slof

Annotation of qemu/roms/SLOF/board-js2x/slof/citrine-disk.fs, revision 1.1.1.1

1.1       root        1: \ *****************************************************************************
                      2: \ * Copyright (c) 2004, 2008 IBM Corporation
                      3: \ * All rights reserved.
                      4: \ * This program and the accompanying materials
                      5: \ * are made available under the terms of the BSD License
                      6: \ * which accompanies this distribution, and is available at
                      7: \ * http://www.opensource.org/licenses/bsd-license.php
                      8: \ *
                      9: \ * Contributors:
                     10: \ *     IBM Corporation - initial implementation
                     11: \ ****************************************************************************/
                     12: 
                     13: 
                     14: ( max-#blocks rsrc id -- )
                     15: 
                     16: new-device   
                     17: 
                     18: lwsplit swap wbsplit rot set-unit
                     19: 
                     20: s" disk" device-name  s" block" device-type
                     21: 
                     22: CONSTANT resource-id
                     23: CONSTANT max-#blocks
                     24: get-parent CONSTANT ppack
                     25: 
                     26: 
                     27: : our-disk-read ( lba count addr -- )
                     28:   >r >r >r resource-id r> r> r> s" do-read" ppack $call-static ;
                     29: 
                     30: 0 pci-alias-disk
                     31: 
                     32: \ Requiered interface for deblocker
                     33: 
                     34: 200   CONSTANT block-size
                     35: 40000 CONSTANT max-transfer 
                     36: 
                     37: : read-blocks ( addr block# #blocks -- #read )
                     38: \   my-unit s" dev-read-blocks" $call-parent
                     39:    \ check if the read is within max-#blocks
                     40:    2dup + max-#blocks 1 + > IF 
                     41:      \ 2drop drop 0 \ return 0 
                     42:      \ returning 0 would be correct (maybe?) but it confuses the deblocker...
                     43:      \ so i erase whatever would have been read and return the "expected" #read
                     44:      dup >r 
                     45:      swap drop \ drop block# (not needed)
                     46:      block-size * erase \ erase at addr #blocks * block-size
                     47:      r>   \ return #read 
                     48:    ELSE
                     49:      dup >r rot our-disk-read r>
                     50:    THEN
                     51: ;    
                     52: 
                     53: INSTANCE VARIABLE deblocker
                     54: 
                     55: : open ( -- okay? )
                     56:    0 0 s" deblocker" $open-package dup deblocker ! dup IF 
                     57:       s" disk-label" find-package IF
                     58:         my-args rot interpose
                     59:       THEN
                     60:    THEN 0<> ;
                     61: 
                     62: : close ( -- )
                     63:    deblocker @ close-package ;
                     64: 
                     65: : seek ( pos.lo pos.hi -- status )
                     66:    2dup lxjoin max-#blocks 1 + block-size *  > IF 
                     67:      \ illegal seek, return -1
                     68:      2drop -1
                     69:    ELSE
                     70:      s" seek" deblocker @ $call-method
                     71:    THEN
                     72: ;
                     73: 
                     74: : read ( addr len -- actual )
                     75:    s" read" deblocker @ $call-method ;
                     76: 
                     77: 
                     78: finish-device
                     79: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.