(* A sketch of a R7RS Scheme Interpreter in Standard ML
 * $Id: scheme.sml,v 1.33 2024/10/30 08:25:17 oj14ozun Exp $
 * https://wwwcip.cs.fau.de/~oj14ozun/src+etc/scheme.sml *)

datatype exp
  = Bool of bool                    (* boolean *)
  | Char of char                    (* character *)
  | Fixn of int                     (* fixnum *)
  | Null                            (* nil *)
  | Pair of (exp ref) * (exp ref)   (* cons cell *)
  | Proc of (exp list * ctx) -> exp (* procedure *)
  | Spec of (exp list * ctx) -> exp (* special form *)
  | Symb of int                     (* symbol *)
  | Strg of string                  (* string *)
  | Undef                           (* undefined *)
and ctx = Ctx of (((int * exp ref) list ref) * (ctx option))

exception Syntax of string
exception Runtime of string
exception EOF

fun pair (a, b) = Pair (ref a, ref b)

local                           (* poor man's hash table *)
    open Array
    val symtable = array (Char.maxOrd, ([] : (int * string) list))
    val counter = ref 0
    fun next () = ! counter before counter := ! counter + 1
    fun hash str =
        let val list = map (Word.fromInt o Char.ord) (String.explode str)
        in Word.toInt (List.foldl Word.xorb (Word.fromInt 0) list)
        end
    fun insert (hval : int) (str : string) =
        let val old = sub (symtable, hval)
            val cnt = next ()
            val new = (cnt, str) :: old
        in update (symtable, hval, new);
           cnt
        end
in fun intern' str =
       let val hval = hash str
           val list = sub (symtable, hval)
       in (case List.find (fn (_, str') => str = str') list of
               SOME (n : int, _) => n
             | NONE => insert hval str)
       end
   fun intern str = Symb (intern' str)
   fun deintern (n : int) : string option =
       case List.find (fn (n', _) => n = n') (foldr List.@ [] symtable)
        of SOME (_, name) => SOME name |  NONE => NONE
end

local
    open TextIO
    fun read_sexp i =
        case (skip i Char.isSpace; lookahead i) of
            SOME #"(" => read_pair i
          | SOME #"#" =>
            (case (discard i; input1 i) of
                 SOME #"t" => Bool true
               | SOME #"f" => Bool false
               | SOME #"\\" =>
                 (case input1 i of
                      SOME c => Char c
                   |  NONE => raise EOF)
               | SOME c => unexpected c
               | NONE => raise EOF)
          | SOME #"'" => quote i "quote"
          | SOME c =>
            let fun nonempty s = 0 < (String.size s)
                open Char
                fun isSym c = isGraph c andalso
                              c <> #"(" andalso
                              c <> #")" andalso
                              c <> #"'" andalso
                              c <> #"#"
                val neg = if c = #"-"
                          then (discard i; true)
                          else false
                val word = collect i isSym
            in if List.all isDigit (String.explode word) andalso
                  nonempty word
               then (case Int.fromString word of
                         SOME n => Fixn (if neg then ~ n else n)
                       | NONE => (print ("["^word^"]"); raise Domain))
               else (intern ((if neg then "-" else "") ^ word))
            end
          | NONE => raise EOF
    and read_pair i =
        let val pair = (ensure i #"("; read_pair' i)
        in ensure' i #")"; pair
        end
    and read_pair' i =
        case (skip i Char.isSpace; lookahead i) of
            SOME #")" => Null
          | _ => let val left = read_sexp i
                 in case (skip i Char.isSpace; lookahead i) of
                        SOME #"." =>
                        (discard i;
                         pair (left, (read_sexp i)))
                      | SOME _ =>
                        (skip i Char.isSpace;
                         pair (left, (read_pair' i)))
                      | NONE => raise EOF
                 end
    and skip i f =
        while (case lookahead i of SOME c => f c | NONE => raise EOF)
              do discard i
    and collect i f =
        let val word = ref ([] : char list)
        in (while (case lookahead i of SOME c => f c | NONE => raise EOF)
                  do case input1 i of
                         SOME c => word := c :: (! word)
                       | NONE => raise EOF;
            String.implode (rev (! word)))
        end
    and discard i = (input1 i; ())
    and ensure' i c = (skip i Char.isSpace; ensure i c)
    and ensure i c =
        case input1 i of
            SOME c' => if c = c' then () else expected c c'
          | _ => raise EOF
    and unexpected c =
        raise Syntax ("Unexpected char " ^ (Char.toString c))
    and expected c c' =
        raise Syntax ("Expected char " ^ (Char.toString c) ^
                      ", got " ^ (Char.toString c'))
    and quote i name =
        pair ((intern name), (pair ((discard i; read_sexp i), Null)))
in fun read i = read_sexp i end

local
    fun disp (Bool b) = if b then "#t" else "#f"
      | disp (Char c) = implode [#"#", #"\\", c]
      | disp (Fixn n) = if n >= 0 then Int.toString n else
                        "-" ^ (Int.toString (~n))
      | disp Null = "()"
      | disp (p as Pair _) = "(" ^ (dislist p) ^ ")"
      | disp (Proc _) = "[procedure]"
      | disp (Spec _) = "[special-form]"
      | disp (Symb n) =
        (case deintern n of
             SOME s => s
           | NONE => "[symbol " ^ (Int.toString n) ^ "]")
      | disp (Strg s) = "\"" ^ s ^ "\""
      | disp Undef = "[undefined]"
    and dislist (Pair (ref a, ref (b as Pair _))) =
        (disp a) ^ " " ^ (dislist b)
      | dislist (Pair (ref a, ref Null)) = disp a
      | dislist (Pair (ref a, ref b)) = (disp a) ^ " . " ^ (disp b)
      | dislist _ = raise Domain
in fun display e = disp e end

fun listify' Null = ([], NONE)
  | listify' (Pair (ref car, ref (cdr as Pair _))) =
    let val (cdr', trail) = listify' cdr in (car :: cdr', trail) end
  | listify' (Pair (ref car, ref Null)) = ([car], NONE)
  | listify' (Pair (ref car, ref cdr)) = ([car], SOME cdr)
  | listify' exp = ([], SOME exp)

fun listify exp = case listify' exp of
                      (l, NONE) => l | (l, SOME e) => raise Runtime ("Not a proper list: " ^ (display e))

fun eval (exp as Symb n, Ctx (env, parent)) : exp =
    (case (List.find (fn (n', _) => n = n') (! env), parent) of
         (SOME (_, v), _) => ! v
       | (NONE, SOME p) => eval (exp, p)
       | _ => raise Runtime ("Unbound symbol \"" ^
                             (case deintern n of SOME s => s | NONE => "???")
                             ^"\""))
  | eval (Pair (ref car, ref cdr), ctx) =
    (apply (eval (car, ctx), (listify cdr), ctx)
     handle Match => raise Runtime "Argument Mismatch")
  | eval (exp, _) = exp (* everything else is self-evaluating *)
and apply (Proc f, args, ctx) = f (map (fn e => eval (e, ctx)) args, ctx)
  | apply (Spec f, args, ctx) = f (args, ctx)
  | apply (exp, args, _) =
    let val args' = String.concatWith ", " (map display args)
        val exp' = display exp
    in raise Runtime ("Cannot be apply (" ^ args' ^ ") to " ^ exp')
    end

local
    fun l'identity ([a], _) = a | l'identity _ = raise Match

    fun l'add (args, _) =
        Fixn (List.foldl (fn (Fixn a, b) => a + b
                         | _ => raise Runtime "Not a number")
                         0 args)
    fun l'mul (args, _) =
        Fixn (List.foldl (fn (Fixn a, b) => a * b
                         | _ => raise Runtime "Not a number")
                         1 args)

    fun l'sub ([Fixn n], _) = Fixn (~n)
      | l'sub ((Fixn n)::rest, _) =
        Fixn (List.foldl (fn (Fixn a, b) => b - a
                         | _ => raise Runtime "Not a number")
                         n rest)
      | l'sub _ = raise Runtime "Not a number"

    fun l'num_equal ((Fixn n)::args, _) =
        Bool (List.foldl (fn (Fixn n', b) => b andalso n = n'
                         | _ => raise Runtime "Not a number")
                         true args)
      | l'num_equal _ = raise Runtime "Not a number"

    fun l'num_nequal ([Fixn n, Fixn m], _) = Bool (n <> m)
      | l'num_nequal ([_, _], _) = raise Runtime "Not a number"
      | l'num_nequal _ = raise Match

    fun make_op _ ([], _) = Bool true
      | make_op _ ([Fixn _], _) = Bool true
      | make_op f ((Fixn n :: (rest as (Fixn m :: _))), ctx) =
        if f (n, m) then make_op f (rest, ctx) else Bool false
      | make_op _ _ = raise Match

    fun l'display ([exp], _) = (print ((display exp) ^ "\n"); Undef)
      | l'display _ = raise Match

    fun l'if ([cond, l'then, l'else], ctx) =
        (case eval (cond, ctx) of
             Bool true  => eval (l'then, ctx)
           | Bool false => eval (l'else, ctx)
           | _ => raise Runtime "Condition is not a boolean")
      | l'if _ = raise Match

    fun progn (elist, ctx) =
        List.foldl (fn (exp, _) => eval (exp, ctx)) Undef elist
    fun mkctx (args, params, super) =
        Ctx (ref (ListPair.zip (args, map ref params)), SOME super)

    val else_sym = intern' "else"
    fun l'cond (cases, ctx) =
        let fun test (_, SOME v : exp option) = SOME v
              | test (Pair (ref cond, ref body), NONE) =
                if ((case cond of Symb n => n = else_sym | _ => false) orelse
                    (case eval (cond, ctx) of Bool b => b | _ => false))
                then SOME (progn (listify body, ctx))
                else NONE
              | test _ = raise Runtime "Malformed cond branch"
        in case List.foldl test NONE cases
            of SOME v => v | NONE => Undef
        end

    fun mkfn (arglist, ctx, body) =
        let open List
            val (arglist, trail) = listify' arglist
            val args = map (fn Symb n => n
                           | _ => raise Runtime "Non-symbol parameter")
                           arglist
            val ll = foldr pair Null
        in Proc (fn (params, _) =>
                    let val ctx' as (Ctx (args', _)) = mkctx (args, params, ctx)
                    in case trail of
                           SOME (Symb n) =>
                           args' := (n, ref (ll (drop (params, length arglist)))) :: (! args')
                         | SOME _ => raise Runtime "Non-symbol parameter"
                         | NONE => ();
                       progn (body, ctx')
                    end)
        end

    fun l'begin (body, ctx) = progn (body, ctx)

    fun l'lambda ((arglist :: body : exp list), ctx) =
        mkfn (arglist, ctx, body)
      | l'lambda _ = raise Match

    fun l'let (arglist :: body, ctx) =
        let val arglist = listify arglist
            fun extr (Pair (ref (Symb n), ref (Pair (ref exp, ref Null)))) =
                (n, eval (exp, ctx))
              | extr _ = raise Runtime "Malformed bindings"
            val args = map extr arglist
        in progn (body, (mkctx (map (fn (n, _) => n) args,
                                map (fn (_, e) => e) args,
                                ctx))) end
      | l'let _ = raise Match

    fun l'letstar (arglist :: body, ctx) =
        let val ctx' = Ctx (ref [], SOME ctx)
            val arglist = listify arglist
            fun extr (Pair (ref (Symb n), ref (Pair (ref exp, ref Null)))) =
                let val exp' = eval (exp, ctx')
                    val Ctx (env, _) = ctx'
                in env := (n, ref exp') :: (! env); (n, exp') end
              | extr _ = raise Runtime "Malformed bindings"
            val args = map extr arglist
        in progn (body, (mkctx (map (fn (n, _) => n) args,
                                map (fn (_, e) => e) args,
                                ctx))) end
      | l'letstar _ = raise Match

    (* (define (foo bar) body) -> (define foo (lambda (bar) body)) *)
    fun l'define ((Pair (ref (Symb n), ref arglist)) :: body, ctx as (Ctx (binds, _))) =
        (binds := (n, ref (mkfn (arglist, ctx, body))) :: (! binds);
         Undef)
      | l'define ([Symb n, value], ctx as Ctx (binds, _)) =
        (binds := (n, ref (eval (value, ctx))) :: (! binds); Undef)
      | l'define _ = raise Match

    fun l'set ([Symb n, exp], ctx) =
        let fun locate (Ctx (binds, parent)) =
                (case List.find (fn (n', _) => n = n') (! binds) of
                     NONE => (case parent of
                                  SOME p => locate p
                                | NONE => NONE)
                   | SOME (_, v) => SOME v)
        in case locate ctx of
               SOME place => (place := eval (exp, ctx); Undef)
             | NONE => raise Runtime "Variable not bound!"
        end
      | l'set _ = raise Match

    fun l'and (args, ctx) =
        let fun conj (exp, acc) =
                case acc of Bool false => acc | _ => eval (exp, ctx)
        in (List.foldl conj (Bool true) args) end
    fun l'or (args, ctx) =
        let fun conj (exp, acc) =
                case acc of Bool false => eval (exp, ctx) | _ => acc
        in (List.foldl conj (Bool false) args) end

    fun l'eq ([a, b] : exp list, _) =
        Bool (case (a, b) of
                  (Bool a, Bool b) => a = b
                | (Char a, Char b) => a = b
                | (Symb a, Symb b) => a = b
                | (Fixn a, Fixn b) => a = b
                | (Null, Null) => true
                | _ => false)
      | l'eq _ = raise Match
    fun l'equal ([a, b] : exp list, ctx) =
        let fun eq (Bool a, Bool b) = a = b
              | eq (Char a, Char b) = a = b
              | eq (Symb a, Symb b) = a = b
              | eq (Fixn a, Fixn b) = a = b
              | eq (Pair (ref al, ref ar), Pair (ref bl, ref br)) =
                eq (al, bl) andalso eq (ar, br)
              | eq (Strg a, Strg b) = a = b
              | eq (Null, Null) = true
              | eq _ = false
        in (Bool o eq) (a, b) end
      | l'equal _ = raise Match

    fun l'apply ([f], ctx) = apply (f, [], ctx)
      | l'apply (f::(args as _::_), ctx) =
        apply (f, (case List.last args
                    of t as Pair _ =>
                       (List.take (args, (List.length args)-1)) @ (listify t)
                    | _ => args), ctx)
      | l'apply _ = raise Match

    fun l'setcar ([Pair (cell, _), e], ctx) = (cell := e; Undef)
      | l'setcar _ = raise Match

    fun l'setcdr ([Pair (_, cell), e], ctx) = (cell := e; Undef)
      | l'setcdr _ = raise Match

    (* abbreviations: *)
    fun proc (name, f) = (intern' name, ref (Proc f))
    fun spec (name, f) = (intern' name, ref (Spec f))
in val builtin =
       Ctx (ref [proc ("identity", l'identity),
                 proc ("+", l'add),
                 proc ("*", l'mul),
                 proc ("-", l'sub),
                 proc ("=", l'num_equal),
                 proc ("/=", l'num_nequal),
                 proc ("<", make_op Int.<),
                 proc (">", make_op Int.>),
                 proc ("<=", make_op Int.<=),
                 proc (">=", make_op Int.>=),
                 proc ("car", (fn ([Pair (ref a, _)], _) => a | _ => raise Match)),
                 proc ("cdr", (fn ([Pair (_, ref b)], _) => b | _ => raise Match)),
                 proc ("cons", (fn ([a, b], _) => pair (a, b) | _ => raise Match)),
                 proc ("display", l'display),
                 proc ("null?", (fn ([Null], _) => Bool true
                                | ([_], _) => Bool false
                                | _ => raise Match)),
                 proc ("pair?", (fn ([Pair _], _) => Bool true
                                | ([_], _) => Bool false
                                | _ => raise Match)),
                 proc ("boolean?", (fn ([Bool _], _) => Bool true
                                   | ([_], _) => Bool false
                                   | _ => raise Match)),
                 proc ("procedure?", (fn ([Proc _], _) => Bool true
                                     | ([_], _) => Bool false
                                     | _ => raise Match)),
                 proc ("symbol?", (fn ([Symb _], _) => Bool true
                                  | ([_], _) => Bool false
                                  | _ => raise Match)),
                 proc ("string?", (fn ([Strg _], _) => Bool true
                                  | ([_], _) => Bool false
                                  | _ => raise Match)),
                 proc ("number?", (fn ([Fixn _], _) => Bool true
                                  | ([_], _) => Bool false
                                  | _ => raise Match)),
                 proc ("eq?", l'eq),
                 proc ("eqv?", l'eq),
                 proc ("equal?", l'equal),
                 proc ("apply", l'apply),
                 proc ("set-car!", l'setcar),
                 proc ("set-cdr!", l'setcdr),
                 spec ("quote", l'identity),
                 spec ("if", l'if),
                 spec ("cond", l'cond),
                 spec ("begin", l'begin),
                 spec ("lambda", l'lambda),
                 spec ("let", l'let),
                 spec ("let*", l'letstar),
                 spec ("define", l'define),
                 spec ("set!", l'set),
                 spec ("and", l'and),
                 spec ("or", l'or)
                ], NONE)
end

val stdlib = [
    "(define (1- n) (- n 1))",
    "(define (1+ n) (+ n 1))",
    "(define (caar x) (car (car x)))",
    "(define (cadr x) (car (cdr x)))",
    "(define (cdar x) (cdr (car x)))",
    "(define (cddr x) (cdr (cdr x)))",
    "(define (caaar x) (car (car (car x))))",
    "(define (caadr x) (car (car (cdr x))))",
    "(define (cadar x) (car (cdr (car x))))",
    "(define (caddr x) (car (cdr (cdr x))))",
    "(define (cdaar x) (cdr (car (car x))))",
    "(define (cdadr x) (cdr (car (cdr x))))",
    "(define (cddar x) (cdr (cdr (car x))))",
    "(define (cdddr x) (cdr (cdr (cdr x))))",
    "(define (list . args) args)",
    (* https://srfi.schemers.org/srfi-1/srfi-1.html#fold *)
    "(define (fold kons knil lst) (if (null? lst) knil (fold kons (kons (car lst) knil) (cdr lst))))",
    "(define (fold-right kons knil lst) (if (null? lst) knil (kons (car lst) (fold-right kons knil (cdr lst)))))",
    "(define (length l) (fold (lambda (_ i) (1+ i)) 0 l))",
    "(define (snoc e l) (fold-right cons (list e) l))",
    "(define (reverse l) (fold cons '() l))",
    "(define (append . l) (fold-right (lambda (l e) (fold-right cons e l)) '() l))",
    "(define (count p? l) (fold (lambda (e i) (if (p? e) (1+ i) i)) 0 l))",
    (* https://rosettacode.org/wiki/Ackermann_function#Scheme *)
    "(define (ack m n) (cond ((= m 0) (+ n 1)) ((= n 0) (ack (- m 1) 1)) (else (ack (- m 1) (ack m (- n 1))))))"
]

fun repl () =
    let open TextIO open CommandLine
        val ctx = Ctx (ref [], SOME builtin)
        fun slurp i =
            ((while true do eval (read i, ctx)) handle EOF => ();
             closeIn i)
        fun rep () =
            (print "> ";
             let val e = display (eval (read TextIO.stdIn, ctx))
             in output (stdOut, e ^ "\n") end)
        fun loop () =
            (rep () handle
             Runtime msg => print ("Runtime error: " ^ msg ^ "\n")
             | Syntax msg => print ("Syntax error: " ^ msg ^ "\n");
             if endOfStream stdIn then () else loop ())
    in (slurp (TextIO.openString (String.concat stdlib));
        List.app (slurp o openIn) (arguments ());
        loop () handle EOF => ())
    end

val () = repl ()

(* Local Variables: *)
(* indent-tabs-mode: nil *)
(* End: *)