/* -*- C++ -*-

// -------------------------------------------------------------------

// MiniLisp - Very small lisp interpreter to demonstrate MiniExp.

// Copyright (c) 2005  Leon Bottou

//

// This software is subject to, and may be distributed under, the

// GNU General Public License, either Version 2 of the license,

// or (at your option) any later version. The license should have

// accompanied the software or you may obtain a copy of the license

// from the Free Software Foundation at http://www.fsf.org .

//

// This program is distributed in the hope that it will be useful,

// but WITHOUT ANY WARRANTY; without even the implied warranty of

// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

// GNU General Public License for more details.

// -------------------------------------------------------------------

*/

#include <stdlib.h>

#include <stdio.h>

#include <string.h>

#include <signal.h>

#include <ctype.h>

#include <math.h>

#include "miniexp.h"

#define CAT(a,b) __CAT(a,b)

#define __CAT(a,b) a ## b

miniexp_t s_quote = miniexp_symbol("quote");

miniexp_t s_true = miniexp_symbol("t");

/* ------------ error */

#ifdef __GNUC__

void error(const char *msg, miniexp_t v=0) __attribute__ ((noreturn));

#else

void error(const char *msg, miniexp_t v=0);

#endif

void

error(const char *msg, miniexp_t v)

{

  if (msg)

    printf("ERROR: %s", msg);

  else

    printf("BREAK");

  if (v)

    {

      printf(": ");

      miniexp_prin(v);

    }

  printf("\n");

  throw 0;

}

/* ------------ environment */

miniexp_t

lookup(miniexp_t var, miniexp_t env)

{

  while (miniexp_consp(env))

    {

      miniexp_t a = miniexp_car(env);

      if (miniexp_car(a) == var)

	return a;

      env = miniexp_cdr(env);

    }

  return 0;

}

minivar_t globalenv;

void

defvar(miniexp_t s, miniexp_t w = 0)

{

  minivar_t v;

  if (! globalenv)

    {

      minivar_t a = miniexp_cons(s_true, s_true);

      globalenv = miniexp_cons(a, 0);

    }

  if (! miniexp_symbolp(s))

    error("defvar: not a symbol", s);

  miniexp_t a = lookup(s, globalenv);

  if (a && w)

    {

      printf("WARNING: redefining '%s\n", miniexp_to_name(s));

      miniexp_rplacd(a, w);

    }

  else

    {

      v = miniexp_cons(s, w);

      v = miniexp_cons(v, miniexp_cdr(globalenv));

      miniexp_rplacd(globalenv, v);

    }

}

/* ------------ evaluate */

static bool break_request = false;

struct callable_t : public miniobj_t

{

  MINIOBJ_DECLARE(callable_t,miniobj_t,"callable");

  virtual miniexp_t call(miniexp_t args, miniexp_t env,

			 bool apply=false) = 0;

};

MINIOBJ_IMPLEMENT(callable_t,miniobj_t,"callable");

miniexp_t

evaluate(miniexp_t expr, miniexp_t env)

{

  if (miniexp_symbolp(expr))

    {

      miniexp_t a = lookup(expr,env);

      if (! a)

	error ("eval: undefined variable", expr);

      return miniexp_cdr(a);

    }

  else if (miniexp_consp(expr))

    {

      miniexp_t s = miniexp_car(expr);

      minivar_t xs = evaluate(s, env);

      miniobj_t *obj = miniexp_to_obj(xs);

      if (break_request)

	error(0);

      if (obj && obj->isa(callable_t::classname))

	return ((callable_t*)obj)->call(miniexp_cdr(expr), env);

      error("apply: cannot apply this object", xs);

    }

  else

    return expr;

}

miniexp_t

evaluate_progn(miniexp_t exprs, miniexp_t env)

{

  minivar_t v;

  while (miniexp_consp(exprs))

    {

      v = evaluate(miniexp_car(exprs),env);

      exprs = miniexp_cdr(exprs);

    }

  if (exprs)

    v = evaluate(exprs,env);

  return v;

}

miniexp_t

evaluate_list(miniexp_t l, miniexp_t env)

