lisp.neko

var buffer_add = $loader.loadprim("std@buffer_add", 2);
var buffer_add_char = $loader.loadprim("std@buffer_add_char", 2);
var buffer_new = $loader.loadprim("std@buffer_new", 0);
var buffer_string = $loader.loadprim("std@buffer_string", 1);
var file_read_char = $loader.loadprim("std@file_read_char", 1);
var file_stdin = $loader.loadprim("std@file_stdin", 0);

var arrstr = function(arr) {
  var buf = buffer_new()
  var i = 0;
  while (i < $asize(arr)) {
    buffer_add(buf, arr[i])
    i += 1
  }
  return buffer_string(buf)
}

var kLPar = 0x28
var kRPar = 0x29
var kQuote = 0x27
var kNil = { tag => "nil", data => "nil" }

var safeCar = function(obj) {
  if (obj.tag == "cons") {
    return obj.car
  }
  return kNil
}

var safeCdr = function(obj) {
  if (obj.tag == "cons") {
    return obj.cdr
  }
  return kNil
}

var makeError = function(str) {
  return { tag => "error", data => str }
}

var sym_table = $hnew(256)
var makeSym = function(str) {
  if (str == "nil") {
    return kNil
  } else if ($not($hmem(sym_table, str, strcmp))) {
    $hadd(sym_table, str, { tag => "sym", data => str })
  }
  return $hget(sym_table, str, strcmp)
}

var sym_t = makeSym("t")
var sym_quote = makeSym("quote")
var sym_if = makeSym("if")
var sym_lambda = makeSym("lambda")
var sym_defun = makeSym("defun")
var sym_setq = makeSym("setq")
var sym_loop = makeSym("loop")
var sym_return = makeSym("return")
var loop_val = $new(null)

var makeNum = function(num) {
  return { tag => "num", data => num }
}

var makeCons = function(a, d) {
  return { tag => "cons", car => a, cdr => d }
}

var makeSubr = function(fn) {
  return { tag => "subr", data => fn }
}

var makeExpr = function(args, env) {
  return { tag => "expr",
           args => safeCar(args),
           body => safeCdr(args),
           env => env }
}

var nreverse = function(lst) {
  var ret = kNil
  while (lst.tag == "cons") {
    var tmp = lst.cdr
    lst.cdr = ret
    ret = lst
    lst = tmp
  }
  return ret
}

var pairlis = function(lst1, lst2) {
  var ret = kNil
  while (lst1.tag == "cons" && lst2.tag == "cons") {
    ret = makeCons(makeCons(lst1.car, lst2.car), ret)
    lst1 = lst1.cdr
    lst2 = lst2.cdr
  }
  return nreverse(ret)
}

var isSpace = function(c) {
  return c == 0x09 || c == 0x0a || c == 0x0d || c == 0x20
}

var isDelimiter = function(c) {
  return c == kLPar || c == kRPar || c == kQuote || isSpace(c);
}

var skipSpaces = function(str) {
  var i = 0;
  while (i < $ssize(str)) {
    if ($not(isSpace($sget(str, i)))) {
      break;
    }
    i += 1
  }
  return $ssub(str, i, $ssize(str) - i)
}

var makeNumOrSym = function(str) {
  if ($string($int(str)) == str) {
    return makeNum($int(str))
  }
  return makeSym(str)
}

var readAtom = function(str) {
  var next = ""
  var i = 0
  while (i < $ssize(str)) {
    if (isDelimiter($sget(str, i))) {
      next = $ssub(str, i, $ssize(str) - i)
      str = $ssub(str, 0, i)
      break;
    }
    i += 1
  }
  return $array(makeNumOrSym(str), next)
}

var readList = $new(null)
var read = $new(null)
read.call = function(str) {
  str = skipSpaces(str)
  if ($ssize(str) == 0) {
    return $array(makeError("empty input"), "")
  } else if ($sget(str, 0) == kRPar) {
    return $array(makeError(arrstr($array("invalid syntax: ", str))), "")
  } else if ($sget(str, 0) == kLPar) {
    return readList.call($ssub(str, 1, $ssize(str) - 1))
  } else if ($sget(str, 0) == kQuote) {
    var tmp = read.call($ssub(str, 1, $ssize(str) - 1))
    return $array(makeCons(sym_quote, makeCons(tmp[0], kNil)), tmp[1])
  }
  return readAtom(str)
}

