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     ! 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.