cleanbf.icl

   1 module cleanbf
   2
   3 import Data.Either
   4 import System.CommandLine
   5 import Data.Error
   6 import System.File
   7
   8 import _SystemArray
   9 import StdEnv
  10
  11 TAPESIZE :== 1024
  12 :: *BFState = {pc :: Int, tc :: Int, io :: *File, cs :: [Int], tape :: *{Int},
  13         prog :: String}
  14
  15 bf :: *BFState -> Either *BFState *BFState
  16 bf st=:{prog,pc,tc,tape,cs}
  17 | st.pc == size st.prog = Left st
  18 = let (b, tape`) = uselect tape tc in Right (case select prog pc of
  19         '<' = {st & pc=pc+1, tape=tape`, tc=tc-1}
  20         '>' = {st & pc=pc+1, tape=tape`, tc=tc+1}
  21         '+' = {st & pc=pc+1, tape=update tape` tc (b+1)}
  22         '-' = {st & pc=pc+1, tape=update tape` tc (b-1)}
  23         '.' = {st & pc=pc+1, tape=tape`, io=st.io <<< toChar b}
  24         ',' = let (_, c, io) = freadc st.io
  25                 in {st & pc=pc+1, tape=update tape` tc (toInt c), io=io}
  26         '[' = let st` = {st & cs=[pc:cs], tape=tape`, pc=pc+1} in if (b == 0)
  27                         {st` & pc=1+(while (\pc`->select prog pc` <> ']') ((+) 1) pc)} st`
  28         ']' = {st & tape=tape`, pc=hd cs, cs=tl cs}
  29         _ = {st & pc=pc+1})
  30
  31 f :: (.a -> (Either .a .a)) -> .(.a -> .a)
  32 f g = (either id (f g)) o g
  33
  34 mkState :: !*File String -> *BFState
  35 mkState f s = {pc=0,tc=0,io=f,cs=[],tape={0\\_<-[0..1024]},prog=s}
  36
  37 Start w
  38 # ([_:p], w) = getCommandLine w
  39 # (io, w) = stdio w
  40 | isEmpty p = snd (fclose (io <<< "Pleasy supply a filename\n") w)
  41 # (io, w) = case readFile (hd p) w of
  42         (Error e, w) = (io <<< "File error: " <<< toString e <<< "\n", w)
  43         (Ok s, w) = let st` = f bf (mkState io s) in (st`.io, w)
  44 # (_, w) = fclose io w
  45 = w