readList.call = function(str) {
  var ret = kNil
  while (true) {
    str = skipSpaces(str)
    if ($ssize(str) == 0) {
      return $array(makeError("unfinished parenthesis"), "")
    } else if ($sget(str, 0) == kRPar) {
      break;
    }
    var tmp = read.call(str)
    var elm = tmp[0]
    var next = tmp[1]
    if (elm.tag == "error") {
      return $array(elm, "")
    }
    ret = makeCons(elm, ret)
    str = next
  }
  return $array(nreverse(ret), $ssub(str, 1, $ssize(str) - 1))
}

var printList = $new(null)
var printObj = $new(null)
printObj.call = function(obj) {
  if (obj.tag == "num" || obj.tag == "sym" || obj.tag == "nil") {
    return $string(obj.data)
  } else if (obj.tag == "error") {
    return arrstr($array("<error: ", obj.data, ">"))
  } else if (obj.tag == "cons") {
    return printList.call(obj)
  } else if (obj.tag == "subr" || obj.tag == "expr") {
    return arrstr($array("<", obj.tag, ">"))
  }
}

printList.call = function(obj) {
  var buf = buffer_new()
  var first = true
  while (obj.tag == "cons") {
    if (first) {
      first = false
    } else {
      buffer_add(buf, " ")
    }
    buffer_add(buf, printObj.call(obj.car))
    obj = obj.cdr
  }
  if (obj.tag == "nil") {
    return arrstr($array("(", buffer_string(buf), ")"))
  }
  return arrstr($array("(", buffer_string(buf), " . ", printObj.call(obj), ")"))
}

var findVar = function(sym, env) {
  while (env.tag == "cons") {
    var alist = env.car
    while (alist.tag == "cons") {
      if (alist.car.car == sym) {
        return alist.car
      }
      alist = alist.cdr
    }
    env = env.cdr
  }
  return kNil
}

var g_env = makeCons(kNil, kNil)

var addToEnv = function(sym, val, env) {
  env.car = makeCons(makeCons(sym, val), env.car)
}

var apply = $new(null)
var evlis = $new(null)
var eval = $new(null)
var loop = $new(null)
eval.call = function(obj, env) {
  if (obj.tag == "nil" || obj.tag == "num" || obj.tag == "error") {
    return obj
  } else if (obj.tag == "sym") {
    var bind = findVar(obj, env)
    if (bind == kNil) {
      return makeError(arrstr($array(obj.data, " has no value")))
    }
    return bind.cdr
  }

  var op = safeCar(obj)
  var args = safeCdr(obj)
  if (op == sym_quote) {
    return safeCar(args)
  } else if (op == sym_if) {
    var c = eval.call(safeCar(args), env)
    if (c.tag == "error") {
      return c
    } else if (c == kNil) {
      return eval.call(safeCar(safeCdr(safeCdr(args))), env)
    }
    return eval.call(safeCar(safeCdr(args)), env)
  } else if (op == sym_lambda) {
    return makeExpr(args, env)
  } else if (op == sym_defun) {
    var expr = makeExpr(safeCdr(args), env)
    var sym = safeCar(args)
    addToEnv(sym, expr, g_env)
    return sym
  } else if (op == sym_setq) {
    var val = eval.call(safeCar(safeCdr(args)), env)
    if (val.tag == "error") {
      return val
    }
    var sym = safeCar(args)
    var bind = findVar(sym, env)
    if (bind == kNil) {
      addToEnv(sym, val, g_env)
    } else {
      bind.cdr = val
    }
    return val
  } else if (op == sym_loop) {
    return loop.call(args, env)
  } else if (op == sym_return) {
    loop_val.value = eval.call(safeCar(args), env)
    return makeError("")
  }
  return apply.call(eval.call(op, env), evlis.call(args, env), env)
}

evlis.call = function(lst, env) {
  var ret = kNil
  while (lst.tag == "cons") {
    var elm = eval.call(lst.car, env)
    if (elm.tag == "error") {
      return elm
    }
    ret = makeCons(elm, ret)
    lst = lst.cdr
  }
  return nreverse(ret)
}

