forth.sml

structure Parser =
struct
  exception ParsingError of string

  datatype cmd = Push of int
               | Add
               | Sub
               | Mul
               | Div
               | Dup
               | Drop
               | Over
               | Swap
               | Custom of string * cmd list
  
  fun tokenize s =
    String.tokens Char.isSpace (String.map Char.toLower s)
  
  fun parse []             = []
    | parse ("+"    :: xs) = Add  :: parse xs
    | parse ("-"    :: xs) = Sub  :: parse xs
    | parse ("*"    :: xs) = Mul  :: parse xs
    | parse ("/"    :: xs) = Div  :: parse xs
    | parse ("drop" :: xs) = Drop :: parse xs
    | parse ("dup"  :: xs) = Dup  :: parse xs
    | parse ("swap" :: xs) = Swap :: parse xs
    | parse ("over" :: xs) = Over :: parse xs
    | parse (":"    :: xs) =
        let
          fun split []        = ([], false, [])
            | split (x :: xs) =
                if x = ";"
                then ([], true, xs)
                else
                  let
                    val (xs', found, xs'') = split xs
                  in
                    (x :: xs', found, xs'')
                  end
        in
          case split xs of
            (x :: xs', true, xs'') =>
              (* let *)
              (*   fun isnumber s = List.all () (explode s) *)
              (* in *)
              (* end *)
              (
                case Int.fromString x of
                  NONE => Custom (x, parse xs') :: parse xs''
                | _    => raise ParsingError "numbers can not be used as command names"
              )
          | _                      => raise ParsingError ""
        end
    | parse (x      :: xs) =
        case Int.fromString x of
          SOME n => Push n :: parse xs
        | NONE   => Custom (x, []) :: parse xs (*raise ParsingError ("unexpected token: " ^ x)*)
end


structure Forth =
struct
  open Parser

  exception StackUnderflow

  type stack = int list

  fun dup (x :: xs) = x :: x :: xs
    | dup _         = raise StackUnderflow

  fun drop (_ :: xs) = xs
    | drop _         = raise StackUnderflow

  fun swap (x :: x' :: xs) = x' :: x :: xs
    | swap _               = raise StackUnderflow

  fun over (x :: x' :: xs) = x' :: x :: x' :: xs
    | over _               = raise StackUnderflow

  fun binop f (x :: x' :: xs) = f (x, x') :: xs
    | binop _ _               = raise StackUnderflow

  fun primitives Add  = binop (op +)
    | primitives Sub  = binop (op -)
    | primitives Mul  = binop (op *)
    | primitives Div  = binop (op div)
    | primitives Dup  = dup
    | primitives Drop = drop
    | primitives Swap = swap
    | primitives Over = over
    | primitives (Push n) = (fn stack => n :: stack)
    | primitives (Custom (_, cmds)) =
        foldl (fn (cmd, chain) => (primitives cmd) o chain) (fn x => x) cmds

  type word = string * cmd

  val words: word list = [
    ("add" , Add ),
    ("sub" , Sub ),
    ("mul" , Mul ),
    ("div" , Div ),
    ("dup" , Dup ),
    ("drop", Drop),
    ("swap", Swap),
    ("over", Over)
  ]

  fun lookupWord key = List.find (fn (k, _) => k = key)

  fun addWord (key: string, cmd: Parser.cmd) pairs =
    let
      fun splitat key [] = ([], [])
        | splitat key ((k, cmd) :: xs) =
            if key = k
            then ([], xs)
            else
              let
                val (xs', xs'') = splitat key xs
              in
                ((k, cmd) :: xs', xs'')
              end

      val (front, rest) = splitat key pairs
    in
      front @ (key, cmd) :: rest
    end

  type state = { stack: stack, words: word list }

  val initialState: state =
    {
      stack = [],
      words = words
    }

  fun eval' ({ stack, ... }: state) [] = stack
    | eval' { stack, words } (cmd :: cmds) =
        case cmd of
          Custom (k, []) =>
            (
              case lookupWord k words of
                SOME (_, cmd') => eval' { stack = (primitives cmd') stack, words = words } cmds
              | NONE           => raise Fail "unknown word"
            )
        | Custom (k, _) => eval' { stack = stack, words = (addWord (k, cmd) words) } cmds
        | _ => eval' { stack = (primitives cmd) stack, words = words } cmds

  fun eval s = eval' initialState (parse (tokenize s))
end