A Brainfuck interpreter, written in the Kitten programming language (http://kittenlang.org/)

brainfuck.ktn

type Instruction Char
type Program [Instruction]
type Memory [Int]

////////////////////////////////////////////////////////////
// Configuration

def debug: false

// Some programs want 0; some want -1.
def eofCell(-> Int): -1

////////////////////////////////////////////////////////////
// Utilities

// This should be the default, methinks.
def safeHead([a] -> a?):
  ->xs
  if (xs isEmpty):
    none
  else:
    xs head some

// TODO(strager): Make a macro.
def when(Bool (-> +IO) -> +IO):
  ->{cond f}
  if cond: f@
  else: noop

def find([a] (a -> Bool +e) -> a? +e):
  filter safeHead

def lookUp([a & b] a (a a -> Bool +e) -> b? +e):
  ->{key eq}
  {first key eq@} find
  {rest} liftOption

// TODO(strager): Find a better name.  'option' is taken.
def maybe(a? (a -> b +e) b -> b +e):
  ->{mx f z}
  option mx: f@
  else: z

// FIXME(strager): Can't do this!
//def apply: @

// FIXME(strager): I can't write a 'switch' function for the
// same reason I can't write an 'apply' alias.

// FIXME(strager): I don't want to write type annotations.
// TODO(strager): Wouldn't it be awesome if we had lenses?
def get([a] Int -> a): #
def set([a] a Int -> [a]): #!
def update([a] (a -> a) Int -> [a]): #@

// FIXME(strager): Bad approximation.
def getCharApprox(-> Char? +IO):
  getLine ->line
  line safeHead

// This should be the default, methinks.
def safeGet([a] Int -> a?):
  ->{xs index}
  if ((index xs length <) (index 0 >=) &&):
    xs index get some
  else:
    none

// TODO(strager): Make this an intrinsic.
def intToChar (Int -> Char?):
  ->c
  [ 7 '\t' pair
  , 10 '\n' pair
  , 32 ' ' pair
  , 33 '!' pair
  , 34 '"' pair
  , 35 '#' pair
  , 36 '$' pair
  , 37 '%' pair
  , 38 '&' pair
  , 39 '\'' pair
  , 40 '(' pair
  , 41 ')' pair
  , 42 '*' pair
  , 43 '+' pair
  , 44 ',' pair
  , 45 '-' pair
  , 46 '.' pair
  , 47 '/' pair
  , 48 '0' pair
  , 49 '1' pair
  , 50 '2' pair
  , 51 '3' pair
  , 52 '4' pair
  , 53 '5' pair
  , 54 '6' pair
  , 55 '7' pair
  , 56 '8' pair
  , 57 '9' pair
  , 58 ':' pair
  , 59 ';' pair
  , 60 '<' pair
  , 61 '=' pair
  , 62 '>' pair
  , 63 '?' pair
  , 64 '@' pair
  , 65 'A' pair
  , 66 'B' pair
  , 67 'C' pair
  , 68 'D' pair
  , 69 'E' pair
  , 70 'F' pair
  , 71 'G' pair
  , 72 'H' pair
  , 73 'I' pair
  , 74 'J' pair
  , 75 'K' pair
  , 76 'L' pair
  , 77 'M' pair
  , 78 'N' pair
  , 79 'O' pair
  , 80 'P' pair
  , 81 'Q' pair
  , 82 'R' pair
  , 83 'S' pair
  , 84 'T' pair
  , 85 'U' pair
  , 86 'V' pair
  , 87 'W' pair
  , 88 'X' pair
  , 89 'Y' pair
  , 90 'Z' pair
  , 91 '[' pair
  , 92 '\\' pair
  , 93 ']' pair
  , 94 '^' pair
  , 95 '_' pair
  , 96 '`' pair
  , 97 'a' pair
  , 98 'b' pair
  , 99 'c' pair
  , 100 'd' pair
  , 101 'e' pair
  , 102 'f' pair
  , 103 'g' pair
  , 104 'h' pair
  , 105 'i' pair
  , 106 'j' pair
  , 107 'k' pair
  , 108 'l' pair
  , 109 'm' pair
  , 110 'n' pair
  , 111 'o' pair
  , 112 'p' pair
  , 113 'q' pair
  , 114 'r' pair
  , 115 's' pair
  , 116 't' pair
  , 117 'u' pair
  , 118 'v' pair
  , 119 'w' pair
  , 120 'x' pair
  , 121 'y' pair
  , 122 'z' pair
  , 123 '{' pair
  , 124 '|' pair
  , 125 '}' pair
  , 126 '~' pair
  ] c {=} lookUp

def error([Char] -> +IO):
  ->message
  ["Error: ", message, "\n"] concat stderr handlePrint
  1 exit

// TODO(strager): Make this a compiler intrinsic.
def unfoldN(a (a -> b a +e) Int -> [b] +e):
  ->{z f size}
  if (size 0 >):
    z f@ ->{b a}
    (a f size-- unfoldN)
    b prepend
  else:
    []

def generateN((Int -> a +e) Int -> [a] +e):
  ->{f size}
  0 {->index
    index f@
    index++
  } size unfoldN

// TODO(strager): Make this more efficient.
def loopN((Int -> +e) Int -> +e):
  ->{f size}
  {f@ ()} size generateN drop

////////////////////////////////////////////////////////////
// Type routines

def eqInstruction(Instruction Instruction -> Bool):
  from Instruction swap
  from Instruction eqChar

def createMemory(Int -> Memory):
  0 swap replicate to Memory

def updateMemory(Memory (Int -> Int) Int -> Memory):
  ->{memory f index}
  (memory from Memory) f index update to Memory

def getMemory(Memory Int -> Int):
  ->{memory index}
  memory from Memory index get

def setMemory(Memory Int Int -> Memory):
  ->{memory value index}
  memory {drop value} index updateMemory

////////////////////////////////////////////////////////////
// Interpreter

def parseProgram([Char] -> Program):
  {to Instruction} map
  to Program

def runProgram(Program -> +IO):
  ->program
  1024 createMemory ->ram

  program 0 ram 0
  loopProgram

def loopProgram(Program Int Memory Int -> +IO):
  stepProgram
  ->running
  if running:
    loopProgram
  else:
    drop drop drop drop

def stepProgram(Program Int Memory Int -> Program Int Memory Int Bool +IO):
  ->{program pc ram ramc}

  debug {
    ram ramc dumpMemory
    program pc dumpProgram
  } when

  program from Program ->instructions

  [ '<' to Instruction {
      program pc++ ram ramc--
      noop // FIXME(strager): Dumb compiler.
    } pair

  , '>' to Instruction {
      program pc++ ram ramc++
      noop // FIXME(strager): Dumb compiler.
    } pair

  , '+' to Instruction {
      program pc++
      (ram {++} ramc updateMemory) ramc
      noop // FIXME(strager): Dumb compiler.
    } pair

  , '-' to Instruction {
      program pc++
      (ram {--} ramc updateMemory) ramc
      noop // FIXME(strager): Dumb compiler.
    } pair

  , '[' to Instruction {
      if (ram ramc getMemory 0 =):
        option (program pc findMatchingRBracket):
          ->rbracket
          program rbracket++ ram ramc
        else:
          ["No matching ] at position ", pc showInt] concat error
          // FIXME(strager): Compiler can't infer non-termination.
          program pc ram ramc
      else:
        program pc++ ram ramc
      noop // FIXME(strager): Dumb compiler.
    } pair

  , ']' to Instruction {
      option (program pc findMatchingLBracket):
        ->lbracket
        program lbracket ram ramc
      else:
        ["No matching [ at position ", pc showInt] concat error
        // FIXME(strager): Compiler can't infer non-termination.
        program pc ram ramc
      noop // FIXME(strager): Dumb compiler.
    } pair

  , '.' to Instruction {
      ram ramc getMemory ->cell
      option (cell intToChar):
        vector print
      else:
        ["Tried to print ", cell showInt, ", which is out of range"] concat error
      program pc++ ram ramc
    } pair

  , ',' to Instruction {
      program pc++
      getCharApprox {charToInt} eofCell maybe ->cell
      (ram cell ramc setMemory) ramc
    } pair
  ] ->instructionTable

  option (instructions pc safeGet):
    ->instruction
    option (instructionTable instruction {eqInstruction} lookUp):
      @ /*apply*/
    else:
      program pc++ ram ramc
    true // Keep running.
    // FIXME(strager): This 'id' needed due to compiler bug.
    id
  else:
    program pc ram ramc
    false // Halt.

def findLBracket(Program Int Int -> Int?):
  ->{program pc depth}
  option (program from Program pc safeGet):
    [ '[' to Instruction {
        if (depth 0 =):
          pc some
        else:
          program pc-- depth-- findLBracket
      } pair
    , ']' to Instruction {
        program pc-- depth++ findLBracket
      } pair
    ] swap {eqInstruction} lookUp option id:
      @ /*apply*/
    else:
      program pc-- depth findLBracket
  else:
    none

def findMatchingLBracket(Program Int -> Int?):
  --
  0 findLBracket

// TODO(strager): Remove duplication with findLBracket.
def findRBracket(Program Int Int -> Int?):
  ->{program pc depth}
  option (program from Program pc safeGet):
    [ '[' to Instruction {
        program pc++ depth++ findRBracket
      } pair
    , ']' to Instruction {
        if (depth 0 =):
          pc some
        else:
          program pc++ depth-- findRBracket
      } pair
    ] swap {eqInstruction} lookUp option id:
      @ /*apply*/
    else:
      program pc++ depth findRBracket
  else:
    none

def findMatchingRBracket(Program Int -> Int?):
  ++
  0 findRBracket

////////////////////////////////////////////////////////////
// Programs

def progHelloWorld:
  "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>."

def progRot13:
  [ "-,+[                         Read first character and start outer character reading loop"
  , "    -[                       Skip forward if character is 0"
  , "        >>++++[>++++++++<-]  Set up divisor (32) for division loop"
  , "                               (MEMORY LAYOUT: dividend copy remainder divisor quotient zero zero)"
  , "        <+<-[                Set up dividend (x minus 1) and enter division loop"
  , "            >+>+>-[>>>]      Increase copy and remainder / reduce divisor / Normal case: skip forward"
  , "            <[[>+<-]>>+>]    Special case: move remainder back to divisor and increase quotient"
  , "            <<<<<-           Decrement dividend"
  , "        ]                    End division loop"
  , "    ]>>>[-]+                 End skip loop; zero former divisor and reuse space for a flag"
  , "    >--[-[<->+++[-]]]<[         Zero that flag unless quotient was 2 or 3; zero quotient; check flag"
  , "        ++++++++++++<[       If flag then set up divisor (13) for second division loop"
  , "                               (MEMORY LAYOUT: zero copy dividend divisor remainder quotient zero zero)"
  , "            >-[>+>>]         Reduce divisor; Normal case: increase remainder"
  , "            >[+[<+>-]>+>>]   Special case: increase remainder / move it back to divisor / increase quotient"
  , "            <<<<<-           Decrease dividend"
  , "        ]                    End division loop"
  , "        >>[<+>-]             Add remainder back to divisor to get a useful 13"
  , "        >[                   Skip forward if quotient was 0"
  , "            -[               Decrement quotient and skip forward if quotient was 1"
  , "                -<<[-]>>     Zero quotient and divisor if quotient was 2"
  , "            ]<<[<<->>-]>>    Zero divisor and subtract 13 from copy if quotient was 1"
  , "        ]<<[<<+>>-]          Zero divisor and add 13 to copy if quotient was 0"
  , "    ]                        End outer skip loop (jump to here if ((character minus 1)/32) was not 2 or 3)"
  , "    <[-]                     Clear remainder from first division if second division was skipped"
  , "    <.[-]                    Output ROT13ed character from copy and clear it"
  , "    <-,+                     Read next character"
  , "]                            End character reading loop"
  ] concat

def progCat:
  ",+[-.,+]"

def progSort:
  ">,+[>,+]<[[[->>+>>-[<]<<<]>[<]<[->>>>+<<<<]>>[>+>+<<-]<<<]>>>>-.[-]>[>]<]"

////////////////////////////////////////////////////////////
// Debugging

def dumpMemory(Memory Int -> +IO):
  ->{ram ramc}

  "Memory:" say
  {->index
    ram index getMemory ->cell
    ["[", index showInt, "] ", cell showInt] concat print
    (index ramc =) {" <" print} when
    newline
  } 32 loopN

def dumpProgram(Program Int -> +IO):
  ->{_ pc}
  ["Program counter: ", pc showInt] concat say

////////////////////////////////////////////////////////////
// Main

progCat
parseProgram runProgram