{

  minivar_t v;

  minivar_t ll = 0;

  miniexp_t lp = ll;

  if (miniexp_consp(l))

    {

      v = evaluate(miniexp_car(l), env);

      lp = ll = miniexp_cons(v, 0);

      l = miniexp_cdr(l);

    }

  while (miniexp_consp(l))

    {

      v = evaluate(miniexp_car(l), env);

      miniexp_rplacd(lp, miniexp_cons(v, 0));

      lp = miniexp_cdr(lp);

      l = miniexp_cdr(l);

    }

  if (l)

    {

      v = evaluate(l, env);

      if (lp)

	miniexp_rplacd(lp, v);

      else

	ll = v;

    }

  return ll;

}

/* ------------ special forms */

class specialform_t : public callable_t

{

  typedef miniexp_t (*fptr_t)(miniexp_t, miniexp_t);

  fptr_t fptr;

public:

  specialform_t(const char *name, fptr_t fptr);

  MINIOBJ_DECLARE(specialform_t,callable_t,"specialform");

  virtual miniexp_t call(miniexp_t args, miniexp_t env, bool);

};

MINIOBJ_IMPLEMENT(specialform_t,callable_t,"specialform");

specialform_t::specialform_t(const char *name, fptr_t fptr)

  : fptr(fptr)

{

  miniexp_t s = miniexp_symbol(name);

  minivar_t v = miniexp_object(this);

  defvar(s, v);

}

miniexp_t

specialform_t::call(miniexp_t args, miniexp_t env, bool)

{

  return (*fptr)(args, env);

}

#define DEFSPECIAL(s, n) \

miniexp_t CAT(f_,n)(miniexp_t, miniexp_t);\

specialform_t *CAT(p_,n) = new specialform_t(s, CAT(f_,n));\

miniexp_t CAT(f_,n)(miniexp_t expr, miniexp_t env)

/* ------------ primitives */

class primitive_t : public callable_t

{

  typedef miniexp_t (*fptr_t)(int, miniexp_t*, miniexp_t);

  fptr_t fptr;

  const int args;

  const int optargs;

public:

  primitive_t(const char *name, fptr_t fptr, int a, int o);

  MINIOBJ_DECLARE(primitive_t,callable_t,"primitive");

  virtual miniexp_t call(miniexp_t args, miniexp_t env, bool);

};

MINIOBJ_IMPLEMENT(primitive_t,callable_t,"primitive");

primitive_t::primitive_t(const char *n, fptr_t f, int a, int o)

  : fptr(f), args(a), optargs(o)

{

  miniexp_t s = miniexp_symbol(n);

  minivar_t v = miniexp_object(this);

  defvar(s, v);

}

miniexp_t

primitive_t::call(miniexp_t args, miniexp_t env, bool apply)

{

  int argc = miniexp_length(args);

  if (argc < this->args)

    error("apply(primitive): not enough arguments");

  if (argc > this->args + this->optargs)

    error("apply(primitive): too many arguments");

  minivar_t xargs = apply ? args : evaluate_list(args, env);

  miniexp_t *argv = new miniexp_t[argc];

  miniexp_t a = xargs;

  argc = 0;

  while (miniexp_consp(a))

    {

      argv[argc++] = miniexp_car(a);

      a = miniexp_cdr(a);

    }

  minivar_t v;

  try

    { v = (*fptr)(argc, argv, env); }

  catch(...)

    { delete [] argv; throw; }

  delete [] argv;

  return v;

}

#define DEFUN(s, n,a,o) \

miniexp_t CAT(f_,n)(int argc, miniexp_t *argv, miniexp_t env);\

primitive_t *CAT(p_,n) = new primitive_t(s, CAT(f_,n), a, o);\

miniexp_t CAT(f_,n)(int argc, miniexp_t *argv, miniexp_t env)

/* ------- functions */

class function_t : public callable_t

{

protected:

  miniexp_t args;

  miniexp_t body;

  miniexp_t env;

  static void check_args(miniexp_t a);