var progn = function(body, env) {
  var ret = kNil
  while (body.tag == "cons") {
    ret = eval.call(body.car, env)
    if (ret.tag == "error") {
      return ret
    }
    body = body.cdr
  }
  return ret
}

loop.call = function(body, env) {
  while (true) {
    var ret = progn(body, env)
    if (ret.tag == "error") {
      if (ret.data == "") {
        return loop_val.value
      }
      return ret
    }
  }
}

apply.call = function(fn, args, env) {
  if (fn.tag == "error") {
    reutrn fn
  } else if (args.tag == "error") {
    return args
  } else if (fn.tag == "subr") {
    return fn.data(args)
  } else if (fn.tag == "expr") {
    return progn(fn.body, makeCons(pairlis(fn.args, args), fn.env))
  }
  return makeError(arrstr($array(printObj.call(fn), " is not function")))
}

var subrCar = function(args) {
  return safeCar(safeCar(args))
}

var subrCdr = function(args) {
  return safeCdr(safeCar(args))
}

var subrCons = function(args) {
  return makeCons(safeCar(args), safeCar(safeCdr(args)))
}

var subrEq = function(args) {
  var x = safeCar(args)
  var y = safeCar(safeCdr(args))
  if (x.tag == "num" && y.tag == "num") {
    if (x.data == y.data) {
      return sym_t
    }
    return kNil
  }
  if (x == y) {
    return sym_t
  }
  return kNil
}

var subrAtom = function(args) {
  if (safeCar(args).tag == "cons") {
    return kNil
  }
  return sym_t
}

var subrNumberp = function(args) {
  if (safeCar(args).tag == "num") {
    return sym_t
  }
  return kNil
}

var subrSymbolp = function(args) {
  if (safeCar(args).tag == "sym") {
    return sym_t
  }
  return kNil
}

var subrAddOrMul = function(fn, init_val) {
  return function(args) {
    var ret = init_val
    while (args.tag == "cons") {
      if (args.car.tag != "num") {
        return makeError("wrong type")
      }
      ret = fn(ret, args.car.data)
      args = args.cdr
    }
    return makeNum(ret)
  }
}
var subrAdd = subrAddOrMul(function(x, y) x + y, 0)
var subrMul = subrAddOrMul(function(x, y) x * y, 1)

var subrSubOrDivOrMod = function(fn) {
  return function(args) {
    var x = safeCar(args)
    var y = safeCar(safeCdr(args))
    if (x.tag != "num" || y.tag != "num") {
      return makeError("wrong type")
    }
    return makeNum(fn(x.data, y.data))
  }
}
var subrSub = subrSubOrDivOrMod(function(x, y) x - y)
var subrDiv = subrSubOrDivOrMod(function(x, y) x / y)
var subrMod = subrSubOrDivOrMod(function(x, y) x % y)

addToEnv(makeSym("car"), makeSubr(subrCar), g_env)
addToEnv(makeSym("cdr"), makeSubr(subrCdr), g_env)
addToEnv(makeSym("cons"), makeSubr(subrCons), g_env)
addToEnv(makeSym("eq"), makeSubr(subrEq), g_env)
addToEnv(makeSym("atom"), makeSubr(subrAtom), g_env)
addToEnv(makeSym("numberp"), makeSubr(subrNumberp), g_env)
addToEnv(makeSym("symbolp"), makeSubr(subrSymbolp), g_env)
addToEnv(makeSym("+"), makeSubr(subrAdd), g_env)
addToEnv(makeSym("*"), makeSubr(subrMul), g_env)
addToEnv(makeSym("-"), makeSubr(subrSub), g_env)
addToEnv(makeSym("/"), makeSubr(subrDiv), g_env)
addToEnv(makeSym("mod"), makeSubr(subrMod), g_env)
addToEnv(sym_t, sym_t, g_env)

var readline = function() {
  var stdin = file_stdin()
  var buf = buffer_new()
  try {
    while (true) {
      var c = file_read_char(stdin)
      if (c == 0x0a) {
        break;
      }
      buffer_add_char(buf, c)
    }
  } catch e {
    return false
  }
  return buffer_string(buf)
}

var input = ""
$print("> ")
while ($istrue(input = readline())) {
  $print(printObj.call(eval.call(read.call(input)[0], g_env)))
  $print("\n> ")
}