Logo Search packages:      
Sourcecode: djvulibre version File versions  Download package

minilisp.cpp

/* -*- 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, Version 2. 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 "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));
#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("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: 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_number(abs(miniexp_to_int(argv[0])));
}

DEFUN("+",plus,0,9999) {
  int s = 0;
  for (int i=0; i<argc; i++)
    {
      if (!miniexp_numberp(argv[i]))
        error("+: number expected");
      s += miniexp_to_int(argv[i]);
    }
  return miniexp_number(s);
}

DEFUN("*",times,0,9999) {
  int s = 1;
  for (int i=0; i<argc; i++)
    {
      if (!miniexp_numberp(argv[i]))
        error("*: number expected");
      s *= miniexp_to_int(argv[i]);
    }
  return miniexp_number(s);
}

DEFUN("-",minus,1,9999) {
  if (! miniexp_numberp(argv[0]))
    error("-: number expected");
  int i = 0;
  int s = 0;
  if (argc>1 && miniexp_numberp(argv[0]))
    s = miniexp_to_int(argv[i++]);
  while (i<argc && miniexp_numberp(argv[i]))
    s -= miniexp_to_int(argv[i++]);
  if (i < argc)
    error("-: number expected", argv[i]);
  return miniexp_number(s);
}

DEFUN("/",div,1,9999) {
  if (! miniexp_numberp(argv[0]))
    error("/: number expected");
  int i = 0;
  int s = 1;
  if (argc>1 && miniexp_numberp(argv[0]))
    s = miniexp_to_int(argv[i++]);
  while (i<argc && miniexp_numberp(argv[i]) && miniexp_to_int(argv[i]))
    s /= miniexp_to_int(argv[i++]);
  if (i < argc)
    if (miniexp_numberp(argv[i]))
      error("/: division by zero", argv[i]);
    else
      error("/: number expected", argv[i]);
  return miniexp_number(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));
  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_numberp(a) && miniexp_numberp(b))
    {
      int na = miniexp_to_int(a);
      int nb = miniexp_to_int(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("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: number expected", argv[1]);
  int f = miniexp_to_int(argv[1]);
  f = (l < f) ? l : (f < 0) ? l : f;
  s += f;
  l -= f;
  if (argc>2)
    {
      if (! miniexp_numberp(argv[2]))
        error("substr: number expected", argv[2]);
      f = miniexp_to_int(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<argc; 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<argc; 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<argc; 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);
}

static struct {
  char *b;
  int l;
  int m;
} pname_data;

static int
pname_puts(const char *s)
{
  int x = strlen(s);
  if (pname_data.l + x >= pname_data.m)
    {
      int nm = pname_data.l + x + 256;
      char *nb = new char[nm+1];
      memcpy(nb, pname_data.b, pname_data.l);
      delete [] pname_data.b;
      pname_data.m = nm;
      pname_data.b = nb;
    }
  strcpy(pname_data.b + pname_data.l, s);
  pname_data.l += x;
  return x;
}

static miniexp_t 
pname(miniexp_t p)
{
  minivar_t r;
  int (*saved)(const char*) = minilisp_puts;
  pname_data.b = 0;
  pname_data.m = pname_data.l = 0;
  try 
    {
      minilisp_puts = pname_puts;
      miniexp_prin(p);
      minilisp_puts = saved;
      r = miniexp_string(pname_data.b);
      delete [] pname_data.b;
      pname_data.b = 0;
    }
  catch(...)
    {
      minilisp_puts = saved;
      delete [] pname_data.b;
      pname_data.b = 0;
    }
  return r;
}

DEFUN("pname",pname,1,0) {
  return pname(argv[0]);
}

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))
    return ((callable_t*)obj)->call(argv[1], env, true);
      error("apply: cannot apply this object", argv[0]);
}

DEFUN("error",error,1,1) {
  if (!miniexp_stringp(argv[0]))
    error("error: string expected", argv[0]);
  error(miniexp_to_str(argv[0]), (argc>1) ? argv[1] : 0);
}

DEFUN("display",display,0,9999) {
  for (int i=0; i<argc; i++)
    {
      minivar_t v = argv[i];
      if (! miniexp_stringp(v)) v = pname(v);
      minilisp_puts(miniexp_to_str(v));
    }
  return 0;
}

DEFUN("string->symbol",string2symbol,1,0) {
  if (! miniexp_stringp(argv[0]))
    error("string->symbol: string expected",argv[0]);
  return miniexp_symbol(miniexp_to_str(argv[0]));
}

DEFUN("symbol->string",symbol2string,1,0) {
  if (! miniexp_symbolp(argv[0]))
    error("symbol->string: symbol expected",argv[0]);
  return miniexp_string(miniexp_to_name(argv[0]));
}


/* ------------ toplevel */

void
toplevel(FILE *inp, FILE *out, bool print)
{
  minilisp_set_output(out);
  minilisp_set_input(inp);
  for(;;)
    {
      minivar_t s = miniexp_read();
      if (s == miniexp_dummy)
        {
          if (feof(inp))
            break;
          printf("ERROR: while parsing\n");
          continue;
        }
      try
        {
          break_request = false;
          minivar_t v = evaluate(s, globalenv);
          if (print)
            {
              printf("= ");
              miniexp_print(v);
            }
        }
      catch(...)
        {
        }
    }
}

miniexp_t 
parse_comment(void)
{
  int c = minilisp_getc();
  while (c != EOF && c != '\n')
    c = minilisp_getc();
  return miniexp_nil;
}

miniexp_t 
parse_quote(void)
{
  minivar_t l = miniexp_read();
  l = miniexp_cons(s_quote, miniexp_cons(l, miniexp_nil));
  return miniexp_cons(l,miniexp_nil);
}

static void 
sighandler(int signo)
{
  break_request = true;
  signal(signo, sighandler);
}

int 
main()
{
  // minilisp_debug(1);
  minilisp_macrochar_parser[(int)';'] = parse_comment;  
  minilisp_macrochar_parser[(int)'\''] = parse_quote;  
  FILE *f = fopen("minilisp.in","r");
  if (f)
    {
      toplevel(f, stdout, false);
      fclose(f);
    }
  else
    printf("WARNING: cannot find 'minilisp.in'\n");
  signal(SIGINT, sighandler);
  toplevel(stdin, stdout, true);
  minilisp_finish();
  return 0;
}

Generated by  Doxygen 1.6.0   Back to index