  static void match_args(miniexp_t a, miniexp_t v, miniexp_t &env;;

public:

  function_t(miniexp_t, miniexp_t, miniexp_t);

  MINIOBJ_DECLARE(function_t,callable_t,"function");

  virtual miniexp_t call(miniexp_t args, miniexp_t env, bool);

  virtual void mark(minilisp_mark_t action);

  virtual miniexp_t funcdef(miniexp_t name=0);

};

MINIOBJ_IMPLEMENT(function_t,callable_t,"function");

void

function_t::check_args(miniexp_t a)

{

 again:

  if (miniexp_symbolp(a) || !a)

    return;

  if (miniexp_listp(a))

    {

      check_args(miniexp_car(a));

      a = miniexp_cdr(a);

      goto again;

    }

  error("lambda: illegal formal arguments");

}

void

function_t::match_args(miniexp_t a, miniexp_t v, miniexp_t &env)

{

 again:

  if (miniexp_symbolp(a))

    {

      minivar_t x = miniexp_cons(a,v);

      env = miniexp_cons(x, env);

      return;

    }

  if (miniexp_consp(a))

    {

      if (! miniexp_consp(v))

	error("apply: not enough arguments", a);

      match_args(miniexp_car(a), miniexp_car(v), env);

      a = miniexp_cdr(a);

      v = miniexp_cdr(v);

      goto again;

    }

  if (v)

    error("apply: too many arguments", v);

}

function_t::function_t(miniexp_t a, miniexp_t b, miniexp_t e)

