qemu/roms/SLOF/board-js2x/slof/citrine-disk.fs

   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