cleanbf.icl

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