  : args(a), body(b), env(e)

{

  check_args(a);

}

miniexp_t

function_t::call(miniexp_t args, miniexp_t env, bool apply)

{

  minivar_t xargs = apply ? args : evaluate_list(args, env);

  minivar_t nenv = this->env;

  match_args(this->args, xargs, nenv);

  return evaluate_progn(body, nenv);

}

void

function_t::mark(minilisp_mark_t action)

{

  action(&args);

  action(&body);

  action(&env;;

}

miniexp_t

function_t::funcdef(miniexp_t name)

{

  if (name)

    {

      miniexp_t d = miniexp_symbol("defun");

      miniexp_t a = miniexp_cons(name, args);

      return miniexp_cons(d, miniexp_cons(a, body));

    }

  else

    {

      miniexp_t d = miniexp_symbol("lambda");

      return miniexp_cons(d,miniexp_cons(args,body));

    }

}

/* ------- macros */

class macrofunction_t : public function_t

{

public:

  macrofunction_t(miniexp_t a, miniexp_t b, miniexp_t e);

  MINIOBJ_DECLARE(macrofunction_t,function_t,"macrofunction");

  virtual miniexp_t call(miniexp_t args, miniexp_t env, bool);

  virtual miniexp_t funcdef(miniexp_t name=0);

};

MINIOBJ_IMPLEMENT(macrofunction_t,function_t,"macrofunction");

macrofunction_t::macrofunction_t(miniexp_t a, miniexp_t b, miniexp_t e)

  : function_t(a,b,e)

{

}

miniexp_t

macrofunction_t::call(miniexp_t args, miniexp_t env, bool)

{

  minivar_t nenv = this->env;

  match_args(this->args, args, nenv);

  minivar_t e = evaluate_progn(body, nenv);

  return evaluate(e, env);

}

miniexp_t

macrofunction_t::funcdef(miniexp_t name)

{

  if (name)

    {

      miniexp_t d = miniexp_symbol("defmacro");

      miniexp_t a = miniexp_cons(name, args);

      return miniexp_cons(d, miniexp_cons(a, body));

    }

  else

    {

      miniexp_t d = miniexp_symbol("mlambda");

      return miniexp_cons(d, miniexp_cons(args, body));

    }

}

/* ------------ define special forms */

DEFSPECIAL("progn",progn)

{

  return evaluate_progn(expr, env);

}

DEFSPECIAL("list",list)

{

  return evaluate_list(expr, env);

}

DEFSPECIAL("if",if)

{

  if (evaluate(miniexp_car(expr), env))

    return evaluate(miniexp_cadr(expr), env);

  return evaluate_progn(miniexp_cddr(expr), env);

}

DEFSPECIAL("setq",setq)

{

  if (miniexp_cddr(expr) || !miniexp_consp(miniexp_cdr(expr)))

    error("setq: syntax error");

  miniexp_t a = lookup(miniexp_car(expr),env);

  if (! a)

    error ("setq: undefined variable", miniexp_car(expr));

  minivar_t v = evaluate(miniexp_cadr(expr), env);

  miniexp_rplacd(a,v);

  return v;

}

DEFSPECIAL("defvar",defvar)

{

  if (miniexp_cddr(expr))

    error("defvar: syntax error");

  minivar_t v = evaluate(miniexp_cadr(expr), env);

  defvar(miniexp_car(expr), v);

  return miniexp_car(expr);

}

DEFSPECIAL("let",let)

{

  miniexp_t v = miniexp_car(expr);

  minivar_t nenv = env;

  minivar_t p, w;

  while (miniexp_consp(v))

    {

      miniexp_t a = miniexp_car(v);

      v = miniexp_cdr(v);

      if (! (miniexp_consp(a) &&

	     miniexp_symbolp(miniexp_car(a)) &&

	     !miniexp_cddr(a)))

	error("let: syntax error");

      w = evaluate(miniexp_cadr(a), env);

      p = miniexp_cons(miniexp_car(a), w);

      nenv = miniexp_cons(p, nenv);

    }

  return evaluate_progn(miniexp_cdr(expr), nenv);

}

DEFSPECIAL("letrec",letrec)

{

  miniexp_t v = miniexp_car(expr);

  minivar_t nenv = env;

  minivar_t p, w;

  while (miniexp_consp(v))

    {

      miniexp_t a = miniexp_car(v);

      v = miniexp_cdr(v);

      if (! (miniexp_consp(a) &&

	     miniexp_symbolp(miniexp_car(a)) &&

	     !miniexp_cddr(a)))

	error("let: syntax error");

      minivar_t p = miniexp_cons(miniexp_car(a), 0);

      nenv = miniexp_cons(p, nenv);

    }

  v = miniexp_car(expr);

  while (miniexp_consp(v))

    {

      miniexp_t a = miniexp_car(v);

      v = miniexp_cdr(v);

      w = evaluate(miniexp_cadr(a), nenv);

      p = lookup(miniexp_car(a), nenv);

      miniexp_rplacd(p,w);

    }

  return evaluate_progn(miniexp_cdr(expr), nenv);

}

DEFSPECIAL("lambda",lambda)

{

  miniexp_t args = miniexp_car(expr);

  miniexp_t body = miniexp_cdr(expr);

  function_t *f = new function_t(args, body, env);

  return miniexp_object(f);

}

DEFSPECIAL("mlambda",mlambda)

{

  miniexp_t args = miniexp_car(expr);

  miniexp_t body = miniexp_cdr(expr);

  function_t *f = new macrofunction_t(args, body, env);

  return miniexp_object(f);

}

DEFSPECIAL("quote",quote)

{

  if (miniexp_cdr(expr))

    error("quote: syntax error");

  return miniexp_car(expr);

}

DEFSPECIAL("while",while)

{

  if (! miniexp_consp(expr))

    error("while: syntax error");

  minivar_t v;

  while (evaluate(miniexp_car(expr), env))

    v = evaluate_progn(miniexp_cdr(expr), env);

  return v;

}

/* ------------ define primitive */

DEFUN("nullp",nullp,1,0) {

  return (!argv[0]) ? s_true : 0;

}

DEFUN("listp",listp,1,0) {

  return miniexp_listp(argv[0]) ? s_true : 0;

}

DEFUN("consp",consp,1,0) {

  return miniexp_consp(argv[0]) ? s_true : 0;

}

DEFUN("numberp",numberp,1,0) {

  return miniexp_numberp(argv[0]) ? s_true : 0;

}

DEFUN("doublep",doublep,1,0) {

  return miniexp_doublep(argv[0]) ? s_true : 0;

}

DEFUN("objectp",objectp,1,0) {

  return miniexp_objectp(argv[0]) ? s_true : 0;

}

DEFUN("symbolp",symbolp,1,0) {

  return miniexp_symbolp(argv[0]) ? s_true : 0;

}

DEFUN("stringp",stringp,1,0) {

  return miniexp_stringp(argv[0]) ? s_true : 0;

}

DEFUN("classof",classof,1,0) {

  return miniexp_classof(argv[0]);

}

DEFUN("car",car,1,0) {

  return miniexp_car(argv[0]);

}

DEFUN("cdr",cdr,1,0) {

  return miniexp_cdr(argv[0]);

}

DEFUN("caar",caar,1,0) {

  return miniexp_caar(argv[0]);

}

DEFUN("cadr",cadr,1,0) {

  return miniexp_cadr(argv[0]);

}

DEFUN("cdar",cdar,1,0) {

  return miniexp_cdar(argv[0]);

}

DEFUN("cddr",cddr,1,0) {

  return miniexp_cddr(argv[0]);

}

DEFUN("length",length,1,0) {

  return miniexp_number(miniexp_length(argv[0]));

}

DEFUN("reverse",reverse,1,0) {

  return miniexp_reverse(argv[0]);

}

DEFUN("cons",cons,2,0) {

  return miniexp_cons(argv[0],argv[1]);

}

DEFUN("nth",nth,2,0) {

  if (! miniexp_numberp(argv[0]))

    error("nth: integer number expected");

  return miniexp_nth(miniexp_to_int(argv[0]), argv[1]);

}

DEFUN("rplaca",rplaca,2,0) {

  return miniexp_rplaca(argv[0],argv[1]);

}

DEFUN("rplacd",rplacd,2,0) {

  return miniexp_rplacd(argv[0],argv[1]);

}

DEFUN("abs",abs,1,0) {

  return miniexp_double(fabs(miniexp_to_double(argv[0])));

}

DEFUN("+",plus,0,9999) {

  double s = 0;

  for (int i=0; i

    {

      if (!miniexp_doublep(argv[i]))

	error("+: number expected");

      s += miniexp_to_double(argv[i]);

    }

  return miniexp_double(s);

}

DEFUN("*",times,0,9999) {

  double s = 1;

  for (int i=0; i

    {

      if (!miniexp_doublep(argv[i]))

	error("*: number expected");

      s *= miniexp_to_double(argv[i]);

    }

  return miniexp_double(s);

}

DEFUN("-",minus,1,9999) {

  if (! miniexp_doublep(argv[0]))

    error("-: number expected");

  int i = 0;

  double s = 0;

  if (argc>1 && miniexp_doublep(argv[0]))

    s = miniexp_to_double(argv[i++]);

  while (i

    s -= miniexp_to_double(argv[i++]);

  if (i < argc)

    error("-: number expected", argv[i]);

  return miniexp_double(s);

}

DEFUN("/",div,1,9999) {

  if (! miniexp_doublep(argv[0]))

    error("/: number expected");

  int i = 0;

  double s = 1;

  if (argc>1 && miniexp_doublep(argv[0]))

    s = miniexp_to_double(argv[i++]);

  while (i

    s /= miniexp_to_double(argv[i++]);

  if (i < argc)

    if (miniexp_doublep(argv[i]))

      error("/: division by zero", argv[i]);

    else

      error("/: number expected", argv[i]);

  return miniexp_double(s);

}

DEFUN("==",equalequal,2,0) {

  return (argv[0]==argv[1]) ? s_true : 0;

}

static bool

equal(miniexp_t a, miniexp_t b)

{

  if (a == b)

    return true;

  else if (miniexp_consp(a) && miniexp_consp(b))

    return equal(miniexp_car(a),miniexp_car(b))

      &&   equal(miniexp_cdr(a),miniexp_cdr(b));

  else if (miniexp_stringp(a) && miniexp_stringp(b))

    return !strcmp(miniexp_to_str(a), miniexp_to_str(b));

  else if (miniexp_doublep(a) && miniexp_doublep(b))

    return miniexp_to_double(a) == miniexp_to_double(b);

  return false;

}

DEFUN("=",equal,2,0) {

  return equal(argv[0],argv[1]) ? s_true : 0;

}

DEFUN("<>",notequal,2,0) {

  return !equal(argv[0],argv[1]) ? s_true : 0;

}

static int

compare(miniexp_t a, miniexp_t b)

{

  if (miniexp_doublep(a) && miniexp_doublep(b))

    {

      double na = miniexp_to_double(a);

      double nb = miniexp_to_double(b);

      if (na < nb)

	return -1;

      else if (na > nb)

	return 1;

      return 0;

    }

  else if (miniexp_stringp(a) && miniexp_stringp(b))

    {

      const char *sa = miniexp_to_str(a);

      const char *sb = miniexp_to_str(b);

      return strcmp(sa, sb);

    }

  else

    error("compare: cannot rank these arguments");

}

DEFUN("<=",cmple,2,0) {

  return (compare(argv[0],argv[1])<=0) ? s_true : 0;

}

DEFUN("<",cmplt,2,0) {

  return (compare(argv[0],argv[1])<0) ? s_true : 0;

}

DEFUN(">=",cmpge,2,0) {

  return (compare(argv[0],argv[1])>=0) ? s_true : 0;

}

DEFUN(">",cmpgt,2,0) {

  return (compare(argv[0],argv[1])>0) ? s_true : 0;

}

DEFUN("floor",floor,1,0) {

  if (! miniexp_doublep(argv[0]))

    error("-: number expected");

  return miniexp_double(floor(miniexp_to_double(argv[0])));

}

DEFUN("ceil",ceil,1,0) {

  if (! miniexp_doublep(argv[0]))

    error("-: number expected");

  return miniexp_double(ceil(miniexp_to_double(argv[0])));

}

DEFUN("strlen",strlen,1,1) {

  if (! miniexp_stringp(argv[0]))

    error("strlen: string expected", argv[0]);

  const char *s = miniexp_to_str(argv[0]);

  return miniexp_number(strlen(s));

}

DEFUN("substr",substr,2,1) {

  if (! miniexp_stringp(argv[0]))

    error("substr: string expected", argv[0]);

  const char *s = miniexp_to_str(argv[0]);

  int l = strlen(s);

  if (! miniexp_numberp(argv[1]))

    error("substr: integer number expected", argv[1]);

  int f = miniexp_to_double(argv[1]);

  f = (l < f) ? l : (f < 0) ? l : f;

  s += f;

  l -= f;

  if (argc>2)

    {

      if (! miniexp_numberp(argv[2]))

	error("substr: integer number expected", argv[2]);

      f = miniexp_to_double(argv[2]);

      l = (f > l) ? l : (f < 0) ? 0 : f;

    }

  return miniexp_substring(s,l);

}

DEFUN("concat",concat,0,9999) {

  minivar_t l = 0;

  for (int i=0; i

    if (miniexp_stringp(argv[i]))

      l = miniexp_cons(argv[i],l);

    else

      error("concat: string expected", argv[i]);

  l = miniexp_reverse(l);

  return miniexp_concat(l);

}

DEFUN("prin",prin,1,9999) {

  minivar_t v;

  v = miniexp_prin(argv[0]);

  for (int i=1; i

    {

      minilisp_puts(" ");

      v = miniexp_prin(argv[i]);

    }

  return v;

}

DEFUN("print",print,1,9999) {

  minivar_t v;

  v = miniexp_prin(argv[0]);

  for (int i=1; i

    {

      minilisp_puts(" ");

      v = miniexp_prin(argv[i]);

    }

  minilisp_puts("\n");

  return v;

}

DEFUN("pprint",pprint,1,1) {

  int w = 72;

  if (argc>1)

    {

      if (! miniexp_numberp(argv[1]))

	error("pprint: second argument must be number");

      w = miniexp_to_int(argv[1]);

    }

  return miniexp_pprint(argv[0], w);

}

DEFUN("pname",pname,1,1) {

  int w = 0;

  if (argc > 1)

    {

      if (! miniexp_numberp(argv[1]))

	error("pprint: second argument must be number");

      w = miniexp_to_int(argv[1]);

    }

  return miniexp_pname(argv[0],w);

}

DEFUN("gc",gc,0,0) {

  minilisp_gc();

  minilisp_info();

  return 0;

}

DEFUN("info",info,0,0) {

  minilisp_info();

  return 0;

}

DEFUN("funcdef",funcdef,1,1) {

  if (! miniexp_isa(argv[0], function_t::classname))

    error("funcdef: expecting function", argv[0]);

  if (argc>1 && ! miniexp_symbolp(argv[1]))

    error("funcdef: expecting symbol", argv[1]);

  function_t *f = (function_t*)miniexp_to_obj(argv[0]);

  return f->funcdef(argc>1 ? argv[1] : 0);

}

DEFUN("vardef",vardef,1,0) {

  miniexp_t a = lookup(argv[0],globalenv);

  if (! a)

    error("vardef: undefined global variable");

  return miniexp_cdr(a);

}

DEFUN("eval",eval,1,0) {

  return evaluate(argv[0],env);

}

DEFUN("apply",apply,2,0) {

  miniobj_t *obj = miniexp_to_obj(argv[0]);

  if (obj && obj->isa(callable_t::classname))